Index: LMDZ5/branches/LMDZ5_AR5/000-README =================================================================== --- LMDZ5/branches/LMDZ5_AR5/000-README (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/000-README (revision 1634) @@ -0,0 +1,20 @@ + +Logiciel LMDZ +------------- + +La documentation relative à LMDZ est accessible sur : +http://lmdz.lmd.jussieu.fr/documentation + +Les quides d'installation et utilisation de LMDZ sont accessibles sur : +http://lmdz.lmd.jussieu.fr/documentation/guides + +========================================================================== + +LMDZ software +------------- + +Documentation about the LMDZ software is available on the web at this address: +http://lmdz.lmd.jussieu.fr/documentation + +Practical installation and user guides are available here: +http://lmdz.lmd.jussieu.fr/documentation/guides Index: LMDZ5/branches/LMDZ5_AR5/DefLists/config.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/config.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/config.def (revision 1634) @@ -0,0 +1,1 @@ +link config.def_LMDZ5_AGCM Index: LMDZ5/branches/LMDZ5_AR5/DefLists/config.def_IPSLCM5B_AGCM =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/config.def_IPSLCM5B_AGCM (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/config.def_IPSLCM5B_AGCM (revision 1634) @@ -0,0 +1,130 @@ +############################################################################## +# PARAMETRES ET CLES DE CONFIGURATION LMDZ +############################################################################## +# D: Valeur par default +# +# Controle des sorties +#********************* +#ok_regdyn : y/n calcul/non des regymes dynamiques sur regions pre-definies +ok_regdyn=y +phys_out_filekeys= y n n n n +phys_out_filenames= histmth histday histhf histins histLES +phys_out_filelevels= 5 2 2 4 4 +phys_out_filetypes= ave(X) ave(X) ave(X) inst(X) inst(X) +phys_out_filetimesteps= _ecrit-mth_ 1day 6hr 3hr 6hr +### parametres pour hist*NMC.nc +#lev_histdayNMC: nombre de niveaux sur la verticale dans le fichier +# histdayNMC: 8 ou 17 +lev_histdayNMC=8 +### - ok_histNMC = y/n, y/n, y/n pour avoir les sorties NMC mensuelles, journalieres et haute frequence +ok_histNMC = y, n, n +# +#Couplage avec autres modules +#****************************** +#option de couplage pour ocean (D:force) +##type_ocean=couple +##version_ocean=nemo +#avec ou sans orchidee (D:n) +##VEGET=y +#type_run=AMIP, ENSP, clim (D:AMIP) +type_run=CLIM +## Soil Model ou non +soil_model=y +## Cycle diurne ou non +cycle_diurne=y + +#Code de transfert radiatif +#************************** +# ajout de ce flag pour activer/desactiver le rayonnement (MPL) +# 0 : pas de rayonnement. 1: on active le rayonnement (D=1) +iflag_radia=1 +## Nombre appels des routines de rayonnements ( par jour) +nbapp_rad=24 + +# Parametres "orbitaux/ ere geologique" +####################################### +#Parametres orbitaux +#excentricite +R_ecc=0.016715 +#equinoxe +R_peri=102.7 +#inclinaison +R_incl=23.441 +#constante solaire +solaire=1365.6537 +## Facteur additif pour l albedo +pmagic=0.00 +# +# Taux gaz a effet de serre +####################################### +#concentration des gaz (co2 ch4 n2o cfc11 cfc12) +# (D: 348. 1650. 306. 280. 484.) +co2_ppm=0.28472500E+03 +#RCO2=co2_ppm * 1.0e-06 * 44.011/28.97= 5.286789092164308E-04 +CH4_ppb=0.79097924E+03 +#RCH4=1.65E-06* 16.043/28.97= 9.137366240938903E-07 +N2O_ppb=0.27542506E+03 +#RN2O=306.E-09* 44.013/28.97= 4.648939592682085E-07 +CFC11_ppt=0. +#RCFC11=280.E-12* 137.3686/28.97= 1.327690990680013E-09 +CFC12_ppt=0. +#RCFC12=484.E-12* 120.9140/28.97= 2.020102726958923E-09 +# +# Parametres effets directs/indirects des "aerosols" +####################################### +### ok_ade=y/n flag Aerosol direct effect +ok_ade=y +### ok_aie=y/n flag Aerosol indirect effect +ok_aie=y +### aer_type = Aerosol variation type : actuel / preind / scenario / annuel +aer_type=preind +### type of coupled aerosol =1 (default) =2 => bc only =3 => pom only =4 => seasalt only =5 => dust only =6 => all aerosol +flag_aerosol=6 +### bl95_b0 = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +bl95_b0=1.7 +### bl95_b1 = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +bl95_b1=0.2 +# +# Parametre de lecture de l'ozone +####################################### +# Allowed values are 0, 1 and 2 +# 0: do not read an ozone climatology +# 1: read a single ozone climatology that will be used day and night +# 2: read two ozone climatologies, the average day and night climatology and the daylight climatology +read_climoz=2 +# +# Parametres simulateur COSP (CFMIP Observational Simulator Package) +####################################### +### ok_cosp=y/n flag simulateur COSP +ok_cosp=n +### freq_COSP = frequence d'appel de COSP en secondes +freq_COSP=10800. +### ok_mensuelCOSP=y/n sortir fichier mensuel COSP histmthCOSP.nc, =n pas de fichier histmthCOSP.nc +ok_mensuelCOSP=y +### ok_journeCOSP=y/n sortir fichier journalier histdayCOSP.nc, =n pas de fichier histdayCOSP.nc +ok_journeCOSP=y +### ok_hfCOSP=y/n, ecrire sorties haute frequence histhfCOSP.nc, =n pas de fichier histhfCOSP.nc +ok_hfCOSP=n +# +# Parametres simulateur ISCCP +####################################### +### ok_isccp=y/n flag simulateur ISCCP +ok_isccp=n +### freqin_isccp = frequence input en secondes du simulateur ISCCP +freq_ISCCP=10800. +### top_height = flag choix calcul nuages par le simulateur en utilisant +# - les donnees IR et/ou VIS et l algorithme ISCCP-D1 +# - top_height = 1 -> algo IR-VIS +# - top_height = 2 -> identique a 1, mais "ptop(ibox)=pfull(ilev)" +# - top_height = 3 -> algo IR +top_height = 1 +### overlap = Hypothese de Recouvrement (HR) utilisee pour le simulateur ISCCP +# - overlap=1 Max overlap +# - overlap=2 Random overlap +# - overlap=3 Max/Random overlap +overlap = 3 +# + +# Specifique aquaplanete +######################## +#qsol0=100. Index: LMDZ5/branches/LMDZ5_AR5/DefLists/config.def_LMDZ5_AGCM =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/config.def_LMDZ5_AGCM (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/config.def_LMDZ5_AGCM (revision 1634) @@ -0,0 +1,124 @@ +############################################################################## +# PARAMETRES ET CLES DE CONFIGURATION LMDZ +############################################################################## +# D: Valeur par default +# +# Controle des sorties +#********************* +OK_journe=y +OK_mensuel=y +ok_hf=y +OK_instan=n +ok_LES=n +#ok_regdyn : y/n calcul/non des regymes dynamiques sur regions pre-definies +ok_regdyn=y +# A transformer en la ligne ci-dessous quand ce sera compatible avec libIGCM +phys_out_filekeys= y y y n n +phys_out_filenames= histmth histday histhf histins histLES +phys_out_filelevels= 10 4 4 4 4 +phys_out_filetypes= ave(X) ave(X) ave(X) inst(X) inst(X) +phys_out_filetimesteps= 10day 1day 6hr 6hr 6hr + +# +#Couplage avec autres modules +#****************************** +#option de couplage pour ocean (D:force) +type_ocean=force +version_ocean=nemo +#avec ou sans orchidee (D:n) +VEGET=y +#type_run=AMIP, ENSP, clim (D:AMIP) +type_run=CLIM +## Soil Model ou non +soil_model=y + +#Code de transfert radiatif +#************************** +# ajout de ce flag pour activer/desactiver le rayonnement (MPL) +# 0 : pas de rayonnement. 1: on active le rayonnement (D=1) +iflag_radia=1 +## Nombre appels des routines de rayonnements ( par jour) +nbapp_rad=24 + +# Parametres "orbitaux/ ere geologique" +####################################### +#Parametres orbitaux +#excentricite +R_ecc=0.016715 +#equinoxe +R_peri=102.7 +#inclinaison +R_incl=23.441 +#constante solaire +solaire=1366.0896 +## Facteur additif pour l albedo +pmagic=0.008 +# +# Taux gaz a effet de serre +####################################### +#concentration des gaz (co2 ch4 n2o cfc11 cfc12) +# (D: 348. 1650. 306. 280. 484.) +co2_ppm=0.36886500E+03 +#RCO2=co2_ppm * 1.0e-06 * 44.011/28.97= 5.286789092164308E-04 +CH4_ppb=0.17510225E+04 +#RCH4=1.65E-06* 16.043/28.97= 9.137366240938903E-07 +N2O_ppb=0.31585000E+03 +#RN2O=306.E-09* 44.013/28.97= 4.648939592682085E-07 +CFC11_ppt=5.18015181E+01 +#RCFC11=280.E-12* 137.3686/28.97= 1.327690990680013E-09 +CFC12_ppt=0.99862742E+03 +#RCFC12=484.E-12* 120.9140/28.97= 2.020102726958923E-09 +# +# Parametres effets directs/indirects des "aerosols" +####################################### +### ok_ade=y/n flag Aerosol direct effect +ok_ade=y +### ok_aie=y/n flag Aerosol indirect effect +ok_aie=y +### aer_type = Aerosol variation type : actuel / preind / scenario / annuel +aer_type=actuel +### type of coupled aerosol =1 (default) =2 => bc only =3 => pom only =4 => seasalt only =5 => dust only =6 => all aerosol +flag_aerosol=6 +### bl95_b0 = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +bl95_b0=1.7 +### bl95_b1 = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +bl95_b1=0.2 +# +# Parametre de lecture de l'ozone +####################################### +# Allowed values are 0, 1 and 2 +# 0: do not read an ozone climatology +# 1: read a single ozone climatology that will be used day and night +# 2: read two ozone climatologies, the average day and night climatology and the daylight climatology +read_climoz=2 +# +# Parametres simulateur COSP (CFMIP Observational Simulator Package) +####################################### +### ok_cosp=y/n flag simulateur COSP +ok_cosp=n +### freq_COSP = frequence d'appel de COSP en secondes +freq_COSP=10800. +### ok_mensuelCOSP=y/n sortir fichier mensuel COSP histmthCOSP.nc, =n pas de fichier histmthCOSP.nc +ok_mensuelCOSP=y +### ok_journeCOSP=y/n sortir fichier journalier histdayCOSP.nc, =n pas de fichier histdayCOSP.nc +ok_journeCOSP=y +### ok_hfCOSP=y/n, ecrire sorties haute frequence histhfCOSP.nc, =n pas de fichier histhfCOSP.nc +ok_hfCOSP=n +# +# Parametres simulateur ISCCP +####################################### +### ok_isccp=y/n flag simulateur ISCCP +ok_isccp=n +### top_height = flag choix calcul nuages par le simulateur en utilisant +# - les donnees IR et/ou VIS et l algorithme ISCCP-D1 +# - top_height = 1 -> algo IR-VIS +# - top_height = 2 -> identique a 1, mais "ptop(ibox)=pfull(ilev)" +# - top_height = 3 -> algo IR +top_height = 1 +### overlap = Hypothese de Recouvrement (HR) utilisee pour le simulateur ISCCP +# - overlap=1 Max overlap +# - overlap=2 Random overlap +# - overlap=3 Max/Random overlap +overlap = 3 +# + Index: LMDZ5/branches/LMDZ5_AR5/DefLists/gcm.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/gcm.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/gcm.def (revision 1634) @@ -0,0 +1,62 @@ +## $Id: gcm.def 1403 2010-07-01 09:02:53Z fairhead $ +## nombre de pas par jour (multiple de iperiod) ( ici pour dt = 1 min ) +day_step=480 +## periode pour le pas Matsuno (en pas) +iperiod=5 +## periode de la dissipation (en pas) +idissip=5 +## choix de l'operateur de dissipation (star ou non star ) +lstardis=y +## nombre d'iterations de l'operateur de dissipation gradiv +nitergdiv=1 +## nombre d'iterations de l'operateur de dissipation nxgradrot +nitergrot=2 +## nombre d'iterations de l'operateur de dissipation divgrad +niterh=2 +## temps de dissipation des plus petites long.d ondes pour u,v (gradiv) +tetagdiv=5400. +## temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot) +tetagrot=5400. +## temps de dissipation des plus petites long.d ondes pour h ( divgrad) +tetatemp=5400. +## coefficient pour gamdissip +coefdis=0. +## choix du shema d'integration temporelle (Matsuno:y ou Matsuno-leapfrog:n) +purmats=n +## avec ou sans physique +## 0: pas de physique (e.g. en mode Shallow Water) +## 1: avec physique (e.g. physique phylmd) +## 2: avec rappel newtonien dans la dynamique +iflag_phys=1 +## avec ou sans fichiers de demarrage (start.nc, startphy.nc) ? +## (sans fichiers de demarrage, initialisation des champs par iniacademic +## dans la dynamique) +read_start=y +## periode de la physique (en pas dynamiques, n'a de sens que si iflag_phys=1) +iphysiq=10 +## Avec ou sans strato +ok_strato=y +# Couche eponge dans les couches de pression plus faible que 100 fois la pression de la derniere couche +iflag_top_bound=2 +# Coefficient pour la couche eponge (valeur derniere couche) +tau_top_bound=5.e-5 +## longitude en degres du centre du zoom +clon=0. +## latitude en degres du centre du zoom +clat=0. +## facteur de grossissement du zoom,selon longitude +grossismx=1.0 +## facteur de grossissement du zoom ,selon latitude +grossismy=1.0 +## Fonction f(y) hyperbolique si = .true. , sinon sinusoidale +fxyhypb=y +## extension en longitude de la zone du zoom ( fraction de la zone totale) +dzoomx=0.0 +## extension en latitude de la zone du zoom ( fraction de la zone totale) +dzoomy=0.0 +##raideur du zoom en X +taux=3. +##raideur du zoom en Y +tauy=3. +## Fonction f(y) avec y = Sin(latit.) si = .true. , sinon y = latit. +ysinus=y Index: LMDZ5/branches/LMDZ5_AR5/DefLists/guide.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/guide.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/guide.def (revision 1634) @@ -0,0 +1,37 @@ +ok_guide=y +# guidage sur niveaux modèle (y) ou standard +guide_modele=y +# inversion de l'ordre des niveaux verticaux +ok_invertp=y +ncep=y + ###################################### + #### guidage de u ##### + guide_u=y + ###################################### + #### guidage de v ##### + guide_v=y + ###################################### + #### guidage de T ##### + guide_T=y + ###################################### + #### guidage de P ##### + guide_P=n + ###################################### + #### guidage de Q (hr=y:hum.rel,n:hum.spec) ##### + guide_Q=n + guide_hr=n + ###################################### + ## guidage dans la couche limite + guide_BL=n + ###################################### +ini_anal=n +tau_min_u=0.04166667 +tau_max_u=0.125 +tau_min_v=0.04166667 +tau_max_v=0.125 +tau_min_T=0.04166667 +tau_max_T=10. +tau_min_Q=0.2 +tau_max_Q=10. +# gamma limité +gamma4=n Index: LMDZ5/branches/LMDZ5_AR5/DefLists/npCFMIP_param.data_amip =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/npCFMIP_param.data_amip (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/npCFMIP_param.data_amip (revision 1634) @@ -0,0 +1,1 @@ +120 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/npCFMIP_param.data_aqua =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/npCFMIP_param.data_aqua (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/npCFMIP_param.data_aqua (revision 1634) @@ -0,0 +1,1 @@ +73 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/offline.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/offline.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/offline.def (revision 1634) @@ -0,0 +1,12 @@ +# +# $Header$ +# +T +4 +T +-2. +48.1 +1 +T +6 +2 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/orchidee.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/orchidee.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/orchidee.def (revision 1634) @@ -0,0 +1,63 @@ +# +# +# Parameter file for LMDZ4OR_v2 configuration +# See comments : http://forge.ipsl.jussieu.fr/orchidee/ +# +STOMATE_OK_CO2=TRUE +# STOMATE_OK_STOMATE is not set +# STOMATE_OK_DGVM is not set +# STOMATE_WATCHOUT is not set +SECHIBA_restart_in=default +SECHIBA_rest_out=sechiba_rest.nc +SECHIBA_reset_time=y +# +OUTPUT_FILE=sechiba_out.nc +WRITE_STEP=2592000 +SECHIBA_HISTLEVEL=5 +# +SECHIBA_HISTFILE2 = FALSE +SECHIBA_OUTPUT_FILE2 = sechiba_out_2.nc +WRITE_STEP2 = 86400.0 +SECHIBA_HISTLEVEL2 = 1 +# +STOMATE_OUTPUT_FILE=stomate_history.nc +STOMATE_HIST_DT=10. +STOMATE_HISTLEVEL=0 +SECHIBA_DAY=0.0 +SECHIBA_ZCANOP=0.5 +DT_SLOW=86400. +# IMPOSE_VEG is not set +VEGETATION_FILE=carteveg5km.nc +# VEGETATION_FILE=pft_new.nc +DIFFUCO_LEAFCI=233. +CONDVEG_SNOWA=default +# IMPOSE_AZE is not set +SOILALB_FILE=soils_param.nc +SOILTYPE_FILE=soils_param.nc +ENERBIL_TSURF=280. +HYDROL_SNOW=0.0 +HYDROL_SNOWAGE=0.0 +HYDROL_SNOWICE=0.0 +HYDROL_SNOWICEAGE=0.0 +HYDROL_HDRY=1.0 +HYDROL_HUMR=1.0 +HYDROL_BQSB=default +HYDROL_GQSB=0.0 +HYDROL_DSG=0.0 +HYDROL_DSP=default +HYDROL_QSV=0.0 +HYDROL_OK_HDIFF=n +HYDROL_TAU_HDIFF=1800. +THERMOSOIL_TPRO=280. +RIVER_ROUTING=y +ROUTING_FILE=routing.nc +LAI_MAP=y +LAI_FILE=lai2D.nc +SECHIBA_QSINT=0.02 +ALB_BARE_MODEL = FALSE +PERCENT_THROUGHFALL_PFT = 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30. +RVEG_PFT = .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5 +CDRAG_FROM_GCM = .TRUE. +#LAND_USE=y +#VEGET_YEAR=0 +#VEGET_UPDATE=1Y Index: LMDZ5/branches/LMDZ5_AR5/DefLists/output.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/output.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/output.def (revision 1634) @@ -0,0 +1,794 @@ +######## Abderrahmane le 20 11 08 ######################## +# Niveaux de sorties et nom pour chaque variable dans les# +# fichiers histmth histday histhf histins histLES # +########################################################## +# Surface geop.height +flag_phis = 1, 1, 10, 1, 1 +name_phis = phis +# Grid area +flag_aire = 1, 1, 10, 1, 1 +name_aire = aire +# Surfac ter+lic +flag_contfracATM = 10, 1, 1, 10, 10 +name_contfracATM = contfracATM +# Surface terre OR +flag_contfracOR = 10, 1, 1, 10, 10 +name_contfracOR = contfracOR +# Grid area CONT +flag_aireTER = 10, 10, 1, 10, 10 +name_aireTER = aireTER +# Latent heat flux +flag_flat = 10, 1, 10, 10, 1 +name_flat = flat +# Sea Level Pressure +flag_slp = 1, 1, 1, 10, 1 +name_slp = slp +# Surface Temperature +flag_tsol = 1, 1, 1, 1, 1 +name_tsol = tsol +# Temperature 2m +flag_t2m = 1, 1, 1, 1, 1 +name_t2m = t2m +# Temperature min 2m +flag_t2m_min = 1, 1, 10, 10, 10 +name_t2m_min = t2m_min +# Temperature max 2m +flag_t2m_max = 1, 1, 10, 10, 10 +name_t2m_max = t2m_max +# Temperature ter lic oce sic at 2m +flag_t2m_ter = 10, 4, 10, 10, 10 +name_t2m_ter = t2m_ter +flag_t2m_lic = 10, 4, 10, 10, 10 +name_t2m_lic = t2m_lic +flag_t2m_oce = 10, 4, 10, 10, 10 +name_t2m_oce = t2m_oce +flag_t2m_sic = 10, 4, 10, 10, 10 +name_t2m_sic = t2m_sic +# 10-m wind speed +flag_wind10m = 1, 1, 1, 10, 10 +name_wind10m = wind10m +# 10-m wind speed max +flag_wind10max = 10, 1, 10, 10, 10 +name_wind10max = wind10max +# Sea-ice fraction +flag_sicf = 1, 1, 10, 10, 10 +name_sicf = sicf +# Specific humidity 2m +flag_q2m = 1, 1, 1, 1, 1 +name_q2m = q2m +# 10m zonal wind +flag_u10m = 1, 1, 1, 1, 1 +name_u10m = u10m +# 10m meridional wind +flag_v10m = 1, 1, 1, 1, 1 +name_v10m = v10m +# Surface Pressure +flag_psol = 1, 1, 1, 1, 1 +name_psol = psol +# Surface Air humidity +flag_qsurf = 1, 10, 10, 10, 10 +name_qsurf = qsurf +# 10m zonal wind (ter lic oce sic) +flag_u10m_ter = 10, 4, 10, 10, 10 +name_u10m_ter = u10m_ter +flag_u10m_lic = 10, 4, 10, 10, 10 +name_u10m_lic = u10m_lic +flag_u10m_oce = 10, 4, 10, 10, 10 +name_u10m_oce = u10m_oce +flag_u10m_sic = 10, 4, 10, 10, 10 +name_u10m_sic = u10m_sic +# 10m meridien wind (ter oce ice lic) +flag_v10m_ter = 10, 4, 10, 10, 10 +name_v10m_ter = v10m_ter +flag_v10m_lic = 10, 4, 10, 10, 10 +name_v10m_lic = v10m_lic +flag_v10m_oce = 10, 4, 10, 10, 10 +name_v10m_oce = v10m_oce +flag_v10m_sic = 10, 4, 10, 10, 10 +name_v10m_sic = v10m_sic +# Soil watter content +flag_qsol = 1, 10, 10, 1, 1 +name_qsol = qsol +# Number of dayrain(liq+sol) +flag_ndayrain = 1, 10, 10, 10, 10 +name_ndayrain = ndayrain +# Precip Totale liq+sol +flag_precip = 1, 1, 1, 1, 1 +name_precip = precip +# Large-scale Precip +flag_plul = 1, 1, 1, 1, 10 +name_plul = plul +# Convective Precip +flag_pluc = 1, 1, 1, 1, 10 +name_pluc = pluc +# Snow fall +flag_snow = 1, 1, 10, 1, 10 +name_snow = snow +# Evaporation +flag_evap = 1, 1, 10, 1, 10 +name_evap = evap +# Solar rad. at TOA +flag_tops = 1, 1, 10, 10, 10 +name_tops = tops +# CS Solar rad. at TOA +flag_tops0 = 1, 5, 10, 10, 10 +name_tops0 = tops0 +# IR rad. at TOA +flag_topl = 1, 1, 10, 1, 10 +name_topl = topl +# CR IR rad. at TOA +flag_topl0 = 1, 5, 10, 10, 10 +name_topl0 = topl0 +# SWup at TOA +flag_SWupTOA = 1, 4, 10, 10, 10 +name_SWupTOA = SWupTOA +# CR SWup at TOA +flag_SWupTOAclr = 1, 4, 10, 10, 10 +name_SWupTOAclr = SWupTOAclr +# SWdn at TOA +flag_SWdnTOA = 1, 4, 10, 10, 10 +name_SWdnTOA = SWdnTOA +# CR SWdn at TOA +flag_SWdnTOAclr = 1, 4, 10, 10, 10 +name_SWdnTOAclr = SWdnTOAclr +# SWup at 200hPa +flag_SWup200 = 1, 10, 10, 10, 10 +name_SWup200 = SWup200 +# CR SWup at 200hPa +flag_SWup200clr = 10, 1, 10, 10, 10 +name_SWup200clr = SWup200clr +# SWdn at 200hPa +flag_SWdn200 = 1, 10, 10, 10, 10 +name_SWdn200 = SWdn200 +# CR SWdn at 200hPa +flag_SWdn200clr = 10, 1, 10, 10, 10 +name_SWdn200clr = SWdn200clr +# LWup at 200mb +flag_LWup200 = 1, 10, 10, 10, 10 +name_LWup200 = LWup200 +# CR LWup at 200mb +flag_LWup200clr = 1, 10, 10, 10, 10 +name_LWup200clr = LWup200clr +# LWdn at 200mb +flag_LWdn200 = 1, 10, 10, 10, 10 +name_LWdn200 = LWdn200 +# CR LWdn at 200mb +flag_LWdn200clr = 1, 10, 10, 10, 10 +name_LWdn200clr = LWdn200clr +# Solar rad. at surf +flag_sols = 1, 1, 10, 1, 10 +name_sols = sols +# CR Solar rad. at surf +flag_sols0 = 1, 5, 10, 10, 10 +name_sols0 = sols0 +# IR rad. at surface +flag_soll = 1, 1, 10, 1, 10 +name_soll = soll +# CR IR rad. at surface +flag_soll0 = 1, 5, 10, 10, 10 +name_soll0 = soll0 +# Rayonnement au sol +flag_radsol = 1, 1, 10, 10, 10 +name_radsol = radsol +# SWup at surface +flag_SWupSFC = 1, 4, 10, 10, 10 +name_SWupSFC = SWupSFC +# CR SWup at surface +flag_SWupSFCclr = 1, 4, 10, 10, 10 +name_SWupSFCclr = SWupSFCclr +# SWdn at surface +flag_SWdnSFC = 1, 1, 10, 10, 10 +name_SWdnSFC = SWdnSFC +# CR at surface +flag_SWdnSFCclr = 1, 4, 10, 10, 10 +name_SWdnSFCclr = SWdnSFCclr +# LWup at surface +flag_LWupSFC = 1, 4, 10, 10, 10 +name_LWupSFC = LWupSFC +# CR LWup at surface +flag_LWupSFCclr = 1, 4, 10, 10, 10 +name_LWupSFCclr = LWupSFCclr +# LWdn at surface +flag_LWdnSFC = 1, 4, 10, 10, 10 +name_LWdnSFC = LWdnSFC +# CR LWdn at surface +flag_LWdnSFCclr = 1, 4, 10, 10, 10 +name_LWdnSFCclr = LWdnSFCclr +# Surf. total heat flux +flag_bils = 1, 2, 10, 1, 10 +name_bils = bils +# Sensible heat flux +flag_sens = 1, 1, 10, 1, 1 +name_sens = sens +# Heat flux derivation +flag_fder = 1, 2, 10, 1, 10 +name_fder = fder +# Thermal flux for snow melting +flag_ffonte = 1, 10, 10, 10, 10 +name_ffonte = ffonte +# Ice Calving +flag_fqcalving = 1, 10, 10, 10, 10 +name_fqcalving = fqcalving +# Land ice melt +flag_fqfonte = 1, 10, 10, 10, 10 +name_fqfonte = fqfonte +# Zonal wind stress (ter ice liq oce) +flag_taux_ter = 1, 4, 10, 1, 10 +name_taux_ter = taux_ter +flag_taux_lic = 1, 4, 10, 1, 10 +name_taux_lic = taux_lic +flag_taux_oce = 1, 4, 10, 1, 10 +name_taux_oce = taux_oce +flag_taux_sic = 1, 4, 10, 1, 10 +name_taux_sic = taux_sic +# Meridien wind stress (ter ice liq oce) +flag_tauy_ter = 1, 4, 10, 1, 10 +name_tauy_ter = tauy_ter +flag_tauy_lic = 1, 4, 10, 1, 10 +name_tauy_lic = tauy_lic +flag_tauy_oce = 1, 4, 10, 1, 10 +name_tauy_oce = tauy_oce +flag_tauy_sic = 1, 4, 10, 1, 10 +name_tauy_sic = tauy_sic +# % surface (ter ice liq oce) +flag_pourc_ter = 1, 4, 10, 1, 10 +name_pourc_ter = pourc_ter +flag_pourc_lic = 1, 4, 10, 1, 10 +name_pourc_lic = pourc_lic +flag_pourc_oce = 1, 4, 10, 1, 10 +name_pourc_oce = pourc_oce +flag_pourc_sic = 1, 4, 10, 1, 10 +name_pourc_sic = pourc_sic +# Fraction (ter ice liq oce) +flag_fract_ter = 1, 4, 10, 1, 10 +name_fract_ter = fract_ter +flag_fract_lic = 1, 4, 10, 1, 10 +name_fract_lic = fract_lic +flag_fract_oce = 1, 4, 10, 1, 10 +name_fract_oce = fract_oce +flag_fract_sic = 1, 4, 10, 1, 10 +name_fract_sic = fract_sic +# Surface temperature (ter ice liq oce) +flag_tsol_ter = 1, 4, 10, 1, 10 +name_tsol_ter = tsol_ter +flag_tsol_lic = 1, 4, 10, 1, 10 +name_tsol_lic = tsol_lic +flag_tsol_oce = 1, 4, 10, 1, 10 +name_tsol_oce = tsol_oce +flag_tsol_sic = 1, 4, 10, 1, 10 +name_tsol_sic = tsol_sic +# Sensible heat flux (ter ice liq oce) +flag_sens_ter = 1, 4, 10, 1, 10 +name_sens_ter = sens_ter +flag_sens_lic = 1, 4, 10, 1, 10 +name_sens_lic = sens_lic +flag_sens_oce = 1, 4, 10, 1, 10 +name_sens_oce = sens_oce +flag_sens_sic = 1, 4, 10, 1, 10 +name_sens_sic = sens_sic +# Latent heat flux (ter ice liq oce) +flag_lat_ter = 1, 4, 10, 1, 10 +name_lat_ter = lat_ter +flag_lat_lic = 1, 4, 10, 1, 10 +name_lat_lic = lat_lic +flag_lat_oce = 1, 4, 10, 1, 10 +name_lat_oce = lat_oce +flag_lat_sic = 1, 4, 10, 1, 10 +name_lat_sic = lat_sic +# LW (ter ice liq oce) +flag_flw_ter = 1, 10, 10, 10, 10 +name_flw_ter = flw_ter +flag_flw_lic = 1, 10, 10, 10, 10 +name_flw_lic = flw_lic +flag_flw_oce = 1, 10, 10, 10, 10 +name_flw_oce = flw_oce +flag_flw_sic = 1, 10, 10, 10, 10 +name_flw_sic = flw_sic +# SW (ter ice liq oce) +flag_fsw_ter = 1, 10, 10, 10, 10 +name_fsw_ter = fsw_ter +flag_fsw_lic = 1, 10, 10, 10, 10 +name_fsw_lic = fsw_lic +flag_fsw_oce = 1, 10, 10, 10, 10 +name_fsw_oce = fsw_oce +flag_fsw_sic = 1, 10, 10, 10, 10 +name_fsw_sic = fsw_sic +# Bilan sol (ter ice liq oce) +flag_wbils_ter = 1, 10, 10, 10, 10 +name_wbils_ter = wbils_ter +flag_wbils_lic = 1, 10, 10, 10, 10 +name_wbils_lic = wbils_lic +flag_wbils_oce = 1, 10, 10, 10, 10 +name_wbils_oce = wbils_oce +flag_wbils_sic = 1, 10, 10, 10, 10 +name_wbils_sic = wbils_sic +# Bilan eau (ter ice liq oce) +flag_wbilo_ter = 1, 10, 10, 10, 10 +name_wbilo_ter = wbilo_ter +flag_wbilo_lic = 1, 10, 10, 10, 10 +name_wbilo_lic = wbilo_lic +flag_wbilo_oce = 1, 10, 10, 10, 10 +name_wbilo_oce = wbilo_oce +flag_wbilo_sic = 1, 10, 10, 10, 10 +name_wbilo_sic = wbilo_sic +# Momentum drag coef +flag_cdrm = 1, 10, 10, 1, 10 +name_cdrm = cdrm +# Heat drag coef +flag_cdrh = 1, 10, 10, 1, 10 +name_cdrh = cdrh +# Low-level cloudiness +flag_cldl = 1, 1, 10, 10, 10 +name_cldl = cldl +# Mid-level cloudiness +flag_cldm = 1, 1, 10, 10, 10 +name_cldm = cldm +# High-level cloudiness +flag_cldh = 1, 1, 10, 10, 10 +name_cldh = cldh +# Total cloudiness +flag_cldt = 1, 1, 2, 10, 10 +name_cldt = cldt +# Cloud liquid water path +flag_cldq = 1, 1, 10, 10, 10 +name_cldq = cldq +# Cloud water path +flag_lwp = 1, 5, 10, 10, 10 +name_lwp = lwp +# Cloud ice water path +flag_iwp = 1, 5, 10, 10, 10 +name_iwp = iwp +# Zonal energy transport +flag_ue = 1, 10, 10, 10, 10 +name_ue = ue +# Merid energy transport +flag_ve = 1, 10, 10, 10, 10 +name_ve = ve +# Zonal humidity transport +flag_uq = 1, 10, 10, 10, 10 +name_uq = uq +# Merid humidity transport +flag_vq = 1, 10, 10, 10, 10 +name_vq = vq +# Conv avlbl pot ener +flag_cape = 1, 10, 10, 10, 10 +name_cape = cape +# Cld base pressure +flag_pbase = 1, 10, 10, 10, 10 +name_pbase = pbase +# Cld top pressure +flag_ptop = 1, 4, 10, 10, 10 +name_ptop = ptop +# Cld base mass flux +flag_fbase = 1, 10, 10, 10, 10 +name_fbase = fbase +# Precipitable water +flag_prw = 1, 1, 10, 10, 10 +name_prw = prw +# Boundary Layer Height +flag_s_pblh = 1, 10, 10, 1, 1 +name_s_pblh = pblh +# t at Boundary Layer Height +flag_s_pblt = 1, 10, 10, 1, 1 +name_s_pblt = pblt +# Condensation level +flag_s_lcl = 1, 10, 10, 1, 10 +name_s_lcl = lcl +# Conv avlbl pot enerfor ABL +flag_s_capCL = 1, 10, 10, 1, 10 +name_s_capCL = capCL +# Liq Water in BL +flag_s_oliqCL = 1, 10, 10, 1, 10 +name_s_oliqCL = oliqCL +# Instability criteria(ABL) +flag_s_cteiCL = 1, 10, 10, 1, 1 +name_s_cteiCL = cteiCL +# Exces du thermique +flag_s_therm = 1, 10, 10, 1, 1 +name_s_therm = therm +# deep_cape(HBTM2) +flag_s_trmb1 = 1, 10, 10, 1, 10 +name_s_trmb1 = trmb1 +# inhibition (HBTM2) +flag_s_trmb2 = 1, 10, 10, 1, 10 +name_s_trmb2 = trmb2 +# Point Omega (HBTM2) +flag_s_trmb3 = 1, 10, 10, 1, 10 +name_s_trmb3 = trmb3 +# Bilan au sol sur ocean slab +flag_slab_bils = 1, 1, 10, 10, 10 +name_slab_bils = slab_bils +# ALE BL +flag_ale_bl = 1, 1, 1, 1, 10 +name_ale_bl = ale_bl +# alp_bl +flag_alp_bl = 1, 1, 1, 1, 10 +name_alp_bl = alp_bl +# ale_wk +flag_ale_wk = 1, 1, 1, 1, 10 +name_ale_wk = ale_wk +# alp_wk +flag_alp_wk = 1, 1, 1, 1, 10 +name_alp_wk = alp_wk +# ale +flag_ale = 1, 1, 1, 1, 10 +name_ale = ale +# alp +flag_alp = 1, 1, 1, 1, 10 +name_alp = alp +# Convective INhibition +flag_cin = 1, 1, 1, 1, 10 +name_cin = cin +# WAPE +flag_wape = 1, 1, 1, 1, 10 +name_wape = wape +# u, v w t q et phi aux niveaux 200, 500, 700 et 850 hPa +flag_u850 = 1, 1, 3, 10, 10 +name_u850 = u850 +flag_u700 = 1, 1, 3, 10, 10 +name_u700 = u700 +flag_u500 = 1, 1, 3, 10, 10 +name_u500 = u500 +flag_u200 = 1, 1, 3, 10, 10 +name_u200 = u200 +flag_v850 = 1, 1, 3, 10, 10 +name_v850 = v850 +flag_v700 = 1, 1, 3, 10, 10 +name_v700 = v700 +flag_v500 = 1, 1, 3, 10, 10 +name_v500 = v500 +flag_v200 = 1, 1, 3, 10, 10 +name_v200 = v200 +flag_w850 = 1, 1, 3, 10, 10 +name_w850 = w850 +flag_w700 = 1, 1, 3, 10, 10 +name_w700 = w700 +flag_w500 = 1, 1, 3, 10, 10 +name_w500 = w500 +flag_w200 = 1, 1, 3, 10, 10 +name_w200 = w200 +flag_t850 = 1, 1, 3, 10, 10 +name_t850 = t850 +flag_t700 = 1, 1, 3, 10, 10 +name_t700 = t700 +flag_t500 = 1, 1, 3, 10, 10 +name_t500 = t500 +flag_t200 = 1, 1, 3, 10, 10 +name_t200 = t200 +flag_q850 = 1, 1, 3, 10, 10 +name_q850 = q850 +flag_q700 = 1, 1, 3, 10, 10 +name_q700 = q700 +flag_q500 = 1, 1, 3, 10, 10 +name_q500 = q500 +flag_q200 = 1, 1, 3, 10, 10 +name_q200 = q200 +flag_phi850 = 1, 1, 3, 10, 10 +name_phi850 = phi850 +flag_phi700 = 1, 1, 3, 10, 10 +name_phi700 = phi700 +flag_phi500 = 1, 1, 3, 10, 10 +name_phi500 = phi500 +flag_phi200 = 1, 1, 3, 10, 10 +name_phi200 = phi200 +# Temp mixte oce-sic +flag_t_oce_sic = 1, 10, 10, 10, 10 +name_t_oce_sic = t_oce_sic +# Weak inversion +flag_weakinv = 10, 1, 10, 10, 10 +name_weakinv = weakinv +# dTheta mini +flag_dthmin = 10, 1, 10, 10, 10 +name_dthmin = dthmin +# 10m zonal and meriden wind (ter sic lic oce) +flag_u10_ter = 10, 4, 10, 10, 10 +name_u10_ter = u10_ter +flag_u10_lic = 10, 4, 10, 10, 10 +name_u10_lic = u10_lic +flag_u10_oce = 10, 4, 10, 10, 10 +name_u10_oce = u10_oce +flag_u10_sic = 10, 4, 10, 10, 10 +name_u10_sic = u10_sic +flag_v10_ter = 10, 4, 10, 10, 10 +name_v10_ter = v10_ter +flag_v10_lic = 10, 4, 10, 10, 10 +name_v10_lic = v10_lic +flag_v10_oce = 10, 4, 10, 10, 10 +name_v10_oce = v10_oce +flag_v10_sic = 10, 4, 10, 10, 10 +name_v10_sic = v10_sic +# Cloud optical thickness +flag_cldtau = 10, 5, 10, 10, 10 +name_cldtau = cldtau +# Cloud optical emissivity +flag_cldemi = 10, 5, 10, 10, 10 +name_cldemi = cldemi +# Relative humidity at 2m +flag_rh2m = 10, 5, 10, 10, 10 +name_rh2m = rh2m +# Saturant humidity at 2m +flag_qsat2m = 10, 5, 10, 10, 10 +name_qsat2m = qsat2m +# Surface air potential temperature +flag_tpot = 10, 5, 10, 10, 10 +name_tpot = tpot +# Surface air equivalent potential temperature +flag_tpote = 10, 5, 10, 10, 10 +name_tpote = tpote +# TKE, tke max and tke (ter sic lic oce) +flag_tke = 4, 10, 10, 10, 10 +name_tke = tke +flag_tke_max = 4, 10, 10, 10, 10 +name_tke_max = tke_max +flag_tke_ter = 10, 4, 10, 10, 10 +name_tke_ter = tke_ter +flag_tke_lic = 10, 4, 10, 10, 10 +name_tke_lic = tke_lic +flag_tke_oce = 10, 4, 10, 10, 10 +name_tke_oce = tke_oce +flag_tke_sic = 10, 4, 10, 10, 10 +name_tke_sic = tke_sic +flag_tke_max_ter = 10, 4, 10, 10, 10 +name_tke_max_ter = tke_max_ter +flag_tke_max_lic = 10, 4, 10, 10, 10 +name_tke_max_lic = tke_max_lic +flag_tke_max_oce = 10, 4, 10, 10, 10 +name_tke_max_oce = tke_max_oce +flag_tke_max_sic = 10, 4, 10, 10, 10 +name_tke_max_sic = tke_max_sic +# Kz melange +flag_kz = 4, 10, 10, 10, 10 +name_kz = kz +# Kz max melange +flag_kz_max = 4, 10, 10, 10, 10 +name_kz_max = kz_max +# Sfce net SW radiation OR +flag_SWnetOR = 10, 10, 2, 10, 10 +name_SWnetOR = SWnetOR +# Sfce incident SW radiation OR +flag_SWdownOR = 10, 10, 2, 10, 10 +name_SWdownOR = SWdownOR +# Sfce incident LW radiation OR +flag_LWdownOR = 10, 10, 2, 10, 10 +name_LWdownOR = LWdownOR +# Solid Large-scale Precip +flag_snowl = 10, 1, 10, 10, 10 +name_snowl = snowl +# cape max +flag_cape_max = 10, 1, 10, 10, 10 +name_cape_max = cape_max +# Down. IR rad. at surface +flag_solldown = 10, 1, 10, 1, 10 +name_solldown = solldown +# Boundary-layer dTs(o) +flag_dtsvdfo = 10, 10, 10, 1, 10 +name_dtsvdfo = dtsvdfo +# Boundary-layer dTs(t) +flag_dtsvdft = 10, 10, 10, 1, 10 +name_dtsvdft = dtsvdft +# Boundary-layer dTs(g) +flag_dtsvdfg = 10, 10, 10, 1, 10 +name_dtsvdfg = dtsvdfg +# Boundary-layer dTs(g) +flag_dtsvdfi = 10, 10, 10, 1, 10 +name_dtsvdfi = dtsvdfi +# rugosity +flag_rugs = 10, 10, 10, 1, 1 +name_rugs = rugs +# Cloud liquid water content +flag_lwcon = 2, 5, 10, 10, 1 +name_lwcon = lwcon +# Cloud ice water content +flag_iwcon = 2, 5, 10, 10, 10 +name_iwcon = iwcon +# Air temperature +flag_temp = 2, 3, 4, 1, 1 +name_temp = temp +# Potential air temperature +flag_theta = 2, 3, 4, 1, 1 +name_theta = theta +# Specific humidity +flag_ovap = 2, 3, 4, 1, 1 +name_ovap = ovap +# ? +flag_ovapinit = 2, 3, 4, 1, 1 +name_ovapinit = ovapinit +# ? +flag_wvapp = 2, 10, 10, 10, 10 +name_wvapp = wvapp +# Geopotential height +flag_geop = 2, 3, 10, 1, 1 +name_geop = geop +# Zonal wind +flag_vitu = 2, 3, 4, 1, 1 +name_vitu = vitu +# Meridional wind +flag_vitv = 2, 3, 4, 1, 1 +name_vitv = vitv +# Vertical wind +flag_vitw = 2, 3, 10, 10, 1 +name_vitw = vitw +# Air pressure +flag_pres = 2, 3, 10, 1, 1 +name_pres = pres +# Cloud Fraction +flag_rneb = 2, 5, 10, 10, 1 +name_rneb = rneb +# Convective Cloud Fraction +flag_rnebcon = 2, 5, 10, 10, 1 +name_rnebcon = rnebcon +# Relative humidity +flag_rhum = 2, 10, 10, 10, 10 +name_rhum = rhum +# Ozone concentration +flag_ozone = 2, 10, 10, 10, 10 +name_ozone = ozone +# saturated updraft +flag_upwd = 2, 10, 10, 10, 10 +name_upwd = upwd +# Physics dT +flag_dtphy = 2, 10, 10, 10, 1 +name_dtphy = dtphy +# Physics dq +flag_dqphy = 2, 10, 10, 10, 1 +name_dqphy = dqphy +# Convective precipitation lic and ice +flag_pr_con_l = 2, 10, 10, 10, 10 +name_pr_con_l = pr_con_l +flag_pr_con_i = 2, 10, 10, 10, 10 +name_pr_con_i = pr_con_i +# Large scale precipitation lic and ice +flag_pr_lsc_l = 2, 10, 10, 10, 10 +name_pr_lsc_l = pr_lsc_l +flag_pr_lsc_i = 2, 10, 10, 10, 10 +name_pr_lsc_i = pr_lsc_i +# Albedo surf, Snow age and rugosity (ter sic lic oce) +flag_albe_ter = 3, 4, 10, 1, 10 +name_albe_ter = albe_ter +flag_albe_lic = 3, 4, 10, 1, 10 +name_albe_lic = albe_lic +flag_albe_oce = 3, 4, 10, 1, 10 +name_albe_oce = albe_oce +flag_albe_sic = 3, 4, 10, 1, 10 +name_albe_sic = albe_sic +flag_ages_ter = 3, 10, 10, 10, 10 +name_ages_ter = ages_ter +flag_ages_lic = 3, 10, 10, 10, 10 +name_ages_lic = ages_lic +flag_ages_oce = 3, 10, 10, 10, 10 +name_ages_oce = ages_oce +flag_ages_sic = 3, 10, 10, 10, 10 +name_ages_sic = ages_sic +flag_rugs_ter = 3, 4, 10, 1, 10 +name_rugs_ter = rugs_ter +flag_rugs_lic = 3, 4, 10, 1, 10 +name_rugs_lic = rugs_lic +flag_rugs_oce = 3, 4, 10, 1, 10 +name_rugs_oce = rugs_oce +flag_rugs_sic = 3, 4, 10, 1, 10 +name_rugs_sic = rugs_sic +# Surface albedo +flag_albs = 3, 10, 10, 1, 10 +name_albs = albs +# Surface albedo LW +flag_albslw = 3, 10, 10, 1, 10 +name_albslw = albslw +# Convective Cloud Liquid water content +flag_clwcon = 4, 10, 10, 10, 10 +name_clwcon = clwcon +# undilute adiab updraft +flag_Ma = 4, 10, 10, 10, 10 +name_Ma = Ma +# saturated downdraft +flag_dnwd = 4, 10, 10, 10, 10 +name_dnwd = dnwd +# unsat. downdraft +flag_dnwd0 = 4, 10, 10, 10, 10 +name_dnwd0 = dnwd0 +# Dynamics dT dQ dU dV, ..... +flag_dtdyn = 4, 10, 10, 10, 1 +name_dtdyn = dtdyn +flag_dqdyn = 4, 10, 10, 10, 1 +name_dqdyn = dqdyn +flag_dudyn = 4, 10, 10, 10, 1 +name_dudyn = dudyn +flag_dvdyn = 4, 10, 10, 10, 1 +name_dvdyn = dvdyn +flag_dtcon = 4, 5, 10, 10, 10 +name_dtcon = dtcon +flag_ducon = 4, 10, 10, 10, 10 +name_ducon = ducon +flag_dqcon = 4, 5, 10, 10, 10 +name_dqcon = dqcon +flag_dtwak = 4, 5, 10, 10, 10 +name_dtwak = dtwak +flag_dqwak = 4, 5, 10, 10, 10 +name_dqwak = dqwak +flag_wake_h = 4, 5, 10, 10, 10 +name_wake_h = wake_h +flag_wake_s = 4, 5, 10, 10, 10 +name_wake_s = wake_s +flag_wake_deltat = 4, 5, 10, 10, 10 +name_wake_deltat = wake_deltat +flag_wake_deltaq = 4, 5, 10, 10, 10 +name_wake_deltaq = wake_deltaq +flag_wake_omg = 4, 5, 10, 10, 10 +name_wake_omg = wake_omg +flag_Vprecip = 10, 10, 10, 10, 10 +name_Vprecip = Vprecip +flag_ftd = 4, 5, 10, 10, 10 +name_ftd = ftd +flag_fqd = 4, 5, 10, 10, 10 +name_fqd = fqd +flag_dtlsc = 4, 10, 10, 10, 10 +name_dtlsc = dtlsc +flag_dtlschr = 4, 10, 10, 10, 10 +name_dtlschr = dtlschr +flag_dqlsc = 4, 10, 10, 10, 10 +name_dqlsc = dqlsc +flag_dtvdf = 4, 10, 10, 1, 10 +name_dtvdf = dtvdf +flag_dqvdf = 4, 10, 10, 1, 10 +name_dqvdf = dqvdf +flag_dteva = 4, 10, 10, 10, 10 +name_dteva = dteva +flag_dqeva = 4, 10, 10, 10, 10 +name_dqeva = dqeva +flag_ptconv = 4, 10, 10, 10, 10 +name_ptconv = ptconv +flag_ratqs = 4, 10, 10, 10, 10 +name_ratqs = ratqs +flag_dtthe = 4, 10, 10, 10, 10 +name_dtthe = dtthe +flag_f_th = 4, 10, 10, 10, 10 +name_f_th = f_th +flag_e_th = 4, 10, 10, 10, 10 +name_e_th = e_th +flag_w_th = 4, 10, 10, 10, 10 +name_w_th = w_th +flag_lambda_th = 4, 10, 10, 10, 10 +name_lambda_th = lambda_th +flag_q_th = 4, 10, 10, 10, 10 +name_q_th = q_th +flag_a_th = 4, 10, 10, 10, 10 +name_a_th = a_th +flag_d_th = 4, 10, 10, 10, 10 +name_d_th = d_th +flag_f0_th = 4, 10, 10, 10, 10 +name_f0_th = f0_th +flag_zmax_th = 4, 10, 10, 10, 10 +name_zmax_th = zmax_th +flag_dqthe = 4, 10, 10, 10, 1 +name_dqthe = dqthe +flag_dtajs = 4, 10, 10, 10, 10 +name_dtajs = dtajs +flag_dqajs = 4, 10, 10, 10, 10 +name_dqajs = dqajs +flag_dtswr = 4, 10, 10, 10, 1 +name_dtswr = dtswr +flag_dtsw0 = 4, 10, 10, 10, 10 +name_dtsw0 = dtsw0 +flag_dtlwr = 4, 10, 10, 10, 1 +name_dtlwr = dtlwr +flag_dtlw0 = 4, 10, 10, 10, 10 +name_dtlw0 = dtlw0 +flag_dtec = 4, 10, 10, 10, 10 +name_dtec = dtec +flag_duvdf = 4, 10, 10, 10, 10 +name_duvdf = duvdf +flag_dvvdf = 4, 10, 10, 10, 10 +name_dvvdf = dvvdf +flag_duoro = 4, 10, 10, 10, 10 +name_duoro = duoro +flag_dvoro = 4, 10, 10, 10, 10 +name_dvoro = dvoro +flag_dulif = 4, 10, 10, 10, 10 +name_dulif = dulif +flag_dvlif = 4, 10, 10, 10, 10 +name_dvlif = dvlif +###! Attention a refaire correctement +flag_trac01 = 4, 10, 10, 10, 10 +name_trac01 = trac01 +flag_trac02 = 4, 10, 10, 10, 10 +name_trac02 = trac02 + Index: LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def (revision 1634) @@ -0,0 +1,1 @@ +link physiq.def_L39_NPv2.0 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_AR40.0 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_AR40.0 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_AR40.0 (revision 1634) @@ -0,0 +1,110 @@ +############################################################################## +# PARAMETRES ET CLES DE LA PHYSIQUE LMDZ +############################################################################## +# D: Valeur par default +# +#Parametres Orographiques et cdrags +#********************************** +## Si=.T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n +#Cdrags +f_cdrag_stable=1. +f_cdrag_ter=1. +f_cdrag_oce=0.8 +#cdmmax +cdmmax=2.5E-3 +#cdhmax +cdhmax=2.0E-3 +## Orodr ou non pour l orographie +ok_orodr=y +## Orolf ou non pour l orographie +ok_orolf=y +#Rugoro +f_rugoro=0. +# +# Rayonnement +#********************* +# activation du nouveau code de rayonnement RRTM +# 0 : Ancien code et 1 : RRTM (D=0) +iflag_rrtm=0 +# +# Parametres nuages +#****************** +#seuils de la precipitation des nuages strateformes (D: 2.6e-4 2.6e-4) +cld_lc_lsc=4.16e-4 +cld_lc_con=4.16e-4 +#constante de temps pour eleminer eau lsc et convective (D: 3600. 3600.) +cld_tau_lsc=1800. +cld_tau_con=1800. +#facteurs correctifs sur la vitesse de chute des cristaux de glace (D: 1 1) +ffallv_lsc=0.5 +ffallv_con=0.5 +#coefficient sur la reevaporation de la pluie (D: 2.e-5 n) +coef_eva=2e-5 +reevap_ice=y +#calcul des proprietes des nuages convectifs (D:1 0.375 1.e-4) +iflag_cldcon=3 +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 +iflag_ratqs=0 +ratqsbas=0.005 +ratqshaut=0.33 +#rayon effectif pour les nuages de glace (D:35) +rad_froid=35 +#rayons effectifs pour les nuages eau liq (tailles des gouttes d eau nuageuse, D: 13 9) +rad_chau1=12 +rad_chau2=11 +## Choix ou non de New oliq +new_oliq=y +# +# Flags Convection +#***************** +#flag pour la convection (D:2, 1:LMD, 2:Tiedtke, 3:KE nouvelle physique, 30:KE IPCC) +iflag_con=30 +#niveau de sorties des diagnos sur la conservation energie +if_ebil=0 +#efficacite de precepitation maxim (D:.993) +epmax=0.999 +#ajustement convectif sec au debut de la convection (D: n 0) +ok_adj_ema=n +iflag_clw=1 +#fermeture convective (D:1, 1:AR4, 2:ALE and ALP) +iflag_clos=1 +#loi de melange a l entrainement (D:1, 0: plate, 1=AR4:PDF) +iflag_mix=1 +#poids des PDFs plate et en cloche (D: 1 0) +qqa1=0. +qqa2=1. +# Facteur multiplication des precip convectives dans KE +cvl_corr=1.0 +# +# Flags Couche limite +#******************** +#shema de CL des thermiques (D:0, 0:ajustement sec,=>1:versions thermiques) +iflag_thermals=0 +#pas de temps du spliting pour les thermiques +nsplit_thermals=1 +tau_thermals=0. +iflag_thermals_ed=0 +iflag_thermals_optflux=0 +#shema de la couche de surface (D:1, 1:LMD, 8:Mellor-Yamada) +iflag_pbl=1 +#diffusion turbulente +ksta_ter=1.e-7 +ksta=1.e-10 +#ok_kzmin : calcul Kzmin dans la CL de surface +ok_kzmin=y +#couplage ou non avec la convection +iflag_coupl=0 (0:AR4 et 1:nouvelle physique) +seuil_inversion=-0.08 + +# Flags wakes +#************ +#activation ou non des wakes (D:0, 0:AR4, 1:nouvelle physique) +iflag_wake=0 +alp_offset=-0.2 + Index: LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv0.0 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv0.0 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv0.0 (revision 1634) @@ -0,0 +1,109 @@ +############################################################################## +# PARAMETRES ET CLES DE LA PHYSIQUE LMDZ +############################################################################## +# D: Valeur par default +# +#Parametres Orographiques et cdrags +#********************************** +## Si=.T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n +#Cdrags +f_cdrag_stable=1. +f_cdrag_ter=1. +f_cdrag_oce=0.8 +#cdmmax +cdmmax=2.5E-3 +#cdhmax +cdhmax=2.0E-3 +## Orodr ou non pour l orographie +ok_orodr=y +## Orolf ou non pour l orographie +ok_orolf=y +#Rugoro +f_rugoro=0. +# +# Rayonnement +#********************* +# activation du nouveau code de rayonnement RRTM +# 0 : Ancien code et 1 : RRTM (D=0) +iflag_rrtm=0 +# +# Parametres nuages +#****************** +#seuils de la precipitation des nuages strateformes (D: 2.6e-4 2.6e-4) +cld_lc_lsc=2.6e-4 +cld_lc_con=2.6e-4 +#constante de temps pour eleminer eau lsc et convective (D: 3600. 3600.) +cld_tau_lsc=1800. +cld_tau_con=1800. +#facteurs correctifs sur la vitesse de chute des cristaux de glace (D: 1 1) +ffallv_lsc=1.5 +ffallv_con=1.5 +#coefficient sur la reevaporation de la pluie (D: 2.e-5 n) +coef_eva=2e-5 +reevap_ice=y +#calcul des proprietes des nuages convectifs (D:1 0.375 1.e-4) +iflag_cldcon=4 +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 +iflag_ratqs=2 +ratqsbas=0.005 +ratqshaut=0.005 +#rayon effectif pour les nuages de glace (D:35) +rad_froid=35 +#rayons effectifs pour les nuages eau liq (tailles des gouttes d eau nuageuse, D: 13 9) +rad_chau1=12 +rad_chau2=11 +## Choix ou non de New oliq +new_oliq=y +# +# Flags Convection +#***************** +#flag pour la convection (D:2, 1:LMD, 2:Tiedtke, 3:KE nouvelle physique, 30:KE IPCC) +iflag_con=3 +#niveau de sorties des diagnos sur la conservation energie +if_ebil=0 +#efficacite de precepitation maxim (D:.993) +epmax=0.999 +#ajustement convectif sec au debut de la convection (D: n 0) +ok_adj_ema=n +iflag_clw=1 +#fermeture convective (D:1, 0:AR4, 2:ALE and ALP) +iflag_clos=2 +#loi de melange a l entrainement (D:1, 0:AR4=PDF plate, 1=PDF) +iflag_mix=1 +#poids des PDFs plate et en cloche (D: 1 0= PDF en cloche) +qqa1=0. +qqa2=1. +# Facteur multiplication des precip convectives dans KE +cvl_corr=1.0 +# +# Flags Couche limite +#******************** +#shema de CL des thermiques (D:0, 0:ajustement sec,=>1:versions thermiques) +iflag_thermals=13 +#pas de temps du spliting pour les thermiques +nsplit_thermals=1 +tau_thermals=0. +iflag_thermals_ed=1 +iflag_thermals_optflux=0 +#shema de la couche de surface (D:1, 1:LMD, 8:Mellor-Yamada) +iflag_pbl=8 +#diffusion turbulente +ksta_ter=1.e-7 +ksta=1.e-10 +#ok_kzmin : calcul Kzmin dans la CL de surface +ok_kzmin=y +#couplage ou non avec la convection +iflag_coupl=1 (0:AR4 et 1:nouvelle physique) +seuil_inversion=-0.08 + +# Flags wakes +#************ +#activation ou non des wakes (D:0, 0:AR4, 1:nouvelle physique) +iflag_wake=1 +alp_offset=-0.2 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv1.0 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv1.0 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv1.0 (revision 1634) @@ -0,0 +1,109 @@ +############################################################################## +# PARAMETRES ET CLES DE LA PHYSIQUE LMDZ +############################################################################## +# D: Valeur par default +# +#Parametres Orographiques et cdrags +#********************************** +## Si=.T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n +#Cdrags +f_cdrag_stable=1. +f_cdrag_ter=1. +f_cdrag_oce=0.8 +#cdmmax +cdmmax=2.5E-3 +#cdhmax +cdhmax=2.0E-3 +## Orodr ou non pour l orographie +ok_orodr=y +## Orolf ou non pour l orographie +ok_orolf=y +#Rugoro +f_rugoro=0. +# +# Rayonnement +#********************* +# activation du nouveau code de rayonnement RRTM +# 0 : Ancien code et 1 : RRTM (D=0) +iflag_rrtm=0 +# +# Parametres nuages +#****************** +#seuils de la precipitation des nuages strateformes (D: 2.6e-4 2.6e-4) +cld_lc_lsc=4.e-4 +cld_lc_con=4.e-4 +#constante de temps pour eleminer eau lsc et convective (D: 3600. 3600.) +cld_tau_lsc=3600. +cld_tau_con=3600. +#facteurs correctifs sur la vitesse de chute des cristaux de glace (D: 1 1) +ffallv_lsc=1.3 +ffallv_con=1.3 +#coefficient sur la reevaporation de la pluie (D: 2.e-5 n) +coef_eva=1e-4 +reevap_ice=y +#calcul des proprietes des nuages convectifs (D:1 0.375 1.e-4) +iflag_cldcon=4 +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 +iflag_ratqs=2 +ratqsbas=0.005 +ratqshaut=0.1 +#rayon effectif pour les nuages de glace (D:35) +rad_froid=35 +#rayons effectifs pour les nuages eau liq (tailles des gouttes d eau nuageuse, D: 13 9) +rad_chau1=12 +rad_chau2=11 +## Choix ou non de New oliq +new_oliq=y +# +# Flags Convection +#***************** +#flag pour la convection (D:2, 1:LMD, 2:Tiedtke, 3:KE nouvelle physique, 30:KE IPCC) +iflag_con=3 +#niveau de sorties des diagnos sur la conservation energie +if_ebil=0 +#efficacite de precepitation maxim (D:.993) +epmax=0.999 +#ajustement convectif sec au debut de la convection (D: n 0) +ok_adj_ema=n +iflag_clw=1 +#fermeture convective (D:1, 0:AR4, 2:ALE and ALP) +iflag_clos=2 +#loi de melange a l entrainement (D:1, 0:AR4=PDF plate, 1=PDF) +iflag_mix=1 +#poids des PDFs plate et en cloche (D: 1 0= PDF en cloche) +qqa1=0. +qqa2=1. +# Facteur multiplication des precip convectives dans KE +cvl_corr=1.0 +# +# Flags Couche limite +#******************** +#shema de CL des thermiques (D:0, 0:ajustement sec,=>1:versions thermiques) +iflag_thermals=15 +#pas de temps du spliting pour les thermiques +nsplit_thermals=1 +tau_thermals=0. +iflag_thermals_ed=10 +iflag_thermals_optflux=0 +#shema de la couche de surface (D:1, 1:LMD, 8:Mellor-Yamada) +iflag_pbl=8 +#diffusion turbulente +ksta_ter=1.e-7 +ksta=1.e-10 +#ok_kzmin : calcul Kzmin dans la CL de surface +ok_kzmin=y +#couplage ou non avec la convection +iflag_coupl=1 (0:AR4 et 1:nouvelle physique) +seuil_inversion=-0.08 + +# Flags wakes +#************ +#activation ou non des wakes (D:0, 0:AR4, 1:nouvelle physique) +iflag_wake=1 +alp_offset=-0.2 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv2.0 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv2.0 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv2.0 (revision 1634) @@ -0,0 +1,112 @@ +############################################################################## +# PARAMETRES ET CLES DE LA PHYSIQUE LMDZ +############################################################################## +# D: Valeur par default +# +#Parametres Orographiques et cdrags +#********************************** +## Si=.T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n +#Cdrags +f_cdrag_stable=1. +f_cdrag_ter=1. +f_cdrag_oce=0.8 +#cdmmax +cdmmax=2.5E-3 +#cdhmax +cdhmax=2.0E-3 +## Orodr ou non pour l orographie +ok_orodr=y +## Orolf ou non pour l orographie +ok_orolf=y +#Rugoro +f_rugoro=0. +# +# Rayonnement +#********************* +# activation du nouveau code de rayonnement RRTM +# 0 : Ancien code et 1 : RRTM (D=0) +iflag_rrtm=0 +# +# Parametres nuages +#****************** +#seuils de la precipitation des nuages strateformes (D: 2.6e-4 2.6e-4) +cld_lc_lsc=4.e-4 +cld_lc_con=4.e-4 +#constante de temps pour eleminer eau lsc et convective (D: 3600. 3600.) +cld_tau_lsc=3600. +cld_tau_con=3600. +#facteurs correctifs sur la vitesse de chute des cristaux de glace (D: 1 1) +ffallv_lsc=1.8 +ffallv_con=1.8 +#coefficient sur la reevaporation de la pluie (D: 2.e-5 n) +coef_eva=1e-4 +reevap_ice=y +#calcul des proprietes des nuages convectifs (D:1 0.375 1.e-4) +iflag_cldcon=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 +iflag_ratqs=2 +ratqsbas=0.01 +ratqshaut=0.1 +#rayon effectif pour les nuages de glace (D:35) +rad_froid=35 +#rayons effectifs pour les nuages eau liq (tailles des gouttes d eau nuageuse, D: 13 9) +rad_chau1=12 +rad_chau2=11 +## Choix ou non de New oliq +new_oliq=y +# +# +# Flags Convection +#***************** +#flag pour la convection (D:2, 1:LMD, 2:Tiedtke, 3:KE nouvelle physique, 30:KE IPCC) +iflag_con=3 +#niveau de sorties des diagnos sur la conservation energie +if_ebil=0 +#efficacite de precepitation maxim (D:.993) +epmax=0.995 +#ajustement convectif sec au debut de la convection (D: n 0) +ok_adj_ema=n +iflag_clw=1 +#fermeture convective (D:1, 0:AR4, 2:ALE and ALP) +iflag_clos=2 +#loi de melange a l entrainement (D:1, 0:AR4=PDF plate, 1=PDF) +iflag_mix=1 +#poids des PDFs plate et en cloche (D: 1 0= PDF en cloche) +qqa1=0. +qqa2=1. +# Facteur multiplication des precip convectives dans KE +cvl_corr=1.0 +# +# +# Flags Couche limite +#******************** +#shema de CL des thermiques (D:0, 0:ajustement sec,=>1:versions thermiques) +iflag_thermals=15 +#pas de temps du spliting pour les thermiques +nsplit_thermals=1 +tau_thermals=0. +iflag_thermals_ed=10 +iflag_thermals_optflux=0 +#shema de la couche de surface (D:1, 1:LMD, 8:Mellor-Yamada) +iflag_pbl=8 +#diffusion turbulente +ksta_ter=1.e-7 +ksta=1.e-10 +#ok_kzmin : calcul Kzmin dans la CL de surface +ok_kzmin=y +#couplage ou non avec la convection +iflag_coupl=1 (0:AR4 et 1:nouvelle physique) +seuil_inversion=-0.08 +# +# +# Flags wakes +#************ +#activation ou non des wakes (D:0, 0:AR4, 1:nouvelle physique) +iflag_wake=1 +alp_offset=-0.2 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv3.0 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv3.0 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/physiq.def_L39_NPv3.0 (revision 1634) @@ -0,0 +1,123 @@ +############################################################################## +# PARAMETRES ET CLES DE LA PHYSIQUE LMDZ +############################################################################## +# D: Valeur par default +# +#Parametres Orographiques et cdrags +#********************************** +## Si=.T. , lecture du fichier limit avec la bonne annee +ok_limitvrai=n +#Cdrags +f_cdrag_stable=1. +f_cdrag_ter=1. +f_cdrag_oce=0.7 +#cdmmax +cdmmax=2.5E-3 +#cdhmax +cdhmax=2.0E-3 +## Orodr ou non pour l orographie +ok_orodr=y +## Orolf ou non pour l orographie +ok_orolf=y +#Rugoro +f_rugoro=0. +# +# Rayonnement +#********************* +# activation du nouveau code de rayonnement RRTM +# 0 : Ancien code et 1 : RRTM (D=0) +iflag_rrtm=0 +# +## Activation ou non de la parametrisation de Hines pour la strato +#****************************************************************** +ok_hines=y +# +# Parametres nuages +#****************** +#seuils de la precipitation des nuages strateformes (D: 2.6e-4 2.6e-4) +cld_lc_lsc=6.e-4 +cld_lc_con=6.e-4 +#constante de temps pour eleminer eau lsc et convective (D: 3600. 3600.) +cld_tau_lsc=1800. +cld_tau_con=1800. +#facteurs correctifs sur la vitesse de chute des cristaux de glace (D: 1 1) +ffallv_lsc=1.35 +ffallv_con=1.35 +#coefficient sur la reevaporation de la pluie (D: 2.e-5 n) +coef_eva=1e-4 +reevap_ice=y +#calcul des proprietes des nuages convectifs (D:1 0.375 1.e-4) +iflag_cldcon=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 +iflag_ratqs=2 +ratqsbas=0.002 +ratqshaut=0.25 +#rayon effectif pour les nuages de glace (D:35) +rad_froid=35 +#rayons effectifs pour les nuages eau liq (tailles des gouttes d eau nuageuse, D: 13 9) +rad_chau1=12 +rad_chau2=11 +## Choix ou non de New oliq +new_oliq=y +# +rei_min=20. +rei_max=61.29 +# +t_glace_min=258. +t_glace_max=273.13 +# +# Flags Convection +#***************** +#flag pour la convection (D:2, 1:LMD, 2:Tiedtke, 3:KE nouvelle physique, 30:KE IPCC) +iflag_con=3 +#niveau de sorties des diagnos sur la conservation energie +if_ebil=0 +#efficacite de precepitation maxim (D:.993) +epmax=0.997 +#ajustement convectif sec au debut de la convection (D: n 0) +ok_adj_ema=n +iflag_clw=0 +#fermeture convective (D:1, 0:AR4, 2:ALE and ALP) +iflag_clos=2 +#loi de melange a l entrainement (D:1, 0:AR4=PDF plate, 1=PDF) +iflag_mix=1 +#poids des PDFs plate et en cloche (D: 1 0) +qqa1=1. +qqa2=0. +# Facteur multiplication des precip convectives dans KE +cvl_corr=1.0 +# +Fmax=0.65 +# +# Flags Couche limite +#******************** +#shema de CL des thermiques (D:0, 0:ajustement sec,=>1:versions thermiques) +iflag_thermals=15 +#pas de temps du spliting pour les thermiques +nsplit_thermals=1 +tau_thermals=0. +iflag_thermals_ed=10 +iflag_thermals_optflux=0 +#shema de la couche de surface (D:1, 1:LMD, 8:Mellor-Yamada) +iflag_pbl=8 +#diffusion turbulente +ksta_ter=1.e-7 +ksta=1.e-10 +#ok_kzmin : calcul Kzmin dans la CL de surface +ok_kzmin=y +#couplage ou non avec la convection +iflag_coupl=5 (0:AR4 et 1:nouvelle physique) +seuil_inversion=-0.08 +#rendement sur la puissance fournie par les thermiques a la convection +alp_bl_k=0.5 +# +# Flags wakes +#************ +#activation ou non des wakes (D:0, 0:AR4, 1:nouvelle physique) +iflag_wake=1 +alp_offset=0. Index: LMDZ5/branches/LMDZ5_AR5/DefLists/pointlocations.txt_amip =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/pointlocations.txt_amip (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/pointlocations.txt_amip (revision 1634) @@ -0,0 +1,193 @@ +1, 290.0 , -20.0 ,'VOCALS cross section (Rob Wood)' +2, 287.5 , -20.0 ,' as above' +3, 285.0 , -20.0 ,' as above ' +4, 282.5 , -20.0 ,' as above ' +5, 280.0 , -20.0 ,' as above ' +6, 277.5 , -20.0 ,'VOCALS cross section (Rob Wood)' +7, 275.0 , -20.0 ,'85W 20S WHOI SE Pacific stratus buoy (http://uop.whoi.edu/stratus/) (CPT)' +8, 270.0 , -18.5 ,'SouthEast Tropical Pacific Section (CFMIP)' +9, 265.0 , -17.0 ,' as above ' +10, 260.0 , -15.5 ,' as above ' +11, 255.0 , -14.0 ,' as above ' +12, 250.0 , -12.5 ,' as above ' +13, 245.0 , -11.0 ,' as above ' +14, 240.0 , -9.50 ,' as above ' +15, 234.9 , -8.0 ,'125.1W 8S central Pacific SE trades TAO buoy (CPT)' +16, -123.0 , 38.1 ,'Point Reyes ARM Mobile Facility N38° 5.51' W122° 57.33' (AMF)' +17, 235 , 35 ,'GCSS Pacific cross section (GPCI) (Joao Teixeira)' +18, 231 , 32 ,' as above ' +19, 227 , 29 ,' as above ' +20, 223 , 26 ,' as above ' +21, 219 , 23 ,' as above ' +22, 215 , 20 ,' as above ' +23, 211 , 17 ,' as above ' +24, 207 , 14 ,' as above ' +25, 203 , 11 ,' as above ' +26, 199 , 8 ,' as above ' +27, 195 , 5 ,' as above ' +28, 191 , 2 ,' as above ' +29, 187 , -1 ,'GCSS Pacific cross section (GPCI) (Joao Teixeira)' +30, 177 , -1 ,'GPCI/Tropical West Pacific link point (CFMIP)' +31, 166.9 , -0.5 ,'166.9E 0.5S Nauru ARM (CPT)' +32, 156 , -2 ,'156E 2S COARE (CPT)' +33, 147.4 , -2.1 ,'147.4E 2.1S Manus ARM (CPT)' +34, 140.5 , -4.75 ,'Papua New Guinea (CFMIP)' +35, 135.5 , -8 ,'Arafura Sea (CFMIP)' +36, 130.9 , -12.4 ,'130.9E 12.4S Darwin ARM (CPT)' +37, -97.5 , 36.4 ,'97.5W 36.4N Oklahoma ARM (CPT)' +38, -156.6 , 71.3 ,'156.6W 71.3N Barrow ARM (CPT) ' +39, -62 , -11 ,'62W 11S Amazonia (CPT)' +40, 4.9 , 52 ,'4.93E,51.97N Cabaaw Mast Netherlands (CPT)' +41, 145 , -42 ,'145E 42S Cape Grim Tasmania (CPT)' +42, -51 , 15 ,'51W 15N WHOI Atlantic tradewind NTAS buoy (http://uop.whoi.edu/ntas/) (CPT)' +43, -140 , 30 ,'140W 30N OWS N (CPT)' +44, -145 , 50 ,'145W 50N OWS P (CPT)' +45, -125.2 , 8 ,'125.2W 8N central Pacific ITCZ TAO buoy (CPT)' +46, 120 , 23.5 ,'120E 23.5N China Sea (CPT)' +47, -28 , 39 ,'Graciosa in the Azores (28W 39N) 2009 AMF deployment (Chris Bretherton)' +48, 8.4 , 48.5 ,'AMF Black forest Germany Main Site: N48° 32.403' E08° 23.812' (AMF)' +49, 116.8 , 32.5 ,'AMF Shouxian China Location: 32°33'N 116°46'E (AMF)' +50, 129.6 , 62.3 ,'CEOP 2 Eastern Siberian Tiaga 62.3N 129.6E (Martin Koehler)' +51, 91.9 , 31.4 ,'CEOP 5 Tibet 31.4N 91.9E (Martin Koehler)' +52, 134.5 , 7.5 ,'CEOP 10 Western Pacific Ocean 7.5N 134.5E (Martin Koehler)' +53, 14.1 , 52.2 ,'CEOP 26 Lindenberg 52.2N 14.1E (Martin Koehler)' +54, 26.6 , 67.4 ,'CEOP 27 Sodankyla 67.4N 26.6E (Martin Koehler)' +55, -105.1 , 54.0 ,'CEOP 33 BERMS (CliC) 54.0N 105.1W (Martin Koehler)' +56, -62.5 , 82.5 ,'CEOP 34 Alert Nunavut 82.5N 62.5W (Martin Koehler)' +57, -53.4 , -28.6 ,'CEOP 48 Cruz Alta (LPB) 28.6S 53.4W (Martin Koehler)' +58, -24 , 41 ,'ASTEX (41N 24W) (Adrian Lock)' +59, -26 , 35 ,'ASTEX (35N 26W) (Adrian Lock)' +60, -29 , 29 ,'ASTEX (29N 29W) (Adrian Lock)' +61, -35 , 12 ,'ATEX = 12N 35W (Adrian Lock)' +62, -56.5 , 15 ,'BOMEX = 15N 56.5W (Adrian Lock)' +63, -61.5 , 18 ,'RICO = 18N 61.5W (Adrian Lock)' +64, -119.5 , 33 ,'EUROCS/FIREI = 33N 119.5W (Adrian Lock)' +65, -122 , 31.5 ,'DYCOMSII = 31.5N 122W (Adrian Lock)' +66, -85 , -2.5 ,'East Pacific Point (CFMIP)' +67, -95 , -2.5 ,'East Pacific Point (CFMIP)' +68, -105 , -2.5 ,'East Pacific Point (CFMIP)' +69, -115 , -2.5 ,'East Pacific Point (CFMIP)' +70, -125 , -2.5 ,'East Pacific Point (CFMIP)' +71, -125 , 18 ,'East Pacific Point (CFMIP)' +72, -69 , 1 ,'North West of Amazonia (CFMIP)' +73, 62.0 , 13.0 ,'MONSOON INFLOW (CFMIP)' +74, -14.4 , -7.97 ,'ASCENSION IS./WIDEAWAKE (RATPAC) (CFMIP)' +75, 150 , 37 ,'Kurishio region (CFMIP)' +76, -21.9 , 64.1 ,'64.1285N 21.9407W Reykjavik (CFMIP)' +77, -170.2 , 57.15 ,'ST. PAUL ISLAND (RATPAC) (CFMIP)' +78, -58.9 , -62.20 ,'BELLINGSHAUSEN (RATPAC) (CFMIP)' +79, 11.95 , 78.93 ,'BSRN site Svalbard (CFMIP)' +80, 144.8 , 13.6 ,'Guam (CFMIP)' +81, 69.3 , -49.2 ,'Southern Ocean - Kerguelen Islands (CFMIP)' +82, 158.9 , -54.6 ,'Southern Ocean - Macquarie Island (CFMIP)' +83, -81 , 27 ,'Florida (81W 27N) ( Brian Mapes )' +84, -167.7 , 8.7 ,'Kwajalein (167.7W 8.7N) ( Brian Mapes )' +85, 90.0 , 12 ,'JASMINE (90E 12N) ( Brian Mapes )' +86, 115 , 12 ,'SCS (115E 12N) ( Brian Mapes )' +87, -95 , 10 ,'EPIC (95W 10N) ( Brian Mapes )' +88, -23 , 8.5 ,'GATE (23W 8.5N) ( Brian Mapes )' +89, -1.44 , 51.14 ,'Chilbolton, UK 51.1445 North, 1.4370 West, altitude 80 m. (Robin Hogan)' +90, 2.20 , 48.71 ,'SIRTA, Palaiseau (Paris), France 48.713 North 2.204 Est (Cloudnet)' +91, 93.7 , -20.1 ,'CFMIP West of Australia' +92, 254.4 , -58.5 ,'CFMIP Southern Ocean' +93, -52.75 , 47.67 ,'CFMIP ST. JOHNS (RATPAC)' +94, -176.6 , -43.95 ,'CFMIP CHATHAM ISLAND (RATPAC)' +95, 72.4 , -7.30 ,'CFMIP DIEGO GARCIA (RATPAC)' +96, -9.88 , -40.35 ,'GOUGH IS. (RATPAC) (CFMIP) ' +97, 189.1 , 38.2 ,'CFMIP Central North Pacific' +98,-149.6 , -17.5 ,'CFMIP Tahiti 17.5° S 149.6°W' +99, 0.0 , -56.0 ,'CFMIP South Atlantic' +100, 273.5 , -42.7 ,'CFMIP off coast of Chile' +101, 153.97 , 24.30 ,'MARCUS IS. (RATPAC) (CFMIP)' +102, 167.9, -29.03 ,'NORFOLK ISLAND (RATPAC) (CFMIP)' +103, -40.0 , 50.0 ,'CFMIP North West Atlantic' +104, 87.95, 65.78 ,'TURUKHANSK (RATPAC) RS ' +105, 0.0, 0.0 ,'0., 0.N Pirata Buoy ( AMMA Francoise Guichard )' +106, 2.5, 3.5, ,'2.5, 3.5N ( AMMA Francoise Guichard )' +107, 2.5, 6.5, ,'2.5, 6.5N ( AMMA Francoise Guichard )' +108, 2.0, 9.5, ,'2. , 9.5N Oueme ( AMMA Francoise Guichard )' +109, 2.5, 11.5, ' 2.5, 11.5N ( AMMA Francoise Guichard )' +110, 2.2, 13.5 ,'13.5N 2.2E Niamey ARM Mobile Facility (AMF)' +111, -1.5, 15.5 ,' -1.5, 15.5N Gourma ( AMMA Francoise Guichard )' +112, 2.5, 18 ,'2.5, 18N ( AMMA Francoise Guichard )' +113, 2.5, 20.5 ,'2.5, 20.5N ( AMMA Francoise Guichard )' +114, 5.5, 23.0 ,'5.5, 23 N Tamanrasset ( AMMA Francoise Guichard )' +115, -17.0, 15.0 ,' -17. 15N Dakar ( AMMA Francoise Guichard )' +116, -165.0, 76.0 ,' 165W, 76N Location of SHEBA IceBreaker May 1998 ( Stephen Klein )' +117, 128.9, 71.6 ,' Tiksi, Russia 71.6 N, 128.9 - Location of NOAA SEARCH Site ( Stephen Klein )' +118, 110.0, 88.0 ,' Central Arctic Ocean Point - midway between Svalbard & SHEBA ( Stephen Klein )' +119, 123.2, -75.1 ,' Antarctica Plateau Dome C: 75?1 S 123?2 E (Sandrine Bony/Christophe Genthon)' +120, -59.4, 13.2 ,' Barbados site -59.4W 13.2N (Sandrine Bony/Louise Nuijens)' +1000001,0.0, 90.0 ,'Aquaplanet Greenwich meridian point 01' +1000002,0.0, 87.5 ,'Aquaplanet Greenwich meridian point 02' +1000003,0.0, 85.0 ,'Aquaplanet Greenwich meridian point 03' +1000004,0.0, 82.5 ,'Aquaplanet Greenwich meridian point 04' +1000005,0.0, 80.0 ,'Aquaplanet Greenwich meridian point 05' +1000006,0.0, 77.5 ,'Aquaplanet Greenwich meridian point 06' +1000007,0.0, 75.0 ,'Aquaplanet Greenwich meridian point 07' +1000008,0.0, 72.5 ,'Aquaplanet Greenwich meridian point 08' +1000009,0.0, 70.0 ,'Aquaplanet Greenwich meridian point 09' +1000010,0.0, 67.5 ,'Aquaplanet Greenwich meridian point 10' +1000011,0.0, 65.0 ,'Aquaplanet Greenwich meridian point 11' +1000012,0.0, 62.5 ,'Aquaplanet Greenwich meridian point 12' +1000013,0.0, 60.0 ,'Aquaplanet Greenwich meridian point 13' +1000014,0.0, 57.5 ,'Aquaplanet Greenwich meridian point 14' +1000015,0.0, 55.0 ,'Aquaplanet Greenwich meridian point 15' +1000016,0.0, 52.5 ,'Aquaplanet Greenwich meridian point 16' +1000017,0.0, 50.0 ,'Aquaplanet Greenwich meridian point 17' +1000018,0.0, 47.5 ,'Aquaplanet Greenwich meridian point 18' +1000019,0.0, 45.0 ,'Aquaplanet Greenwich meridian point 19' +1000020,0.0, 42.5 ,'Aquaplanet Greenwich meridian point 20' +1000021,0.0, 40.0 ,'Aquaplanet Greenwich meridian point 21' +1000022,0.0, 37.5 ,'Aquaplanet Greenwich meridian point 22' +1000023,0.0, 35.0 ,'Aquaplanet Greenwich meridian point 23' +1000024,0.0, 32.5 ,'Aquaplanet Greenwich meridian point 24' +1000025,0.0, 30.0 ,'Aquaplanet Greenwich meridian point 25' +1000026,0.0, 27.5 ,'Aquaplanet Greenwich meridian point 26' +1000027,0.0, 25.0 ,'Aquaplanet Greenwich meridian point 27' +1000028,0.0, 22.5 ,'Aquaplanet Greenwich meridian point 28' +1000029,0.0, 20.0 ,'Aquaplanet Greenwich meridian point 29' +1000030,0.0, 17.5 ,'Aquaplanet Greenwich meridian point 30' +1000031,0.0, 15.0 ,'Aquaplanet Greenwich meridian point 31' +1000032,0.0, 12.5 ,'Aquaplanet Greenwich meridian point 32' +1000033,0.0, 10.0 ,'Aquaplanet Greenwich meridian point 33' +1000034,0.0, 7.50 ,'Aquaplanet Greenwich meridian point 34' +1000035,0.0, 5.00 ,'Aquaplanet Greenwich meridian point 35' +1000036,0.0, 2.50 ,'Aquaplanet Greenwich meridian point 36' +1000037,0.0, 0.00 ,'Aquaplanet Greenwich meridian point 37' +1000038,0.0, -2.50 ,'Aquaplanet Greenwich meridian point 38' +1000039,0.0, -5.00 ,'Aquaplanet Greenwich meridian point 39' +1000040,0.0, -7.50 ,'Aquaplanet Greenwich meridian point 40' +1000041,0.0, -10.0 ,'Aquaplanet Greenwich meridian point 41' +1000042,0.0, -12.5 ,'Aquaplanet Greenwich meridian point 42' +1000043,0.0, -15.0 ,'Aquaplanet Greenwich meridian point 43' +1000044,0.0, -17.5 ,'Aquaplanet Greenwich meridian point 44' +1000045,0.0, -20.0 ,'Aquaplanet Greenwich meridian point 45' +1000046,0.0, -22.5 ,'Aquaplanet Greenwich meridian point 46' +1000047,0.0, -25.0 ,'Aquaplanet Greenwich meridian point 47' +1000048,0.0, -27.5 ,'Aquaplanet Greenwich meridian point 48' +1000049,0.0, -30.0 ,'Aquaplanet Greenwich meridian point 49' +1000050,0.0, -32.5 ,'Aquaplanet Greenwich meridian point 50' +1000051,0.0, -35.0 ,'Aquaplanet Greenwich meridian point 51' +1000052,0.0, -37.5 ,'Aquaplanet Greenwich meridian point 52' +1000053,0.0, -40.0 ,'Aquaplanet Greenwich meridian point 53' +1000054,0.0, -42.5 ,'Aquaplanet Greenwich meridian point 54' +1000055,0.0, -45.0 ,'Aquaplanet Greenwich meridian point 55' +1000056,0.0, -47.5 ,'Aquaplanet Greenwich meridian point 56' +1000057,0.0, -50.0 ,'Aquaplanet Greenwich meridian point 57' +1000058,0.0, -52.5 ,'Aquaplanet Greenwich meridian point 58' +1000059,0.0, -55.0 ,'Aquaplanet Greenwich meridian point 59' +1000060,0.0, -57.5 ,'Aquaplanet Greenwich meridian point 60' +1000061,0.0, -60.0 ,'Aquaplanet Greenwich meridian point 61' +1000062,0.0, -62.5 ,'Aquaplanet Greenwich meridian point 62' +1000063,0.0, -65.0 ,'Aquaplanet Greenwich meridian point 63' +1000064,0.0, -67.5 ,'Aquaplanet Greenwich meridian point 64' +1000065,0.0, -70.0 ,'Aquaplanet Greenwich meridian point 65' +1000066,0.0, -72.5 ,'Aquaplanet Greenwich meridian point 66' +1000067,0.0, -75.0 ,'Aquaplanet Greenwich meridian point 67' +1000068,0.0, -77.5 ,'Aquaplanet Greenwich meridian point 68' +1000069,0.0, -80.0 ,'Aquaplanet Greenwich meridian point 69' +1000070,0.0, -82.5 ,'Aquaplanet Greenwich meridian point 70' +1000071,0.0, -85.0 ,'Aquaplanet Greenwich meridian point 71' +1000072,0.0, -87.5 ,'Aquaplanet Greenwich meridian point 72' +1000073,0.0, -90.0 ,'Aquaplanet Greenwich meridian point 73' Index: LMDZ5/branches/LMDZ5_AR5/DefLists/pointlocations.txt_aqua =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/pointlocations.txt_aqua (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/pointlocations.txt_aqua (revision 1634) @@ -0,0 +1,73 @@ +1000001,0.0, 90.0 ,'Aquaplanet Greenwich meridian point 01' +1000002,0.0, 87.5 ,'Aquaplanet Greenwich meridian point 02' +1000003,0.0, 85.0 ,'Aquaplanet Greenwich meridian point 03' +1000004,0.0, 82.5 ,'Aquaplanet Greenwich meridian point 04' +1000005,0.0, 80.0 ,'Aquaplanet Greenwich meridian point 05' +1000006,0.0, 77.5 ,'Aquaplanet Greenwich meridian point 06' +1000007,0.0, 75.0 ,'Aquaplanet Greenwich meridian point 07' +1000008,0.0, 72.5 ,'Aquaplanet Greenwich meridian point 08' +1000009,0.0, 70.0 ,'Aquaplanet Greenwich meridian point 09' +1000010,0.0, 67.5 ,'Aquaplanet Greenwich meridian point 10' +1000011,0.0, 65.0 ,'Aquaplanet Greenwich meridian point 11' +1000012,0.0, 62.5 ,'Aquaplanet Greenwich meridian point 12' +1000013,0.0, 60.0 ,'Aquaplanet Greenwich meridian point 13' +1000014,0.0, 57.5 ,'Aquaplanet Greenwich meridian point 14' +1000015,0.0, 55.0 ,'Aquaplanet Greenwich meridian point 15' +1000016,0.0, 52.5 ,'Aquaplanet Greenwich meridian point 16' +1000017,0.0, 50.0 ,'Aquaplanet Greenwich meridian point 17' +1000018,0.0, 47.5 ,'Aquaplanet Greenwich meridian point 18' +1000019,0.0, 45.0 ,'Aquaplanet Greenwich meridian point 19' +1000020,0.0, 42.5 ,'Aquaplanet Greenwich meridian point 20' +1000021,0.0, 40.0 ,'Aquaplanet Greenwich meridian point 21' +1000022,0.0, 37.5 ,'Aquaplanet Greenwich meridian point 22' +1000023,0.0, 35.0 ,'Aquaplanet Greenwich meridian point 23' +1000024,0.0, 32.5 ,'Aquaplanet Greenwich meridian point 24' +1000025,0.0, 30.0 ,'Aquaplanet Greenwich meridian point 25' +1000026,0.0, 27.5 ,'Aquaplanet Greenwich meridian point 26' +1000027,0.0, 25.0 ,'Aquaplanet Greenwich meridian point 27' +1000028,0.0, 22.5 ,'Aquaplanet Greenwich meridian point 28' +1000029,0.0, 20.0 ,'Aquaplanet Greenwich meridian point 29' +1000030,0.0, 17.5 ,'Aquaplanet Greenwich meridian point 30' +1000031,0.0, 15.0 ,'Aquaplanet Greenwich meridian point 31' +1000032,0.0, 12.5 ,'Aquaplanet Greenwich meridian point 32' +1000033,0.0, 10.0 ,'Aquaplanet Greenwich meridian point 33' +1000034,0.0, 7.50 ,'Aquaplanet Greenwich meridian point 34' +1000035,0.0, 5.00 ,'Aquaplanet Greenwich meridian point 35' +1000036,0.0, 2.50 ,'Aquaplanet Greenwich meridian point 36' +1000037,0.0, 0.00 ,'Aquaplanet Greenwich meridian point 37' +1000038,0.0, -2.50 ,'Aquaplanet Greenwich meridian point 38' +1000039,0.0, -5.00 ,'Aquaplanet Greenwich meridian point 39' +1000040,0.0, -7.50 ,'Aquaplanet Greenwich meridian point 40' +1000041,0.0, -10.0 ,'Aquaplanet Greenwich meridian point 41' +1000042,0.0, -12.5 ,'Aquaplanet Greenwich meridian point 42' +1000043,0.0, -15.0 ,'Aquaplanet Greenwich meridian point 43' +1000044,0.0, -17.5 ,'Aquaplanet Greenwich meridian point 44' +1000045,0.0, -20.0 ,'Aquaplanet Greenwich meridian point 45' +1000046,0.0, -22.5 ,'Aquaplanet Greenwich meridian point 46' +1000047,0.0, -25.0 ,'Aquaplanet Greenwich meridian point 47' +1000048,0.0, -27.5 ,'Aquaplanet Greenwich meridian point 48' +1000049,0.0, -30.0 ,'Aquaplanet Greenwich meridian point 49' +1000050,0.0, -32.5 ,'Aquaplanet Greenwich meridian point 50' +1000051,0.0, -35.0 ,'Aquaplanet Greenwich meridian point 51' +1000052,0.0, -37.5 ,'Aquaplanet Greenwich meridian point 52' +1000053,0.0, -40.0 ,'Aquaplanet Greenwich meridian point 53' +1000054,0.0, -42.5 ,'Aquaplanet Greenwich meridian point 54' +1000055,0.0, -45.0 ,'Aquaplanet Greenwich meridian point 55' +1000056,0.0, -47.5 ,'Aquaplanet Greenwich meridian point 56' +1000057,0.0, -50.0 ,'Aquaplanet Greenwich meridian point 57' +1000058,0.0, -52.5 ,'Aquaplanet Greenwich meridian point 58' +1000059,0.0, -55.0 ,'Aquaplanet Greenwich meridian point 59' +1000060,0.0, -57.5 ,'Aquaplanet Greenwich meridian point 60' +1000061,0.0, -60.0 ,'Aquaplanet Greenwich meridian point 61' +1000062,0.0, -62.5 ,'Aquaplanet Greenwich meridian point 62' +1000063,0.0, -65.0 ,'Aquaplanet Greenwich meridian point 63' +1000064,0.0, -67.5 ,'Aquaplanet Greenwich meridian point 64' +1000065,0.0, -70.0 ,'Aquaplanet Greenwich meridian point 65' +1000066,0.0, -72.5 ,'Aquaplanet Greenwich meridian point 66' +1000067,0.0, -75.0 ,'Aquaplanet Greenwich meridian point 67' +1000068,0.0, -77.5 ,'Aquaplanet Greenwich meridian point 68' +1000069,0.0, -80.0 ,'Aquaplanet Greenwich meridian point 69' +1000070,0.0, -82.5 ,'Aquaplanet Greenwich meridian point 70' +1000071,0.0, -85.0 ,'Aquaplanet Greenwich meridian point 71' +1000072,0.0, -87.5 ,'Aquaplanet Greenwich meridian point 72' +1000073,0.0, -90.0 ,'Aquaplanet Greenwich meridian point 73' Index: LMDZ5/branches/LMDZ5_AR5/DefLists/run.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/run.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/run.def (revision 1634) @@ -0,0 +1,34 @@ +# $Id: run.def 1403 2010-07-01 09:02:53Z fairhead $ +# +## Fichier de configuration general +## +INCLUDEDEF=physiq.def +INCLUDEDEF=gcm.def +INCLUDEDEF=orchidee.def +INCLUDEDEF=output.def +INCLUDEDEF=config.def +## Type de calendrier utilise +## valeur possible: earth_360d (defaut), earth_365d, earth_366d +calend=earth_360d +## Jour de l'etat initial ( = 350 si 20 Decembre ,par expl. ,comme ici ) +dayref=1 +## Annee de l'etat initial ( avec 4 chiffres ) +anneeref=1980 +## Nombre de jours d'integration +nday=5 +## Remise a zero de la date initiale +raz_date=0 +## periode de sortie des variables de controle (en pas) +iconser=240 +## periode d'ecriture du fichier histoire (en jour) +iecri=1 +## flag de sortie dynzon +ok_dynzon=n +## periode de stockage fichier dynzon (en jour) +periodav= 30. +## activation du calcul d equilibrage de charge +adjust=n +## activation du filtre fft +use_filtre_fft=n +## niveau d'impression de controle +prt_level=1 Index: LMDZ5/branches/LMDZ5_AR5/DefLists/traceur.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/DefLists/traceur.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/DefLists/traceur.def (revision 1634) @@ -0,0 +1,5 @@ +4 +14 14 H2Ov +10 10 H2Ol +10 10 RN +10 10 PB Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-AMD64_CICLAD.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-AMD64_CICLAD.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-AMD64_CICLAD.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER /usr/lib64/openmpi/1.2.8-pgf/bin/mpif90 +%LINK /usr/lib64/openmpi/1.2.8-pgf/bin/mpif90 +%AR ar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM +%BASE_FFLAGS -i4 -r8 +%PROD_FFLAGS -O2 -Munroll -Mnoframe -Mautoinline -Mcache_align +%DEV_FFLAGS -Mbounds +%DEBUG_FFLAGS -g -traceback -Mbounds -Mchkfpstk -Mchkstk -Ktrap=denorm,divz,ovf,unf +%MPI_FFLAGS +%OMP_FFLAGS -mp +%BASE_LD -lblas +%MPI_LD -L/usr/lib64/openmpi/1.2.8-pgf/lib +%OMP_LD -mp Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-AMD64_CICLAD.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-AMD64_CICLAD.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-AMD64_CICLAD.path (revision 1634) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR="-L/opt/netcdf/pgf/lib -lnetcdf" +NETCDF_INCDIR=-I/opt/netcdf/pgf/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-ES_MOON.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-ES_MOON.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-ES_MOON.fcm (revision 1634) @@ -0,0 +1,17 @@ +%COMPILER esmpif90 +%LINK esmpif90 +%AR esar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eC -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" + + Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-ES_MOON.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-ES_MOON.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-ES_MOON.path (revision 1634) @@ -0,0 +1,11 @@ +NETCDF_LIBDIR="-L/S/home010/c0010/ES/lib -lnetcdf" +NETCDF_INCDIR=-I/S/home010/c0010/ES/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/ES/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/ES/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib +LIBPREFIX=sx Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-IA64_PLATINE.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-IA64_PLATINE.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-IA64_PLATINE.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER mpif90 +%LINK mpif90 +%AR ar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MKL +%BASE_FFLAGS -i4 -r8 -automatic -align all -I${MKLROOT}/include +%PROD_FFLAGS -O3 +%DEV_FFLAGS -p -g -O3 -traceback +%DEBUG_FFLAGS -p -g -traceback +%MPI_FFLAGS +%OMP_FFLAGS -openmp +%BASE_LD -p -i4 -r8 -automatic $MKL_LIBS +%MPI_LD +%OMP_LD -openmp Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-IA64_PLATINE.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-IA64_PLATINE.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-IA64_PLATINE.path (revision 1634) @@ -0,0 +1,11 @@ +NETCDF_LIBDIR="-L/usr/lib -lnetcdff -lnetcdf" +NETCDF_INCDIR=-I/usr/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/IA64/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/IA64/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib + Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-PW6_VARGAS.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-PW6_VARGAS.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-PW6_VARGAS.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER xlf_r +%LINK mpxlf_r +%AR ar +%MAKE gmake +%FPP_FLAGS -P -I/usr/local/pub/FFTW/3.2/include +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_FFTW +%BASE_FFLAGS -qautodbl=dbl4 -qxlf90=autodealloc -qmaxmem=-1 -qzerosize -I/usr/local/pub/FFTW/3.2/include +%PROD_FFLAGS -O3 +%DEV_FFLAGS -O2 -qfullpath -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap +%DEBUG_FFLAGS -g -qfullpath -qnooptimize -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:zerodivide:invalid:enable -qsigtrap -qcheck +%MPI_FFLAGS -I/usr/lpp/ppe.poe/include/thread64 +%OMP_FFLAGS -qsmp=omp +%BASE_LD -lessl -L/usr/local/pub/FFTW/3.2/lib -lfftw3 +%MPI_LD +%OMP_LD -qsmp=omp Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-PW6_VARGAS.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-PW6_VARGAS.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-PW6_VARGAS.path (revision 1634) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR="${NETCDF_LDFLAGS:--L/usr/local/pub/NetCDF/3.6.2/lib -lnetcdf}" +NETCDF_INCDIR="${NETCDF_FFLAGS:--I/usr/local/pub/NetCDF/3.6.2/include}" +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/AIX6/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/AIX6/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.fcm (revision 1634) @@ -0,0 +1,16 @@ +%COMPILER sxmpif90 +%LINK sxmpif90 +%AR sxar +%MAKE sxgmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eR -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" + Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.opt =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.opt (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.opt (revision 1634) @@ -0,0 +1,12 @@ +%INLINE -pi auto exp=swtt1_lmdar4,swtt_lmdar4,swde_lmdar4,lwttm_lmdar4,lwtt_lmdar4,swr_lmdar4,swclr_lmdar4 noexp=SW_LMDAR4,SWU_LMDAR4,SW1S_LMDAR4,SW2S_LMDAR4,LW_LMDAR4,LWU_LMDAR4,LWBV_LMDAR4,LWC_LMDAR4,LWB_LMDAR4,LWV_LMDAR4,LWVB_LMDAR4,LWVD_LMDAR4,LWVN_LMDAR4 line=2000 + +bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR +bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -Wf,-O,extendreorder %INLINE +bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt %INLINE +bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_BRODIE.path (revision 1634) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR="-L/SXlocal/pub/netCDF/3.6.1-openmp/lib -lnetcdf" +NETCDF_INCDIR=-I/SXlocal/pub/netCDF/3.6.1-openmp/include +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER sxmpif90 +%LINK sxmpif90 +%AR sxar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eC -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -size_t64 -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.opt =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.opt (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.opt (revision 1634) @@ -0,0 +1,12 @@ +%INLINE -pi auto exp=swtt1_lmdar4,swtt_lmdar4,swde_lmdar4,lwttm_lmdar4,lwtt_lmdar4,swr_lmdar4,swclr_lmdar4 noexp=SW_LMDAR4,SWU_LMDAR4,SW1S_LMDAR4,SW2S_LMDAR4,LW_LMDAR4,LWU_LMDAR4,LWBV_LMDAR4,LWC_LMDAR4,LWB_LMDAR4,LWV_LMDAR4,LWVB_LMDAR4,LWVD_LMDAR4,LWVN_LMDAR4 line=2000 + +bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR +bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -Wf,-O,extendreorder %INLINE +bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt %INLINE +bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX8_MERCURE.path (revision 1634) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR="-L ${NETCDF_SX_LIBDIR:-/usr/local/SX8/soft/netcdf/lib} -lnetcdf" +NETCDF_INCDIR=-I${NETCDF_SX_INCLUDEDIR:-/usr/local/SX8/soft/netcdf/include} +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER sxmpif90 +%LINK sxmpif90 +%AR sxar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MATHKEISAN +%BASE_FFLAGS -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R2 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" +%PROD_FFLAGS -C vopt -pi expin=%SRC_PATH/%DYN/cray.F exp=ssum,scopy +%DEV_FFLAGS -C vsafe -gv -Wf,-init stack=nan,-init heap=nan +%DEBUG_FFLAGS -C debug -eC -Wf,-init stack=nan,-init heap=nan +%MPI_FFLAGS +%OMP_FFLAGS -P openmp +%BASE_LD -size_t64 -lblas -lfft +%MPI_LD +%OMP_LD -P openmp -Wl,"-ZL 3G" Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.opt =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.opt (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.opt (revision 1634) @@ -0,0 +1,12 @@ +%INLINE -pi auto exp=swtt1_lmdar4,swtt_lmdar4,swde_lmdar4,lwttm_lmdar4,lwtt_lmdar4,swr_lmdar4,swclr_lmdar4 noexp=SW_LMDAR4,SWU_LMDAR4,SW1S_LMDAR4,SW2S_LMDAR4,LW_LMDAR4,LWU_LMDAR4,LWBV_LMDAR4,LWC_LMDAR4,LWB_LMDAR4,LWV_LMDAR4,LWVB_LMDAR4,LWVD_LMDAR4,LWVN_LMDAR4 line=2000 + +bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR +bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -Wf,-O,extendreorder %INLINE +bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt %INLINE +bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PARA_FFLAGS %PROD_FFLAGS %INCDIR -C hopt Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-SX9_MERCURE.path (revision 1634) @@ -0,0 +1,10 @@ +NETCDF_LIBDIR="-L${NETCDF_SX_LIBDIR:-/ccc/applications/sx9/netcdf-3.6.1/lib} -lnetcdf" +NETCDF_INCDIR=-I${NETCDF_SX_INCLUDEDIR:-/ccc/applications/sx9/netcdf-3.6.1/include} +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-X64_TITANE.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-X64_TITANE.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-X64_TITANE.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER mpif90 +%LINK mpif90 +%AR ar +%MAKE gmake +%FPP_FLAGS -P -traditional +%FPP_DEF NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM FFT_MKL +%BASE_FFLAGS -i4 -r8 -automatic -align all -I${MKLROOT}/include +%PROD_FFLAGS -O3 +%DEV_FFLAGS -p -g -O3 -traceback -fp-stack-check -ftrapuv +%DEBUG_FFLAGS -p -g -traceback +%MPI_FFLAGS +%OMP_FFLAGS -openmp +%BASE_LD -p -i4 -r8 -automatic $MKL_LIBS +%MPI_LD +%OMP_LD -openmp Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-X64_TITANE.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-X64_TITANE.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-X64_TITANE.path (revision 1634) @@ -0,0 +1,11 @@ +NETCDF_LIBDIR="-L$NETCDF_LIB_DIR -lnetcdff -lnetcdf" +NETCDF_INCDIR=-I$NETCDF_INC_DIR +IOIPSL_INCDIR=$LMDGCM/../../lib +IOIPSL_LIBDIR=$LMDGCM/../../lib +ORCH_INCDIR=$LMDGCM/../../lib +ORCH_LIBDIR=$LMDGCM/../../lib +OASIS_INCDIR=$LMDGCM/../../prism/X64/build/lib/psmile.$couple +OASIS_LIBDIR=$LMDGCM/../../prism/X64/lib +INCA_LIBDIR=$LMDGCM/../INCA3/config/lib +INCA_INCDIR=$LMDGCM/../INCA3/config/lib + Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-g95.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-g95.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-g95.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER g95 +%LINK g95 +%AR ar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF PLOUF +%BASE_FFLAGS -c +%PROD_FFLAGS -O3 +%DEV_FFLAGS -O +%DEBUG_FFLAGS -fbounds-check -freal=nan -ftrace=full -g -O0 -Wall +%MPI_FFLAGS +%OMP_FFLAGS +%BASE_LD +%MPI_LD +%OMP_LD Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-g95.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-g95.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-g95.path (revision 1634) @@ -0,0 +1,6 @@ +NETCDF_LIBDIR=... +NETCDF_INCDIR=... +IOIPSL_INCDIR=... +IOIPSL_LIBDIR=... +ORCH_INCDIR=... +ORCH_LIBDIR=... Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-gfortran.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-gfortran.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-gfortran.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER gfortran +%LINK gfortran +%AR ar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF PLOUF +%BASE_FFLAGS -c +%PROD_FFLAGS -O3 +%DEV_FFLAGS -O +%DEBUG_FFLAGS -ffpe-trap=invalid,zero,overflow -fbounds-check -g3 -O0 -fstack-protector-all +%MPI_FFLAGS +%OMP_FFLAGS +%BASE_LD +%MPI_LD +%OMP_LD Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-gfortran.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-gfortran.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-gfortran.path (revision 1634) @@ -0,0 +1,6 @@ +NETCDF_LIBDIR=... +NETCDF_INCDIR=... +IOIPSL_INCDIR=... +IOIPSL_LIBDIR=... +ORCH_INCDIR=... +ORCH_LIBDIR=... Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-linux-32bit.fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-linux-32bit.fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-linux-32bit.fcm (revision 1634) @@ -0,0 +1,15 @@ +%COMPILER pgf95 +%LINK pgf95 +%AR ar +%MAKE make +%FPP_FLAGS -P -traditional +%FPP_DEF +%BASE_FFLAGS +%PROD_FFLAGS -fast +%DEV_FFLAGS -g -O1 +%DEBUG_FFLAGS -g -O0 -Kieee -Ktrap=fp -Mbounds +%MPI_FFLAGS +%OMP_FFLAGS +%BASE_LD +%MPI_LD +%OMP_LD Index: LMDZ5/branches/LMDZ5_AR5/arch/arch-linux-32bit.path =================================================================== --- LMDZ5/branches/LMDZ5_AR5/arch/arch-linux-32bit.path (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/arch/arch-linux-32bit.path (revision 1634) @@ -0,0 +1,6 @@ +NETCDF_LIBDIR="-L/usr/local/netcdf-pgi/lib -lnetcdf" +NETCDF_INCDIR=-I/usr/local/netcdf-pgi/include +IOIPSL_INCDIR=... +IOIPSL_LIBDIR=... +ORCH_INCDIR=/u/fairhead/modipsl_ioipsl_3/lib +ORCH_LIBDIR=/u/fairhead/modipsl_ioipsl_3/lib Index: LMDZ5/branches/LMDZ5_AR5/bld.cfg =================================================================== --- LMDZ5/branches/LMDZ5_AR5/bld.cfg (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/bld.cfg (revision 1634) @@ -0,0 +1,107 @@ +# ----------------------- FCM extract configuration file ----------------------- +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ + +#Default value of FPP fortran preprocessor +%FPP cpp + +inc arch.fcm +inc config.fcm + +%CONFIG_NAME %{ARCH}%SUFF_NAME +%BASE_CONFIG_PATH %LIBO/%CONFIG_NAME +%CONFIG_PATH %BASE_CONFIG_PATH/.config +%SRC_PATH %LIBF + +%FFLAGS %BASE_FFLAGS %COMPIL_FFLAGS %PARA_FFLAGS +%LD_FLAGS %BASE_LD %PARA_LD + +src::dyn %SRC_PATH/%DYN +src::phys %SRC_PATH/%PHYS +src::grid %SRC_PATH/grid +src::filtrez %SRC_PATH/filtrez +src::bibio %SRC_PATH/bibio +src::cosp %COSP +src::ext_src %EXT_SRC + +bld::lib::dyn %DYN +bld::lib::phys %PHYS +bld::lib::grid grid +bld::lib::filtrez filtrez +bld::lib::bibio bibio +bld::lib::cosp cosp +bld::lib: ext_src ext_src + + +bld::outfile_ext::exe %SUFF_NAME.e +bld::target lib%{DYN}.a lib%{PHYS}.a libgrid.a libfiltrez.a libbibio.a libcosp.a libext_src.a +bld::target %EXEC%SUFF_NAME.e +bld::exe_dep %{DYN} %{PHYS} grid filtrez bibio cos ext_src + + +dir::root %CONFIG_PATH +dir::lib %BASE_CONFIG_PATH +dir::bin %ROOT_PATH/bin + +#search_src 1 + +bld::tool::fpp %FPP +bld::tool::fc %COMPILER +bld::tool::ld %LINK +bld::tool::ar %AR +bld::tool::make %MAKE +bld::tool::fflags %FFLAGS %INCDIR +bld::tool::ldflags %LD_FLAGS %LIB + +bld::tool::cppflags %FPP_FLAGS %INCDIR +bld::tool::fppflags %FPP_FLAGS %INCDIR +bld::tool::fppkeys %CPP_KEY %FPP_DEF + + +#bld::tool::fflags::phys::readaerosol %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt -pi auto +#bld::tool::fflags::phys::aeropt_2bands %BASE_FFLAGS %PROD_FFLAGS %INCDIR +#bld::tool::fflags::phys::radiation_AR4 %BASE_FFLAGS %PROD_FFLAGS1 %INCDIR -C hopt -Wf,-O,extendreorder +#bld::tool::fflags::phys::radiation_AR4_param %BASE_FFLAGS %PROD_FFLAGS1 %INCDIR -C hopt -f3 +#bld::tool::fflags::phys::fisrtilp %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::phys::cv30_routines %BASE_FFLAGS %PROD_FFLAGS %INCDIR -Wf,-O,extendreorder +#bld::tool::fflags::phys::cvltr %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::phys::clouds_gno %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::dyn::vlsplt_p %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt +#bld::tool::fflags::dyn::groupeun_p %BASE_FFLAGS %PROD_FFLAGS %INCDIR -C hopt + + +inc arch.opt + +# Pre-process code before analysing dependencies +bld::pp 1 + + +# Ignore the following dependencies +bld::excl_dep inc::netcdf.inc +bld::excl_dep use::netcdf +bld::excl_dep use::typesizes +bld::excl_dep h::netcdf.inc +bld::excl_dep h::mpif.h +bld::excl_dep inc::mpif.h +bld::excl_dep use::ioipsl +bld::excl_dep use::intersurf +bld::excl_dep use::mod_prism_proto +bld::excl_dep use::mod_prism_def_partition_proto +bld::excl_dep use::mod_prism_get_proto +bld::excl_dep use::mod_prism_put_proto +bld::excl_dep use::mkl_dfti + +# Don't generate interface files +bld::tool::geninterface none + +# Allow ".inc" as an extension for CPP include files +bld::infile_ext::inc CPP::INCLUDE + +# extension for module output +bld::outfile_ext::mod .mod +bld::tool::SHELL /bin/bash Index: LMDZ5/branches/LMDZ5_AR5/build_gcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/build_gcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/build_gcm (revision 1634) @@ -0,0 +1,27 @@ +#!/bin/bash + +if test -f '.lock' + then + echo 'ATTENTION: vous etes sans doute en train de compiler le modele par ailleurs' + echo "Attendez que la premiere compilation soit terminee pour relancer la suivante." + echo "Si vous etes sur que vous ne compilez pas le modele par ailleurs," + echo "vous pouvez continuer en repondant oui." + echo "Voulez-vous vraiment continuer?" + read ouinon + if [[ $ouinon == "oui" ]] + then + echo OK + else + exit + fi +else + echo "compilation en cours..." > '.lock' +fi + +#set arch=$1 + + +fcm build + +\rm -f '.lock' + Index: LMDZ5/branches/LMDZ5_AR5/config.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/config.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/config.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/config.def Index: LMDZ5/branches/LMDZ5_AR5/cosp_input_nl.txt =================================================================== --- LMDZ5/branches/LMDZ5_AR5/cosp_input_nl.txt (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/cosp_input_nl.txt (revision 1634) @@ -0,0 +1,104 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +! Namelist that sets up the main COSP options +&COSP_INPUT + CMOR_NL='./cmor/cosp_cmor_nl.txt', ! CMOR namelist + NPOINTS=9026,! Number of gridpoints (klon dans LMDZi : ici correspond a klon de 96x95) + NPOINTS_IT=10000,! Max number of gridpoints to be processed in one iteration + NCOLUMNS=20, ! Number of subcolumns + NLEVELS=39, ! Number of model levels + USE_VGRID=.true., ! Use fixed vertical grid for outputs? (if .true. then you need to define number of levels with Nlr) + NLR=40, ! Number of levels in statistical outputs (only used if USE_VGRID=.true.) + CSAT_VGRID=.true., ! CloudSat vertical grid? (if .true. then the CloudSat standard grid is used for the outputs. + ! USE_VGRID needs also be .true.) + FINPUT='histday.nc', ! NetCDF file with 1D inputs +! FINPUT='cosp_input_um_2d.nc', ! NetCDF file with 2D inputs + !---------------------------------------------------------------------------------- + !--------------- Inputs related to radar simulations + !---------------------------------------------------------------------------------- + RADAR_FREQ=94.0, ! CloudSat radar frequency (GHz) + SURFACE_RADAR=0, ! surface=1, spaceborne=0 + use_mie_tables=0,! use a precomputed lookup table? yes=1,no=0 + use_gas_abs=1, ! include gaseous absorption? yes=1,no=0 + do_ray=0, ! calculate/output Rayleigh refl=1, not=0 + melt_lay=0, ! melting layer model off=0, on=1 + k2=-1, ! |K|^2, -1=use frequency dependent default + use_reff=.true., ! True if you want effective radius to be used by radar simulator (always used by lidar) + use_precipitation_fluxes=.true., ! True if precipitation fluxes are input to the algorithm + !---------------------------------------------------------------------------------- + !---------------- Inputs related to lidar simulations + !---------------------------------------------------------------------------------- + Nprmts_max_hydro=12, ! Max number of parameters for hydrometeor size distributions + Naero=1, ! Number of aerosol species (Not used) + Nprmts_max_aero=1, ! Max number of parameters for aerosol size distributions (Not used) + lidar_ice_type=0, ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical) + OVERLAP=3, ! overlap type: 1=max, 2=rand, 3=max/rand + !---------------------------------------------------------------------------------- + !---------------- Inputs related to ISCCP simulator + !---------------------------------------------------------------------------------- + ISCCP_TOPHEIGHT=1, ! 1 = adjust top height using both a computed + ! infrared brightness temperature and the visible + ! optical depth to adjust cloud top pressure. Note + ! that this calculation is most appropriate to compare + ! to ISCCP data during sunlit hours. + ! 2 = do not adjust top height, that is cloud top + ! pressure is the actual cloud top pressure + ! in the model + ! 3 = adjust top height using only the computed + ! infrared brightness temperature. Note that this + ! calculation is most appropriate to compare to ISCCP + ! IR only algortihm (i.e. you can compare to nighttime + ! ISCCP data with this option) + ISCCP_TOPHEIGHT_DIRECTION=1, ! direction for finding atmosphere pressure level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 1 = find the *lowest* altitude (highest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 2 = find the *highest* altitude (lowest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! 1 = default setting, and matches all versions of + ! ISCCP simulator with versions numbers 3.5.1 and lower + ! 2 = experimental setting + !---------------------------------------------------------------------------------- + !-------------- RTTOV inputs + !---------------------------------------------------------------------------------- + Platform=1, ! satellite platform + Satellite=15, ! satellite + Instrument=0, ! instrument + Nchannels=8, ! Number of channels to be computed + Channels=1,3,5,6,8,10,11,13, ! Channel numbers (please be sure that you supply Nchannels) + Surfem=0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, ! Surface emissivity (please be sure that you supply Nchannels) + ZenAng=50.0, ! Satellite Zenith Angle + CO2=5.241e-04, ! Mixing ratios of trace gases + CH4=9.139e-07, + N2O=4.665e-07, + CO=2.098e-07 +/ + + Index: LMDZ5/branches/LMDZ5_AR5/cosp_output_nl.txt =================================================================== --- LMDZ5/branches/LMDZ5_AR5/cosp_output_nl.txt (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/cosp_output_nl.txt (revision 1634) @@ -0,0 +1,63 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! Namelist that sets up output-related variables. It controls +! the instrument simulators to run and the list of variables +! to be written to file +&COSP_OUTPUT + ! Simulator flags + Lradar_sim=.false., + Llidar_sim=.true., + Lisccp_sim=.true., + Lmisr_sim=.false., + ! Output variables + Lalbisccp=.true., + Latb532=.true., + Lboxptopisccp=.true., + Lboxtauisccp=.true., + Lcfad_dbze94=.false., + Lcfad_lidarsr532=.true., + Lclcalipso=.true., + Lclhcalipso=.true., + Lclisccp2=.true., + Lcllcalipso=.true., + Lclmcalipso=.true., + Lcltcalipso=.true., + Lctpisccp=.true., + Ldbze94=.false., + Ltauisccp=.true., + Ltclisccp=.true., + Llongitude=.false., + Llatitude=.false., + Lparasol_refl=.true., + LclMISR=.false., + Lmeantbisccp=.true., + Lmeantbclrisccp=.true., + ! Use lidar and radar + Lclcalipso2=.false., + Lcltlidarradar=.false., + ! These are provided for debugging or special purposes + Lfrac_out=.false., + Lbeta_mol532=.true., +/ Index: LMDZ5/branches/LMDZ5_AR5/create_make_gcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/create_make_gcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/create_make_gcm (revision 1634) @@ -0,0 +1,234 @@ +#!/bin/sh +# +# $Id$ +# +#set -xv +machine=`hostname` +os=`uname` +gcm=`pwd` +libf=$gcm/libf +libo=$gcm/libo +CRAY=0 +if [ "$machine" = "atlas" -o "$machine" = "etoile" -o "$machine" = "axis" ] ; then + CRAY=1 +fi +XNEC=0 +if [ "$machine" = "rhodes" ] ; then + XNEC=1 +fi +X6NEC=0 +if [ "$machine" = "mercure" ] ; then + X6NEC=1 +fi +X8BRODIE=0 +if [ "$machine" = "brodie" ] ; then + X8BRODIE=1 +fi +VPP=0 +if [ "$machine" = "nymphea0" ] ; then + VPP=1 +fi +# +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Definitions de Macros pour Make" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo +echo "# Repertoires :" +echo +echo "GCM = "$gcm +echo 'LIBF = $(GCM)/libf' +if [ "$CRAY" = '0' ] ; then +# echo 'LIBO = $(GCM)/libo/$(MACHINE)' + echo 'LIBO = $(LIBOGCM)/$(MACHINE)' +else + echo 'LIBO = $(GCM)/libo' +fi +#echo 'LOCAL_DIR=$(GCM)' +#echo $localdir +echo "LOCAL_DIR=`echo $localdir`" +echo 'BIBIO = $(LIBF)/bibio' +echo "FILTRE = filtre" +echo "PHYS = " +echo "DYN = dyn " +echo 'LIBPHY = $(LIBO)/libphy$(PHYS).a' +echo 'DIRMAIN=dyn$(DIM)d$(FLAG_PARA)' +echo 'RM=rm' +echo +echo "OPLINK = " +echo +echo '# Les differentes librairies pour l"edition des liens:' +echo +echo 'dyn3d = $(LIBO)/libdyn3d.a $(LIBO)/lib$(FILTRE).a' +echo 'dyn3dpar = $(LIBO)/libdyn3dpar.a $(LIBO)/lib$(FILTRE).a' +echo 'dyn2d = $(LIBO)/libdyn2d.a' +echo 'dyn1d = $(LIBO)/libdyn1d.a' +echo 'L_DYN = -ldyn$(DIM)d$(FLAG_PARA)' +echo 'L_FILTRE = -l$(FILTRE)' +echo 'L_PHY = -lphy$(PHYS) ' +echo 'L_BIBIO = -lbibio' +echo 'L_ADJNT =' +echo 'L_COSP = -lcosp' + +echo +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Option de compilation FORTRAN" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo + echo 'COMPILE = $(F77) $(OPTIM) $(INCLUDE) -c' + echo 'COMPILE90 = $(F90) $(OPTIM90) $(INCLUDE) -c' + echo 'COMPTRU90 = $(F90) $(OPTIMTRU90) $(INCLUDE) -c' + echo "LINK = $LINK" + echo "AR = $AR" +echo +echo +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Creation des differents executables" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo +echo "# Executables:" +echo "# ------------" +echo +echo "PROG = code" +echo +#echo 'main : chimie $(DYN) bibio phys $(OPTION_DEP) ' +echo 'main : $(DYN) bibio phys $(OPTION_DEP) ' +echo ' cd $(LIBO) ; $(RANLIB) lib*.a ; cd $(GCM) ;\' +echo ' cd $(LOCAL_DIR); \' +echo ' $(COMPILE90) $(LIBF)/$(DIRMAIN)/$(SOURCE) -o $(PROG).o ; \' +echo ' $(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_COSP) $(L_FILTRE) $(L_PHY) $(L_DYN) $(L_BIBIO) $(L_DYN) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o ' +echo +echo 'dyn : $(LIBO)/libdyn$(DIM)d$(FLAG_PARA).a $(FILTRE)$(DIM)d' +echo +echo 'phys : $(LIBPHY)' +echo +#echo 'chimie : $(LIBO)/libchimie.a' +echo +echo 'bibio : $(LIBO)/libbibio.a' +echo +echo 'adjnt : $(LIBO)/libadjnt.a' +echo +echo 'cosp : $(LIBO)/libcosp.a' +echo +echo '$(FILTRE)3d : $(LIBO)/lib$(FILTRE).a' +echo +echo '$(FILTRE)2d :' +echo +echo '$(FILTRE)1d :' +echo +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo "# Contenu des differentes bibliotheques" +echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%" +echo +echo +cd $libf >/dev/null 2>&1 +for diri in ` ls ` +do + if [ -d $diri ] ; then + if [ "`ls $diri/*.F`" != "" ] || [ "`ls $diri/*.F90`" != "" ] ; then + cd $diri >/dev/null 2>&1 + echo + listlib="" + for i in `ls *.F` + do + fili=`basename $i .F` + test=` ( head $i | grep ' PROGRAM' ) ` + if [ "$test" = "" ] ; then + listlib=$listlib" "$fili + fi + done + for i in `ls *.F90` + do + fili=`basename $i .F90` + test=` ( head $i | grep ' PROGRAM' ) ` + if [ "$test" = "" ] ; then + listlib=$listlib" "$fili + fi + done +# + echo + echo + echo "#=======================================================================" + echo "# Contenu de la bibliotheque correspondant au Directory "$diri + echo "#=======================================================================" + echo + for fili in $listlib + do + echo '$(LIBO)/lib'$diri".a : " '$(LIBO)/lib'$diri".a("$fili".o)" + echo + done + echo '.PRECIOUS : $(LIBO)/lib'$diri'.a' + echo + echo + echo "# Compilation des membres de la bibliotheque lib"$diri".a" + echo + for fili in $listlib + do + if [ -f $fili.F90 ] ; then + trufile=$fili.F90 + else + trufile=$fili.F + fi + F90=0 ; egrep -i '^ *use ' $trufile > /dev/null 2>&1 && F90=1 + egrep -i '^ *module ' $trufile > /dev/null 2>&1 && F90=1 + egrep -i '#include*.inc ' $trufile > /dev/null 2>&1 && F90=1 + str1='$(LIBO)/lib'$diri'.a('$fili'.o) : $(LIBF)/'$diri/$trufile + [ "$fili" = "chem.subs" ] && str1=$str1' $(LIBF)/'$diri/chem.mods.F + for stri in ` ( sed -n "/\#include/s/\#include//p" $trufile | sed 's/\"//g' ; egrep -i '^ *use ' $trufile | sed -e 's/,/ /' | awk ' { print $2 } ' ) ` + do + + +# Differents cas de dependance correspondant a des include ou des +# use module. +# soit dans le repertoire local soit dans un autre. + + stri=`echo $stri | tr [A-Z] [a-z]` + if [ -f $stri ] ; then + echo $str1 \\ + str1='$(LIBF)/'$diri'/'$stri + else + if [ -f $stri.F ] || [ -f $stri.F90 ] ; then + echo $str1 \\ + str1='$(LIBO)/lib'$diri'.a('$stri'.o)' + else + for dirinc in dyn3d grid bibio filtrez + do + if [ -f ../$dirinc/$stri ] ; then + echo $str1 \\ + str1='$(LIBF)/'`cd .. ; ls */$stri | head -1` + fi + if [ -f ../$dirinc/$stri.F90 ] ; then + echo $str1 \\ + str1='$(LIBO)/lib'$dirinc'.a('$stri'.o)' + fi + done + fi + fi + done + echo $str1 + # Compile in LIBO directory; and before compiling, remove + # object from library + echo ' cd $(LIBO); \' + echo ' $(AR) d $(LIBO)/lib'$diri'.a '$fili'.o ; \' + if [ "$F90" -eq '0' ] ; then + ## Fixed Form Fortran 77 + echo ' $(COMPILE) $(LIBF)/'$diri'/'$trufile' ; \' + else + ## Fortran 90 + if [ -f $fili.F90 ] ; then + ## Free Form + echo ' $(COMPTRU90) $(LIBF)/'$diri'/'$trufile' ; \' + else + echo ' $(COMPILE90) $(LIBF)/'$diri'/'$trufile' ; \' + fi + fi + # Put generated object in library + echo ' $(AR) r $(LIBO)/lib'$diri'.a '$fili'.o ; $(RM) '$fili'.o ; \' + echo ' cd $(GCM)' + echo + done +# + echo + cd $libf + fi + fi +done Index: LMDZ5/branches/LMDZ5_AR5/gcm.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/gcm.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/gcm.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/gcm.def Index: LMDZ5/branches/LMDZ5_AR5/guide.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/guide.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/guide.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/guide.def Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/arth.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/arth.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/arth.F90 (revision 1634) @@ -0,0 +1,82 @@ +MODULE arth_m + + IMPLICIT NONE + + INTEGER, PARAMETER, private:: NPAR_ARTH=16, NPAR2_ARTH=8 + + INTERFACE arth + ! Returns an arithmetic progression, given a first term "first", an + ! increment and a number of terms "n". + + MODULE PROCEDURE arth_r, arth_i + ! The difference between the procedures is the type of + ! arguments "first" and "increment" and of function result. + END INTERFACE + + private arth_r, arth_i + +CONTAINS + + pure FUNCTION arth_r(first,increment,n) + + REAL, INTENT(IN) :: first,increment + INTEGER, INTENT(IN) :: n + REAL, DIMENSION(n) :: arth_r + + ! Variables local to the procedure: + + INTEGER :: k,k2 + REAL :: temp + + !--------------------------------------- + + if (n > 0) arth_r(1)=first + if (n <= NPAR_ARTH) then + do k=2,n + arth_r(k)=arth_r(k-1)+increment + end do + else + do k=2,NPAR2_ARTH + arth_r(k)=arth_r(k-1)+increment + end do + temp=increment*NPAR2_ARTH + k=NPAR2_ARTH + do + if (k >= n) exit + k2=k+k + arth_r(k+1:min(k2,n)) = temp + arth_r(1:min(k,n-k)) + temp=temp+temp + k=k2 + end do + end if + END FUNCTION arth_r + + !************************************* + + pure FUNCTION arth_i(first,increment,n) + + INTEGER, INTENT(IN) :: first,increment,n + INTEGER, DIMENSION(n) :: arth_i + INTEGER :: k,k2,temp + if (n > 0) arth_i(1)=first + if (n <= NPAR_ARTH) then + do k=2,n + arth_i(k)=arth_i(k-1)+increment + end do + else + do k=2,NPAR2_ARTH + arth_i(k)=arth_i(k-1)+increment + end do + temp=increment*NPAR2_ARTH + k=NPAR2_ARTH + do + if (k >= n) exit + k2=k+k + arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k)) + temp=temp+temp + k=k2 + end do + end if + END FUNCTION arth_i + +END MODULE arth_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/assert_eq_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/assert_eq_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/assert_eq_m.F90 (revision 1634) @@ -0,0 +1,70 @@ +! $Id$ +MODULE assert_eq_m + + implicit none + + INTERFACE assert_eq + MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn + END INTERFACE + + private assert_eq2,assert_eq3,assert_eq4,assert_eqn + +CONTAINS + + FUNCTION assert_eq2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2 + INTEGER assert_eq2 + if (n1 == n2) then + assert_eq2=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string + print *, 'program terminated by assert_eq2' + stop 1 + end if + END FUNCTION assert_eq2 + !BL + FUNCTION assert_eq3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3 + INTEGER assert_eq3 + if (n1 == n2 .and. n2 == n3) then + assert_eq3=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string + print *, 'program terminated by assert_eq3' + stop 1 + end if + END FUNCTION assert_eq3 + !BL + FUNCTION assert_eq4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3,n4 + INTEGER assert_eq4 + if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then + assert_eq4=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string,n1,n2,n3,n4 + print *, 'program terminated by assert_eq4' + stop 1 + end if + END FUNCTION assert_eq4 + !BL + FUNCTION assert_eqn(nn,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, DIMENSION(:), INTENT(IN) :: nn + INTEGER assert_eqn + if (all(nn(2:) == nn(1))) then + assert_eqn=nn(1) + else + write (*,*) 'nrerror: an assert_eq failed with this tag: ', & + string + print *, 'program terminated by assert_eqn' + stop 1 + end if + END FUNCTION assert_eqn + +END MODULE assert_eq_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/assert_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/assert_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/assert_m.F90 (revision 1634) @@ -0,0 +1,69 @@ +! $Id$ +MODULE assert_m + + implicit none + + INTERFACE assert + MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v + END INTERFACE + + private assert1,assert2,assert3,assert4,assert_v + +CONTAINS + + SUBROUTINE assert1(n1,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1 + if (.not. n1) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert1' + stop 1 + end if + END SUBROUTINE assert1 + !BL + SUBROUTINE assert2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2 + if (.not. (n1 .and. n2)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert2' + stop 1 + end if + END SUBROUTINE assert2 + !BL + SUBROUTINE assert3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3 + if (.not. (n1 .and. n2 .and. n3)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert3' + stop 1 + end if + END SUBROUTINE assert3 + !BL + SUBROUTINE assert4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3,n4 + if (.not. (n1 .and. n2 .and. n3 .and. n4)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert4' + stop 1 + end if + END SUBROUTINE assert4 + !BL + SUBROUTINE assert_v(n,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, DIMENSION(:), INTENT(IN) :: n + if (.not. all(n)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + print *, 'program terminated by assert_v' + stop 1 + end if + END SUBROUTINE assert_v + +END MODULE assert_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/chfev.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/chfev.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/chfev.F (revision 1634) @@ -0,0 +1,155 @@ +*DECK CHFEV + SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR) +C***BEGIN PROLOGUE CHFEV +C***PURPOSE Evaluate a cubic polynomial given in Hermite form at an +C array of points. While designed for use by PCHFE, it may +C be useful directly as an evaluator for a piecewise cubic +C Hermite function in applications, such as graphing, where +C the interval is known in advance. +C***LIBRARY SLATEC (PCHIP) +C***CATEGORY E3 +C***TYPE SINGLE PRECISION (CHFEV-S, DCHFEV-D) +C***KEYWORDS CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION, +C PCHIP +C***AUTHOR Fritsch, F. N., (LLNL) +C Lawrence Livermore National Laboratory +C P.O. Box 808 (L-316) +C Livermore, CA 94550 +C FTS 532-4275, (510) 422-4275 +C***DESCRIPTION +C +C CHFEV: Cubic Hermite Function EValuator +C +C Evaluates the cubic polynomial determined by function values +C F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points +C XE(J), J=1(1)NE. +C +C ---------------------------------------------------------------------- +C +C Calling sequence: +C +C INTEGER NE, NEXT(2), IERR +C REAL X1, X2, F1, F2, D1, D2, XE(NE), FE(NE) +C +C CALL CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR) +C +C Parameters: +C +C X1,X2 -- (input) endpoints of interval of definition of cubic. +C (Error return if X1.EQ.X2 .) +C +C F1,F2 -- (input) values of function at X1 and X2, respectively. +C +C D1,D2 -- (input) values of derivative at X1 and X2, respectively. +C +C NE -- (input) number of evaluation points. (Error return if +C NE.LT.1 .) +C +C XE -- (input) real array of points at which the function is to be +C evaluated. If any of the XE are outside the interval +C [X1,X2], a warning error is returned in NEXT. +C +C FE -- (output) real array of values of the cubic function defined +C by X1,X2, F1,F2, D1,D2 at the points XE. +C +C NEXT -- (output) integer array indicating number of extrapolation +C points: +C NEXT(1) = number of evaluation points to left of interval. +C NEXT(2) = number of evaluation points to right of interval. +C +C IERR -- (output) error flag. +C Normal return: +C IERR = 0 (no errors). +C "Recoverable" errors: +C IERR = -1 if NE.LT.1 . +C IERR = -2 if X1.EQ.X2 . +C (The FE-array has not been changed in either case.) +C +C***REFERENCES (NONE) +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 811019 DATE WRITTEN +C 820803 Minor cosmetic changes for release 1. +C 890411 Added SAVE statements (Vers. 3.2). +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890703 Corrected category record. (WRB) +C 890703 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE CHFEV +C Programming notes: +C +C To produce a double precision version, simply: +C a. Change CHFEV to DCHFEV wherever it occurs, +C b. Change the real declaration to double precision, and +C c. Change the constant ZERO to double precision. +C +C DECLARE ARGUMENTS. +C + INTEGER NE, NEXT(2), IERR + REAL X1, X2, F1, F2, D1, D2, XE(*), FE(*) +C +C DECLARE LOCAL VARIABLES. +C + INTEGER I + REAL C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO + SAVE ZERO + DATA ZERO /0./ +C +C VALIDITY-CHECK ARGUMENTS. +C +C***FIRST EXECUTABLE STATEMENT CHFEV + IF (NE .LT. 1) GO TO 5001 + H = X2 - X1 + IF (H .EQ. ZERO) GO TO 5002 +C +C INITIALIZE. +C + IERR = 0 + NEXT(1) = 0 + NEXT(2) = 0 + XMI = MIN(ZERO, H) + XMA = MAX(ZERO, H) +C +C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). +C + DELTA = (F2 - F1)/H + DEL1 = (D1 - DELTA)/H + DEL2 = (D2 - DELTA)/H +C (DELTA IS NO LONGER NEEDED.) + C2 = -(DEL1+DEL1 + DEL2) + C3 = (DEL1 + DEL2)/H +C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) +C +C EVALUATION LOOP. +C + DO 500 I = 1, NE + X = XE(I) - X1 + FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) +C COUNT EXTRAPOLATION POINTS. + IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 + IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 +C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) + 500 CONTINUE +C +C NORMAL RETURN. +C + RETURN +C +C ERROR RETURNS. +C + 5001 CONTINUE +C NE.LT.1 RETURN. + IERR = -1 + CALL XERMSG ('SLATEC', 'CHFEV', + + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) + RETURN +C + 5002 CONTINUE +C X1.EQ.X2 RETURN. + IERR = -2 + CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR, + + 1) + RETURN +C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------ + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/fdump.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/fdump.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/fdump.F (revision 1634) @@ -0,0 +1,31 @@ +*DECK FDUMP + SUBROUTINE FDUMP +C***BEGIN PROLOGUE FDUMP +C***PURPOSE Symbolic dump (should be locally written). +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (FDUMP-A) +C***KEYWORDS ERROR, XERMSG +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C ***Note*** Machine Dependent Routine +C FDUMP is intended to be replaced by a locally written +C version which produces a symbolic dump. Failing this, +C it should be replaced by a version which prints the +C subprogram nesting list. Note that this dump must be +C printed on each of up to five files, as indicated by the +C XGETUA routine. See XSETUA and XGETUA for details. +C +C Written by Ron Jones, with SLATEC Common Math Library Subcommittee +C +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE FDUMP +C***FIRST EXECUTABLE STATEMENT FDUMP + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/formcoord.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/formcoord.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/formcoord.F (revision 1634) @@ -0,0 +1,54 @@ +! +! $Header$ +! + subroutine formcoord(unit,n,x,a,rev,text) + implicit none + integer n,unit,ndec + logical rev + real x(n),a + character*4 text + + integer i,id,i1,i2,in + real dx,dxmin + + if(rev) then + id=-1 + i1=n + i2=n-1 + in=1 + write(unit,3000) text(1:1) + else + id=1 + i1=1 + i2=2 + in=n + endif + + if (n.lt.2) then + ndec=1 + write(unit,1000) text,n,x(1)*a + else + dxmin=abs(x(2)-x(1)) + do i=2,n-1 + dx=abs(x(i+1)-x(i)) + if (dx.lt.dxmin) dxmin=dx + enddo + + ndec=-log10(dxmin)+2 + if(mod(n,6).eq.1) then + write(unit,1000) text,n,x(i1)*a + write(unit,2000) (x(i)*a,i=i2,in,id) + else + write(unit,1000) text,n + write(unit,2000) (x(i)*a,i=i1,in,id) + endif + endif + +1000 format(a4,2x,i4,' LEVELS',43x,f12.2) +2000 format(6f12.2) +c1000 format(a4,2x,i4,' LEVELS',43x,f12.) +c2000 format(6f12.) +3000 format('FORMAT ',a1,'REV') + return + + end Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/handle_err_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/handle_err_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/handle_err_m.F90 (revision 1634) @@ -0,0 +1,46 @@ +! $Id$ +module handle_err_m + + implicit none + +contains + + subroutine handle_err(message, ncerr, ncid, varid) + + use netcdf, only: nf90_strerror, nf90_noerr, nf90_close + + character(len=*), intent(in):: message + ! (should include name of calling procedure) + + integer, intent(in):: ncerr + + integer, intent(in), optional :: ncid + ! (Provide this argument if you want "handle_err" to try to close + ! the file.) + + integer, intent(in), optional :: varid + + ! Variable local to the procedure: + integer ncerr_close + + !------------------- + + if (ncerr /= nf90_noerr) then + print *, message, ":" + if (present(varid)) print *, "varid = ", varid + print *, trim(nf90_strerror(ncerr)) + if (present(ncid)) then + ! Try to close, to leave the file in a consistent state: + ncerr_close = nf90_close(ncid) + ! (do not call "nf95_close", we do not want to recurse) + if (ncerr_close /= nf90_noerr) then + print *, "nf90_close:" + print *, trim(nf90_strerror(ncerr_close)) + end if + end if + stop 1 + end if + + end subroutine handle_err + +end module handle_err_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/i1mach.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/i1mach.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/i1mach.F (revision 1634) @@ -0,0 +1,126 @@ +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +C I1MACH( 1) = the standard input unit. +C I1MACH( 2) = the standard output unit. +C I1MACH( 3) = the standard punch unit. +C I1MACH( 4) = the standard error message unit. +C +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +C I1MACH( 7) = A, the base. +C I1MACH( 8) = S, the number of base-A digits. +C I1MACH( 9) = A**S - 1, the largest magnitude. +C +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +C Single-Precision: +C I1MACH(11) = T, the number of base-B digits. +C I1MACH(12) = EMIN, the smallest exponent E. +C I1MACH(13) = EMAX, the largest exponent E. +C +C Double-Precision: +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C 100623 Use Fortran 95 intrinsic functions (Lionel GUEZ) +C***END PROLOGUE I1MACH +C + INTEGER IMACH(16),OUTPUT + SAVE IMACH + EQUIVALENCE (IMACH(4),OUTPUT) +C***FIRST EXECUTABLE STATEMENT I1MACH + IMACH( 1) = 5 + IMACH( 2) = 6 + IMACH( 3) = 6 + IMACH( 4) = 6 + IMACH( 5) = bit_size(0) + IMACH( 6) = IMACH( 5) / 8 + IMACH( 7) = radix(0) + IMACH( 8) = digits(0) + IMACH( 9) = huge(0) + IMACH(10) = radix(0.) + IMACH(11) = digits(0.) + IMACH(12) = minexponent(0.) + IMACH(13) = maxexponent(0.) + IMACH(14) = digits(0d0) + IMACH(15) = minexponent(0d0) + IMACH(16) = maxexponent(0d0) + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/initdynav.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/initdynav.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/initdynav.F (revision 1634) @@ -0,0 +1,200 @@ +! +! $Id$ +! + subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt) + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac, ONLY : nqtot, ttext + use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, & + & dynhistave_file,dynhistvave_file,dynhistuave_file + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL. Initialisation du fichier histoire moyenne. +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep : frequence d'ecriture +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + integer day0, anne0 + real tstep, t_ops, t_wrt + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid, zvertiid + integer ii,jj + integer zan, dayref +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + +! Creation de 3 fichiers pour les differentes grilles horizontales +! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier +! Grille Scalaire + call histbeg(dynhistave_file, iip1, rlong(:,1), jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, thoriid,histaveid) + +C Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) +! Grille V + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + call histbeg(dynhistvave_file, iip1, rlong(:,1), jjm, rlat(1,:), + . 1, iip1, 1, jjm, + . tau0, zjulian, tstep, vhoriid,histvaveid) +! Grille U + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histbeg(dynhistuave_file, iip1, rlong(:,1),jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, uhoriid,histuaveid) +C +C Appel a histvert pour la grille verticale +C + call histvert(histaveid,'presnivs','Niveaux Pression + & approximatifs','mb',llm, presnivs/100., zvertiid,'down') + call histvert(histuaveid,'presnivs','Niveaux Pression + & approximatifs','mb',llm, presnivs/100., zvertiid,'down') + call histvert(histvaveid,'presnivs','Niveaux Pression + & approximatifs','mb',llm, presnivs/100., zvertiid,'down') +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C +! write(6,*)'inithistave',tstep + call histdef(histuaveid, 'u', 'vent u moyen ', + . 'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C Vents V +C + call histdef(histvaveid, 'v', 'vent v moyen', + . 'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Temperature +C + call histdef(histaveid, 'temp', 'temperature moyenne', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Temperature potentielle +C + call histdef(histaveid, 'theta', 'temperature potentielle', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Geopotentiel +C + call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Traceurs +C +! DO iq=1,nqtot +! call histdef(histaveid, ttext(iq), ttext(iq), '-', +! . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, +! . 32, 'ave(X)', t_ops, t_wrt) +! enddo +C +C Masse +C + call histdef(histaveid, 'masse', 'masse', 'kg', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Geopotentiel au sol +C +! call histdef(histaveid, 'phis', 'geopotentiel au sol', '-', +! . iip1, jjp1, thoriid, 1, 1, 1, -99, +! . 32, 'ave(X)', t_ops, t_wrt) +!C +C Fin +C + call histend(histaveid) + call histend(histuaveid) + call histend(histvaveid) +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"initdynav: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/initfluxsto.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/initfluxsto.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/initfluxsto.F (revision 1634) @@ -0,0 +1,233 @@ +! +! $Id$ +! + subroutine initfluxsto + . (infile,tstep,t_ops,t_wrt, + . fileid,filevid,filedid) + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + real tstep, t_ops, t_wrt + integer fileid, filevid,filedid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + real nivd(1) + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1) + integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid + integer ii,jj + integer zan, idayref + logical ok_sync +C +C Initialisations +C + pi = 4. * atan (1.) + str='q ' + ctrac = 'traceur ' + ok_sync = .true. +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = annee_ref + idayref = day_ref + CALL ymds2ju(zan, 1, idayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, uhoriid, fileid) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + call histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:), + . 1, iip1, 1, jjm, + . tau0, zjulian, tstep, vhoriid, filevid) + + rl(1,1) = 1. + call histbeg('defstoke.nc', 1, rl, 1, rl, + . 1, 1, 1, 1, + . tau0, zjulian, tstep, dhoriid, filedid) + +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar', + . 'Grille points scalaires', thoriid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +c pour le fichier def + nivd(1) = 1 + call histvert(filedid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . 1, nivd, dvertiid) + +C +C Appels a histdef pour la definition des variables a sauvegarder + + CALL histdef(fileid, "phis", "Surface geop. height", "-", + . iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(fileid, "aire", "Grid area", "-", + . iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "dtvr", "tps dyn", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istdyn", "tps stock", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istphy", "tps stock phy", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + +C +C Masse +C + call histdef(fileid, 'masse', 'Masse', 'kg', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pbaru +C + call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', + . iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Pbarv +C + call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', + . iip1, jjm, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C w +C + call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) + call histend(filedid) + if (ok_sync) then + call histsync(fileid) + call histsync(filevid) + call histsync(filedid) + endif + +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"initfluxsto: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/inithist.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/inithist.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/inithist.F (revision 1634) @@ -0,0 +1,197 @@ +! +! $Id$ +! + subroutine inithist(day0,anne0,tstep,t_ops,t_wrt) + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac, ONLY : nqtot, ttext + use com_io_dyn_mod, only : histid,histvid,histuid, & + & dynhist_file,dynhistv_file,dynhistu_file + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C nq: nombre de traceurs +C +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + integer day0, anne0 + real tstep, t_ops, t_wrt + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid, zvertiid + integer ii,jj + integer zan, dayref +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + +! ------------------------------------------------------------- +! Creation des 3 fichiers pour les grilles horizontales U,V,Scal +! ------------------------------------------------------------- +!Grille U + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histbeg(dynhistu_file, iip1, rlong(:,1), jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, uhoriid, histuid) + +! Grille V + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + call histbeg(dynhistv_file, iip1, rlong(:,1), jjm, rlat(1,:), + . 1, iip1, 1, jjm, + . tau0, zjulian, tstep, vhoriid, histvid) + +!Grille Scalaire + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + call histbeg(dynhist_file, iip1, rlong(:,1), jjp1, rlat(1,:), + . 1, iip1, 1, jjp1, + . tau0, zjulian, tstep, thoriid, histid) +! ------------------------------------------------------------- +C Appel a histvert pour la grille verticale +! ------------------------------------------------------------- + call histvert(histid, 'presnivs', 'Niveaux pression','mb', + . llm, presnivs/100., zvertiid,'down') + call histvert(histvid, 'presnivs', 'Niveaux pression','mb', + . llm, presnivs/100., zvertiid,'down') + call histvert(histuid, 'presnivs', 'Niveaux pression','mb', + . llm, presnivs/100., zvertiid,'down') +C +! ------------------------------------------------------------- +C Appels a histdef pour la definition des variables a sauvegarder +! ------------------------------------------------------------- +C +C Vents U +C + call histdef(histuid, 'u', 'vent u', 'm/s', + . iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Vents V +C + call histdef(histvid, 'v', 'vent v', 'm/s', + . iip1, jjm, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + call histdef(histid, 'teta', 'temperature potentielle', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Geopotentiel +C + call histdef(histid, 'phi', 'geopotentiel', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Traceurs +C +! +! DO iq=1,nqtot +! call histdef(histid, ttext(iq), ttext(iq), '-', +! . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, +! . 32, 'inst(X)', t_ops, t_wrt) +! enddo +!C +C Masse +C + call histdef(histid, 'masse', 'masse', 'kg', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Geopotentiel au sol +!C +! call histdef(histid, 'phis', 'geopotentiel au sol', '-', +! . iip1, jjp1, thoriid, 1, 1, 1, -99, +! . 32, 'inst(X)', t_ops, t_wrt) +!C +C Fin +C + call histend(histid) + call histend(histuid) + call histend(histvid) +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"inithist: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/interpolation.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/interpolation.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/interpolation.F90 (revision 1634) @@ -0,0 +1,138 @@ +! $Id$ +module interpolation + + ! From Press et al., 1996, version 2.10a + ! B3 Interpolation and Extrapolation + + IMPLICIT NONE + +contains + + pure FUNCTION locate(xx,x) + + REAL, DIMENSION(:), INTENT(IN) :: xx + REAL, INTENT(IN) :: x + INTEGER locate + + ! Given an array xx(1:N), and given a value x, returns a value j, + ! between 0 and N, such that x is between xx(j) and xx(j + 1). xx + ! must be monotonic, either increasing or decreasing. j = 0 or j = + ! N is returned to indicate that x is out of range. This + ! procedure should not be called with a zero-sized array argument. + ! See notes. + + INTEGER n,jl,jm,ju + LOGICAL ascnd + + !---------------------------- + + n=size(xx) + ascnd = (xx(n) >= xx(1)) + ! (True if ascending order of table, false otherwise.) + ! Initialize lower and upper limits: + jl=0 + ju=n+1 + do while (ju-jl > 1) + jm=(ju+jl)/2 ! Compute a midpoint, + if (ascnd .eqv. (x >= xx(jm))) then + jl=jm ! and replace either the lower limit + else + ju=jm ! or the upper limit, as appropriate. + end if + end do + ! {ju == jl + 1} + + ! {(ascnd .and. xx(jl) <= x < xx(jl+1)) + ! .neqv. + ! (.not. ascnd .and. xx(jl+1) <= x < xx(jl))} + + ! Then set the output, being careful with the endpoints: + if (x == xx(1)) then + locate=1 + else if (x == xx(n)) then + locate=n-1 + else + locate=jl + end if + + END FUNCTION locate + + !*************************** + + pure SUBROUTINE hunt(xx,x,jlo) + + ! Given an array xx(1:N ), and given a value x, returns a value + ! jlo such that x is between xx(jlo) and xx(jlo+1). xx must be + ! monotonic, either increasing or decreasing. jlo = 0 or jlo = N is + ! returned to indicate that x is out of range. jlo on input is taken as + ! the initial guess for jlo on output. + ! Modified so that it uses the information "jlo = 0" on input. + + INTEGER, INTENT(INOUT) :: jlo + REAL, INTENT(IN) :: x + REAL, DIMENSION(:), INTENT(IN) :: xx + INTEGER n,inc,jhi,jm + LOGICAL ascnd, hunt_up + + !----------------------------------------------------- + + n=size(xx) + ascnd = (xx(n) >= xx(1)) + ! (True if ascending order of table, false otherwise.) + if (jlo < 0 .or. jlo > n) then + ! Input guess not useful. Go immediately to bisection. + jlo=0 + jhi=n+1 + else + inc=1 ! Set the hunting increment. + if (jlo == 0) then + hunt_up = .true. + else + hunt_up = x >= xx(jlo) .eqv. ascnd + end if + if (hunt_up) then ! Hunt up: + do + jhi=jlo+inc + if (jhi > n) then ! Done hunting, since off end of table. + jhi=n+1 + exit + else + if (x < xx(jhi) .eqv. ascnd) exit + jlo=jhi ! Not done hunting, + inc=inc+inc ! so double the increment + end if + end do ! and try again. + else ! Hunt down: + jhi=jlo + do + jlo=jhi-inc + if (jlo < 1) then ! Done hunting, since off end of table. + jlo=0 + exit + else + if (x >= xx(jlo) .eqv. ascnd) exit + jhi=jlo ! Not done hunting, + inc=inc+inc ! so double the increment + end if + end do ! and try again. + end if + end if ! Done hunting, value bracketed. + + do ! Hunt is done, so begin the final bisection phase: + if (jhi-jlo <= 1) then + if (x == xx(n)) jlo=n-1 + if (x == xx(1)) jlo=1 + exit + else + jm=(jhi+jlo)/2 + if (x >= xx(jm) .eqv. ascnd) then + jlo=jm + else + jhi=jm + end if + end if + end do + + END SUBROUTINE hunt + +end module interpolation Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_errioipsl.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_errioipsl.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_errioipsl.F90 (revision 1634) @@ -0,0 +1,219 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_errioipsl +!- +!$Id: errioipsl.f90 386 2008-09-04 08:38:48Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg +!- + INTEGER :: n_l=6, ilv_cur=0, ilv_max=0 + LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE. +!- +!=== +CONTAINS +!=== +SUBROUTINE ipslnlf (new_number,old_number) +!!-------------------------------------------------------------------- +!! The "ipslnlf" routine allows to know and modify +!! the current logical number for the messages. +!! +!! SUBROUTINE ipslnlf (new_number,old_number) +!! +!! Optional INPUT argument +!! +!! (I) new_number : new logical number of the file +!! +!! Optional OUTPUT argument +!! +!! (I) old_number : current logical number of the file +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(IN) :: new_number + INTEGER,OPTIONAL,INTENT(OUT) :: old_number +!--------------------------------------------------------------------- + IF (PRESENT(old_number)) THEN + old_number = n_l + ENDIF + IF (PRESENT(new_number)) THEN + n_l = new_number + ENDIF +!--------------------- +END SUBROUTINE ipslnlf +!=== +SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!! The "ipslerr" routine +!! allows to handle the messages to the user. +!! +!! INPUT +!! +!! plev : Category of message to be reported to the user +!! 1 = Note to the user +!! 2 = Warning to the user +!! 3 = Fatal error +!! pcname : Name of subroutine which has called ipslerr +!! pstr1 +!! pstr2 : Strings containing the explanations to the user +!! pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + ilv_cur = plev + ilv_max = MAX(ilv_max,plev) + WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3) + ENDIF + IF ( (plev == 3).AND.lact_mode) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE ipslerr +!=== +SUBROUTINE ipslerr_act (new_mode,old_mode) +!!-------------------------------------------------------------------- +!! The "ipslerr_act" routine allows to know and modify +!! the current "action mode" for the error messages, +!! and reinitialize the error level values. +!! +!! SUBROUTINE ipslerr_act (new_mode,old_mode) +!! +!! Optional INPUT argument +!! +!! (I) new_mode : new error action mode +!! .TRUE. -> STOP in case of fatal error +!! .FALSE. -> CONTINUE in case of fatal error +!! +!! Optional OUTPUT argument +!! +!! (I) old_mode : current error action mode +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_mode + LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode +!--------------------------------------------------------------------- + IF (PRESENT(old_mode)) THEN + old_mode = lact_mode + ENDIF + IF (PRESENT(new_mode)) THEN + lact_mode = new_mode + ENDIF + ilv_cur = 0 + ilv_max = 0 +!------------------------- +END SUBROUTINE ipslerr_act +!=== +SUBROUTINE ipslerr_inq (current_level,maximum_level) +!!-------------------------------------------------------------------- +!! The "ipslerr_inq" routine allows to know +!! the current level of the error messages +!! and the maximum level encountered since the +!! last call to "ipslerr_act". +!! +!! SUBROUTINE ipslerr_inq (current_level,maximum_level) +!! +!! Optional OUTPUT argument +!! +!! (I) current_level : current error level +!! (I) maximum_level : maximum error level +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level +!--------------------------------------------------------------------- + IF (PRESENT(current_level)) THEN + current_level = ilv_cur + ENDIF + IF (PRESENT(maximum_level)) THEN + maximum_level = ilv_max + ENDIF +!------------------------- +END SUBROUTINE ipslerr_inq +!=== +SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!- INPUT +!- plev : Category of message to be reported to the user +!- 1 = Note to the user +!- 2 = Warning to the user +!- 3 = Fatal error +!- pcname : Name of subroutine which has called histerr +!- pstr1 +!- pstr2 : String containing the explanations to the user +!- pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + WRITE(*,'(" ")') + WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(*,'(" --> ",A)') pstr1 + WRITE(*,'(" --> ",A)') pstr2 + WRITE(*,'(" --> ",A)') pstr3 + ENDIF + IF (plev == 3) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE histerr +!=== +SUBROUTINE ipsldbg (new_status,old_status) +!!-------------------------------------------------------------------- +!! The "ipsldbg" routine +!! allows to activate or deactivate the debug, +!! and to know the current status of the debug. +!! +!! SUBROUTINE ipsldbg (new_status,old_status) +!! +!! Optional INPUT argument +!! +!! (L) new_status : new status of the debug +!! +!! Optional OUTPUT argument +!! +!! (L) old_status : current status of the debug +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_status + LOGICAL,OPTIONAL,INTENT(OUT) :: old_status +!--------------------------------------------------------------------- + IF (PRESENT(old_status)) THEN + old_status = ioipsl_debug + ENDIF + IF (PRESENT(new_status)) THEN + ioipsl_debug = new_status + ENDIF +!--------------------- +END SUBROUTINE ipsldbg +!=== +!------------------- +END MODULE ioipsl_errioipsl Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_getincom.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_getincom.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_getincom.F90 (revision 1634) @@ -0,0 +1,1980 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_getincom +!- +!$Id: getincom.f90 536 2009-01-30 11:46:27Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +USE ioipsl_errioipsl, ONLY : ipslerr +USE ioipsl_stringop, & + & ONLY : nocomma,cmpblank,strlowercase +!- +IMPLICIT NONE +!- +PRIVATE +PUBLIC :: getin, getin_dump +!- +INTERFACE getin +!!-------------------------------------------------------------------- +!! The "getin" routines get a variable. +!! We first check if we find it in the database +!! and if not we get it from the run.def file. +!! +!! SUBROUTINE getin (target,ret_val) +!! +!! INPUT +!! +!! (C) target : Name of the variable +!! +!! OUTPUT +!! +!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain +!! that will contain the (standard) +!! integer/real/character/logical values +!!-------------------------------------------------------------------- + MODULE PROCEDURE getinrs, getinr1d, getinr2d, & + & getinis, getini1d, getini2d, & + & getincs, getinc1d, getinc2d, & + & getinls, getinl1d, getinl2d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "getin_dump" routine will dump the content of the database +!! into a file which has the same format as the run.def file. +!! The idea is that the user can see which parameters were used +!! and re-use the file for another run. +!! +!! SUBROUTINE getin_dump (fileprefix) +!! +!! OPTIONAL INPUT argument +!! +!! (C) fileprefix : allows the user to change the name of the file +!! in which the data will be archived +!!-------------------------------------------------------------------- +!- + INTEGER,PARAMETER :: max_files=100 + CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist + INTEGER,SAVE :: nbfiles +!- + INTEGER,PARAMETER :: i_txtslab=1000,l_n=30 + INTEGER,SAVE :: nb_lines,i_txtsize=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier + CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline +!- + INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15 + CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)' +!- +! The data base of parameters +!- + INTEGER,PARAMETER :: memslabs=200 + INTEGER,PARAMETER :: compress_lim=20 +!- + INTEGER,SAVE :: nb_keys=0 + INTEGER,SAVE :: keymemsize=0 +!- +! keystr definition +! name of a key +!- +! keystatus definition +! keystatus = 1 : Value comes from run.def +! keystatus = 2 : Default value is used +! keystatus = 3 : Some vector elements were taken from default +!- +! keytype definition +! keytype = 1 : Integer +! keytype = 2 : Real +! keytype = 3 : Character +! keytype = 4 : Logical +!- + INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4 +!- +! Allow compression for keys (only for integer and real) +! keycompress < 0 : not compressed +! keycompress > 0 : number of repeat of the value +!- +TYPE :: t_key + CHARACTER(LEN=l_n) :: keystr + INTEGER :: keystatus, keytype, keycompress, & + & keyfromfile, keymemstart, keymemlen +END TYPE t_key +!- + TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab +!- + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem + INTEGER,SAVE :: i_memsize=0, i_mempos=0 + REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem + INTEGER,SAVE :: r_memsize=0, r_mempos=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem + INTEGER,SAVE :: c_memsize=0, c_mempos=0 + LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem + INTEGER,SAVE :: l_memsize=0, l_mempos=0 +!- +CONTAINS +!- +!=== INTEGER INTERFACE +!- +SUBROUTINE getinis (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: ret_val +!- + INTEGER,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,i_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinis +!=== +SUBROUTINE getini1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getini1d +!=== +SUBROUTINE getini2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:,:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getini2d +!- +!=== REAL INTERFACE +!- +SUBROUTINE getinrs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL :: ret_val +!- + REAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,r_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinrs +!=== +SUBROUTINE getinr1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinr1d +!=== +SUBROUTINE getinr2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:,:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinr2d +!- +!=== CHARACTER INTERFACE +!- +SUBROUTINE getincs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,c_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getincs +!=== +SUBROUTINE getinc1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinc1d +!=== +SUBROUTINE getinc2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinc2d +!- +!=== LOGICAL INTERFACE +!- +SUBROUTINE getinls (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL :: ret_val +!- + LOGICAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,l_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinls +!=== +SUBROUTINE getinl1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinl1d +!=== +SUBROUTINE getinl2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:,:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinl2d +!- +!=== Generic file/database INTERFACE +!- +SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Subroutine that will extract from the file the values +!- attributed to the keyword target +!- +!- (C) target : target for which we will look in the file +!- (I) status : tells us from where we obtained the data +!- (I) fileorig : index of the file from which the key comes +!- (I) i_val(:) : INTEGER(nb_to_ret) values +!- (R) r_val(:) : REAL(nb_to_ret) values +!- (L) l_val(:) : LOGICAL(nb_to_ret) values +!- (C) c_val(:) : CHARACTER(nb_to_ret) values +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,INTENT(OUT) :: status,fileorig + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=80) :: str_READ,str_READ_lower + CHARACTER(LEN=9) :: c_vtyp + LOGICAL,DIMENSION(:),ALLOCATABLE :: found + LOGICAL :: def_beha,compressed + CHARACTER(LEN=10) :: c_fmt + INTEGER :: i_cmpval + REAL :: r_cmpval + INTEGER :: ipos_tr,ipos_fl +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + SELECT CASE (k_typ) + CASE(k_i) + nb_to_ret = SIZE(i_val) + CASE(k_r) + nb_to_ret = SIZE(r_val) + CASE(k_c) + nb_to_ret = SIZE(c_val) + CASE(k_l) + nb_to_ret = SIZE(l_val) + CASE DEFAULT + CALL ipslerr (3,'get_fil', & + & 'Internal error','Unknown type of data',' ') + END SELECT +!- +! Read the file(s) + CALL getin_read +!- +! Allocate and initialize the memory we need + ALLOCATE(found(nb_to_ret)) + found(:) = .FALSE. +!- +! See what we find in the files read + DO it=1,nb_to_ret +!--- +!-- First try the target as it is + CALL get_findkey (2,target,pos) +!--- +!-- Another try +!--- + IF (pos < 0) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + CALL get_findkey (2,TRIM(target)//'__'//cnt,pos) + ENDIF +!--- +!-- We dont know from which file the target could come. +!-- Thus by default we attribute it to the first file : + fileorig = 1 +!--- + IF (pos > 0) THEN +!----- + found(it) = .TRUE. + fileorig = fromfile(pos) +!----- +!---- DECODE +!----- + str_READ = ADJUSTL(fichier(pos)) + str_READ_lower = str_READ + CALL strlowercase (str_READ_lower) +!----- + IF ( (TRIM(str_READ_lower) == 'def') & + & .OR.(TRIM(str_READ_lower) == 'default') ) THEN + def_beha = .TRUE. + ELSE + def_beha = .FALSE. + len_str = LEN_TRIM(str_READ) + io_err = 0 + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str + READ (UNIT=str_READ(1:len_str), & + & FMT=c_fmt,IOSTAT=io_err) i_val(it) + CASE(k_r) + READ (UNIT=str_READ(1:len_str), & + & FMT=*,IOSTAT=io_err) r_val(it) + CASE(k_c) + c_val(it) = str_READ(1:len_str) + CASE(k_l) + ipos_tr = -1 + ipos_fl = -1 + ipos_tr = MAX(INDEX(str_READ_lower,'tru'), & + & INDEX(str_READ_lower,'y')) + ipos_fl = MAX(INDEX(str_READ_lower,'fal'), & + & INDEX(str_READ_lower,'n')) + IF (ipos_tr > 0) THEN + l_val(it) = .TRUE. + ELSE IF (ipos_fl > 0) THEN + l_val(it) = .FALSE. + ELSE + io_err = 100 + ENDIF + END SELECT + IF (io_err /= 0) THEN + CALL ipslerr (3,'get_fil', & + & 'Target '//TRIM(target), & + & 'is not of '//TRIM(c_vtyp)//' type',' ') + ENDIF + ENDIF +!----- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!------- +!------ Is this the value of a compressed field ? + compressed = (compline(pos) > 0) + IF (compressed) THEN + IF (compline(pos) /= nb_to_ret) THEN + CALL ipslerr (2,'get_fil', & + & 'For key '//TRIM(target)//' we have a compressed field', & + & 'which does not have the right size.', & + & 'We will try to fix that.') + ENDIF + IF (k_typ == k_i) THEN + i_cmpval = i_val(it) + ELSE IF (k_typ == k_r) THEN + r_cmpval = r_val(it) + ENDIF + ENDIF + ENDIF + ELSE + found(it) = .FALSE. + def_beha = .FALSE. + compressed = .FALSE. + ENDIF + ENDDO +!- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!--- +!-- If this is a compressed field then we will uncompress it + IF (compressed) THEN + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + IF (k_typ == k_i) THEN + i_val(it) = i_cmpval + ELSE IF (k_typ == k_r) THEN + ENDIF + found(it) = .TRUE. + ENDIF + ENDDO + ENDIF + ENDIF +!- +! Now we set the status for what we found + IF (def_beha) THEN + status = 2 + WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target) + ELSE + status_cnt = 0 + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + status_cnt = status_cnt+1 + IF (status_cnt <= max_msgs) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & + & ADVANCE='NO') TRIM(target) + IF (nb_to_ret > 1) THEN + WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') + WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it + ENDIF + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=*,FMT=*) "=",i_val(it) + CASE(k_r) + WRITE (UNIT=*,FMT=*) "=",r_val(it) + CASE(k_c) + WRITE (UNIT=*,FMT=*) "=",c_val(it) + CASE(k_l) + WRITE (UNIT=*,FMT=*) "=",l_val(it) + END SELECT + ELSE IF (status_cnt == max_msgs+1) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)') + ENDIF + ENDIF + ENDDO +!--- + IF (status_cnt == 0) THEN + status = 1 + ELSE IF (status_cnt == nb_to_ret) THEN + status = 2 + ELSE + status = 3 + ENDIF + ENDIF +! Deallocate the memory + DEALLOCATE(found) +!--------------------- +END SUBROUTINE get_fil +!=== +SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Read the required variable in the database +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: pos,size_of_in + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,k_beg,k_end + CHARACTER(LEN=9) :: c_vtyp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_rdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- + IF (key_tab(pos)%keytype /= k_typ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong data type for keyword '//TRIM(target), & + & '(NOT '//TRIM(c_vtyp)//')',' ') + ENDIF +!- + IF (key_tab(pos)%keycompress > 0) THEN + IF ( (key_tab(pos)%keycompress /= size_of_in) & + & .OR.(key_tab(pos)%keymemlen /= 1) ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong compression length','for keyword '//TRIM(target),' ') + ELSE + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart) + CASE(k_r) + r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart) + END SELECT + ENDIF + ELSE + IF (key_tab(pos)%keymemlen /= size_of_in) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong array length','for keyword '//TRIM(target),' ') + ELSE + k_beg = key_tab(pos)%keymemstart + k_end = k_beg+key_tab(pos)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(k_beg:k_end) + CASE(k_r) + r_val(1:size_of_in) = r_mem(k_beg:k_end) + CASE(k_c) + c_val(1:size_of_in) = c_mem(k_beg:k_end) + CASE(k_l) + l_val(1:size_of_in) = l_mem(k_beg:k_end) + END SELECT + ENDIF + ENDIF +!--------------------- +END SUBROUTINE get_rdb +!=== +SUBROUTINE get_wdb & + & (target,status,fileorig,size_of_in, & + & i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Write data into the data base +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: status,fileorig,size_of_in + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ + CHARACTER(LEN=9) :: c_vtyp + INTEGER :: k_mempos,k_memsize,k_beg,k_end + LOGICAL :: l_cmp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_wdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- +! First check if we have sufficiant space for the new key + IF (nb_keys+1 > keymemsize) THEN + CALL getin_allockeys () + ENDIF +!- + SELECT CASE (k_typ) + CASE(k_i) + k_mempos = i_mempos; k_memsize = i_memsize; + l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_r) + k_mempos = r_mempos; k_memsize = r_memsize; + l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_c) + k_mempos = c_mempos; k_memsize = c_memsize; + l_cmp = .FALSE. + CASE(k_l) + k_mempos = l_mempos; k_memsize = l_memsize; + l_cmp = .FALSE. + END SELECT +!- +! Fill out the items of the data base + nb_keys = nb_keys+1 + key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n)) + key_tab(nb_keys)%keystatus = status + key_tab(nb_keys)%keytype = k_typ + key_tab(nb_keys)%keyfromfile = fileorig + key_tab(nb_keys)%keymemstart = k_mempos+1 + IF (l_cmp) THEN + key_tab(nb_keys)%keycompress = size_of_in + key_tab(nb_keys)%keymemlen = 1 + ELSE + key_tab(nb_keys)%keycompress = -1 + key_tab(nb_keys)%keymemlen = size_of_in + ENDIF +!- +! Before writing the actual size lets see if we have the space + IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen & + & > k_memsize) THEN + CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen) + ENDIF +!- + k_beg = key_tab(nb_keys)%keymemstart + k_end = k_beg+key_tab(nb_keys)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen) + i_mempos = k_end + CASE(k_r) + r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen) + r_mempos = k_end + CASE(k_c) + c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen) + c_mempos = k_end + CASE(k_l) + l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen) + l_mempos = k_end + END SELECT +!--------------------- +END SUBROUTINE get_wdb +!- +!=== +!- +SUBROUTINE getin_read +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,SAVE :: allread=0 + INTEGER,SAVE :: current +!--------------------------------------------------------------------- + IF (allread == 0) THEN +!-- Allocate a first set of memory. + CALL getin_alloctxt () + CALL getin_allockeys () + CALL getin_allocmem (k_i,0) + CALL getin_allocmem (k_r,0) + CALL getin_allocmem (k_c,0) + CALL getin_allocmem (k_l,0) +!-- Start with reading the files + nbfiles = 1 + filelist(1) = 'run.def' + current = 1 +!-- + DO WHILE (current <= nbfiles) + CALL getin_readdef (current) + current = current+1 + ENDDO + allread = 1 + CALL getin_checkcohe () + ENDIF +!------------------------ +END SUBROUTINE getin_read +!- +!=== +!- + SUBROUTINE getin_readdef(current) +!--------------------------------------------------------------------- +!- This subroutine will read the files and only keep the +!- the relevant information. The information is kept as it +!- found in the file. The data will be analysed later. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: current +!- + CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt + INTEGER :: nb_lastkey +!- + INTEGER :: eof,ptn,len_str,i,it,iund,io_err + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + eof = 0 + ptn = 1 + nb_lastkey = 0 +!- + IF (check) THEN + WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) + ENDIF +!- + OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err) + IF (io_err /= 0) THEN + CALL ipslerr (2,'getin_readdef', & + & 'Could not open file '//TRIM(filelist(current)),' ',' ') + RETURN + ENDIF +!- + DO WHILE (eof /= 1) +!--- + CALL getin_skipafew (22,READ_str,eof,nb_lastkey) + len_str = LEN_TRIM(READ_str) + ptn = INDEX(READ_str,'=') +!--- + IF (ptn > 0) THEN +!---- Get the target + key_str = TRIM(ADJUSTL(READ_str(1:ptn-1))) +!---- Make sure that a vector keyword has the right length + iund = INDEX(key_str,'__') + IF (iund > 0) THEN + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') & + & LEN_TRIM(key_str)-iund-1 + READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), & + & FMT=c_fmt,IOSTAT=io_err) it + IF ( (io_err == 0).AND.(it > 0) ) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + key_str = key_str(1:iund+1)//cnt + ELSE + CALL ipslerr (3,'getin_readdef', & + & 'A very strange key has just been found :', & + & TRIM(key_str),' ') + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str))) + CALL nocomma (NEW_str) + CALL cmpblank (NEW_str) + NEW_str = TRIM(ADJUSTL(NEW_str)) + IF (check) THEN + WRITE(*,*) & + & '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) + ENDIF +!---- Decypher the content of NEW_str +!- +!---- This has to be a new key word, thus : + nb_lastkey = 0 +!---- + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) +!---- + ELSE IF (len_str > 0) THEN +!---- Prepare the key if we have an old one to which +!---- we will add the line just read + IF (nb_lastkey > 0) THEN + iund = INDEX(last_key,'__') + IF (iund > 0) THEN +!-------- We only continue a keyword, thus it is easy + key_str = last_key(1:iund-1) + ELSE + IF (nb_lastkey /= 1) THEN + CALL ipslerr (3,'getin_readdef', & + & 'We can not have a scalar keyword', & + & 'and a vector content',' ') + ENDIF +!-------- The last keyword needs to be transformed into a vector. + WRITE(UNIT=cnt,FMT=c_i_fmt) 1 + targetlist(nb_lines) = & + & last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt + key_str = last_key(1:LEN_TRIM(last_key)) + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(1:len_str))) + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) + ELSE +!---- If we have an empty line then the keyword finishes + nb_lastkey = 0 + IF (check) THEN + WRITE(*,*) 'getin_readdef : Have found an emtpy line ' + ENDIF + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + IF (check) THEN + OPEN (UNIT=22,file='run.def.test') + DO i=1,nb_lines + WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i) + ENDDO + CLOSE(UNIT=22) + ENDIF +!--------------------------- +END SUBROUTINE getin_readdef +!- +!=== +!- +SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey) +!--------------------------------------------------------------------- +!- This subroutine is going to decypher the line. +!- It essentialy checks how many items are included and +!- it they can be attached to a key. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: current,nb_lastkey + CHARACTER(LEN=*) :: key_str,NEW_str,last_key +!- +! LOCAL +!- + INTEGER :: len_str,blk,nbve,starpos + CHARACTER(LEN=100) :: tmp_str,new_key,mult + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt +!--------------------------------------------------------------------- + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + tmp_str = NEW_str(1:len_str) +!- +! If the key is a new file then we take it up. Else +! we save the line and go on. +!- + IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN + DO WHILE (blk > 0) + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!----- + nbfiles = nbfiles+1 + filelist(nbfiles) = tmp_str(1:blk) +!----- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ') + ENDDO +!--- + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!--- + nbfiles = nbfiles+1 + filelist(nbfiles) = TRIM(ADJUSTL(tmp_str)) +!--- + last_key = 'INCLUDEDEF' + nb_lastkey = 1 + ELSE +!- +!-- We are working on a new line of input +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 +!- +!-- First we solve the issue of conpressed information. Once +!-- this is done all line can be handled in the same way. +!- + starpos = INDEX(NEW_str(1:len_str),'*') + IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') & + & .AND.(tmp_str(1:1) /= "'") ) THEN +!----- + IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We can not have a compressed field of values', & + & 'in a vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str)) + ENDIF +!- +!---- Read the multiplied +!- + mult = TRIM(ADJUSTL(NEW_str(1:starpos-1))) +!---- Construct the new string and its parameters + NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str))) + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + IF (blk > 1) THEN + CALL ipslerr (2,'getin_decrypt', & + & 'This is a strange behavior','you could report',' ') + ENDIF + WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult) + READ(UNIT=mult,FMT=c_fmt) compline(nb_lines) +!--- + ELSE + compline(nb_lines) = -1 + ENDIF +!- +!-- If there is no space wthin the line then the target is a scalar +!-- or the element of a properly written vector. +!-- (ie of the type TARGET__00001) +!- + IF ( (blk <= 1) & + & .OR.(tmp_str(1:1) == '"') & + & .OR.(tmp_str(1:1) == "'") ) THEN +!- + IF (nb_lastkey == 0) THEN +!------ Save info of current keyword as a scalar +!------ if it is not a continuation + targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + nb_lastkey = 1 + ELSE +!------ We are continuing a vector so the keyword needs +!------ to get the underscores + WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1 + targetlist(nb_lines) = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nb_lastkey+1 + ENDIF +!----- + fichier(nb_lines) = NEW_str(1:len_str) + fromfile(nb_lines) = current + ELSE +!- +!---- If there are blanks whithin the line then we are dealing +!---- with a vector and we need to split it in many entries +!---- with the TARGET__n notation. +!---- +!---- Test if the targer is not already a vector target ! +!- + IF (INDEX(TRIM(key_str),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We have found a mixed vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str),' ') + ENDIF +!- + nbve = nb_lastkey + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + DO WHILE (blk > 0) +!- +!------ Save the content of target__nbve +!- + fichier(nb_lines) = tmp_str(1:blk) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(TRIM(tmp_str),' ') +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + ENDDO +!- +!---- Save the content of the last target +!- + fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nbve +!- + ENDIF +!- + ENDIF +!--------------------------- +END SUBROUTINE getin_decrypt +!- +!=== +!- +SUBROUTINE getin_checkcohe () +!--------------------------------------------------------------------- +!- This subroutine checks for redundancies. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: line,n_k,k +!--------------------------------------------------------------------- + DO line=1,nb_lines-1 +!- + n_k = 0 + DO k=line+1,nb_lines + IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN + n_k = k + EXIT + ENDIF + ENDDO +!--- +!-- IF we have found it we have a problem to solve. +!--- + IF (n_k > 0) THEN + WRITE(*,*) 'COUNT : ',n_k + WRITE(*,*) & + & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) + WRITE(*,*) & + & 'getin_checkcohe : The following values were encoutered :' + WRITE(*,*) & + & ' ',TRIM(targetlist(line)),' == ',fichier(line) + WRITE(*,*) & + & ' ',TRIM(targetlist(k)),' == ',fichier(k) + WRITE(*,*) & + & 'getin_checkcohe : We will keep only the last value' + targetlist(line) = ' ' + ENDIF + ENDDO +!----------------------------- +END SUBROUTINE getin_checkcohe +!- +!=== +!- +SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: unit,eof,nb_lastkey + CHARACTER(LEN=100) :: dummy + CHARACTER(LEN=100) :: out_string + CHARACTER(LEN=1) :: first +!--------------------------------------------------------------------- + first="#" + eof = 0 + out_string = " " +!- + DO WHILE (first == "#") + READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy + dummy = TRIM(ADJUSTL(dummy)) + first=dummy(1:1) + IF (first == "#") THEN + nb_lastkey = 0 + ENDIF + ENDDO + out_string=dummy +!- + RETURN +!- +9998 CONTINUE + CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ') +!- +7778 CONTINUE + eof = 1 +!---------------------------- +END SUBROUTINE getin_skipafew +!- +!=== +!- +SUBROUTINE getin_allockeys () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab + CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + IF (keymemsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp,FMT=*) memslabs + ALLOCATE(key_tab(memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + nb_keys = 0 + keymemsize = memslabs + key_tab(:)%keycompress = -1 +!--- + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp,FMT=*) keymemsize + ALLOCATE(tmp_key_tab(keymemsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate tmp_key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs + tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize) + DEALLOCATE(key_tab) + ALLOCATE(key_tab(keymemsize+memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + key_tab(:)%keycompress = -1 + key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize) + DEALLOCATE(tmp_key_tab) + keymemsize = keymemsize+memslabs + ENDIF +!----------------------------- +END SUBROUTINE getin_allockeys +!- +!=== +!- +SUBROUTINE getin_allocmem (type,len_wanted) +!--------------------------------------------------------------------- +!- Allocate the memory of the data base for all 4 types of memory +!- INTEGER / REAL / CHARACTER / LOGICAL +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: type,len_wanted +!- + INTEGER,ALLOCATABLE :: tmp_int(:) + REAL,ALLOCATABLE :: tmp_real(:) + CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) + LOGICAL,ALLOCATABLE :: tmp_logic(:) + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + SELECT CASE (type) + CASE(k_i) + IF (i_memsize == 0) THEN + ALLOCATE(i_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_memsize=memslabs + ELSE + ALLOCATE(tmp_int(i_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_int(1:i_memsize) = i_mem(1:i_memsize) + DEALLOCATE(i_mem) + ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_mem(1:i_memsize) = tmp_int(1:i_memsize) + i_memsize = i_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_int) + ENDIF + CASE(k_r) + IF (r_memsize == 0) THEN + ALLOCATE(r_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_memsize = memslabs + ELSE + ALLOCATE(tmp_real(r_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_real', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_real(1:r_memsize) = r_mem(1:r_memsize) + DEALLOCATE(r_mem) + ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_mem(1:r_memsize) = tmp_real(1:r_memsize) + r_memsize = r_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_real) + ENDIF + CASE(k_c) + IF (c_memsize == 0) THEN + ALLOCATE(c_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_memsize = memslabs + ELSE + ALLOCATE(tmp_char(c_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_char', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_char(1:c_memsize) = c_mem(1:c_memsize) + DEALLOCATE(c_mem) + ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_mem(1:c_memsize) = tmp_char(1:c_memsize) + c_memsize = c_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_char) + ENDIF + CASE(k_l) + IF (l_memsize == 0) THEN + ALLOCATE(l_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_memsize = memslabs + ELSE + ALLOCATE(tmp_logic(l_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_logic', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_logic(1:l_memsize) = l_mem(1:l_memsize) + DEALLOCATE(l_mem) + ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_mem(1:l_memsize) = tmp_logic(1:l_memsize) + l_memsize = l_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_logic) + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ') + END SELECT +!---------------------------- +END SUBROUTINE getin_allocmem +!- +!=== +!- +SUBROUTINE getin_alloctxt () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:) + CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:) + INTEGER,ALLOCATABLE :: tmp_int(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp1,c_tmp2 +!--------------------------------------------------------------------- + IF (i_txtsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtslab + ALLOCATE(fichier(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(targetlist(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(fromfile(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(compline(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + nb_lines = 0 + i_txtsize = i_txtslab + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtsize + WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab + ALLOCATE(tmp_fic(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_fic', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_fic(1:i_txtsize) = fichier(1:i_txtsize) + DEALLOCATE(fichier) + ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fichier(1:i_txtsize) = tmp_fic(1:i_txtsize) + DEALLOCATE(tmp_fic) +!--- + ALLOCATE(tmp_tgl(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_tgl', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize) + DEALLOCATE(targetlist) + ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize) + DEALLOCATE(tmp_tgl) +!--- + ALLOCATE(tmp_int(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_int(1:i_txtsize) = fromfile(1:i_txtsize) + DEALLOCATE(fromfile) + ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fromfile(1:i_txtsize) = tmp_int(1:i_txtsize) +!--- + tmp_int(1:i_txtsize) = compline(1:i_txtsize) + DEALLOCATE(compline) + ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + compline(1:i_txtsize) = tmp_int(1:i_txtsize) + DEALLOCATE(tmp_int) +!--- + i_txtsize = i_txtsize+i_txtslab + ENDIF +!---------------------------- +END SUBROUTINE getin_alloctxt +!- +!=== +!- +SUBROUTINE getin_dump (fileprefix) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(*),OPTIONAL :: fileprefix +!- + CHARACTER(LEN=80) :: usedfileprefix + INTEGER :: ikey,if,iff,iv + CHARACTER(LEN=20) :: c_tmp + CHARACTER(LEN=100) :: tmp_str,used_filename + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (PRESENT(fileprefix)) THEN + usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80)) + ELSE + usedfileprefix = "used" + ENDIF +!- + DO if=1,nbfiles +!--- + used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if)) + IF (check) THEN + WRITE(*,*) & + & 'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if + WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys + ENDIF + OPEN (UNIT=22,FILE=used_filename) +!--- +!-- If this is the first file we need to add the list +!-- of file which belong to it + IF ( (if == 1).AND.(nbfiles > 1) ) THEN + WRITE(22,*) '# ' + WRITE(22,*) '# This file is linked to the following files :' + WRITE(22,*) '# ' + DO iff=2,nbfiles + WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) + ENDDO + WRITE(22,*) '# ' + ENDIF +!--- + DO ikey=1,nb_keys +!----- +!---- Is this key from this file ? + IF (key_tab(ikey)%keyfromfile == if) THEN +!------- +!------ Write some comments + WRITE(22,*) '#' + SELECT CASE (key_tab(ikey)%keystatus) + CASE(1) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' comes from the run.def.' + CASE(2) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' are all defaults.' + CASE(3) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr), & + & ' are a mix of run.def and defaults.' + CASE DEFAULT + WRITE(22,*) '# Dont know from where the value of ', & + & TRIM(key_tab(ikey)%keystr),' comes.' + END SELECT + WRITE(22,*) '#' +!------- +!------ Write the values + SELECT CASE (key_tab(ikey)%keytype) + CASE(k_i) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',i_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',i_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',i_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_r) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',r_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',r_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',r_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_c) + IF (key_tab(ikey)%keymemlen == 1) THEN + tmp_str = c_mem(key_tab(ikey)%keymemstart) + WRITE(22,*) TRIM(key_tab(ikey)%keystr), & + & ' = ',TRIM(tmp_str) + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + tmp_str = c_mem(key_tab(ikey)%keymemstart+iv) + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',TRIM(tmp_str) + ENDDO + ENDIF + CASE(k_l) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (l_mem(key_tab(ikey)%keymemstart)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE ' + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = FALSE ' + ENDIF + ENDDO + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_dump', & + & 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), & + & ' ',' ') + END SELECT + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + ENDDO +!------------------------ +END SUBROUTINE getin_dump +!=== +SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v) +!--------------------------------------------------------------------- +!- Returns the type of the argument (mutually exclusive) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(OUT) :: k_typ + CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp + INTEGER,DIMENSION(:),OPTIONAL :: i_v + REAL,DIMENSION(:),OPTIONAL :: r_v + LOGICAL,DIMENSION(:),OPTIONAL :: l_v + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v +!--------------------------------------------------------------------- + k_typ = 0 + IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) & + & /= 1) THEN + CALL ipslerr (3,'get_qtyp', & + & 'Invalid number of optional arguments','(/= 1)',' ') + ENDIF +!- + IF (PRESENT(i_v)) THEN + k_typ = k_i + c_vtyp = 'INTEGER' + ELSEIF (PRESENT(r_v)) THEN + k_typ = k_r + c_vtyp = 'REAL' + ELSEIF (PRESENT(c_v)) THEN + k_typ = k_c + c_vtyp = 'CHARACTER' + ELSEIF (PRESENT(l_v)) THEN + k_typ = k_l + c_vtyp = 'LOGICAL' + ENDIF +!---------------------- +END SUBROUTINE get_qtyp +!=== +SUBROUTINE get_findkey (i_tab,c_key,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a key in a table +!--------------------------------------------------------------------- +!- INPUT +!- i_tab : 1 -> search in key_tab(1:nb_keys)%keystr +!- 2 -> search in targetlist(1:nb_lines) +!- c_key : Name of the key we are looking for +!- OUTPUT +!- pos : -1 if key not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: i_tab + CHARACTER(LEN=*),INTENT(in) :: c_key + INTEGER,INTENT(out) :: pos +!- + INTEGER :: ikey_max,ikey + CHARACTER(LEN=l_n) :: c_q_key +!--------------------------------------------------------------------- + pos = -1 + IF (i_tab == 1) THEN + ikey_max = nb_keys + ELSEIF (i_tab == 2) THEN + ikey_max = nb_lines + ELSE + ikey_max = 0 + ENDIF + IF ( ikey_max > 0 ) THEN + DO ikey=1,ikey_max + IF (i_tab == 1) THEN + c_q_key = key_tab(ikey)%keystr + ELSE + c_q_key = targetlist(ikey) + ENDIF + IF (TRIM(c_q_key) == TRIM(c_key)) THEN + pos = ikey + EXIT + ENDIF + ENDDO + ENDIF +!------------------------- +END SUBROUTINE get_findkey +!=== +!------------------ +END MODULE ioipsl_getincom Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_stringop.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_stringop.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/ioipsl_stringop.F90 (revision 1634) @@ -0,0 +1,243 @@ +! +! $Id$ +! +! Module/Routines extracted from IOIPSL v2_1_8 +! +MODULE ioipsl_stringop +!- +!$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- + INTEGER,DIMENSION(30) :: & + & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, & + & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/) +!- +!--------------------------------------------------------------------- +CONTAINS +!= +SUBROUTINE cmpblank (str) +!--------------------------------------------------------------------- +!- Compact blanks +!--------------------------------------------------------------------- + CHARACTER(LEN=*),INTENT(inout) :: str +!- + INTEGER :: lcc,ipb +!--------------------------------------------------------------------- + lcc = LEN_TRIM(str) + ipb = 1 + DO + IF (ipb >= lcc) EXIT + IF (str(ipb:ipb+1) == ' ') THEN + str(ipb+1:) = str(ipb+2:lcc) + lcc = lcc-1 + ELSE + ipb = ipb+1 + ENDIF + ENDDO +!---------------------- +END SUBROUTINE cmpblank +!=== +INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds number of occurences of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!- + INTEGER :: ipos,indx +!--------------------------------------------------------------------- + cntpos = 0 + ipos = 1 + DO + indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) + IF (indx > 0) THEN + cntpos = cntpos+1 + ipos = ipos+indx+l_r-1 + ELSE + EXIT + ENDIF + ENDDO +!------------------ +END FUNCTION cntpos +!=== +INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds position of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!--------------------------------------------------------------------- + findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) + IF (findpos == 0) findpos=-1 +!------------------- +END FUNCTION findpos +!=== +SUBROUTINE find_str (str_tab,str,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a string in a table +!--------------------------------------------------------------------- +!- INPUT +!- str_tab : Table of strings +!- str : Target we are looking for +!- OUTPUT +!- pos : -1 if str not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab + CHARACTER(LEN=*),INTENT(in) :: str + INTEGER,INTENT(out) :: pos +!- + INTEGER :: nb_str,i +!--------------------------------------------------------------------- + pos = -1 + nb_str=SIZE(str_tab) + IF ( nb_str > 0 ) THEN + DO i=1,nb_str + IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN + pos = i + EXIT + ENDIF + ENDDO + ENDIF +!---------------------- +END SUBROUTINE find_str +!=== +SUBROUTINE nocomma (str) +!--------------------------------------------------------------------- +!- Replace commas with blanks +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + IF (str(i:i) == ',') str(i:i) = ' ' + ENDDO +!--------------------- +END SUBROUTINE nocomma +!=== +SUBROUTINE strlowercase (str) +!--------------------------------------------------------------------- +!- Converts a string into lowercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 65).AND.(ic <= 90) ) str(i:i) = ACHAR(ic+32) + ENDDO +!-------------------------- +END SUBROUTINE strlowercase +!=== +SUBROUTINE struppercase (str) +!--------------------------------------------------------------------- +!- Converts a string into uppercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 97).AND.(ic <= 122) ) str(i:i) = ACHAR(ic-32) + ENDDO +!-------------------------- +END SUBROUTINE struppercase +!=== +SUBROUTINE gensig (str,sig) +!--------------------------------------------------------------------- +!- Generate a signature from the first 30 characters of the string +!- This signature is not unique and thus when one looks for the +!- one needs to also verify the string. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str + INTEGER :: sig +!- + INTEGER :: i +!--------------------------------------------------------------------- + sig = 0 + DO i=1,MIN(LEN_TRIM(str),30) + sig = sig + prime(i)*IACHAR(str(i:i)) + ENDDO +!-------------------- +END SUBROUTINE gensig +!=== +SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos) +!--------------------------------------------------------------------- +!- Find the string signature in a list of signatures +!--------------------------------------------------------------------- +!- INPUT +!- nb_sig : length of table of signatures +!- str_tab : Table of strings +!- str : Target string we are looking for +!- sig_tab : Table of signatures +!- sig : Target signature we are looking for +!- OUTPUT +!- pos : -1 if str not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb_sig + CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab + CHARACTER(LEN=*) :: str + INTEGER,DIMENSION(nb_sig) :: sig_tab + INTEGER :: sig +!- + INTEGER :: pos + INTEGER,DIMENSION(nb_sig) :: loczeros +!- + INTEGER :: il,len + INTEGER,DIMENSION(1) :: minpos +!--------------------------------------------------------------------- + pos = -1 + il = LEN_TRIM(str) +!- + IF ( nb_sig > 0 ) THEN + loczeros = ABS(sig_tab(1:nb_sig)-sig) + IF ( COUNT(loczeros < 1) == 1 ) THEN + minpos = MINLOC(loczeros) + len = LEN_TRIM(str_tab(minpos(1))) + IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & + .AND.(len == il) ) THEN + pos = minpos(1) + ENDIF + ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN + DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 ) + minpos = MINLOC(loczeros) + len = LEN_TRIM(str_tab(minpos(1))) + IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) & + .AND.(len == il) ) THEN + pos = minpos(1) + ELSE + loczeros(minpos(1)) = 99999 + ENDIF + ENDDO + ENDIF + ENDIF +!----------------------- + END SUBROUTINE find_sig +!=== +!------------------ +END MODULE ioipsl_stringop Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/j4save.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/j4save.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/j4save.F (revision 1634) @@ -0,0 +1,65 @@ +*DECK J4SAVE + FUNCTION J4SAVE (IWHICH, IVALUE, ISET) +C***BEGIN PROLOGUE J4SAVE +C***SUBSIDIARY +C***PURPOSE Save or recall global variables needed by error +C handling routines. +C***LIBRARY SLATEC (XERROR) +C***TYPE INTEGER (J4SAVE-I) +C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C J4SAVE saves and recalls several global variables needed +C by the library error handling routines. +C +C Description of Parameters +C --Input-- +C IWHICH - Index of item desired. +C = 1 Refers to current error number. +C = 2 Refers to current error control flag. +C = 3 Refers to current unit number to which error +C messages are to be sent. (0 means use standard.) +C = 4 Refers to the maximum number of times any +C message is to be printed (as set by XERMAX). +C = 5 Refers to the total number of units to which +C each error message is to be written. +C = 6 Refers to the 2nd unit for error messages +C = 7 Refers to the 3rd unit for error messages +C = 8 Refers to the 4th unit for error messages +C = 9 Refers to the 5th unit for error messages +C IVALUE - The value to be set for the IWHICH-th parameter, +C if ISET is .TRUE. . +C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE +C given the value, IVALUE. If ISET=.FALSE., the +C IWHICH-th parameter will be unchanged, and IVALUE +C is a dummy parameter. +C --Output-- +C The (old) value of the IWHICH-th parameter will be returned +C in the function value, J4SAVE. +C +C***SEE ALSO XERMSG +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900205 Minor modifications to prologue. (WRB) +C 900402 Added TYPE section. (WRB) +C 910411 Added KEYWORDS section. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE J4SAVE + LOGICAL ISET + INTEGER IPARAM(9) + SAVE IPARAM + DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ + DATA IPARAM(5)/1/ + DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ +C***FIRST EXECUTABLE STATEMENT J4SAVE + J4SAVE = IPARAM(IWHICH) + IF (ISET) IPARAM(IWHICH) = IVALUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/lnblnk.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/lnblnk.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/lnblnk.F (revision 1634) @@ -0,0 +1,39 @@ +! +! $Header$ +! + INTEGER FUNCTION lnblnk (letter) + +C-------------------------------------------------------- +C Fonction qui determine la longeur d'un string sans les +C blancs qui suivent. Le critere pour determiner la fin du +C string est, trois blancs de suite +C--------------------------------------------------------- +C ARGUMENTS +C +++++++++ +C letter: CHARACTER*xxx (xxx < imax) +C le string dont on determine la longuer +C lnblnk: INTEGER +C le nombre de characteres +C +C PARAMETER +C +++++++++ +C imax : INTEGER +C le nombre maximale de character que peut contenir le string +C a traiter + + IMPLICIT NONE + INTEGER i,imax + PARAMETER (imax = 256) + CHARACTER(*) letter + + i=0 + +10 i=i+1 + IF (letter(i:i+3) . EQ . ' ') GOTO 20 + GOTO 10 + +20 lnblnk=i-1 + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/misc_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/misc_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/misc_mod.F90 (revision 1634) @@ -0,0 +1,6 @@ +module misc_mod + integer,save :: itaumax + logical,save :: adjust + integer,save :: ItCount + logical,save :: debug +end module misc_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/netcdf95.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/netcdf95.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/netcdf95.F90 (revision 1634) @@ -0,0 +1,45 @@ +! $Id$ +module netcdf95 + + ! Author: Lionel GUEZ + + ! Three criticisms may be made about the Fortran 90 NetCDF interface: + + ! -- NetCDF procedures are usually functions with side effects. + ! First, they have "intent(out)" arguments. + ! Furthermore, there is obviously data transfer inside the procedures. + ! Any data transfer inside a function is considered as a side effect. + + ! -- The caller of a NetCDF procedure usually has to handle the error + ! status. NetCDF procedures would be much friendlier if they behaved + ! like the Fortran input/output statements. That is, the error status + ! should be an optional output argument. + ! If the caller does not request the error status and there is an + ! error then the NetCDF procedure should produce an error message + ! and stop the program. + + ! -- Some procedures use array arguments with assumed size. + ! It would be better to use the pointer attribute. + + ! This module produces a NetCDF interface that answers those three + ! criticisms for some (not all) procedures. + + ! "nf95_get_att" is more secure than "nf90_get_att" because it + ! checks that the "values" argument is long enough and removes the + ! null terminator, if any. + + ! This module replaces some of the official NetCDF procedures. + ! This module also provides the procedures "handle_err" and "nf95_gw_var". + + ! This module provides only a partial replacement for some generic + ! procedures such as "nf90_def_var". + + use nf95_def_var_m + use nf95_put_var_m + use nf95_gw_var_m + use nf95_put_att_m + use nf95_get_att_m + use simple + use handle_err_m + +end module netcdf95 Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_def_var_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_def_var_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_def_var_m.F90 (revision 1634) @@ -0,0 +1,102 @@ +! $Id$ +module nf95_def_var_m + + ! The generic procedure name "nf90_def_var" applies to + ! "nf90_def_var_Scalar" but we cannot apply the generic procedure name + ! "nf95_def_var" to "nf95_def_var_scalar" because of the additional + ! optional argument. + ! "nf95_def_var_scalar" cannot be distinguished from "nf95_def_var_oneDim". + + implicit none + + interface nf95_def_var + module procedure nf95_def_var_oneDim, nf95_def_var_ManyDims + end interface + + private + public nf95_def_var, nf95_def_var_scalar + +contains + + subroutine nf95_def_var_scalar(ncid, name, xtype, varid, ncerr) + + use netcdf, only: nf90_def_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: xtype + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_var(ncid, name, xtype, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_var_scalar " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_var_scalar + + !*********************** + + subroutine nf95_def_var_oneDim(ncid, name, xtype, dimids, varid, ncerr) + + use netcdf, only: nf90_def_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: xtype + integer, intent( in) :: dimids + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_var_oneDim " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_var_oneDim + + !*********************** + + subroutine nf95_def_var_ManyDims(ncid, name, xtype, dimids, varid, ncerr) + + use netcdf, only: nf90_def_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: xtype + integer, dimension(:), intent( in) :: dimids + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_var_ManyDims " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_var_ManyDims + +end module nf95_def_var_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_get_att_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_get_att_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_get_att_m.F90 (revision 1634) @@ -0,0 +1,60 @@ +! $Id$ +module nf95_get_att_m + + implicit none + + interface nf95_get_att + module procedure nf95_get_att_text + end interface + + private + public nf95_get_att + +contains + + subroutine nf95_get_att_text(ncid, varid, name, values, ncerr) + + use netcdf, only: nf90_get_att, nf90_inquire_attribute, nf90_noerr + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + character(len = *), intent( in) :: name + character(len = *), intent(out) :: values + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + integer att_len + + !------------------- + + ! Check that the length of "values" is large enough: + ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, len=att_len) + call handle_err("nf95_get_att_text nf90_inquire_attribute " & + // trim(name), ncerr_not_opt, ncid, varid) + if (len(values) < att_len) then + print *, "nf95_get_att_text" + print *, "varid = ", varid + print *, "attribute name: ", name + print *, 'length of "values" is not large enough' + print *, "len(values) = ", len(values) + print *, "number of characters in attribute: ", att_len + stop 1 + end if + + values = "" ! useless in NetCDF version 3.6.2 or better + ncerr_not_opt = nf90_get_att(ncid, varid, name, values) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_get_att_text", ncerr_not_opt, ncid, varid) + end if + + if (att_len >= 1 .and. ncerr_not_opt == nf90_noerr) then + ! Remove null terminator, if any: + if (iachar(values(att_len:att_len)) == 0) values(att_len:att_len) = " " + end if + + end subroutine nf95_get_att_text + +end module nf95_get_att_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_gw_var_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_gw_var_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_gw_var_m.F90 (revision 1634) @@ -0,0 +1,338 @@ +! $Id$ +module nf95_gw_var_m + + implicit none + + interface nf95_gw_var + ! "nf95_gw_var" stands for "NetCDF 1995 get whole variable". + ! These procedures read a whole NetCDF variable (coordinate or + ! primary) into an array. + ! The difference between the procedures is the rank of the array + ! and the type of Fortran values. + ! The procedures do not check the type of the NetCDF variable. + +!!$ module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, & +!!$ nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_dble_1d, & +!!$ nf95_gw_var_dble_3d, nf95_gw_var_int_1d, nf95_gw_var_int_3d + module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, & + nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_int_1d, & + nf95_gw_var_int_3d + end interface + + private + public nf95_gw_var + +contains + + subroutine nf95_gw_var_real_1d(ncid, varid, values) + + ! Real type, the array has rank 1. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:) + + ! Variables local to the procedure: + integer ierr, len + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 1) then + print *, "nf95_gw_var_real_1d: NetCDF variable is not of rank 1" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len) + deallocate(dimids) ! pointer + + allocate(values(len)) + if (len /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_1d + + !************************************ + + subroutine nf95_gw_var_real_2d(ncid, varid, values) + + ! Real type, the array has rank 2. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:, :) + + ! Variables local to the procedure: + integer ierr, len1, len2 + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 2) then + print *, "nf95_gw_var_real_2d: NetCDF variable is not of rank 2" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len1) + call nf95_inquire_dimension(ncid, dimids(2), len=len2) + deallocate(dimids) ! pointer + + allocate(values(len1, len2)) + if (len1 /= 0 .and. len2 /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_2d + + !************************************ + + subroutine nf95_gw_var_real_3d(ncid, varid, values) + + ! Real type, the array has rank 3. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:, :, :) + + ! Variables local to the procedure: + integer ierr, len1, len2, len3 + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 3) then + print *, "nf95_gw_var_real_3d: NetCDF variable is not of rank 3" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len1) + call nf95_inquire_dimension(ncid, dimids(2), len=len2) + call nf95_inquire_dimension(ncid, dimids(3), len=len3) + deallocate(dimids) ! pointer + + allocate(values(len1, len2, len3)) + if (len1 * len2 * len3 /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_3d + + !************************************ + + subroutine nf95_gw_var_real_4d(ncid, varid, values) + + ! Real type, the array has rank 4. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + real, pointer:: values(:, :, :, :) + + ! Variables local to the procedure: + integer ierr, len_dim(4), i + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 4) then + print *, "nf95_gw_var_real_4d: NetCDF variable is not of rank 4" + stop 1 + end if + + do i = 1, 4 + call nf95_inquire_dimension(ncid, dimids(i), len=len_dim(i)) + end do + deallocate(dimids) ! pointer + + allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4))) + if (all(len_dim /= 0)) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_real_4d + + !************************************ + +!!$ subroutine nf95_gw_var_dble_1d(ncid, varid, values) +!!$ +!!$ ! Double precision, the array has rank 1. +!!$ +!!$ use netcdf, only: NF90_GET_VAR +!!$ use simple, only: nf95_inquire_variable, nf95_inquire_dimension +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent(in):: ncid +!!$ integer, intent(in):: varid +!!$ double precision, pointer:: values(:) +!!$ +!!$ ! Variables local to the procedure: +!!$ integer ierr, len +!!$ integer, pointer :: dimids(:) +!!$ +!!$ !--------------------- +!!$ +!!$ call nf95_inquire_variable(ncid, varid, dimids=dimids) +!!$ +!!$ if (size(dimids) /= 1) then +!!$ print *, "nf95_gw_var_dble_1d: NetCDF variable is not of rank 1" +!!$ stop 1 +!!$ end if +!!$ +!!$ call nf95_inquire_dimension(ncid, dimids(1), len=len) +!!$ deallocate(dimids) ! pointer +!!$ +!!$ allocate(values(len)) +!!$ if (len /= 0) then +!!$ ierr = NF90_GET_VAR(ncid, varid, values) +!!$ call handle_err("NF90_GET_VAR", ierr, ncid, varid) +!!$ end if +!!$ +!!$ end subroutine nf95_gw_var_dble_1d +!!$ +!!$ !************************************ +!!$ +!!$ subroutine nf95_gw_var_dble_3d(ncid, varid, values) +!!$ +!!$ ! Double precision, the array has rank 3. +!!$ +!!$ use netcdf, only: NF90_GET_VAR +!!$ use simple, only: nf95_inquire_variable, nf95_inquire_dimension +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent(in):: ncid +!!$ integer, intent(in):: varid +!!$ double precision, pointer:: values(:, :, :) +!!$ +!!$ ! Variables local to the procedure: +!!$ integer ierr, len1, len2, len3 +!!$ integer, pointer :: dimids(:) +!!$ +!!$ !--------------------- +!!$ +!!$ call nf95_inquire_variable(ncid, varid, dimids=dimids) +!!$ +!!$ if (size(dimids) /= 3) then +!!$ print *, "nf95_gw_var_dble_3d: NetCDF variable is not of rank 3" +!!$ stop 1 +!!$ end if +!!$ +!!$ call nf95_inquire_dimension(ncid, dimids(1), len=len1) +!!$ call nf95_inquire_dimension(ncid, dimids(2), len=len2) +!!$ call nf95_inquire_dimension(ncid, dimids(3), len=len3) +!!$ deallocate(dimids) ! pointer +!!$ +!!$ allocate(values(len1, len2, len3)) +!!$ if (len1 * len2 * len3 /= 0) then +!!$ ierr = NF90_GET_VAR(ncid, varid, values) +!!$ call handle_err("NF90_GET_VAR", ierr, ncid, varid) +!!$ end if +!!$ +!!$ end subroutine nf95_gw_var_dble_3d + + !************************************ + + subroutine nf95_gw_var_int_1d(ncid, varid, values) + + ! Integer type, the array has rank 1. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + integer, pointer:: values(:) + + ! Variables local to the procedure: + integer ierr, len + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 1) then + print *, "nf95_gw_var_int_1d: NetCDF variable is not of rank 1" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len) + deallocate(dimids) ! pointer + + allocate(values(len)) + if (len /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_int_1d + + !************************************ + + subroutine nf95_gw_var_int_3d(ncid, varid, values) + + ! Integer type, the array has rank 3. + + use netcdf, only: NF90_GET_VAR + use simple, only: nf95_inquire_variable, nf95_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent(in):: ncid + integer, intent(in):: varid + integer, pointer:: values(:, :, :) + + ! Variables local to the procedure: + integer ierr, len1, len2, len3 + integer, pointer :: dimids(:) + + !--------------------- + + call nf95_inquire_variable(ncid, varid, dimids=dimids) + + if (size(dimids) /= 3) then + print *, "nf95_gw_var_int_3d: NetCDF variable is not of rank 3" + stop 1 + end if + + call nf95_inquire_dimension(ncid, dimids(1), len=len1) + call nf95_inquire_dimension(ncid, dimids(2), len=len2) + call nf95_inquire_dimension(ncid, dimids(3), len=len3) + deallocate(dimids) ! pointer + + allocate(values(len1, len2, len3)) + if (len1 * len2 * len3 /= 0) then + ierr = NF90_GET_VAR(ncid, varid, values) + call handle_err("NF90_GET_VAR", ierr, ncid, varid) + end if + + end subroutine nf95_gw_var_int_3d + +end module nf95_gw_var_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_put_att_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_put_att_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_put_att_m.F90 (revision 1634) @@ -0,0 +1,67 @@ +! $Id$ +module nf95_put_att_m + + implicit none + + interface nf95_put_att + module procedure nf95_put_att_text, nf95_put_att_one_FourByteInt + end interface + + private + public nf95_put_att + +contains + + subroutine nf95_put_att_text(ncid, varid, name, values, ncerr) + + use netcdf, only: nf90_put_att + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid, varid + character(len = *), intent(in) :: name + character(len = *), intent(in) :: values + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_att(ncid, varid, name, values) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_att_text", ncerr_not_opt, ncid, varid) + end if + + end subroutine nf95_put_att_text + + !************************************ + + subroutine nf95_put_att_one_FourByteInt(ncid, varid, name, values, ncerr) + + use netcdf, only: nf90_put_att + use handle_err_m, only: handle_err + use typesizes, only: FourByteInt + + integer, intent(in) :: ncid, varid + character(len = *), intent(in) :: name + integer(kind = FourByteInt), intent(in) :: values + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_att(ncid, varid, name, values) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_att_one_FourByteInt", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_att_one_FourByteInt + +end module nf95_put_att_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_put_var_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_put_var_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/nf95_put_var_m.F90 (revision 1634) @@ -0,0 +1,279 @@ +! $Id$ +module nf95_put_var_m + + implicit none + + interface nf95_put_var + module procedure nf95_put_var_FourByteReal, nf95_put_var_FourByteInt, & + nf95_put_var_1D_FourByteReal, nf95_put_var_1D_FourByteInt, & + nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, & + nf95_put_var_4D_FourByteReal +!!$ module procedure nf95_put_var_1D_FourByteReal, & +!!$ nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, & +!!$ nf95_put_var_4D_FourByteReal, nf90_put_var_1D_EightByteReal, & +!!$ nf90_put_var_3D_EightByteReal + end interface + + private + public nf95_put_var + +contains + + subroutine nf95_put_var_FourByteReal(ncid, varid, values, start, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values + integer, dimension(:), optional, intent( in) :: start + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_FourByteReal + + !*********************** + + subroutine nf95_put_var_FourByteInt(ncid, varid, values, start, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + integer, intent( in) :: values + integer, dimension(:), optional, intent( in) :: start + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_FourByteInt", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_FourByteInt + + !*********************** + + subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid, varid + real, intent(in) :: values(:) + integer, dimension(:), optional, intent(in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_1D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_1D_FourByteReal + + !*********************** + + subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid, varid + integer, intent(in) :: values(:) + integer, dimension(:), optional, intent(in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_1D_FourByteInt", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_1D_FourByteInt + + !*********************** + + subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values(:, :) + integer, dimension(:), optional, intent( in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_2D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_2D_FourByteReal + + !*********************** + + subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values(:, :, :) + integer, dimension(:), optional, intent( in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_3D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_3D_FourByteReal + + !*********************** + + subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, count, & + stride, map, ncerr) + + use netcdf, only: nf90_put_var + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, varid + real, intent( in) :: values(:, :, :, :) + integer, dimension(:), optional, intent( in) :: start, count, stride, map + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & + map) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_put_var_4D_FourByteReal", ncerr_not_opt, ncid, & + varid) + end if + + end subroutine nf95_put_var_4D_FourByteReal + + !*********************** + +!!$ subroutine nf90_put_var_1D_EightByteReal(ncid, varid, values, start, count, & +!!$ stride, map, ncerr) +!!$ +!!$ use typesizes, only: eightByteReal +!!$ use netcdf, only: nf90_put_var +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent( in) :: ncid, varid +!!$ real (kind = EightByteReal), intent( in) :: values(:) +!!$ integer, dimension(:), optional, intent( in) :: start, count, stride, map +!!$ integer, intent(out), optional:: ncerr +!!$ +!!$ ! Variable local to the procedure: +!!$ integer ncerr_not_opt +!!$ +!!$ !------------------- +!!$ +!!$ ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & +!!$ map) +!!$ if (present(ncerr)) then +!!$ ncerr = ncerr_not_opt +!!$ else +!!$ call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, & +!!$ varid) +!!$ end if +!!$ +!!$ end subroutine nf90_put_var_1D_EightByteReal +!!$ +!!$ !*********************** +!!$ +!!$ subroutine nf90_put_var_3D_EightByteReal(ncid, varid, values, start, count, & +!!$ stride, map, ncerr) +!!$ +!!$ use typesizes, only: eightByteReal +!!$ use netcdf, only: nf90_put_var +!!$ use handle_err_m, only: handle_err +!!$ +!!$ integer, intent( in) :: ncid, varid +!!$ real (kind = EightByteReal), intent( in) :: values(:, :, :) +!!$ integer, dimension(:), optional, intent( in) :: start, count, stride, map +!!$ integer, intent(out), optional:: ncerr +!!$ +!!$ ! Variable local to the procedure: +!!$ integer ncerr_not_opt +!!$ +!!$ !------------------- +!!$ +!!$ ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count, stride, & +!!$ map) +!!$ if (present(ncerr)) then +!!$ ncerr = ncerr_not_opt +!!$ else +!!$ call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, & +!!$ varid) +!!$ end if +!!$ +!!$ end subroutine nf90_put_var_3D_EightByteReal + +end module nf95_put_var_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchdf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchdf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchdf.F (revision 1634) @@ -0,0 +1,106 @@ +*DECK PCHDF + REAL FUNCTION PCHDF (K, X, S, IERR) +C***BEGIN PROLOGUE PCHDF +C***SUBSIDIARY +C***PURPOSE Computes divided differences for PCHCE and PCHSP +C***LIBRARY SLATEC (PCHIP) +C***TYPE SINGLE PRECISION (PCHDF-S, DPCHDF-D) +C***AUTHOR Fritsch, F. N., (LLNL) +C***DESCRIPTION +C +C PCHDF: PCHIP Finite Difference Formula +C +C Uses a divided difference formulation to compute a K-point approx- +C imation to the derivative at X(K) based on the data in X and S. +C +C Called by PCHCE and PCHSP to compute 3- and 4-point boundary +C derivative approximations. +C +C ---------------------------------------------------------------------- +C +C On input: +C K is the order of the desired derivative approximation. +C K must be at least 3 (error return if not). +C X contains the K values of the independent variable. +C X need not be ordered, but the values **MUST** be +C distinct. (Not checked here.) +C S contains the associated slope values: +C S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1. +C (Note that S need only be of length K-1.) +C +C On return: +C S will be destroyed. +C IERR will be set to -1 if K.LT.2 . +C PCHDF will be set to the desired derivative approximation if +C IERR=0 or to zero if IERR=-1. +C +C ---------------------------------------------------------------------- +C +C***SEE ALSO PCHCE, PCHSP +C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- +C Verlag, New York, 1978, pp. 10-16. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 820503 DATE WRITTEN +C 820805 Converted to SLATEC library version. +C 870813 Minor cosmetic changes. +C 890411 Added SAVE statements (Vers. 3.2). +C 890411 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900328 Added TYPE section. (WRB) +C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) +C 920429 Revised format and order of references. (WRB,FNF) +C 930503 Improved purpose. (FNF) +C***END PROLOGUE PCHDF +C +C**End +C +C DECLARE ARGUMENTS. +C + INTEGER K, IERR + REAL X(K), S(K) +C +C DECLARE LOCAL VARIABLES. +C + INTEGER I, J + REAL VALUE, ZERO + SAVE ZERO + DATA ZERO /0./ +C +C CHECK FOR LEGAL VALUE OF K. +C +C***FIRST EXECUTABLE STATEMENT PCHDF + IF (K .LT. 3) GO TO 5001 +C +C COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. +C + DO 10 J = 2, K-1 + DO 9 I = 1, K-J + S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) + 9 CONTINUE + 10 CONTINUE +C +C EVALUATE DERIVATIVE AT X(K). +C + VALUE = S(1) + DO 20 I = 2, K-1 + VALUE = S(I) + VALUE*(X(K)-X(I)) + 20 CONTINUE +C +C NORMAL RETURN. +C + IERR = 0 + PCHDF = VALUE + RETURN +C +C ERROR RETURN. +C + 5001 CONTINUE +C K.LT.3 RETURN. + IERR = -1 + CALL XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1) + PCHDF = ZERO + RETURN +C------------- LAST LINE OF PCHDF FOLLOWS ------------------------------ + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchfe.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchfe.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchfe.F (revision 1634) @@ -0,0 +1,308 @@ +*DECK PCHFE + SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) +C***BEGIN PROLOGUE PCHFE +C***PURPOSE Evaluate a piecewise cubic Hermite function at an array of +C points. May be used by itself for Hermite interpolation, +C or as an evaluator for PCHIM or PCHIC. +C***LIBRARY SLATEC (PCHIP) +C***CATEGORY E3 +C***TYPE SINGLE PRECISION (PCHFE-S, DPCHFE-D) +C***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, +C PIECEWISE CUBIC EVALUATION +C***AUTHOR Fritsch, F. N., (LLNL) +C Lawrence Livermore National Laboratory +C P.O. Box 808 (L-316) +C Livermore, CA 94550 +C FTS 532-4275, (510) 422-4275 +C***DESCRIPTION +C +C PCHFE: Piecewise Cubic Hermite Function Evaluator +C +C Evaluates the cubic Hermite function defined by N, X, F, D at +C the points XE(J), J=1(1)NE. +C +C To provide compatibility with PCHIM and PCHIC, includes an +C increment between successive values of the F- and D-arrays. +C +C ---------------------------------------------------------------------- +C +C Calling sequence: +C +C PARAMETER (INCFD = ...) +C INTEGER N, NE, IERR +C REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) +C LOGICAL SKIP +C +C CALL PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) +C +C Parameters: +C +C N -- (input) number of data points. (Error return if N.LT.2 .) +C +C X -- (input) real array of independent variable values. The +C elements of X must be strictly increasing: +C X(I-1) .LT. X(I), I = 2(1)N. +C (Error return if not.) +C +C F -- (input) real array of function values. F(1+(I-1)*INCFD) is +C the value corresponding to X(I). +C +C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is +C the value corresponding to X(I). +C +C INCFD -- (input) increment between successive values in F and D. +C (Error return if INCFD.LT.1 .) +C +C SKIP -- (input/output) logical variable which should be set to +C .TRUE. if the user wishes to skip checks for validity of +C preceding parameters, or to .FALSE. otherwise. +C This will save time in case these checks have already +C been performed (say, in PCHIM or PCHIC). +C SKIP will be set to .TRUE. on normal return. +C +C NE -- (input) number of evaluation points. (Error return if +C NE.LT.1 .) +C +C XE -- (input) real array of points at which the function is to be +C evaluated. +C +C NOTES: +C 1. The evaluation will be most efficient if the elements +C of XE are increasing relative to X; +C that is, XE(J) .GE. X(I) +C implies XE(K) .GE. X(I), all K.GE.J . +C 2. If any of the XE are outside the interval [X(1),X(N)], +C values are extrapolated from the nearest extreme cubic, +C and a warning error is returned. +C +C FE -- (output) real array of values of the cubic Hermite function +C defined by N, X, F, D at the points XE. +C +C IERR -- (output) error flag. +C Normal return: +C IERR = 0 (no errors). +C Warning error: +C IERR.GT.0 means that extrapolation was performed at +C IERR points. +C "Recoverable" errors: +C IERR = -1 if N.LT.2 . +C IERR = -2 if INCFD.LT.1 . +C IERR = -3 if the X-array is not strictly increasing. +C IERR = -4 if NE.LT.1 . +C (The FE-array has not been changed in any of these cases.) +C NOTE: The above errors are checked in the order listed, +C and following arguments have **NOT** been validated. +C +C***REFERENCES (NONE) +C***ROUTINES CALLED CHFEV, XERMSG +C***REVISION HISTORY (YYMMDD) +C 811020 DATE WRITTEN +C 820803 Minor cosmetic changes for release 1. +C 870707 Minor cosmetic changes to prologue. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C***END PROLOGUE PCHFE +C Programming notes: +C +C 1. To produce a double precision version, simply: +C a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they +C occur, +C b. Change the real declaration to double precision, +C +C 2. Most of the coding between the call to CHFEV and the end of +C the IR-loop could be eliminated if it were permissible to +C assume that XE is ordered relative to X. +C +C 3. CHFEV does not assume that X1 is less than X2. thus, it would +C be possible to write a version of PCHFE that assumes a strict- +C ly decreasing X-array by simply running the IR-loop backwards +C (and reversing the order of appropriate tests). +C +C 4. The present code has a minor bug, which I have decided is not +C worth the effort that would be required to fix it. +C If XE contains points in [X(N-1),X(N)], followed by points .LT. +C X(N-1), followed by points .GT.X(N), the extrapolation points +C will be counted (at least) twice in the total returned in IERR. +C +C DECLARE ARGUMENTS. +C + INTEGER N, INCFD, NE, IERR + REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) + LOGICAL SKIP +C +C DECLARE LOCAL VARIABLES. +C + INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ +C +C VALIDITY-CHECK ARGUMENTS. +C +C***FIRST EXECUTABLE STATEMENT PCHFE + IF (SKIP) GO TO 5 +C + IF ( N.LT.2 ) GO TO 5001 + IF ( INCFD.LT.1 ) GO TO 5002 + DO 1 I = 2, N + IF ( X(I).LE.X(I-1) ) GO TO 5003 + 1 CONTINUE +C +C FUNCTION DEFINITION IS OK, GO ON. +C + 5 CONTINUE + IF ( NE.LT.1 ) GO TO 5004 + IERR = 0 + SKIP = .TRUE. +C +C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) +C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) + JFIRST = 1 + IR = 2 + 10 CONTINUE +C +C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. +C + IF (JFIRST .GT. NE) GO TO 5000 +C +C LOCATE ALL POINTS IN INTERVAL. +C + DO 20 J = JFIRST, NE + IF (XE(J) .GE. X(IR)) GO TO 30 + 20 CONTINUE + J = NE + 1 + GO TO 40 +C +C HAVE LOCATED FIRST POINT BEYOND INTERVAL. +C + 30 CONTINUE + IF (IR .EQ. N) J = NE + 1 +C + 40 CONTINUE + NJ = J - JFIRST +C +C SKIP EVALUATION IF NO POINTS IN INTERVAL. +C + IF (NJ .EQ. 0) GO TO 50 +C +C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . +C +C ---------------------------------------------------------------- + CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), + * NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) +C ---------------------------------------------------------------- + IF (IERC .LT. 0) GO TO 5005 +C + IF (NEXT(2) .EQ. 0) GO TO 42 +C IF (NEXT(2) .GT. 0) THEN +C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE +C RIGHT OF X(IR). +C + IF (IR .LT. N) GO TO 41 +C IF (IR .EQ. N) THEN +C THESE ARE ACTUALLY EXTRAPOLATION POINTS. + IERR = IERR + NEXT(2) + GO TO 42 + 41 CONTINUE +C ELSE +C WE SHOULD NEVER HAVE GOTTEN HERE. + GO TO 5005 +C ENDIF +C ENDIF + 42 CONTINUE +C + IF (NEXT(1) .EQ. 0) GO TO 49 +C IF (NEXT(1) .GT. 0) THEN +C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE +C LEFT OF X(IR-1). +C + IF (IR .GT. 2) GO TO 43 +C IF (IR .EQ. 2) THEN +C THESE ARE ACTUALLY EXTRAPOLATION POINTS. + IERR = IERR + NEXT(1) + GO TO 49 + 43 CONTINUE +C ELSE +C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST +C EVALUATION INTERVAL. +C +C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). + DO 44 I = JFIRST, J-1 + IF (XE(I) .LT. X(IR-1)) GO TO 45 + 44 CONTINUE +C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR +C IN CHFEV. + GO TO 5005 +C + 45 CONTINUE +C RESET J. (THIS WILL BE THE NEW JFIRST.) + J = I +C +C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. + DO 46 I = 1, IR-1 + IF (XE(J) .LT. X(I)) GO TO 47 + 46 CONTINUE +C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). +C + 47 CONTINUE +C AT THIS POINT, EITHER XE(J) .LT. X(1) +C OR X(I-1) .LE. XE(J) .LT. X(I) . +C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE +C CYCLING. + IR = MAX(1, I-1) +C ENDIF +C ENDIF + 49 CONTINUE +C + JFIRST = J +C +C END OF IR-LOOP. +C + 50 CONTINUE + IR = IR + 1 + IF (IR .LE. N) GO TO 10 +C +C NORMAL RETURN. +C + 5000 CONTINUE + RETURN +C +C ERROR RETURNS. +C + 5001 CONTINUE +C N.LT.2 RETURN. + IERR = -1 + CALL XERMSG ('SLATEC', 'PCHFE', + + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) + RETURN +C + 5002 CONTINUE +C INCFD.LT.1 RETURN. + IERR = -2 + CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR, + + 1) + RETURN +C + 5003 CONTINUE +C X-ARRAY NOT STRICTLY INCREASING. + IERR = -3 + CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING' + + , IERR, 1) + RETURN +C + 5004 CONTINUE +C NE.LT.1 RETURN. + IERR = -4 + CALL XERMSG ('SLATEC', 'PCHFE', + + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) + RETURN +C + 5005 CONTINUE +C ERROR RETURN FROM CHFEV. +C *** THIS CASE SHOULD NEVER OCCUR *** + IERR = -5 + CALL XERMSG ('SLATEC', 'PCHFE', + + 'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2) + RETURN +C------------- LAST LINE OF PCHFE FOLLOWS ------------------------------ + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchfe_95.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchfe_95.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchfe_95.F90 (revision 1634) @@ -0,0 +1,76 @@ +module PCHFE_95_m + + implicit none + +contains + + SUBROUTINE PCHFE_95(X, F, D, SKIP, XE, FE, IERR) + + ! PURPOSE Evaluate a piecewise cubic Hermite function at an array of + ! points. May be used by itself for Hermite interpolation, + ! or as an evaluator for PCHIM or PCHIC. + ! CATEGORY E3 + ! KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, + ! PIECEWISE CUBIC EVALUATION + + ! PCHFE: Piecewise Cubic Hermite Function Evaluator + ! Evaluates the cubic Hermite function defined by X, F, D at + ! the points XE. + + use assert_eq_m, only: assert_eq + + REAL, intent(in):: X(:) ! real array of independent variable values + ! The elements of X must be strictly increasing. + + REAL, intent(in):: F(:) ! real array of function values + ! F(I) is the value corresponding to X(I). + + REAL, intent(in):: D(:) ! real array of derivative values + ! D(I) is the value corresponding to X(I). + + LOGICAL, intent(inout):: SKIP + ! request to skip checks for validity of "x" + ! If "skip" is false then "pchfe" will check that size(x) >= 2 and + ! "x" is in strictly ascending order. + ! Setting "skip" to true will save time in case these checks have + ! already been performed (say, in "PCHIM" or "PCHIC"). + ! "SKIP" will be set to TRUE on normal return. + + real, intent(in):: XE(:) ! points at which the function is to be evaluated + ! NOTES: + ! 1. The evaluation will be most efficient if the elements of XE + ! are increasing relative to X. + ! That is, XE(J) .GE. X(I) + ! implies XE(K) .GE. X(I), all K.GE.J + ! 2. If any of the XE are outside the interval [X(1),X(N)], values + ! are extrapolated from the nearest extreme cubic, and a warning + ! error is returned. + + real, intent(out):: FE(:) ! values of the cubic Hermite function + ! defined by X, F, D at the points XE + + integer, intent(out):: IERR ! error flag + ! Normal return: + ! IERR = 0 no error + ! Warning error: + ! IERR > 0 means that extrapolation was performed at IERR points + ! "Recoverable" errors: + ! IERR = -1 if N < 2 + ! IERR = -3 if the X-array is not strictly increasing + ! IERR = -4 if NE < 1 + ! NOTE: The above errors are checked in the order listed, and + ! following arguments have **NOT** been validated. + + ! Variables local to the procedure: + + INTEGER N, NE + + !--------------------------------------- + + n = assert_eq(size(x), size(f), size(d), "PCHFE_95 n") + ne = assert_eq(size(xe), size(fe), "PCHFE_95 ne") + call PCHFE(N, X, F, D, 1, SKIP, NE, XE, FE, IERR) + + end SUBROUTINE PCHFE_95 + +end module PCHFE_95_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchsp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchsp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchsp.F (revision 1634) @@ -0,0 +1,388 @@ +*DECK PCHSP + SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) +C***BEGIN PROLOGUE PCHSP +C***PURPOSE Set derivatives needed to determine the Hermite represen- +C tation of the cubic spline interpolant to given data, with +C specified boundary conditions. +C***LIBRARY SLATEC (PCHIP) +C***CATEGORY E1A +C***TYPE SINGLE PRECISION (PCHSP-S, DPCHSP-D) +C***KEYWORDS CUBIC HERMITE INTERPOLATION, PCHIP, +C PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION +C***AUTHOR Fritsch, F. N., (LLNL) +C Lawrence Livermore National Laboratory +C P.O. Box 808 (L-316) +C Livermore, CA 94550 +C FTS 532-4275, (510) 422-4275 +C***DESCRIPTION +C +C PCHSP: Piecewise Cubic Hermite Spline +C +C Computes the Hermite representation of the cubic spline inter- +C polant to the data given in X and F satisfying the boundary +C conditions specified by IC and VC. +C +C To facilitate two-dimensional applications, includes an increment +C between successive values of the F- and D-arrays. +C +C The resulting piecewise cubic Hermite function may be evaluated +C by PCHFE or PCHFD. +C +C NOTE: This is a modified version of C. de Boor's cubic spline +C routine CUBSPL. +C +C ---------------------------------------------------------------------- +C +C Calling sequence: +C +C PARAMETER (INCFD = ...) +C INTEGER IC(2), N, NWK, IERR +C REAL VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK) +C +C CALL PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) +C +C Parameters: +C +C IC -- (input) integer array of length 2 specifying desired +C boundary conditions: +C IC(1) = IBEG, desired condition at beginning of data. +C IC(2) = IEND, desired condition at end of data. +C +C IBEG = 0 to set D(1) so that the third derivative is con- +C tinuous at X(2). This is the "not a knot" condition +C provided by de Boor's cubic spline routine CUBSPL. +C < This is the default boundary condition. > +C IBEG = 1 if first derivative at X(1) is given in VC(1). +C IBEG = 2 if second derivative at X(1) is given in VC(1). +C IBEG = 3 to use the 3-point difference formula for D(1). +C (Reverts to the default b.c. if N.LT.3 .) +C IBEG = 4 to use the 4-point difference formula for D(1). +C (Reverts to the default b.c. if N.LT.4 .) +C NOTES: +C 1. An error return is taken if IBEG is out of range. +C 2. For the "natural" boundary condition, use IBEG=2 and +C VC(1)=0. +C +C IEND may take on the same values as IBEG, but applied to +C derivative at X(N). In case IEND = 1 or 2, the value is +C given in VC(2). +C +C NOTES: +C 1. An error return is taken if IEND is out of range. +C 2. For the "natural" boundary condition, use IEND=2 and +C VC(2)=0. +C +C VC -- (input) real array of length 2 specifying desired boundary +C values, as indicated above. +C VC(1) need be set only if IC(1) = 1 or 2 . +C VC(2) need be set only if IC(2) = 1 or 2 . +C +C N -- (input) number of data points. (Error return if N.LT.2 .) +C +C X -- (input) real array of independent variable values. The +C elements of X must be strictly increasing: +C X(I-1) .LT. X(I), I = 2(1)N. +C (Error return if not.) +C +C F -- (input) real array of dependent variable values to be inter- +C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). +C +C D -- (output) real array of derivative values at the data points. +C These values will determine the cubic spline interpolant +C with the requested boundary conditions. +C The value corresponding to X(I) is stored in +C D(1+(I-1)*INCFD), I=1(1)N. +C No other entries in D are changed. +C +C INCFD -- (input) increment between successive values in F and D. +C This argument is provided primarily for 2-D applications. +C (Error return if INCFD.LT.1 .) +C +C WK -- (scratch) real array of working storage. +C +C NWK -- (input) length of work array. +C (Error return if NWK.LT.2*N .) +C +C IERR -- (output) error flag. +C Normal return: +C IERR = 0 (no errors). +C "Recoverable" errors: +C IERR = -1 if N.LT.2 . +C IERR = -2 if INCFD.LT.1 . +C IERR = -3 if the X-array is not strictly increasing. +C IERR = -4 if IBEG.LT.0 or IBEG.GT.4 . +C IERR = -5 if IEND.LT.0 of IEND.GT.4 . +C IERR = -6 if both of the above are true. +C IERR = -7 if NWK is too small. +C NOTE: The above errors are checked in the order listed, +C and following arguments have **NOT** been validated. +C (The D-array has not been changed in any of these cases.) +C IERR = -8 in case of trouble solving the linear system +C for the interior derivative values. +C (The D-array may have been changed in this case.) +C ( Do **NOT** use it! ) +C +C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- +C Verlag, New York, 1978, pp. 53-59. +C***ROUTINES CALLED PCHDF, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820503 DATE WRITTEN +C 820804 Converted to SLATEC library version. +C 870707 Minor cosmetic changes to prologue. +C 890411 Added SAVE statements (Vers. 3.2). +C 890703 Corrected category record. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 920429 Revised format and order of references. (WRB,FNF) +C***END PROLOGUE PCHSP +C Programming notes: +C +C To produce a double precision version, simply: +C a. Change PCHSP to DPCHSP wherever it occurs, +C b. Change the real declarations to double precision, and +C c. Change the constants ZERO, HALF, ... to double precision. +C +C DECLARE ARGUMENTS. +C + INTEGER IC(2), N, INCFD, NWK, IERR + REAL VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*) +C +C DECLARE LOCAL VARIABLES. +C + INTEGER IBEG, IEND, INDEX, J, NM1 + REAL G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO + SAVE ZERO, HALF, ONE, TWO, THREE + REAL PCHDF +C + DATA ZERO /0./, HALF /0.5/, ONE /1./, TWO /2./, THREE /3./ +C +C VALIDITY-CHECK ARGUMENTS. +C +C***FIRST EXECUTABLE STATEMENT PCHSP + IF ( N.LT.2 ) GO TO 5001 + IF ( INCFD.LT.1 ) GO TO 5002 + DO 1 J = 2, N + IF ( X(J).LE.X(J-1) ) GO TO 5003 + 1 CONTINUE +C + IBEG = IC(1) + IEND = IC(2) + IERR = 0 + IF ( (IBEG.LT.0).OR.(IBEG.GT.4) ) IERR = IERR - 1 + IF ( (IEND.LT.0).OR.(IEND.GT.4) ) IERR = IERR - 2 + IF ( IERR.LT.0 ) GO TO 5004 +C +C FUNCTION DEFINITION IS OK -- GO ON. +C + IF ( NWK .LT. 2*N ) GO TO 5007 +C +C COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, +C COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). + DO 5 J=2,N + WK(1,J) = X(J) - X(J-1) + WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) + 5 CONTINUE +C +C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. +C + IF ( IBEG.GT.N ) IBEG = 0 + IF ( IEND.GT.N ) IEND = 0 +C +C SET UP FOR BOUNDARY CONDITIONS. +C + IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) ) THEN + D(1,1) = VC(1) + ELSE IF (IBEG .GT. 2) THEN +C PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. + DO 10 J = 1, IBEG + INDEX = IBEG-J+1 +C INDEX RUNS FROM IBEG DOWN TO 1. + XTEMP(J) = X(INDEX) + IF (J .LT. IBEG) STEMP(J) = WK(2,INDEX) + 10 CONTINUE +C -------------------------------- + D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR) +C -------------------------------- + IF (IERR .NE. 0) GO TO 5009 + IBEG = 1 + ENDIF +C + IF ( (IEND.EQ.1).OR.(IEND.EQ.2) ) THEN + D(1,N) = VC(2) + ELSE IF (IEND .GT. 2) THEN +C PICK UP LAST IEND POINTS. + DO 15 J = 1, IEND + INDEX = N-IEND+J +C INDEX RUNS FROM N+1-IEND UP TO N. + XTEMP(J) = X(INDEX) + IF (J .LT. IEND) STEMP(J) = WK(2,INDEX+1) + 15 CONTINUE +C -------------------------------- + D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR) +C -------------------------------- + IF (IERR .NE. 0) GO TO 5009 + IEND = 1 + ENDIF +C +C --------------------( BEGIN CODING FROM CUBSPL )-------------------- +C +C **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF +C F AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM- +C INATION, WITH S(J) ENDING UP IN D(1,J), ALL J. +C WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE. +C +C CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM +C WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) +C + IF (IBEG .EQ. 0) THEN + IF (N .EQ. 2) THEN +C NO CONDITION AT LEFT END AND N = 2. + WK(2,1) = ONE + WK(1,1) = ONE + D(1,1) = TWO*WK(2,2) + ELSE +C NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2. + WK(2,1) = WK(1,3) + WK(1,1) = WK(1,2) + WK(1,3) + D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) + * + WK(1,2)**2*WK(2,3)) / WK(1,1) + ENDIF + ELSE IF (IBEG .EQ. 1) THEN +C SLOPE PRESCRIBED AT LEFT END. + WK(2,1) = ONE + WK(1,1) = ZERO + ELSE +C SECOND DERIVATIVE PRESCRIBED AT LEFT END. + WK(2,1) = TWO + WK(1,1) = ONE + D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1) + ENDIF +C +C IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND +C CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH +C EQUATION READS WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J). +C + NM1 = N-1 + IF (NM1 .GT. 1) THEN + DO 20 J=2,NM1 + IF (WK(2,J-1) .EQ. ZERO) GO TO 5008 + G = -WK(1,J+1)/WK(2,J-1) + D(1,J) = G*D(1,J-1) + * + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) + WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) + 20 CONTINUE + ENDIF +C +C CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM +C (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N) +C +C IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK- +C SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT +C AT THIS POINT. + IF (IEND .EQ. 1) GO TO 30 +C + IF (IEND .EQ. 0) THEN + IF (N.EQ.2 .AND. IBEG.EQ.0) THEN +C NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. + D(1,2) = WK(2,2) + GO TO 30 + ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0)) THEN +C EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* +C NOT-A-KNOT AT LEFT END POINT). + D(1,N) = TWO*WK(2,N) + WK(2,N) = ONE + IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 + G = -ONE/WK(2,N-1) + ELSE +C NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR ALSO NOT-A- +C KNOT AT LEFT END POINT. + G = WK(1,N-1) + WK(1,N) +C DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES). + D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) + * + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G + IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 + G = -G/WK(2,N-1) + WK(2,N) = WK(1,N-1) + ENDIF + ELSE +C SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT. + D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) + WK(2,N) = TWO + IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 + G = -ONE/WK(2,N-1) + ENDIF +C +C COMPLETE FORWARD PASS OF GAUSS ELIMINATION. +C + WK(2,N) = G*WK(1,N-1) + WK(2,N) + IF (WK(2,N) .EQ. ZERO) GO TO 5008 + D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) +C +C CARRY OUT BACK SUBSTITUTION +C + 30 CONTINUE + DO 40 J=NM1,1,-1 + IF (WK(2,J) .EQ. ZERO) GO TO 5008 + D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) + 40 CONTINUE +C --------------------( END CODING FROM CUBSPL )-------------------- +C +C NORMAL RETURN. +C + RETURN +C +C ERROR RETURNS. +C + 5001 CONTINUE +C N.LT.2 RETURN. + IERR = -1 + CALL XERMSG ('SLATEC', 'PCHSP', + + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) + RETURN +C + 5002 CONTINUE +C INCFD.LT.1 RETURN. + IERR = -2 + CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR, + + 1) + RETURN +C + 5003 CONTINUE +C X-ARRAY NOT STRICTLY INCREASING. + IERR = -3 + CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING' + + , IERR, 1) + RETURN +C + 5004 CONTINUE +C IC OUT OF RANGE RETURN. + IERR = IERR - 3 + CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1) + RETURN +C + 5007 CONTINUE +C NWK TOO SMALL RETURN. + IERR = -7 + CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1) + RETURN +C + 5008 CONTINUE +C SINGULAR SYSTEM. +C *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES *** +C *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). *** + IERR = -8 + CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR, + + 1) + RETURN +C + 5009 CONTINUE +C ERROR RETURN FROM PCHDF. +C *** THIS CASE SHOULD NEVER OCCUR *** + IERR = -9 + CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR, + + 1) + RETURN +C------------- LAST LINE OF PCHSP FOLLOWS ------------------------------ + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchsp_95.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchsp_95.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/pchsp_95.F90 (revision 1634) @@ -0,0 +1,116 @@ +module pchsp_95_m + + implicit none + +contains + + function pchsp_95(x, f, ibeg, iend, vc_beg, vc_end) + + ! PURPOSE: Set derivatives needed to determine the Hermite + ! representation of the cubic spline interpolant to given data, + ! with specified boundary conditions. + + ! Part of the "pchip" package. + + ! CATEGORY: E1A + + ! KEYWORDS: cubic hermite interpolation, piecewise cubic + ! interpolation, spline interpolation + + ! DESCRIPTION: "pchsp" stands for "Piecewise Cubic Hermite Spline" + ! Computes the Hermite representation of the cubic spline + ! interpolant to the data given in X and F satisfying the boundary + ! conditions specified by Ibeg, iend, vc_beg and VC_end. + + ! The resulting piecewise cubic Hermite function may be evaluated + ! by "pchfe" or "pchfd". + + ! NOTE: This is a modified version of C. de Boor's cubic spline + ! routine "cubspl". + + ! REFERENCE: Carl de Boor, A Practical Guide to Splines, Springer, + ! 2001, pages 43-47 + + use assert_eq_m, only: assert_eq + + real, intent(in):: x(:) + ! independent variable values + ! The elements of X must be strictly increasing: + ! X(I-1) < X(I), I = 2...N. + ! (Error return if not.) + ! (error if size(x) < 2) + + real, intent(in):: f(:) + ! dependent variable values to be interpolated + ! F(I) is value corresponding to X(I). + + INTEGER, intent(in):: ibeg + ! desired boundary condition at beginning of data + + ! IBEG = 0 to set pchsp_95(1) so that the third derivative is con- + ! tinuous at X(2). This is the "not a knot" condition + ! provided by de Boor's cubic spline routine CUBSPL. + ! This is the default boundary condition. + ! IBEG = 1 if first derivative at X(1) is given in VC_BEG. + ! IBEG = 2 if second derivative at X(1) is given in VC_BEG. + ! IBEG = 3 to use the 3-point difference formula for pchsp_95(1). + ! (Reverts to the default boundary condition if size(x) < 3 .) + ! IBEG = 4 to use the 4-point difference formula for pchsp_95(1). + ! (Reverts to the default boundary condition if size(x) < 4 .) + + ! NOTES: + ! 1. An error return is taken if IBEG is out of range. + ! 2. For the "natural" boundary condition, use IBEG=2 and + ! VC_BEG=0. + + INTEGER, intent(in):: iend + ! IC(2) = IEND, desired condition at end of data. + ! IEND may take on the same values as IBEG, but applied to + ! derivative at X(N). In case IEND = 1 or 2, The value is given in VC_END. + + ! NOTES: + ! 1. An error return is taken if IEND is out of range. + ! 2. For the "natural" boundary condition, use IEND=2 and + ! VC_END=0. + + REAL, intent(in), optional:: vc_beg + ! desired boundary value, as indicated above. + ! VC_BEG need be set only if IBEG = 1 or 2 . + + REAL, intent(in), optional:: vc_end + ! desired boundary value, as indicated above. + ! VC_END need be set only if Iend = 1 or 2 . + + real pchsp_95(size(x)) + ! derivative values at the data points + ! These values will determine the cubic spline interpolant + ! with the requested boundary conditions. + ! The value corresponding to X(I) is stored in + ! PCHSP_95(I), I=1...N. + + ! LOCAL VARIABLES: + real wk(2, size(x)) ! real array of working storage + INTEGER n ! number of data points + integer ierr, ic(2) + real vc(2) + + !------------------------------------------------------------------- + + n = assert_eq(size(x), size(f), "pchsp_95 n") + if ((ibeg == 1 .or. ibeg == 2) .and. .not. present(vc_beg)) then + print *, "vc_beg required for IBEG = 1 or 2" + stop 1 + end if + if ((iend == 1 .or. iend == 2) .and. .not. present(vc_end)) then + print *, "vc_end required for IEND = 1 or 2" + stop 1 + end if + ic = (/ibeg, iend/) + if (present(vc_beg)) vc(1) = vc_beg + if (present(vc_end)) vc(2) = vc_end + call PCHSP(IC, VC, N, X, F, pchsp_95, 1, WK, size(WK), IERR) + if (ierr /= 0) stop 1 + + END function pchsp_95 + +end module pchsp_95_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr1_lint_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr1_lint_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr1_lint_m.F90 (revision 1634) @@ -0,0 +1,98 @@ +! $Id$ +module regr1_lint_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr1_lint + ! Each procedure regrids by linear interpolation. + ! The regridding operation is done on the first dimension of the + ! input array. + ! The difference betwwen the procedures is the rank of the first argument. + module procedure regr11_lint, regr12_lint + end interface + + private + public regr1_lint + +contains + + function regr11_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 1. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt !!, polint + + real, intent(in):: vs(:) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(xt)) ! values of the function on the target grid + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs), size(xs), "regr11_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) +!! call polint(xs(is_b:is_b+1), vs(is_b:is_b+1), xt(it), vt(it)) + vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) & + + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr11_lint + + !********************************************************* + + function regr12_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 2. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(xt), size(vs, 2)) ! values of the function on the target grid + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs), "regr12_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) & + + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr12_lint + +end module regr1_lint_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr1_step_av_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr1_step_av_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr1_step_av_m.F90 (revision 1634) @@ -0,0 +1,268 @@ +! $Id$ +module regr1_step_av_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr1_step_av + + ! Each procedure regrids a step function by averaging it. + ! The regridding operation is done on the first dimension of the + ! input array. + ! Source grid contains edges of steps. + ! Target grid contains positions of cell edges. + ! The target grid should be included in the source grid: no + ! extrapolation is allowed. + ! The difference between the procedures is the rank of the first argument. + + module procedure regr11_step_av, regr12_step_av, regr13_step_av, & + regr14_step_av + end interface + + private + public regr1_step_av + +contains + + function regr11_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 1. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1) ! average values on the target grid + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns") + nt = size(xt) - 1 + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr11_step_av xs bad order") + call assert(xt(1) < xt(2), "regr11_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr11_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it)": + left_edge = xt(it) + vt(it) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) & + / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr11_step_av + + !******************************************** + + function regr12_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 2. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr12_step_av xs bad order") + call assert(xt(1) < xt(2), "regr12_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr12_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :)": + left_edge = xt(it) + vt(it, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) & + / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr12_step_av + + !******************************************** + + function regr13_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 3. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) + ! (average values on the target grid) + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr13_step_av xs bad order") + call assert(xt(1) < xt(2), "regr13_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr13_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :, :)": + left_edge = xt(it) + vt(it, :, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :, :) = (vt(it, :, :) & + + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr13_step_av + + !******************************************** + + function regr14_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 4. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4)) + ! (average values on the target grid) + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr14_step_av xs bad order") + call assert(xt(1) < xt(2), "regr14_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr14_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :, :, :)": + left_edge = xt(it) + vt(it, :, :, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) & + * vs(is, :, :, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) & + * vs(is, :, :, :)) / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr14_step_av + +end module regr1_step_av_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr3_lint_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr3_lint_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/regr3_lint_m.F90 (revision 1634) @@ -0,0 +1,100 @@ +! $Id$ +module regr3_lint_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr3_lint + ! Each procedure regrids by linear interpolation. + ! The regridding operation is done on the third dimension of the + ! input array. + ! The difference betwwen the procedures is the rank of the first argument. + module procedure regr33_lint, regr34_lint + end interface + + private + public regr3_lint + +contains + + function regr33_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 3. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(vs, 1), size(vs, 2), size(xt)) + ! (values of the function on the target grid) + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 3), size(xs), "regr33_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(:, :, it) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b) & + + (xt(it) - xs(is_b)) * vs(:, :, is_b+1)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr33_lint + + !********************************************************* + + function regr34_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 4. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :, :, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(vs, 1), size(vs, 2), size(xt), size(vs, 4)) + ! (values of the function on the target grid) + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 3), size(xs), "regr34_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(:, :, it, :) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b, :) & + + (xt(it) - xs(is_b)) * vs(:, :, is_b+1, :)) & + / (xs(is_b+1) - xs(is_b)) + end do + + end function regr34_lint + +end module regr3_lint_m Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/simple.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/simple.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/simple.F90 (revision 1634) @@ -0,0 +1,312 @@ +! $Id$ +module simple + + implicit none + +contains + + subroutine nf95_open(path, mode, ncid, chunksize, ncerr) + + use netcdf, only: nf90_open + use handle_err_m, only: handle_err + + character(len=*), intent(in):: path + integer, intent(in):: mode + integer, intent(out):: ncid + integer, intent(inout), optional:: chunksize + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_open(path, mode, ncid, chunksize) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_open " // path, ncerr_not_opt) + end if + + end subroutine nf95_open + + !************************ + + subroutine nf95_inq_dimid(ncid, name, dimid, ncerr) + + use netcdf, only: nf90_inq_dimid + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent(out) :: dimid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_inq_dimid(ncid, name, dimid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inq_dimid", ncerr_not_opt, ncid) + end if + + end subroutine nf95_inq_dimid + + !************************ + + subroutine nf95_inquire_dimension(ncid, dimid, name, len, ncerr) + + use netcdf, only: nf90_inquire_dimension + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid, dimid + character (len = *), optional, intent(out) :: name + integer, optional, intent(out) :: len + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, len) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inquire_dimension", ncerr_not_opt, ncid) + end if + + end subroutine nf95_inquire_dimension + + !************************ + + subroutine nf95_inq_varid(ncid, name, varid, ncerr) + + use netcdf, only: nf90_inq_varid + use handle_err_m, only: handle_err + + integer, intent(in) :: ncid + character (len = *), intent(in) :: name + integer, intent(out) :: varid + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_inq_varid(ncid, name, varid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inq_varid, name = " // name, ncerr_not_opt, ncid) + end if + + end subroutine nf95_inq_varid + + !************************ + + subroutine nf95_inquire_variable(ncid, varid, name, xtype, ndims, dimids, & + nAtts, ncerr) + + ! In "nf90_inquire_variable", "dimids" is an assumed-size array. + ! This is the classical case of an array the size of which is + ! unknown in the calling procedure, before the call. + ! Here we use a better solution: a pointer argument array. + ! This procedure associates and defines "dimids" if it is present. + + use netcdf, only: nf90_inquire_variable, nf90_max_var_dims + use handle_err_m, only: handle_err + + integer, intent(in):: ncid, varid + character(len = *), optional, intent(out):: name + integer, optional, intent(out) :: xtype, ndims + integer, dimension(:), optional, pointer :: dimids + integer, optional, intent(out) :: nAtts + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + integer dimids_local(nf90_max_var_dims) + integer ndims_not_opt + + !------------------- + + if (present(dimids)) then + ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, & + ndims_not_opt, dimids_local, nAtts) + allocate(dimids(ndims_not_opt)) ! also works if ndims_not_opt == 0 + dimids = dimids_local(:ndims_not_opt) + if (present(ndims)) ndims = ndims_not_opt + else + ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, ndims, & + nAtts=nAtts) + end if + + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid) + end if + + end subroutine nf95_inquire_variable + + !************************ + + subroutine nf95_create(path, cmode, ncid, initialsize, chunksize, ncerr) + + use netcdf, only: nf90_create + use handle_err_m, only: handle_err + + character (len = *), intent(in ) :: path + integer, intent(in ) :: cmode + integer, intent( out) :: ncid + integer, optional, intent(in ) :: initialsize + integer, optional, intent(inout) :: chunksize + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_create(path, cmode, ncid, initialsize, chunksize) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_create " // path, ncerr_not_opt) + end if + + end subroutine nf95_create + + !************************ + + subroutine nf95_def_dim(ncid, name, len, dimid, ncerr) + + use netcdf, only: nf90_def_dim + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + character (len = *), intent( in) :: name + integer, intent( in) :: len + integer, intent(out) :: dimid + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_def_dim(ncid, name, len, dimid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_def_dim", ncerr_not_opt, ncid) + end if + + end subroutine nf95_def_dim + + !*********************** + + subroutine nf95_redef(ncid, ncerr) + + use netcdf, only: nf90_redef + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_redef(ncid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_redef", ncerr_not_opt, ncid) + end if + + end subroutine nf95_redef + + !*********************** + + subroutine nf95_enddef(ncid, h_minfree, v_align, v_minfree, r_align, ncerr) + + use netcdf, only: nf90_enddef + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + integer, optional, intent( in) :: h_minfree, v_align, v_minfree, r_align + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_enddef(ncid, h_minfree, v_align, v_minfree, r_align) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_enddef", ncerr_not_opt, ncid) + end if + + end subroutine nf95_enddef + + !*********************** + + subroutine nf95_close(ncid, ncerr) + + use netcdf, only: nf90_close + use handle_err_m, only: handle_err + + integer, intent( in) :: ncid + integer, intent(out), optional :: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_close(ncid) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_close", ncerr_not_opt) + end if + + end subroutine nf95_close + + !*********************** + + subroutine nf95_copy_att(ncid_in, varid_in, name, ncid_out, varid_out, ncerr) + + use netcdf, only: nf90_copy_att + use handle_err_m, only: handle_err + + integer, intent( in):: ncid_in, varid_in + character(len=*), intent( in):: name + integer, intent( in):: ncid_out, varid_out + integer, intent(out), optional:: ncerr + + ! Variable local to the procedure: + integer ncerr_not_opt + + !------------------- + + ncerr_not_opt = nf90_copy_att(ncid_in, varid_in, name, ncid_out, varid_out) + if (present(ncerr)) then + ncerr = ncerr_not_opt + else + call handle_err("nf95_copy_att", ncerr_not_opt, ncid_out) + end if + + end subroutine nf95_copy_att + +end module simple Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/vampir.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/vampir.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/vampir.F90 (revision 1634) @@ -0,0 +1,86 @@ +module Vampir + + INTEGER,parameter :: VTcaldyn=1 + INTEGER,parameter :: VTintegre=2 + INTEGER,parameter :: VTadvection=3 + INTEGER,parameter :: VTdissipation=4 + INTEGER,parameter :: VThallo=5 + INTEGER,parameter :: VTphysiq=6 + INTEGER,parameter :: VTinca=7 + + INTEGER,parameter :: nb_inst=7 + INTEGER :: MPE_begin(nb_inst) + INTEGER :: MPE_end(nb_inst) + +contains + + subroutine InitVampir + implicit none + +#ifdef USE_VT + include 'VT.inc' + integer :: ierr + + call VTSYMDEF(VTcaldyn,"caldyn","caldyn",ierr) + call VTSYMDEF(VTintegre,"integre","integre",ierr) + call VTSYMDEF(VTadvection,"advection","advection",ierr) + call VTSYMDEF(VTdissipation,"dissipation","dissipation",ierr) + call VTSYMDEF(VThallo,"hallo","hallo",ierr) + call VTSYMDEF(VTphysiq,"physiq","physiq",ierr) + call VTSYMDEF(VTinca,"inca","inca",ierr) +#endif + +#ifdef USE_MPE + include 'mpe_logf.h' + integer :: ierr,i + + DO i=1,nb_inst + ierr = MPE_Log_get_state_eventIDs( MPE_begin(i), MPE_end(i) ) + ENDDO + + ierr = MPE_Describe_state( MPE_begin(VTcaldyn), MPE_end(VTcaldyn),"caldyn", "yellow" ) + ierr = MPE_Describe_state( MPE_begin(VTintegre), MPE_end(VTintegre),"integre", "blue" ) + ierr = MPE_Describe_state( MPE_begin(VTadvection), MPE_end(VTadvection),"advection", "green" ) + ierr = MPE_Describe_state( MPE_begin(VTdissipation), MPE_end(VTdissipation),"dissipation", "ivory" ) + ierr = MPE_Describe_state( MPE_begin(VThallo), MPE_end(VThallo),"hallo", "orange" ) + ierr = MPE_Describe_state( MPE_begin(VTphysiq), MPE_end(VTphysiq),"physiq", "purple" ) + ierr = MPE_Describe_state( MPE_begin(VTinca), MPE_end(VTinca),"inca", "LightBlue" ) +#endif + end subroutine InitVampir + + subroutine VTb(number) + implicit none + INTEGER :: number +#ifdef USE_VT + include 'VT.inc' + integer :: ierr + + call VTBEGIN(number,ierr) +#endif +#ifdef USE_MPE + include 'mpe_logf.h' + integer :: ierr,i + ierr = MPE_Log_event( MPE_begin(number), 0, '' ) +#endif + + end subroutine VTb + + subroutine VTe(number) + implicit none + INTEGER :: Number +#ifdef USE_VT + include 'VT.inc' + integer :: ierr + + call VTEND(number,ierr) +#endif + +#ifdef USE_MPE + include 'mpe_logf.h' + integer :: ierr,i + ierr = MPE_Log_event( MPE_end(number), 0, '' ) +#endif + + end subroutine VTe + +end module Vampir Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/write_field.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/write_field.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/write_field.F90 (revision 1634) @@ -0,0 +1,326 @@ +! +! $Id$ +! +module write_field +implicit none + + integer, parameter :: MaxWriteField = 100 + integer, dimension(MaxWriteField),save :: FieldId + integer, dimension(MaxWriteField),save :: FieldVarId + integer, dimension(MaxWriteField),save :: FieldIndex + character(len=255), dimension(MaxWriteField) :: FieldName + + integer,save :: NbField = 0 + + interface WriteField + module procedure WriteField3d,WriteField2d,WriteField1d + end interface WriteField + contains + + function GetFieldIndex(name) + implicit none + integer :: GetFieldindex + character(len=*) :: name + + character(len=255) :: TrueName + integer :: i + + + TrueName=TRIM(ADJUSTL(name)) + + GetFieldIndex=-1 + do i=1,NbField + if (TrueName==FieldName(i)) then + GetFieldIndex=i + exit + endif + enddo + end function GetFieldIndex + + subroutine WriteField3d(name,Field) + implicit none + character(len=*) :: name + real, dimension(:,:,:) :: Field + integer, dimension(3) :: Dim + + Dim=shape(Field) + call WriteField_gen(name,Field,Dim(1),Dim(2),Dim(3)) + + end subroutine WriteField3d + + subroutine WriteField2d(name,Field) + implicit none + character(len=*) :: name + real, dimension(:,:) :: Field + integer, dimension(2) :: Dim + + Dim=shape(Field) + call WriteField_gen(name,Field,Dim(1),Dim(2),1) + + end subroutine WriteField2d + + subroutine WriteField1d(name,Field) + implicit none + character(len=*) :: name + real, dimension(:) :: Field + integer, dimension(1) :: Dim + + Dim=shape(Field) + call WriteField_gen(name,Field,Dim(1),1,1) + + end subroutine WriteField1d + + subroutine WriteField_gen(name,Field,dimx,dimy,dimz) + implicit none + include 'netcdf.inc' + character(len=*) :: name + integer :: dimx,dimy,dimz + real,dimension(dimx,dimy,dimz) :: Field + integer,dimension(dimx*dimy*dimz) :: ndex + integer :: status + integer :: index + integer :: start(4) + integer :: count(4) + + + Index=GetFieldIndex(name) + if (Index==-1) then + call CreateNewField(name,dimx,dimy,dimz) + Index=GetFieldIndex(name) + else + FieldIndex(Index)=FieldIndex(Index)+1. + endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=FieldIndex(Index) + + count(1)=dimx + count(2)=dimy + count(3)=dimz + count(4)=1 + + status = NF_PUT_VARA_DOUBLE(FieldId(Index),FieldVarId(Index),start,count,Field) + status = NF_SYNC(FieldId(Index)) + + end subroutine WriteField_gen + + subroutine CreateNewField(name,dimx,dimy,dimz) + implicit none + include 'netcdf.inc' + character(len=*) :: name + integer :: dimx,dimy,dimz + integer :: TabDim(4) + integer :: status + + + NbField=NbField+1 + FieldName(NbField)=TRIM(ADJUSTL(name)) + FieldIndex(NbField)=1 + + + status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField)) + status = NF_DEF_DIM(FieldId(NbField),'X',dimx,TabDim(1)) + status = NF_DEF_DIM(FieldId(NbField),'Y',dimy,TabDim(2)) + status = NF_DEF_DIM(FieldId(NbField),'Z',dimz,TabDim(3)) + status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(4)) + status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,4,TabDim,FieldVarId(NbField)) + status = NF_ENDDEF(FieldId(NbField)) + + end subroutine CreateNewField + + + + subroutine write_field1D(name,Field) + implicit none + + integer, parameter :: MaxDim=1 + character(len=*) :: name + real, dimension(:) :: Field + real, dimension(:),allocatable :: New_Field + character(len=20) :: str + integer, dimension(MaxDim) :: Dim + integer :: i,nb + integer, parameter :: id=10 + integer, parameter :: NbCol=4 + integer :: ColumnSize + integer :: pos + character(len=255) :: form + character(len=255) :: MaxLen + + + open(unit=id,file=name//'.field',form='formatted',status='replace') + write (id,'("----- Field '//name//'",//)') + Dim=shape(Field) + MaxLen=int2str(len(trim(int2str(Dim(1))))) + ColumnSize=20+6+3+len(trim(int2str(Dim(1)))) + Nb=0 + Pos=2 + do i=1,Dim(1) + nb=nb+1 + + if (MOD(nb,NbCol)==0) then + form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)' + Pos=2 + else + form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)' + Pos=Pos+ColumnSize + endif + write (id,form,advance='no') i,Field(i) + enddo + + close(id) + + end subroutine write_field1D + + subroutine write_field2D(name,Field) + implicit none + + integer, parameter :: MaxDim=2 + character(len=*) :: name + real, dimension(:,:) :: Field + real, dimension(:,:),allocatable :: New_Field + character(len=20) :: str + integer, dimension(MaxDim) :: Dim + integer :: i,j,nb + integer, parameter :: id=10 + integer, parameter :: NbCol=4 + integer :: ColumnSize + integer :: pos,offset + character(len=255) :: form + character(len=255) :: spacing + + open(unit=id,file=name//'.field',form='formatted',status='replace') + write (id,'("----- Field '//name//'",//)') + + Dim=shape(Field) + offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+3 + ColumnSize=20+6+3+offset + + spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")' + + do i=1,Dim(2) + nb=0 + Pos=2 + do j=1,Dim(1) + nb=nb+1 + + if (MOD(nb,NbCol)==0) then + form='(t'//trim(int2str(pos))// & + ',"('//trim(int2str(j))//',' & + //trim(int2str(i))//')",t' & + //trim(int2str(pos+offset)) & + //'," ---> ",g22.16,/)' + Pos=2 + else + form='(t'//trim(int2str(pos))// & + ',"('//trim(int2str(j))//',' & + //trim(int2str(i))//')",t' & + //trim(int2str(pos+offset)) & + //'," ---> ",g22.16," | ")' + Pos=Pos+ColumnSize + endif + write (id,form,advance='no') Field(j,i) + enddo + if (MOD(nb,NbCol)==0) then + write (id,spacing) + else + write (id,'("")') + write (id,spacing) + endif + enddo + + end subroutine write_field2D + + subroutine write_field3D(name,Field) + implicit none + + integer, parameter :: MaxDim=3 + character(len=*) :: name + real, dimension(:,:,:) :: Field + real, dimension(:,:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + integer :: i,j,k,nb + integer, parameter :: id=10 + integer, parameter :: NbCol=4 + integer :: ColumnSize + integer :: pos,offset + character(len=255) :: form + character(len=255) :: spacing + + open(unit=id,file=name//'.field',form='formatted',status='replace') + write (id,'("----- Field '//name//'"//)') + + Dim=shape(Field) + offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+len(trim(int2str(Dim(3))))+4 + ColumnSize=22+6+3+offset + +! open(unit=id,file=name,form=formatted + + spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")' + + do i=1,Dim(3) + + do j=1,Dim(2) + nb=0 + Pos=2 + + do k=1,Dim(1) + nb=nb+1 + + 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)) & + //'," ---> ",g22.16,/)' + Pos=2 + else + form='(t'//trim(int2str(pos))// & + ',"('//trim(int2str(k))//',' & + //trim(int2str(j))//',' & + //trim(int2str(i))//')",t' & + //trim(int2str(pos+offset)) & + //'," ---> ",g22.16," | ")' +! dépent de l'implémention, sur compaq, c'est necessaire +! Pos=Pos+ColumnSize + endif + write (id,form,advance='no') Field(k,j,i) + enddo + if (MOD(nb,NbCol)==0) then + write (id,spacing) + else + write (id,'("")') + write (id,spacing) + endif + enddo + write (id,spacing) + enddo + + close(id) + + end subroutine write_field3D + + function int2str(int) + implicit none + integer, parameter :: MaxLen=10 + integer,intent(in) :: int + character(len=MaxLen) :: int2str + logical :: flag + integer :: i + flag=.true. + + i=int + + int2str='' + do while (flag) + int2str=CHAR(MOD(i,10)+48)//int2str + i=i/10 + if (i==0) flag=.false. + enddo + end function int2str + +end module write_field + Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/writedynav.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/writedynav.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/writedynav.F (revision 1634) @@ -0,0 +1,152 @@ +! +! $Id$ +! + subroutine writedynav(time, vcov, + , ucov,teta,ppk,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL + USE ioipsl +#endif + USE infotrac, ONLY : nqtot, ttext + use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1*llm),phi(ip1jmp1,llm),ppk(ip1jmp1*llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer ndex2d(ip1jmp1),ndexu(ip1jmp1*llm),ndexv(ip1jm*llm) + INTEGER iq, ii, ll + real tm(ip1jmp1*llm) + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + logical ok_sync + integer itau_w +C +C Initialisations +C + ndexu = 0 + ndexv = 0 + ndex2d = 0 + ok_sync = .TRUE. + tm = 999.999 + vnat = 999.999 + unat = 999.999 + itau_w = itau_dyn + time + +C Passage aux composantes naturelles du vent + call covnat(llm, ucov, vcov, unat, vnat) + +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + call histwrite(histuaveid, 'u', itau_w, unat, + . iip1*jjp1*llm, ndexu) +C +C Vents V +C + call histwrite(histvaveid, 'v', itau_w, vnat, + . iip1*jjm*llm, ndexv) +C +C Temperature potentielle moyennee +C + call histwrite(histaveid, 'theta', itau_w, teta, + . iip1*jjp1*llm, ndexu) +C +C Temperature moyennee +C + do ii = 1, ijp1llm + tm(ii) = teta(ii) * ppk(ii)/cpp + enddo + call histwrite(histaveid, 'temp', itau_w, tm, + . iip1*jjp1*llm, ndexu) +C +C Geopotentiel +C + call histwrite(histaveid, 'phi', itau_w, phi, + . iip1*jjp1*llm, ndexu) +C +C Traceurs +C +! DO iq=1,nqtot +! call histwrite(histaveid, ttext(iq), itau_w, q(:,:,iq), +! . iip1*jjp1*llm, ndexu) +! enddo +C +C Masse +C + call histwrite(histaveid, 'masse', itau_w, masse, + $ iip1*jjp1*llm, ndexu) +C +C Pression au sol +C + call histwrite(histaveid, 'ps', itau_w, ps, iip1*jjp1, ndex2d) +C +C Geopotentiel au sol +C +! call histwrite(histaveid,'phis',itau_w, phis,iip1*jjp1, ndex2d) +C +C Fin +C + if (ok_sync) then + call histsync(histaveid) + call histsync(histvaveid) + call histsync(histuaveid) + ENDIF + +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"writedynav: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/writehist.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/writehist.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/writehist.F (revision 1634) @@ -0,0 +1,136 @@ +! +! $Id$ +! + subroutine writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL + USE ioipsl +#endif + USE infotrac, ONLY : nqtot, ttext + use com_io_dyn_mod, only : histid,histvid,histuid + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL to work +C Variables locales +C + integer iq, ii, ll + integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1) + logical ok_sync + integer itau_w + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + +C +C Initialisations +C + ndexu = 0 + ndexv = 0 + ndex2d = 0 + ok_sync =.TRUE. + itau_w = itau_dyn + time +! Passage aux composantes naturelles du vent + call covnat(llm, ucov, vcov, unat, vnat) +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + call histwrite(histuid, 'u', itau_w, unat, + . iip1*jjp1*llm, ndexu) +C +C Vents V +C + call histwrite(histvid, 'v', itau_w, vnat, + . iip1*jjm*llm, ndexv) + +C +C Temperature potentielle +C + call histwrite(histid, 'teta', itau_w, teta, + . iip1*jjp1*llm, ndexu) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi, + . iip1*jjp1*llm, ndexu) +C +C Traceurs +C +! DO iq=1,nqtot +! call histwrite(histid, ttext(iq), itau_w, q(:,:,iq), +! . iip1*jjp1*llm, ndexu) +! enddo +!C +C Masse +C + call histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d) +C +C Geopotentiel au sol +C +! call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d) +C +C Fin +C + if (ok_sync) then + call histsync(histid) + call histsync(histvid) + call histsync(histuid) + endif +#else +! tell the user this routine should be run with ioipsl + write(lunout,*)"writehist: Warning this routine should not be", + & " used without ioipsl" +#endif +! of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/xercnt.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/xercnt.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/xercnt.F (revision 1634) @@ -0,0 +1,60 @@ +*DECK XERCNT + SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) +C***BEGIN PROLOGUE XERCNT +C***SUBSIDIARY +C***PURPOSE Allow user control over handling of errors. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERCNT-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C Allows user control over handling of individual errors. +C Just after each message is recorded, but before it is +C processed any further (i.e., before it is printed or +C a decision to abort is made), a call is made to XERCNT. +C If the user has provided his own version of XERCNT, he +C can then override the value of KONTROL used in processing +C this message by redefining its value. +C KONTRL may be set to any value from -2 to 2. +C The meanings for KONTRL are the same as in XSETF, except +C that the value of KONTRL changes only for this message. +C If KONTRL is set to a value outside the range from -2 to 2, +C it will be moved back into that range. +C +C Description of Parameters +C +C --Input-- +C LIBRAR - the library that the routine is in. +C SUBROU - the subroutine that XERMSG is being called from +C MESSG - the first 20 characters of the error message. +C NERR - same as in the call to XERMSG. +C LEVEL - same as in the call to XERMSG. +C KONTRL - the current value of the control flag as set +C by a call to XSETF. +C +C --Output-- +C KONTRL - the new value of KONTRL. If KONTRL is not +C defined, it will remain at its original value. +C This changed value of control affects only +C the current occurrence of the current message. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE +C names, changed routine name from XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERCNT + CHARACTER*(*) LIBRAR, SUBROU, MESSG +C***FIRST EXECUTABLE STATEMENT XERCNT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/xerhlt.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/xerhlt.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/xerhlt.F (revision 1634) @@ -0,0 +1,39 @@ +*DECK XERHLT + SUBROUTINE XERHLT (MESSG) +C***BEGIN PROLOGUE XERHLT +C***SUBSIDIARY +C***PURPOSE Abort program execution and print error message. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERHLT-A) +C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C ***Note*** machine dependent routine +C XERHLT aborts the execution of the program. +C The error message causing the abort is given in the calling +C sequence, in case one needs it for printing on a dayfile, +C for example. +C +C Description of Parameters +C MESSG is as in XERMSG. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to delete length of character +C and changed routine name from XERABT to XERHLT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERHLT + CHARACTER*(*) MESSG +C***FIRST EXECUTABLE STATEMENT XERHLT + STOP + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/xermsg.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/xermsg.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/xermsg.F (revision 1634) @@ -0,0 +1,364 @@ +*DECK XERMSG + SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) +C***BEGIN PROLOGUE XERMSG +C***PURPOSE Process error messages for SLATEC and other libraries. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERMSG-A) +C***KEYWORDS ERROR MESSAGE, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C XERMSG processes a diagnostic message in a manner determined by the +C value of LEVEL and the current value of the library error control +C flag, KONTRL. See subroutine XSETF for details. +C +C LIBRAR A character constant (or character variable) with the name +C of the library. This will be 'SLATEC' for the SLATEC +C Common Math Library. The error handling package is +C general enough to be used by many libraries +C simultaneously, so it is desirable for the routine that +C detects and reports an error to identify the library name +C as well as the routine name. +C +C SUBROU A character constant (or character variable) with the name +C of the routine that detected the error. Usually it is the +C name of the routine that is calling XERMSG. There are +C some instances where a user callable library routine calls +C lower level subsidiary routines where the error is +C detected. In such cases it may be more informative to +C supply the name of the routine the user called rather than +C the name of the subsidiary routine that detected the +C error. +C +C MESSG A character constant (or character variable) with the text +C of the error or warning message. In the example below, +C the message is a character constant that contains a +C generic message. +C +C CALL XERMSG ('SLATEC', 'MMPY', +C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', +C *3, 1) +C +C It is possible (and is sometimes desirable) to generate a +C specific message--e.g., one that contains actual numeric +C values. Specific numeric values can be converted into +C character strings using formatted WRITE statements into +C character variables. This is called standard Fortran +C internal file I/O and is exemplified in the first three +C lines of the following example. You can also catenate +C substrings of characters to construct the error message. +C Here is an example showing the use of both writing to +C an internal file and catenating character strings. +C +C CHARACTER*5 CHARN, CHARL +C WRITE (CHARN,10) N +C WRITE (CHARL,10) LDA +C 10 FORMAT(I5) +C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// +C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// +C * CHARL, 3, 1) +C +C There are two subtleties worth mentioning. One is that +C the // for character catenation is used to construct the +C error message so that no single character constant is +C continued to the next line. This avoids confusion as to +C whether there are trailing blanks at the end of the line. +C The second is that by catenating the parts of the message +C as an actual argument rather than encoding the entire +C message into one large character variable, we avoid +C having to know how long the message will be in order to +C declare an adequate length for that large character +C variable. XERMSG calls XERPRN to print the message using +C multiple lines if necessary. If the message is very long, +C XERPRN will break it into pieces of 72 characters (as +C requested by XERMSG) for printing on multiple lines. +C Also, XERMSG asks XERPRN to prefix each line with ' * ' +C so that the total line length could be 76 characters. +C Note also that XERPRN scans the error message backwards +C to ignore trailing blanks. Another feature is that +C the substring '$$' is treated as a new line sentinel +C by XERPRN. If you want to construct a multiline +C message without having to count out multiples of 72 +C characters, just use '$$' as a separator. '$$' +C obviously must occur within 72 characters of the +C start of each line to have its intended effect since +C XERPRN is asked to wrap around at 72 characters in +C addition to looking for '$$'. +C +C NERR An integer value that is chosen by the library routine's +C author. It must be in the range -99 to 999 (three +C printable digits). Each distinct error should have its +C own error number. These error numbers should be described +C in the machine readable documentation for the routine. +C The error numbers need be unique only within each routine, +C so it is reasonable for each routine to start enumerating +C errors from 1 and proceeding to the next integer. +C +C LEVEL An integer value in the range 0 to 2 that indicates the +C level (severity) of the error. Their meanings are +C +C -1 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. An attempt is made to only print this +C message once. +C +C 0 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. +C +C 1 A recoverable error. This is used even if the error is +C so serious that the routine cannot return any useful +C answer. If the user has told the error package to +C return after recoverable errors, then XERMSG will +C return to the Library routine which can then return to +C the user's routine. The user may also permit the error +C package to terminate the program upon encountering a +C recoverable error. +C +C 2 A fatal error. XERMSG will not return to its caller +C after it receives a fatal error. This level should +C hardly ever be used; it is much better to allow the +C user a chance to recover. An example of one of the few +C cases in which it is permissible to declare a level 2 +C error is a reverse communication Library routine that +C is likely to be called repeatedly until it integrates +C across some interval. If there is a serious error in +C the input such that another step cannot be taken and +C the Library routine is called again without the input +C error having been corrected by the caller, the Library +C routine will probably be called forever with improper +C input. In this case, it is reasonable to declare the +C error to be fatal. +C +C Each of the arguments to XERMSG is input; none will be modified by +C XERMSG. A routine may make multiple calls to XERMSG with warning +C level messages; however, after a call to XERMSG with a recoverable +C error, the routine should return to the user. Do not try to call +C XERMSG with a second recoverable error after the first recoverable +C error because the error package saves the error number. The user +C can retrieve this error number by calling another entry point in +C the error handling package and then clear the error number when +C recovering from the error. Calling XERMSG in succession causes the +C old error number to be overwritten by the latest error number. +C This is considered harmless for error numbers associated with +C warning messages but must not be done for error numbers of serious +C errors. After a call to XERMSG with a recoverable error, the user +C must be given a chance to call NUMXER or XERCLR to retrieve or +C clear the error number. +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE +C***REVISION HISTORY (YYMMDD) +C 880101 DATE WRITTEN +C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. +C THERE ARE TWO BASIC CHANGES. +C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO +C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES +C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS +C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE +C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER +C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY +C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE +C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. +C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE +C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE +C OF LOWER CASE. +C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. +C THE PRINCIPAL CHANGES ARE +C 1. CLARIFY COMMENTS IN THE PROLOGUES +C 2. RENAME XRPRNT TO XERPRN +C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES +C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / +C CHARACTER FOR NEW RECORDS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C CLEAN UP THE CODING. +C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN +C PREFIX. +C 891013 REVISED TO CORRECT COMMENTS. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but +C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added +C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and +C XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERMSG + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 XLIBR, XSUBR + CHARACTER*72 TEMP + CHARACTER*20 LFIRST +C***FIRST EXECUTABLE STATEMENT XERMSG + LKNTRL = J4SAVE (2, 0, .FALSE.) + MAXMES = J4SAVE (4, 0, .FALSE.) +C +C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. +C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE +C SHOULD BE PRINTED. +C +C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN +C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, +C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. +C + IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. + * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN + CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // + * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// + * 'JOB ABORT DUE TO FATAL ERROR.', 72) + CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) + CALL XERHLT (' ***XERMSG -- INVALID INPUT') + RETURN + ENDIF +C +C RECORD THE MESSAGE. +C + I = J4SAVE (1, NERR, .TRUE.) + CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) +C +C HANDLE PRINT-ONCE WARNING MESSAGES. +C + IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN +C +C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. +C + XLIBR = LIBRAR + XSUBR = SUBROU + LFIRST = MESSG + LERR = NERR + LLEVEL = LEVEL + CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) +C + LKNTRL = MAX(-2, MIN(2,LKNTRL)) + MKNTRL = ABS(LKNTRL) +C +C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS +C ZERO AND THE ERROR IS NOT FATAL. +C + IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 + IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 + IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 + IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 +C +C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A +C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) +C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG +C IS NOT ZERO. +C + IF (LKNTRL .NE. 0) THEN + TEMP(1:21) = 'MESSAGE FROM ROUTINE ' + I = MIN(LEN(SUBROU), 16) + TEMP(22:21+I) = SUBROU(1:I) + TEMP(22+I:33+I) = ' IN LIBRARY ' + LTEMP = 33 + I + I = MIN(LEN(LIBRAR), 16) + TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) + TEMP(LTEMP+I+1:LTEMP+I+1) = '.' + LTEMP = LTEMP + I + 1 + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE +C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE +C FROM EACH OF THE FOLLOWING THREE OPTIONS. +C 1. LEVEL OF THE MESSAGE +C 'INFORMATIVE MESSAGE' +C 'POTENTIALLY RECOVERABLE ERROR' +C 'FATAL ERROR' +C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE +C 'PROG CONTINUES' +C 'PROG ABORTED' +C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK +C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS +C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) +C 'TRACEBACK REQUESTED' +C 'TRACEBACK NOT REQUESTED' +C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT +C EXCEED 74 CHARACTERS. +C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. +C + IF (LKNTRL .GT. 0) THEN +C +C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. +C + IF (LEVEL .LE. 0) THEN + TEMP(1:20) = 'INFORMATIVE MESSAGE,' + LTEMP = 20 + ELSEIF (LEVEL .EQ. 1) THEN + TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' + LTEMP = 30 + ELSE + TEMP(1:12) = 'FATAL ERROR,' + LTEMP = 12 + ENDIF +C +C THEN WHETHER THE PROGRAM WILL CONTINUE. +C + IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. + * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN + TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' + LTEMP = LTEMP + 14 + ELSE + TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' + LTEMP = LTEMP + 16 + ENDIF +C +C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' + LTEMP = LTEMP + 20 + ELSE + TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' + LTEMP = LTEMP + 24 + ENDIF + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C NOW SEND OUT THE MESSAGE. +C + CALL XERPRN (' * ', -1, MESSG, 72) +C +C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A +C TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR + DO 10 I=16,22 + IF (TEMP(I:I) .NE. ' ') GO TO 20 + 10 CONTINUE +C + 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) + CALL FDUMP + ENDIF +C +C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. +C + IF (LKNTRL .NE. 0) THEN + CALL XERPRN (' * ', -1, ' ', 72) + CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) + CALL XERPRN (' ', 0, ' ', 72) + ENDIF +C +C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE +C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. +C + 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN +C +C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A +C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR +C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. +C + IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN + IF (LEVEL .EQ. 1) THEN + CALL XERPRN + * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) + ELSE + CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) + ENDIF + CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) + CALL XERHLT (' ') + ELSE + CALL XERHLT (MESSG) + ENDIF + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/xerprn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/xerprn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/xerprn.F (revision 1634) @@ -0,0 +1,228 @@ +*DECK XERPRN + SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) +C***BEGIN PROLOGUE XERPRN +C***SUBSIDIARY +C***PURPOSE Print error messages processed by XERMSG. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERPRN-A) +C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C This routine sends one or more lines to each of the (up to five) +C logical units to which error messages are to be sent. This routine +C is called several times by XERMSG, sometimes with a single line to +C print and sometimes with a (potentially very long) message that may +C wrap around into multiple lines. +C +C PREFIX Input argument of type CHARACTER. This argument contains +C characters to be put at the beginning of each line before +C the body of the message. No more than 16 characters of +C PREFIX will be used. +C +C NPREF Input argument of type INTEGER. This argument is the number +C of characters to use from PREFIX. If it is negative, the +C intrinsic function LEN is used to determine its length. If +C it is zero, PREFIX is not used. If it exceeds 16 or if +C LEN(PREFIX) exceeds 16, only the first 16 characters will be +C used. If NPREF is positive and the length of PREFIX is less +C than NPREF, a copy of PREFIX extended with blanks to length +C NPREF will be used. +C +C MESSG Input argument of type CHARACTER. This is the text of a +C message to be printed. If it is a long message, it will be +C broken into pieces for printing on multiple lines. Each line +C will start with the appropriate prefix and be followed by a +C piece of the message. NWRAP is the number of characters per +C piece; that is, after each NWRAP characters, we break and +C start a new line. In addition the characters '$$' embedded +C in MESSG are a sentinel for a new line. The counting of +C characters up to NWRAP starts over for each new line. The +C value of NWRAP typically used by XERMSG is 72 since many +C older error messages in the SLATEC Library are laid out to +C rely on wrap-around every 72 characters. +C +C NWRAP Input argument of type INTEGER. This gives the maximum size +C piece into which to break MESSG for printing on multiple +C lines. An embedded '$$' ends a line, and the count restarts +C at the following character. If a line break does not occur +C on a blank (it would split a word) that word is moved to the +C next line. Values of NWRAP less than 16 will be treated as +C 16. Values of NWRAP greater than 132 will be treated as 132. +C The actual line length will be NPREF + NWRAP after NPREF has +C been adjusted to fall between 0 and 16 and NWRAP has been +C adjusted to fall between 16 and 132. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 880621 DATE WRITTEN +C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF +C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK +C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE +C SLASH CHARACTER IN FORMAT STATEMENTS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK +C LINES TO BE PRINTED. +C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF +C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. +C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Added code to break messages between words. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERPRN + CHARACTER*(*) PREFIX, MESSG + INTEGER NPREF, NWRAP + CHARACTER*148 CBUFF + INTEGER IU(5), NUNIT + CHARACTER*2 NEWLIN + PARAMETER (NEWLIN = '$$') +C***FIRST EXECUTABLE STATEMENT XERPRN + CALL XGETUA(IU,NUNIT) +C +C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD +C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD +C ERROR MESSAGE UNIT. +C + N = I1MACH(4) + DO 10 I=1,NUNIT + IF (IU(I) .EQ. 0) IU(I) = N + 10 CONTINUE +C +C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE +C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING +C THE REST OF THIS ROUTINE. +C + IF ( NPREF .LT. 0 ) THEN + LPREF = LEN(PREFIX) + ELSE + LPREF = NPREF + ENDIF + LPREF = MIN(16, LPREF) + IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX +C +C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE +C TIME FROM MESSG TO PRINT ON ONE LINE. +C + LWRAP = MAX(16, MIN(132, NWRAP)) +C +C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. +C + LENMSG = LEN(MESSG) + N = LENMSG + DO 20 I=1,N + IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 + LENMSG = LENMSG - 1 + 20 CONTINUE + 30 CONTINUE +C +C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. +C + IF (LENMSG .EQ. 0) THEN + CBUFF(LPREF+1:LPREF+1) = ' ' + DO 40 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) + 40 CONTINUE + RETURN + ENDIF +C +C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING +C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. +C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. +C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. +C +C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE +C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE +C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH +C OF THE SECOND ARGUMENT. +C +C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE +C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER +C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT +C POSITION NEXTC. +C +C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE +C REMAINDER OF THE CHARACTER STRING. LPIECE +C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, +C WHICHEVER IS LESS. +C +C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: +C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE +C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY +C BLANK LINES. THIS TAKES CARE OF THE SITUATION +C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF +C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE +C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC +C SHOULD BE INCREMENTED BY 2. +C +C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. +C +C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 +C RESET LPIECE = LPIECE-1. NOTE THAT THIS +C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. +C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY +C AT THE END OF A LINE. +C + NEXTC = 1 + 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) + IF (LPIECE .EQ. 0) THEN +C +C THERE WAS NO NEW LINE SENTINEL FOUND. +C + IDELTA = 0 + LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) + IF (LPIECE .LT. LENMSG+1-NEXTC) THEN + DO 52 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 54 + ENDIF + 52 CONTINUE + ENDIF + 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSEIF (LPIECE .EQ. 1) THEN +C +C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). +C DON'T PRINT A BLANK LINE. +C + NEXTC = NEXTC + 2 + GO TO 50 + ELSEIF (LPIECE .GT. LWRAP+1) THEN +C +C LPIECE SHOULD BE SET DOWN TO LWRAP. +C + IDELTA = 0 + LPIECE = LWRAP + DO 56 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 58 + ENDIF + 56 CONTINUE + 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSE +C +C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. +C WE SHOULD DECREMENT LPIECE BY ONE. +C + LPIECE = LPIECE - 1 + CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + 2 + ENDIF +C +C PRINT +C + DO 60 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) + 60 CONTINUE +C + IF (NEXTC .LE. LENMSG) GO TO 50 + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/xersve.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/xersve.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/xersve.F (revision 1634) @@ -0,0 +1,155 @@ +*DECK XERSVE + SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + + ICOUNT) +C***BEGIN PROLOGUE XERSVE +C***SUBSIDIARY +C***PURPOSE Record that an error has occurred. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (XERSVE-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C *Usage: +C +C INTEGER KFLAG, NERR, LEVEL, ICOUNT +C CHARACTER * (len) LIBRAR, SUBROU, MESSG +C +C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) +C +C *Arguments: +C +C LIBRAR :IN is the library that the message is from. +C SUBROU :IN is the subroutine that the message is from. +C MESSG :IN is the message to be saved. +C KFLAG :IN indicates the action to be performed. +C when KFLAG > 0, the message in MESSG is saved. +C when KFLAG=0 the tables will be dumped and +C cleared. +C when KFLAG < 0, the tables will be dumped and +C not cleared. +C NERR :IN is the error number. +C LEVEL :IN is the error severity. +C ICOUNT :OUT the number of times this message has been seen, +C or zero if the table has overflowed and does not +C contain this message specifically. When KFLAG=0, +C ICOUNT will not be altered. +C +C *Description: +C +C Record that this error occurred and possibly dump and clear the +C tables. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 800319 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900413 Routine modified to remove reference to KFLAG. (WRB) +C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling +C sequence, use IF-THEN-ELSE, make number of saved entries +C easily changeable, changed routine name from XERSAV to +C XERSVE. (RWC) +C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERSVE + PARAMETER (LENTAB=10) + INTEGER LUN(5) + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB + CHARACTER*20 MESTAB(LENTAB), MES + DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) + SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG + DATA KOUNTX/0/, NMSG/0/ +C***FIRST EXECUTABLE STATEMENT XERSVE +C + IF (KFLAG.LE.0) THEN +C +C Dump the table. +C + IF (NMSG.EQ.0) RETURN +C +C Print to each unit. +C + CALL XGETUA (LUN, NUNIT) + DO 20 KUNIT = 1,NUNIT + IUNIT = LUN(KUNIT) + IF (IUNIT.EQ.0) IUNIT = I1MACH(4) +C +C Print the table header. +C + WRITE (IUNIT,9000) +C +C Print body of table. +C + DO 10 I = 1,NMSG + WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), + * NERTAB(I),LEVTAB(I),KOUNT(I) + 10 CONTINUE +C +C Print number of other errors. +C + IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX + WRITE (IUNIT,9030) + 20 CONTINUE +C +C Clear the error tables. +C + IF (KFLAG.EQ.0) THEN + NMSG = 0 + KOUNTX = 0 + ENDIF + ELSE +C +C PROCESS A MESSAGE... +C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, +C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. +C + LIB = LIBRAR + SUB = SUBROU + MES = MESSG + DO 30 I = 1,NMSG + IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. + * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. + * LEVEL.EQ.LEVTAB(I)) THEN + KOUNT(I) = KOUNT(I) + 1 + ICOUNT = KOUNT(I) + RETURN + ENDIF + 30 CONTINUE +C + IF (NMSG.LT.LENTAB) THEN +C +C Empty slot found for new message. +C + NMSG = NMSG + 1 + LIBTAB(I) = LIB + SUBTAB(I) = SUB + MESTAB(I) = MES + NERTAB(I) = NERR + LEVTAB(I) = LEVEL + KOUNT (I) = 1 + ICOUNT = 1 + ELSE +C +C Table is full. +C + KOUNTX = KOUNTX+1 + ICOUNT = 0 + ENDIF + ENDIF + RETURN +C +C Formats. +C + 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + + ' LIBRARY SUBROUTINE MESSAGE START NERR', + + ' LEVEL COUNT') + 9010 FORMAT (1X,A,3X,A,3X,A,3I10) + 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) + 9030 FORMAT (1X) + END Index: LMDZ5/branches/LMDZ5_AR5/libf/bibio/xgetua.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/bibio/xgetua.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/bibio/xgetua.F (revision 1634) @@ -0,0 +1,51 @@ +*DECK XGETUA + SUBROUTINE XGETUA (IUNITA, N) +C***BEGIN PROLOGUE XGETUA +C***PURPOSE Return unit number(s) to which error messages are being +C sent. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XGETUA-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XGETUA may be called to determine the unit number or numbers +C to which error messages are being sent. +C These unit numbers may have been set by a call to XSETUN, +C or a call to XSETUA, or may be a default value. +C +C Description of Parameters +C --Output-- +C IUNIT - an array of one to five unit numbers, depending +C on the value of N. A value of zero refers to the +C default unit, as defined by the I1MACH machine +C constant routine. Only IUNIT(1),...,IUNIT(N) are +C defined by XGETUA. The values of IUNIT(N+1),..., +C IUNIT(5) are not defined (for N .LT. 5) or altered +C in any way by XGETUA. +C N - the number of units to which copies of the +C error messages are being sent. N will be in the +C range from 1 to 5. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XGETUA + DIMENSION IUNITA(5) +C***FIRST EXECUTABLE STATEMENT XGETUA + N = J4SAVE(5,0,.FALSE.) + DO 30 I=1,N + INDEX = I+4 + IF (I.EQ.1) INDEX = 3 + IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) + 30 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/MISR_simulator.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/MISR_simulator.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/MISR_simulator.F (revision 1634) @@ -0,0 +1,460 @@ +! +! Copyright (c) 2009, Roger Marchand, version 1.2 +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the University of Washington nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, +! BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT +! SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! + + SUBROUTINE MISR_simulator( + & npoints, + & nlev, + & ncol, + & sunlit, + & zfull, + & at, + & dtau_s, + & dtau_c, + & frac_out, + & fq_MISR_TAU_v_CTH, + & dist_model_layertops, + & MISR_mean_ztop, + & MISR_cldarea + & ) + + + implicit none + integer n_MISR_CTH + parameter(n_MISR_CTH=16) + +! ----- +! Input +! ----- + + INTEGER npoints ! if ncol ==1, the number of model points in the horizontal grid + ! else the number of GCM grid points + + INTEGER nlev ! number of model vertical levels + + INTEGER ncol ! number of model sub columns + ! (must already be generated in via scops and passed to this + ! routine via the variable frac_out ) + + INTEGER sunlit(npoints) ! 1 for day points, 0 for night time + + REAL zfull(npoints,nlev) ! height (in meters) of full model levels (i.e. midpoints) + ! zfull(npoints,1) is top level of model + ! zfull(npoints,nlev) is bottom level of model (closest point to surface) + + REAL at(npoints,nlev) ! temperature in each model level (K) + + REAL dtau_s(npoints,nlev) ! visible wavelength cloud optical depth ... for "stratiform" condensate + ! NOTE: this the cloud optical depth of only the + ! the model cell (i,j) + + REAL dtau_c(npoints,nlev) ! visible wavelength cloud optical depth ... for "convective" condensate + ! NOTE: this the cloud optical depth of only the + ! the model cell (i,j) + + REAL frac_out(npoints,ncol,nlev) ! NOTE: only need if columns>1 ... subgrid scheme in use. + +! ------ +! Outputs +! ------ + + REAL fq_MISR_TAU_v_CTH(npoints,7,n_MISR_CTH) + REAL dist_model_layertops(npoints,n_MISR_CTH) + REAL MISR_cldarea(npoints) ! fractional area coverged by clouds + REAL MISR_mean_ztop(npoints) ! mean cloud top hieght(m) MISR would observe + ! NOTE: == 0 if area ==0 + + +! ------ +! Working variables +! ------ + + REAL tau(npoints,ncol) ! total column optical depth ... + + INTEGER j,ilev,ilev2,ibox + INTEGER itau + + LOGICAL box_cloudy(npoints,ncol) + + real isccp_taumin + real boxarea + real tauchk + REAL box_MISR_ztop(npoints,ncol) ! cloud top hieght(m) MISR would observe + + integer thres_crossed_MISR + integer loop,iMISR_ztop + + real dtau, cloud_dtau, MISR_penetration_height,ztest + + real MISR_CTH_boundaries(n_MISR_CTH+1) + + DATA MISR_CTH_boundaries / -99, 0, 0.5, 1, 1.5, 2, 2.5, 3, + c 4, 5, 7, 9, 11, 13, 15, 17, 99 / + + DATA isccp_taumin / 0.3 / + + tauchk = -1.*log(0.9999999) + + ! + ! For each GCM cell or horizontal model grid point ... + ! + do j=1,npoints + + ! + ! estimate distribution of Model layer tops + ! + dist_model_layertops(j,:)=0 + + do ilev=1,nlev + + ! define location of "layer top" + if(ilev.eq.1 .or. ilev.eq.nlev) then + ztest=zfull(j,ilev) + else + ztest=0.5*(zfull(j,ilev)+zfull(j,ilev-1)) + endif + + ! find MISR layer that contains this level + ! note, the first MISR level is "no height" level + iMISR_ztop=2 + do loop=2,n_MISR_CTH + + if ( ztest .gt. + & 1000*MISR_CTH_boundaries(loop+1) ) then + + iMISR_ztop=loop+1 + endif + enddo + + dist_model_layertops(j,iMISR_ztop)= + & dist_model_layertops(j,iMISR_ztop)+1 + enddo + + + ! + ! compute total cloud optical depth for each column + ! + do ibox=1,ncol + + ! Initialize tau to zero in each subcolum + tau(j,ibox)=0. + box_cloudy(j,ibox)=.false. + box_MISR_ztop(j,ibox)=0 + + ! initialize threshold detection for each sub column + thres_crossed_MISR=0; + + do ilev=1,nlev + + dtau=0 + + if (frac_out(j,ibox,ilev).eq.1) then + dtau = dtau_s(j,ilev) + endif + + if (frac_out(j,ibox,ilev).eq.2) then + dtau = dtau_c(j,ilev) + end if + + tau(j,ibox)=tau(j,ibox)+ dtau + + + ! NOW for MISR .. + ! if there a cloud ... start the counter ... store this height + if(thres_crossed_MISR .eq. 0 .and. dtau .gt. 0.) then + + ! first encountered a "cloud" + thres_crossed_MISR=1 + cloud_dtau=0 + endif + + if( thres_crossed_MISR .lt. 99 .and. + & thres_crossed_MISR .gt. 0 ) then + + if( dtau .eq. 0.) then + + ! we have come to the end of the current cloud + ! layer without yet selecting a CTH boundary. + ! ... restart cloud tau counter + cloud_dtau=0 + else + ! add current optical depth to count for + ! the current cloud layer + cloud_dtau=cloud_dtau+dtau + endif + + ! if the cloud is continuous but optically thin (< 1) + ! from above the current layer cloud top to the current level + ! then MISR will like see a top below the top of the current + ! layer + if( dtau.gt.0 .and. (cloud_dtau-dtau) .lt. 1) then + + if(dtau .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then + + ! MISR will likely penetrate to some point + ! within this layer ... the middle + MISR_penetration_height=zfull(j,ilev) + + else + ! take the OD = 1.0 level into this layer + MISR_penetration_height= + & 0.5*(zfull(j,ilev)+zfull(j,ilev-1)) - + & 0.5*(zfull(j,ilev-1)-zfull(j,ilev+1)) + & /dtau + endif + + box_MISR_ztop(j,ibox)=MISR_penetration_height + + endif + + ! check for a distinctive water layer + if(dtau .gt. 1 .and. at(j,ilev).gt.273 ) then + + ! must be a water cloud ... + ! take this as CTH level + thres_crossed_MISR=99 + endif + + ! if the total column optical depth is "large" than + ! MISR can't seen anything else ... set current point as CTH level + if(tau(j,ibox) .gt. 5) then + + thres_crossed_MISR=99 + endif + + endif ! MISR CTH booundary not set + + enddo !ilev - loop over vertical levesl + + ! written by roj 5/2006 + ! check to see if there was a cloud for which we didn't + ! set a MISR cloud top boundary + if( thres_crossed_MISR .eq. 1) then + + ! if the cloud has a total optical depth of greater + ! than ~ 0.5 MISR will still likely pick up this cloud + ! with a height near the true cloud top + ! otherwise there should be no CTH + if( tau(j,ibox) .gt. 0.5) then + + ! keep MISR detected CTH + + elseif(tau(j,ibox) .gt. 0.2) then + + ! MISR may detect but wont likley have a good height + box_MISR_ztop(j,ibox)=-1 + + else + ! MISR not likely to even detect. + ! so set as not cloudy + box_MISR_ztop(j,ibox)=0 + + endif + + endif + + enddo ! loop of subcolumns + enddo ! loop of gridpoints + + + ! + ! Modify MISR CTH for satellite spatial / pattern matcher effects + ! + ! Code in this region added by roj 5/2006 to account + ! for spatial effect of the MISR pattern matcher. + ! Basically, if a column is found between two neighbors + ! at the same CTH, and that column has no hieght or + ! a lower CTH, THEN misr will tend to but place the + ! odd column at the same height as it neighbors. + ! + ! This setup assumes the columns represent a about a 1 to 4 km scale + ! it will need to be modified significantly, otherwise + if(ncol.eq.1) then + + ! adjust based on neightboring points ... i.e. only 2D grid was input + do j=2,npoints-1 + + if(box_MISR_ztop(j-1,1).gt.0 .and. + & box_MISR_ztop(j+1,1).gt.0 ) then + + if( abs( box_MISR_ztop(j-1,1) - + & box_MISR_ztop(j+1,1) ) .lt. 500 + & .and. + & box_MISR_ztop(j,1) .lt. + & box_MISR_ztop(j+1,1) ) then + + box_MISR_ztop(j,1) = + & box_MISR_ztop(j+1,1) + endif + + endif + enddo + else + + ! adjust based on neighboring subcolumns .... + do ibox=2,ncol-1 + + if(box_MISR_ztop(1,ibox-1).gt.0 .and. + & box_MISR_ztop(1,ibox+1).gt.0 ) then + + if( abs( box_MISR_ztop(1,ibox-1) - + & box_MISR_ztop(1,ibox+1) ) .lt. 500 + & .and. + & box_MISR_ztop(1,ibox) .lt. + & box_MISR_ztop(1,ibox+1) ) then + + box_MISR_ztop(1,ibox) = + & box_MISR_ztop(1,ibox+1) + endif + + endif + enddo + + endif + + ! + ! DETERMINE CLOUD TYPE FREQUENCIES + ! + ! Now that ztop and tau have been determined, + ! determine amount of each cloud type + boxarea=1./real(ncol) + do j=1,npoints + + ! reset frequencies -- modified loop structure, roj 5/2006 + do ilev=1,7 ! "tau loop" + do ilev2=1,n_MISR_CTH + fq_MISR_TAU_v_CTH(j,ilev,ilev2)=0. + enddo + enddo + + MISR_cldarea(j)=0. + MISR_mean_ztop(j)=0. + + do ibox=1,ncol + + if (tau(j,ibox) .gt. (tauchk)) then + box_cloudy(j,ibox)=.true. + endif + + itau = 0 + + if (box_cloudy(j,ibox)) then + + !determine optical depth category + if (tau(j,ibox) .lt. isccp_taumin) then + itau=1 + else if (tau(j,ibox) .ge. isccp_taumin + & .and. tau(j,ibox) .lt. 1.3) then + itau=2 + else if (tau(j,ibox) .ge. 1.3 + & .and. tau(j,ibox) .lt. 3.6) then + itau=3 + else if (tau(j,ibox) .ge. 3.6 + & .and. tau(j,ibox) .lt. 9.4) then + itau=4 + else if (tau(j,ibox) .ge. 9.4 + & .and. tau(j,ibox) .lt. 23.) then + itau=5 + else if (tau(j,ibox) .ge. 23. + & .and. tau(j,ibox) .lt. 60.) then + itau=6 + else if (tau(j,ibox) .ge. 60.) then + itau=7 + endif + + endif + + ! update MISR histograms and summary metrics - roj 5/2005 + if (sunlit(j).eq.1) then + + !if cloudy added by roj 5/2005 + if( box_MISR_ztop(j,ibox).eq.0) then + + ! no cloud detected + iMISR_ztop=0 + + elseif( box_MISR_ztop(j,ibox).eq.-1) then + + ! cloud can be detected but too thin to get CTH + iMISR_ztop=1 + + fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= + & fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea + + else + + ! + ! determine index for MISR bin set + ! + + iMISR_ztop=2 + + do loop=2,n_MISR_CTH + + if ( box_MISR_ztop(j,ibox) .gt. + & 1000*MISR_CTH_boundaries(loop+1) ) then + + iMISR_ztop=loop+1 + + endif + enddo + + if(box_cloudy(j,ibox)) then + + ! there is an isccp clouds so itau(j) is defined + fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop)= + & fq_MISR_TAU_v_CTH(j,itau,iMISR_ztop) + boxarea + + else + ! MISR CTH resolution is trying to fill in a + ! broken cloud scene where there is no condensate. + ! The MISR CTH-1D-OD product will only put in a cloud + ! if the MISR cloud mask indicates cloud. + ! therefore we will not include this column in the histogram + ! in reality aerosoal and 3D effects or bright surfaces + ! could fool the MISR cloud mask + + ! the alternative is to count as very thin cloud ?? +! fq_MISR_TAU_v_CTH(1,iMISR_ztop)= +! & fq_MISR_TAU_v_CTH(1,iMISR_ztop) + boxarea + endif + + + MISR_mean_ztop(j)=MISR_mean_ztop(j)+ + & box_MISR_ztop(j,ibox)*boxarea + + MISR_cldarea(j)=MISR_cldarea(j) + boxarea + + endif + + endif ! is sunlight ? + + enddo ! ibox - loop over subcolumns + + if( MISR_cldarea(j) .gt. 0.) then + MISR_mean_ztop(j)= MISR_mean_ztop(j) / MISR_cldarea(j) ! roj 5/2006 + endif + + enddo ! loop over grid points + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/array_lib.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/array_lib.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/array_lib.F90 (revision 1634) @@ -0,0 +1,165 @@ +! ARRAY_LIB: Array procedures for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! infind (function) +! lin_interpolate (function) + + module array_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! function INFIND +! ---------------------------------------------------------------------------- + function infind(list,val,sort,dist) + use m_mrgrnk + implicit none +! +! Purpose: +! Finds the index of an array that is closest to a value, plus the +! difference between the value found and the value specified +! +! Inputs: +! [list] an array of sequential values +! [val] a value to locate +! Optional input: +! [sort] set to 1 if [list] is in unknown/non-sequential order +! +! Returns: +! index of [list] that is closest to [val] +! +! Optional output: +! [dist] set to variable containing [list([result])] - [val] +! +! Requires: +! mrgrnk library +! +! Created: +! 10/16/03 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 01/31/06 IDL to Fortran 90 + +! ----- INPUTS ----- + real*8, dimension(:), intent(in) :: list + real*8, intent(in) :: val + integer, intent(in), optional :: sort + +! ----- OUTPUTS ----- + integer*4 :: infind + real*8, intent(out), optional :: dist + +! ----- INTERNAL ----- + real*8, dimension(size(list)) :: lists + integer*4 :: nlist, result, tmp(1), sort_list + integer*4, dimension(size(list)) :: mask, idx + + if (present(sort)) then + sort_list = sort + else + sort_list = 0 + endif + + nlist = size(list) + if (sort_list == 1) then + call mrgrnk(list,idx) + lists = list(idx) + else + lists = list + endif + + if (val >= lists(nlist)) then + result = nlist + else if (val <= lists(1)) then + result = 1 + else + mask(:) = 0 + where (lists < val) mask = 1 + tmp = minloc(mask,1) + if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then + result = tmp(1) - 1 + else + result = tmp(1) + endif + endif + if (present(dist)) dist = lists(result)-val + if (sort_list == 1) then + infind = idx(result) + else + infind = result + endif + + end function infind + +! ---------------------------------------------------------------------------- +! function LIN_INTERPOLATE +! ---------------------------------------------------------------------------- + subroutine lin_interpolate(yarr,xarr,yyarr,xxarr,tol) + use m_mrgrnk + implicit none +! +! Purpose: +! linearly interpolate a set of y2 values given a set of y1,x1,x2 +! +! Inputs: +! [yarr] an array of y1 values +! [xarr] an array of x1 values +! [xxarr] an array of x2 values +! [tol] maximum distance for a match +! +! Output: +! [yyarr] interpolated array of y2 values +! +! Requires: +! mrgrnk library +! +! Created: +! 06/07/06 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, dimension(:), intent(in) :: yarr, xarr, xxarr + real*8, intent(in) :: tol + +! ----- OUTPUTS ----- + real*8, dimension(size(xxarr)), intent(out) :: yyarr + +! ----- INTERNAL ----- + real*8, dimension(size(xarr)) :: ysort, xsort + integer*4, dimension(size(xarr)) :: ist + integer*4 :: nx, nxx, i, iloc + real*8 :: d, m + + nx = size(xarr) + nxx = size(xxarr) + +! // xsort, ysort are sorted versions of xarr, yarr + call mrgrnk(xarr,ist) + ysort = yarr(ist) + xsort = xarr(ist) + + do i=1,nxx + iloc = infind(xsort,xxarr(i),dist=d) + if (d > tol) then + print *, 'interpolation error' + stop + endif + if (iloc == nx) then +! :: set to the last value + yyarr(i) = ysort(nx) + else +! :: is there another closeby value? + if (abs(xxarr(i)-xsort(iloc+1)) < 2*tol) then +! :: yes, do a linear interpolation + m = (ysort(iloc+1)-ysort(iloc))/(xsort(iloc+1)-xsort(iloc)) + yyarr(i) = ysort(iloc) + m*(xxarr(i)-xsort(iloc)) + else +! :: no, set to the only nearby value + yyarr(i) = ysort(iloc) + endif + endif + enddo + + end subroutine lin_interpolate + + end module array_lib Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/atmos_lib.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/atmos_lib.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/atmos_lib.F90 (revision 1634) @@ -0,0 +1,135 @@ +! ATMOS_LIB: Atmospheric science procedures for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! mcclatchey (subroutine) + + module atmos_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! subroutine MCCLATCHEY +! ---------------------------------------------------------------------------- + subroutine mcclatchey(stype,hgt,prs,tk,rh) + implicit none +! +! Purpose: +! returns a standard atmospheric profile +! +! Input: +! [stype] type of profile to return +! 1 = mid-latitude summer +! 2 = mid-latitude winter +! 3 = tropical +! +! Outputs: +! [hgt] height (m) +! [prs] pressure (hPa) +! [tk] temperature (K) +! [rh] relative humidity (%) +! +! Created: +! 06/01/2006 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + integer, intent(in) :: & + stype + + integer, parameter :: ndat = 33 + +! ----- OUTPUTS ----- + real*8, intent(out), dimension(ndat) :: & + hgt, & ! height (m) + prs, & ! pressure (hPa) + tk, & ! temperature (K) + rh ! relative humidity (%) + + hgt = (/0.00000,1000.00,2000.00,3000.00,4000.00,5000.00, & + 6000.00,7000.00,8000.00,9000.00,10000.0,11000.0, & + 12000.0,13000.0,14000.0,15000.0,16000.0,17000.0, & + 18000.0,19000.0,20000.0,21000.0,22000.0,23000.0, & + 24000.0,25000.0,30000.0,35000.0,40000.0,45000.0, & + 50000.0,70000.0,100000./) + + select case(stype) + + case(1) +! // mid-latitide summer + prs = (/1013.00, 902.000, 802.000, 710.000, 628.000, 554.000, & + 487.000, 426.000, 372.000, 324.000, 281.000, 243.000, & + 209.000, 179.000, 153.000, 130.000, 111.000, 95.0000, & + 81.2000, 69.5000, 59.5000, 51.0000, 43.7000, 37.6000, & + 32.2000, 27.7000, 13.2000, 6.52000, 3.33000, 1.76000, & + 0.951000,0.0671000,0.000300000/) + + tk = (/294.000, 290.000, 285.000, 279.000, 273.000, 267.000, & + 261.000, 255.000, 248.000, 242.000, 235.000, 229.000, & + 222.000, 216.000, 216.000, 216.000, 216.000, 216.000, & + 216.000, 217.000, 218.000, 219.000, 220.000, 222.000, & + 223.000, 224.000, 234.000, 245.000, 258.000, 270.000, & + 276.000, 218.000, 210.000/) + + rh = (/74.8384, 63.4602, 55.0485, 45.4953, 39.3805, 31.7965, & + 30.3958, 29.5966, 30.1626, 29.3624, 30.3334, 19.0768, & + 11.0450, 6.61278, 3.67379, 2.79209, 2.35123, 2.05732, & + 1.83690, 1.59930, 1.30655, 1.31890, 1.17620,0.994076, & + 0.988566,0.989143,0.188288,0.0205613,0.00271164,0.000488798, & + 0.000107066,0.000406489,7.68645e-06/) + + case(2) +! // mid-latitude winter + prs = (/1018.00, 897.300, 789.700, 693.800, 608.100, 531.300, & + 462.700, 401.600, 347.300, 299.200, 256.800, 219.900, & + 188.200, 161.000, 137.800, 117.800, 100.700, 86.1000, & + 73.5000, 62.8000, 53.7000, 45.8000, 39.1000, 33.4000, & + 28.6000, 24.3000, 11.1000, 5.18000, 2.53000, 1.29000, & + 0.682000,0.0467000,0.000300000/) + + tk = (/272.200, 268.700, 265.200, 261.700, 255.700, 249.700, & + 243.700, 237.700, 231.700, 225.700, 219.700, 219.200, & + 218.700, 218.200, 217.700, 217.200, 216.700, 216.200, & + 215.700, 215.200, 215.200, 215.200, 215.200, 215.200, & + 215.200, 215.200, 217.400, 227.800, 243.200, 258.500, & + 265.700, 230.700, 210.200/) + + rh = (/76.6175, 70.1686, 65.2478, 56.6267, 49.8755, 47.1765, & + 44.0477, 31.0565, 23.0244, 19.6510, 17.8987, 17.4376, & + 16.0621, 5.10608, 3.00679, 2.42293, 2.16406, 2.00901, & + 1.90374, 1.98072, 1.81902, 2.06155, 2.06154, 2.18280, & + 2.42531,2.70824,1.12105,0.108119,0.00944200,0.00115201, & + 0.000221094,0.000101946,7.49350e-06/) + + case(3) +! // tropical + prs = (/1013.00, 904.000, 805.000, 715.000, 633.000, 559.000, & + 492.000, 432.000, 378.000, 329.000, 286.000, 247.000, & + 213.000, 182.000, 156.000, 132.000, 111.000, 93.7000, & + 78.9000, 66.6000, 56.5000, 48.0000, 40.9000, 35.0000, & + 30.0000, 25.7000, 12.2000, 6.00000, 3.05000, 1.59000, & + 0.854000,0.0579000,0.000300000/) + + tk = (/300.000, 294.000, 288.000, 284.000, 277.000, 270.000, & + 264.000, 257.000, 250.000, 244.000, 237.000, 230.000, & + 224.000, 217.000, 210.000, 204.000, 197.000, 195.000, & + 199.000, 203.000, 207.000, 211.000, 215.000, 217.000, & + 219.000, 221.000, 232.000, 243.000, 254.000, 265.000, & + 270.000, 219.000, 210.000/) + + rh = (/71.4334, 69.4097, 71.4488, 46.7724, 34.7129, 38.3820, & + 33.7214, 32.0122, 30.2607, 24.5059, 19.5321, 13.2966, & + 8.85795, 5.87496, 7.68644, 12.8879, 29.4976, 34.9351, & + 17.1606, 9.53422, 5.10154, 3.45407, 2.11168, 1.76247, & + 1.55162,1.37966,0.229799,0.0245943,0.00373686,0.000702138, & + 0.000162076,0.000362055,7.68645e-06/) + + case default + print *, 'Must enter a profile type' + stop + + end select + + end subroutine mcclatchey + + end module atmos_lib Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/congvec.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/congvec.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/congvec.h (revision 1634) @@ -0,0 +1,54 @@ + +! *****************************COPYRIGHT**************************** +! (c) British Crown Copyright 2009, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the +! following conditions are met: +! +! * Redistributions of source code must retain the above +! copyright notice, this list of conditions and the following +! disclaimer. +! * Redistributions in binary form must reproduce the above +! copyright notice, this list of conditions and the following +! disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its +! contributors may be used to endorse or promote products +! derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* + + do irand = 1, npoints + ! Marsaglia CONG algorithm + seed(irand)=69069*seed(irand)+1234567 + ! mod 32 bit overflow + seed(irand)=mod(seed(irand),2**30) + ran(irand)=seed(irand)*0.931322574615479E-09 + enddo + + ! convert to range 0-1 (32 bit only) + overflow_32=i2_16*i2_16 + if ( overflow_32 .le. huge32 ) then + do irand = 1, npoints + ran(irand)=ran(irand)+1 + ran(irand)=(ran(irand))-int(ran(irand)) + enddo + endif + + Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp.F90 (revision 1634) @@ -0,0 +1,512 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +!!#include "cosp_defs.h" +MODULE MOD_COSP + USE MOD_COSP_TYPES + USE MOD_COSP_SIMULATOR + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP --------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Arguments + integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand + integer,intent(in) :: Ncolumns + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_gridbox),intent(inout) :: gbx + type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + + ! Local variables + integer :: Npoints ! Number of gridpoints + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Niter ! Number of calls to cosp_simulator + integer :: i_first,i_last ! First and last gridbox to be processed in each iteration + integer :: i,j,k,Ni + integer,dimension(2) :: ix,iy + logical :: reff_zero + real :: minv,maxv + real :: maxp,minp + integer,dimension(:),save, allocatable :: & ! Dimensions nPoints + seed ! It is recommended that the seed is set to a different value for each model + ! gridbox it is called on, as it is possible that the choice of the same + ! seed value every time may introduce some statistical bias in the results, + ! particularly for low values of NCOL. +!$OMP THREADPRIVATE(seed) + real,dimension(:),allocatable :: rseed ! It is recommended that the seed is set to a different value for each model + ! Types used in one iteration + type(cosp_gridbox) :: gbx_it + type(cosp_subgrid) :: sgx_it + type(cosp_vgrid) :: vgrid_it + type(cosp_sgradar) :: sgradar_it + type(cosp_sglidar) :: sglidar_it + type(cosp_isccp) :: isccp_it + type(cosp_misr) :: misr_it + type(cosp_radarstats) :: stradar_it + type(cosp_lidarstats) :: stlidar_it + + logical,save :: first_cosp=.TRUE. +!$OMP THREADPRIVATE(first_cosp) + + !++++++++++ Dimensions ++++++++++++ + Npoints = gbx%Npoints + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + +!++++++++++ Apply sanity checks to inputs ++++++++++ +! call cosp_check_input('longitude',gbx%longitude,min_val=0.0,max_val=360.0) + call cosp_check_input('longitude',gbx%longitude,min_val=-180.0,max_val=180.0) + call cosp_check_input('latitude',gbx%latitude,min_val=-90.0,max_val=90.0) + call cosp_check_input('dlev',gbx%dlev,min_val=0.0) + call cosp_check_input('p',gbx%p,min_val=0.0) + call cosp_check_input('ph',gbx%ph,min_val=0.0) + call cosp_check_input('T',gbx%T,min_val=0.0) + call cosp_check_input('q',gbx%q,min_val=0.0) + call cosp_check_input('sh',gbx%sh,min_val=0.0) + call cosp_check_input('dtau_s',gbx%dtau_s,min_val=0.0) + call cosp_check_input('dtau_c',gbx%dtau_c,min_val=0.0) + call cosp_check_input('dem_s',gbx%dem_s,min_val=0.0,max_val=1.0) + call cosp_check_input('dem_c',gbx%dem_c,min_val=0.0,max_val=1.0) + ! Point information (Npoints) + call cosp_check_input('land',gbx%land,min_val=0.0,max_val=1.0) + call cosp_check_input('psfc',gbx%psfc,min_val=0.0) + call cosp_check_input('sunlit',gbx%sunlit,min_val=0.0,max_val=1.0) + call cosp_check_input('skt',gbx%skt,min_val=0.0) + ! TOTAL and CONV cloud fraction for SCOPS + call cosp_check_input('tca',gbx%tca,min_val=0.0,max_val=1.0) + call cosp_check_input('cca',gbx%cca,min_val=0.0,max_val=1.0) + ! Precipitation fluxes on model levels + call cosp_check_input('rain_ls',gbx%rain_ls,min_val=0.0) + call cosp_check_input('rain_cv',gbx%rain_cv,min_val=0.0) + call cosp_check_input('snow_ls',gbx%snow_ls,min_val=0.0) + call cosp_check_input('snow_cv',gbx%snow_cv,min_val=0.0) + call cosp_check_input('grpl_ls',gbx%grpl_ls,min_val=0.0) + ! Hydrometeors concentration and distribution parameters + call cosp_check_input('mr_hydro',gbx%mr_hydro,min_val=0.0) + ! Effective radius [m]. (Npoints,Nlevels,Nhydro) + call cosp_check_input('Reff',gbx%Reff,min_val=0.0) + reff_zero=.true. + if (any(gbx%Reff > 1.e-8)) then + reff_zero=.false. + ! reff_zero == .false. + ! and gbx%use_reff == .true. Reff use in radar and lidar + ! and reff_zero == .false. Reff use in lidar and set to 0 for radar + endif +! if ((gbx%use_reff) .and. (reff_zero)) then ! Inconsistent choice. Want to use Reff but not inputs passed +! print *, '---------- COSP ERROR ------------' +! print *, '' +! print *, 'use_reff==.true. but Reff is always zero' +! print *, '' +! print *, '----------------------------------' +! stop +! endif + if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar + gbx%Reff = DEFAULT_LIDAR_REFF + print *, '---------- COSP WARNING ------------' + print *, '' + print *, 'Using default Reff in lidar simulations' + print *, '' + print *, '----------------------------------' + endif + + ! Aerosols concentration and distribution parameters + call cosp_check_input('conc_aero',gbx%conc_aero,min_val=0.0) + ! Checks for CRM mode + if (Ncolumns == 1) then + if (gbx%use_precipitation_fluxes) then + print *, '---------- COSP ERROR ------------' + print *, '' + print *, 'Use of precipitation fluxes not supported in CRM mode (Ncolumns=1)' + print *, '' + print *, '----------------------------------' + stop + endif + if ((maxval(gbx%dtau_c) > 0.0).or.(maxval(gbx%dem_c) > 0.0)) then + print *, '---------- COSP ERROR ------------' + print *, '' + print *, ' dtau_c > 0.0 or dem_c > 0.0. In CRM mode (Ncolumns=1), ' + print *, ' the optical depth (emmisivity) of all clouds must be ' + print *, ' passed through dtau_s (dem_s)' + print *, '' + print *, '----------------------------------' + stop + endif + endif + + if (first_cosp) then + ! We base the seed in the decimal part of the surface pressure. + allocate(seed(Npoints)) + + allocate(rseed(klon_glo)) + CALL gather(gbx%psfc,rseed) + call bcast(rseed) +! seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1 + ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to + ! randomize for each call to COSP even when Npoints ==1 + minp = minval(rseed) + maxp = maxval(rseed) + + if (Npoints .gt. 1) THEN + seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1 + else + seed=int(gbx%psfc-minp) + endif + + deallocate(rseed) + first_cosp=.false. + endif + + if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints + call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + else ! Several iterations to save memory + Niter = gbx%Npoints/gbx%Npoints_it ! Integer division + if (Niter*gbx%Npoints_it < gbx%Npoints) Niter = Niter + 1 + do i=1,Niter + i_first = (i-1)*gbx%Npoints_it + 1 + i_last = i_first + gbx%Npoints_it - 1 + i_last = min(i_last,gbx%Npoints) + Ni = i_last - i_first + 1 + if (i == 1) then + ! Allocate types for all but last iteration + call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, & + gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & + gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & + gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & + gbx%use_precipitation_fluxes,gbx%use_reff, & + gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & + gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & + gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & + gbx_it) + call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) + call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) + call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) + call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) + call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) + call construct_cosp_misr(cfg,Ni,misr_it) + call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) + call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) + elseif (i == Niter) then ! last iteration + call free_cosp_gridbox(gbx_it,.true.) + call free_cosp_subgrid(sgx_it) + call free_cosp_vgrid(vgrid_it) + call free_cosp_sgradar(sgradar_it) + call free_cosp_sglidar(sglidar_it) + call free_cosp_isccp(isccp_it) + call free_cosp_misr(misr_it) + call free_cosp_radarstats(stradar_it) + call free_cosp_lidarstats(stlidar_it) + ! Allocate types for iterations + call construct_cosp_gridbox(gbx%time,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables,gbx%use_gas_abs, & + gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels,Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & + gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & + gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & + gbx%use_precipitation_fluxes,gbx%use_reff, & + gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & + gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & + gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & + gbx_it) + ! --- Copy arrays without Npoints as dimension --- + gbx_it%dist_prmts_hydro = gbx%dist_prmts_hydro + gbx_it%dist_type_aero = gbx_it%dist_type_aero + call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) + call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) + call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) + call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) + call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) + call construct_cosp_misr(cfg,Ni,misr_it) + call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) + call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) + endif + ! --- Copy sections of arrays with Npoints as dimension --- + ix=(/i_first,i_last/) + iy=(/1,Ni/) + call cosp_gridbox_cpsection(ix,iy,gbx,gbx_it) + ! These serve as initialisation of *_it types + call cosp_subgrid_cpsection(ix,iy,sgx,sgx_it) + if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar,sgradar_it) + if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it) + if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it) + if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr,misr_it) + if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it) + if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it) + print *,'---------ix: ',ix + call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, & + sglidar_it,isccp_it,misr_it,stradar_it,stlidar_it) + + ! --- Copy results to output structures --- +! call cosp_gridbox_cphp(gbx_it,gbx) + ix=(/1,Ni/) + iy=(/i_first,i_last/) + call cosp_subgrid_cpsection(ix,iy,sgx_it,sgx) + if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar_it,sgradar) + if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar) + if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp) + if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr_it,misr) + if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar) + if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar) + enddo + ! Deallocate types + call free_cosp_gridbox(gbx_it,.true.) + call free_cosp_subgrid(sgx_it) + call free_cosp_vgrid(vgrid_it) + call free_cosp_sgradar(sgradar_it) + call free_cosp_sglidar(sglidar_it) + call free_cosp_isccp(isccp_it) + call free_cosp_misr(misr_it) + call free_cosp_radarstats(stradar_it) + call free_cosp_lidarstats(stlidar_it) + endif + + +END SUBROUTINE COSP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP_ITER ---------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Arguments + integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand + integer,dimension(:),intent(in) :: seed + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_gridbox),intent(inout) :: gbx + type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + + ! Local variables + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of subcolumns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Niter ! Number of calls to cosp_simulator + integer :: i,j,k + integer :: I_HYDRO + real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out + integer,parameter :: scops_debug=0 ! set to non-zero value to print out inputs for debugging in SCOPS + + real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, & + tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud. + ! Levels are from TOA to SURFACE. (nPoints, nLev) + real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level + ! Levels are from SURFACE to TOA + real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric dens + type(cosp_sghydro) :: sghydro ! Subgrid info for hydrometeors en each iteration + + + !++++++++++ Dimensions ++++++++++++ + Npoints = gbx%Npoints + Ncolumns = gbx%Ncolumns + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + + + !++++++++++ Climate/NWP mode ++++++++++ + if (Ncolumns > 1) then + !++++++++++ Subgrid sampling ++++++++++ + ! Allocate arrays before calling SCOPS + allocate(frac_ls(Npoints,Nlevels),frac_cv(Npoints,Nlevels),prec_ls(Npoints,Nlevels),prec_cv(Npoints,Nlevels)) + allocate(tca_scops(Npoints,Nlevels),cca_scops(Npoints,Nlevels), & + ls_p_rate(Npoints,Nlevels),cv_p_rate(Npoints,Nlevels)) + ! Initialize to zero + frac_ls=0.0 + prec_ls=0.0 + frac_cv=0.0 + prec_cv=0.0 + ! Cloud fractions for SCOPS from TOA to SFC + tca_scops = gbx%tca(:,Nlevels:1:-1) + cca_scops = gbx%cca(:,Nlevels:1:-1) + + ! Call to SCOPS + ! strat and conv arrays are passed with levels from TOA to SURFACE. + call scops(Npoints,Nlevels,Ncolumns,seed,tca_scops,cca_scops,overlap,sgx%frac_out,scops_debug) + + ! temporarily use prec_ls/cv to transfer information about precipitation flux into prec_scops + if(gbx%use_precipitation_fluxes) then + ls_p_rate(:,Nlevels:1:-1)=gbx%rain_ls(:,1:Nlevels)+gbx%snow_ls(:,1:Nlevels)+gbx%grpl_ls(:,1:Nlevels) + cv_p_rate(:,Nlevels:1:-1)=gbx%rain_cv(:,1:Nlevels)+gbx%snow_cv(:,1:Nlevels) + else + ls_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_LSRAIN)+ & + gbx%mr_hydro(:,1:Nlevels,I_LSSNOW)+ & + gbx%mr_hydro(:,1:Nlevels,I_LSGRPL) + cv_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_CVRAIN)+ & + gbx%mr_hydro(:,1:Nlevels,I_CVSNOW) + endif + + call prec_scops(Npoints,Nlevels,Ncolumns,ls_p_rate,cv_p_rate,sgx%frac_out,sgx%prec_frac) + + ! Precipitation fraction + do j=1,Npoints,1 + do k=1,Nlevels,1 + do i=1,Ncolumns,1 + if (sgx%frac_out (j,i,Nlevels+1-k) == I_LSC) frac_ls(j,k)=frac_ls(j,k)+1. + if (sgx%frac_out (j,i,Nlevels+1-k) == I_CVC) frac_cv(j,k)=frac_cv(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 1) prec_ls(j,k)=prec_ls(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 2) prec_cv(j,k)=prec_cv(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 3) then + prec_cv(j,k)=prec_cv(j,k)+1. + prec_ls(j,k)=prec_ls(j,k)+1. + endif + enddo !i + frac_ls(j,k)=frac_ls(j,k)/Ncolumns + frac_cv(j,k)=frac_cv(j,k)/Ncolumns + prec_ls(j,k)=prec_ls(j,k)/Ncolumns + prec_cv(j,k)=prec_cv(j,k)/Ncolumns + enddo !k + enddo !j + + ! Levels from SURFACE to TOA. + if (Npoints*Ncolumns*Nlevels < 10000) then + sgx%frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sgx%prec_frac(1:Npoints,:,1:Nlevels) = sgx%prec_frac(1:Npoints,:,Nlevels:1:-1) + else + ! This is done within a loop (unvectorized) over nPoints to save memory + do j=1,Npoints + sgx%frac_out(j,:,1:Nlevels) = sgx%frac_out(j,:,Nlevels:1:-1) + sgx%prec_frac(j,:,1:Nlevels) = sgx%prec_frac(j,:,Nlevels:1:-1) + enddo + endif + + ! Deallocate arrays that will no longer be used + deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate) + + ! Populate the subgrid arrays + call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro) + do k=1,Ncolumns + !--------- Mixing ratios for clouds and Reff for Clouds and precip ------- + column_frac_out => sgx%frac_out(:,k,:) + where (column_frac_out == I_LSC) !+++++++++++ LS clouds ++++++++ + sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ) + sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE) + + sghydro%Reff(:,k,:,I_LSCLIQ) = gbx%Reff(:,:,I_LSCLIQ) + sghydro%Reff(:,k,:,I_LSCICE) = gbx%Reff(:,:,I_LSCICE) + sghydro%Reff(:,k,:,I_LSRAIN) = gbx%Reff(:,:,I_LSRAIN) + sghydro%Reff(:,k,:,I_LSSNOW) = gbx%Reff(:,:,I_LSSNOW) + sghydro%Reff(:,k,:,I_LSGRPL) = gbx%Reff(:,:,I_LSGRPL) + elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV clouds ++++++++ + sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ) + sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE) + + sghydro%Reff(:,k,:,I_CVCLIQ) = gbx%Reff(:,:,I_CVCLIQ) + sghydro%Reff(:,k,:,I_CVCICE) = gbx%Reff(:,:,I_CVCICE) + sghydro%Reff(:,k,:,I_CVRAIN) = gbx%Reff(:,:,I_CVRAIN) + sghydro%Reff(:,k,:,I_CVSNOW) = gbx%Reff(:,:,I_CVSNOW) + end where + !--------- Precip ------- + if (.not. gbx%use_precipitation_fluxes) then + where (column_frac_out == I_LSC) !+++++++++++ LS Precipitation ++++++++ + sghydro%mr_hydro(:,k,:,I_LSRAIN) = gbx%mr_hydro(:,:,I_LSRAIN) + sghydro%mr_hydro(:,k,:,I_LSSNOW) = gbx%mr_hydro(:,:,I_LSSNOW) + sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL) + elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV Precipitation ++++++++ + sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN) + sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW) + end where + endif + enddo + ! convert the mixing ratio and precipitation flux from gridbox mean to the fraction-based values + do k=1,Nlevels + do j=1,Npoints + !--------- Clouds ------- + if (frac_ls(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_LSCLIQ) = sghydro%mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSCICE) = sghydro%mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k) + endif + if (frac_cv(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_CVCLIQ) = sghydro%mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k) + sghydro%mr_hydro(j,:,k,I_CVCICE) = sghydro%mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k) + endif + !--------- Precip ------- + if (gbx%use_precipitation_fluxes) then + if (prec_ls(j,k) .ne. 0.) then + gbx%rain_ls(j,k) = gbx%rain_ls(j,k)/prec_ls(j,k) + gbx%snow_ls(j,k) = gbx%snow_ls(j,k)/prec_ls(j,k) + gbx%grpl_ls(j,k) = gbx%grpl_ls(j,k)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + gbx%rain_cv(j,k) = gbx%rain_cv(j,k)/prec_cv(j,k) + gbx%snow_cv(j,k) = gbx%snow_cv(j,k)/prec_cv(j,k) + endif + else + if (prec_ls(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_LSRAIN) = sghydro%mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSSNOW) = sghydro%mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSGRPL) = sghydro%mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_CVRAIN) = sghydro%mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k) + sghydro%mr_hydro(j,:,k,I_CVSNOW) = sghydro%mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k) + endif + endif + enddo !k + enddo !j + deallocate(frac_ls,prec_ls,frac_cv,prec_cv) + + if (gbx%use_precipitation_fluxes) then + ! convert precipitation flux into mixing ratio + call pf_to_mr(Npoints,Nlevels,Ncolumns,gbx%rain_ls,gbx%snow_ls,gbx%grpl_ls, & + gbx%rain_cv,gbx%snow_cv,sgx%prec_frac,gbx%p,gbx%T, & + sghydro%mr_hydro(:,:,:,I_LSRAIN),sghydro%mr_hydro(:,:,:,I_LSSNOW),sghydro%mr_hydro(:,:,:,I_LSGRPL), & + sghydro%mr_hydro(:,:,:,I_CVRAIN),sghydro%mr_hydro(:,:,:,I_CVSNOW)) + endif + !++++++++++ CRM mode ++++++++++ + else + sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro + sghydro%Reff(:,1,:,:) = gbx%Reff + !--------- Clouds ------- + where ((gbx%dtau_s > 0.0)) + sgx%frac_out(:,1,:) = 1 ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) + endwhere + endif ! Ncolumns > 1 + + + !++++++++++ Simulator ++++++++++ + call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Deallocate subgrid arrays + call free_cosp_sghydro(sghydro) +END SUBROUTINE COSP_ITER + +END MODULE MOD_COSP Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_constants.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_constants.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_constants.F90 (revision 1634) @@ -0,0 +1,130 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes +! Oct 2008 - H. Chepfer - Added PARASOL_NREFL +! +! +MODULE MOD_COSP_CONSTANTS +! use netcdf, only: nf90_fill_rea + IMPLICIT NONE + + ! Indices to address arrays of LS and CONV hydrometeors + integer,parameter :: I_LSCLIQ = 1 + integer,parameter :: I_LSCICE = 2 + integer,parameter :: I_LSRAIN = 3 + integer,parameter :: I_LSSNOW = 4 + integer,parameter :: I_CVCLIQ = 5 + integer,parameter :: I_CVCICE = 6 + integer,parameter :: I_CVRAIN = 7 + integer,parameter :: I_CVSNOW = 8 + integer,parameter :: I_LSGRPL = 9 + + ! Missing value +!! real,parameter :: R_UNDEF = -1.0E30 + real,parameter :: R_UNDEF = 9.96921e+36 +! real,parameter :: R_UNDEF = nf90_fill_rea + ! Number of possible output variables + integer,parameter :: N_OUT_LIST = 27 + ! Value for forward model result from a level that is under the ground + real,parameter :: R_GROUND = -1.0E20 + + ! Stratiform and convective clouds in frac_out + integer, parameter :: I_LSC = 1, & ! Large-scale clouds + I_CVC = 2 ! Convective clouds + + !--- Radar constants + ! CFAD constants + integer,parameter :: DBZE_BINS = 15 ! Number of dBZe bins in histogram (cfad) + real,parameter :: DBZE_MIN = -100.0 ! Minimum value for radar reflectivity + real,parameter :: DBZE_MAX = 80.0 ! Maximum value for radar reflectivity + real,parameter :: CFAD_ZE_MIN = -50.0 ! Lower value of the first CFAD Ze bin + real,parameter :: CFAD_ZE_WIDTH = 5.0 ! Bin width (dBZe) + + + !--- Lidar constants + ! CFAD constants + integer,parameter :: SR_BINS = 15 + integer,parameter :: DPOL_BINS = 6 + real,parameter :: LIDAR_UNDEF = 999.999 + ! Other constants + integer,parameter :: LIDAR_NCAT = 4 + integer,parameter :: PARASOL_NREFL = 5 ! parasol + real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 6.0, 80.0/) +! real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/1.0, 2.0, 3.0, 4.0, 5.0/) + real,parameter :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius + + !--- MISR constants + integer,parameter :: MISR_N_CTH = 16 + + !--- RTTOV constants + integer,parameter :: RTTOV_MAX_CHANNELS = 20 + + ! ISCCP tau-Pc axes + real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 50000.0/) + real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, & + 9.4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/)) + +! real,parameter,dimension(7) :: ISCCP_PC = (/9000., 24500., 37500., 50000., 62000., 74000., 90000./) +! real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/0.0,18000.0,18000.0,31000.0,31000.0, & +! 44000.0,44000.0,56000.0,56000.0,68000.0,68000.0,80000.0,80000.0,100000.0/), shape=(/2,7/)) + + real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./) + real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = reshape(source=(/100000.0,80000.0,80000.0,68000.0,68000.0,56000.0 & + ,56000.0,44000.0,44000.0,31000.0,31000.0,18000.0,18000.0,0.0/), shape=(/2,7/)) + + real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = (/ 0., 0.25, 0.75, 1.25, 1.75, 2.25, 2.75, 3.5, & + 4.5, 6., 8., 10., 12., 14.5, 16., 18./) + real,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = reshape(source=(/ & + -99.0, 0.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.5, & + 1.5, 2.0, 2.0, 2.5, 2.5, 3.0, 3.0, 4.0, & + 4.0, 5.0, 5.0, 7.0, 7.0, 9.0, 9.0, 11.0, & + 11.0, 13.0, 13.0, 15.0, 15.0, 17.0, 17.0, 99.0/), & + shape=(/2,MISR_N_CTH/)) + + ! Table hclass for quickbeam + integer,parameter :: N_HYDRO = 9 + real :: HCLASS_TYPE(N_HYDRO),HCLASS_COL(N_HYDRO),HCLASS_PHASE(N_HYDRO), & + HCLASS_CP(N_HYDRO),HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO) + real :: HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), & + HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO) + data HCLASS_TYPE/5,1,2,2,5,1,2,2,2/ + data HCLASS_COL/1,2,3,4,5,6,7,8,9/ + data HCLASS_PHASE/0,1,0,1,0,1,0,1,1/ + data HCLASS_CP/0,0,1,1,0,0,1,1,1/ + data HCLASS_DMIN/-1,-1,-1,-1,-1,-1,-1,-1,-1/ + data HCLASS_DMAX/-1,-1,-1,-1,-1,-1,-1,-1,-1/ + data HCLASS_APM/524,110.8,524,-1,524,110.8,524,-1,-1/ + data HCLASS_BPM/3,2.91,3,-1,3,2.91,3,-1,-1/ + data HCLASS_RHO/-1,-1,-1,100,-1,-1,-1,100,400/ + data HCLASS_P1/-1,-1,8000000.,3000000.,-1,-1,8000000.,3000000.,4000000./ + data HCLASS_P2/6,40,-1,-1,6,40,-1,-1,-1/ + data HCLASS_P3/0.3,2,-1,-1,0.3,2,-1,-1,-1/ + + + +END MODULE MOD_COSP_CONSTANTS Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_isccp_simulator.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_isccp_simulator.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_isccp_simulator.F90 (revision 1634) @@ -0,0 +1,96 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP_ISCCP_SIMULATOR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ISCCP_SIMULATOR(gbx,sgx,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info + type(cosp_isccp),intent(inout) :: y ! ISCCP simulator output + + ! Local variables + integer :: i,Nlevels,Npoints + real :: pfull(gbx%Npoints, gbx%Nlevels) + real :: phalf(gbx%Npoints, gbx%Nlevels + 1) + real :: qv(gbx%Npoints, gbx%Nlevels) + real :: cc(gbx%Npoints, gbx%Nlevels) + real :: conv(gbx%Npoints, gbx%Nlevels) + real :: dtau_s(gbx%Npoints, gbx%Nlevels) + real :: dtau_c(gbx%Npoints, gbx%Nlevels) + real :: at(gbx%Npoints, gbx%Nlevels) + real :: dem_s(gbx%Npoints, gbx%Nlevels) + real :: dem_c(gbx%Npoints, gbx%Nlevels) + real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) + integer :: sunlit(gbx%Npoints) + + Nlevels = gbx%Nlevels + Npoints = gbx%Npoints + ! Flip inputs. Levels from TOA to surface + pfull = gbx%p(:,Nlevels:1:-1) + phalf(:,1) = 0.0 ! Top level + phalf(:,2:Nlevels+1) = gbx%ph(:,Nlevels:1:-1) + qv = gbx%sh(:,Nlevels:1:-1) + cc = 0.999999*gbx%tca(:,Nlevels:1:-1) + conv = 0.999999*gbx%cca(:,Nlevels:1:-1) + dtau_s = gbx%dtau_s(:,Nlevels:1:-1) + dtau_c = gbx%dtau_c(:,Nlevels:1:-1) + at = gbx%T(:,Nlevels:1:-1) + dem_s = gbx%dem_s(:,Nlevels:1:-1) + dem_c = gbx%dem_c(:,Nlevels:1:-1) + frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sunlit = int(gbx%sunlit) + call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, & + pfull,phalf,qv,cc,conv,dtau_s,dtau_c, & + gbx%isccp_top_height,gbx%isccp_top_height_direction, & + gbx%isccp_overlap,frac_out, & + gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, & + y%meanptop,y%meantaucld,y%meanalbedocld, & + y%meantb,y%meantbclr,y%boxtau,y%boxptop) + + ! Flip outputs. Levels from surface to TOA + ! --- (npoints,tau=7,pressure=7) + y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1) + + ! Change boxptop from hPa to Pa. This avoids using UDUNITS in CMOR +! y%boxptop = y%boxptop*100.0 + + ! Check if there is any value slightly greater than 1 + where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5)) + y%totalcldarea = 1.0 + endwhere + +END SUBROUTINE COSP_ISCCP_SIMULATOR + +END MODULE MOD_COSP_ISCCP_SIMULATOR Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_lidar.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_lidar.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_lidar.F90 (revision 1634) @@ -0,0 +1,87 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Oct 2008 - S. Bony - Instructions "Call for large-scale cloud" removed -> sgx%frac_out is used instead. +! Call lidar_simulator changed (lsca, gbx%cca and depol removed; +! frac_out changed in sgx%frac_out) +! +! +MODULE MOD_COSP_LIDAR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_LIDAR ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgrid info + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_sglidar),intent(inout) :: y ! Subgrid output + + ! Local variables + integer :: i + real :: presf(sgx%Npoints, sgx%Nlevels + 1) + real :: frac_out(sgx%Npoints, sgx%Nlevels) + real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci + real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot + real,dimension(sgx%Npoints, PARASOL_NREFL) :: refle + + + presf(:,1:sgx%Nlevels) = gbx%ph + presf(:,sgx%Nlevels + 1) = 0.0 +! presf(:,sgx%Nlevels + 1) = gbx%p(:,sgx%Nlevels) - (presf(:,sgx%Nlevels) - gbx%p(:,sgx%Nlevels)) + lsca = gbx%tca-gbx%cca + do i=1,sgx%Ncolumns + ! Temporary arrays for simulator call + mr_ll(:,:) = sghydro%mr_hydro(:,i,:,I_LSCLIQ) + mr_li(:,:) = sghydro%mr_hydro(:,i,:,I_LSCICE) + mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ) + mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE) + frac_out(:,:) = sgx%frac_out(:,i,:) + call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4 & + , PARASOL_NREFL, LIDAR_UNDEF & + , gbx%p, presf, gbx%T & + , mr_ll, mr_li, mr_cl, mr_ci & + , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE), gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) & + , frac_out, gbx%lidar_ice_type, y%beta_mol, beta_tot, tau_tot & + , refle ) ! reflectance + + y%beta_tot(:,i,:) = beta_tot(:,:) + y%tau_tot(:,i,:) = tau_tot(:,:) + y%refl(:,i,:) = refle(:,:) + enddo + +END SUBROUTINE COSP_LIDAR + +END MODULE MOD_COSP_LIDAR Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_misr_simulator.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_misr_simulator.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_misr_simulator.F90 (revision 1634) @@ -0,0 +1,80 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Nov 2008 - A. Bodas-Salcedo - Initial version +! +! + +MODULE MOD_COSP_MISR_SIMULATOR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------- SUBROUTINE COSP_MISR_SIMULATOR ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_MISR_SIMULATOR(gbx,sgx,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info + type(cosp_misr),intent(inout) :: y ! MISR simulator output + + ! Local variables + integer :: i,Nlevels,Npoints + real :: dtau_s(gbx%Npoints, gbx%Nlevels) + real :: dtau_c(gbx%Npoints, gbx%Nlevels) + real :: at(gbx%Npoints, gbx%Nlevels) + real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) + integer :: sunlit(gbx%Npoints) + + real :: zfull(gbx%Npoints, gbx%Nlevels) ! height (in meters) of full model levels (i.e. midpoints) + ! zfull(npoints,1) is top level of model + ! zfull(npoints,nlev) is bottom level of model + real :: phy_t0p1_mean_ztop ! mean cloud top height(m) of 0.1 tau treshold + real :: fq_phy_t0p1_TAU_v_CTH(7,16) + + + Nlevels = gbx%Nlevels + Npoints = gbx%Npoints + ! Levels from TOA to surface + zfull = gbx%zlev(:,Nlevels:1:-1) + at = gbx%T(:,Nlevels:1:-1) + dtau_s = gbx%dtau_s(:,Nlevels:1:-1) + dtau_c = gbx%dtau_c(:,Nlevels:1:-1) + frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sunlit = int(gbx%sunlit) + + call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,& + sunlit,zfull,at,dtau_s,dtau_c,frac_out, & + y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea) + +END SUBROUTINE COSP_MISR_SIMULATOR + +END MODULE MOD_COSP_MISR_SIMULATOR Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_radar.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_radar.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_radar.F90 (revision 1634) @@ -0,0 +1,212 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP_RADAR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + use radar_simulator_types + use array_lib + use atmos_lib + use format_input + IMPLICIT NONE + + INTERFACE + subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, & + nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, & + rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, & + g_to_vol_in,g_to_vol_out) + + use m_mrgrnk + use array_lib + use math_lib + use optics_lib + use radar_simulator_types + implicit none + ! ----- INPUTS ----- + type(mie), intent(in) :: mt + type(class_param) :: hp + real*8, intent(in) :: freq,k2 + integer, intent(in) :: do_ray,use_gas_abs,use_mie_table, & + nhclass,nprof,ngate,nsizes + real*8, dimension(nsizes), intent(in) :: D + real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, & + t_matrix,rh_matrix + real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix + real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix + ! ----- OUTPUTS ----- + real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, & + g_atten_to_vol,dBZe,h_atten_to_vol + ! ----- OPTIONAL ----- + real*8, optional, dimension(ngate,nprof) :: & + g_to_vol_in,g_to_vol_out + end subroutine radar_simulator + END INTERFACE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_RADAR ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RADAR(gbx,sgx,sghydro,z) + IMPLICIT NONE + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgrid info + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_sgradar),intent(inout) :: z ! Output from simulator, subgrid + + ! Local variables + integer :: & + nsizes ! num of discrete drop sizes + + real*8 :: & + freq, & ! radar frequency (GHz) + k2 ! |K|^2, -1=use frequency dependent default + + real*8, dimension(:,:), allocatable :: & + g_to_vol ! integrated atten due to gases, r>v (dB) + + real*8, dimension(:,:), allocatable :: & + Ze_non, & ! radar reflectivity withOUT attenuation (dBZ) + Ze_ray, & ! Rayleigh reflectivity (dBZ) + h_atten_to_vol, & ! attenuation by hydromets, radar to vol (dB) + g_atten_to_vol, & ! gaseous atteunation, radar to vol (dB) + dBZe, & ! effective radar reflectivity factor (dBZ) + hgt_matrix, & ! height of hydrometeors (km) + t_matrix, & !temperature (k) + p_matrix, & !pressure (hPa) + rh_matrix !relative humidity (%) + + real*8, dimension(:,:,:), allocatable :: & + hm_matrix, & ! hydrometeor mixing ratio (g kg^-1) + re_matrix + + integer, parameter :: one = 1 + logical :: hgt_reversed + integer :: pr,i,j,k,unt + +! ----- main program settings ------ + + freq = gbx%radar_freq + k2 = gbx%k2 + + ! + ! note: intitialization section that was here has been relocated to SUBROUTINE CONSTRUCT_COSP_GRIDBOX by roj, Feb 2008 + ! + mt_ttl=gbx%mt_ttl ! these variables really should be moved into the mt structure rather than kept as global arrays. + mt_tti=gbx%mt_tti + + ! Inputs to Quickbeam + allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), & + t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels)) + allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) + allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) + + ! Outputs from Quickbeam + allocate(Ze_non(gbx%Npoints,gbx%Nlevels)) + allocate(Ze_ray(gbx%Npoints,gbx%Nlevels)) + allocate(h_atten_to_vol(gbx%Npoints,gbx%Nlevels)) + allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels)) + allocate(dBZe(gbx%Npoints,gbx%Nlevels)) + + ! Optional argument. It is computed and returned in the first call to + ! radar_simulator, and passed as input in the rest + allocate(g_to_vol(gbx%Nlevels,gbx%Npoints)) + + p_matrix = gbx%p/100.0 ! From Pa to hPa + hgt_matrix = gbx%zlev/1000.0 ! From m to km + t_matrix = gbx%T-273.15 ! From K to C + rh_matrix = gbx%q + re_matrix = 0.0 + + ! Quickbeam assumes the first row is closest to the radar + call order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, & + rh_matrix,gbx%surface_radar,hgt_reversed) + + ! ----- loop over subcolumns ----- + do pr=1,sgx%Ncolumns + ! atmospheric profiles are the same within the same gridbox + ! only hydrometeor profiles will be different + if (hgt_reversed) then + do i=1,gbx%Nhydro + hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,gbx%Nlevels:1:-1,i)*1000.0 ! Units from kg/kg to g/kg + if (gbx%use_reff) then + re_matrix(i,:,:) = sghydro%Reff(:,pr,gbx%Nlevels:1:-1,i)*1.e6 ! Units from m to micron + endif + enddo + else + do i=1,gbx%Nhydro + hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg + if (gbx%use_reff) then + re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6 ! Units from m to micron + endif + enddo + endif + + ! ----- call radar simulator ----- + if (pr == 1) then ! Compute gaseous attenuation for all profiles + j=0 + if (gbx%Npoints == 53) then + unt=10 + j=1 + endif + if (gbx%Npoints == 153) then + unt=11 + j=101 + endif + call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, & ! v0.2: mt changed to gbx%mt, roj + gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, & ! v0.2: hp->gbx%hp, D->gbx%d, nsizes->gbx%nsizes, roj + hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol) + else ! Use gaseous atteunuation for pr = 1 + call radar_simulator(freq,k2,gbx%do_ray,gbx%use_gas_abs,gbx%use_mie_tables,gbx%mt, & + gbx%Nhydro,gbx%hp,gbx%Npoints,gbx%Nlevels,gbx%nsizes,gbx%D, & + hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix,rh_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol) + endif + ! ----- BEGIN output section ----- + ! spaceborne radar : from TOA to SURFACE + if (gbx%surface_radar == 1) then + z%Ze_tot(:,pr,:)=dBZe(:,:) + else if (gbx%surface_radar == 0) then ! Spaceborne + z%Ze_tot(:,pr,:)=dBZe(:,gbx%Nlevels:1:-1) + endif + + enddo !pr + + ! Change undefined value to one defined in COSP + where (z%Ze_tot == -999.0) z%Ze_tot = R_UNDEF + + deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix) + deallocate(hm_matrix,re_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe) + deallocate(g_to_vol) + + ! deallocate(mt_ttl,mt_tti) !v0.2: roj feb 2008 can not be done here, + !these variables now part of gbx structure and dealocated later + +END SUBROUTINE COSP_RADAR + +END MODULE MOD_COSP_RADAR Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_simulator.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_simulator.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_simulator.F90 (revision 1634) @@ -0,0 +1,96 @@ +! (c) British Crown Copyright 2008, the Met Office. + +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! +! + +MODULE MOD_COSP_SIMULATOR + USE MOD_COSP_TYPES + USE MOD_COSP_RADAR + USE MOD_COSP_LIDAR + USE MOD_COSP_ISCCP_SIMULATOR + USE MOD_COSP_MISR_SIMULATOR + USE MOD_COSP_STATS + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP_SIMULATOR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,stradar,stlidar) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Grid-box inputs + type(cosp_subgrid),intent(in) :: sgx ! Subgrid inputs + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + ! Local variables + ! ***Timing variables (to be deleted in final version) + integer :: t0,t1,count_rate,count_max + + !+++++++++ Radar model ++++++++++ + if (cfg%Lradar_sim) then + call cosp_radar(gbx,sgx,sghydro,sgradar) + endif + + !+++++++++ Lidar model ++++++++++ + if (cfg%Llidar_sim) then + call cosp_lidar(gbx,sgx,sghydro,sglidar) + endif + + + !+++++++++ ISCCP simulator ++++++++++ + if (cfg%Lisccp_sim) then + call cosp_isccp_simulator(gbx,sgx,isccp) + endif + + !+++++++++ MISR simulator ++++++++++ + if (cfg%Lmisr_sim) then + call cosp_misr_simulator(gbx,sgx,misr) + endif + + + !+++++++++++ Summary statistics +++++++++++ + if (cfg%Lstats) then + call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) +! print *, '%%%%%% Stats:', (t1-t0)*1.0/count_rate, ' s' + endif + + +END SUBROUTINE COSP_SIMULATOR + +END MODULE MOD_COSP_SIMULATOR Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_stats.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_stats.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_stats.F90 (revision 1634) @@ -0,0 +1,254 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid +! Oct 2008 - J.-L. Dufresne - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns in COSP_STATS +! Oct 2008 - H. Chepfer - Added PARASOL reflectance arguments +! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations +! +! +MODULE MOD_COSP_STATS + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_LLNL_STATS + USE MOD_LMD_IPSL_STATS + IMPLICIT NONE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_STATS ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) + + ! Input arguments + type(cosp_gridbox),intent(in) :: gbx + type(cosp_subgrid),intent(in) :: sgx + type(cosp_config),intent(in) :: cfg + type(cosp_sgradar),intent(in) :: sgradar + type(cosp_sglidar),intent(in) :: sglidar + type(cosp_vgrid),intent(in) :: vgrid + ! Output arguments + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar + + ! Local variables + integer :: Npoints !# of grid points + integer :: Nlevels !# of levels + integer :: Nhydro !# of hydrometeors + integer :: Ncolumns !# of columns + integer :: Nlr + logical :: ok_lidar_cfad = .false. + real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out + real,dimension(:,:),allocatable :: ph_c,betamol_c + + Npoints = gbx%Npoints + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + Ncolumns = gbx%Ncolumns + Nlr = vgrid%Nlvgrid + + if (cfg%Lcfad_Lidarsr532) ok_lidar_cfad=.true. + + if (vgrid%use_vgrid) then ! Statistics in a different vertical grid + allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), & + betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), & + ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr)) + Ze_out = 0.0 + betatot_out = 0.0 + betamol_out= 0.0 + betamol_c = 0.0 + ph_in(:,1,:) = gbx%ph(:,:) + ph_out = 0.0 + ph_c = 0.0 + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) then + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, & + Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.) + stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + endif + !++++++++++++ Lidar CFAD ++++++++++++++++ + if (cfg%Llidar_sim) then + betamol_in(:,1,:) = sglidar%beta_mol(:,:) + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, & + Nlr,vgrid%zl,vgrid%zu,betamol_out) + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, & + Nlr,vgrid%zl,vgrid%zu,betatot_out) + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, & + Nlr,vgrid%zl,vgrid%zu,ph_out) + ph_c(:,:) = ph_out(:,1,:) + betamol_c(:,:) = betamol_out(:,1,:) + ! Stats from lidar_stat_summary + call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,betatot_out,betamol_c,sglidar%refl,gbx%land,ph_c & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl) + endif + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + betatot_out,betamol_c,Ze_out, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + ! Deallocate arrays at coarse resolution + deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c) + else ! Statistics in model levels + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + !++++++++++++ Lidar CFAD ++++++++++++++++ + ! Stats from lidar_stat_summary + if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,sglidar%beta_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,stlidar%lidarcld,stlidar%cldlayer,stlidar%parasolrefl) + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + sglidar%beta_tot,sglidar%beta_mol,sgradar%Ze_tot, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + endif + ! Replace undef + where (stlidar%cfad_sr == LIDAR_UNDEF) stlidar%cfad_sr = R_UNDEF + where (stlidar%lidarcld == LIDAR_UNDEF) stlidar%lidarcld = R_UNDEF + where (stlidar%cldlayer == LIDAR_UNDEF) stlidar%cldlayer = R_UNDEF + where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF + +END SUBROUTINE COSP_STATS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ---------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,M,zl,zu,r,log_units) + implicit none + ! Input arguments + integer,intent(in) :: Npoints !# of grid points + integer,intent(in) :: Nlevels !# of levels + integer,intent(in) :: Ncolumns !# of columns + real,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) + real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y ! Variable to be changed to a different grid + integer,intent(in) :: M !# levels in the new grid + real,dimension(M),intent(in) :: zl ! Lower boundary of new levels [m] + real,dimension(M),intent(in) :: zu ! Upper boundary of new levels [m] + logical,optional,intent(in) :: log_units ! log units, need to convert to linear units + ! Output + real,dimension(Npoints,Ncolumns,M),intent(out) :: r ! Variable on new grid + + ! Local variables + integer :: i,j,k + logical :: lunits + + integer :: l + real,dimension(Npoints) :: ws,sumwyp + real,dimension(Npoints,Nlevels) :: xl,xu + real,dimension(Npoints,Nlevels) :: w + real,dimension(Npoints,Ncolumns,Nlevels) :: yp + + lunits=.false. + if (present(log_units)) lunits=log_units + + r(:,:,:) = R_GROUND + ! Vertical grid at that point + xl(:,:) = zhalf(:,:) + xu(:,1:Nlevels-1) = xl(:,2:Nlevels) + xu(:,Nlevels) = zfull(:,Nlevels) + zfull(:,Nlevels) - zhalf(:,Nlevels) ! Top level symmetric + yp(:,:,:) = y(:,:,:) ! Temporary variable to regrid + ! Check for dBZ and change if necessary + if (lunits) then + where (y /= R_UNDEF) + yp = 10.0**(y/10.0) + elsewhere + yp = 0.0 + end where + endif + do k=1,M + ! Find weights + w(:,:) = 0.0 + do j=1,Nlevels + do i=1,Npoints + if ((xl(i,j) < zl(k)).and.(xu(i,j) > zl(k)).and.(xu(i,j) <= zu(k))) then + !xl(j)-----------------xu(j) + ! zl(k)------------------------------zu(k) + w(i,j) = xu(i,j) - zl(k) + else if ((xl(i,j) >= zl(k)).and.(xu(i,j) <= zu(k))) then + ! xl(j)-----------------xu(j) + ! zl(k)------------------------------zu(k) + w(i,j) = xu(i,j) - xl(i,j) + else if ((xl(i,j) >= zl(k)).and.(xl(i,j) < zu(k)).and.(xu(i,j) >= zu(k))) then + ! xl(j)-----------------xu(j) + ! zl(k)------------------------------zu(k) + w(i,j) = zu(k) - xl(i,j) + else if ((xl(i,j) <= zl(k)).and.(xu(i,j) >= zu(k))) then + ! xl(j)---------------------------xu(j) + ! zl(k)--------------zu(k) + w(i,j) = zu(k) - zl(k) + endif + enddo + enddo + ! Do the weighted mean + do j=1,Ncolumns + ws (:) = 0.0 + sumwyp(:) = 0.0 + do l=1,Nlevels + do i=1,Npoints + if (zu(k) > zhalf(i,1)) then ! Level above model bottom level + ws (i) = ws (i) + w(i,l) + sumwyp(i) = sumwyp(i) + w(i,l)*yp(i,j,l) + endif + enddo + enddo + do i=1,Npoints + if (zu(k) > zhalf(i,1)) then ! Level above model bottom level + if (ws(i) > 0.0) r(i,j,k) = sumwyp(i)/ws(i) + endif + enddo + enddo + enddo + ! Check for dBZ and change if necessary + if (lunits) then + do k=1,M + do j=1,Ncolumns + do i=1,Npoints + if (zu(k) > zhalf(i,1)) then ! Level above model bottom level + if (r(i,j,k) <= 0.0) then + r(i,j,k) = R_UNDEF + else + r(i,j,k) = 10.0*log10(r(i,j,k)) + endif + endif + enddo + enddo + enddo + endif + + + +END SUBROUTINE COSP_CHANGE_VERTICAL_GRID + +END MODULE MOD_COSP_STATS Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_types.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_types.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_types.F90 (revision 1634) @@ -0,0 +1,1379 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Feb 2008 - R. Marchand - Added Quickbeam types and initialisation +! Oct 2008 - H. Chepfer - Added PARASOL reflectance diagnostic +! Nov 2008 - R. Marchand - Added MISR diagnostics +! Nov 2008 - V. John - Added RTTOV diagnostics +! +! +MODULE MOD_COSP_TYPES + USE MOD_COSP_CONSTANTS + USE MOD_COSP_UTILS + + use radar_simulator_types, only: class_param, mie, nd, mt_nd, dmax, dmin, mt_ttl, mt_tti, cnt_liq, cnt_ice ! added by roj Feb 2008 + + IMPLICIT NONE + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------------- DERIVED TYPES ---------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Configuration choices (simulators, variables) + TYPE COSP_CONFIG + logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, & + Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, & + Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, & + Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfrac_out,Lbeta_mol532,Ltbrttov + character(len=32) :: out_list(N_OUT_LIST) + END TYPE COSP_CONFIG + + ! Outputs from RTTOV + TYPE COSP_RTTOV + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Nchan ! Number of channels + + ! Brightness temperatures (Npoints,Nchan) + real,pointer :: tbs(:,:) + + END TYPE COSP_RTTOV + + ! Outputs from MISR simulator + TYPE COSP_MISR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ntau ! Number of tau intervals + integer :: Nlevels ! Number of cth levels + + ! --- (npoints,ntau,nlevels) + ! the fraction of the model grid box covered by each of the MISR cloud types + real,pointer :: fq_MISR(:,:,:) + + ! --- (npoints) + real,pointer :: MISR_meanztop(:), MISR_cldarea(:) + ! --- (npoints,nlevels) + real,pointer :: MISR_dist_model_layertops(:,:) + END TYPE COSP_MISR + + ! Outputs from ISCCP simulator + TYPE COSP_ISCCP + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + + + ! --- (npoints,tau=7,pressure=7) + ! the fraction of the model grid box covered by each of the 49 ISCCP D level cloud types + real,pointer :: fq_isccp(:,:,:) + + ! --- (npoints) --- + ! The fraction of model grid box columns with cloud somewhere in them. + ! This should equal the sum over all entries of fq_isccp + real,pointer :: totalcldarea(:) + ! mean all-sky 10.5 micron brightness temperature + real,pointer :: meantb(:) + ! mean clear-sky 10.5 micron brightness temperature + real,pointer :: meantbclr(:) + + ! The following three means are averages over the cloudy areas only. If no + ! clouds are in grid box all three quantities should equal zero. + + ! mean cloud top pressure (mb) - linear averaging in cloud top pressure. + real,pointer :: meanptop(:) + ! mean optical thickness linear averaging in albedo performed. + real,pointer :: meantaucld(:) + ! mean cloud albedo. linear averaging in albedo performed + real,pointer :: meanalbedocld(:) + + !--- (npoints,ncol) --- + ! optical thickness in each column + real,pointer :: boxtau(:,:) + ! cloud top pressure (mb) in each column + real,pointer :: boxptop(:,:) + END TYPE COSP_ISCCP + + ! Summary statistics from radar + TYPE COSP_VGRID + logical :: use_vgrid ! Logical flag that indicates change of grid + logical :: csat_vgrid ! Flag for Cloudsat grid + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nlvgrid ! Number of levels of new grid + ! Array with dimensions (Nlvgrid) + real, dimension(:), pointer :: z,zl,zu ! Height and lower and upper boundaries of new levels + ! Array with dimensions (Nlevels) + real, dimension(:), pointer :: mz,mzl,mzu ! Height and lower and upper boundaries of model levels + END TYPE COSP_VGRID + + ! Output data from lidar code + TYPE COSP_SGLIDAR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Nrefl ! Number of parasol reflectances + ! Arrays with dimensions (Npoints,Nlevels) + real,dimension(:,:),pointer :: beta_mol ! Molecular backscatter + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: beta_tot ! Total backscattered signal + real,dimension(:,:,:),pointer :: tau_tot ! Optical thickness integrated from top to level z + ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) + real,dimension(:,:,:),pointer :: refl ! parasol reflectances + END TYPE COSP_SGLIDAR + + ! Output data from radar code + TYPE COSP_SGRADAR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + ! output vertical levels: spaceborne radar -> from TOA to SURFACE + ! Arrays with dimensions (Npoints,Nlevels) + real,dimension(:,:),pointer :: att_gas ! 2-way attenuation by gases [dBZ] + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: Ze_tot ! Effective reflectivity factor [dBZ] + + END TYPE COSP_SGRADAR + + + ! Summary statistics from radar + TYPE COSP_RADARSTATS + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nhydro ! Number of hydrometeors + ! Array with dimensions (Npoints,dBZe_bins,Nlevels) + real, dimension(:,:,:), pointer :: cfad_ze ! Ze CFAD + ! Array with dimensions (Npoints) + real,dimension(:),pointer :: radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale + ! Arrays with dimensions (Npoints,Nlevels) + real, dimension(:,:),pointer :: lidar_only_freq_cloud + END TYPE COSP_RADARSTATS + + ! Summary statistics from lidar + TYPE COSP_LIDARSTATS + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nhydro ! Number of hydrometeors + integer :: Nrefl ! Number of parasol reflectances + + ! Arrays with dimensions (SR_BINS) + real, dimension(:),pointer :: srbval ! SR bins in cfad_sr + ! Arrays with dimensions (Npoints,SR_BINS,Nlevels) + real, dimension(:,:,:),pointer :: cfad_sr ! CFAD of scattering ratio + ! Arrays with dimensions (Npoints,Nlevels) + real, dimension(:,:),pointer :: lidarcld ! 3D "lidar" cloud fraction + ! Arrays with dimensions (Npoints,LIDAR_NCAT) + real, dimension(:,:),pointer :: cldlayer ! low, mid, high-level lidar cloud cover + ! Arrays with dimensions (Npoints,PARASOL_NREFL) + real, dimension(:,:),pointer :: parasolrefl ! mean parasol reflectance + + END TYPE COSP_LIDARSTATS + + + ! Input data for simulator. Subgrid scale. + ! Input data from SURFACE to TOA + TYPE COSP_SUBGRID + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + + real,dimension(:,:,:),pointer :: prec_frac ! Subgrid precip array. Dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: frac_out ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) + END TYPE COSP_SUBGRID + + ! Input data for simulator at Subgrid scale. + ! Used on a reduced number of points + TYPE COSP_SGHYDRO + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + real,dimension(:,:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor + ! (Npoints,Ncolumns,Nlevels,Nhydro) [kg/kg] + real,dimension(:,:,:,:),pointer :: Reff ! Effective Radius of each hydrometeor + ! (Reff==0 means use default size) + ! (Npoints,Ncolumns,Nlevels,Nhydro) [m] + END TYPE COSP_SGHYDRO + + ! Input data for simulator. Gridbox scale. + TYPE COSP_GRIDBOX + ! Scalars and dimensions + integer :: Npoints ! Number of gridpoints + integer :: Nlevels ! Number of levels + integer :: Ncolumns ! Number of columns + integer :: Nhydro ! Number of hydrometeors + integer :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions + integer :: Naero ! Number of aerosol species + integer :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions + integer :: Npoints_it ! Max number of gridpoints to be processed in one iteration + + ! Time [days] + double precision :: time + + ! Radar ancillary info + real :: radar_freq, & ! Radar frequency [GHz] + k2 ! |K|^2, -1=use frequency dependent default + integer :: surface_radar, & ! surface=1, spaceborne=0 + use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0 + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay ! melting layer model off=0, on=1 + + ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008 + type(class_param) :: hp ! structure used by radar simulator to store Ze and N scaling constants and other information + type(mie):: mt ! structure used by radar simulator to store mie LUT information + integer :: nsizes ! number of discrete drop sizes (um) used to represent the distribution + real*8, dimension(:), pointer :: D ! array of discrete drop sizes (um) used to represent the distribution + real*8, dimension(:), pointer :: mt_ttl, mt_tti ! array of temperatures used with Ze_scaling (also build into mie LUT) + + ! Lidar + integer :: lidar_ice_type !ice particle shape hypothesis in lidar calculations + !(ice_type=0 for spheres, ice_type=1 for non spherical particles) + + ! Radar + logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm + logical :: use_reff ! True if Reff is to be used by radar + + ! Geolocation (Npoints) + real,dimension(:),pointer :: longitude ! longitude [degrees East] + real,dimension(:),pointer :: latitude ! latitude [deg North] + ! Gridbox information (Npoints,Nlevels) + real,dimension(:,:),pointer :: zlev ! Height of model levels [m] + real,dimension(:,:),pointer :: zlev_half ! Height at half model levels [m] (Bottom of model layer) + real,dimension(:,:),pointer :: dlev ! Depth of model levels [m] + real,dimension(:,:),pointer :: p ! Pressure at full model levels [Pa] + real,dimension(:,:),pointer :: ph ! Pressure at half model levels [Pa] + real,dimension(:,:),pointer :: T ! Temperature at model levels [K] + real,dimension(:,:),pointer :: q ! Relative humidity to water (%) + real,dimension(:,:),pointer :: sh ! Specific humidity to water [kg/kg] + real,dimension(:,:),pointer :: dtau_s ! mean 0.67 micron optical depth of stratiform + ! clouds in each model level + ! NOTE: this the cloud optical depth of only the + ! cloudy part of the grid box, it is not weighted + ! with the 0 cloud optical depth of the clear + ! part of the grid box + real,dimension(:,:),pointer :: dtau_c ! mean 0.67 micron optical depth of convective + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: dem_s ! 10.5 micron longwave emissivity of stratiform + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: dem_c ! 10.5 micron longwave emissivity of convective + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: mr_ozone ! Ozone mass mixing ratio [kg/kg] + + ! Point information (Npoints) + real,dimension(:),pointer :: land !Landmask [0 - Ocean, 1 - Land] + real,dimension(:),pointer :: psfc !Surface pressure [Pa] + real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime + real,dimension(:),pointer :: skt ! Skin temperature (K) + real,dimension(:),pointer :: sfc_height ! Surface height [m] + real,dimension(:),pointer :: u_wind ! eastward wind [m s-1] + real,dimension(:),pointer :: v_wind ! northward wind [m s-1] + + ! TOTAL and CONV cloud fraction for SCOPS + real,dimension(:,:),pointer :: tca ! Total cloud fraction + real,dimension(:,:),pointer :: cca ! Convective cloud fraction + ! Precipitation fluxes on model levels + real,dimension(:,:),pointer :: rain_ls ! large-scale precipitation flux of rain [kg/m2.s] + real,dimension(:,:),pointer :: rain_cv ! convective precipitation flux of rain [kg/m2.s] + real,dimension(:,:),pointer :: snow_ls ! large-scale precipitation flux of snow [kg/m2.s] + real,dimension(:,:),pointer :: snow_cv ! convective precipitation flux of snow [kg/m2.s] + real,dimension(:,:),pointer :: grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s] + ! Hydrometeors concentration and distribution parameters +! real,dimension(:,:,:),pointer :: fr_hydro ! Fraction of the gridbox occupied by each hydrometeor (Npoints,Nlevels,Nhydro) + real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg] + real,dimension(:,:),pointer :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro) + ! Effective radius [m]. (Npoints,Nlevels,Nhydro) + real,dimension(:,:,:),pointer :: Reff + ! Aerosols concentration and distribution parameters + real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero) + integer,dimension(:),pointer :: dist_type_aero ! Particle size distribution type for each aerosol species (Naero) + real,dimension(:,:,:,:),pointer :: dist_prmts_aero ! Distributional parameters for aerosols + ! (Npoints,Nlevels,Nprmts_max_aero,Naero) + ! ISCCP simulator inputs + integer :: isccp_top_height ! 1 = adjust top height using both a computed + ! infrared brightness temperature and the visible + ! optical depth to adjust cloud top pressure. Note + ! that this calculation is most appropriate to compare + ! to ISCCP data during sunlit hours. + ! 2 = do not adjust top height, that is cloud top + ! pressure is the actual cloud top pressure + ! in the model + ! 3 = adjust top height using only the computed + ! infrared brightness temperature. Note that this + ! calculation is most appropriate to compare to ISCCP + ! IR only algortihm (i.e. you can compare to nighttime + ! ISCCP data with this option) + integer :: isccp_top_height_direction ! direction for finding atmosphere pressure level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 1 = find the *lowest* altitude (highest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 2 = find the *highest* altitude (lowest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! 1 = default setting, and matches all versions of + ! ISCCP simulator with versions numbers 3.5.1 and lower + ! 2 = experimental setting + integer :: isccp_overlap ! overlap type (1=max, 2=rand, 3=max/rand) + real :: isccp_emsfc_lw ! 10.5 micron emissivity of surface (fraction) + + ! RTTOV inputs/options + integer :: plat ! satellite platform + integer :: sat ! satellite + integer :: inst ! instrument + integer :: Nchan ! Number of channels to be computed + integer, dimension(:), pointer :: Ichan ! Channel numbers + real, dimension(:), pointer :: Surfem ! Surface emissivity + real :: ZenAng ! Satellite Zenith Angles + real :: co2,ch4,n2o,co ! Mixing ratios of trace gases + + END TYPE COSP_GRIDBOX + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV ------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_RTTOV(Npoints,Nchan,x) + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Nchan ! Number of channels + type(cosp_rttov),intent(out) :: x + + ! Dimensions + x%Npoints = Npoints + x%Nchan = Nchan + + ! --- Allocate arrays --- + allocate(x%tbs(Npoints, Nchan)) + ! --- Initialise to zero --- + x%tbs = 0.0 + END SUBROUTINE CONSTRUCT_COSP_RTTOV + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_RTTOV ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_RTTOV(x) + type(cosp_rttov),intent(inout) :: x + + ! --- Deallocate arrays --- + deallocate(x%tbs) + END SUBROUTINE FREE_COSP_RTTOV + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_MISR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_MISR(cfg,Npoints,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of gridpoints + type(cosp_misr),intent(out) :: x + ! Local variables + integer :: i,j,k + + + ! Allocate minumum storage if simulator not used + if (cfg%Lmisr_sim) then + i = Npoints + j = 7 + k = MISR_N_CTH + else + i = 1 + j = 1 + k = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ntau = j + x%Nlevels = k + + ! allocate space for MISR simulator outputs ... + allocate(x%fq_MISR(i,j,k), x%MISR_meanztop(i),x%MISR_cldarea(i), x%MISR_dist_model_layertops(i,k)) + x%fq_MISR = 0.0 + x%MISR_meanztop = 0.0 + x%MISR_cldarea = 0.0 + x%MISR_dist_model_layertops = 0.0 + + END SUBROUTINE CONSTRUCT_COSP_MISR +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_MISR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_MISR(x) + type(cosp_misr),intent(inout) :: x + deallocate(x%fq_MISR, x%MISR_meanztop,x%MISR_cldarea, x%MISR_dist_model_layertops) + + END SUBROUTINE FREE_COSP_MISR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_ISCCP ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_ISCCP(cfg,Npoints,Ncolumns,Nlevels,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + type(cosp_isccp),intent(out) :: x + ! Local variables + integer :: i,j,k + + ! Allocate minumum storage if simulator not used + if (cfg%Lisccp_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + else + i = 1 + j = 1 + k = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + + ! --- Allocate arrays --- + allocate(x%fq_isccp(i,7,7), x%totalcldarea(i), & + x%meanptop(i), x%meantaucld(i), & + x%meantb(i), x%meantbclr(i), & + x%boxtau(i,j), x%boxptop(i,j), & + x%meanalbedocld(i)) + ! --- Initialise to zero --- + x%fq_isccp = 0.0 + x%totalcldarea = 0.0 + x%meanptop = 0.0 + x%meantaucld = 0.0 + x%meantb = 0.0 + x%meantbclr = 0.0 + x%boxtau = 0.0 + x%boxptop = 0.0 + x%meanalbedocld= 0.0 + END SUBROUTINE CONSTRUCT_COSP_ISCCP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_ISCCP ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_ISCCP(x) + type(cosp_isccp),intent(inout) :: x + + deallocate(x%fq_isccp, x%totalcldarea, & + x%meanptop, x%meantaucld, x%meantb, x%meantbclr, & + x%boxtau, x%boxptop, x%meanalbedocld) + END SUBROUTINE FREE_COSP_ISCCP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_VGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x) + type(cosp_gridbox),intent(in) :: gbx ! Gridbox information + integer,intent(in) :: Nlvgrid ! Number of new levels + logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid + logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested + type(cosp_vgrid),intent(out) :: x + + ! Local variables + integer :: i + real :: zstep + + x%use_vgrid = use_vgrid + x%csat_vgrid = cloudsat + + ! Dimensions + x%Npoints = gbx%Npoints + x%Ncolumns = gbx%Ncolumns + x%Nlevels = gbx%Nlevels + + ! --- Allocate arrays --- + if (use_vgrid) then + x%Nlvgrid = Nlvgrid + else + x%Nlvgrid = gbx%Nlevels + endif + allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid)) + allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels)) + + ! --- Model vertical levels --- + ! Use height levels of first model gridbox + x%mz = gbx%zlev(1,:) + x%mzl = gbx%zlev_half(1,:) + x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels) + x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels)) + + if (use_vgrid) then + ! --- Initialise to zero --- + x%z = 0.0 + x%zl = 0.0 + x%zu = 0.0 + if (cloudsat) then ! --- CloudSat grid requested --- + zstep = 480.0 + else + ! Other grid requested. Constant vertical spacing with top at 20 km + zstep = 20000.0/x%Nlvgrid + endif + do i=1,x%Nlvgrid + x%zl(i) = (i-1)*zstep + x%zu(i) = i*zstep + enddo + x%z = (x%zl + x%zu)/2.0 + else + x%z = x%mz + x%zl = x%mzl + x%zu = x%mzu + endif + + END SUBROUTINE CONSTRUCT_COSP_VGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_VGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_VGRID(x) + type(cosp_vgrid),intent(inout) :: x + + deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu) + END SUBROUTINE FREE_COSP_VGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGLIDAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGLIDAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nrefl ! Number of parasol reflectances ! parasol + type(cosp_sglidar),intent(out) :: x + ! Local variables + integer :: i,j,k,l,m + + ! Allocate minumum storage if simulator not used + if (cfg%Llidar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + m = Nrefl + else + i = 1 + j = 1 + k = 1 + l = 1 + m = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + x%Nrefl = m + + ! --- Allocate arrays --- + allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), & + x%tau_tot(i,j,k),x%refl(i,j,m)) + ! --- Initialise to zero --- + x%beta_mol = 0.0 + x%beta_tot = 0.0 + x%tau_tot = 0.0 + x%refl = 0.0 ! parasol + END SUBROUTINE CONSTRUCT_COSP_SGLIDAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_SGLIDAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGLIDAR(x) + type(cosp_sglidar),intent(inout) :: x + + deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl) + END SUBROUTINE FREE_COSP_SGLIDAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGRADAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGRADAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_sgradar),intent(out) :: x + ! Local variables + integer :: i,j,k,l + + if (cfg%Lradar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + else ! Allocate minumum storage if simulator not used + i = 1 + j = 1 + k = 1 + l = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + + ! --- Allocate arrays --- + allocate(x%att_gas(i,k), x%Ze_tot(i,j,k)) + ! --- Initialise to zero --- + x%att_gas = 0.0 + x%Ze_tot = 0.0 + ! The following line give a compilation error on the Met Office NEC +! call zero_real(x%Z_hydro, x%att_hydro) +! f90: error(666): cosp_types.f90, line nnn: +! Actual argument corresponding to dummy +! argument of ELEMENTAL subroutine +! "zero_real" with INTENET(OUT) attribute +! is not array. + END SUBROUTINE CONSTRUCT_COSP_SGRADAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_SGRADAR ---------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGRADAR(x) + type(cosp_sgradar),intent(inout) :: x + + deallocate(x%att_gas, x%Ze_tot) + END SUBROUTINE FREE_COSP_SGRADAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------- SUBROUTINE CONSTRUCT_COSP_RADARSTATS --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_RADARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_radarstats),intent(out) :: x + ! Local variables + integer :: i,j,k,l + + ! Allocate minumum storage if simulator not used + if (cfg%Lradar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + else + i = 1 + j = 1 + k = 1 + l = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + + ! --- Allocate arrays --- + allocate(x%cfad_ze(i,DBZE_BINS,k),x%lidar_only_freq_cloud(i,k)) + allocate(x%radar_lidar_tcc(i)) + ! --- Initialise to zero --- + x%cfad_ze = 0.0 + x%lidar_only_freq_cloud = 0.0 + x%radar_lidar_tcc = 0.0 + END SUBROUTINE CONSTRUCT_COSP_RADARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_RADARSTATS ------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_RADARSTATS(x) + type(cosp_radarstats),intent(inout) :: x + + deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc) + END SUBROUTINE FREE_COSP_RADARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------- SUBROUTINE CONSTRUCT_COSP_LIDARSTATS --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_LIDARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nrefl ! Number of parasol reflectance + type(cosp_lidarstats),intent(out) :: x + ! Local variables + integer :: i,j,k,l,m + + ! Allocate minumum storage if simulator not used + if (cfg%Llidar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + m = Nrefl + else + i = 1 + j = 1 + k = 1 + l = 1 + m = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + x%Nrefl = m + + ! --- Allocate arrays --- + allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), & + x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m)) + ! --- Initialise to zero --- + x%srbval = 0.0 + x%cfad_sr = 0.0 + x%lidarcld = 0.0 + x%cldlayer = 0.0 + x%parasolrefl = 0.0 + END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_LIDARSTATS ------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_LIDARSTATS(x) + type(cosp_lidarstats),intent(inout) :: x + + deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl) + END SUBROUTINE FREE_COSP_LIDARSTATS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SUBGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y) + integer,intent(in) :: Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nlevels ! Number of levels + type(cosp_subgrid),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + + ! --- Allocate arrays --- + allocate(y%frac_out(Npoints,Ncolumns,Nlevels)) + if (Ncolumns > 1) then + allocate(y%prec_frac(Npoints,Ncolumns,Nlevels)) + else ! CRM mode, not needed + allocate(y%prec_frac(1,1,1)) + endif + ! --- Initialise to zero --- + y%prec_frac = 0.0 + y%frac_out = 0.0 + ! The following line gives a compilation error on the Met Office NEC +! call zero_real(y%mr_hydro) +! f90: error(666): cosp_types.f90, line nnn: +! Actual argument corresponding to dummy +! argument of ELEMENTAL subroutine +! "zero_real" with INTENET(OUT) attribute +! is not array. + + END SUBROUTINE CONSTRUCT_COSP_SUBGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_SUBGRID ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SUBGRID(y) + type(cosp_subgrid),intent(inout) :: y + + ! --- Deallocate arrays --- + deallocate(y%prec_frac, y%frac_out) + + END SUBROUTINE FREE_COSP_SUBGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGHYDRO ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGHYDRO(Npoints,Ncolumns,Nlevels,Nhydro,y) + integer,intent(in) :: Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nhydro, & ! Number of hydrometeors + Nlevels ! Number of levels + type(cosp_sghydro),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + y%Nhydro = Nhydro + + ! --- Allocate arrays --- + allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), & + y%Reff(Npoints,Ncolumns,Nlevels,Nhydro)) + ! --- Initialise to zero --- + y%mr_hydro = 0.0 + y%Reff = 0.0 + + END SUBROUTINE CONSTRUCT_COSP_SGHYDRO + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_SGHYDRO ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGHYDRO(y) + type(cosp_sghydro),intent(inout) :: y + + ! --- Deallocate arrays --- + deallocate(y%mr_hydro, y%Reff) + + END SUBROUTINE FREE_COSP_SGHYDRO + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, & + use_precipitation_fluxes,use_reff, & + ! RTTOV inputs + Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,& + y) + double precision,intent(in) :: time ! Time since start of run [days] + real,intent(in) :: radar_freq, & ! Radar frequency [GHz] + k2 ! |K|^2, -1=use frequency dependent default + integer,intent(in) :: & + surface_radar, & ! surface=1,spaceborne=0 + use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first column everywhere + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay ! melting layer model off=0, on=1 + integer,intent(in) :: Npoints ! Number of gridpoints + integer,intent(in) :: Nlevels ! Number of levels + integer,intent(in) :: Ncolumns ! Number of columns + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions + integer,intent(in) :: Naero ! Number of aerosol species + integer,intent(in) :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions + integer,intent(in) :: Npoints_it ! Number of gridpoints processed in one iteration + integer,intent(in) :: lidar_ice_type ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical) + integer,intent(in) :: isccp_top_height + integer,intent(in) :: isccp_top_height_direction + integer,intent(in) :: isccp_overlap + real,intent(in) :: isccp_emsfc_lw + logical,intent(in) :: use_precipitation_fluxes,use_reff + integer,intent(in) :: Plat + integer,intent(in) :: Sat + integer,intent(in) :: Inst + integer,intent(in) :: Nchan + integer,intent(in) :: Ichan(Nchan) + real,intent(in) :: SurfEm(Nchan) + real,intent(in) :: ZenAng + real,intent(in) :: co2,ch4,n2o,co + type(cosp_gridbox),intent(out) :: y + + + ! local variables + integer i, cnt_ice, cnt_liq + character*200 :: mie_table_name ! Mie table name + real*8 :: delt, deltp + + ! Dimensions and scalars + y%radar_freq = radar_freq + y%surface_radar = surface_radar + y%use_mie_tables = use_mie_tables + y%use_gas_abs = use_gas_abs + y%do_ray = do_ray + y%melt_lay = melt_lay + y%k2 = k2 + y%Npoints = Npoints + y%Nlevels = Nlevels + y%Ncolumns = Ncolumns + y%Nhydro = Nhydro + y%Nprmts_max_hydro = Nprmts_max_hydro + y%Naero = Naero + y%Nprmts_max_aero = Nprmts_max_aero + y%Npoints_it = Npoints_it + y%lidar_ice_type = lidar_ice_type + y%isccp_top_height = isccp_top_height + y%isccp_top_height_direction = isccp_top_height_direction + y%isccp_overlap = isccp_overlap + y%isccp_emsfc_lw = isccp_emsfc_lw + y%use_precipitation_fluxes = use_precipitation_fluxes + y%use_reff = use_reff + + y%time = time + + ! RTTOV parameters + y%Plat = Plat + y%Sat = Sat + y%Inst = Inst + y%Nchan = Nchan + y%ZenAng = ZenAng + y%co2 = co2 + y%ch4 = ch4 + y%n2o = n2o + y%co = co + + ! --- Allocate arrays --- + ! Gridbox information (Npoints,Nlevels) + allocate(y%zlev(Npoints,Nlevels), y%zlev_half(Npoints,Nlevels), y%dlev(Npoints,Nlevels), & + y%p(Npoints,Nlevels), y%ph(Npoints,Nlevels), y%T(Npoints,Nlevels), & + y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), & + y%dtau_s(Npoints,Nlevels), y%dtau_c(Npoints,Nlevels), & + y%dem_s(Npoints,Nlevels), y%dem_c(Npoints,Nlevels), & + y%tca(Npoints,Nlevels), y%cca(Npoints,Nlevels), & + y%rain_ls(Npoints,Nlevels), y%rain_cv(Npoints,Nlevels), y%grpl_ls(Npoints,Nlevels), & + y%snow_ls(Npoints,Nlevels), y%snow_cv(Npoints,Nlevels),y%mr_ozone(Npoints,Nlevels)) + + + ! Surface information and geolocation (Npoints) + allocate(y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), & + y%sunlit(Npoints),y%skt(Npoints),y%sfc_height(Npoints),y%u_wind(Npoints),y%v_wind(Npoints)) + ! Hydrometeors concentration and distribution parameters + allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), & + y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), & + y%Reff(Npoints,Nlevels,Nhydro)) + ! Aerosols concentration and distribution parameters + allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), & + y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero)) + + ! RTTOV channels and sfc. emissivity + allocate(y%ichan(Nchan),y%surfem(Nchan)) + + ! RTTOV parameters + y%ichan = ichan + y%surfem = surfem + + ! --- Initialise to zero --- + y%zlev = 0.0 + y%zlev_half = 0.0 + y%dlev = 0.0 + y%p = 0.0 + y%ph = 0.0 + y%T = 0.0 + y%q = 0.0 + y%sh = 0.0 + y%dtau_s = 0.0 + y%dtau_c = 0.0 + y%dem_s = 0.0 + y%dem_c = 0.0 + y%tca = 0.0 + y%cca = 0.0 + y%rain_ls = 0.0 + y%rain_cv = 0.0 + y%grpl_ls = 0.0 + y%snow_ls = 0.0 + y%snow_cv = 0.0 + y%Reff = 0.0 + y%mr_ozone = 0.0 + y%u_wind = 0.0 + y%v_wind = 0.0 + + + ! (Npoints) +! call zero_real(y%psfc, y%land) + y%longitude = 0.0 + y%latitude = 0.0 + y%psfc = 0.0 + y%land = 0.0 + y%sunlit = 0.0 + y%skt = 0.0 + y%sfc_height = 0.0 + ! (Npoints,Nlevels,Nhydro) +! y%fr_hydro = 0.0 + y%mr_hydro = 0.0 + ! Others + y%dist_prmts_hydro = 0.0 ! (Nprmts_max_hydro,Nhydro) + y%conc_aero = 0.0 ! (Npoints,Nlevels,Naero) + y%dist_type_aero = 0 ! (Naero) + y%dist_prmts_aero = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero) + + y%hp%p1 = 0.0 + y%hp%p2 = 0.0 + y%hp%p3 = 0.0 + y%hp%dmin = 0.0 + y%hp%dmax = 0.0 + y%hp%apm = 0.0 + y%hp%bpm = 0.0 + y%hp%rho = 0.0 + y%hp%dtype = 0 + y%hp%col = 0 + y%hp%cp = 0 + y%hp%phase = 0 + y%hp%scaled = .false. + y%hp%z_flag = .false. + y%hp%Ze_scaled = 0.0 + y%hp%Zr_scaled = 0.0 + y%hp%kr_scaled = 0.0 + y%hp%fc = 0.0 + y%hp%rho_eff = 0.0 + y%hp%ifc = 0 + y%hp%idd = 0 + y%mt%freq = 0.0 + y%mt%tt = 0.0 + y%mt%f = 0.0 + y%mt%D = 0.0 + y%mt%qext = 0.0 + y%mt%qbsca = 0.0 + y%mt%phase = 0 + + + ! --- Initialize the distributional parameters for hydrometeors + y%dist_prmts_hydro( 1,:) = HCLASS_TYPE(:) + y%dist_prmts_hydro( 2,:) = HCLASS_COL(:) + y%dist_prmts_hydro( 3,:) = HCLASS_PHASE(:) + y%dist_prmts_hydro( 4,:) = HCLASS_CP(:) + y%dist_prmts_hydro( 5,:) = HCLASS_DMIN(:) + y%dist_prmts_hydro( 6,:) = HCLASS_DMAX(:) + y%dist_prmts_hydro( 7,:) = HCLASS_APM(:) + y%dist_prmts_hydro( 8,:) = HCLASS_BPM(:) + y%dist_prmts_hydro( 9,:) = HCLASS_RHO(:) + y%dist_prmts_hydro(10,:) = HCLASS_P1(:) + y%dist_prmts_hydro(11,:) = HCLASS_P2(:) + y%dist_prmts_hydro(12,:) = HCLASS_P3(:) + + ! the following code added by roj to initialize structures used by radar simulator, Feb 2008 + call load_hydrometeor_classes(y%Nprmts_max_hydro,y%dist_prmts_hydro(:,:),y%hp,y%Nhydro) + + ! load mie tables ? + if (y%use_mie_tables == 1) then + + ! ----- Mie tables ---- + mie_table_name='mie_table.dat' + call load_mie_table(mie_table_name,y%mt) + + ! :: D specified by table ... not must match that used when mie LUT generated! + y%nsizes = mt_nd + allocate(y%D(y%nsizes)) + y%D = y%mt%D + + else + ! otherwise we still need to initialize temperature arrays for Ze scaling (which is only done when not using mie table) + + cnt_ice=19 + cnt_liq=20 + if (.not.(allocated(mt_ttl).and.allocated(mt_tti))) then + allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice)) ! note needed as this is global array ... + ! which should be changed in the future + endif + + do i=1,cnt_ice + mt_tti(i)=(i-1)*5-90 + enddo + + do i=1,cnt_liq + mt_ttl(i)=(i-1)*5 - 60 + enddo + + allocate(y%mt_ttl(cnt_liq),y%mt_tti(cnt_ice)) + + y%mt_ttl = mt_ttl + y%mt_tti = mt_tti + +! !------ OLD code in v0.1 --------------------------- +! allocate(mt_ttl(2),mt_tti(2)) +! allocate(y%mt_ttl(2),y%mt_tti(2)) +! mt_ttl = 0.0 +! mt_tti = 0.0 +! y%mt_ttl = mt_ttl +! y%mt_tti = mt_tti +! !--------------------------------------------------- + + ! :: D created on a log-linear scale + y%nsizes = nd + delt = (log(dmax)-log(dmin))/(y%nsizes-1) + deltp = exp(delt) + allocate(y%D(y%nsizes)) + y%D(1) = dmin + do i=2,y%nsizes + y%D(i) = y%D(i-1)*deltp + enddo + + endif + + +END SUBROUTINE CONSTRUCT_COSP_GRIDBOX + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_GRIDBOX ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal) + type(cosp_gridbox),intent(inout) :: y + logical,intent(in),optional :: dglobal + + ! --- Free arrays --- + deallocate(y%D,y%mt_ttl,y%mt_tti) ! added by roj Feb 2008 + if (.not.present(dglobal)) deallocate(mt_ttl,mt_tti) + +! deallocate(y%hp%p1,y%hp%p2,y%hp%p3,y%hp%dmin,y%hp%dmax,y%hp%apm,y%hp%bpm,y%hp%rho, & +! y%hp%dtype,y%hp%col,y%hp%cp,y%hp%phase,y%hp%scaled, & +! y%hp%z_flag,y%hp%Ze_scaled,y%hp%Zr_scaled,y%hp%kr_scaled, & +! y%hp%fc, y%hp%rho_eff, y%hp%ifc, y%hp%idd) +! deallocate(y%mt%freq, y%mt%tt, y%mt%f, y%mt%D, y%mt%qext, y%mt%qbsca, y%mt%phase) + + deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, & + y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, & + y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, & + y%mr_hydro, y%dist_prmts_hydro, & + y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, & + y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, & + y%sunlit, y%skt, y%sfc_height, y%Reff,y%ichan,y%surfem, & + y%mr_ozone,y%u_wind,y%v_wind) + + END SUBROUTINE FREE_COSP_GRIDBOX + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_GRIDBOX_CPHP ---------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_GRIDBOX_CPHP(x,y) + type(cosp_gridbox),intent(in) :: x + type(cosp_gridbox),intent(inout) :: y + + integer :: i,j,k,sz(3) + double precision :: tny + + tny = tiny(tny) + y%hp%p1 = x%hp%p1 + y%hp%p2 = x%hp%p2 + y%hp%p3 = x%hp%p3 + y%hp%dmin = x%hp%dmin + y%hp%dmax = x%hp%dmax + y%hp%apm = x%hp%apm + y%hp%bpm = x%hp%bpm + y%hp%rho = x%hp%rho + y%hp%dtype = x%hp%dtype + y%hp%col = x%hp%col + y%hp%cp = x%hp%cp + y%hp%phase = x%hp%phase + + y%hp%fc = x%hp%fc + y%hp%rho_eff = x%hp%rho_eff + y%hp%ifc = x%hp%ifc + y%hp%idd = x%hp%idd + sz = shape(x%hp%z_flag) + do k=1,sz(3) + do j=1,sz(2) + do i=1,sz(1) + if (x%hp%scaled(i,k)) y%hp%scaled(i,k) = .true. + if (x%hp%z_flag(i,j,k)) y%hp%z_flag(i,j,k) = .true. + if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k) + if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k) + if (abs(x%hp%kr_scaled(i,j,k)) > tny) y%hp%kr_scaled(i,j,k) = x%hp%kr_scaled(i,j,k) + enddo + enddo + enddo + +END SUBROUTINE COSP_GRIDBOX_CPHP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_GRIDBOX_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_GRIDBOX_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_gridbox),intent(in) :: x + type(cosp_gridbox),intent(inout) :: y + + integer :: i,j,k,sz(3) + + ! --- Copy arrays without Npoints as dimension --- + y%dist_prmts_hydro = x%dist_prmts_hydro + y%dist_type_aero = x%dist_type_aero + y%D = x%D + y%mt_ttl = x%mt_ttl + y%mt_tti = x%mt_tti + + +! call cosp_gridbox_cphp(x,y) + + ! 1D + y%longitude(iy(1):iy(2)) = x%longitude(ix(1):ix(2)) + y%latitude(iy(1):iy(2)) = x%latitude(ix(1):ix(2)) + y%psfc(iy(1):iy(2)) = x%psfc(ix(1):ix(2)) + y%land(iy(1):iy(2)) = x%land(ix(1):ix(2)) + y%sunlit(iy(1):iy(2)) = x%sunlit(ix(1):ix(2)) + y%skt(iy(1):iy(2)) = x%skt(ix(1):ix(2)) + y%sfc_height(iy(1):iy(2)) = x%sfc_height(ix(1):ix(2)) + y%u_wind(iy(1):iy(2)) = x%u_wind(ix(1):ix(2)) + y%v_wind(iy(1):iy(2)) = x%v_wind(ix(1):ix(2)) + ! 2D + y%zlev(iy(1):iy(2),:) = x%zlev(ix(1):ix(2),:) + y%zlev_half(iy(1):iy(2),:) = x%zlev_half(ix(1):ix(2),:) + y%dlev(iy(1):iy(2),:) = x%dlev(ix(1):ix(2),:) + y%p(iy(1):iy(2),:) = x%p(ix(1):ix(2),:) + y%ph(iy(1):iy(2),:) = x%ph(ix(1):ix(2),:) + y%T(iy(1):iy(2),:) = x%T(ix(1):ix(2),:) + y%q(iy(1):iy(2),:) = x%q(ix(1):ix(2),:) + y%sh(iy(1):iy(2),:) = x%sh(ix(1):ix(2),:) + y%dtau_s(iy(1):iy(2),:) = x%dtau_s(ix(1):ix(2),:) + y%dtau_c(iy(1):iy(2),:) = x%dtau_c(ix(1):ix(2),:) + y%dem_s(iy(1):iy(2),:) = x%dem_s(ix(1):ix(2),:) + y%dem_c(iy(1):iy(2),:) = x%dem_c(ix(1):ix(2),:) + y%tca(iy(1):iy(2),:) = x%tca(ix(1):ix(2),:) + y%cca(iy(1):iy(2),:) = x%cca(ix(1):ix(2),:) + y%rain_ls(iy(1):iy(2),:) = x%rain_ls(ix(1):ix(2),:) + y%rain_cv(iy(1):iy(2),:) = x%rain_cv(ix(1):ix(2),:) + y%grpl_ls(iy(1):iy(2),:) = x%grpl_ls(ix(1):ix(2),:) + y%snow_ls(iy(1):iy(2),:) = x%snow_ls(ix(1):ix(2),:) + y%snow_cv(iy(1):iy(2),:) = x%snow_cv(ix(1):ix(2),:) + y%mr_ozone(iy(1):iy(2),:) = x%mr_ozone(ix(1):ix(2),:) + ! 3D + y%Reff(iy(1):iy(2),:,:) = x%Reff(ix(1):ix(2),:,:) + y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:) + y%mr_hydro(iy(1):iy(2),:,:) = x%mr_hydro(ix(1):ix(2),:,:) + ! 4D + y%dist_prmts_aero(iy(1):iy(2),:,:,:) = x%dist_prmts_aero(ix(1):ix(2),:,:,:) + +END SUBROUTINE COSP_GRIDBOX_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SUBGRID_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SUBGRID_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_subgrid),intent(in) :: x + type(cosp_subgrid),intent(inout) :: y + + y%prec_frac(iy(1):iy(2),:,:) = x%prec_frac(ix(1):ix(2),:,:) + y%frac_out(iy(1):iy(2),:,:) = x%frac_out(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SUBGRID_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SGRADAR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SGRADAR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_sgradar),intent(in) :: x + type(cosp_sgradar),intent(inout) :: y + + y%att_gas(iy(1):iy(2),:) = x%att_gas(ix(1):ix(2),:) + y%Ze_tot(iy(1):iy(2),:,:) = x%Ze_tot(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SGRADAR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SGLIDAR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SGLIDAR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_sglidar),intent(in) :: x + type(cosp_sglidar),intent(inout) :: y + + y%beta_mol(iy(1):iy(2),:) = x%beta_mol(ix(1):ix(2),:) + y%beta_tot(iy(1):iy(2),:,:) = x%beta_tot(ix(1):ix(2),:,:) + y%tau_tot(iy(1):iy(2),:,:) = x%tau_tot(ix(1):ix(2),:,:) + y%refl(iy(1):iy(2),:,:) = x%refl(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SGLIDAR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_ISCCP_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ISCCP_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_isccp),intent(in) :: x + type(cosp_isccp),intent(inout) :: y + + y%fq_isccp(iy(1):iy(2),:,:) = x%fq_isccp(ix(1):ix(2),:,:) + y%totalcldarea(iy(1):iy(2)) = x%totalcldarea(ix(1):ix(2)) + y%meantb(iy(1):iy(2)) = x%meantb(ix(1):ix(2)) + y%meantbclr(iy(1):iy(2)) = x%meantbclr(ix(1):ix(2)) + y%meanptop(iy(1):iy(2)) = x%meanptop(ix(1):ix(2)) + y%meantaucld(iy(1):iy(2)) = x%meantaucld(ix(1):ix(2)) + y%meanalbedocld(iy(1):iy(2)) = x%meanalbedocld(ix(1):ix(2)) + y%boxtau(iy(1):iy(2),:) = x%boxtau(ix(1):ix(2),:) + y%boxptop(iy(1):iy(2),:) = x%boxptop(ix(1):ix(2),:) +END SUBROUTINE COSP_ISCCP_CPSECTION + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_MISR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_MISR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_misr),intent(in) :: x + type(cosp_misr),intent(inout) :: y + + y%fq_MISR(iy(1):iy(2),:,:) = x%fq_MISR(ix(1):ix(2),:,:) + y%MISR_meanztop(iy(1):iy(2)) = x%MISR_meanztop(ix(1):ix(2)) + y%MISR_cldarea(iy(1):iy(2)) = x%MISR_cldarea(ix(1):ix(2)) + y%MISR_dist_model_layertops(iy(1):iy(2),:) = x%MISR_dist_model_layertops(ix(1):ix(2),:) +END SUBROUTINE COSP_MISR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_RTTOV_CPSECTION ------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RTTOV_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_rttov),intent(in) :: x + type(cosp_rttov),intent(inout) :: y + + y%tbs(iy(1):iy(2),:) = x%tbs(ix(1):ix(2),:) +END SUBROUTINE COSP_RTTOV_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_RADARSTATS_CPSECTION -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RADARSTATS_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_radarstats),intent(in) :: x + type(cosp_radarstats),intent(inout) :: y + + y%cfad_ze(iy(1):iy(2),:,:) = x%cfad_ze(ix(1):ix(2),:,:) + y%radar_lidar_tcc(iy(1):iy(2)) = x%radar_lidar_tcc(ix(1):ix(2)) + y%lidar_only_freq_cloud(iy(1):iy(2),:) = x%lidar_only_freq_cloud(ix(1):ix(2),:) +END SUBROUTINE COSP_RADARSTATS_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_LIDARSTATS_CPSECTION -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDARSTATS_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_lidarstats),intent(in) :: x + type(cosp_lidarstats),intent(inout) :: y + + y%srbval = x%srbval + y%cfad_sr(iy(1):iy(2),:,:) = x%cfad_sr(ix(1):ix(2),:,:) + y%lidarcld(iy(1):iy(2),:) = x%lidarcld(ix(1):ix(2),:) + y%cldlayer(iy(1):iy(2),:) = x%cldlayer(ix(1):ix(2),:) + y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:) +END SUBROUTINE COSP_LIDARSTATS_CPSECTION + +END MODULE MOD_COSP_TYPES Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_utils.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_utils.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/cosp_utils.F90 (revision 1634) @@ -0,0 +1,336 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! + +MODULE MOD_COSP_UTILS + USE MOD_COSP_CONSTANTS + IMPLICIT NONE + + INTERFACE Z_TO_DBZ + MODULE PROCEDURE Z_TO_DBZ_2D,Z_TO_DBZ_3D,Z_TO_DBZ_4D + END INTERFACE + + INTERFACE COSP_CHECK_INPUT + MODULE PROCEDURE COSP_CHECK_INPUT_1D,COSP_CHECK_INPUT_2D,COSP_CHECK_INPUT_3D + END INTERFACE +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_PRECIP_MXRATIO -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, & + n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2, & + flux,mxratio) + + ! Input arguments, (IN) + integer,intent(in) :: Npoints,Nlevels,Ncolumns + real,intent(in),dimension(Npoints,Nlevels) :: p,T,flux + real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac + real,intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,prec_type + ! Input arguments, (OUT) + real,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio + ! Local variables + integer :: i,j,k + real :: sigma,one_over_xip1,xi,rho0,rho + + mxratio = 0.0 + + if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed + !gamma1 = gamma(alpha_x + b_x + d_x + 1.0) + !gamma2 = gamma(alpha_x + b_x + 1.0) + xi = d_x/(alpha_x + b_x - n_bx + 1.0) + rho0 = 1.29 + sigma = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi + one_over_xip1 = 1.0/(xi + 1.0) + + do k=1,Nlevels + do j=1,Ncolumns + do i=1,Npoints + if ((prec_frac(i,j,k)==prec_type).or.(prec_frac(i,j,k)==3.)) then + rho = p(i,k)/(287.05*T(i,k)) + mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1 + mxratio(i,j,k)=mxratio(i,j,k)/rho + endif + enddo + enddo + enddo + endif +END SUBROUTINE COSP_PRECIP_MXRATIO + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE ZERO_INT ------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ELEMENTAL SUBROUTINE ZERO_INT(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) + + integer,intent(inout) :: x + integer,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 + x = 0 + if (present(y01)) y01 = 0 + if (present(y02)) y02 = 0 + if (present(y03)) y03 = 0 + if (present(y04)) y04 = 0 + if (present(y05)) y05 = 0 + if (present(y06)) y06 = 0 + if (present(y07)) y07 = 0 + if (present(y08)) y08 = 0 + if (present(y09)) y09 = 0 + if (present(y10)) y10 = 0 + if (present(y11)) y11 = 0 + if (present(y12)) y12 = 0 + if (present(y13)) y13 = 0 + if (present(y14)) y14 = 0 + if (present(y15)) y15 = 0 + if (present(y16)) y16 = 0 + if (present(y17)) y17 = 0 + if (present(y18)) y18 = 0 + if (present(y19)) y19 = 0 + if (present(y20)) y20 = 0 + if (present(y21)) y21 = 0 + if (present(y22)) y22 = 0 + if (present(y23)) y23 = 0 + if (present(y24)) y24 = 0 + if (present(y25)) y25 = 0 + if (present(y26)) y26 = 0 + if (present(y27)) y27 = 0 + if (present(y28)) y28 = 0 + if (present(y29)) y29 = 0 + if (present(y30)) y30 = 0 +END SUBROUTINE ZERO_INT + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE ZERO_REAL ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ELEMENTAL SUBROUTINE ZERO_REAL(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) + + real,intent(inout) :: x + real,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 + x = 0.0 + if (present(y01)) y01 = 0.0 + if (present(y02)) y02 = 0.0 + if (present(y03)) y03 = 0.0 + if (present(y04)) y04 = 0.0 + if (present(y05)) y05 = 0.0 + if (present(y06)) y06 = 0.0 + if (present(y07)) y07 = 0.0 + if (present(y08)) y08 = 0.0 + if (present(y09)) y09 = 0.0 + if (present(y10)) y10 = 0.0 + if (present(y11)) y11 = 0.0 + if (present(y12)) y12 = 0.0 + if (present(y13)) y13 = 0.0 + if (present(y14)) y14 = 0.0 + if (present(y15)) y15 = 0.0 + if (present(y16)) y16 = 0.0 + if (present(y17)) y17 = 0.0 + if (present(y18)) y18 = 0.0 + if (present(y19)) y19 = 0.0 + if (present(y20)) y20 = 0.0 + if (present(y21)) y21 = 0.0 + if (present(y22)) y22 = 0.0 + if (present(y23)) y23 = 0.0 + if (present(y24)) y24 = 0.0 + if (present(y25)) y25 = 0.0 + if (present(y26)) y26 = 0.0 + if (present(y27)) y27 = 0.0 + if (present(y28)) y28 = 0.0 + if (present(y29)) y29 = 0.0 + if (present(y30)) y30 = 0.0 +END SUBROUTINE ZERO_REAL + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_2D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_2D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_2D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_3D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_3D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_3D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_4D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_4D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:,:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_4D + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_1D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_1D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_1D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_1D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_2D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_2D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:,:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_2D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_2D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_3D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_3D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:,:,:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_3D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_3D + + +END MODULE MOD_COSP_UTILS Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/dsd.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/dsd.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/dsd.F90 (revision 1634) @@ -0,0 +1,359 @@ + subroutine dsd(Q,Re,D,N,nsizes,dtype,rho_a,tc, & + dmin,dmax,apm,bpm,rho_c,p1,p2,p3,fc,scaled) + use array_lib + use math_lib + implicit none + +! Purpose: +! Create a discrete drop size distribution +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [Q] hydrometeor mixing ratio (g/kg) +! [Re] Optional Effective Radius (microns). 0 = use default. +! [D] discrete drop sizes (um) +! [nsizes] number of elements of [D] +! [dtype] distribution type +! [rho_a] ambient air density (kg m^-3) +! [tc] temperature (C) +! [dmin] minimum size cutoff (um) +! [dmax] maximum size cutoff (um) +! [rho_c] alternate constant density (kg m^-3) +! [p1],[p2],[p3] distribution parameters +! +! Input/Output: +! [fc] scaling factor for the distribution +! [scaled] has this hydrometeor type been scaled? +! [apm] a parameter for mass (kg m^[-bpm]) +! [bmp] b params for mass +! +! Outputs: +! [N] discrete concentrations (cm^-3 um^-1) +! or, for monodisperse, a constant (1/cm^3) +! +! Requires: +! function infind +! +! Created: +! 11/28/05 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 01/31/06 Port from IDL to Fortran 90 +! 07/07/06 Rewritten for variable DSD's +! 10/02/06 Rewritten using scaling factors (Roger Marchand and JMH) + +! ----- INPUTS ----- + + integer*4, intent(in) :: nsizes + integer, intent(in) :: dtype + real*8, intent(in) :: Q,D(nsizes),rho_a,tc,dmin,dmax, & + rho_c,p1,p2,p3 + +! ----- INPUT/OUTPUT ----- + + real*8, intent(inout) :: fc(nsizes),apm,bpm,Re + logical, intent(inout) :: scaled + +! ----- OUTPUTS ----- + + real*8, intent(out) :: N(nsizes) + +! ----- INTERNAL ----- + + real*8 :: & + N0,D0,vu,np,dm,ld, & ! gamma, exponential variables + dmin_mm,dmax_mm,ahp,bhp, & ! power law variables + rg,log_sigma_g, & ! lognormal variables + rho_e ! particle density (kg m^-3) + + real*8 :: tmp1, tmp2 + real*8 :: pi,rc + + integer k,lidx,uidx + + pi = acos(-1.0) + +! // if density is constant, store equivalent values for apm and bpm + if ((rho_c > 0) .and. (apm < 0)) then + apm = (pi/6)*rho_c + bpm = 3. + endif + + select case(dtype) + +! ---------------------------------------------------------! +! // modified gamma ! +! ---------------------------------------------------------! +! :: N0 = total number concentration (m^-3) +! :: np = fixed number concentration (kg^-1) +! :: D0 = characteristic diameter (um) +! :: dm = mean diameter (um) +! :: vu = distribution width parameter + + case(1) + if (abs(p1+1) < 1E-8) then + +! // D0, vu are given + vu = p3 + + if(Re.le.0) then + dm = p2 + D0 = gamma(vu)/gamma(vu+1)*dm + else + D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3) + endif + + if (scaled .eqv. .false.) then + + fc = ( & + ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / & + (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) & + ) * 1E-12 + scaled = .true. + + endif + + N = fc*rho_a*(Q*1E-3) + + elseif (abs(p2+1) < 1E-8) then + +! // N0, vu are given + np = p1 + vu = p3 + tmp1 = (Q*1E-3)**(1./bpm) + + if (scaled .eqv. .false.) then + + fc = (D*1E-6 / (gamma(vu)/(apm*np*gamma(vu+bpm)))** & + (1./bpm))**vu + + scaled = .true. + + endif + + N = ( & + (rho_a*np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * & + exp(-1.*fc**(1./vu)/tmp1) & + ) * 1E-12 + + else + +! // vu isn't given + print *, 'Error: Must specify a value for vu' + stop + + endif + +! ---------------------------------------------------------! +! // exponential ! +! ---------------------------------------------------------! +! :: N0 = intercept parameter (m^-4) +! :: ld = slope parameter (um) + + case(2) + if (abs(p1+1) > 1E-8) then + +! // N0 has been specified, determine ld + N0 = p1 + + if(Re>0) then + + ! if Re is set and No is set than the distribution is fully defined. + ! so we assume Re and No have already been chosen consistant with + ! the water content, Q. + + ! print *,'using Re pass ...' + + ld = 1.5/Re ! units 1/um + + N = ( & + N0*exp(-1*ld*D) & + ) * 1E-12 + + else + + tmp1 = 1./(1.+bpm) + + if (scaled .eqv. .false.) then + fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6) + scaled = .true. + + endif + + N = ( & + N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) & + ) * 1E-12 + + endif + + elseif (abs(p2+1) > 1E-8) then + +! // ld has been specified, determine N0 + ld = p2 + + if (scaled .eqv. .false.) then + + fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* & + exp(-1.*(ld*1E6)*(D*1E-6))*1E-12 + scaled = .true. + + endif + + N = fc*rho_a*(Q*1E-3) + + else + +! // ld will be determined from temperature, then N0 follows + ld = 1220*10.**(-0.0245*tc)*1E-6 + N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm)) + + N = ( & + N0*exp(-1*ld*D) & + ) * 1E-12 + + endif + +! ---------------------------------------------------------! +! // power law ! +! ---------------------------------------------------------! +! :: ahp = Ar parameter (m^-4 mm^-bhp) +! :: bhp = br parameter +! :: dmin_mm = lower bound (mm) +! :: dmax_mm = upper bound (mm) + + case(3) + +! :: br parameter + if (abs(p1+2) < 1E-8) then +! :: if p1=-2, bhp is parameterized according to Ryan (2000), +! :: applicatable to cirrus clouds + if (tc < -30) then + bhp = -1.75+0.09*((tc+273)-243.16) + elseif ((tc >= -30) .and. (tc < -9)) then + bhp = -3.25-0.06*((tc+273)-265.66) + else + bhp = -2.15 + endif + elseif (abs(p1+3) < 1E-8) then +! :: if p1=-3, bhp is parameterized according to Ryan (2000), +! :: applicable to frontal clouds + if (tc < -35) then + bhp = -1.75+0.09*((tc+273)-243.16) + elseif ((tc >= -35) .and. (tc < -17.5)) then + bhp = -2.65+0.09*((tc+273)-255.66) + elseif ((tc >= -17.5) .and. (tc < -9)) then + bhp = -3.25-0.06*((tc+273)-265.66) + else + bhp = -2.15 + endif + else +! :: otherwise the specified value is used + bhp = p1 + endif + +! :: Ar parameter + dmin_mm = dmin*1E-3 + dmax_mm = dmax*1E-3 + +! :: commented lines are original method with constant density + ! rc = 500. ! (kg/m^3) + ! tmp1 = 6*rho_a*(bhp+4) + ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4)) + ! ahp = (Q*1E-3)*1E12*tmp1/tmp2 + +! :: new method is more consistent with the rest of the distributions +! :: and allows density to vary with particle size + tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1) + tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1)) + ahp = tmp1/tmp2 * 1E24 + ! ahp = tmp1/tmp2 + + lidx = infind(D,dmin) + uidx = infind(D,dmax) + do k=lidx,uidx + + N(k) = ( & + ahp*(D(k)*1E-3)**bhp & + ) * 1E-12 + + enddo + + ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm + +! ---------------------------------------------------------! +! // monodisperse ! +! ---------------------------------------------------------! +! :: D0 = particle diameter (um) + + case(4) + + if (scaled .eqv. .false.) then + + D0 = p1 + rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3) + fc(1) = (6./(pi*D0**3*rho_e))*1E12 + scaled = .true. + + endif + + N(1) = fc(1)*rho_a*(Q*1E-3) + +! ---------------------------------------------------------! +! // lognormal ! +! ---------------------------------------------------------! +! :: N0 = total number concentration (m^-3) +! :: np = fixed number concentration (kg^-1) +! :: rg = mean radius (um) +! :: log_sigma_g = ln(geometric standard deviation) + + case(5) + if (abs(p1+1) < 1E-8) then + +! // rg, log_sigma_g are given + log_sigma_g = p3 + tmp2 = (bpm*log_sigma_g)**2. + if(Re.le.0) then + rg = p2 + else + rg =Re*exp(-2.5*(log_sigma_g**2)) + endif + + if (scaled .eqv. .false.) then + + fc = 0.5 * ( & + (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * & + log_sigma_g*D*0.5*1E-6)) * & + exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) & + ) * 1E-12 + scaled = .true. + + endif + + N = fc*rho_a*(Q*1E-3) + + elseif (abs(p2+1) < 1E-8) then + +! // N0, log_sigma_g are given + Np = p1 + log_sigma_g = p3 + N0 = np*rho_a + tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0) + tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2. + rg = ((tmp1/tmp2)**(1/bpm))*1E6 + + N = 0.5*( & + N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * & + exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) & + ) * 1E-12 + + else + +! // vu isn't given + print *, 'Error: Must specify a value for sigma_g' + stop + + endif + + end select + + end subroutine dsd Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/format_input.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/format_input.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/format_input.F90 (revision 1634) @@ -0,0 +1,132 @@ +! FORMAT_INPUT: Procedures to prepare data for input to the simulator +! Compiled/Modified: +! 08/28/2006 John Haynes (haynes@atmos.colostate.edu) +! +! irreg_to_grid (subroutine) +! order_data (subroutine) + + module format_input + + contains + +! ---------------------------------------------------------------------------- +! SUBROUTINE IRREG_TO_GRID +! ---------------------------------------------------------------------------- + subroutine irreg_to_grid(hgt_matrix,t_matrix,p_matrix,rh_matrix, & + env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix) + use array_lib + implicit none + +! Purpose: +! Linearly interpolate sounding-level data to the hydrometeor-level +! resolution +! +! Inputs: +! [hgt_matrix] hydrometeor-level heights +! [env_hgt_matrix] sounding-level heights +! [env_t_matrix] sounding-level temperatures +! [env_p_matrix] sounding-level pressures +! [env_rh_matrix] sounding-level relative humidities +! +! Outputs: +! [t_matrix] hydrometeor-level temperatures +! [p_matrix] hydrometeor-level pressures +! [rh_matrix] hydrometeor-level relative humidities +! +! Created: +! 08/28/2006 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, dimension(:,:), intent(in) :: & + hgt_matrix,env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix + +! ----- OUTPUTS ----- + real*8, dimension(:,:), intent(out) :: & + t_matrix,p_matrix,rh_matrix + +! ----- INTERNAL ----- + integer :: nprof, i + integer,parameter :: KR8 = selected_real_kind(15,300) + + nprof = size(hgt_matrix,1) + do i=1,nprof + call lin_interpolate(env_t_matrix(i,:),env_hgt_matrix(i,:), & + t_matrix(i,:),hgt_matrix(i,:),1000._KR8) + call lin_interpolate(env_p_matrix(i,:),env_hgt_matrix(i,:), & + p_matrix(i,:),hgt_matrix(i,:),1000._KR8) + call lin_interpolate(env_rh_matrix(i,:),env_hgt_matrix(i,:), & + rh_matrix(i,:),hgt_matrix(i,:),1000._KR8) + enddo + + end subroutine irreg_to_grid + +! ---------------------------------------------------------------------------- +! SUBROUTINE ORDER_DATA +! ---------------------------------------------------------------------------- + subroutine order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, & + rh_matrix,sfc_radar,hgt_reversed) + implicit none + +! Purpose: +! Ensure that input data is in top-down order/bottom-up order, +! for space-based/surface based radars, respectively +! +! Inputs: +! [hgt_matrix] heights +! [hm_matrix] mixing ratios +! [t_matrix] temperatures +! [p_matrix] pressures +! [rh_matrix] relative humidities +! [sfc_radar] 1=surface radar, 0=spaceborne +! +! Outputs: +! [hgt_matrix],[hm_matrix],[p_matrix,[t_matrix],[rh_matrix] in proper +! order for input to the radar simulator routine +! [hgt_reversed] T=heights were reordered,F=heights were not reordered +! +! Note: +! The order for all profiles is assumed to the same as the first profile. +! +! Created: +! 08/28/2006 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + integer, intent(in) :: sfc_radar + +! ----- OUTPUTS ----- + real*8, dimension(:,:), intent(inout) :: & + hgt_matrix,p_matrix,t_matrix,rh_matrix + real*8, dimension(:,:,:), intent(inout) :: & + hm_matrix + logical, intent(out) :: hgt_reversed + +! ----- INTERNAL ----- + integer :: ngate + logical :: hgt_descending + + + ngate = size(hgt_matrix,2) + hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate) + +! :: surface: heights must be ascending +! :: space-based: heights must be descending + if ( & + (sfc_radar == 1 .and. hgt_descending) .or. & + (sfc_radar == 0 .and. (.not. hgt_descending)) & + ) & + then + + hgt_matrix(:,:) = hgt_matrix(:,ngate:1:-1) + hm_matrix(:,:,:) = hm_matrix(:,:,ngate:1:-1) + p_matrix(:,:) = p_matrix(:,ngate:1:-1) + t_matrix(:,:) = t_matrix(:,ngate:1:-1) + rh_matrix(:,:) = rh_matrix(:,ngate:1:-1) + + hgt_reversed = .true. + else + hgt_reversed = .false. + endif + + end subroutine order_data + + end module format_input Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/gases.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/gases.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/gases.F90 (revision 1634) @@ -0,0 +1,182 @@ + function gases(PRES_mb,T,RH,f) + implicit none + +! Purpose: +! Compute 2-way gaseous attenuation through a volume in microwave +! +! Inputs: +! [PRES_mb] pressure (mb) (hPa) +! [T] temperature (K) +! [RH] relative humidity (%) +! [f] frequency (GHz), < 300 GHz +! +! Returns: +! 2-way gaseous attenuation (dB/km) +! +! Reference: +! Uses method of Liebe (1985) +! +! Created: +! 12/09/05 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 01/31/06 Port from IDL to Fortran 90 + + integer, parameter :: & + nbands_o2 = 48 ,& + nbands_h2o = 30 + real*8, intent(in) :: PRES_mb, T, RH, f + real*8 :: gases, th, e, p, sumo, gm0, a0, ap, term1, term2, term3, & + bf, be, term4, npp + real*8, dimension(nbands_o2) :: v0, a1, a2, a3, a4, a5, a6 + real*8, dimension(nbands_h2o) :: v1, b1, b2, b3 + integer :: i + +! // table1 parameters v0, a1, a2, a3, a4, a5, a6 + data v0/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500, & + 52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570, & + 55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810, & + 58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750, & + 61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150, & + 64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270, & + 67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420, & + 118.7503410,368.4983500,424.7631200,487.2493700,715.3931500, & + 773.8387300, 834.1453300/ + data a1/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141, & + 0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535, & + 0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240, & + 0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152, & + 0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801, & + 0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002, & + 0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/ + data a2/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000, & + 6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000, & + 0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000, & + 0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000, & + 1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000, & + 6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000, & + 0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/ + data a3/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000, & + 0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000, & + 0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900, & + 0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800, & + 0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000, & + 0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000, & + 0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/ + data a4/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/ + data a5/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000, & + 0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500, & + 0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400, & + 0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600, & + -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000, & + -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000, & + -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000/ + data a6/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000,& + 1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000, & + 0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, & + 0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, & + 2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000, & + 1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000, & + 0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/ + +! // table2 parameters v1, b1, b2, b3 + data v1/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440, & + 325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, & + 443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, & + 504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, & + 859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, & + 987.9267640/ + data b1/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000, & + 0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, & + 0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, & + 0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, & + 8.5600000,9.1600000,138.0000000/ + data b2/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000, & + 9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000, & + 3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000, & + 7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000, & + 1.3690000,1.8420000,0.1780000/ + data b3/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000, & + 0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000, & + 0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000, & + 0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000, & + 0.0253000,0.0240000,0.0286000/ + +! // conversions + th = 300./T ! unitless + e = (RH*th**5)/(41.45*10**(9.834*th-10)) ! kPa + p = PRES_mb/10.-e ! kPa + +! // term1 + sumo = 0. + do i=1,nbands_o2 + sumo = sumo + fpp_o2(p,th,e,a3(i),a4(i),a5(i),a6(i),f,v0(i)) & + * s_o2(p,th,a1(i),a2(i)) + enddo + term1 = sumo + +! // term2 + gm0 = 5.6E-3*(p+1.1*e)*th**(0.8) + a0 = 3.07E-4 + ap = 1.4*(1-1.2*f**(1.5)*1E-5)*1E-10 + term2 = (2*a0*(gm0*(1+(f/gm0)**2)*(1+(f/60.)**2))**(-1) + ap*p*th**(2.5)) & + * f*p*th**2 + +! // term3 + sumo = 0. + do i=1,nbands_h2o + sumo = sumo + fpp_h2o(p,th,e,b3(i),f,v1(i)) & + * s_h2o(th,e,b1(i),b2(i)) + enddo + term3 = sumo + +! // term4 + bf = 1.4E-6 + be = 5.41E-5 + term4 = (bf*p+be*e*th**3)*f*e*th**(2.5) + +! // summation and result + npp = term1 + term2 + term3 + term4 + gases = 0.182*f*npp + +! ----- SUB FUNCTIONS ----- + + contains + + function fpp_o2(p,th,e,a3,a4,a5,a6,f,v0) + real*8 :: fpp_o2,p,th,e,a3,a4,a5,a6,f,v0 + real*8 :: gm, delt, x, y + gm = a3*(p*th**(0.8-a4)+1.1*e*th) + delt = a5*p*th**(a6) + x = (v0-f)**2+gm**2 + y = (v0+f)**2+gm**2 + fpp_o2 = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x))) + end function fpp_o2 + + function fpp_h2o(p,th,e,b3,f,v0) + real*8 :: fpp_h2o,p,th,e,b3,f,v0 + real*8 :: gm, delt, x, y + gm = b3*(p*th**(0.8)+4.8*e*th) + delt = 0. + x = (v0-f)**2+gm**2 + y = (v0+f)**2+gm**2 + fpp_h2o = ((1./x)+(1./y))*(gm*f/v0) - (delt*f/v0)*(((v0-f)/(x))-((v0+f)/(x))) + end function fpp_h2o + + function s_o2(p,th,a1,a2) + real*8 :: s_o2,p,th,a1,a2 + s_o2 = a1*p*th**(3)*exp(a2*(1-th)) + end function s_o2 + + function s_h2o(th,e,b1,b2) + real*8 :: s_h2o,th,e,b1,b2 + s_h2o = b1*e*th**(3.5)*exp(b2*(1-th)) + end function s_h2o + + end function gases Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/icarus.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/icarus.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/icarus.F (revision 1634) @@ -0,0 +1,1268 @@ + SUBROUTINE ICARUS( + & debug, + & debugcol, + & npoints, + & sunlit, + & nlev, + & ncol, + & pfull, + & phalf, + & qv, + & cc, + & conv, + & dtau_s, + & dtau_c, + & top_height, + & top_height_direction, + & overlap, + & frac_out, + & skt, + & emsfc_lw, + & at, + & dem_s, + & dem_c, + & fq_isccp, + & totalcldarea, + & meanptop, + & meantaucld, + & meanalbedocld, + & meantb, + & meantbclr, + & boxtau, + & boxptop + &) + +!$Id: icarus.f,v 4.1 2010/05/27 16:30:18 hadmw Exp $ + +! *****************************COPYRIGHT**************************** +! (c) 2009, Lawrence Livermore National Security Limited Liability +! Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the +! following conditions are met: +! +! * Redistributions of source code must retain the above +! copyright notice, this list of conditions and the following +! disclaimer. +! * Redistributions in binary form must reproduce the above +! copyright notice, this list of conditions and the following +! disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security +! Limited Liability Corporation nor the names of its +! contributors may be used to endorse or promote products +! derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* + + implicit none + +! NOTE: the maximum number of levels and columns is set by +! the following parameter statement + + INTEGER ncolprint + +! ----- +! Input +! ----- + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER sunlit(npoints) ! 1 for day points, 0 for night time + + REAL pfull(npoints,nlev) + ! pressure of full model levels (Pascals) + ! pfull(npoints,1) is top level of model + ! pfull(npoints,nlev) is bot of model + + REAL phalf(npoints,nlev+1) + ! pressure of half model levels (Pascals) + ! phalf(npoints,1) is top of model + ! phalf(npoints,nlev+1) is the surface pressure + + REAL qv(npoints,nlev) + ! water vapor specific humidity (kg vapor/ kg air) + ! on full model levels + + REAL cc(npoints,nlev) + ! input cloud cover in each model level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by clouds + + REAL conv(npoints,nlev) + ! input convective cloud cover in each model + ! level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by convective clouds + + REAL dtau_s(npoints,nlev) + ! mean 0.67 micron optical depth of stratiform + ! clouds in each model level + ! NOTE: this the cloud optical depth of only the + ! cloudy part of the grid box, it is not weighted + ! with the 0 cloud optical depth of the clear + ! part of the grid box + + REAL dtau_c(npoints,nlev) + ! mean 0.67 micron optical depth of convective + ! clouds in each + ! model level. Same note applies as in dtau_s. + + INTEGER overlap ! overlap type + ! 1=max + ! 2=rand + ! 3=max/rand + + INTEGER top_height ! 1 = adjust top height using both a computed + ! infrared brightness temperature and the visible + ! optical depth to adjust cloud top pressure. Note + ! that this calculation is most appropriate to compare + ! to ISCCP data during sunlit hours. + ! 2 = do not adjust top height, that is cloud top + ! pressure is the actual cloud top pressure + ! in the model + ! 3 = adjust top height using only the computed + ! infrared brightness temperature. Note that this + ! calculation is most appropriate to compare to ISCCP + ! IR only algortihm (i.e. you can compare to nighttime + ! ISCCP data with this option) + + INTEGER top_height_direction ! direction for finding atmosphere pressure level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! + ! 1 = find the *lowest* altitude (highest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! + ! 2 = find the *highest* altitude (lowest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! ! + ! 1 = old setting: matches all versions of + ! ISCCP simulator with versions numbers 3.5.1 and lower + ! + ! 2 = default setting: for version numbers 4.0 and higher +! +! The following input variables are used only if top_height = 1 or top_height = 3 +! + REAL skt(npoints) ! skin Temperature (K) + REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL at(npoints,nlev) ! temperature in each model level (K) + REAL dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform + ! clouds in each + ! model level. Same note applies as in dtau_s. + REAL dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective + ! clouds in each + ! model level. Same note applies as in dtau_s. + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into + ! Equivalent of BOX in original version, but + ! indexed by column then row, rather than + ! by row then column + + + +! ------ +! Output +! ------ + + REAL fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by + ! each of the 49 ISCCP D level cloud types + + REAL totalcldarea(npoints) ! the fraction of model grid box columns + ! with cloud somewhere in them. NOTE: This diagnostic + ! does not count model clouds with tau < isccp_taumin + ! Thus this diagnostic does not equal the sum over all entries of fq_isccp. + ! However, this diagnostic does equal the sum over entries of fq_isccp with + ! itau = 2:7 (omitting itau = 1) + + + ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. + ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero. + + REAL meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging + ! in cloud top pressure. + + REAL meantaucld(npoints) ! mean optical thickness + ! linear averaging in albedo performed. + + real meanalbedocld(npoints) ! mean cloud albedo + ! linear averaging in albedo performed + + real meantb(npoints) ! mean all-sky 10.5 micron brightness temperature + + real meantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature + + REAL boxtau(npoints,ncol) ! optical thickness in each column + + REAL boxptop(npoints,ncol) ! cloud top pressure (mb) in each column + + +! +! ------ +! Working variables added when program updated to mimic Mark Webb's PV-Wave code +! ------ + + REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave + ! emissivity in part of + ! gridbox under consideration + + REAL ptrop(npoints) + REAL attrop(npoints) + REAL attropmin (npoints) + REAL atmax(npoints) + REAL btcmin(npoints) + REAL transmax(npoints) + + INTEGER i,j,ilev,ibox,itrop(npoints) + INTEGER ipres(npoints) + INTEGER itau(npoints),ilev2 + INTEGER acc(nlev,ncol) + INTEGER match(npoints,nlev-1) + INTEGER nmatch(npoints) + INTEGER levmatch(npoints,ncol) + + !variables needed for water vapor continuum absorption + real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) + real taumin(npoints) + real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 + real press(npoints), dpress(npoints), atmden(npoints) + real rvh20(npoints), wk(npoints), rhoave(npoints) + real rh20s(npoints), rfrgn(npoints) + real tmpexp(npoints),tauwv(npoints) + + character*1 cchar(6),cchar_realtops(6) + integer icycle + REAL tau(npoints,ncol) + LOGICAL box_cloudy(npoints,ncol) + REAL tb(npoints,ncol) + REAL ptop(npoints,ncol) + REAL emcld(npoints,ncol) + REAL fluxtop(npoints,ncol) + REAL trans_layers_above(npoints,ncol) + real isccp_taumin,fluxtopinit(npoints),tauir(npoints) + REAL albedocld(npoints,ncol) + real boxarea + integer debug ! set to non-zero value to print out inputs + ! with step debug + integer debugcol ! set to non-zero value to print out column + ! decomposition with step debugcol + integer rangevec(npoints),rangeerror + + integer index1(npoints),num1,jj,k1,k2 + real rec2p13,tauchk,logp,logp1,logp2,atd + real output_missing_value + + character*10 ftn09 + + DATA isccp_taumin / 0.3 / + DATA output_missing_value / -1.E+30 / + DATA cchar / ' ','-','1','+','I','+'/ + DATA cchar_realtops / ' ',' ','1','1','I','I'/ + +! ------ End duplicate definitions common to wrapper routine + + tauchk = -1.*log(0.9999999) + rec2p13=1./2.13 + + ncolprint=0 + + if ( debug.ne.0 ) then + j=1 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(a10)') 'debug=' + write(6,'(8I10)') debug + write(6,'(a10)') 'debugcol=' + write(6,'(8I10)') debugcol + write(6,'(a10)') 'npoints=' + write(6,'(8I10)') npoints + write(6,'(a10)') 'nlev=' + write(6,'(8I10)') nlev + write(6,'(a10)') 'ncol=' + write(6,'(8I10)') ncol + write(6,'(a11)') 'top_height=' + write(6,'(8I10)') top_height + write(6,'(a21)') 'top_height_direction=' + write(6,'(8I10)') top_height_direction + write(6,'(a10)') 'overlap=' + write(6,'(8I10)') overlap + write(6,'(a10)') 'emsfc_lw=' + write(6,'(8f10.2)') emsfc_lw + do j=1,npoints,debug + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(a10)') 'sunlit=' + write(6,'(8I10)') sunlit(j) + write(6,'(a10)') 'pfull=' + write(6,'(8f10.2)') (pfull(j,i),i=1,nlev) + write(6,'(a10)') 'phalf=' + write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1) + write(6,'(a10)') 'qv=' + write(6,'(8f10.3)') (qv(j,i),i=1,nlev) + write(6,'(a10)') 'cc=' + write(6,'(8f10.3)') (cc(j,i),i=1,nlev) + write(6,'(a10)') 'conv=' + write(6,'(8f10.2)') (conv(j,i),i=1,nlev) + write(6,'(a10)') 'dtau_s=' + write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev) + write(6,'(a10)') 'dtau_c=' + write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev) + write(6,'(a10)') 'skt=' + write(6,'(8f10.2)') skt(j) + write(6,'(a10)') 'at=' + write(6,'(8f10.2)') (at(j,i),i=1,nlev) + write(6,'(a10)') 'dem_s=' + write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev) + write(6,'(a10)') 'dem_c=' + write(6,'(8f10.3)') (dem_c(j,i),i=1,nlev) + enddo + endif + +! ---------------------------------------------------! + + if (ncolprint.ne.0) then + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + enddo + endif + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + do j=1,npoints + ptrop(j)=5000. + attropmin(j) = 400. + atmax(j) = 0. + attrop(j) = 120. + itrop(j) = 1 + enddo + + do 12 ilev=1,nlev + do j=1,npoints + if (pfull(j,ilev) .lt. 40000. .and. + & pfull(j,ilev) .gt. 5000. .and. + & at(j,ilev) .lt. attropmin(j)) then + ptrop(j) = pfull(j,ilev) + attropmin(j) = at(j,ilev) + attrop(j) = attropmin(j) + itrop(j)=ilev + end if + enddo +12 continue + + do 13 ilev=1,nlev + do j=1,npoints + if (at(j,ilev) .gt. atmax(j) .and. + & ilev .ge. itrop(j)) atmax(j)=at(j,ilev) + enddo +13 continue + + end if + + + if (top_height .eq. 1 .or. top_height .eq. 3) then + do j=1,npoints + meantb(j) = 0. + meantbclr(j) = 0. + end do + else + do j=1,npoints + meantb(j) = output_missing_value + meantbclr(j) = output_missing_value + end do + end if + +! -----------------------------------------------------! + +! ---------------------------------------------------! + + do ilev=1,nlev + do j=1,npoints + + rangevec(j)=0 + + if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then +! error = cloud fraction less than zero +! error = cloud fraction greater than 1 + rangevec(j)=rangevec(j)+1 + endif + + if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then +! ' error = convective cloud fraction less than zero' +! ' error = convective cloud fraction greater than 1' + rangevec(j)=rangevec(j)+2 + endif + + if (dtau_s(j,ilev) .lt. 0.) then +! ' error = stratiform cloud opt. depth less than zero' + rangevec(j)=rangevec(j)+4 + endif + + if (dtau_c(j,ilev) .lt. 0.) then +! ' error = convective cloud opt. depth less than zero' + rangevec(j)=rangevec(j)+8 + endif + + if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then +! ' error = stratiform cloud emissivity less than zero' +! ' error = stratiform cloud emissivity greater than 1' + rangevec(j)=rangevec(j)+16 + endif + + if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then +! ' error = convective cloud emissivity less than zero' +! ' error = convective cloud emissivity greater than 1' + rangevec(j)=rangevec(j)+32 + endif + enddo + + rangeerror=0 + do j=1,npoints + rangeerror=rangeerror+rangevec(j) + enddo + + if (rangeerror.ne.0) then + write (6,*) 'Input variable out of range' + write (6,*) 'rangevec:' + write (6,*) rangevec + STOP + endif + enddo + +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and +! put into vector tau + + !initialize tau and albedocld to zero + do 15 ibox=1,ncol + do j=1,npoints + tau(j,ibox)=0. + albedocld(j,ibox)=0. + boxtau(j,ibox)=output_missing_value + boxptop(j,ibox)=output_missing_value + box_cloudy(j,ibox)=.false. + enddo +15 continue + + !compute total cloud optical depth for each column + do ilev=1,nlev + !increment tau for each of the boxes + do ibox=1,ncol + do j=1,npoints + if (frac_out(j,ibox,ilev).eq.1) then + tau(j,ibox)=tau(j,ibox) + & + dtau_s(j,ilev) + endif + if (frac_out(j,ibox,ilev).eq.2) then + tau(j,ibox)=tau(j,ibox) + & + dtau_c(j,ilev) + end if + enddo + enddo ! ibox + enddo ! ilev + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(i2,1X,8(f7.2,1X))') + & ilev, + & (tau(j,ibox),ibox=1,ncolprint) + enddo + endif +! +! ---------------------------------------------------! + + + +! +! ---------------------------------------------------! +! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES +! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE +! +! again this is only done if top_height = 1 or 3 +! +! fluxtop is the 10.5 micron radiance at the top of the +! atmosphere +! trans_layers_above is the total transmissivity in the layers +! above the current layer +! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear +! sky versions of these quantities. + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + + !---------------------------------------------------------------------- + ! + ! DO CLEAR SKY RADIANCE CALCULATION FIRST + ! + !compute water vapor continuum emissivity + !this treatment follows Schwarkzopf and Ramasamy + !JGR 1999,vol 104, pages 9467-9499. + !the emissivity is calculated at a wavenumber of 955 cm-1, + !or 10.47 microns + wtmair = 28.9644 + wtmh20 = 18.01534 + Navo = 6.023E+23 + grav = 9.806650E+02 + pstd = 1.013250E+06 + t0 = 296. + if (ncolprint .ne. 0) + & write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv' + do 125 ilev=1,nlev + do j=1,npoints + !press and dpress are dyne/cm2 = Pascals *10 + press(j) = pfull(j,ilev)*10. + dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10 + !atmden = g/cm2 = kg/m2 / 10 + atmden(j) = dpress(j)/grav + rvh20(j) = qv(j,ilev)*wtmair/wtmh20 + wk(j) = rvh20(j)*Navo*atmden(j)/wtmair + rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev)) + rh20s(j) = rvh20(j)*rhoave(j) + rfrgn(j) = rhoave(j)-rh20s(j) + tmpexp(j) = exp(-0.02*(at(j,ilev)-t0)) + tauwv(j) = wk(j)*1.e-20*( + & (0.0224697*rh20s(j)*tmpexp(j)) + + & (3.41817e-7*rfrgn(j)) )*0.98 + dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j)) + enddo + if (ncolprint .ne. 0) then + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write(6,'(i2,1X,3(f8.3,3X))') ilev, + & qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), + & tauwv(j),dem_wv(j,ilev) + enddo + endif +125 continue + + !initialize variables + do j=1,npoints + fluxtop_clrsky(j) = 0. + trans_layers_above_clrsky(j)=1. + enddo + + do ilev=1,nlev + do j=1,npoints + + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + & + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above_clrsky(j)= + & trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev)) + + + enddo + if (ncolprint.ne.0) then + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'ilev:' + write (6,'(I2)') ilev + + write (6,'(a)') + & 'emiss_layer,100.*bb(j),100.*f,total_trans:' + write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), + & 100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j) + enddo + endif + + enddo !loop over level + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) + & * trans_layers_above_clrsky(j) + + !clear sky brightness temperature + meantbclr(j) = 1307.27/(log(1.+(1./fluxtop_clrsky(j)))) + + enddo + + if (ncolprint.ne.0) then + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'id:' + write (6,'(a)') 'surface' + + write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:' + write (6,'(5(f7.2,1X))') emsfc_lw,100.*bb(j), + & 100.*fluxtop_clrsky(j), + & trans_layers_above_clrsky(j), meantbclr(j) + enddo + endif + + + ! + ! END OF CLEAR SKY CALCULATION + ! + !---------------------------------------------------------------- + + + + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'ts:' + write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint) + + write (6,'(a)') 'ta_rev:' + write (6,'(8f7.2)') + & ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev) + + enddo + endif + !loop over columns + do ibox=1,ncol + do j=1,npoints + fluxtop(j,ibox)=0. + trans_layers_above(j,ibox)=1. + enddo + enddo + + do ilev=1,nlev + do j=1,npoints + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + enddo + + do ibox=1,ncol + do j=1,npoints + + ! emissivity for point in this layer + if (frac_out(j,ibox,ilev).eq.1) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_s(j,ilev)) ) + else if (frac_out(j,ibox,ilev).eq.2) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_c(j,ilev)) ) + else + dem(j,ibox)= dem_wv(j,ilev) + end if + + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + dem(j,ibox) * bb(j) + & * trans_layers_above(j,ibox) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above(j,ibox)= + & trans_layers_above(j,ibox)*(1.-dem(j,ibox)) + + enddo ! j + enddo ! ibox + + if (ncolprint.ne.0) then + do j=1,npoints,1000 + write (6,'(a)') 'ilev:' + write (6,'(I2)') ilev + + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'emiss_layer:' + write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') '100.*bb(j):' + write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + + write (6,'(a)') '100.*f:' + write (6,'(8f7.2)') + & (100.*fluxtop(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_trans:' + write (6,'(8f7.2)') + & (trans_layers_above(j,ibox),ibox=1,ncolprint) + enddo + endif + + enddo ! ilev + + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + end do + + do ibox=1,ncol + do j=1,npoints + + !add in surface emission + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + emsfc_lw * bb(j) + & * trans_layers_above(j,ibox) + + end do + end do + + !calculate mean infrared brightness temperature + do ibox=1,ncol + do j=1,npoints + meantb(j) = meantb(j)+1307.27/(log(1.+(1./fluxtop(j,ibox)))) + end do + end do + do j=1, npoints + meantb(j) = meantb(j) / real(ncol) + end do + + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'id:' + write (6,'(a)') 'surface' + + write (6,'(a)') 'emiss_layer:' + write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint) + + write (6,'(a)') '100.*bb(j):' + write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + + write (6,'(a)') '100.*f:' + write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'meantb(j):' + write (6,'(8f7.2)') (meantb(j),ibox=1,ncolprint) + + end do + endif + + !now that you have the top of atmosphere radiance account + !for ISCCP procedures to determine cloud top temperature + + !account for partially transmitting cloud recompute flux + !ISCCP would see assuming a single layer cloud + !note choice here of 2.13, as it is primarily ice + !clouds which have partial emissivity and need the + !adjustment performed in this section + ! + !If it turns out that the cloud brightness temperature + !is greater than 260K, then the liquid cloud conversion + !factor of 2.56 is used. + ! + !Note that this is discussed on pages 85-87 of + !the ISCCP D level documentation (Rossow et al. 1996) + + do j=1,npoints + !compute minimum brightness temperature and optical depth + btcmin(j) = 1. / ( exp(1307.27/(attrop(j)-5.)) - 1. ) + enddo + do ibox=1,ncol + do j=1,npoints + transmax(j) = (fluxtop(j,ibox)-btcmin(j)) + & /(fluxtop_clrsky(j)-btcmin(j)) + !note that the initial setting of tauir(j) is needed so that + !tauir(j) has a realistic value should the next if block be + !bypassed + tauir(j) = tau(j,ibox) * rec2p13 + taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001)) + + enddo + + if (top_height .eq. 1) then + do j=1,npoints + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + fluxtopinit(j) = fluxtop(j,ibox) + tauir(j) = tau(j,ibox) *rec2p13 + endif + enddo + do icycle=1,2 + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + emcld(j,ibox) = 1. - exp(-1. * tauir(j) ) + fluxtop(j,ibox) = fluxtopinit(j) - + & ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) + fluxtop(j,ibox)=max(1.E-06, + & (fluxtop(j,ibox)/emcld(j,ibox))) + tb(j,ibox)= 1307.27 + & / (log(1. + (1./fluxtop(j,ibox)))) + if (tb(j,ibox) .gt. 260.) then + tauir(j) = tau(j,ibox) / 2.56 + end if + end if + end if + enddo + enddo + + endif + + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + !cloudy box + !NOTE: tb is the cloud-top temperature not infrared brightness temperature + !at this point in the code + tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox)))) + if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then + tb(j,ibox) = attrop(j) - 5. + tau(j,ibox) = 2.13*taumin(j) + end if + else + !clear sky brightness temperature + tb(j,ibox) = meantbclr(j) + end if + enddo ! j + enddo ! ibox + + if (ncolprint.ne.0) then + + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + + write (6,'(a)') 'attrop:' + write (6,'(8f7.2)') (attrop(j)) + + write (6,'(a)') 'btcmin:' + write (6,'(8f7.2)') (btcmin(j)) + + write (6,'(a)') 'fluxtop_clrsky*100:' + write (6,'(8f7.2)') + & (100.*fluxtop_clrsky(j)) + + write (6,'(a)') '100.*f_adj:' + write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'transmax:' + write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint) + + write (6,'(a)') 'tau:' + write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'emcld:' + write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_trans:' + write (6,'(8f7.2)') + & (trans_layers_above(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_emiss:' + write (6,'(8f7.2)') + & (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'total_trans:' + write (6,'(8f7.2)') + & (trans_layers_above(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'ppout:' + write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) + enddo ! j + endif + + end if + +! ---------------------------------------------------! + +! +! ---------------------------------------------------! +! DETERMINE CLOUD TOP PRESSURE +! +! again the 2 methods differ according to whether +! or not you use the physical cloud top pressure (top_height = 2) +! or the radiatively determined cloud top pressure (top_height = 1 or 3) +! + + !compute cloud top pressure + do 30 ibox=1,ncol + !segregate according to optical thickness + if (top_height .eq. 1 .or. top_height .eq. 3) then + !find level whose temperature + !most closely matches brightness temperature + do j=1,npoints + nmatch(j)=0 + enddo + do 29 k1=1,nlev-1 + if (top_height_direction .eq. 2) then + ilev = nlev - k1 + else + ilev = k1 + end if + !cdir nodep + do j=1,npoints + if (ilev .ge. itrop(j)) then + if ((at(j,ilev) .ge. tb(j,ibox) .and. + & at(j,ilev+1) .le. tb(j,ibox)) .or. + & (at(j,ilev) .le. tb(j,ibox) .and. + & at(j,ilev+1) .ge. tb(j,ibox))) then + nmatch(j)=nmatch(j)+1 + match(j,nmatch(j))=ilev + end if + end if + enddo +29 continue + + do j=1,npoints + if (nmatch(j) .ge. 1) then + k1 = match(j,nmatch(j)) + k2 = k1 + 1 + logp1 = log(pfull(j,k1)) + logp2 = log(pfull(j,k2)) + atd = max(tauchk,abs(at(j,k2) - at(j,k1))) + logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd + ptop(j,ibox) = exp(logp) + if(abs(pfull(j,k1)-ptop(j,ibox)) .lt. + & abs(pfull(j,k2)-ptop(j,ibox))) then + levmatch(j,ibox)=k1 + else + levmatch(j,ibox)=k2 + end if + else + if (tb(j,ibox) .le. attrop(j)) then + ptop(j,ibox)=ptrop(j) + levmatch(j,ibox)=itrop(j) + end if + if (tb(j,ibox) .ge. atmax(j)) then + ptop(j,ibox)=pfull(j,nlev) + levmatch(j,ibox)=nlev + end if + end if + enddo ! j + + else ! if (top_height .eq. 1 .or. top_height .eq. 3) + + do j=1,npoints + ptop(j,ibox)=0. + enddo + do ilev=1,nlev + do j=1,npoints + if ((ptop(j,ibox) .eq. 0. ) + & .and.(frac_out(j,ibox,ilev) .ne. 0)) then + ptop(j,ibox)=phalf(j,ilev) + levmatch(j,ibox)=ilev + end if + end do + end do + end if + + do j=1,npoints + if (tau(j,ibox) .le. (tauchk )) then + ptop(j,ibox)=0. + levmatch(j,ibox)=0 + endif + enddo + +30 continue + +! +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! DETERMINE ISCCP CLOUD TYPE FREQUENCIES +! +! Now that ptop and tau have been determined, +! determine amount of each of the 49 ISCCP cloud +! types +! +! Also compute grid box mean cloud top pressure and +! optical thickness. The mean cloud top pressure and +! optical thickness are averages over the cloudy +! area only. The mean cloud top pressure is a linear +! average of the cloud top pressures. The mean cloud +! optical thickness is computed by converting optical +! thickness to an albedo, averaging in albedo units, +! then converting the average albedo back to a mean +! optical thickness. +! + + !compute isccp frequencies + + !reset frequencies + do 38 ilev=1,7 + do 38 ilev2=1,7 + do j=1,npoints ! + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + fq_isccp(j,ilev,ilev2)= 0. + else + fq_isccp(j,ilev,ilev2)= output_missing_value + end if + enddo +38 continue + + !reset variables need for averaging cloud properties + do j=1,npoints + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + totalcldarea(j) = 0. + meanalbedocld(j) = 0. + meanptop(j) = 0. + meantaucld(j) = 0. + else + totalcldarea(j) = output_missing_value + meanalbedocld(j) = output_missing_value + meanptop(j) = output_missing_value + meantaucld(j) = output_missing_value + end if + enddo ! j + + boxarea = 1./real(ncol) + + do 39 ibox=1,ncol + do j=1,npoints + + if (tau(j,ibox) .gt. (tauchk ) + & .and. ptop(j,ibox) .gt. 0.) then + box_cloudy(j,ibox)=.true. + endif + + if (box_cloudy(j,ibox)) then + + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + + boxtau(j,ibox) = tau(j,ibox) + + if (tau(j,ibox) .ge. isccp_taumin) then + totalcldarea(j) = totalcldarea(j) + boxarea + + !convert optical thickness to albedo + albedocld(j,ibox) + & = (tau(j,ibox)**0.895)/((tau(j,ibox)**0.895)+6.82) + + !contribute to averaging + meanalbedocld(j) = meanalbedocld(j) + & +albedocld(j,ibox)*boxarea + + end if + + endif + + endif + + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + + if (box_cloudy(j,ibox)) then + + !convert ptop to millibars + ptop(j,ibox)=ptop(j,ibox) / 100. + + !save for output cloud top pressure and optical thickness + boxptop(j,ibox) = ptop(j,ibox) + + if (tau(j,ibox) .ge. isccp_taumin) then + meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea + end if + + !reset itau(j), ipres(j) + itau(j) = 0 + ipres(j) = 0 + + !determine optical depth category + if (tau(j,ibox) .lt. isccp_taumin) then + itau(j)=1 + else if (tau(j,ibox) .ge. isccp_taumin + & + & .and. tau(j,ibox) .lt. 1.3) then + itau(j)=2 + else if (tau(j,ibox) .ge. 1.3 + & .and. tau(j,ibox) .lt. 3.6) then + itau(j)=3 + else if (tau(j,ibox) .ge. 3.6 + & .and. tau(j,ibox) .lt. 9.4) then + itau(j)=4 + else if (tau(j,ibox) .ge. 9.4 + & .and. tau(j,ibox) .lt. 23.) then + itau(j)=5 + else if (tau(j,ibox) .ge. 23. + & .and. tau(j,ibox) .lt. 60.) then + itau(j)=6 + else if (tau(j,ibox) .ge. 60.) then + itau(j)=7 + end if + + !determine cloud top pressure category + if ( ptop(j,ibox) .gt. 0. + & .and.ptop(j,ibox) .lt. 180.) then + ipres(j)=1 + else if(ptop(j,ibox) .ge. 180. + & .and.ptop(j,ibox) .lt. 310.) then + ipres(j)=2 + else if(ptop(j,ibox) .ge. 310. + & .and.ptop(j,ibox) .lt. 440.) then + ipres(j)=3 + else if(ptop(j,ibox) .ge. 440. + & .and.ptop(j,ibox) .lt. 560.) then + ipres(j)=4 + else if(ptop(j,ibox) .ge. 560. + & .and.ptop(j,ibox) .lt. 680.) then + ipres(j)=5 + else if(ptop(j,ibox) .ge. 680. + & .and.ptop(j,ibox) .lt. 800.) then + ipres(j)=6 + else if(ptop(j,ibox) .ge. 800.) then + ipres(j)=7 + end if + + !update frequencies + if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then + fq_isccp(j,itau(j),ipres(j))= + & fq_isccp(j,itau(j),ipres(j))+ boxarea + end if + + end if + + end if + + enddo ! j +39 continue + + !compute mean cloud properties + do j=1,npoints + if (totalcldarea(j) .gt. 0.) then + ! code above guarantees that totalcldarea > 0 + ! only if sunlit .eq. 1 .or. top_height = 3 + ! and applies only to clouds with tau > isccp_taumin + meanptop(j) = meanptop(j) / totalcldarea(j) + meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j) + meantaucld(j) = (6.82/((1./meanalbedocld(j))-1.))**(1./0.895) + else + ! this code is necessary so that in the case that totalcldarea = 0., + ! that these variables, which are in-cloud averages, are set to missing + ! note that totalcldarea will be 0. if all the clouds in the grid box have + ! tau < isccp_taumin + meanptop(j) = output_missing_value + meanalbedocld(j) = output_missing_value + meantaucld(j) = output_missing_value + end if + enddo ! j +! +! ---------------------------------------------------! + +! ---------------------------------------------------! +! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM +! + if (debugcol.ne.0) then +! + do j=1,npoints,debugcol + + !produce character output + do ilev=1,nlev + do ibox=1,ncol + acc(ilev,ibox)=0 + enddo + enddo + + do ilev=1,nlev + do ibox=1,ncol + acc(ilev,ibox)=frac_out(j,ibox,ilev)*2 + if (levmatch(j,ibox) .eq. ilev) + & acc(ilev,ibox)=acc(ilev,ibox)+1 + enddo + enddo + + !print test + + write(ftn09,11) j +11 format('ftn09.',i4.4) + open(9, FILE=ftn09, FORM='FORMATTED') + + write(9,'(a1)') ' ' + write(9,'(10i5)') + & (ilev,ilev=5,nlev,5) + write(9,'(a1)') ' ' + + do ibox=1,ncol + write(9,'(40(a1),1x,40(a1))') + & (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) + & ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) + end do + close(9) + + if (ncolprint.ne.0) then + write(6,'(a1)') ' ' + write(6,'(a2,1X,5(a7,1X),a50)') + & 'ilev', + & 'pfull','at', + & 'cc*100','dem_s','dtau_s', + & 'cchar' + +! do 4012 ilev=1,nlev +! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint) +! write(6,'(i2,1X,5(f7.2,1X),50(a1))') +! & ilev, +! & pfull(j,ilev)/100.,at(j,ilev), +! & cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev) +! & ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint) +!4012 continue + write (6,'(a)') 'skt(j):' + write (6,'(8f7.2)') skt(j) + + write (6,'(8I7)') (ibox,ibox=1,ncolprint) + + write (6,'(a)') 'tau:' + write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'tb:' + write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'ptop:' + write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint) + endif + + enddo + + end if + + return + end + + Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histdayCOSP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histdayCOSP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histdayCOSP.h (revision 1634) @@ -0,0 +1,197 @@ +! Abderrahmane Idelkadi Septebmre 2009 +! Sorties journalieres de COSP +! Pour l'instant sorties Lidar et ISCCP +! +! sorties par jour +! +!$OMP MASTER + zstoday = ecrit_day + zout = freq_COSP +! +! PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +! + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + + CALL histbeg_phy("histdayCOSP",itau_phy,zjulian,dtime,nhori,nid_day_cosp) + +! Definition de l'axe vertical + if (use_vgrid) then + CALL histvert(nid_day_cosp,"height","height","m",Nlevout,vgrid%z,nvert) + else + CALL histvert(nid_day_cosp,"presnivs","Vertical levels","mb",Nlevout,presnivs,nvert) + endif + + CALL histvert(nid_day_cosp,"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertm) + + CALL histvert(nid_day_cosp,"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp) + + CALL histvert(nid_day_cosp,"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp) + + CALL histvert(nid_day_cosp,"column","column","count",Ncolumns,column_ax(1:Ncolumns),nvertcol) + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histdef(nid_day_cosp, "cllcalipso", & + "Lidar Low-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lclhcalipso) then + CALL histdef(nid_day_cosp, "clhcalipso", & + "Lidar High-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lclmcalipso) then + CALL histdef(nid_day_cosp, "clmcalipso", & + "Lidar Mid-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lcltcalipso) then + CALL histdef(nid_day_cosp, "cltcalipso", & + "Lidar Total Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lclcalipso) then + CALL histdef(nid_day_cosp, "clcalipso", & + "Lidar Cloud Fraction (532 nm)", "1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histdef(nid_day_cosp, "cfad_lidarsr532_"//chcol(ii), & + "Lidar Scattering Ratio CFAD (532 nm)","1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstoday) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histdef(nid_day_cosp, "parasol_refl", & + "PARASOL-like mono-directional reflectance","1", & + iim,jj_nb,nhori, PARASOL_NREFL,1, PARASOL_NREFL, nvertp,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histdef(nid_day_cosp, "atb532_"//chcol(ii), & + "Lidar Attenuated Total Backscatter (532 nm)","1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstoday) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histdef(nid_day_cosp, "beta_mol532", & + "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstoday) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histdef(nid_day_cosp, "clisccp2_"//chcol(ii), & + "Cloud Fraction as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,7,1,7,nvertisccp, 32, & + "ave(X)", zout,zstoday) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histdef(nid_day_cosp, "boxtauisccp", & + "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lboxptopisccp) then + CALL histdef(nid_day_cosp, "boxptopisccp", & + "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Ltclisccp) then + CALL histdef(nid_day_cosp, "tclisccp", & + "Total Cloud Fraction as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lctpisccp) then + CALL histdef(nid_day_cosp, "ctpisccp", & + "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Ltauisccp) then + CALL histdef(nid_day_cosp, "tauisccp", & + "Optical Depth as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lalbisccp) then + CALL histdef(nid_day_cosp, "albisccp", & + "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lmeantbisccp) then + CALL histdef(nid_day_cosp, "meantbisccp", & + " Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + if (cfg%Lmeantbclrisccp) then + CALL histdef(nid_day_cosp, "meantbclrisccp", & + "Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstoday) + endif + endif ! Isccp + + + CALL histend(nid_day_cosp) +!$OMP END MASTER +!$OMP BARRIER Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histhfCOSP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histhfCOSP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histhfCOSP.h (revision 1634) @@ -0,0 +1,197 @@ +! Abderrahmane Idelkadi Septebmre 2009 +! Sorties journalieres de COSP +! Pour l'instant sorties Lidar et ISCCP +! +! sorties par jour +! +!$OMP MASTER + zstohf = ecrit_hf + zout = freq_COSP +! +! PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +! + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + + CALL histbeg_phy("histhfCOSP",itau_phy,zjulian,dtime,nhori,nid_hf_cosp) + +! Definition de l'axe vertical + if (use_vgrid) then + CALL histvert(nid_hf_cosp,"height","height","m",Nlevout,vgrid%z,nvert) + else + CALL histvert(nid_hf_cosp,"presnivs","Vertical levels","mb",Nlevout,presnivs,nvert) + endif + + CALL histvert(nid_hf_cosp,"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertm) + + CALL histvert(nid_hf_cosp,"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp) + + CALL histvert(nid_hf_cosp,"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp) + + CALL histvert(nid_hf_cosp,"column","column","count",Ncolumns,column_ax(1:Ncolumns),nvertcol) + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histdef(nid_hf_cosp, "cllcalipso", & + "Lidar Low-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lclhcalipso) then + CALL histdef(nid_hf_cosp, "clhcalipso", & + "Lidar High-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lclmcalipso) then + CALL histdef(nid_hf_cosp, "clmcalipso", & + "Lidar Mid-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lcltcalipso) then + CALL histdef(nid_hf_cosp, "cltcalipso", & + "Lidar Total Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lclcalipso) then + CALL histdef(nid_hf_cosp, "clcalipso", & + "Lidar Cloud Fraction (532 nm)", "1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histdef(nid_hf_cosp, "cfad_lidarsr532_"//chcol(ii), & + "Lidar Scattering Ratio CFAD (532 nm)","1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstohf) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histdef(nid_hf_cosp, "parasol_refl", & + "PARASOL-like mono-directional reflectance","1", & + iim,jj_nb,nhori, PARASOL_NREFL,1, PARASOL_NREFL, nvertp,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histdef(nid_hf_cosp, "atb532_"//chcol(ii), & + "Lidar Attenuated Total Backscatter (532 nm)","1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstohf) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histdef(nid_hf_cosp, "beta_mol532", & + "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstohf) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histdef(nid_hf_cosp, "clisccp2_"//chcol(ii), & + "Cloud Fraction as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,7,1,7,nvertisccp, 32, & + "ave(X)", zout,zstohf) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histdef(nid_hf_cosp, "boxtauisccp", & + "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lboxptopisccp) then + CALL histdef(nid_hf_cosp, "boxptopisccp", & + "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Ltclisccp) then + CALL histdef(nid_hf_cosp, "tclisccp", & + "Total Cloud Fraction as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lctpisccp) then + CALL histdef(nid_hf_cosp, "ctpisccp", & + "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Ltauisccp) then + CALL histdef(nid_hf_cosp, "tauisccp", & + "Optical Depth as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lalbisccp) then + CALL histdef(nid_hf_cosp, "albisccp", & + "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lmeantbisccp) then + CALL histdef(nid_hf_cosp, "meantbisccp", & + " Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + if (cfg%Lmeantbclrisccp) then + CALL histdef(nid_hf_cosp, "meantbclrisccp", & + "Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstohf) + endif + endif ! Isccp + + + CALL histend(nid_hf_cosp) +!$OMP END MASTER +!$OMP BARRIER Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histmthCOSP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histmthCOSP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/ini_histmthCOSP.h (revision 1634) @@ -0,0 +1,204 @@ +! Abderrahmane Idelkadi Septebmre 2009 +! Sorties journalieres de COSP +! Pour l'instant sorties Lidar et ISCCP +! +! sorties par jour +! +!$OMP MASTER + zstomth = ecrit_mth + zout = freq_COSP +! +! PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +! + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + CALL histbeg_phy("histmthCOSP",itau_phy,zjulian,dtime,nhori,nid_mth_cosp) + +! Definition de l'axe vertical + print*,'height_mlev=',vgrid%mz + if (use_vgrid) then + CALL histvert(nid_mth_cosp,"height","height","m",Nlevout,vgrid%z,nvert) + else + CALL histvert(nid_mth_cosp,"presnivs","Vertical levels","Pa",Nlevout,presnivs,nvert,"down") + endif + CALL histvert(nid_mth_cosp,"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertm) + + CALL histvert(nid_mth_cosp,"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp) + + CALL histvert(nid_mth_cosp,"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp) + + CALL histvert(nid_mth_cosp,"column","column","count",Ncolumns,column_ax(1:Ncolumns),nvertcol) + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histdef(nid_mth_cosp, "cllcalipso", & + "Lidar Low-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lclhcalipso) then + CALL histdef(nid_mth_cosp, "clhcalipso", & + "Lidar High-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lclmcalipso) then + CALL histdef(nid_mth_cosp, "clmcalipso", & + "Lidar Mid-level Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lcltcalipso) then + CALL histdef(nid_mth_cosp, "cltcalipso", & + "Lidar Total Cloud Fraction", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lclcalipso) then + CALL histdef(nid_mth_cosp, "clcalipso", & + "Lidar Cloud Fraction (532 nm)", "1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstomth) +! CALL histdef(nid_mth_cosp, "zlev_m", & +! "Height at Midel model levels", "m", & +! iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & +! "ave(X)", zout,zstomth) +! CALL histdef(nid_mth_cosp, "zlev_b", & +! "Height at bottom model levels", "m", & +! iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & +! "ave(X)", zout,zstomth) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histdef(nid_mth_cosp, "cfad_lidarsr532_"//chcol(ii), & + "Lidar Scattering Ratio CFAD (532 nm)","1", & + iim,jj_nb,nhori, Nlevout,1,Nlevout,nvert, 32, & + "ave(X)", zout,zstomth) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histdef(nid_mth_cosp, "parasol_refl", & + "PARASOL-like mono-directional reflectance","1", & + iim,jj_nb,nhori, PARASOL_NREFL,1, PARASOL_NREFL, nvertp,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histdef(nid_mth_cosp, "atb532_"//chcol(ii), & + "Lidar Attenuated Total Backscatter (532 nm)","1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstomth) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histdef(nid_mth_cosp, "beta_mol532", & + "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", & + iim,jj_nb,nhori, Nlevlmdz,1,Nlevlmdz,nvertm, 32, & + "ave(X)", zout,zstomth) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%tttttttttttt) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histdef(nid_mth_cosp, "clisccp2_"//chcol(ii), & + "Cloud Fraction as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,7,1,7,nvertisccp, 32, & + "ave(X)", zout,zstomth) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histdef(nid_mth_cosp, "boxtauisccp", & + "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lboxptopisccp) then + CALL histdef(nid_mth_cosp, "boxptopisccp", & + "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", & + iim,jj_nb,nhori,Ncolumns,1,Ncolumns,nvertcol, 32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Ltclisccp) then + CALL histdef(nid_mth_cosp, "tclisccp", & + "Total Cloud Fraction as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lctpisccp) then + CALL histdef(nid_mth_cosp, "ctpisccp", & + "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Ltauisccp) then + CALL histdef(nid_mth_cosp, "tauisccp", & + "Optical Depth as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lalbisccp) then + CALL histdef(nid_mth_cosp, "albisccp", & + "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lmeantbisccp) then + CALL histdef(nid_mth_cosp, "meantbisccp", & + " Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + if (cfg%Lmeantbclrisccp) then + CALL histdef(nid_mth_cosp, "meantbclrisccp", & + "Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator","K", & + iim, jj_nb,nhori,1,1,1,-99,32, & + "ave(X)", zout,zstomth) + endif + endif ! Isccp + + + CALL histend(nid_mth_cosp) +!$OMP END MASTER +!$OMP BARRIER Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/lidar_simulator.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/lidar_simulator.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/lidar_simulator.F90 (revision 1634) @@ -0,0 +1,571 @@ +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its +! contributors may be used to endorse or promote products derived from this software without +! specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + SUBROUTINE lidar_simulator(npoints,nlev,npart,nrefl & + , undef & + , pres, presf, temp & + , q_lsliq, q_lsice, q_cvliq, q_cvice & + , ls_radliq, ls_radice, cv_radliq, cv_radice & + , frac_out, ice_type & + , pmol, pnorm, tautot, refl ) +! +!--------------------------------------------------------------------------------- +! Purpose: To compute lidar signal from model-simulated profiles of cloud water +! and cloud fraction in each sub-column of each model gridbox. +! +! References: +! Chepfer H., S. Bony, D. Winker, M. Chiriaco, J.-L. Dufresne, G. Seze (2008), +! Use of CALIPSO lidar observations to evaluate the cloudiness simulated by a +! climate model, Geophys. Res. Lett., 35, L15704, doi:10.1029/2008GL034207. +! +! Previous references: +! Chiriaco et al, MWR, 2006; Chepfer et al., MWR, 2007 +! +! Contacts: Helene Chepfer (chepfer@lmd.polytechnique.fr), Sandrine Bony (bony@lmd.jussieu.fr) +! +! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony +! +! May 2008, H. Chepfer: +! - Units of pressure inputs: Pa +! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients +! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical) +! +! June 2008, A. Bodas-Salcedo: +! - Ported to Fortran 90 and optimisation changes +! +! August 2008, J-L Dufresne: +! - Optimisation changes (sum instructions suppressed) +! +! October 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Interface with COSP v2.0: +! cloud fraction removed from inputs +! in-cloud condensed water now in input (instead of grid-averaged value) +! depolarisation diagnostic removed +! parasol (polder) reflectances (for 5 different solar zenith angles) added +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Modification of the integration of the lidar equation. +! - change the cloud detection threshold +! +! April 2008, A. Bodas-Salcedo: +! - Bug fix in computation of pmol and pnorm of upper layer +! +! April 2008, J-L. Dufresne +! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 +! was missing. This affects the ATB values but not the cloud fraction. +! +!--------------------------------------------------------------------------------- +! +! Inputs: +! npoints : number of horizontal points +! nlev : number of vertical levels +! npart: numberb of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). +! Currently npart must be 4 +! nrefl: number of solar zenith angles for parasol reflectances +! pres : pressure in the middle of atmospheric layers (full levels): Pa +! presf: pressure in the interface of atmospheric layers (half levels): Pa +! presf(..,1) : surface pressure ; presf(..,nlev+1)= TOA pressure +! temp : temperature of atmospheric layers: K +! q_lsliq: LS sub-column liquid water mixing ratio (kg/kg) +! q_lsice: LS sub-column ice water mixing ratio (kg/kg) +! q_cvliq: CONV sub-column liquid water mixing ratio (kg/kg) +! q_cvice: CONV sub-column ice water mixing ratio (kg/kg) +! ls_radliq: effective radius of LS liquid particles (meters) +! ls_radice: effective radius of LS ice particles (meters) +! cv_radliq: effective radius of CONV liquid particles (meters) +! cv_radice: effective radius of CONV ice particles (meters) +! frac_out : cloud cover in each sub-column of the gridbox (output from scops) +! ice_type : ice particle shape hypothesis (ice_type=0 for spheres, ice_type=1 +! for non spherical particles) +! +! Outputs: +! pmol : molecular attenuated backscatter lidar signal power (m^-1.sr^-1) +! pnorm: total attenuated backscatter lidar signal power (m^-1.sr^-1) +! tautot: optical thickess integrated from top to level z +! refl : parasol(polder) reflectance +! +! Version 1.0 (June 2007) +! Version 1.1 (May 2008) +! Version 1.2 (June 2008) +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +!--------------------------------------------------------------------------------- + + IMPLICIT NONE + REAL :: SRsat + PARAMETER (SRsat = 0.01) ! threshold full attenuation + + LOGICAL ok_parasol + PARAMETER (ok_parasol=.true.) ! set to .true. if you want to activate parasol reflectances + + INTEGER i, k + + INTEGER INDX_LSLIQ,INDX_LSICE,INDX_CVLIQ,INDX_CVICE + PARAMETER (INDX_LSLIQ=1,INDX_LSICE=2,INDX_CVLIQ=3,INDX_CVICE=4) +! inputs: + INTEGER npoints,nlev,npart,ice_type + INTEGER nrefl + real undef ! undefined value + REAL pres(npoints,nlev) ! pressure full levels + REAL presf(npoints,nlev+1) ! pressure half levels + REAL temp(npoints,nlev) + REAL q_lsliq(npoints,nlev), q_lsice(npoints,nlev) + REAL q_cvliq(npoints,nlev), q_cvice(npoints,nlev) + REAL ls_radliq(npoints,nlev), ls_radice(npoints,nlev) + REAL cv_radliq(npoints,nlev), cv_radice(npoints,nlev) + REAL frac_out(npoints,nlev) + +! outputs (for each subcolumn): + + REAL pmol(npoints,nlev) ! molecular backscatter signal power (m^-1.sr^-1) + REAL pnorm(npoints,nlev) ! total lidar backscatter signal power (m^-1.sr^-1) + REAL tautot(npoints,nlev)! optical thickess integrated from top + REAL refl(npoints,nrefl)! parasol reflectance ! parasol + +! actsim variables: + + REAL km, rdiffm, Qscat, Cmol + PARAMETER (Cmol = 6.2446e-32) ! depends on wavelength + PARAMETER (km = 1.38e-23) ! Boltzmann constant (J/K) + + PARAMETER (rdiffm = 0.7) ! multiple scattering correction parameter + PARAMETER (Qscat = 2.0) ! particle scattering efficiency at 532 nm + + REAL rholiq, rhoice + PARAMETER (rholiq=1.0e+03) ! liquid water (kg/m3) + PARAMETER (rhoice=0.5e+03) ! ice (kg/m3) + + REAL pi, rhopart(npart) + REAL polpart(npart,5) ! polynomial coefficients derived for spherical and non spherical + ! particules + +! grid-box variables: + REAL rad_part(npoints,nlev,npart) + REAL rhoair(npoints,nlev), zheight(npoints,nlev+1) + REAL beta_mol(npoints,nlev), alpha_mol(npoints,nlev) + REAL kp_part(npoints,nlev,npart) + +! sub-column variables: + REAL frac_sub(npoints,nlev) + REAL qpart(npoints,nlev,npart) ! mixing ratio particles in each subcolumn + REAL alpha_part(npoints,nlev,npart) + REAL tau_mol_lay(npoints) ! temporary variable, moL. opt. thickness of layer k + REAL tau_mol(npoints,nlev) ! optical thickness between TOA and bottom of layer k + REAL tau_part(npoints,nlev,npart) + REAL betatot(npoints,nlev) + REAL tautot_lay(npoints) ! temporary variable, total opt. thickness of layer k +! Optical thickness from TOA to surface for Parasol + REAL tautot_S_liq(npoints),tautot_S_ice(npoints) ! for liq and ice clouds + +! Abderrahmane 8-2-2011 + Logical iflag_testlidar + PARAMETER (iflag_testlidar=.false.) + +!------------------------------------------------------------ +!---- 1. Preliminary definitions and calculations : +!------------------------------------------------------------ + + if ( npart .ne. 4 ) then + print *,'Error in lidar_simulator, npart should be 4, not',npart + stop + endif + + pi = dacos(-1.D0) + +! Polynomial coefficients for spherical liq/ice particles derived from Mie theory. +! Polynomial coefficients for non spherical particles derived from a composite of +! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001) +! and FDTD theory for very small particles (Yang et al., JQSRT, 2003). + +! We repeat the same coefficients for LS and CONV cloud to make code more readable +!* LS Liquid water coefficients: + polpart(INDX_LSLIQ,1) = 2.6980e-8 + polpart(INDX_LSLIQ,2) = -3.7701e-6 + polpart(INDX_LSLIQ,3) = 1.6594e-4 + polpart(INDX_LSLIQ,4) = -0.0024 + polpart(INDX_LSLIQ,5) = 0.0626 +!* LS Ice coefficients: + if (ice_type.eq.0) then + polpart(INDX_LSICE,1) = -1.0176e-8 + polpart(INDX_LSICE,2) = 1.7615e-6 + polpart(INDX_LSICE,3) = -1.0480e-4 + polpart(INDX_LSICE,4) = 0.0019 + polpart(INDX_LSICE,5) = 0.0460 + endif +!* LS Ice NS coefficients: + if (ice_type.eq.1) then + polpart(INDX_LSICE,1) = 1.3615e-8 + polpart(INDX_LSICE,2) = -2.04206e-6 + polpart(INDX_LSICE,3) = 7.51799e-5 + polpart(INDX_LSICE,4) = 0.00078213 + polpart(INDX_LSICE,5) = 0.0182131 + endif +!* CONV Liquid water coefficients: + polpart(INDX_CVLIQ,1) = 2.6980e-8 + polpart(INDX_CVLIQ,2) = -3.7701e-6 + polpart(INDX_CVLIQ,3) = 1.6594e-4 + polpart(INDX_CVLIQ,4) = -0.0024 + polpart(INDX_CVLIQ,5) = 0.0626 +!* CONV Ice coefficients: + if (ice_type.eq.0) then + polpart(INDX_CVICE,1) = -1.0176e-8 + polpart(INDX_CVICE,2) = 1.7615e-6 + polpart(INDX_CVICE,3) = -1.0480e-4 + polpart(INDX_CVICE,4) = 0.0019 + polpart(INDX_CVICE,5) = 0.0460 + endif + if (ice_type.eq.1) then + polpart(INDX_CVICE,1) = 1.3615e-8 + polpart(INDX_CVICE,2) = -2.04206e-6 + polpart(INDX_CVICE,3) = 7.51799e-5 + polpart(INDX_CVICE,4) = 0.00078213 + polpart(INDX_CVICE,5) = 0.0182131 + endif + +! density: +!* clear-sky air: + rhoair = pres/(287.04*temp) + +!* liquid/ice particules: + rhopart(INDX_LSLIQ) = rholiq + rhopart(INDX_LSICE) = rhoice + rhopart(INDX_CVLIQ) = rholiq + rhopart(INDX_CVICE) = rhoice + +! effective radius particles: + rad_part(:,:,INDX_LSLIQ) = ls_radliq(:,:) + rad_part(:,:,INDX_LSICE) = ls_radice(:,:) + rad_part(:,:,INDX_CVLIQ) = cv_radliq(:,:) + rad_part(:,:,INDX_CVICE) = cv_radice(:,:) + rad_part(:,:,:)=MAX(rad_part(:,:,:),0.) + rad_part(:,:,:)=MIN(rad_part(:,:,:),70.0e-6) + +! altitude at half pressure levels: + zheight(:,1) = 0.0 + do k = 2, nlev+1 + zheight(:,k) = zheight(:,k-1) & + -(presf(:,k)-presf(:,k-1))/(rhoair(:,k-1)*9.81) + enddo + +! cloud fraction (0 or 1) in each sub-column: +! (if frac_out=1or2 -> frac_sub=1; if frac_out=0 -> frac_sub=0) + frac_sub = MIN( frac_out, 1.0 ) + +!------------------------------------------------------------ +!---- 2. Molecular alpha and beta: +!------------------------------------------------------------ + + beta_mol = pres/km/temp * Cmol + alpha_mol = 8.0*pi/3.0 * beta_mol + +!------------------------------------------------------------ +!---- 3. Particles alpha and beta: +!------------------------------------------------------------ + +! polynomes kp_lidar derived from Mie theory: + do i = 1, npart + where ( rad_part(:,:,i).gt.0.0) + kp_part(:,:,i) = & + polpart(i,1)*(rad_part(:,:,i)*1e6)**4 & + + polpart(i,2)*(rad_part(:,:,i)*1e6)**3 & + + polpart(i,3)*(rad_part(:,:,i)*1e6)**2 & + + polpart(i,4)*(rad_part(:,:,i)*1e6) & + + polpart(i,5) + elsewhere + kp_part(:,:,i) = 0. + endwhere + enddo + +! mixing ratio particules in each subcolumn: + qpart(:,:,INDX_LSLIQ) = q_lsliq(:,:) ! oct08 + qpart(:,:,INDX_LSICE) = q_lsice(:,:) ! oct08 + qpart(:,:,INDX_CVLIQ) = q_cvliq(:,:) ! oct08 + qpart(:,:,INDX_CVICE) = q_cvice(:,:) ! oct08 + +! alpha of particles in each subcolumn: + do i = 1, npart + where ( rad_part(:,:,i).gt.0.0) + alpha_part(:,:,i) = 3.0/4.0 * Qscat & + * rhoair(:,:) * qpart(:,:,i) & + / (rhopart(i) * rad_part(:,:,i) ) + elsewhere + alpha_part(:,:,i) = 0. + endwhere + enddo + +!------------------------------------------------------------ +!---- 4. Backscatter signal: +!------------------------------------------------------------ + +! optical thickness (molecular): +! opt. thick of each layer + tau_mol(:,1:nlev) = alpha_mol(:,1:nlev) & + & *(zheight(:,2:nlev+1)-zheight(:,1:nlev)) +! opt. thick from TOA + DO k = nlev-1, 1, -1 + tau_mol(:,k) = tau_mol(:,k) + tau_mol(:,k+1) + ENDDO + +! optical thickness (particles): + + tau_part = rdiffm * alpha_part + DO i = 1, npart +! opt. thick of each layer + tau_part(:,:,i) = tau_part(:,:,i) & + & * (zheight(:,2:nlev+1)-zheight(:,1:nlev) ) +! opt. thick from TOA + DO k = nlev-1, 1, -1 + tau_part(:,k,i) = tau_part(:,k,i) + tau_part(:,k+1,i) + ENDDO + ENDDO + +! molecular signal: +! Upper layer + pmol(:,nlev) = beta_mol(:,nlev) / (2.*tau_mol(:,nlev)) & + & * (1.-exp(-2.0*tau_mol(:,nlev))) +! Other layers + DO k= nlev-1, 1, -1 + tau_mol_lay(:) = tau_mol(:,k)-tau_mol(:,k+1) ! opt. thick. of layer k + WHERE (tau_mol_lay(:).GT.0.) + pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1)) / (2.*tau_mol_lay(:)) & + & * (1.-exp(-2.0*tau_mol_lay(:))) + ELSEWHERE +! This must never happend, but just in case, to avoid div. by 0 + pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1)) + END WHERE + END DO +! +! Total signal (molecular + particules): +! +! For performance reason on vector computers, the 2 following lines should not be used +! and should be replace by the later one. +! betatot(:,:) = beta_mol(:,:) + sum(kp_part*alpha_part,dim=3) +! tautot(:,:) = tau_mol(:,:) + sum(tau_part,dim=3) + betatot(:,:) = beta_mol(:,:) + tautot(:,:) = tau_mol(:,:) + DO i = 1, npart + betatot(:,:) = betatot(:,:) + kp_part(:,:,i)*alpha_part(:,:,i) + tautot(:,:) = tautot(:,:) + tau_part(:,:,i) + ENDDO ! i +! +! Upper layer + pnorm(:,nlev) = betatot(:,nlev) / (2.*tautot(:,nlev)) & + & * (1.-exp(-2.0*tautot(:,nlev))) +! Other layers + DO k= nlev-1, 1, -1 + tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k + WHERE (tautot_lay(:).GT.0.) + pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) & +!correc pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) & ! correc Satoh +!correc & / (2.0*tautot_lay(:)) & ! correc Satoh + & * (1.-EXP(-2.0*tautot_lay(:))) + ELSEWHERE +! This must never happend, but just in case, to avoid div. by 0 + pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) + END WHERE + END DO + + if (iflag_testlidar) then +!+JLD test +! do k=1,nlev +! print*,'Min val de frac_out=',k,minval(frac_out(:,k)) +! print*,'Max val de frac_out=',k,maxval(frac_out(:,k)) +! enddo + where ( frac_out(:,:).ge.0.5) +! Correction AI 9 5 11 pnorm(:,:) = pmol(:,:)*10. + pnorm(:,:) = pmol(:,:)*50. + elsewhere + pnorm(:,:) = pmol(:,:) + endwhere +!-JLD test + endif + +!-------- End computation Lidar -------------------------- + +!--------------------------------------------------------- +! Parasol/Polder module +! +! Purpose : Compute reflectance for one particular viewing direction +! and 5 solar zenith angles (calculation valid only over ocean) +! --------------------------------------------------------- + +! initialization: + refl(:,:) = 0.0 + +! activate parasol calculations: + if (ok_parasol) then + +! Optical thickness from TOA to surface + tautot_S_liq = 0. + tautot_S_ice = 0. + tautot_S_liq(:) = tautot_S_liq(:) & + + tau_part(:,1,1) + tau_part(:,1,3) + tautot_S_ice(:) = tautot_S_ice(:) & + + tau_part(:,1,2) + tau_part(:,1,4) + + call parasol(npoints,nrefl,undef & + ,tautot_S_liq,tautot_S_ice & + ,refl) + + endif ! ok_parasol + + END SUBROUTINE lidar_simulator +! +!--------------------------------------------------------------------------------- +! + SUBROUTINE parasol(npoints,nrefl,undef & + ,tautot_S_liq,tautot_S_ice & + ,refl) +!--------------------------------------------------------------------------------- +! Purpose: To compute Parasol reflectance signal from model-simulated profiles +! of cloud water and cloud fraction in each sub-column of each model +! gridbox. +! +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - optimization for vectorization +! +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +!--------------------------------------------------------------------------------- + + IMPLICIT NONE + +! inputs + INTEGER npoints ! Number of horizontal gridpoints + INTEGER nrefl ! Number of angles for which the reflectance + ! is computed. Can not be greater then ntetas + REAL undef ! Undefined value. Currently not used + REAL tautot_S_liq(npoints) ! liquid water cloud optical thickness, + ! integrated from TOA to surface + REAL tautot_S_ice(npoints) ! same for ice water clouds only +! outputs + REAL refl(npoints,nrefl) ! Parasol reflectances +! +! Local variables + REAL tautot_S(npoints) ! cloud optical thickness, from TOA to surface + REAL frac_taucol_liq(npoints), frac_taucol_ice(npoints) + + REAL pi +! look up table variables: + INTEGER ny, it + INTEGER ntetas, nbtau ! number of angle and of optical thickness + ! of the look-up table + PARAMETER (ntetas=5, nbtau=7) + REAL aa(ntetas,nbtau-1), ab(ntetas,nbtau-1) + REAL ba(ntetas,nbtau-1), bb(ntetas,nbtau-1) + REAL tetas(ntetas),tau(nbtau) + REAL r_norm(ntetas) + REAL rlumA(ntetas,nbtau), rlumB(ntetas,nbtau) + REAL rlumA_mod(npoints,5), rlumB_mod(npoints,5) + + DATA tau /0., 1., 5., 10., 20., 50., 100./ + DATA tetas /0., 20., 40., 60., 80./ + +! Look-up table for spherical liquid particles: + DATA (rlumA(1,ny),ny=1,nbtau) /0.03, 0.090886, 0.283965, & + 0.480587, 0.695235, 0.908229, 1.0 / + DATA (rlumA(2,ny),ny=1,nbtau) /0.03, 0.072185, 0.252596, & + 0.436401, 0.631352, 0.823924, 0.909013 / + DATA (rlumA(3,ny),ny=1,nbtau) /0.03, 0.058410, 0.224707, & + 0.367451, 0.509180, 0.648152, 0.709554 / + DATA (rlumA(4,ny),ny=1,nbtau) /0.03, 0.052498, 0.175844, & + 0.252916, 0.326551, 0.398581, 0.430405 / + DATA (rlumA(5,ny),ny=1,nbtau) /0.03, 0.034730, 0.064488, & + 0.081667, 0.098215, 0.114411, 0.121567 / + +! Look-up table for ice particles: + DATA (rlumB(1,ny),ny=1,nbtau) /0.03, 0.092170, 0.311941, & + 0.511298, 0.712079 , 0.898243 , 0.976646 / + DATA (rlumB(2,ny),ny=1,nbtau) /0.03, 0.087082, 0.304293, & + 0.490879, 0.673565, 0.842026, 0.912966 / + DATA (rlumB(3,ny),ny=1,nbtau) /0.03, 0.083325, 0.285193, & + 0.430266, 0.563747, 0.685773, 0.737154 / + DATA (rlumB(4,ny),ny=1,nbtau) /0.03, 0.084935, 0.233450, & + 0.312280, 0.382376, 0.446371, 0.473317 / + DATA (rlumB(5,ny),ny=1,nbtau) /0.03, 0.054157, 0.089911, & + 0.107854, 0.124127, 0.139004, 0.145269 / + +!-------------------------------------------------------------------------------- +! Lum_norm=f(tetaS,tau_cloud) derived from adding-doubling calculations +! valid ONLY ABOVE OCEAN (albedo_sfce=5%) +! valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�) +! based on adding-doubling radiative transfer computation +! for tau values (0 to 100) and for tetas values (0 to 80) +! for 2 scattering phase functions: liquid spherical, ice non spherical + + IF ( nrefl.GT. ntetas ) THEN + PRINT *,'Error in lidar_simulator, nrefl should be less then ',ntetas,' not',nrefl + STOP + ENDIF + + rlumA_mod=0 + rlumB_mod=0 +! + pi = ACOS(-1.0) + r_norm(:)=1./ COS(pi/180.*tetas(:)) +! + tautot_S_liq(:)=MAX(tautot_S_liq(:),tau(1)) + tautot_S_ice(:)=MAX(tautot_S_ice(:),tau(1)) + tautot_S(:) = tautot_S_ice(:) + tautot_S_liq(:) +! +! relative fraction of the opt. thick due to liquid or ice clouds + WHERE (tautot_S(:) .GT. 0.) + frac_taucol_liq(:) = tautot_S_liq(:) / tautot_S(:) + frac_taucol_ice(:) = tautot_S_ice(:) / tautot_S(:) + ELSEWHERE + frac_taucol_liq(:) = 1. + frac_taucol_ice(:) = 0. + END WHERE + tautot_S(:)=MIN(tautot_S(:),tau(nbtau)) +! +! Linear interpolation : + + DO ny=1,nbtau-1 +! microphysics A (liquid clouds) + aA(:,ny) = (rlumA(:,ny+1)-rlumA(:,ny))/(tau(ny+1)-tau(ny)) + bA(:,ny) = rlumA(:,ny) - aA(:,ny)*tau(ny) +! microphysics B (ice clouds) + aB(:,ny) = (rlumB(:,ny+1)-rlumB(:,ny))/(tau(ny+1)-tau(ny)) + bB(:,ny) = rlumB(:,ny) - aB(:,ny)*tau(ny) + ENDDO +! + DO it=1,ntetas + DO ny=1,nbtau-1 + WHERE (tautot_S(:).GE.tau(ny).AND.tautot_S(:).LE.tau(ny+1)) + rlumA_mod(:,it) = aA(it,ny)*tautot_S(:) + bA(it,ny) + rlumB_mod(:,it) = aB(it,ny)*tautot_S(:) + bB(it,ny) + END WHERE + END DO + END DO +! + DO it=1,ntetas + refl(:,it) = frac_taucol_liq(:) * rlumA_mod(:,it) & + + frac_taucol_ice(:) * rlumB_mod(:,it) +! normalized radiance -> reflectance: + refl(:,it) = refl(:,it) * r_norm(it) + ENDDO + + RETURN + END SUBROUTINE parasol Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/llnl_stats.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/llnl_stats.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/llnl_stats.F90 (revision 1634) @@ -0,0 +1,135 @@ +! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation +! nor the names of its contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_LLNL_STATS + USE MOD_COSP_CONSTANTS + IMPLICIT NONE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- FUNCTION COSP_CFAD ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +FUNCTION COSP_CFAD(Npoints,Ncolumns,Nlevels,Nbins,x,xmin,xmax,bmin,bwidth) + ! Input arguments + integer,intent(in) :: Npoints,Ncolumns,Nlevels,Nbins + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: x + real,intent(in) :: xmin,xmax + real,intent(in) :: bmin,bwidth + + real,dimension(Npoints,Nbins,Nlevels) :: cosp_cfad + ! Local variables + integer :: i, j, k + integer :: ibin + + !--- Input arguments + ! Npoints: Number of horizontal points + ! Ncolumns: Number of subcolumns + ! Nlevels: Number of levels + ! Nbins: Number of x axis bins + ! x: variable to process (Npoints,Ncolumns,Nlevels) + ! xmin: minimum value allowed for x + ! xmax: minimum value allowed for x + ! bmin: mimumum value of first bin + ! bwidth: bin width + ! + ! Output: 2D histogram on each horizontal point (Npoints,Nbins,Nlevels) + + cosp_cfad = 0.0 + ! bwidth intervals in the range [bmin,bmax=bmin+Nbins*hwidth] + ! Valid x values smaller than bmin and larger than bmax are set + ! into the smallest bin and largest bin, respectively. + do j = 1, Nlevels, 1 + do k = 1, Ncolumns, 1 + do i = 1, Npoints, 1 + if (x(i,k,j) == R_GROUND) then + cosp_cfad(i,:,j) = R_UNDEF + elseif ((x(i,k,j) >= xmin) .and. (x(i,k,j) <= xmax)) then + ibin = ceiling((x(i,k,j) - bmin)/bwidth) + if (ibin > Nbins) ibin = Nbins + if (ibin < 1) ibin = 1 + cosp_cfad(i,ibin,j) = cosp_cfad(i,ibin,j) + 1.0 + end if + enddo !i + enddo !k + enddo !j + where ((cosp_cfad /= R_UNDEF).and.(cosp_cfad /= 0.0)) cosp_cfad = cosp_cfad / Ncolumns +END FUNCTION COSP_CFAD + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,beta_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc) + ! Input arguments + integer,intent(in) :: Npoints,Ncolumns,Nlevels + real,dimension(Npoints,Nlevels),intent(in) :: beta_mol ! Molecular backscatter + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot ! Total backscattered signal + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot ! Radar reflectivity + ! Output arguments + real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud + real,dimension(Npoints),intent(out) :: tcc + + ! local variables + real :: sc_ratio + real :: s_cld, s_att +! parameter (S_cld = 3.0) ! Previous thresold for cloud detection + parameter (S_cld = 5.0) ! New (dec 2008) thresold for cloud detection + parameter (s_att = 0.01) + integer :: flag_sat !first saturated level encountered from top + integer :: flag_cld !cloudy column + integer :: pr,i,j + + lidar_only_freq_cloud = 0.0 + tcc = 0.0 + do pr=1,Npoints + do i=1,Ncolumns + flag_sat = 0 + flag_cld = 0 + do j=Nlevels,1,-1 !top->surf + sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j) +! if ((pr == 1).and.(j==8)) print *, pr,i,j,sc_ratio,Ze_tot(pr,i,j) + if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j + if (Ze_tot(pr,i,j) .lt. -30.) then !radar can't detect cloud + if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then !lidar sense cloud +! if ((pr == 1).and.(j==8)) print *, 'L' + lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf + flag_cld=1 + endif + else !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.) +! if ((pr == 1).and.(j==8)) print *, 'R' + flag_cld=1 + endif + enddo !levels + if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1. + enddo !columns +! if (tcc(pr) > Ncolumns) then +! print *, 'tcc(',pr,'): ', tcc(pr) +! tcc(pr) = Ncolumns +! endif + enddo !points + lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns + tcc=tcc/Ncolumns + +END SUBROUTINE COSP_LIDAR_ONLY_CLOUD +END MODULE MOD_LLNL_STATS Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/lmd_ipsl_stats.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/lmd_ipsl_stats.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/lmd_ipsl_stats.F90 (revision 1634) @@ -0,0 +1,413 @@ +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its +! contributors may be used to endorse or promote products derived from this software without +! specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +!------------------------------------------------------------------------------------ +! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). +!------------------------------------------------------------------------------------ +MODULE MOD_LMD_IPSL_STATS + USE MOD_LLNL_STATS + IMPLICIT NONE + +CONTAINS + SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl & + ,pnorm,pmol,refl,land,pplay,undef,ok_lidar_cfad & + ,cfad2,srbval & + ,ncat,lidarcld,cldlayer,parasolrefl) +! +! ----------------------------------------------------------------------------------- +! Lidar outputs : +! +! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction +! from the lidar signals (ATB and molecular ATB) computed from model outputs +! + +! Compute CFADs of lidar scattering ratio SR and of depolarization index +! +! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - change of the cloud detection threshold S_cld from 3 to 5, for better +! with both day and night observations. The optical thinest clouds are missed. +! - remove of the detection of the first fully attenuated layer encountered from above. +! December 2008, A. Bodas-Salcedo: +! - Dimensions of pmol reduced to (npoints,llm) +! August 2009, A. Bodas-Salcedo: +! - Warning message regarding PARASOL being valid only over ocean deleted. +! February 2010, A. Bodas-Salcedo: +! - Undef passed into cosp_cfad_sr +! June 2010, T. Yokohata, T. Nishimura and K. Ogochi +! Optimisation of COSP_CFAD_SR +! +! Version 1.0 (June 2007) +! Version 1.1 (May 2008) +! Version 1.2 (June 2008) +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +! c------------------------------------------------------------------------------------ + +! c inputs : + integer npoints + integer ncol + integer llm + integer max_bin ! nb of bins for SR CFADs + integer ncat ! nb of cloud layer types (low,mid,high,total) + integer nrefl ! nb of solar zenith angles for parasol reflectances + + real undef ! undefined value + real pnorm(npoints,ncol,llm) ! lidar ATB + real pmol(npoints,llm) ! molecular ATB + real land(npoints) ! Landmask [0 - Ocean, 1 - Land] + real pplay(npoints,llm) ! pressure on model levels (Pa) + logical ok_lidar_cfad ! true if lidar CFAD diagnostics need to be computed + real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol + +! c outputs : + real lidarcld(npoints,llm) ! 3D "lidar" cloud fraction + real cldlayer(npoints,ncat) ! "lidar" cloud fraction (low, mid, high, total) + real cfad2(npoints,max_bin,llm) ! CFADs of SR + real srbval(max_bin) ! SR bins in CFADs + real parasolrefl(npoints,nrefl)! grid-averaged parasol reflectance + +! c threshold for cloud detection : + real S_clr + parameter (S_clr = 1.2) + real S_cld +! parameter (S_cld = 3.0) ! Previous thresold for cloud detection + parameter (S_cld = 5.0) ! New (dec 2008) thresold for cloud detection + real S_att + parameter (S_att = 0.01) + +! c local variables : + integer ic,k + real x3d(npoints,ncol,llm) + real x3d_c(npoints,llm),pnorm_c(npoints,llm) + real xmax +! +! c ------------------------------------------------------- +! c 0- Initializations +! c ------------------------------------------------------- +! + +! Should be modified in future version + xmax=undef-1.0 + +! c ------------------------------------------------------- +! c 1- Lidar scattering ratio : +! c ------------------------------------------------------- +! +! where ((pnorm.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) +! x3d = pnorm/pmol +! elsewhere +! x3d = undef +! end where +! A.B-S: pmol reduced to 2D (npoints,llm) (Dec 08) + do ic = 1, ncol + pnorm_c = pnorm(:,ic,:) + where ((pnorm_c.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) + x3d_c = pnorm_c/pmol + elsewhere + x3d_c = undef + end where + x3d(:,ic,:) = x3d_c + enddo + +! c ------------------------------------------------------- +! c 2- Diagnose cloud fractions (3D, low, middle, high, total) +! c from subgrid-scale lidar scattering ratios : +! c ------------------------------------------------------- + + CALL COSP_CLDFRAC(npoints,ncol,llm,ncat, & + x3d,pplay, S_att,S_cld,undef,lidarcld, & + cldlayer) + +! c ------------------------------------------------------- +! c 3- CFADs +! c ------------------------------------------------------- + if (ok_lidar_cfad) then +! +! c CFADs of subgrid-scale lidar scattering ratios : +! c ------------------------------------------------------- + CALL COSP_CFAD_SR(npoints,ncol,llm,max_bin,undef, & + x3d, & + S_att,S_clr,xmax,cfad2,srbval) + + endif ! ok_lidar_cfad +! c ------------------------------------------------------- + +! c ------------------------------------------------------- +! c 4- Compute grid-box averaged Parasol reflectances +! c ------------------------------------------------------- + + parasolrefl(:,:) = 0.0 + + do k = 1, nrefl + do ic = 1, ncol + parasolrefl(:,k) = parasolrefl(:,k) + refl(:,ic,k) + enddo + enddo + + do k = 1, nrefl + parasolrefl(:,k) = parasolrefl(:,k) / float(ncol) +! if land=1 -> parasolrefl=undef +! if land=0 -> parasolrefl=parasolrefl + parasolrefl(:,k) = parasolrefl(:,k) * MAX(1.0-land(:),0.0) & + + (1.0 - MAX(1.0-land(:),0.0))*undef + enddo + + RETURN + END SUBROUTINE diag_lidar + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- FUNCTION COSP_CFAD_SR ------------------------ +! Author: Sandrine Bony (LMD/IPSL, CNRS, Paris) +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CFAD_SR(Npoints,Ncolumns,Nlevels,Nbins,undef, & + x,S_att,S_clr,xmax,cfad,srbval) + IMPLICIT NONE + +!--- Input arguments +! Npoints: Number of horizontal points +! Ncolumns: Number of subcolumns +! Nlevels: Number of levels +! Nbins: Number of x axis bins +! xmax: maximum value allowed for x +! S_att: Threshold for full attenuation +! S_clr: Threshold for clear-sky layer +! +!--- Input-Outout arguments +! x: variable to process (Npoints,Ncolumns,Nlevels), mofified where saturation occurs +! +! -- Output arguments +! srbval : values of the histogram bins +! cfad: 2D histogram on each horizontal point + +! Input arguments + integer Npoints,Ncolumns,Nlevels,Nbins + real xmax,S_att,S_clr,undef +! Input-output arguments + real x(Npoints,Ncolumns,Nlevels) +! Output : + real cfad(Npoints,Nbins,Nlevels) + real srbval(Nbins) +! Local variables + integer i, j, k, ib + real srbval_ext(0:Nbins) + +! c ------------------------------------------------------- +! c 0- Initializations +! c ------------------------------------------------------- + if ( Nbins .lt. 6) return + + srbval(1) = S_att + srbval(2) = S_clr + srbval(3) = 3.0 + srbval(4) = 5.0 + srbval(5) = 7.0 + srbval(6) = 10.0 + do i = 7, MIN(10,Nbins) + srbval(i) = srbval(i-1) + 5.0 + enddo + DO i = 11, MIN(13,Nbins) + srbval(i) = srbval(i-1) + 10.0 + enddo + srbval(MIN(14,Nbins)) = 80.0 + srbval(Nbins) = xmax + cfad(:,:,:) = 0.0 + + srbval_ext(1:Nbins) = srbval + srbval_ext(0) = -1.0 +! c ------------------------------------------------------- +! c c- Compute CFAD +! c ------------------------------------------------------- + + do j = 1, Nlevels + do ib = 1, Nbins + do k = 1, Ncolumns + do i = 1, Npoints + if (x(i,k,j) /= undef) then + if ((x(i,k,j).gt.srbval_ext(ib-1)).and.(x(i,k,j).le.srbval_ext(ib))) & + cfad(i,ib,j) = cfad(i,ib,j) + 1.0 + else + cfad(i,ib,j) = undef + endif + enddo + enddo + enddo + enddo + + where (cfad .ne. undef) cfad = cfad / float(Ncolumns) + +! c ------------------------------------------------------- + RETURN + END SUBROUTINE COSP_CFAD_SR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- SUBROUTINE COSP_CLDFRAC ------------------- +! c Purpose: Cloud fraction diagnosed from lidar measurements +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat, & + x,pplay,S_att,S_cld,undef,lidarcld, & + cldlayer) + IMPLICIT NONE +! Input arguments + integer Npoints,Ncolumns,Nlevels,Ncat + real x(Npoints,Ncolumns,Nlevels) + real pplay(Npoints,Nlevels) + real S_att,S_cld + real undef +! Output : + real lidarcld(Npoints,Nlevels) ! 3D cloud fraction + real cldlayer(Npoints,Ncat) ! low, middle, high, total cloud fractions +! Local variables + integer ip, k, iz, ic + real p1 + real cldy(Npoints,Ncolumns,Nlevels) + real srok(Npoints,Ncolumns,Nlevels) + real cldlay(Npoints,Ncolumns,Ncat) + real nsublay(Npoints,Ncolumns,Ncat), nsublayer(Npoints,Ncat) + real nsub(Npoints,Nlevels) + + real cldlay1(Npoints,Ncolumns) + real cldlay2(Npoints,Ncolumns) + real cldlay3(Npoints,Ncolumns) + real nsublay1(Npoints,Ncolumns) + real nsublay2(Npoints,Ncolumns) + real nsublay3(Npoints,Ncolumns) + + +! --------------------------------------------------------------- +! 1- initialization +! --------------------------------------------------------------- + + if ( Ncat .ne. 4 ) then + print *,'Error in lmd_ipsl_stats.cosp_cldfrac, Ncat must be 4, not',Ncat + stop + endif + + lidarcld = 0.0 + nsub = 0.0 + cldlay = 0.0 + nsublay = 0.0 + +! --------------------------------------------------------------- +! 2- Cloud detection +! --------------------------------------------------------------- + + do k = 1, Nlevels + +! cloud detection at subgrid-scale: + where ( (x(:,:,k).gt.S_cld) .and. (x(:,:,k).ne. undef) ) + cldy(:,:,k)=1.0 + elsewhere + cldy(:,:,k)=0.0 + endwhere + +! number of usefull sub-columns: + where ( (x(:,:,k).gt.S_att) .and. (x(:,:,k).ne. undef) ) + srok(:,:,k)=1.0 + elsewhere + srok(:,:,k)=0.0 + endwhere + + enddo ! k + +! --------------------------------------------------------------- +! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure +! categories) : +! --------------------------------------------------------------- + lidarcld = 0.0 + nsub = 0.0 + +!! XXX: Use cldlay[1-3] and nsublay[1-3] to avoid bank-conflicts. + cldlay1 = 0.0 + cldlay2 = 0.0 + cldlay3 = 0.0 + cldlay(:,:,4) = 0.0 !! XXX: Ncat == 4 + nsublay1 = 0.0 + nsublay2 = 0.0 + nsublay3 = 0.0 + nsublay(:,:,4) = 0.0 + do k = Nlevels, 1, -1 + do ic = 1, Ncolumns + do ip = 1, Npoints + p1 = pplay(ip,k) + + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds + cldlay3(ip,ic) = MAX(cldlay3(ip,ic), cldy(ip,ic,k)) + nsublay3(ip,ic) = MAX(nsublay3(ip,ic), srok(ip,ic,k)) + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid clouds + cldlay2(ip,ic) = MAX(cldlay2(ip,ic), cldy(ip,ic,k)) + nsublay2(ip,ic) = MAX(nsublay2(ip,ic), srok(ip,ic,k)) + else + cldlay1(ip,ic) = MAX(cldlay1(ip,ic), cldy(ip,ic,k)) + nsublay1(ip,ic) = MAX(nsublay1(ip,ic), srok(ip,ic,k)) + endif + + cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4), cldy(ip,ic,k)) + lidarcld(ip,k)=lidarcld(ip,k) + cldy(ip,ic,k) + nsublay(ip,ic,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k)) + nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k) + enddo + enddo + enddo + cldlay(:,:,1) = cldlay1 + cldlay(:,:,2) = cldlay2 + cldlay(:,:,3) = cldlay3 + nsublay(:,:,1) = nsublay1 + nsublay(:,:,2) = nsublay2 + nsublay(:,:,3) = nsublay3 + +! -- grid-box 3D cloud fraction + + where ( nsub(:,:).gt.0.0 ) + lidarcld(:,:) = lidarcld(:,:)/nsub(:,:) + elsewhere + lidarcld(:,:) = undef + endwhere + +! -- layered cloud fractions + + cldlayer = 0.0 + nsublayer = 0.0 + + do iz = 1, Ncat + do ic = 1, Ncolumns + + cldlayer(:,iz)=cldlayer(:,iz) + cldlay(:,ic,iz) + nsublayer(:,iz)=nsublayer(:,iz) + nsublay(:,ic,iz) + + enddo + enddo + where ( nsublayer(:,:).gt.0.0 ) + cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:) + elsewhere + cldlayer(:,:) = undef + endwhere + + RETURN + END SUBROUTINE COSP_CLDFRAC +! --------------------------------------------------------------- + +END MODULE MOD_LMD_IPSL_STATS Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/load_hydrometeor_classes.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/load_hydrometeor_classes.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/load_hydrometeor_classes.F90 (revision 1634) @@ -0,0 +1,54 @@ + subroutine load_hydrometeor_classes(Nprmts_max,dist_prmts_hydro,hp,nhclass) + use radar_simulator_types + implicit none + +! Purpose: +! Loads the hydrometeor classes to be used in calculations +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [dist_prmts_hydro] from data in hydrometeor class input +! +! Outputs: +! [hp] structure that define hydrometeor types +! +! Modified: +! 08/23/2006 placed into subroutine form (Roger Marchand) + +! ----- INPUT ----- + integer, intent(in) :: nhclass,Nprmts_max + real,dimension(Nprmts_max,nhclass), intent(in) :: dist_prmts_hydro +! ----- OUTPUTS ----- + type(class_param), intent(out) :: hp + +! ----- INTERNAL ----- + integer :: i + + hp%rho(:) = -1 + + do i = 1,nhclass,1 + hp%dtype(i) = dist_prmts_hydro(1,i) + hp%col(i) = dist_prmts_hydro(2,i) + hp%phase(i) = dist_prmts_hydro(3,i) + hp%cp(i) = dist_prmts_hydro(4,i) + hp%dmin(i) = dist_prmts_hydro(5,i) + hp%dmax(i) = dist_prmts_hydro(6,i) + hp%apm(i) = dist_prmts_hydro(7,i) + hp%bpm(i) = dist_prmts_hydro(8,i) + hp%rho(i) = dist_prmts_hydro(9,i) + hp%p1(i) = dist_prmts_hydro(10,i) + hp%p2(i) = dist_prmts_hydro(11,i) + hp%p3(i) = dist_prmts_hydro(12,i) + enddo + +! // setup scaling arrays + hp%fc = -999. + hp%scaled = .false. + hp%z_flag = .false. + hp%rho_eff = -999. + hp%ifc = -9 + hp%idd = -9 + + + end subroutine load_hydrometeor_classes Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/load_mie_table.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/load_mie_table.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/load_mie_table.F90 (revision 1634) @@ -0,0 +1,69 @@ + subroutine load_mie_table(mie_table_name,mt) + use radar_simulator_types + implicit none + +! Purpose: +! Loads the Mie table data +! Part of Quickbeam v1.03 +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [mie_table_name] Mie table input file +! +! Outputs: +! [mt] structure of Mie table data +! +! Created from Quickbeam v1.02 08/24/2006 by Roger Marchand + +! ----- INPUT ----- + character*200, intent(in) :: mie_table_name + +! ----- OUTPUT ----- + type(mie), intent(out) :: mt + +! ----- INTERNAL ----- + integer :: i + + integer*4 :: dummy_in(4) + + open(51,file=mie_table_name,action='read') + + read(51,*) dummy_in + + if(dummy_in(1).ne. mt_nfreq .or. & + dummy_in(2).ne. mt_ntt .or. & + dummy_in(3).ne. mt_nf .or. & + dummy_in(4).ne. mt_nd) then + + print *,'Mie file is of size :',dummy_in(:) + print *,' expected a size of:',mt_nfreq, mt_ntt,mt_nf,mt_nf + print *,' change paramters in radar_simulator_types.f90 ?? ' + stop + endif + + read(51,*) mt%freq + read(51,*) mt%tt + read(51,*) mt%f + read(51,*) mt%phase + read(51,*) mt%D + read(51,*) mt%qext + read(51,*) mt%qbsca + + close(51) + +! // create arrays of liquid/ice temperature + cnt_liq = 0 + cnt_ice = 0 + do i=1,mt_ntt + if (mt%phase(i) == 0) cnt_liq = cnt_liq + 1 + if (mt%phase(i) == 1) cnt_ice = cnt_ice + 1 + enddo + allocate(mt_ttl(cnt_liq),mt_tti(cnt_ice)) + do i=1,cnt_liq + mt_ttl(i) = mt%tt(i) + enddo + do i=1,cnt_ice + mt_tti(i) = mt%tt(cnt_liq+i) + enddo + + end subroutine load_mie_table Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/math_lib.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/math_lib.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/math_lib.F90 (revision 1634) @@ -0,0 +1,395 @@ +! MATH_LIB: Mathematics procedures for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! gamma (function) +! path_integral (function) +! avint (subroutine) + + module math_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! function GAMMA +! ---------------------------------------------------------------------------- + function gamma(x) + implicit none +! +! Purpose: +! Returns the gamma function +! +! Input: +! [x] value to compute gamma function of +! +! Returns: +! gamma(x) +! +! Coded: +! 02/02/06 John Haynes (haynes@atmos.colostate.edu) +! (original code of unknown origin) + +! ----- INPUTS ----- + real*8, intent(in) :: x + +! ----- OUTPUTS ----- + real*8 :: gamma + +! ----- INTERNAL ----- + real*8 :: pi,ga,z,r,gr + real*8 :: g(26) + integer :: k,m1,m + + pi = acos(-1.) + if (x ==int(x)) then + if (x > 0.0) then + ga=1.0 + m1=x-1 + do k=2,m1 + ga=ga*k + enddo + else + ga=1.0+300 + endif + else + if (abs(x) > 1.0) then + z=abs(x) + m=int(z) + r=1.0 + do k=1,m + r=r*(z-k) + enddo + z=z-m + else + z=x + endif + data g/1.0,0.5772156649015329, & + -0.6558780715202538, -0.420026350340952d-1, & + 0.1665386113822915,-.421977345555443d-1, & + -.96219715278770d-2, .72189432466630d-2, & + -.11651675918591d-2, -.2152416741149d-3, & + .1280502823882d-3, -.201348547807d-4, & + -.12504934821d-5, .11330272320d-5, & + -.2056338417d-6, .61160950d-8, & + .50020075d-8, -.11812746d-8, & + .1043427d-9, .77823d-11, & + -.36968d-11, .51d-12, & + -.206d-13, -.54d-14, .14d-14, .1d-15/ + gr=g(26) + do k=25,1,-1 + gr=gr*z+g(k) + enddo + ga=1.0/(gr*z) + if (abs(x) > 1.0) then + ga=ga*r + if (x < 0.0) ga=-pi/(x*ga*sin(pi*x)) + endif + endif + gamma = ga + return + end function gamma + +! ---------------------------------------------------------------------------- +! function PATH_INTEGRAL +! ---------------------------------------------------------------------------- + function path_integral(f,s,i1,i2) + use m_mrgrnk + use array_lib + implicit none +! +! Purpose: +! evalues the integral (f ds) between f(index=i1) and f(index=i2) +! using the AVINT procedure +! +! Inputs: +! [f] functional values +! [s] abscissa values +! [i1] index of lower limit +! [i2] index of upper limit +! +! Returns: +! result of path integral +! +! Notes: +! [s] may be in forward or reverse numerical order +! +! Requires: +! mrgrnk package +! +! Created: +! 02/02/06 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, intent(in), dimension(:) :: f,s + integer, intent(in) :: i1, i2 + +! ---- OUTPUTS ----- + real*8 :: path_integral + +! ----- INTERNAL ----- + real*8 :: sumo, deltah, val + integer*4 :: nelm, j + integer*4, dimension(i2-i1+1) :: idx + real*8, dimension(i2-i1+1) :: f_rev, s_rev + + nelm = i2-i1+1 + if (nelm > 3) then + call mrgrnk(s(i1:i2),idx) + s_rev = s(idx) + f_rev = f(idx) + call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), & + s_rev(i1),s_rev(i2), val) + path_integral = val + else + sumo = 0. + do j=i1,i2 + deltah = abs(s(i1+1)-s(i1)) + sumo = sumo + f(j)*deltah + enddo + path_integral = sumo + endif + ! print *, sumo + + return + end function path_integral + +! ---------------------------------------------------------------------------- +! subroutine AVINT +! ---------------------------------------------------------------------------- + subroutine avint ( ftab, xtab, ntab, a_in, b_in, result ) + implicit none +! +! Purpose: +! estimate the integral of unevenly spaced data +! +! Inputs: +! [ftab] functional values +! [xtab] abscissa values +! [ntab] number of elements of [ftab] and [xtab] +! [a] lower limit of integration +! [b] upper limit of integration +! +! Outputs: +! [result] approximate value of integral +! +! Reference: +! From SLATEC libraries, in public domain +! +!*********************************************************************** +! +! AVINT estimates the integral of unevenly spaced data. +! +! Discussion: +! +! The method uses overlapping parabolas and smoothing. +! +! Modified: +! +! 30 October 2000 +! 4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of +! loop to allow vectorization. +! +! Reference: +! +! Philip Davis and Philip Rabinowitz, +! Methods of Numerical Integration, +! Blaisdell Publishing, 1967. +! +! P E Hennion, +! Algorithm 77, +! Interpolation, Differentiation and Integration, +! Communications of the Association for Computing Machinery, +! Volume 5, page 96, 1962. +! +! Parameters: +! +! Input, real ( kind = 8 ) FTAB(NTAB), the function values, +! FTAB(I) = F(XTAB(I)). +! +! Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the +! function values are given. The XTAB's must be distinct +! and in ascending order. +! +! Input, integer NTAB, the number of entries in FTAB and +! XTAB. NTAB must be at least 3. +! +! Input, real ( kind = 8 ) A, the lower limit of integration. A should +! be, but need not be, near one endpoint of the interval +! (X(1), X(NTAB)). +! +! Input, real ( kind = 8 ) B, the upper limit of integration. B should +! be, but need not be, near one endpoint of the interval +! (X(1), X(NTAB)). +! +! Output, real ( kind = 8 ) RESULT, the approximate value of the integral. + + integer, intent(in) :: ntab + + integer,parameter :: KR8 = selected_real_kind(15,300) + real ( kind = KR8 ), intent(in) :: a_in + real ( kind = KR8 ) a + real ( kind = KR8 ) atemp + real ( kind = KR8 ), intent(in) :: b_in + real ( kind = KR8 ) b + real ( kind = KR8 ) btemp + real ( kind = KR8 ) ca + real ( kind = KR8 ) cb + real ( kind = KR8 ) cc + real ( kind = KR8 ) ctemp + real ( kind = KR8 ), intent(in) :: ftab(ntab) + integer i + integer ihi + integer ilo + integer ind + real ( kind = KR8 ), intent(out) :: result + real ( kind = KR8 ) sum1 + real ( kind = KR8 ) syl + real ( kind = KR8 ) term1 + real ( kind = KR8 ) term2 + real ( kind = KR8 ) term3 + real ( kind = KR8 ) x1 + real ( kind = KR8 ) x2 + real ( kind = KR8 ) x3 + real ( kind = KR8 ), intent(in) :: xtab(ntab) + logical lerror + + lerror = .false. + a = a_in + b = b_in + + if ( ntab < 3 ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'AVINT - Fatal error!' + write ( *, '(a,i6)' ) ' NTAB is less than 3. NTAB = ', ntab + stop + end if + + do i = 2, ntab + if ( xtab(i) <= xtab(i-1) ) then + lerror = .true. + exit + end if + end do + + if (lerror) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'AVINT - Fatal error!' + write ( *, '(a)' ) ' XTAB(I) is not greater than XTAB(I-1).' + write ( *, '(a,i6)' ) ' Here, I = ', i + write ( *, '(a,g14.6)' ) ' XTAB(I-1) = ', xtab(i-1) + write ( *, '(a,g14.6)' ) ' XTAB(I) = ', xtab(i) + stop + end if + + result = 0.0D+00 + + if ( a == b ) then + write ( *, '(a)' ) ' ' + write ( *, '(a)' ) 'AVINT - Warning!' + write ( *, '(a)' ) ' A = B, integral=0.' + return + end if +! +! If B < A, temporarily switch A and B, and store sign. +! + if ( b < a ) then + syl = b + b = a + a = syl + ind = -1 + else + syl = a + ind = 1 + end if +! +! Bracket A and B between XTAB(ILO) and XTAB(IHI). +! + ilo = 1 + ihi = ntab + + do i = 1, ntab + if ( a <= xtab(i) ) then + exit + end if + ilo = ilo + 1 + end do + + ilo = max ( 2, ilo ) + ilo = min ( ilo, ntab - 1 ) + + do i = 1, ntab + if ( xtab(i) <= b ) then + exit + end if + ihi = ihi - 1 + end do + + ihi = min ( ihi, ntab - 1 ) + ihi = max ( ilo, ihi - 1 ) +! +! Carry out approximate integration from XTAB(ILO) to XTAB(IHI). +! + sum1 = 0.0D+00 + + do i = ilo, ihi + + x1 = xtab(i-1) + x2 = xtab(i) + x3 = xtab(i+1) + + term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) ) + term2 = ftab(i) / ( ( x2 - x1 ) * ( x2 - x3 ) ) + term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) ) + + atemp = term1 + term2 + term3 + + btemp = - ( x2 + x3 ) * term1 & + - ( x1 + x3 ) * term2 & + - ( x1 + x2 ) * term3 + + ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3 + + if ( i <= ilo ) then + ca = atemp + cb = btemp + cc = ctemp + else + ca = 0.5D+00 * ( atemp + ca ) + cb = 0.5D+00 * ( btemp + cb ) + cc = 0.5D+00 * ( ctemp + cc ) + end if + + sum1 = sum1 & + + ca * ( x2**3 - syl**3 ) / 3.0D+00 & + + cb * 0.5D+00 * ( x2**2 - syl**2 ) & + + cc * ( x2 - syl ) + + ca = atemp + cb = btemp + cc = ctemp + + syl = x2 + + end do + + result = sum1 & + + ca * ( b**3 - syl**3 ) / 3.0D+00 & + + cb * 0.5D+00 * ( b**2 - syl**2 ) & + + cc * ( b - syl ) +! +! Restore original values of A and B, reverse sign of integral +! because of earlier switch. +! + if ( ind /= 1 ) then + ind = 1 + syl = b + b = a + a = syl + result = -result + end if + + return + end subroutine avint + + end module math_lib Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/mrgrnk.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/mrgrnk.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/mrgrnk.F90 (revision 1634) @@ -0,0 +1,410 @@ +Module m_mrgrnk +Integer, Parameter :: kdp = selected_real_kind(15) +public :: mrgrnk +private :: kdp +private :: I_mrgrnk, D_mrgrnk +interface mrgrnk + module procedure D_mrgrnk, I_mrgrnk +end interface mrgrnk +contains + +Subroutine D_mrgrnk (XDONT, IRNGT) +! __________________________________________________________ +! MRGRNK = Merge-sort ranking of an array +! For performance reasons, the first 2 passes are taken +! out of the standard loop, and use dedicated coding. +! __________________________________________________________ +! __________________________________________________________ + Real (kind=kdp), Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT +! __________________________________________________________ + Real (kind=kdp) :: XVALA, XVALB +! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB +! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select +! +! Fill-in the index array, creating ordered couples +! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If +! +! We will now have ordered subsets A - B - A - B - ... +! and merge A and B couples into C - C - ... +! + LMTNA = 2 + LMTNC = 4 +! +! First iteration. The length of the ordered subsets goes from 2 to 4 +! + Do + If (NVAL <= 2) Exit +! +! Loop on merges of A and B into C +! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit +! +! 1 2 3 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit +! +! 1 3 2 +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 +! +! 3 1 2 +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If +! +! 1 2 3 4 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle +! +! 1 3 x x +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If +! +! 3 x x x +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else +! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do +! +! The Cs become As and Bs +! + LMTNA = 4 + Exit + End Do +! +! Iteration loop. Each time, the length of the ordered subsets +! is doubled. +! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC +! +! Loop on merges of A and B into C +! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 +! +! Shortcut for the case when the max of A is smaller +! than the min of B. This line may be activated when the +! initial set is already close to sorted. +! +! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE +! +! One steps in the C subset, that we build in the final rank array +! +! Make a copy of the rank array for the merge iteration +! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) +! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) +! + Do + IWRK = IWRK + 1 +! +! We still have unprocessed values in both A and B +! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then +! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If +! + End Do + End Do +! +! The Cs become As and Bs +! + LMTNA = 2 * LMTNA + End Do +! + Return +! +End Subroutine D_mrgrnk + +Subroutine I_mrgrnk (XDONT, IRNGT) +! __________________________________________________________ +! MRGRNK = Merge-sort ranking of an array +! For performance reasons, the first 2 passes are taken +! out of the standard loop, and use dedicated coding. +! __________________________________________________________ +! __________________________________________________________ + Integer, Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT +! __________________________________________________________ + Integer :: XVALA, XVALB +! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB +! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select +! +! Fill-in the index array, creating ordered couples +! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If +! +! We will now have ordered subsets A - B - A - B - ... +! and merge A and B couples into C - C - ... +! + LMTNA = 2 + LMTNC = 4 +! +! First iteration. The length of the ordered subsets goes from 2 to 4 +! + Do + If (NVAL <= 2) Exit +! +! Loop on merges of A and B into C +! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit +! +! 1 2 3 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit +! +! 1 3 2 +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 +! +! 3 1 2 +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If +! +! 1 2 3 4 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle +! +! 1 3 x x +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If +! +! 3 x x x +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else +! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do +! +! The Cs become As and Bs +! + LMTNA = 4 + Exit + End Do +! +! Iteration loop. Each time, the length of the ordered subsets +! is doubled. +! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC +! +! Loop on merges of A and B into C +! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 +! +! Shortcut for the case when the max of A is smaller +! than the min of B. This line may be activated when the +! initial set is already close to sorted. +! +! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE +! +! One steps in the C subset, that we build in the final rank array +! +! Make a copy of the rank array for the merge iteration +! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) +! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) +! + Do + IWRK = IWRK + 1 +! +! We still have unprocessed values in both A and B +! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then +! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If +! + End Do + End Do +! +! The Cs become As and Bs +! + LMTNA = 2 * LMTNA + End Do +! + Return +! +End Subroutine I_mrgrnk +end module m_mrgrnk Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/optics_lib.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/optics_lib.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/optics_lib.F90 (revision 1634) @@ -0,0 +1,747 @@ +! OPTICS_LIB: Optical proecures for for F90 +! Compiled/Modified: +! 07/01/06 John Haynes (haynes@atmos.colostate.edu) +! +! m_wat (subroutine) +! m_ice (subroutine) +! mie_int (subroutine) + + module optics_lib + implicit none + + contains + +! ---------------------------------------------------------------------------- +! subroutine M_WAT +! ---------------------------------------------------------------------------- + subroutine m_wat(freq, t, n_r, n_i) + implicit none +! +! Purpose: +! compute complex index of refraction of liquid water +! +! Inputs: +! [freq] frequency (GHz) +! [t] temperature (C) +! +! Outputs: +! [n_r] real part index of refraction +! [n_i] imaginary part index of refraction +! +! Reference: +! Based on the work of Ray (1972) +! +! Coded: +! 03/22/05 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, intent(in) :: freq,t + +! ----- OUTPUTS ----- + real*8, intent(out) :: n_r, n_i + +! ----- INTERNAL ----- + real*8 ld,es,ei,a,ls,sg,tm1,cos1,sin1 + real*8 e_r,e_i + real*8 pi + complex*16 e_comp, sq + + ld = 100.*2.99792458E8/(freq*1E9) + es = 78.54*(1-(4.579E-3*(t-25.)+1.19E-5*(t-25.)**2 & + -2.8E-8*(t-25.)**3)) + ei = 5.27137+0.021647*t-0.00131198*t**2 + a = -(16.8129/(t+273.))+0.0609265 + ls = 0.00033836*exp(2513.98/(t+273.)) + sg = 12.5664E8 + + tm1 = (ls/ld)**(1-a) + pi = acos(-1.D0) + cos1 = cos(0.5*a*pi) + sin1 = sin(0.5*a*pi) + + e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1.+2*tm1*sin1+tm1**2)) + e_i = (((es-ei)*tm1*cos1)/(1.+2*tm1*sin1+tm1**2)) & + +((sg*ld)/1.885E11) + + e_comp = dcmplx(e_r,e_i) + sq = sqrt(e_comp) + + n_r = real(sq) + n_i = aimag(sq) + + return + end subroutine m_wat + +! ---------------------------------------------------------------------------- +! subroutine M_ICE +! ---------------------------------------------------------------------------- + subroutine m_ice(freq,t,n_r,n_i) + implicit none +! +! Purpose: +! compute complex index of refraction of ice +! +! Inputs: +! [freq] frequency (GHz) +! [t] temperature (C) +! +! Outputs: +! [n_r] real part index of refraction +! [n_i] imaginary part index of refraction +! +! Reference: +! Fortran 90 port from IDL of REFICE by Stephen G. Warren +! +! Modified: +! 05/31/05 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + real*8, intent(in) :: freq, t + +! ----- OUTPUTS ----- + real*8, intent(out) :: n_r,n_i + +! Parameters: + integer*2 :: i,lt1,lt2,nwl,nwlt + parameter(nwl=468,nwlt=62) + + real*8 :: alam,cutice,pi,t1,t2,tk,wlmax,wlmin, & + x,x1,x2,y,y1,y2,ylo,yhi + + real*8 :: & + tabim(nwl),tabimt(nwlt,4),tabre(nwl),tabret(nwlt,4),temref(4), & + wl(nwl),wlt(nwlt) + +! Defines wavelength dependent complex index of refraction for ice. +! Allowable wavelength range extends from 0.045 microns to 8.6 meter +! temperature dependence only considered beyond 167 microns. +! +! interpolation is done n_r vs. log(xlam) +! n_r vs. t +! log(n_i) vs. log(xlam) +! log(n_i) vs. t +! +! Stephen G. Warren - 1983 +! Dept. of Atmospheric Sciences +! University of Washington +! Seattle, Wa 98195 +! +! Based on +! +! Warren,S.G.,1984. +! Optical constants of ice from the ultraviolet to the microwave. +! Applied Optics,23,1206-1225 +! +! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C + + data temref/272.16,268.16,253.16,213.16/ + + data wlmin,wlmax/0.045,8.6e6/ + data cutice/167.0/ + + data (wl(i),i=1,114)/ & + 0.4430e-01,0.4510e-01,0.4590e-01,0.4680e-01,0.4770e-01,0.4860e-01, & + 0.4960e-01,0.5060e-01,0.5170e-01,0.5280e-01,0.5390e-01,0.5510e-01, & + 0.5640e-01,0.5770e-01,0.5900e-01,0.6050e-01,0.6200e-01,0.6360e-01, & + 0.6530e-01,0.6700e-01,0.6890e-01,0.7080e-01,0.7290e-01,0.7380e-01, & + 0.7510e-01,0.7750e-01,0.8000e-01,0.8270e-01,0.8550e-01,0.8860e-01, & + 0.9180e-01,0.9300e-01,0.9540e-01,0.9920e-01,0.1033e+00,0.1078e+00, & + 0.1100e+00,0.1127e+00,0.1140e+00,0.1181e+00,0.1210e+00,0.1240e+00, & + 0.1272e+00,0.1295e+00,0.1305e+00,0.1319e+00,0.1333e+00,0.1348e+00, & + 0.1362e+00,0.1370e+00,0.1378e+00,0.1387e+00,0.1393e+00,0.1409e+00, & + 0.1425e+00,0.1435e+00,0.1442e+00,0.1450e+00,0.1459e+00,0.1468e+00, & + 0.1476e+00,0.1480e+00,0.1485e+00,0.1494e+00,0.1512e+00,0.1531e+00, & + 0.1540e+00,0.1550e+00,0.1569e+00,0.1580e+00,0.1589e+00,0.1610e+00, & + 0.1625e+00,0.1648e+00,0.1669e+00,0.1692e+00,0.1713e+00,0.1737e+00, & + 0.1757e+00,0.1779e+00,0.1802e+00,0.1809e+00,0.1821e+00,0.1833e+00, & + 0.1843e+00,0.1850e+00,0.1860e+00,0.1870e+00,0.1880e+00,0.1890e+00, & + 0.1900e+00,0.1910e+00,0.1930e+00,0.1950e+00,0.2100e+00,0.2500e+00, & + 0.3000e+00,0.3500e+00,0.4000e+00,0.4100e+00,0.4200e+00,0.4300e+00, & + 0.4400e+00,0.4500e+00,0.4600e+00,0.4700e+00,0.4800e+00,0.4900e+00, & + 0.5000e+00,0.5100e+00,0.5200e+00,0.5300e+00,0.5400e+00,0.5500e+00/ + data (wl(i),i=115,228)/ & + 0.5600e+00,0.5700e+00,0.5800e+00,0.5900e+00,0.6000e+00,0.6100e+00, & + 0.6200e+00,0.6300e+00,0.6400e+00,0.6500e+00,0.6600e+00,0.6700e+00, & + 0.6800e+00,0.6900e+00,0.7000e+00,0.7100e+00,0.7200e+00,0.7300e+00, & + 0.7400e+00,0.7500e+00,0.7600e+00,0.7700e+00,0.7800e+00,0.7900e+00, & + 0.8000e+00,0.8100e+00,0.8200e+00,0.8300e+00,0.8400e+00,0.8500e+00, & + 0.8600e+00,0.8700e+00,0.8800e+00,0.8900e+00,0.9000e+00,0.9100e+00, & + 0.9200e+00,0.9300e+00,0.9400e+00,0.9500e+00,0.9600e+00,0.9700e+00, & + 0.9800e+00,0.9900e+00,0.1000e+01,0.1010e+01,0.1020e+01,0.1030e+01, & + 0.1040e+01,0.1050e+01,0.1060e+01,0.1070e+01,0.1080e+01,0.1090e+01, & + 0.1100e+01,0.1110e+01,0.1120e+01,0.1130e+01,0.1140e+01,0.1150e+01, & + 0.1160e+01,0.1170e+01,0.1180e+01,0.1190e+01,0.1200e+01,0.1210e+01, & + 0.1220e+01,0.1230e+01,0.1240e+01,0.1250e+01,0.1260e+01,0.1270e+01, & + 0.1280e+01,0.1290e+01,0.1300e+01,0.1310e+01,0.1320e+01,0.1330e+01, & + 0.1340e+01,0.1350e+01,0.1360e+01,0.1370e+01,0.1380e+01,0.1390e+01, & + 0.1400e+01,0.1410e+01,0.1420e+01,0.1430e+01,0.1440e+01,0.1449e+01, & + 0.1460e+01,0.1471e+01,0.1481e+01,0.1493e+01,0.1504e+01,0.1515e+01, & + 0.1527e+01,0.1538e+01,0.1563e+01,0.1587e+01,0.1613e+01,0.1650e+01, & + 0.1680e+01,0.1700e+01,0.1730e+01,0.1760e+01,0.1800e+01,0.1830e+01, & + 0.1840e+01,0.1850e+01,0.1855e+01,0.1860e+01,0.1870e+01,0.1890e+01/ + data (wl(i),i=229,342)/ & + 0.1905e+01,0.1923e+01,0.1942e+01,0.1961e+01,0.1980e+01,0.2000e+01, & + 0.2020e+01,0.2041e+01,0.2062e+01,0.2083e+01,0.2105e+01,0.2130e+01, & + 0.2150e+01,0.2170e+01,0.2190e+01,0.2220e+01,0.2240e+01,0.2245e+01, & + 0.2250e+01,0.2260e+01,0.2270e+01,0.2290e+01,0.2310e+01,0.2330e+01, & + 0.2350e+01,0.2370e+01,0.2390e+01,0.2410e+01,0.2430e+01,0.2460e+01, & + 0.2500e+01,0.2520e+01,0.2550e+01,0.2565e+01,0.2580e+01,0.2590e+01, & + 0.2600e+01,0.2620e+01,0.2675e+01,0.2725e+01,0.2778e+01,0.2817e+01, & + 0.2833e+01,0.2849e+01,0.2865e+01,0.2882e+01,0.2899e+01,0.2915e+01, & + 0.2933e+01,0.2950e+01,0.2967e+01,0.2985e+01,0.3003e+01,0.3021e+01, & + 0.3040e+01,0.3058e+01,0.3077e+01,0.3096e+01,0.3115e+01,0.3135e+01, & + 0.3155e+01,0.3175e+01,0.3195e+01,0.3215e+01,0.3236e+01,0.3257e+01, & + 0.3279e+01,0.3300e+01,0.3322e+01,0.3345e+01,0.3367e+01,0.3390e+01, & + 0.3413e+01,0.3436e+01,0.3460e+01,0.3484e+01,0.3509e+01,0.3534e+01, & + 0.3559e+01,0.3624e+01,0.3732e+01,0.3775e+01,0.3847e+01,0.3969e+01, & + 0.4099e+01,0.4239e+01,0.4348e+01,0.4387e+01,0.4444e+01,0.4505e+01, & + 0.4547e+01,0.4560e+01,0.4580e+01,0.4719e+01,0.4904e+01,0.5000e+01, & + 0.5100e+01,0.5200e+01,0.5263e+01,0.5400e+01,0.5556e+01,0.5714e+01, & + 0.5747e+01,0.5780e+01,0.5814e+01,0.5848e+01,0.5882e+01,0.6061e+01, & + 0.6135e+01,0.6250e+01,0.6289e+01,0.6329e+01,0.6369e+01,0.6410e+01/ + data (wl(i),i=343,456)/ & + 0.6452e+01,0.6494e+01,0.6579e+01,0.6667e+01,0.6757e+01,0.6897e+01, & + 0.7042e+01,0.7143e+01,0.7246e+01,0.7353e+01,0.7463e+01,0.7576e+01, & + 0.7692e+01,0.7812e+01,0.7937e+01,0.8065e+01,0.8197e+01,0.8333e+01, & + 0.8475e+01,0.8696e+01,0.8929e+01,0.9091e+01,0.9259e+01,0.9524e+01, & + 0.9804e+01,0.1000e+02,0.1020e+02,0.1031e+02,0.1042e+02,0.1053e+02, & + 0.1064e+02,0.1075e+02,0.1087e+02,0.1100e+02,0.1111e+02,0.1136e+02, & + 0.1163e+02,0.1190e+02,0.1220e+02,0.1250e+02,0.1282e+02,0.1299e+02, & + 0.1316e+02,0.1333e+02,0.1351e+02,0.1370e+02,0.1389e+02,0.1408e+02, & + 0.1429e+02,0.1471e+02,0.1515e+02,0.1538e+02,0.1563e+02,0.1613e+02, & + 0.1639e+02,0.1667e+02,0.1695e+02,0.1724e+02,0.1818e+02,0.1887e+02, & + 0.1923e+02,0.1961e+02,0.2000e+02,0.2041e+02,0.2083e+02,0.2222e+02, & + 0.2260e+02,0.2305e+02,0.2360e+02,0.2460e+02,0.2500e+02,0.2600e+02, & + 0.2857e+02,0.3100e+02,0.3333e+02,0.3448e+02,0.3564e+02,0.3700e+02, & + 0.3824e+02,0.3960e+02,0.4114e+02,0.4276e+02,0.4358e+02,0.4458e+02, & + 0.4550e+02,0.4615e+02,0.4671e+02,0.4736e+02,0.4800e+02,0.4878e+02, & + 0.5003e+02,0.5128e+02,0.5275e+02,0.5350e+02,0.5424e+02,0.5500e+02, & + 0.5574e+02,0.5640e+02,0.5700e+02,0.5746e+02,0.5840e+02,0.5929e+02, & + 0.6000e+02,0.6100e+02,0.6125e+02,0.6250e+02,0.6378e+02,0.6467e+02, & + 0.6558e+02,0.6655e+02,0.6760e+02,0.6900e+02,0.7053e+02,0.7300e+02/ + data (wl(i),i=457,468)/ & + 0.7500e+02,0.7629e+02,0.8000e+02,0.8297e+02,0.8500e+02,0.8680e+02, & + 0.9080e+02,0.9517e+02,0.1000e+03,0.1200e+03,0.1500e+03,0.1670e+03/ + data wlt/ & + 0.1670e+03,0.1778e+03,0.1884e+03, & + 0.1995e+03,0.2113e+03,0.2239e+03,0.2371e+03,0.2512e+03,0.2661e+03, & + 0.2818e+03,0.2985e+03,0.3162e+03,0.3548e+03,0.3981e+03,0.4467e+03, & + 0.5012e+03,0.5623e+03,0.6310e+03,0.7943e+03,0.1000e+04,0.1259e+04, & + 0.2500e+04,0.5000e+04,0.1000e+05,0.2000e+05,0.3200e+05,0.3500e+05, & + 0.4000e+05,0.4500e+05,0.5000e+05,0.6000e+05,0.7000e+05,0.9000e+05, & + 0.1110e+06,0.1200e+06,0.1300e+06,0.1400e+06,0.1500e+06,0.1600e+06, & + 0.1700e+06,0.1800e+06,0.2000e+06,0.2500e+06,0.2900e+06,0.3200e+06, & + 0.3500e+06,0.3800e+06,0.4000e+06,0.4500e+06,0.5000e+06,0.6000e+06, & + 0.6400e+06,0.6800e+06,0.7200e+06,0.7600e+06,0.8000e+06,0.8400e+06, & + 0.9000e+06,0.1000e+07,0.2000e+07,0.5000e+07,0.8600e+07/ + data (tabre(i),i=1,114)/ & + 0.83441, 0.83676, 0.83729, 0.83771, 0.83827, 0.84038, & + 0.84719, 0.85522, 0.86047, 0.86248, 0.86157, 0.86093, & + 0.86419, 0.86916, 0.87764, 0.89296, 0.91041, 0.93089, & + 0.95373, 0.98188, 1.02334, 1.06735, 1.11197, 1.13134, & + 1.15747, 1.20045, 1.23840, 1.27325, 1.32157, 1.38958, & + 1.41644, 1.40906, 1.40063, 1.40169, 1.40934, 1.40221, & + 1.39240, 1.38424, 1.38075, 1.38186, 1.39634, 1.40918, & + 1.40256, 1.38013, 1.36303, 1.34144, 1.32377, 1.30605, & + 1.29054, 1.28890, 1.28931, 1.30190, 1.32025, 1.36302, & + 1.41872, 1.45834, 1.49028, 1.52128, 1.55376, 1.57782, & + 1.59636, 1.60652, 1.61172, 1.61919, 1.62522, 1.63404, & + 1.63689, 1.63833, 1.63720, 1.63233, 1.62222, 1.58269, & + 1.55635, 1.52453, 1.50320, 1.48498, 1.47226, 1.45991, & + 1.45115, 1.44272, 1.43498, 1.43280, 1.42924, 1.42602, & + 1.42323, 1.42143, 1.41897, 1.41660, 1.41434, 1.41216, & + 1.41006, 1.40805, 1.40423, 1.40067, 1.38004, 1.35085, & + 1.33394, 1.32492, 1.31940, 1.31854, 1.31775, 1.31702, & + 1.31633, 1.31569, 1.31509, 1.31452, 1.31399, 1.31349, & + 1.31302, 1.31257, 1.31215, 1.31175, 1.31136, 1.31099/ + data (tabre(i),i=115,228)/ & + 1.31064, 1.31031, 1.30999, 1.30968, 1.30938, 1.30909, & + 1.30882, 1.30855, 1.30829, 1.30804, 1.30780, 1.30756, & + 1.30733, 1.30710, 1.30688, 1.30667, 1.30646, 1.30625, & + 1.30605, 1.30585, 1.30566, 1.30547, 1.30528, 1.30509, & + 1.30491, 1.30473, 1.30455, 1.30437, 1.30419, 1.30402, & + 1.30385, 1.30367, 1.30350, 1.30333, 1.30316, 1.30299, & + 1.30283, 1.30266, 1.30249, 1.30232, 1.30216, 1.30199, & + 1.30182, 1.30166, 1.30149, 1.30132, 1.30116, 1.30099, & + 1.30082, 1.30065, 1.30048, 1.30031, 1.30014, 1.29997, & + 1.29979, 1.29962, 1.29945, 1.29927, 1.29909, 1.29891, & + 1.29873, 1.29855, 1.29837, 1.29818, 1.29800, 1.29781, & + 1.29762, 1.29743, 1.29724, 1.29705, 1.29686, 1.29666, & + 1.29646, 1.29626, 1.29605, 1.29584, 1.29563, 1.29542, & + 1.29521, 1.29499, 1.29476, 1.29453, 1.29430, 1.29406, & + 1.29381, 1.29355, 1.29327, 1.29299, 1.29272, 1.29252, & + 1.29228, 1.29205, 1.29186, 1.29167, 1.29150, 1.29130, & + 1.29106, 1.29083, 1.29025, 1.28962, 1.28891, 1.28784, & + 1.28689, 1.28623, 1.28521, 1.28413, 1.28261, 1.28137, & + 1.28093, 1.28047, 1.28022, 1.27998, 1.27948, 1.27849/ + data (tabre(i),i=229,342)/ & + 1.27774, 1.27691, 1.27610, 1.27535, 1.27471, 1.27404, & + 1.27329, 1.27240, 1.27139, 1.27029, 1.26901, 1.26736, & + 1.26591, 1.26441, 1.26284, 1.26036, 1.25860, 1.25815, & + 1.25768, 1.25675, 1.25579, 1.25383, 1.25179, 1.24967, & + 1.24745, 1.24512, 1.24266, 1.24004, 1.23725, 1.23270, & + 1.22583, 1.22198, 1.21548, 1.21184, 1.20790, 1.20507, & + 1.20209, 1.19566, 1.17411, 1.14734, 1.10766, 1.06739, & + 1.04762, 1.02650, 1.00357, 0.98197, 0.96503, 0.95962, & + 0.97269, 0.99172, 1.00668, 1.02186, 1.04270, 1.07597, & + 1.12954, 1.21267, 1.32509, 1.42599, 1.49656, 1.55095, & + 1.59988, 1.63631, 1.65024, 1.64278, 1.62691, 1.61284, & + 1.59245, 1.57329, 1.55770, 1.54129, 1.52654, 1.51139, & + 1.49725, 1.48453, 1.47209, 1.46125, 1.45132, 1.44215, & + 1.43366, 1.41553, 1.39417, 1.38732, 1.37735, 1.36448, & + 1.35414, 1.34456, 1.33882, 1.33807, 1.33847, 1.34053, & + 1.34287, 1.34418, 1.34634, 1.34422, 1.33453, 1.32897, & + 1.32333, 1.31800, 1.31432, 1.30623, 1.29722, 1.28898, & + 1.28730, 1.28603, 1.28509, 1.28535, 1.28813, 1.30156, & + 1.30901, 1.31720, 1.31893, 1.32039, 1.32201, 1.32239/ + data (tabre(i),i=343,456)/ & + 1.32149, 1.32036, 1.31814, 1.31705, 1.31807, 1.31953, & + 1.31933, 1.31896, 1.31909, 1.31796, 1.31631, 1.31542, & + 1.31540, 1.31552, 1.31455, 1.31193, 1.30677, 1.29934, & + 1.29253, 1.28389, 1.27401, 1.26724, 1.25990, 1.24510, & + 1.22241, 1.19913, 1.17150, 1.15528, 1.13700, 1.11808, & + 1.10134, 1.09083, 1.08734, 1.09254, 1.10654, 1.14779, & + 1.20202, 1.25825, 1.32305, 1.38574, 1.44478, 1.47170, & + 1.49619, 1.51652, 1.53328, 1.54900, 1.56276, 1.57317, & + 1.58028, 1.57918, 1.56672, 1.55869, 1.55081, 1.53807, & + 1.53296, 1.53220, 1.53340, 1.53289, 1.51705, 1.50097, & + 1.49681, 1.49928, 1.50153, 1.49856, 1.49053, 1.46070, & + 1.45182, 1.44223, 1.43158, 1.41385, 1.40676, 1.38955, & + 1.34894, 1.31039, 1.26420, 1.23656, 1.21663, 1.20233, & + 1.19640, 1.19969, 1.20860, 1.22173, 1.24166, 1.28175, & + 1.32784, 1.38657, 1.46486, 1.55323, 1.60379, 1.61877, & + 1.62963, 1.65712, 1.69810, 1.72065, 1.74865, 1.76736, & + 1.76476, 1.75011, 1.72327, 1.68490, 1.62398, 1.59596, & + 1.58514, 1.59917, 1.61405, 1.66625, 1.70663, 1.73713, & + 1.76860, 1.80343, 1.83296, 1.85682, 1.87411, 1.89110/ + data (tabre(i),i=457,468)/ & + 1.89918, 1.90432, 1.90329, 1.88744, 1.87499, 1.86702, & + 1.85361, 1.84250, 1.83225, 1.81914, 1.82268, 1.82961/ + data (tabret(i,1),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, & + 1.82748, 1.82224, 1.81718, 1.81204, 1.80704, 1.80250, & + 1.79834, 1.79482, 1.79214, 1.78843, 1.78601, 1.78434, & + 1.78322, 1.78248, 1.78201, 1.78170, 1.78160, 1.78190, & + 1.78300, 1.78430, 1.78520, 1.78620, 1.78660, 1.78680, & + 1.78690, 1.78700, 1.78700, 1.78710, 1.78710, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78800/ + data (tabret(i,2),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, 1.82748, & + 1.82224, 1.81718, 1.81204, 1.80704, 1.80250, 1.79834, & + 1.79482, 1.79214, 1.78843, 1.78601, 1.78434, 1.78322, & + 1.78248, 1.78201, 1.78170, 1.78160, 1.78190, 1.78300, & + 1.78430, 1.78520, 1.78610, 1.78630, 1.78640, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78720/ + data(tabret(i,3),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, 1.82748, 1.82224, & + 1.81718, 1.81204, 1.80704, 1.80250, 1.79834, 1.79482, & + 1.79214, 1.78843, 1.78601, 1.78434, 1.78322, 1.78248, & + 1.78201, 1.78160, 1.78140, 1.78160, 1.78220, 1.78310, & + 1.78380, 1.78390, 1.78400, 1.78400, 1.78400, 1.78400, & + 1.78400, 1.78390, 1.78380, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78400, 1.78450/ + data (tabret(i,4),i=1,nwlt)/ & + 1.82961, 1.83258, 1.83149, 1.82748, 1.82224, 1.81718, & + 1.81204, 1.80704, 1.80250, 1.79834, 1.79482, 1.79214, & + 1.78843, 1.78601, 1.78434, 1.78322, 1.78248, 1.78201, & + 1.78150, 1.78070, 1.78010, 1.77890, 1.77790, 1.77730, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77800/ + data(tabim(i),i=1,114)/ & + 0.1640e+00,0.1730e+00,0.1830e+00,0.1950e+00,0.2080e+00,0.2230e+00, & + 0.2400e+00,0.2500e+00,0.2590e+00,0.2680e+00,0.2790e+00,0.2970e+00, & + 0.3190e+00,0.3400e+00,0.3660e+00,0.3920e+00,0.4160e+00,0.4400e+00, & + 0.4640e+00,0.4920e+00,0.5170e+00,0.5280e+00,0.5330e+00,0.5340e+00, & + 0.5310e+00,0.5240e+00,0.5100e+00,0.5000e+00,0.4990e+00,0.4680e+00, & + 0.3800e+00,0.3600e+00,0.3390e+00,0.3180e+00,0.2910e+00,0.2510e+00, & + 0.2440e+00,0.2390e+00,0.2390e+00,0.2440e+00,0.2470e+00,0.2240e+00, & + 0.1950e+00,0.1740e+00,0.1720e+00,0.1800e+00,0.1940e+00,0.2130e+00, & + 0.2430e+00,0.2710e+00,0.2890e+00,0.3340e+00,0.3440e+00,0.3820e+00, & + 0.4010e+00,0.4065e+00,0.4050e+00,0.3890e+00,0.3770e+00,0.3450e+00, & + 0.3320e+00,0.3150e+00,0.2980e+00,0.2740e+00,0.2280e+00,0.1980e+00, & + 0.1720e+00,0.1560e+00,0.1100e+00,0.8300e-01,0.5800e-01,0.2200e-01, & + 0.1000e-01,0.3000e-02,0.1000e-02,0.3000e-03,0.1000e-03,0.3000e-04, & + 0.1000e-04,0.3000e-05,0.1000e-05,0.7000e-06,0.4000e-06,0.2000e-06, & + 0.1000e-06,0.6377e-07,0.3750e-07,0.2800e-07,0.2400e-07,0.2200e-07, & + 0.1900e-07,0.1750e-07,0.1640e-07,0.1590e-07,0.1325e-07,0.8623e-08, & + 0.5504e-08,0.3765e-08,0.2710e-08,0.2510e-08,0.2260e-08,0.2080e-08, & + 0.1910e-08,0.1540e-08,0.1530e-08,0.1550e-08,0.1640e-08,0.1780e-08, & + 0.1910e-08,0.2140e-08,0.2260e-08,0.2540e-08,0.2930e-08,0.3110e-08/ + data(tabim(i),i=115,228)/ & + 0.3290e-08,0.3520e-08,0.4040e-08,0.4880e-08,0.5730e-08,0.6890e-08, & + 0.8580e-08,0.1040e-07,0.1220e-07,0.1430e-07,0.1660e-07,0.1890e-07, & + 0.2090e-07,0.2400e-07,0.2900e-07,0.3440e-07,0.4030e-07,0.4300e-07, & + 0.4920e-07,0.5870e-07,0.7080e-07,0.8580e-07,0.1020e-06,0.1180e-06, & + 0.1340e-06,0.1400e-06,0.1430e-06,0.1450e-06,0.1510e-06,0.1830e-06, & + 0.2150e-06,0.2650e-06,0.3350e-06,0.3920e-06,0.4200e-06,0.4440e-06, & + 0.4740e-06,0.5110e-06,0.5530e-06,0.6020e-06,0.7550e-06,0.9260e-06, & + 0.1120e-05,0.1330e-05,0.1620e-05,0.2000e-05,0.2250e-05,0.2330e-05, & + 0.2330e-05,0.2170e-05,0.1960e-05,0.1810e-05,0.1740e-05,0.1730e-05, & + 0.1700e-05,0.1760e-05,0.1820e-05,0.2040e-05,0.2250e-05,0.2290e-05, & + 0.3040e-05,0.3840e-05,0.4770e-05,0.5760e-05,0.6710e-05,0.8660e-05, & + 0.1020e-04,0.1130e-04,0.1220e-04,0.1290e-04,0.1320e-04,0.1350e-04, & + 0.1330e-04,0.1320e-04,0.1320e-04,0.1310e-04,0.1320e-04,0.1320e-04, & + 0.1340e-04,0.1390e-04,0.1420e-04,0.1480e-04,0.1580e-04,0.1740e-04, & + 0.1980e-04,0.2500e-04,0.5400e-04,0.1040e-03,0.2030e-03,0.2708e-03, & + 0.3511e-03,0.4299e-03,0.5181e-03,0.5855e-03,0.5899e-03,0.5635e-03, & + 0.5480e-03,0.5266e-03,0.4394e-03,0.3701e-03,0.3372e-03,0.2410e-03, & + 0.1890e-03,0.1660e-03,0.1450e-03,0.1280e-03,0.1030e-03,0.8600e-04, & + 0.8220e-04,0.8030e-04,0.8500e-04,0.9900e-04,0.1500e-03,0.2950e-03/ + data(tabim(i),i=229,342)/ & + 0.4687e-03,0.7615e-03,0.1010e-02,0.1313e-02,0.1539e-02,0.1588e-02, & + 0.1540e-02,0.1412e-02,0.1244e-02,0.1068e-02,0.8414e-03,0.5650e-03, & + 0.4320e-03,0.3500e-03,0.2870e-03,0.2210e-03,0.2030e-03,0.2010e-03, & + 0.2030e-03,0.2140e-03,0.2320e-03,0.2890e-03,0.3810e-03,0.4620e-03, & + 0.5480e-03,0.6180e-03,0.6800e-03,0.7300e-03,0.7820e-03,0.8480e-03, & + 0.9250e-03,0.9200e-03,0.8920e-03,0.8700e-03,0.8900e-03,0.9300e-03, & + 0.1010e-02,0.1350e-02,0.3420e-02,0.7920e-02,0.2000e-01,0.3800e-01, & + 0.5200e-01,0.6800e-01,0.9230e-01,0.1270e+00,0.1690e+00,0.2210e+00, & + 0.2760e+00,0.3120e+00,0.3470e+00,0.3880e+00,0.4380e+00,0.4930e+00, & + 0.5540e+00,0.6120e+00,0.6250e+00,0.5930e+00,0.5390e+00,0.4910e+00, & + 0.4380e+00,0.3720e+00,0.3000e+00,0.2380e+00,0.1930e+00,0.1580e+00, & + 0.1210e+00,0.1030e+00,0.8360e-01,0.6680e-01,0.5400e-01,0.4220e-01, & + 0.3420e-01,0.2740e-01,0.2200e-01,0.1860e-01,0.1520e-01,0.1260e-01, & + 0.1060e-01,0.8020e-02,0.6850e-02,0.6600e-02,0.6960e-02,0.9160e-02, & + 0.1110e-01,0.1450e-01,0.2000e-01,0.2300e-01,0.2600e-01,0.2900e-01, & + 0.2930e-01,0.3000e-01,0.2850e-01,0.1730e-01,0.1290e-01,0.1200e-01, & + 0.1250e-01,0.1340e-01,0.1400e-01,0.1750e-01,0.2400e-01,0.3500e-01, & + 0.3800e-01,0.4200e-01,0.4600e-01,0.5200e-01,0.5700e-01,0.6900e-01, & + 0.7000e-01,0.6700e-01,0.6500e-01,0.6400e-01,0.6200e-01,0.5900e-01/ + data(tabim(i),i=343,456)/ & + 0.5700e-01,0.5600e-01,0.5500e-01,0.5700e-01,0.5800e-01,0.5700e-01, & + 0.5500e-01,0.5500e-01,0.5400e-01,0.5200e-01,0.5200e-01,0.5200e-01, & + 0.5200e-01,0.5000e-01,0.4700e-01,0.4300e-01,0.3900e-01,0.3700e-01, & + 0.3900e-01,0.4000e-01,0.4200e-01,0.4400e-01,0.4500e-01,0.4600e-01, & + 0.4700e-01,0.5100e-01,0.6500e-01,0.7500e-01,0.8800e-01,0.1080e+00, & + 0.1340e+00,0.1680e+00,0.2040e+00,0.2480e+00,0.2800e+00,0.3410e+00, & + 0.3790e+00,0.4090e+00,0.4220e+00,0.4220e+00,0.4030e+00,0.3890e+00, & + 0.3740e+00,0.3540e+00,0.3350e+00,0.3150e+00,0.2940e+00,0.2710e+00, & + 0.2460e+00,0.1980e+00,0.1640e+00,0.1520e+00,0.1420e+00,0.1280e+00, & + 0.1250e+00,0.1230e+00,0.1160e+00,0.1070e+00,0.7900e-01,0.7200e-01, & + 0.7600e-01,0.7500e-01,0.6700e-01,0.5500e-01,0.4500e-01,0.2900e-01, & + 0.2750e-01,0.2700e-01,0.2730e-01,0.2890e-01,0.3000e-01,0.3400e-01, & + 0.5300e-01,0.7550e-01,0.1060e+00,0.1350e+00,0.1761e+00,0.2229e+00, & + 0.2746e+00,0.3280e+00,0.3906e+00,0.4642e+00,0.5247e+00,0.5731e+00, & + 0.6362e+00,0.6839e+00,0.7091e+00,0.6790e+00,0.6250e+00,0.5654e+00, & + 0.5433e+00,0.5292e+00,0.5070e+00,0.4883e+00,0.4707e+00,0.4203e+00, & + 0.3771e+00,0.3376e+00,0.3056e+00,0.2835e+00,0.3170e+00,0.3517e+00, & + 0.3902e+00,0.4509e+00,0.4671e+00,0.4779e+00,0.4890e+00,0.4899e+00, & + 0.4873e+00,0.4766e+00,0.4508e+00,0.4193e+00,0.3880e+00,0.3433e+00/ + data(tabim(i),i=457,468)/ & + 0.3118e+00,0.2935e+00,0.2350e+00,0.1981e+00,0.1865e+00,0.1771e+00, & + 0.1620e+00,0.1490e+00,0.1390e+00,0.1200e+00,0.9620e-01,0.8300e-01/ + data(tabimt(i,1),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01, & + 0.4560e-01,0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01, & + 0.1760e-01,0.1665e-01,0.1620e-01,0.1550e-01,0.1470e-01,0.1390e-01, & + 0.1320e-01,0.1250e-01,0.1180e-01,0.1060e-01,0.9540e-02,0.8560e-02, & + 0.6210e-02,0.4490e-02,0.3240e-02,0.2340e-02,0.1880e-02,0.1740e-02, & + 0.1500e-02,0.1320e-02,0.1160e-02,0.8800e-03,0.6950e-03,0.4640e-03, & + 0.3400e-03,0.3110e-03,0.2940e-03,0.2790e-03,0.2700e-03,0.2640e-03, & + 0.2580e-03,0.2520e-03,0.2490e-03,0.2540e-03,0.2640e-03,0.2740e-03, & + 0.2890e-03,0.3050e-03,0.3150e-03,0.3460e-03,0.3820e-03,0.4620e-03, & + 0.5000e-03,0.5500e-03,0.5950e-03,0.6470e-03,0.6920e-03,0.7420e-03, & + 0.8200e-03,0.9700e-03,0.1950e-02,0.5780e-02,0.9700e-02/ + data(tabimt(i,2),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01, & + 0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01,0.1760e-01, & + 0.1665e-01,0.1600e-01,0.1500e-01,0.1400e-01,0.1310e-01,0.1230e-01, & + 0.1150e-01,0.1080e-01,0.9460e-02,0.8290e-02,0.7270e-02,0.4910e-02, & + 0.3300e-02,0.2220e-02,0.1490e-02,0.1140e-02,0.1060e-02,0.9480e-03, & + 0.8500e-03,0.7660e-03,0.6300e-03,0.5200e-03,0.3840e-03,0.2960e-03, & + 0.2700e-03,0.2520e-03,0.2440e-03,0.2360e-03,0.2300e-03,0.2280e-03, & + 0.2250e-03,0.2200e-03,0.2160e-03,0.2170e-03,0.2200e-03,0.2250e-03, & + 0.2320e-03,0.2390e-03,0.2600e-03,0.2860e-03,0.3560e-03,0.3830e-03, & + 0.4150e-03,0.4450e-03,0.4760e-03,0.5080e-03,0.5400e-03,0.5860e-03, & + 0.6780e-03,0.1280e-02,0.3550e-02,0.5600e-02/ + data(tabimt(i,3),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01,0.3790e-01, & + 0.3140e-01,0.2620e-01,0.2190e-01,0.1880e-01,0.1660e-01,0.1540e-01, & + 0.1470e-01,0.1350e-01,0.1250e-01,0.1150e-01,0.1060e-01,0.9770e-02, & + 0.9010e-02,0.7660e-02,0.6520e-02,0.5540e-02,0.3420e-02,0.2100e-02, & + 0.1290e-02,0.7930e-03,0.5700e-03,0.5350e-03,0.4820e-03,0.4380e-03, & + 0.4080e-03,0.3500e-03,0.3200e-03,0.2550e-03,0.2120e-03,0.2000e-03, & + 0.1860e-03,0.1750e-03,0.1660e-03,0.1560e-03,0.1490e-03,0.1440e-03, & + 0.1350e-03,0.1210e-03,0.1160e-03,0.1160e-03,0.1170e-03,0.1200e-03, & + 0.1230e-03,0.1320e-03,0.1440e-03,0.1680e-03,0.1800e-03,0.1900e-03, & + 0.2090e-03,0.2160e-03,0.2290e-03,0.2400e-03,0.2600e-03,0.2920e-03, & + 0.6100e-03,0.1020e-02,0.1810e-02/ + data(tabimt(i,4),i=1,nwlt)/ & + 0.8300e-01,0.6900e-01,0.5700e-01,0.4450e-01,0.3550e-01,0.2910e-01, & + 0.2440e-01,0.1970e-01,0.1670e-01,0.1400e-01,0.1235e-01,0.1080e-01, & + 0.8900e-02,0.7340e-02,0.6400e-02,0.5600e-02,0.5000e-02,0.4520e-02, & + 0.3680e-02,0.2990e-02,0.2490e-02,0.1550e-02,0.9610e-03,0.5950e-03, & + 0.3690e-03,0.2670e-03,0.2510e-03,0.2290e-03,0.2110e-03,0.1960e-03, & + 0.1730e-03,0.1550e-03,0.1310e-03,0.1130e-03,0.1060e-03,0.9900e-04, & + 0.9300e-04,0.8730e-04,0.8300e-04,0.7870e-04,0.7500e-04,0.6830e-04, & + 0.5600e-04,0.4960e-04,0.4550e-04,0.4210e-04,0.3910e-04,0.3760e-04, & + 0.3400e-04,0.3100e-04,0.2640e-04,0.2510e-04,0.2430e-04,0.2390e-04, & + 0.2370e-04,0.2380e-04,0.2400e-04,0.2460e-04,0.2660e-04,0.4450e-04, & + 0.8700e-04,0.1320e-03/ + + pi = acos(-1.0) + n_r=0.0 + n_i=0.0 + +! // convert frequency to wavelength (um) + alam=3E5/freq + if((alam < wlmin) .or. (alam > wlmax)) then + print *, 'm_ice: wavelength out of bounds' + stop + endif + +! // convert temperature to K + tk = t + 273.16 + + if (alam < cutice) then + +! // region from 0.045 microns to 167.0 microns - no temperature depend + do i=2,nwl + if(alam < wl(i)) continue + enddo + x1=log(wl(i-1)) + x2=log(wl(i)) + y1=tabre(i-1) + y2=tabre(i) + x=log(alam) + y=((x-x1)*(y2-y1)/(x2-x1))+y1 + n_r=y + y1=log(abs(tabim(i-1))) + y2=log(abs(tabim(i))) + y=((x-x1)*(y2-y1)/(x2-x1))+y1 + n_i=exp(y) + + else + +! // region from 167.0 microns to 8.6 meters - temperature dependence + if(tk > temref(1)) tk=temref(1) + if(tk < temref(4)) tk=temref(4) + do 11 i=2,4 + if(tk.ge.temref(i)) go to 12 + 11 continue + 12 lt1=i + lt2=i-1 + do 13 i=2,nwlt + if(alam.le.wlt(i)) go to 14 + 13 continue + 14 x1=log(wlt(i-1)) + x2=log(wlt(i)) + y1=tabret(i-1,lt1) + y2=tabret(i,lt1) + x=log(alam) + ylo=((x-x1)*(y2-y1)/(x2-x1))+y1 + y1=tabret(i-1,lt2) + y2=tabret(i,lt2) + yhi=((x-x1)*(y2-y1)/(x2-x1))+y1 + t1=temref(lt1) + t2=temref(lt2) + y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo + n_r=y + y1=log(abs(tabimt(i-1,lt1))) + y2=log(abs(tabimt(i,lt1))) + ylo=((x-x1)*(y2-y1)/(x2-x1))+y1 + y1=log(abs(tabimt(i-1,lt2))) + y2=log(abs(tabimt(i,lt2))) + yhi=((x-x1)*(y2-y1)/(x2-x1))+y1 + y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo + n_i=exp(y) + + endif + + end subroutine m_ice + +! ---------------------------------------------------------------------------- +! subroutine MIEINT +! ---------------------------------------------------------------------------- +! +! General purpose Mie scattering routine for single particles +! Author: R Grainger 1990 +! History: +! G Thomas, March 2005: Added calculation of Phase function and +! code to ensure correct calculation of backscatter coeficient +! Options/Extend_Source +! + Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error) + + Integer * 2 Imaxx + Parameter (Imaxx = 12000) + Real * 4 RIMax ! largest real part of refractive index + Parameter (RIMax = 2.5) + Real * 4 IRIMax ! largest imaginary part of refractive index + Parameter (IRIMax = -2) + Integer * 2 Itermax + Parameter (Itermax = 12000 * 2.5) + ! must be large enough to cope with the + ! largest possible nmx = x * abs(scm) + 15 + ! or nmx = Dx + 4.05*Dx**(1./3.) + 2.0 + Integer * 2 Imaxnp + Parameter (Imaxnp = 10000) ! Change this as required +! INPUT + Real * 8 Dx + Complex * 16 SCm + Integer * 4 Inp + Real * 8 Dqv(Inp) +! OUTPUT + Complex * 16 Xs1(InP) + Complex * 16 Xs2(InP) + Real * 8 Dqxt + Real * 8 Dqsc + Real * 8 Dg + Real * 8 Dbsc + Real * 8 DPh(InP) + Integer * 4 Error +! LOCAL + Integer * 2 I + Integer * 2 NStop + Integer * 2 NmX + Integer * 4 N ! N*N > 32767 ie N > 181 + Integer * 4 Inp2 + Real * 8 Chi,Chi0,Chi1 + Real * 8 APsi,APsi0,APsi1 + Real * 8 Pi0(Imaxnp) + Real * 8 Pi1(Imaxnp) + Real * 8 Taun(Imaxnp) + Real * 8 Psi,Psi0,Psi1 + Complex * 8 Ir + Complex * 16 Cm + Complex * 16 A,ANM1,APB + Complex * 16 B,BNM1,AMB + Complex * 16 D(Itermax) + Complex * 16 Sp(Imaxnp) + Complex * 16 Sm(Imaxnp) + Complex * 16 Xi,Xi0,Xi1 + Complex * 16 Y +! ACCELERATOR VARIABLES + Integer * 2 Tnp1 + Integer * 2 Tnm1 + Real * 8 Dn + Real * 8 Rnx + Real * 8 S(Imaxnp) + Real * 8 T(Imaxnp) + Real * 8 Turbo + Real * 8 A2 + Complex * 16 A1 + + If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then + Error = 1 + Return + EndIf + Cm = SCm + Ir = 1 / Cm + Y = Dx * Cm + If (Dx.Lt.0.02) Then + NStop = 2 + Else + If (Dx.Le.8.0) Then + NStop = Dx + 4.00*Dx**(1./3.) + 2.0 + Else + If (Dx.Lt. 4200.0) Then + NStop = Dx + 4.05*Dx**(1./3.) + 2.0 + Else + NStop = Dx + 4.00*Dx**(1./3.) + 2.0 + End If + End If + End If + NmX = Max(Real(NStop),Real(Abs(Y))) + 15. + If (Nmx .gt. Itermax) then + Error = 1 + Return + End If + Inp2 = Inp+1 + D(NmX) = Dcmplx(0,0) + Do N = Nmx-1,1,-1 + A1 = (N+1) / Y + D(N) = A1 - 1/(A1+D(N+1)) + End Do + Do I =1,Inp2 + Sm(I) = Dcmplx(0,0) + Sp(I) = Dcmplx(0,0) + Pi0(I) = 0 + Pi1(I) = 1 + End Do + Psi0 = Cos(Dx) + Psi1 = Sin(Dx) + Chi0 =-Sin(Dx) + Chi1 = Cos(Dx) + APsi0 = Psi0 + APsi1 = Psi1 + Xi0 = Dcmplx(APsi0,Chi0) + Xi1 = Dcmplx(APsi1,Chi1) + Dg = 0 + Dqsc = 0 + Dqxt = 0 + Tnp1 = 1 + Do N = 1,Nstop + DN = N + Tnp1 = Tnp1 + 2 + Tnm1 = Tnp1 - 2 + A2 = Tnp1 / (DN*(DN+1D0)) + Turbo = (DN+1D0) / DN + Rnx = DN/Dx + Psi = Dble(Tnm1)*Psi1/Dx - Psi0 + APsi = Psi + Chi = Tnm1*Chi1/Dx - Chi0 + Xi = Dcmplx(APsi,Chi) + A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)* Xi- Xi1) + B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)* Xi- Xi1) + Dqxt = Tnp1 * Dble(A + B) + Dqxt + Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc + If (N.Gt.1) then + Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN) + End If + Anm1 = A + Bnm1 = B + APB = A2 * (A + B) + AMB = A2 * (A - B) + Do I = 1,Inp2 + If (I.GT.Inp) Then + S(I) = -Pi1(I) + Else + S(I) = Dqv(I) * Pi1(I) + End If + T(I) = S(I) - Pi0(I) + Taun(I) = N*T(I) - Pi0(I) + Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I) + Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I) + Pi0(I) = Pi1(I) + Pi1(I) = S(I) + T(I)*Turbo + End Do + Psi0 = Psi1 + Psi1 = Psi + Apsi1 = Psi1 + Chi0 = Chi1 + Chi1 = Chi + Xi1 = Dcmplx(APsi1,Chi1) + End Do + If (Dg .GT.0) Dg = 2 * Dg / Dqsc + Dqsc = 2 * Dqsc / Dx**2 + Dqxt = 2 * Dqxt / Dx**2 + Do I = 1,Inp + Xs1(I) = (Sp(I)+Sm(I)) / 2 + Xs2(I) = (Sp(I)-Sm(I)) / 2 + Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc) + End Do + Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2 + Error = 0 + Return + End subroutine MieInt + + end module optics_lib Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/pf_to_mr.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/pf_to_mr.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/pf_to_mr.F (revision 1634) @@ -0,0 +1,128 @@ +! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation +! nor the names of its contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + subroutine pf_to_mr(npoints,nlev,ncol,rain_ls,snow_ls,grpl_ls, + & rain_cv,snow_cv,prec_frac, + & p,t,mx_rain_ls,mx_snow_ls,mx_grpl_ls, + & mx_rain_cv,mx_snow_cv) + + + implicit none + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER i,j,ilev,ibox + + REAL rain_ls(npoints,nlev),snow_ls(npoints,nlev) ! large-scale precipitation flux + REAL grpl_ls(npoints,nlev) + REAL rain_cv(npoints,nlev),snow_cv(npoints,nlev) ! convective precipitation flux + + REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky + ! 1 -> LS precipitation + ! 2 -> CONV precipitation + ! 3 -> both + REAL mx_rain_ls(npoints,ncol,nlev),mx_snow_ls(npoints,ncol,nlev) + REAL mx_grpl_ls(npoints,ncol,nlev) + REAL mx_rain_cv(npoints,ncol,nlev),mx_snow_cv(npoints,ncol,nlev) + REAL p(npoints,nlev),t(npoints,nlev) + REAL ar,as,ag,br,bs,bg,nr,ns,ng,rho0,rhor,rhos,rhog,rho + REAL term1r,term1s,term1g,term2r,term2s,term2g,term3 + REAL term4r_ls,term4s_ls,term4g_ls,term4r_cv,term4s_cv + REAL term1x2r,term1x2s,term1x2g,t123r,t123s,t123g + + ! method from Khairoutdinov and Randall (2003 JAS) + + ! --- List of constants from Appendix B + ! Constant in fall speed formula + ar=842. + as=4.84 + ag=94.5 + ! Exponent in fall speed formula + br=0.8 + bs=0.25 + bg=0.5 + ! Intercept parameter + nr=8.*1000.*1000. + ns=3.*1000.*1000. + ng=4.*1000.*1000. + ! Densities for air and hydrometeors + rho0=1.29 + rhor=1000. + rhos=100. + rhog=400. + ! Term 1 of Eq. (A19). + term1r=ar*17.8379/6. + term1s=as*8.28508/6. + term1g=ag*11.6317/6. + ! Term 2 of Eq. (A19). + term2r=(3.14159265*rhor*nr)**(-br/4.) + term2s=(3.14159265*rhos*ns)**(-bs/4.) + term2g=(3.14159265*rhog*ng)**(-bg/4.) + + term1x2r=term1r*term2r + term1x2s=term1s*term2s + term1x2g=term1g*term2g + do ilev=1,nlev + do j=1,npoints + rho=p(j,ilev)/(287.05*t(j,ilev)) + term3=(rho0/rho)**0.5 + ! Term 4 of Eq. (A19). + t123r=term1x2r*term3 + t123s=term1x2s*term3 + t123g=term1x2g*term3 + term4r_ls=rain_ls(j,ilev)/(t123r) + term4s_ls=snow_ls(j,ilev)/(t123s) + term4g_ls=grpl_ls(j,ilev)/(t123g) + term4r_cv=rain_cv(j,ilev)/(t123r) + term4s_cv=snow_cv(j,ilev)/(t123s) + do ibox=1,ncol + mx_rain_ls(j,ibox,ilev)=0. + mx_snow_ls(j,ibox,ilev)=0. + mx_grpl_ls(j,ibox,ilev)=0. + mx_rain_cv(j,ibox,ilev)=0. + mx_snow_cv(j,ibox,ilev)=0. + if ((prec_frac(j,ibox,ilev) .eq. 1.) .or. + & (prec_frac(j,ibox,ilev) .eq. 3.)) then + mx_rain_ls(j,ibox,ilev)= + & (term4r_ls**(1./(1.+br/4.)))/rho + mx_snow_ls(j,ibox,ilev)= + & (term4s_ls**(1./(1.+bs/4.)))/rho + mx_grpl_ls(j,ibox,ilev)= + & (term4g_ls**(1./(1.+bg/4.)))/rho + endif + if ((prec_frac(j,ibox,ilev) .eq. 2.) .or. + & (prec_frac(j,ibox,ilev) .eq. 3.)) then + mx_rain_cv(j,ibox,ilev)= + & (term4r_cv**(1./(1.+br/4.)))/rho + mx_snow_cv(j,ibox,ilev)= + & (term4s_cv**(1./(1.+bs/4.)))/rho + endif + enddo ! loop over ncol + enddo ! loop over npoints + enddo ! loop over nlev + + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/phys_cosp.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/phys_cosp.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/phys_cosp.F90 (revision 1634) @@ -0,0 +1,505 @@ +! Simulateur COSP : Cfmip Observation Simulator Package + +! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS +!Idelkadi Abderrahmane Aout-Septembre 2009 + + subroutine phys_cosp( itap,dtime,freq_cosp, & + ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & + ecrit_mth,ecrit_day,ecrit_hf, & + Nptslmdz,Nlevlmdz,lon,lat, presnivs,overlaplmdz, & + ref_liq,ref_ice,fracTerLic,u_wind,v_wind,phis,phi,ph,p,skt,t, & + sh,rh,tca,cca,mr_lsliq,mr_lsice,fl_lsrainI,fl_lssnowI, & + fl_ccrainI,fl_ccsnowI,mr_ozone,dtau_s,dem_s) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! Inputs : +! itap, !Increment de la physiq +! dtime, !Pas de temps physiq +! overlap, !Overlap type in SCOPS +! Npoints, !Nb de points de la grille physiq +! Nlevels, !Nb de niveaux verticaux +! Ncolumns, !Number of subcolumns +! lon,lat, !Longitudes et latitudes de la grille LMDZ +! ref_liq,ref_ice, !Rayons effectifs des particules liq et ice (en microm) +! fracTerLic, !Fraction terre a convertir en masque +! u_wind,v_wind, !Vents a 10m ??? +! phi, !Geopotentiel +! phis, !Geopotentiel sol +! ph, !pression pour chaque inter-couche +! p, !Pression aux milieux des couches +! skt,t, !Temp au sol et temp 3D +! sh, !Humidite specifique +! rh, !Humidite relatif +! tca, !Fraction nuageuse +! cca !Fraction nuageuse convective +! mr_lsliq, !Liq Cloud water content +! mr_lsice, !Ice Cloud water content +! mr_ccliq, !Convective Cloud Liquid water content +! mr_ccice, !Cloud ice water content +! fl_lsrain, !Large scale precipitation lic +! fl_lssnow, !Large scale precipitation ice +! fl_ccrain, !Convective precipitation lic +! fl_ccsnow, !Convective precipitation ice +! mr_ozone, !Concentration ozone (Kg/Kg) +! dem_s !Cloud optical emissivity +! dtau_s !Cloud optical thickness +! emsfc_lw = 1. !Surface emissivity dans radlwsw.F90 + +!!! Outputs : +! calipso2D, !Lidar Low/heigh/Mean/Total-level Cloud Fraction +! calipso3D, !Lidar Cloud Fraction (532 nm) +! cfadlidar, !Lidar Scattering Ratio CFAD (532 nm) +! parasolrefl, !PARASOL-like mono-directional reflectance +! atb, !Lidar Attenuated Total Backscatter (532 nm) +! betamol, !Lidar Molecular Backscatter (532 nm) +! cfaddbze, !Radar Reflectivity Factor CFAD (94 GHz) +! clcalipso2, !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat +! dbze, !Efective_reflectivity_factor +! cltlidarradar, !Lidar and Radar Total Cloud Fraction +! clMISR, !Cloud Fraction as Calculated by the MISR Simulator +! clisccp2, !Cloud Fraction as Calculated by the ISCCP Simulator +! boxtauisccp, !Optical Depth in Each Column as Calculated by the ISCCP Simulator +! boxptopisccp, !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator +! tclisccp, !Total Cloud Fraction as Calculated by the ISCCP Simulator +! ctpisccp, !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator +! tauisccp, !Mean Optical Depth as Calculated by the ISCCP Simulator +! albisccp, !Mean Cloud Albedo as Calculated by the ISCCP Simulator +! meantbisccp, !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +! meantbclrisccp !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_COSP + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + use ioipsl + use iophy + + IMPLICIT NONE + + ! Local variables + character(len=64),PARAMETER :: cosp_input_nl='cosp_input_nl.txt' + character(len=64),PARAMETER :: cosp_output_nl='cosp_output_nl.txt' + character(len=512), save :: finput ! Input file name + character(len=512), save :: cmor_nl + integer, save :: isccp_topheight,isccp_topheight_direction,overlap + integer,save :: Ncolumns ! Number of subcolumns in SCOPS +! integer,parameter :: Ncollmdz=20 + integer,parameter :: Ncolmax=100 + integer, save :: Npoints ! Number of gridpoints +!$OMP THREADPRIVATE(Npoints) + integer, save :: Nlevels ! Number of levels + Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F + integer, save :: Nlr ! Number of levels in statistical outputs + integer, save :: Npoints_it ! Max number of gridpoints to be processed in one iteration + integer :: i + type(cosp_config),save :: cfg ! Configuration options +!$OMP THREADPRIVATE(cfg) + type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP + type(cosp_subgrid) :: sgx ! Subgrid outputs + type(cosp_sgradar) :: sgradar ! Output from radar simulator + type(cosp_sglidar) :: sglidar ! Output from lidar simulator + type(cosp_isccp) :: isccp ! Output from ISCCP simulator + type(cosp_misr) :: misr ! Output from MISR simulator + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats + type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + + integer :: t0,t1,count_rate,count_max + integer :: Nlon,Nlat,geomode + real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw +!$OMP THREADPRIVATE(emsfc_lw) + integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels + real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem + integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay + integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type + integer, save :: platform,satellite,Instrument,Nchannels + logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff + +! Declaration necessaires pour les sorties IOIPSL + integer :: ii,idayref + real :: zjulian,zstoday,zstomth,zstohf,zout,ecrit_day,ecrit_hf,ecrit_mth + logical :: ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP + integer :: nhori,nvert,nvertp,nvertisccp,nvertm,nvertcol + integer, save :: nid_day_cosp,nid_mth_cosp,nid_hf_cosp +!$OMP THREADPRIVATE(nid_day_cosp,nid_mth_cosp,nid_hf_cosp) + logical, save :: debut_cosp=.true. +!$OMP THREADPRIVATE(debut_cosp) + integer :: itau_wcosp + character(len=2) :: str2 + real,dimension(Ncolmax) :: column_ax + character(len=10),save,dimension(Ncolmax) :: chcol + + integer, save :: Nlevout +!$OMP THREADPRIVATE(Nlevout) + + include "dimensions.h" + include "temps.h" + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM + integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) + real,dimension(Nptslmdz,Nlevlmdz) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + fl_lsrain,fl_lssnow,fl_ccrain,fl_ccsnow,fl_lsgrpl, & + zlev,zlev_half,mr_ozone,radliq,radice,dtau_s,dem_s,ref_liq,ref_ice + real,dimension(Nptslmdz,Nlevlmdz) :: fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI + real,dimension(Nptslmdz) :: lon,lat,skt,fracTerLic,u_wind,v_wind,phis + real,dimension(Nlevlmdz) :: presnivs + integer :: itap,k,ip + real :: dtime,freq_cosp + logical, parameter :: lCOSP=.FALSE. + +! + namelist/COSP_INPUT/cmor_nl,overlap,isccp_topheight,isccp_topheight_direction, & + npoints_it,ncolumns,nlevels,use_vgrid,nlr,csat_vgrid,finput, & + radar_freq,surface_radar,use_mie_tables, & + use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, & + lidar_ice_type,use_precipitation_fluxes,use_reff, & + platform,satellite,Instrument,Nchannels, & + Channels,Surfem,ZenAng,co2,ch4,n2o,co + +!---------------- End of declaration of variables -------------- + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Read namelist with COSP inputs +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + if (debut_cosp) then + NPoints=Nptslmdz + Nlevels=Nlevlmdz + +! Lecture du namelist input + CALL read_cosp_input + + do ii=1,Ncolumns + write(str2,'(i2.2)')ii + chcol(ii)="c"//str2 + column_ax(ii) = real(ii) + enddo + +! Clefs Outputs + call read_cosp_output_nl(cosp_output_nl,cfg) + + if (overlaplmdz.ne.overlap) then + print*,'Attention overlaplmdz different de overlap lu dans namelist ' + endif + print*,'Fin lecture Namelists, debut_cosp =',debut_cosp + + print*,' Cles sorties cosp :' + print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim + + endif ! debut_cosp + + print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', & + itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate local arrays +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! call system_clock(t0,count_rate,count_max) !!! Only for testing purposes + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate memory for gridbox type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for gridbox type...' + + call construct_cosp_gridbox(dble(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, & + use_precipitation_fluxes,use_reff, & + Platform,Satellite,Instrument,Nchannels,ZenAng, & + channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Here code to populate input structure +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + print *, 'Populating input structure...' + gbx%longitude = lon + gbx%latitude = lat + + gbx%p = p ! + gbx%ph = ph + gbx%zlev = phi/9.81 + + zlev_half(:,1) = phis(:)/9.81 + do k = 2, Nlevels + do ip = 1, Npoints + zlev_half(ip,k) = phi(ip,k)/9.81 + & + (phi(ip,k)-phi(ip,k-1))/9.81 * (ph(ip,k)-p(ip,k)) / (p(ip,k)-p(ip,k-1)) + enddo + enddo + gbx%zlev_half = zlev_half + + gbx%T = T + gbx%q = rh*100. + gbx%sh = sh + gbx%cca = cca !convective_cloud_amount (1) + gbx%tca = tca ! total_cloud_amount (1) + gbx%psfc = ph(:,1) !pression de surface + gbx%skt = skt !Skin temperature (K) + + do ip = 1, Npoints + if (fracTerLic(ip).ge.0.5) then + gbx%land(ip) = 1. + else + gbx%land(ip) = 0. + endif + enddo + gbx%mr_ozone = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg) +! A voir l equivalent LMDZ (u10m et v10m) + gbx%u_wind = u_wind !eastward_wind (m s-1) + gbx%v_wind = v_wind !northward_wind +! Attention + gbx%sunlit = 1 + +! A voir l equivalent LMDZ + mr_ccliq = 0.0 + mr_ccice = 0.0 + gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg) + gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic + gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid + gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice +! A revoir + fl_lsrain = fl_lsrainI + fl_ccrainI + fl_lssnow = fl_lssnowI + fl_ccsnowI + gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1) + gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow +! A voir l equivalent LMDZ + fl_lsgrpl=0. + fl_ccsnow = 0. + fl_ccrain = 0. + gbx%grpl_ls = fl_lsgrpl !flux_large_scale_cloud_graupel + gbx%rain_cv = fl_ccrain !flux_convective_cloud_rain + gbx%snow_cv = fl_ccsnow !flux_convective_cloud_snow + + gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6 + gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6 + + ! ISCCP simulator + gbx%dtau_s = dtau_s + gbx%dtau_c = 0. + gbx%dem_s = dem_s + gbx%dem_c = 0. + +! Surafce emissivity + emsfc_lw = 1. + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Define new vertical grid +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Defining new vertical grid...' + call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid) + + if (debut_cosp) then +! Creer le fichier de sorie, definir les variable de sortie + ! Axe verticale (Pa ou Km) + Nlevout = vgrid%Nlvgrid + + do ii=1,Ncolumns + column_ax(ii) = real(ii) + enddo + + if (ok_mensuelCOSP) then + include "ini_histmthCOSP.h" + endif + if (ok_journeCOSP) then + include "ini_histdayCOSP.h" + endif + if (ok_hfCOSP) then + include "ini_histhfCOSP.h" + endif + + debut_cosp=.false. + endif ! debut_cosp + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Allocate memory for other types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for other types...' + call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx) + call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar) + call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar) + call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar) + call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar) + call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp) + call construct_cosp_misr(cfg,Npoints,misr) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Call simulator +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Calling simulator...' + call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Write outputs to CMOR-compliant NetCDF +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! A traiter le cas ou l on a des valeurs indefinies +! Attention teste + +! if(1.eq.0)then + + + do k = 1,Nlevout + do ip = 1,Npoints + if(stlidar%lidarcld(ip,k).eq.R_UNDEF)then + stlidar%lidarcld(ip,k)=0. + endif + enddo + + + do ii= 1,SR_BINS + do ip = 1,Npoints + if(stlidar%cfad_sr(ip,ii,k).eq.R_UNDEF)then + stlidar%cfad_sr(ip,ii,k)=0. + endif + enddo + enddo + enddo + + do ip = 1,Npoints + do k = 1,Nlevlmdz + if(sglidar%beta_mol(ip,k).eq.R_UNDEF)then + sglidar%beta_mol(ip,k)=0. + endif + + do ii= 1,Ncolumns + if(sglidar%beta_tot(ip,ii,k).eq.R_UNDEF)then + sglidar%beta_tot(ip,ii,k)=0. + endif + enddo + + enddo !k = 1,Nlevlmdz + enddo !ip = 1,Npoints + + do k = 1,LIDAR_NCAT + do ip = 1,Npoints + if(stlidar%cldlayer(ip,k).eq.R_UNDEF)then + stlidar%cldlayer(ip,k)=0. + endif + enddo + enddo + +! endif + + do ip = 1,Npoints + if(isccp%totalcldarea(ip).eq.-1.E+30)then + isccp%totalcldarea(ip)=0. + endif + if(isccp%meanptop(ip).eq.-1.E+30)then + isccp%meanptop(ip)=0. + endif + if(isccp%meantaucld(ip).eq.-1.E+30)then + isccp%meantaucld(ip)=0. + endif + if(isccp%meanalbedocld(ip).eq.-1.E+30)then + isccp%meanalbedocld(ip)=0. + endif + if(isccp%meantb(ip).eq.-1.E+30)then + isccp%meantb(ip)=0. + endif + if(isccp%meantbclr(ip).eq.-1.E+30)then + isccp%meantbclr(ip)=0. + endif + + do k=1,7 + do ii=1,7 + if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then + isccp%fq_isccp(ip,ii,k)=0. + endif + enddo + enddo + + do ii=1,Ncolumns + if(isccp%boxtau(ip,ii).eq.-1.E+30)then + isccp%boxtau(ip,ii)=0. + endif + enddo + + do ii=1,Ncolumns + if(isccp%boxptop(ip,ii).eq.-1.E+30)then + isccp%boxptop(ip,ii)=0. + endif + enddo + enddo + + if (ok_mensuelCOSP) then + include "write_histmthCOSP.h" + endif + if (ok_journeCOSP) then + include "write_histdayCOSP.h" + endif + if (ok_hfCOSP ) then + include "write_histhfCOSP.h" + endif + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Deallocate memory in derived types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Deallocating memory...' + call free_cosp_gridbox(gbx) + call free_cosp_subgrid(sgx) + call free_cosp_sgradar(sgradar) + call free_cosp_radarstats(stradar) + call free_cosp_sglidar(sglidar) + call free_cosp_lidarstats(stlidar) + call free_cosp_isccp(isccp) + call free_cosp_misr(misr) + call free_cosp_vgrid(vgrid) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Time in s. Only for testing purposes +! call system_clock(t1,count_rate,count_max) +! print *,(t1-t0)*1.0/count_rate + + CONTAINS + + SUBROUTINE read_cosp_input + + IF (is_master) THEN + OPEN(10,file=cosp_input_nl,status='old') + READ(10,nml=cosp_input) + CLOSE(10) + ENDIF + CALL bcast(cmor_nl) + CALL bcast(overlap) + CALL bcast(isccp_topheight) + CALL bcast(isccp_topheight_direction) + CALL bcast(npoints_it) + CALL bcast(ncolumns) + CALL bcast(nlevels) + CALL bcast(use_vgrid) + CALL bcast(nlr) + CALL bcast(csat_vgrid) + CALL bcast(finput) + CALL bcast(radar_freq) + CALL bcast(surface_radar) + CALL bcast(use_mie_tables) + CALL bcast(use_gas_abs) + CALL bcast(do_ray) + CALL bcast(melt_lay) + CALL bcast(k2) + CALL bcast(Nprmts_max_hydro) + CALL bcast(Naero) + CALL bcast(Nprmts_max_aero) + CALL bcast(lidar_ice_type) + CALL bcast(use_precipitation_fluxes) + CALL bcast(use_reff) + CALL bcast(platform) + CALL bcast(satellite) + CALL bcast(Instrument) + CALL bcast(Nchannels) + CALL bcast(Channels) + CALL bcast(Surfem) + CALL bcast(ZenAng) + CALL bcast(co2) + CALL bcast(ch4) + CALL bcast(n2o) + CALL bcast(co) +!$OMP BARRIER + END SUBROUTINE read_cosp_input + +end subroutine phys_cosp Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/phys_cosp.F90.prev =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/phys_cosp.F90.prev (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/phys_cosp.F90.prev (revision 1634) @@ -0,0 +1,456 @@ +! Simulateur COSP : Cfmip Observation Simulator Package +! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS +!Idelkadi Abderrahmane Aout-Septembre 2009 + + subroutine phys_cosp( itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf, & + overlaplmdz,Nptslmdz,Nlevlmdz,lon,lat, presnivs, & + ref_liq,ref_ice,fracTerLic,u_wind,v_wind,phi,ph,p,skt,t, & + sh,rh,tca,cca,mr_lsliq,mr_lsice,fl_lsrainI,fl_lssnowI, & + fl_ccrainI,fl_ccsnowI,mr_ozone,dtau_s,dem_s) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! Inputs : +! itap, !Increment de la physiq +! dtime, !Pas de temps physiq +! overlap, !Overlap type in SCOPS +! Npoints, !Nb de points de la grille physiq +! Nlevels, !Nb de niveaux verticaux +! Ncolumns, !Number of subcolumns +! lon,lat, !Longitudes et latitudes de la grille LMDZ +! ref_liq,ref_ice, !Rayons effectifs des particules liq et ice (en microm) +! fracTerLic, !Fraction terre a convertir en masque +! u_wind,v_wind, !Vents a 10m ??? +! phi, !Geopotentiel +! ph, !pression pour chaque inter-couche +! p, !Pression aux milieux des couches +! skt,t, !Temp au sol et temp 3D +! sh, !Humidite specifique +! rh, !Humidite relatif +! tca, !Fraction nuageuse +! cca !Fraction nuageuse convective +! mr_lsliq, !Liq Cloud water content +! mr_lsice, !Ice Cloud water content +! mr_ccliq, !Convective Cloud Liquid water content +! mr_ccice, !Cloud ice water content +! fl_lsrain, !Large scale precipitation lic +! fl_lssnow, !Large scale precipitation ice +! fl_ccrain, !Convective precipitation lic +! fl_ccsnow, !Convective precipitation ice +! mr_ozone, !Concentration ozone (Kg/Kg) +! dem_s !Cloud optical emissivity +! dtau_s !Cloud optical thickness +! emsfc_lw = 1. !Surface emissivity dans radlwsw.F90 + +!!! Outputs : +! calipso2D, !Lidar Low/heigh/Mean/Total-level Cloud Fraction +! calipso3D, !Lidar Cloud Fraction (532 nm) +! cfadlidar, !Lidar Scattering Ratio CFAD (532 nm) +! parasolrefl, !PARASOL-like mono-directional reflectance +! atb, !Lidar Attenuated Total Backscatter (532 nm) +! betamol, !Lidar Molecular Backscatter (532 nm) +! cfaddbze, !Radar Reflectivity Factor CFAD (94 GHz) +! clcalipso2, !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat +! dbze, !Efective_reflectivity_factor +! cltlidarradar, !Lidar and Radar Total Cloud Fraction +! clMISR, !Cloud Fraction as Calculated by the MISR Simulator +! clisccp2, !Cloud Fraction as Calculated by the ISCCP Simulator +! boxtauisccp, !Optical Depth in Each Column as Calculated by the ISCCP Simulator +! boxptopisccp, !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator +! tclisccp, !Total Cloud Fraction as Calculated by the ISCCP Simulator +! ctpisccp, !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator +! tauisccp, !Mean Optical Depth as Calculated by the ISCCP Simulator +! albisccp, !Mean Cloud Albedo as Calculated by the ISCCP Simulator +! meantbisccp, !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +! meantbclrisccp !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_COSP + USE mod_phys_lmdz_para + use ioipsl + use iophy + + IMPLICIT NONE + + ! Local variables + character(len=64) :: cosp_input_nl='cosp_input_nl.txt' + character(len=64) :: cosp_output_nl='cosp_output_nl.txt' + character(len=512), save :: finput ! Input file name + character(len=512), save :: cmor_nl + integer, save :: isccp_topheight,isccp_topheight_direction,overlap + integer,save :: Ncolumns ! Number of subcolumns in SCOPS + integer,parameter :: Ncollmdz=20 + integer, save :: Npoints ! Number of gridpoints + integer, save :: Nlevels ! Number of levels + Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F + integer, save :: Nlr ! Number of levels in statistical outputs + integer, save :: Npoints_it ! Max number of gridpoints to be processed in one iteration + integer :: i + type(cosp_config),save :: cfg ! Configuration options + type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP + type(cosp_subgrid) :: sgx ! Subgrid outputs + type(cosp_sgradar) :: sgradar ! Output from radar simulator + type(cosp_sglidar) :: sglidar ! Output from lidar simulator + type(cosp_isccp) :: isccp ! Output from ISCCP simulator + type(cosp_misr) :: misr ! Output from MISR simulator + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats + type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + + integer :: t0,t1,count_rate,count_max + integer :: Nlon,Nlat,geomode + real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw + integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels + real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem + integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay + integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type + integer, save :: platform,satellite,Instrument,Nchannels + logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff + +! Declaration necessaires pour les sorties IOIPSL + integer :: ii,idayref + real :: zjulian,zstoday,zstomth,zstohf,zout,ecrit_day,ecrit_hf,ecrit_mth + integer :: nhori,nvert,nvertp,nvertisccp,nvertm,nvertcol + integer, save :: nid_day_cosp,nid_mth_cosp,nid_hf_cosp + logical, save :: debut_cosp=.true. + integer :: itau_wcosp + character(len=10),dimension(Ncollmdz) :: chcol=(/'c01','c02','c03','c04','c05','c06','c07','c08','c09','c10', & + 'c11','c12','c13','c14','c15','c16','c17','c18','c19','c20'/) + real,dimension(Ncollmdz) :: column_ax + integer, save :: Nlevout + + include "dimensions.h" + include "temps.h" + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM + integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) +! real,dimension(Npoints,Nlevels) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + real,dimension(Nptslmdz,Nlevlmdz) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + fl_lsrain,fl_lssnow,fl_ccrain,fl_ccsnow,fl_lsgrpl, & + zlev,mr_ozone,radliq,radice,dtau_s,dem_s + real,dimension(Nptslmdz,Nlevlmdz) :: fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI + real,dimension(Nptslmdz) :: lon,lat,skt,fracTerLic,u_wind,v_wind + real,dimension(Nlevlmdz) :: presnivs + real :: ref_liq,ref_ice + integer :: itap,k,ip + real :: dtime,freq_cosp + +! + namelist/COSP_INPUT/cmor_nl,overlap,isccp_topheight,isccp_topheight_direction, & + npoints,npoints_it,ncolumns,nlevels,use_vgrid,nlr,csat_vgrid,finput, & + radar_freq,surface_radar,use_mie_tables, & + use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, & + lidar_ice_type,use_precipitation_fluxes,use_reff, & + platform,satellite,Instrument,Nchannels, & + Channels,Surfem,ZenAng,co2,ch4,n2o,co + +!---------------- End of declaration of variables -------------- + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Read namelist with COSP inputs +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + if (debut_cosp) then +! Lecture du namelist input + open(10,file=cosp_input_nl,status='old') + read(10,nml=cosp_input) + close(10) +! Clefs Outputs + call read_cosp_output_nl(cosp_output_nl,cfg) + + if ( (Ncollmdz.ne.Ncolumns).or.(Nptslmdz.ne.Npoints).or.(Nlevlmdz.ne.Nlevels) ) then + print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F = ', & + Nptslmdz, Nlevlmdz, Ncollmdz + print*,'Nb points Horiz, Vert, Sub-col lus dans namelist = ', & + Npoints, Nlevels, Ncolumns + print*,'Nb points Horiz, Vert, Sub-col passes par physiq.F est different de celui lu par namelist ' + call abort + endif + + if (overlaplmdz.ne.overlap) then + print*,'Attention overlaplmdz different de overlap lu dans namelist ' + endif + print*,'Fin lecture Namelists, debut_cosp =',debut_cosp + + endif ! debut_cosp + + print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', & + itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate local arrays +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! call system_clock(t0,count_rate,count_max) !!! Only for testing purposes + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate memory for gridbox type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for gridbox type...' + print*,'Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro ',Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro + print*,' Cles sorties cosp :' + print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lrttov_sim + call construct_cosp_gridbox(float(itap),radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, & + use_precipitation_fluxes,use_reff, & + Platform,Satellite,Instrument,Nchannels,ZenAng, & + channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Here code to populate input structure +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + print *, 'Populating input structure...' + gbx%longitude = lon + gbx%latitude = lat + + gbx%p = p ! + gbx%ph = ph + gbx%zlev_half = phi/9.81 + + do k = 1, Nlevels-1 + do ip = 1, Npoints + zlev(ip,k) = phi(ip,k)/9.81 + (phi(ip,k+1)-phi(ip,k))/9.81 * (ph(ip,k)-ph(ip,k+1))/p(ip,k) + enddo + enddo + do ip = 1, Npoints + zlev(ip,Nlevels) = zlev(ip,Nlevels-1)+ 2.*(phi(ip,Nlevels)/9.81-zlev(ip,Nlevels-1)) + END DO + gbx%zlev = zlev + + gbx%T = T + gbx%q = rh*100. + gbx%sh = sh + gbx%cca = cca !convective_cloud_amount (1) + gbx%tca = tca ! total_cloud_amount (1) + gbx%psfc = ph(:,1) !pression de surface + gbx%skt = skt !Skin temperature (K) + + do ip = 1, Npoints + if (fracTerLic(ip).ge.0.5) then + gbx%land(ip) = 1. + else + gbx%land(ip) = 0. + endif + enddo + gbx%mr_ozone = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg) +! A voir l equivalent LMDZ (u10m et v10m) + gbx%u_wind = u_wind !eastward_wind (m s-1) + gbx%v_wind = v_wind !northward_wind +! Attention + gbx%sunlit = 1 + +! A voir l equivalent LMDZ + mr_ccliq = 0.0 + mr_ccice = 0.0 + gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg) + gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic + gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid + gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice +! A revoir + fl_lsrain = fl_lsrainI + fl_ccrainI + fl_lssnow = fl_lssnowI + fl_ccsnowI + gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1) + gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow +! A voir l equivalent LMDZ + fl_lsgrpl=0. + fl_ccsnow = 0. + fl_ccrain = 0. + gbx%grpl_ls = fl_lsgrpl !flux_large_scale_cloud_graupel + gbx%rain_cv = fl_ccrain !flux_convective_cloud_rain + gbx%snow_cv = fl_ccsnow !flux_convective_cloud_snow + +!Attention Teste + do k = 1, Nlevels + do ip = 1, Npoints +! liquid particles : + radliq(ip,k) = 12.0e-06 + if (k.le.3) radliq(ip,k) = 11.0e-06 + +! ice particles : + if ( (t(ip,k)-273.15).gt.-81.4 ) then + radice(ip,k) = (0.71*(t(ip,k)-273.15)+61.29)*1e-6 + else + radice(ip,k) = 3.5*1e-6 + endif + END DO + END DO + gbx%Reff(:,:,I_LSCLIQ) = radliq + gbx%Reff(:,:,I_LSCICE) = radice + gbx%Reff(:,:,I_CVCLIQ) = radliq + gbx%Reff(:,:,I_CVCICE) = radice + + ! ISCCP simulator + gbx%dtau_s = dtau_s + print*,'dtau_s(1,:)=',gbx%dtau_s(1,:) + gbx%dtau_c = 0. + gbx%dem_s = dem_s + print*,'dem_s(1,:)=',gbx%dem_s(1,:) + gbx%dem_c = 0. + +! Surafce emissivity + emsfc_lw = 1. + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Define new vertical grid +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Defining new vertical grid...' + call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid) + + if (debut_cosp) then +! Creer le fichier de sorie, definir les variable de sortie + ! Axe verticale (Pa ou Km) + Nlevout = vgrid%Nlvgrid + + do ii=1,Ncolumns + column_ax(ii) = float(ii) + enddo + + include "ini_histmthCOSP.h" + include "ini_histdayCOSP.h" + include "ini_histhfCOSP.h" + + print*,'Fin Initialisation des sorties COSP, debut_cosp =',debut_cosp + print*,'R_UNDEF=',R_UNDEF + + debut_cosp=.false. + endif ! debut_cosp + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Allocate memory for other types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Allocating memory for other types...' + call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx) + call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar) + call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar) + call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar) + call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar) + call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp) + call construct_cosp_misr(cfg,Npoints,misr) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Call simulator +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Calling simulator...' + call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) + print*,'stlidar%lidarcld(1,:)=',stlidar%lidarcld(1,:) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Write outputs to CMOR-compliant NetCDF +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! A traiter le cas ou l on a des valeurs indefinies +! Attention teste + +! if(1.eq.0)then + + + do k = 1,Nlevout +! do ip = 1,Npoints +! if(stlidar%lidarcld(ip,k).eq.R_UNDEF)then +! stlidar%lidarcld(ip,k)=0. +! endif +! enddo + + + do ii= 1,SR_BINS + do ip = 1,Npoints + if(stlidar%cfad_sr(ip,ii,k).eq.R_UNDEF)then + stlidar%cfad_sr(ip,ii,k)=0. + endif + enddo + enddo + enddo + + do ip = 1,Npoints + do k = 1,Nlevlmdz + if(sglidar%beta_mol(ip,k).eq.R_UNDEF)then + sglidar%beta_mol(ip,k)=0. + endif + + do ii= 1,Ncolumns + if(sglidar%beta_tot(ip,ii,k).eq.R_UNDEF)then + sglidar%beta_tot(ip,ii,k)=0. + endif + enddo + + enddo !k = 1,Nlevlmdz + enddo !ip = 1,Npoints + + do k = 1,LIDAR_NCAT + do ip = 1,Npoints + if(stlidar%cldlayer(ip,k).eq.R_UNDEF)then + stlidar%cldlayer(ip,k)=0. + endif + enddo + enddo + +! endif + + do ip = 1,Npoints + if(isccp%totalcldarea(ip).eq.-1.E+30)then + isccp%totalcldarea(ip)=0. + endif + if(isccp%meanptop(ip).eq.-1.E+30)then + isccp%meanptop(ip)=0. + endif + if(isccp%meantaucld(ip).eq.-1.E+30)then + isccp%meantaucld(ip)=0. + endif + if(isccp%meanalbedocld(ip).eq.-1.E+30)then + isccp%meanalbedocld(ip)=0. + endif + if(isccp%meantb(ip).eq.-1.E+30)then + isccp%meantb(ip)=0. + endif + if(isccp%meantbclr(ip).eq.-1.E+30)then + isccp%meantbclr(ip)=0. + endif + + do k=1,7 + do ii=1,7 + if(isccp%fq_isccp(ip,ii,k).eq.-1.E+30)then + isccp%fq_isccp(ip,ii,k)=0. + endif + enddo + enddo + + do ii=1,Ncolumns + if(isccp%boxtau(ip,ii).eq.-1.E+30)then + isccp%boxtau(ip,ii)=0. + endif + enddo + + do ii=1,Ncolumns + if(isccp%boxptop(ip,ii).eq.-1.E+30)then + isccp%boxptop(ip,ii)=0. + endif + enddo + enddo + + include "write_histmthCOSP.h" + include "write_histdayCOSP.h" + include "write_histhfCOSP.h" + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Deallocate memory in derived types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Deallocating memory...' + call free_cosp_gridbox(gbx) + call free_cosp_subgrid(sgx) + call free_cosp_sgradar(sgradar) + call free_cosp_radarstats(stradar) + call free_cosp_sglidar(sglidar) + call free_cosp_lidarstats(stlidar) + call free_cosp_isccp(isccp) + call free_cosp_misr(misr) + call free_cosp_vgrid(vgrid) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Time in s. Only for testing purposes +! call system_clock(t1,count_rate,count_max) +! print *,(t1-t0)*1.0/count_rate + +end subroutine phys_cosp Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/prec_scops.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/prec_scops.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/prec_scops.F (revision 1634) @@ -0,0 +1,268 @@ +! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation +! nor the names of its contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate, + & frac_out,prec_frac) + + + implicit none + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER i,j,ilev,ibox,cv_col + + REAL ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev) + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into + ! Equivalent of BOX in original version, but + ! indexed by column then row, rather than + ! by row then column + !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + REAL prec_frac(npoints,ncol,nlev) ! 0 -> clear sky + ! 1 -> LS precipitation + ! 2 -> CONV precipitation + ! 3 -> both + !TOA to SURFACE!!!!!!!!!!!!!!!!!! + + INTEGER flag_ls, flag_cv + INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for + ! stratiform cloud and convective cloud in the vertical column + + cv_col = 0.05*ncol + if (cv_col .eq. 0) cv_col=1 + + do ilev=1,nlev + do ibox=1,ncol + do j=1,npoints + prec_frac(j,ibox,ilev) = 0 + enddo + enddo + enddo + + do j=1,npoints + do ibox=1,ncol + frac_out_ls(j,ibox)=0 + frac_out_cv(j,ibox)=0 + flag_ls=0 + flag_cv=0 + do ilev=1,nlev + if (frac_out(j,ibox,ilev) .eq. 1) then + flag_ls=1 + endif + if (frac_out(j,ibox,ilev) .eq. 2) then + flag_cv=1 + endif + enddo !loop over nlev + if (flag_ls .eq. 1) then + frac_out_ls(j,ibox)=1 + endif + if (flag_cv .eq. 1) then + frac_out_cv(j,ibox)=1 + endif + enddo ! loop over ncol + enddo ! loop over npoints + +! initialize the top layer + do j=1,npoints + flag_ls=0 + flag_cv=0 + + if (ls_p_rate(j,1) .gt. 0.) then + do ibox=1,ncol ! possibility ONE + if (frac_out(j,ibox,1) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + if (flag_ls .eq. 0) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,2) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_ls(j,ibox) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Five + do ibox=1,ncol +! prec_frac(j,1:ncol,1) = 1 + prec_frac(j,ibox,1) = 1 + enddo ! loop over ncol + endif + endif + ! There is large scale precipitation + + if (cv_p_rate(j,1) .gt. 0.) then + do ibox=1,ncol ! possibility ONE + if (frac_out(j,ibox,1) .eq. 2) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + if (flag_cv .eq. 0) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,2) .eq. 2) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_cv(j,ibox) .eq. 1) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Five + do ibox=1,cv_col + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + enddo !loop over cv_col + endif + endif + ! There is convective precipitation + + enddo ! loop over npoints +! end of initializing the top layer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! working on the levels from top to surface + do ilev=2,nlev + do j=1,npoints + flag_ls=0 + flag_cv=0 + + if (ls_p_rate(j,ilev) .gt. 0.) then + do ibox=1,ncol ! possibility ONE&TWO + if ((frac_out(j,ibox,ilev) .eq. 1) .or. + & ((prec_frac(j,ibox,ilev-1) .eq. 1) + & .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,ilev+1) .eq. 1) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_ls(j,ibox) .eq. 1) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Five + do ibox=1,ncol +! prec_frac(j,1:ncol,ilev) = 1 + prec_frac(j,ibox,ilev) = 1 + enddo ! loop over ncol + endif + endif ! There is large scale precipitation + + if (cv_p_rate(j,ilev) .gt. 0.) then + do ibox=1,ncol ! possibility ONE&TWO + if ((frac_out(j,ibox,ilev) .eq. 2) .or. + & ((prec_frac(j,ibox,ilev-1) .eq. 2) + & .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,ilev+1) .eq. 2) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_cv(j,ibox) .eq. 1) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Five + do ibox=1,cv_col + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + enddo !loop over cv_col + endif + endif ! There is convective precipitation + + enddo ! loop over npoints + enddo ! loop over nlev + + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/radar_simulator.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/radar_simulator.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/radar_simulator.F90 (revision 1634) @@ -0,0 +1,511 @@ + subroutine radar_simulator(freq,k2,do_ray,use_gas_abs,use_mie_table,mt, & + nhclass,hp,nprof,ngate,nsizes,D,hgt_matrix,hm_matrix,re_matrix,p_matrix,t_matrix, & + rh_matrix,Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe, & + g_to_vol_in,g_to_vol_out) + +! rh_matrix,Ze_non,Ze_ray,kr_matrix,g_atten_to_vol,dBZe) + + use m_mrgrnk + use array_lib + use math_lib + use optics_lib + use radar_simulator_types + implicit none + +! Purpose: +! Simulates a vertical profile of radar reflectivity +! Part of QuickBeam v1.04 by John Haynes & Roger Marchand +! +! Inputs: +! [freq] radar frequency (GHz), can be anything unless +! use_mie_table=1, in which case one of 94,35,13.8,9.6,3 +! [k2] |K|^2, the dielectric constant, set to -1 to use the +! frequency dependent default +! [do_ray] 1=do Rayleigh calcs, 0=not +! [use_gas_abs] 1=do gaseous abs calcs, 0=not, +! 2=use same as first profile (undocumented) +! [use_mie_table] 1=use Mie tables, 0=not +! [mt] Mie look up table +! [nhclass] number of hydrometeor types +! [hp] structure that defines hydrometeor types +! [nprof] number of hydrometeor profiles +! [ngate] number of vertical layers +! [nsizes] number of discrete particles in [D] +! [D] array of discrete particles (um) +! +! (The following 5 arrays must be in order from closest to the radar +! to farthest...) +! [hgt_matrix] height of hydrometeors (km) +! [hm_matrix] table of hydrometeor mixing rations (g/kg) +! [re_matrix] OPTIONAL table of hydrometeor effective radii (microns) +! [p_matrix] pressure profile (hPa) +! [t_matrix] temperature profile (C) +! [rh_matrix] relative humidity profile (%) +! +! Outputs: +! [Ze_non] radar reflectivity without attenuation (dBZ) +! [Ze_ray] Rayleigh reflectivity (dBZ) +! [h_atten_to_vol] attenuation by hydromets, radar to vol (dB) +! [g_atten_to_vol] gaseous atteunation, radar to vol (dB) +! [dBZe] effective radar reflectivity factor (dBZ) +! +! Optional: +! [g_to_vol_in] integrated atten due to gases, r>v (dB). +! If present then is used as gaseous absorption, independently of the +! value in use_gas_abs +! [g_to_vol_out] integrated atten due to gases, r>v (dB). +! If present then gaseous absorption for each profile is returned here. +! +! Created: +! 11/28/2005 John Haynes (haynes@atmos.colostate.edu) +! Modified: +! 09/2006 placed into subroutine form, scaling factors (Roger Marchand,JMH) +! 08/2007 added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand) +! 01/2008 'Do while' to determine if hydrometeor(s) present in volume +! changed for vectorization purposes (A. Bodas-Salcedo) + +! ----- INPUTS ----- + type(mie), intent(in) :: mt + type(class_param), intent(inout) :: hp + real*8, intent(in) :: freq,k2 + integer, intent(in) :: do_ray,use_gas_abs,use_mie_table, & + nhclass,nprof,ngate,nsizes + real*8, dimension(nsizes), intent(in) :: D + real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, & + t_matrix,rh_matrix + real*8, dimension(nhclass,nprof,ngate), intent(in) :: hm_matrix + real*8, dimension(nhclass,nprof,ngate), intent(inout) :: re_matrix + +! ----- OUTPUTS ----- + real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, & + g_atten_to_vol,dBZe,h_atten_to_vol + +! ----- OPTIONAL ----- + real*8, optional, dimension(ngate,nprof) :: & + g_to_vol_in,g_to_vol_out ! integrated atten due to gases, r>v (dB). This allows to output and then input + ! the same gaseous absorption in different calls. Optional to allow compatibility + ! with original version. A. Bodas April 2008. + +! real*8, dimension(nprof,ngate) :: kr_matrix + +! ----- INTERNAL ----- + integer :: & + phase, & ! 0=liquid, 1=ice + ns ! number of discrete drop sizes + + integer*4, dimension(ngate) :: & + hydro ! 1=hydrometeor in vol, 0=none + real*8 :: & + rho_a, & ! air density (kg m^-3) + gases ! function: 2-way gas atten (dB/km) + + real*8, dimension(:), allocatable :: & + Di, Deq, & ! discrete drop sizes (um) + Ni, Ntemp, & ! discrete concentrations (cm^-3 um^-1) + rhoi ! discrete densities (kg m^-3) + + real*8, dimension(ngate) :: & + z_vol, & ! effective reflectivity factor (mm^6/m^3) + z_ray, & ! reflectivity factor, Rayleigh only (mm^6/m^3) + kr_vol, & ! attenuation coefficient hydro (dB/km) + g_vol, & ! attenuation coefficient gases (dB/km) + a_to_vol, & ! integrated atten due to hydometeors, r>v (dB) + g_to_vol ! integrated atten due to gases, r>v (dB) + + + integer,parameter :: KR8 = selected_real_kind(15,300) + real*8, parameter :: xx = -1.0_KR8 + real*8, dimension(:), allocatable :: xxa + real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2,apm,bpm + integer*4 :: tp, i, j, k, pr, itt, iff + + real*8 bin_length,step,base,step_list(25),base_list(25) + integer*4 iRe_type,n,max_bin + + logical :: g_to_vol_in_present, g_to_vol_out_present + + ! Logicals to avoid calling present within the loops + g_to_vol_in_present = present(g_to_vol_in) + g_to_vol_out_present = present(g_to_vol_out) + + ! set up Re bins for z_scalling + bin_length=50; + max_bin=25 + + step_list(1)=1 + base_list(1)=75 + do j=2,max_bin + step_list(j)=3*(j-1); + if(step_list(j)>bin_length) then + step_list(j)=bin_length; + endif + base_list(j)=base_list(j-1)+floor(bin_length/step_list(j-1)); + enddo + + + pi = acos(-1.0) + if (use_mie_table == 1) iff = infind(mt%freq,freq,sort=1) + + + ! // loop over each profile (nprof) + do pr=1,nprof + +! ----- calculations for each volume ----- + z_vol(:) = 0 + z_ray(:) = 0 + kr_vol(:) = 0 + hydro(:) = 0 + +! // loop over eacho range gate (ngate) + do k=1,ngate + +! :: determine if hydrometeor(s) present in volume + hydro(k) = 0 + do j=1,nhclass ! Do while changed for vectorization purposes (A. B-S) + if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then + hydro(k) = 1 + exit + endif + enddo + + if (hydro(k) == 1) then +! :: if there is hydrometeor in the volume + + rho_a = (p_matrix(pr,k)*100.)/(287*(t_matrix(pr,k)+273.15)) + +! :: loop over hydrometeor type + do tp=1,nhclass + + if (hm_matrix(tp,pr,k) <= 1E-12) cycle + + phase = hp%phase(tp) + if(phase==0) then + itt = infind(mt_ttl,t_matrix(pr,k)) + else + itt = infind(mt_tti,t_matrix(pr,k)) + endif + + ! calculate Re if we have an exponential distribution with fixed No ... precipitation type particle + if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8) then + + apm=hp%apm(tp) + bpm=hp%bpm(tp) + + if ((hp%rho(tp) > 0) .and. (apm < 0)) then + apm = (pi/6)*hp%rho(tp) + bpm = 3. + endif + + tmp1 = 1./(1.+bpm) + ld = ((apm*gamma(1.+bpm)*hp%p1(tp))/(rho_a*hm_matrix(tp,pr,k)*1E-3))**tmp1 + + Re = 1.5E6/ld + + re_matrix(tp,pr,k) = Re; + + endif + + if(re_matrix(tp,pr,k).eq.0) then + + iRe_type=1 + Re=0 + else + iRe_type=1 + Re=re_matrix(tp,pr,k) + + n=floor(Re/bin_length) + if(n==0) then + if(Re<25) then + step=0.5 + base=0 + else + step=1 + base=25 + endif + else + if(n>max_bin) then + n=max_bin + endif + + step=step_list(n) + base=base_list(n) + endif + + iRe_type=floor(Re/step) + + if(iRe_type.lt.1) then + iRe_type=1 + endif + + Re=step*(iRe_type+0.5) + iRe_type=iRe_type+base-floor(n*bin_length/step) + + ! make sure iRe_type is within bounds + if(iRe_type.ge.nRe_types) then + + ! print *, tp, re_matrix(tp,pr,k), Re, iRe_type + + ! no scaling allowed + Re=re_matrix(tp,pr,k) + + iRe_type=nRe_types + hp%z_flag(tp,itt,iRe_type)=.false. + hp%scaled(tp,iRe_type)=.false. + endif + endif + + ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them + ! if not we will calculate Ze, Zr, and Kr from the distribution parameters + if( .not. hp%z_flag(tp,itt,iRe_type) ) then + +! :: create a distribution of hydrometeors within volume + select case(hp%dtype(tp)) + case(4) + ns = 1 + allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns)) + if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns)) + Di = hp%p1(tp) + Ni = 0. + case default + ns = nsizes + allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns)) + if (use_mie_table == 1) allocate(mt_qext(ns),mt_qbsca(ns),Ntemp(ns)) + Di = D + Ni = 0. + end select + +! :: create a DSD (using scaling factor if applicable) + ! hp%scaled(tp,iRe_type)=.false. ! turn off N scaling + + call dsd(hm_matrix(tp,pr,k),Re,Di,Ni,ns,hp%dtype(tp),rho_a, & + t_matrix(pr,k),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), & + hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),hp%fc(tp,1:ns,iRe_type), & + hp%scaled(tp,iRe_type)) + +! :: calculate particle density + ! if ((hp%rho_eff(tp,1,iRe_type) < 0) .and. (phase == 1)) then + if (phase == 1) then + if (hp%rho(tp) < 0) then + + ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density + ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3) !MG Mie approach + + ! as the particle size gets small it is possible that the mass to size relationship of + ! (given by power law in hclass.data) can produce impossible results + ! where the mass is larger than a solid sphere of ice. + ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere. + ! do i=1,ns + ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then + ! hp%rho_eff(tp,i,iRe_type) = 917 + !endif + !enddo + + ! alternative is to use equivalent volume spheres. + hp%rho_eff(tp,1:ns,iRe_type) = 917 ! solid ice == equivalent volume approach + Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * & + ( (Di*1E-6) ** (hp%bpm(tp)/3.0) ) * 1E6 ! Di now really Deq in microns. + + else + + ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp) !MG Mie approach + + ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3). + hp%rho_eff(tp,1:ns,iRe_type) = 917 + Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0)) + + endif + + ! if using equivalent volume spheres + if (use_mie_table == 1) then + + Ntemp=Ni + + ! Find N(Di) from N(Deq) which we know + do i=1,ns + j=infind(Deq,Di(i)) + Ni(i)=Ntemp(j) + enddo + else + ! just use Deq and D variable input to mie code + Di=Deq; + endif + + endif + rhoi = hp%rho_eff(tp,1:ns,iRe_type) + +! :: calculate effective reflectivity factor of volume + if (use_mie_table == 1) then + + if ((hp%dtype(tp) == 4) .and. (hp%idd(tp) < 0)) then + hp%idd(tp) = infind(mt%D,Di(1)) + endif + + if (phase == 0) then + + ! itt = infind(mt_ttl,t_matrix(pr,k)) + select case(hp%dtype(tp)) + case(4) + mt_qext(1) = mt%qext(hp%idd(tp),itt,1,iff) + mt_qbsca(1) = mt%qbsca(hp%idd(tp),itt,1,iff) + case default + mt_qext = mt%qext(:,itt,1,iff) + mt_qbsca = mt%qbsca(:,itt,1,iff) + end select + + call zeff(freq,Di,Ni,ns,k2,mt_ttl(itt),0,do_ray, & + ze,zr,kr,mt_qext,mt_qbsca,xx) + + else + + ! itt = infind(mt_tti,t_matrix(pr,k)) + select case(hp%dtype(tp)) + case(4) + if (hp%ifc(tp,1,iRe_type) < 0) then + hp%ifc(tp,1,iRe_type) = infind(mt%f,rhoi(1)/917.) + endif + mt_qext(1) = & + mt%qext(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff) + mt_qbsca(1) = & + mt%qbsca(hp%idd(tp),itt+cnt_liq,hp%ifc(tp,1,iRe_type),iff) + case default + do i=1,ns + if (hp%ifc(tp,i,iRe_type) < 0) then + hp%ifc(tp,i,iRe_type) = infind(mt%f,rhoi(i)/917.) + endif + mt_qext(i) = mt%qext(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff) + mt_qbsca(i) = mt%qbsca(i,itt+cnt_liq,hp%ifc(tp,i,iRe_type),iff) + enddo + end select + + call zeff(freq,Di,Ni,ns,k2,mt_tti(itt),1,do_ray, & + ze,zr,kr,mt_qext,mt_qbsca,xx) + + endif + + else + + xxa = -9.9 + call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, & + ze,zr,kr,xxa,xxa,rhoi) + + + endif ! end of use mie table + + ! xxa = -9.9 + !call zeff(freq,Di,Ni,ns,k2,t_matrix(pr,k),phase,do_ray, & + ! ze2,zr,kr2,xxa,xxa,rhoi) + + ! if(abs(ze2-ze)/ze2 > 0.1) then + ! if(abs(kr2-kr)/kr2 > 0.1) then + + ! write(*,*) pr,k,tp,ze2,ze2-ze,abs(ze2-ze)/ze2,itt+cnt_liq,iff + ! write(*,*) pr,k,tp,ze2,kr2,kr2-kr,abs(kr2-kr)/kr2 + ! stop + + !endif + + deallocate(Di,Ni,rhoi,xxa,Deq) + if (use_mie_table == 1) deallocate(mt_qext,mt_qbsca,Ntemp) + + else ! can use z scaling + + if( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then + + ze = hp%Ze_scaled(tp,itt,iRe_type) + zr = hp%Zr_scaled(tp,itt,iRe_type) + kr = hp%kr_scaled(tp,itt,iRe_type) + + else + scale_factor=rho_a*hm_matrix(tp,pr,k) + + zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor + ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor + kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor + endif + + endif ! end z_scaling + + ! kr=0 + + kr_vol(k) = kr_vol(k) + kr + z_vol(k) = z_vol(k) + ze + z_ray(k) = z_ray(k) + zr + + ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can + if( .not. hp%z_flag(tp,itt,iRe_type) .and. 1.eq.1 ) then + + if( ( (hp%dtype(tp)==1 .or. hp%dtype(tp)==5 .or. hp%dtype(tp)==2) .and. abs(hp%p1(tp)+1) < 1E-8 ) .or. & + ( hp%dtype(tp)==3 .or. hp%dtype(tp)==4 ) & + ) then + + scale_factor=rho_a*hm_matrix(tp,pr,k) + + hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor + hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor + hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor + + hp%z_flag(tp,itt,iRe_type)=.True. + + elseif( hp%dtype(tp)==2 .and. abs(hp%p2(tp)+1) < 1E-8 ) then + + hp%Ze_scaled(tp,itt,iRe_type) = ze + hp%Zr_scaled(tp,itt,iRe_type) = zr + hp%kr_scaled(tp,itt,iRe_type) = kr + + hp%z_flag(tp,itt,iRe_type)=.True. + endif + + endif + + enddo ! end loop of tp (hydrometeor type) + + else +! :: volume is hydrometeor-free + + kr_vol(k) = 0 + z_vol(k) = -999 + z_ray(k) = -999 + + endif + +! :: attenuation due to hydrometeors between radar and volume + a_to_vol(k) = 2*path_integral(kr_vol,hgt_matrix(pr,:),1,k-1) + +! :: attenuation due to gaseous absorption between radar and volume + if (g_to_vol_in_present) then + g_to_vol(k) = g_to_vol_in(k,pr) + else + if ( (use_gas_abs == 1) .or. ((use_gas_abs == 2) .and. (pr == 1)) ) then + g_vol(k) = gases(p_matrix(pr,k),t_matrix(pr,k)+273.15, & + rh_matrix(pr,k),freq) + g_to_vol(k) = path_integral(g_vol,hgt_matrix(pr,:),1,k-1) + elseif (use_gas_abs == 0) then + g_to_vol(k) = 0 + endif + endif + +! kr_matrix(pr,:)=kr_vol + +! :: store results in matrix for return to calling program + h_atten_to_vol(pr,k)=a_to_vol(k) + g_atten_to_vol(pr,k)=g_to_vol(k) + if ((do_ray == 1) .and. (z_ray(k) > 0)) then + Ze_ray(pr,k) = 10*log10(z_ray(k)) + else + Ze_ray(pr,k) = -999 + endif + if (z_vol(k) > 0) then + dBZe(pr,k) = 10*log10(z_vol(k))-a_to_vol(k)-g_to_vol(k) + Ze_non(pr,k) = 10*log10(z_vol(k)) + else + dBZe(pr,k) = -999 + Ze_non(pr,k) = -999 + endif + + enddo ! end loop of k (range gate) + ! Output array with gaseous absorption + if (g_to_vol_out_present) g_to_vol_out(:,pr) = g_to_vol + enddo ! end loop over pr (profile) + + end subroutine radar_simulator + Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/radar_simulator_types.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/radar_simulator_types.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/radar_simulator_types.F90 (revision 1634) @@ -0,0 +1,55 @@ + module radar_simulator_types + +! Collection of common variables and types +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim + + integer, parameter :: & + maxhclass = 20 ,& ! max number of hydrometeor classes + nd = 85 ,& ! number of discrete particles + nRe_types = 250 ! number or Re size bins allowed in N and Z_scaled look up table + + real*8, parameter :: & + dmin = 0.1 ,& ! min size of discrete particle + dmax = 10000. ! max size of discrete particle + + integer, parameter :: & + mt_nfreq = 5 , & + mt_ntt = 39 , & ! num temperatures in table + mt_nf = 14 , & ! number of ice fractions in table + mt_nd = 85 ! num discrete mode-p drop sizes in table + + +! ---- hydrometeor class type ----- + + type class_param + real*8, dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho + integer, dimension(maxhclass) :: dtype,col,cp,phase + logical, dimension(maxhclass,nRe_types) :: scaled + logical, dimension(maxhclass,mt_ntt,nRe_types) :: z_flag + real*8, dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled + real*8, dimension(maxhclass,nd,nRe_types) :: fc, rho_eff + integer, dimension(maxhclass,nd,nRe_types) :: ifc + integer, dimension(maxhclass) :: idd + end type class_param + +! ----- mie table structure ----- + + type mie + real*8 :: freq(mt_nfreq), tt(mt_ntt), f(mt_nf), D(mt_nd) + real*8, dimension(mt_nd,mt_ntt,mt_nf,mt_nfreq) :: qext, qbsca + integer :: phase(mt_ntt) + end type mie + + real*8, dimension(:), save, allocatable :: & + mt_ttl, & ! liquid temperatures (C) + mt_tti, & ! ice temperatures (C) + mt_qext, mt_qbsca ! extincion/backscatter efficiency +!$OMP THREADPRIVATE(mt_ttl,mt_tti,mt_qext, mt_qbsca) + + integer*4,save :: & + cnt_liq, & ! liquid temperature count + cnt_ice ! ice temperature count +!$OMP THREADPRIVATE(cnt_liq,cnt_ice) + + end module radar_simulator_types Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/read_cosp_output_nl.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/read_cosp_output_nl.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/read_cosp_output_nl.F90 (revision 1634) @@ -0,0 +1,232 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------- SUBROUTINE READ_COSP_OUTPUT_NL ------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE READ_COSP_OUTPUT_NL(cosp_nl,cfg) + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE mod_phys_lmdz_para + character(len=*),intent(in) :: cosp_nl + type(cosp_config),intent(out) :: cfg + ! Local variables + integer :: i + + logical, save :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, & + Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2,Lcllcalipso, & + Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp,Ltclisccp, & + Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfrac_out,Lbeta_mol532,Ltbrttov + + namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,Lcfad_dbze94, & + Lcfad_lidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp2, & + Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lctpisccp,Ldbze94,Ltauisccp, & + Ltclisccp,Llongitude,Llatitude,Lparasol_refl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfrac_out,Lbeta_mol532,Ltbrttov + + do i=1,N_OUT_LIST + cfg%out_list(i)='' + enddo + + IF (is_master) THEN + open(10,file=cosp_nl,status='old') + read(10,nml=cosp_output) + close(10) + ENDIF + + CALL bcast(Lradar_sim) + CALL bcast(Llidar_sim) + CALL bcast(Lisccp_sim) + CALL bcast(Lmisr_sim) + CALL bcast(Lrttov_sim) + CALL bcast(Lalbisccp) + CALL bcast(Latb532) + CALL bcast(Lboxptopisccp) + CALL bcast(Lboxtauisccp) + CALL bcast(Lcfad_dbze94) + CALL bcast(Lcfad_lidarsr532) + CALL bcast(Lclcalipso2) + CALL bcast(Lclcalipso) + CALL bcast(Lclhcalipso) + CALL bcast(Lclisccp2) + CALL bcast(Lcllcalipso) + CALL bcast(Lclmcalipso) + CALL bcast(Lcltcalipso) + CALL bcast(Lcltlidarradar) + CALL bcast(Lctpisccp) + CALL bcast(Ldbze94) + CALL bcast(Ltauisccp) + CALL bcast(Ltclisccp) + CALL bcast(Llongitude) + CALL bcast(Llatitude) + CALL bcast(Lparasol_refl) + CALL bcast(LclMISR) + CALL bcast(Lmeantbisccp) + CALL bcast(Lmeantbclrisccp) + CALL bcast(Lfrac_out) + CALL bcast(Lbeta_mol532) + CALL bcast(Ltbrttov) +!$OMP BARRIER + +! print*,' Cles sorties cosp :' +! print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', & +! Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim + + ! Deal with dependencies + if (.not.Lradar_sim) then + Lcfad_dbze94 = .false. + Lclcalipso2 = .false. + Lcltlidarradar = .false. + Ldbze94 = .false. + endif + if (.not.Llidar_sim) then + Latb532 = .false. + Lcfad_lidarsr532 = .false. + Lclcalipso2 = .false. + Lclcalipso = .false. + Lclhcalipso = .false. + Lcllcalipso = .false. + Lclmcalipso = .false. + Lcltcalipso = .false. + Lcltlidarradar = .false. + Lparasol_refl = .false. + Lbeta_mol532 = .false. + endif + if (.not.Lisccp_sim) then + Lalbisccp = .false. + Lboxptopisccp = .false. + Lboxtauisccp = .false. + Lclisccp2 = .false. + Lctpisccp = .false. + Ltauisccp = .false. + Ltclisccp = .false. + Lmeantbisccp = .false. + Lmeantbclrisccp = .false. + endif + if (.not.Lmisr_sim) then + LclMISR = .false. + endif + if (.not.Lrttov_sim) then + Ltbrttov = .false. + endif + if ((.not.Lradar_sim).and.(.not.Llidar_sim).and. & + (.not.Lisccp_sim).and.(.not.Lmisr_sim)) then + Lfrac_out = .false. + endif + + ! Diagnostics that use Radar and Lidar + if (((Lclcalipso2).or.(Lcltlidarradar)).and.((Lradar_sim).or.(Llidar_sim))) then + Lclcalipso2 = .true. + Lcltlidarradar = .true. + Llidar_sim = .true. + Lradar_sim = .true. + endif + + cfg%Lstats = .false. + if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) cfg%Lstats = .true. + + ! Copy instrument flags to cfg structure + cfg%Lradar_sim = Lradar_sim + cfg%Llidar_sim = Llidar_sim + cfg%Lisccp_sim = Lisccp_sim + cfg%Lmisr_sim = Lmisr_sim + cfg%Lrttov_sim = Lrttov_sim + + ! Flag to control output to file + cfg%Lwrite_output = .false. + if (cfg%Lstats.or.cfg%Lmisr_sim.or.cfg%Lrttov_sim) then + cfg%Lwrite_output = .true. + endif + + ! Output diagnostics + i = 1 + if (Lalbisccp) cfg%out_list(i) = 'albisccp' + i = i+1 + if (Latb532) cfg%out_list(i) = 'atb532' + i = i+1 + if (Lboxptopisccp) cfg%out_list(i) = 'boxptopisccp' + i = i+1 + if (Lboxtauisccp) cfg%out_list(i) = 'boxtauisccp' + i = i+1 + if (Lcfad_dbze94) cfg%out_list(i) = 'cfad_dbze94' + i = i+1 + if (Lcfad_lidarsr532) cfg%out_list(i) = 'cfad_lidarsr532' + i = i+1 + if (Lclcalipso2) cfg%out_list(i) = 'clcalipso2' + i = i+1 + if (Lclcalipso) cfg%out_list(i) = 'clcalipso' + i = i+1 + if (Lclhcalipso) cfg%out_list(i) = 'clhcalipso' + i = i+1 + if (Lclisccp2) cfg%out_list(i) = 'clisccp2' + i = i+1 + if (Lcllcalipso) cfg%out_list(i) = 'cllcalipso' + i = i+1 + if (Lclmcalipso) cfg%out_list(i) = 'clmcalipso' + i = i+1 + if (Lcltcalipso) cfg%out_list(i) = 'cltcalipso' + i = i+1 + if (Lcltlidarradar) cfg%out_list(i) = 'cltlidarradar' + i = i+1 + if (Lctpisccp) cfg%out_list(i) = 'ctpisccp' + i = i+1 + if (Ldbze94) cfg%out_list(i) = 'dbze94' + i = i+1 + if (Ltauisccp) cfg%out_list(i) = 'tauisccp' + i = i+1 + if (Ltclisccp) cfg%out_list(i) = 'tclisccp' + i = i+1 + if (Llongitude) cfg%out_list(i) = 'lon' + i = i+1 + if (Llatitude) cfg%out_list(i) = 'lat' + i = i+1 + if (Lparasol_refl) cfg%out_list(i) = 'parasol_refl' + i = i+1 + if (LclMISR) cfg%out_list(i) = 'clMISR' + i = i+1 + if (Lmeantbisccp) cfg%out_list(i) = 'meantbisccp' + i = i+1 + if (Lmeantbclrisccp) cfg%out_list(i) = 'meantbclrisccp' + i = i+1 + if (Lfrac_out) cfg%out_list(i) = 'frac_out' + i = i+1 + if (Lbeta_mol532) cfg%out_list(i) = 'beta_mol532' + i = i+1 + if (Ltbrttov) cfg%out_list(i) = 'tbrttov' + + if (i /= N_OUT_LIST) then + print *, 'COSP_IO: wrong number of output diagnostics' + stop + endif + + ! Copy diagnostic flags to cfg structure + cfg%Lalbisccp = Lalbisccp + cfg%Latb532 = Latb532 + cfg%Lboxptopisccp = Lboxptopisccp + cfg%Lboxtauisccp = Lboxtauisccp + cfg%Lcfad_dbze94 = Lcfad_dbze94 + cfg%Lcfad_lidarsr532 = Lcfad_lidarsr532 + cfg%Lclcalipso2 = Lclcalipso2 + cfg%Lclcalipso = Lclcalipso + cfg%Lclhcalipso = Lclhcalipso + cfg%Lclisccp2 = Lclisccp2 + cfg%Lcllcalipso = Lcllcalipso + cfg%Lclmcalipso = Lclmcalipso + cfg%Lcltcalipso = Lcltcalipso + cfg%Lcltlidarradar = Lcltlidarradar + cfg%Lctpisccp = Lctpisccp + cfg%Ldbze94 = Ldbze94 + cfg%Ltauisccp = Ltauisccp + cfg%Ltclisccp = Ltclisccp + cfg%Llongitude = Llongitude + cfg%Llatitude = Llatitude + cfg%Lparasol_refl = Lparasol_refl + cfg%LclMISR = LclMISR + cfg%Lmeantbisccp = Lmeantbisccp + cfg%Lmeantbclrisccp = Lmeantbclrisccp + cfg%Lfrac_out = Lfrac_out + cfg%Lbeta_mol532 = Lbeta_mol532 + cfg%Ltbrttov = Ltbrttov + + END SUBROUTINE READ_COSP_OUTPUT_NL + Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/scops.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/scops.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/scops.F (revision 1634) @@ -0,0 +1,339 @@ + subroutine scops(npoints,nlev,ncol,seed,cc,conv, + & overlap,frac_out,ncolprint) + + +! *****************************COPYRIGHT**************************** +! (c) British Crown Copyright 2009, the Met Office. +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the +! following conditions are met: +! +! * Redistributions of source code must retain the above +! copyright notice, this list of conditions and the following +! disclaimer. +! * Redistributions in binary form must reproduce the above +! copyright notice, this list of conditions and the following +! disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its +! contributors may be used to endorse or promote products +! derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* + + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + + implicit none + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + + INTEGER overlap ! overlap type + ! 1=max + ! 2=rand + ! 3=max/rand + REAL cc(npoints,nlev) + ! input cloud cover in each model level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by clouds + + REAL conv(npoints,nlev) + ! input convective cloud cover in each model + ! level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by convective clouds + + INTEGER i,j,ilev,ibox,ncolprint,ilev2 + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into + ! Equivalent of BOX in original version, but + ! indexed by column then row, rather than + ! by row then column + + + INTEGER seed(npoints) + ! seed values for marsaglia random number generator + ! It is recommended that the seed is set + ! to a different value for each model + ! gridbox it is called on, as it is + ! possible that the choice of the same + ! seed value every time may introduce some + ! statistical bias in the results, particularly + ! for low values of NCOL. + + REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction) + ! with extra layer of zeroes on top + ! in this version this just contains the values input + ! from cc but with an extra level + + REAL threshold(npoints,ncol) ! pointer to position in gridbox + REAL maxocc(npoints,ncol) ! Flag for max overlapped conv cld + REAL maxosc(npoints,ncol) ! Flag for max overlapped strat cld + + REAL boxpos(npoints,ncol) ! ordered pointer to position in gridbox + + REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold + ! is chosen + + REAL ran(npoints) ! vector of random numbers + + INTEGER irand,i2_16,huge32,overflow_32 ! variables for RNG + PARAMETER(huge32=2147483647) + i2_16=65536 + + do ibox=1,ncol + do j=1,npoints + boxpos(j,ibox)=(ibox-.5)/ncol + enddo + enddo + +! ---------------------------------------------------! +! Initialise working variables +! ---------------------------------------------------! + +! Initialised frac_out to zero + + do ilev=1,nlev + do ibox=1,ncol + do j=1,npoints + frac_out(j,ibox,ilev)=0.0 + enddo + enddo + enddo + +! assign 2d tca array using 1d input array cc + + do j=1,npoints + tca(j,0)=0 + enddo + + do ilev=1,nlev + do j=1,npoints + tca(j,ilev)=cc(j,ilev) + enddo + enddo + + if (ncolprint.ne.0) then + write (6,'(a)') 'frac_out_pp_rev:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') + & ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev) + + enddo + write (6,'(a)') 'ncol:' + write (6,'(I3)') ncol + endif + if (ncolprint.ne.0) then + write (6,'(a)') 'last_frac_pp:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') (tca(j,0)) + enddo + endif + +! ---------------------------------------------------! +! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS +! frac_out is the array that contains the information +! where 0 is no cloud, 1 is a stratiform cloud and 2 is a +! convective cloud + + !loop over vertical levels + DO 200 ilev = 1,nlev + +! Initialise threshold + + IF (ilev.eq.1) then + ! If max overlap + IF (overlap.eq.1) then + ! select pixels spread evenly + ! across the gridbox + DO ibox=1,ncol + do j=1,npoints + threshold(j,ibox)=boxpos(j,ibox) + enddo + enddo + ELSE + DO ibox=1,ncol +! include 'congvec_para.h' + include 'congvec.h' + ! select random pixels from the non-convective + ! part the gridbox ( some will be converted into + ! convective pixels below ) + do j=1,npoints + threshold(j,ibox)= + & conv(j,ilev)+(1-conv(j,ilev))*ran(j) + enddo + enddo + ENDIF + IF (ncolprint.ne.0) then + write (6,'(a)') 'threshold_nsf2:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + enddo + ENDIF + ENDIF + + IF (ncolprint.ne.0) then + write (6,'(a)') 'ilev:' + write (6,'(I2)') ilev + ENDIF + + DO ibox=1,ncol + + ! All versions + do j=1,npoints + if (boxpos(j,ibox).le.conv(j,ilev)) then + maxocc(j,ibox) = 1. + else + maxocc(j,ibox) = 0. + end if + enddo + + ! Max overlap + if (overlap.eq.1) then + do j=1,npoints + threshold_min(j,ibox)=conv(j,ilev) + maxosc(j,ibox)=1 + enddo + endif + + ! Random overlap + if (overlap.eq.2) then + do j=1,npoints + threshold_min(j,ibox)=conv(j,ilev) + maxosc(j,ibox)=0 + enddo + endif + + ! Max/Random overlap + if (overlap.eq.3) then + do j=1,npoints + threshold_min(j,ibox)=max(conv(j,ilev), + & min(tca(j,ilev-1),tca(j,ilev))) + if (threshold(j,ibox) + & .lt.min(tca(j,ilev-1),tca(j,ilev)) + & .and.(threshold(j,ibox).gt.conv(j,ilev))) then + maxosc(j,ibox)= 1 + else + maxosc(j,ibox)= 0 + end if + enddo + endif + + ! Reset threshold + + include 'congvec.h' + + do j=1,npoints + threshold(j,ibox)= + !if max overlapped conv cloud + & maxocc(j,ibox) * ( + & boxpos(j,ibox) + & ) + + !else + & (1-maxocc(j,ibox)) * ( + !if max overlapped strat cloud + & (maxosc(j,ibox)) * ( + !threshold=boxpos + & threshold(j,ibox) + & ) + + !else + & (1-maxosc(j,ibox)) * ( + !threshold_min=random[thrmin,1] + & threshold_min(j,ibox)+ + & (1-threshold_min(j,ibox))*ran(j) + & ) + & ) + enddo + + ENDDO ! ibox + +! Fill frac_out with 1's where tca is greater than the threshold + + DO ibox=1,ncol + do j=1,npoints + if (tca(j,ilev).gt.threshold(j,ibox)) then + frac_out(j,ibox,ilev)=1 + else + frac_out(j,ibox,ilev)=0 + end if + enddo + ENDDO + +! Code to partition boxes into startiform and convective parts +! goes here + + DO ibox=1,ncol + do j=1,npoints + if (threshold(j,ibox).le.conv(j,ilev)) then + ! = 2 IF threshold le conv(j) + frac_out(j,ibox,ilev) = 2 + else + ! = the same IF NOT threshold le conv(j) + frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev) + end if + enddo + ENDDO + +! Set last_frac to tca at this level, so as to be tca +! from last level next time round + + if (ncolprint.ne.0) then + + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'last_frac:' + write (6,'(8f5.2)') (tca(j,ilev-1)) + + write (6,'(a)') 'conv:' + write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint) + + write (6,'(a)') 'max_overlap_cc:' + write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'max_overlap_sc:' + write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'threshold_min_nsf2:' + write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'threshold_nsf2:' + write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + + write (6,'(a)') 'frac_out_pp_rev:' + write (6,'(8f5.2)') + & ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev) + enddo + endif + +200 CONTINUE !loop over nlev + + + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histdayCOSP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histdayCOSP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histdayCOSP.h (revision 1634) @@ -0,0 +1,139 @@ +! Ecriture des fichiers de sorties COSP +! Sorties journalierres +! Abderrahmane Idelkadi Septembre 2009 + + IF (MOD(itap,NINT(freq_COSP/dtime)).EQ.0) THEN + + itau_wcosp = itau_phy + itap + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"cllcalipso", & + itau_wcosp,stlidar%cldlayer(:,1)) + endif + if (cfg%Lclhcalipso) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"clhcalipso", & + itau_wcosp,stlidar%cldlayer(:,3)) + endif + if (cfg%Lclmcalipso) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"clmcalipso", & + itau_wcosp,stlidar%cldlayer(:,2)) + endif + if (cfg%Lcltcalipso) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"cltcalipso", & + itau_wcosp,stlidar%cldlayer(:,4)) + endif + if (cfg%Lclcalipso) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"clcalipso", & + itau_wcosp,stlidar%lidarcld) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histwrite_phy(nid_day_cosp,lCOSP, & + "cfad_lidarsr532_"//chcol(ii),itau_wcosp,stlidar%cfad_sr(:,ii,:)) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"parasol_refl", & + itau_wcosp,stlidar%parasolrefl) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histwrite_phy(nid_day_cosp,lCOSP,"atb532_"//chcol(ii), & + itau_wcosp,sglidar%beta_tot(:,ii,:)) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"beta_mol532", & + itau_wcosp,sglidar%beta_mol) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histwrite_phy(nid_day_cosp,lCOSP, & + "clisccp2_"//chcol(ii),itau_wcosp,isccp%fq_isccp(:,ii,:)) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"boxtauisccp", & + itau_wcosp,isccp%boxtau) + endif + if (cfg%Lboxptopisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"boxptopisccp", & + itau_wcosp,isccp%boxptop) + endif + if (cfg%Ltclisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"tclisccp", & + itau_wcosp,isccp%totalcldarea) + endif + if (cfg%Lctpisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"ctpisccp", & + itau_wcosp,isccp%meanptop) + endif + if (cfg%Ltauisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"tauisccp", & + itau_wcosp,isccp%meantaucld) + endif + if (cfg%Lalbisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"albisccp", & + itau_wcosp,isccp%meanalbedocld) + endif + if (cfg%Lmeantbisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"meantbisccp", & + itau_wcosp,isccp%meantb) + endif + if (cfg%Lmeantbclrisccp) then + CALL histwrite_phy(nid_day_cosp,lCOSP,"meantbclrisccp", & + itau_wcosp,isccp%meantbclr) + endif + endif ! Isccp + +! if (ok_sync) then +!$OMP MASTER + call histsync(nid_day_cosp) +!$OMP END MASTER +! endif + + ENDIF ! if freq_COSP Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histhfCOSP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histhfCOSP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histhfCOSP.h (revision 1634) @@ -0,0 +1,140 @@ +! Ecriture des fichiers de sorties COSP +! Sorties journalierres +! Abderrahmane Idelkadi Septembre 2009 + + IF (MOD(itap,NINT(freq_COSP/dtime)).EQ.0) THEN + + itau_wcosp = itau_phy + itap + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"cllcalipso", & + itau_wcosp,stlidar%cldlayer(:,1)) + endif + if (cfg%Lclhcalipso) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"clhcalipso", & + itau_wcosp,stlidar%cldlayer(:,3)) + endif + if (cfg%Lclmcalipso) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"clmcalipso", & + itau_wcosp,stlidar%cldlayer(:,2)) + endif + if (cfg%Lcltcalipso) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"cltcalipso", & + itau_wcosp,stlidar%cldlayer(:,4)) + endif + if (cfg%Lclcalipso) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"clcalipso", & + itau_wcosp,stlidar%lidarcld) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histwrite_phy(nid_hf_cosp,lCOSP, & + "cfad_lidarsr532_"//chcol(ii),itau_wcosp,stlidar%cfad_sr(:,ii,:)) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"parasol_refl", & + itau_wcosp,stlidar%parasolrefl) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histwrite_phy(nid_hf_cosp,lCOSP,"atb532_"//chcol(ii), & + itau_wcosp,sglidar%beta_tot(:,ii,:)) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"beta_mol532", & + itau_wcosp,sglidar%beta_mol) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histwrite_phy(nid_hf_cosp,lCOSP, & + "clisccp2_"//chcol(ii),itau_wcosp,isccp%fq_isccp(:,ii,:)) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"boxtauisccp", & + itau_wcosp,isccp%boxtau) + endif + if (cfg%Lboxptopisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"boxptopisccp", & + itau_wcosp,isccp%boxptop) + endif + if (cfg%Ltclisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"tclisccp", & + itau_wcosp,isccp%totalcldarea) + endif + if (cfg%Lctpisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"ctpisccp", & + itau_wcosp,isccp%meanptop) + + endif + if (cfg%Ltauisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"tauisccp", & + itau_wcosp,isccp%meantaucld) + endif + if (cfg%Lalbisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"albisccp", & + itau_wcosp,isccp%meanalbedocld) + endif + if (cfg%Lmeantbisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"meantbisccp", & + itau_wcosp,isccp%meantb) + endif + if (cfg%Lmeantbclrisccp) then + CALL histwrite_phy(nid_hf_cosp,lCOSP,"meantbclrisccp", & + itau_wcosp,isccp%meantbclr) + endif + endif ! Isccp + +! if (ok_sync) then +!$OMP MASTER + call histsync(nid_hf_cosp) +!$OMP END MASTER +! endif + + ENDIF ! if freq_COSP Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histmthCOSP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histmthCOSP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/write_histmthCOSP.h (revision 1634) @@ -0,0 +1,139 @@ +! Ecriture des fichiers de sorties COSP +! Sorties journalierres +! Abderrahmane Idelkadi Septembre 2009 + + IF (MOD(itap,NINT(freq_COSP/dtime)).EQ.0) THEN + + itau_wcosp = itau_phy + itap + +! Sorties LIDAR + if (cfg%Llidar_sim) then + if (cfg%Lcllcalipso) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"cllcalipso",itau_wcosp, & + stlidar%cldlayer(:,1)) + endif + if (cfg%Lclhcalipso) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"clhcalipso",itau_wcosp, & + stlidar%cldlayer(:,3)) + endif + if (cfg%Lclmcalipso) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"clmcalipso",itau_wcosp, & + stlidar%cldlayer(:,2)) + endif + if (cfg%Lcltcalipso) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"cltcalipso",itau_wcosp, & + stlidar%cldlayer(:,4)) + endif + if (cfg%Lclcalipso) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"clcalipso",itau_wcosp, & + stlidar%lidarcld) + endif + if (cfg%Lcfad_lidarsr532) then + do ii=1,SR_BINS + CALL histwrite_phy(nid_mth_cosp,lCOSP, & + "cfad_lidarsr532_"//chcol(ii),itau_wcosp,stlidar%cfad_sr(:,ii,:)) + enddo + endif + if (cfg%Lparasol_refl) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"parasol_refl", & + itau_wcosp,stlidar%parasolrefl) + endif + if (cfg%Latb532) then + do ii=1,Ncolumns + CALL histwrite_phy(nid_mth_cosp,lCOSP, & + "atb532_"//chcol(ii),itau_wcosp,sglidar%beta_tot(:,ii,:)) + enddo + endif + if (cfg%Lbeta_mol532) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"beta_mol532", & + itau_wcosp,sglidar%beta_mol) + endif + endif ! Lidar + +! Sorties RADAR +!Attention A FAIRE +! if (cfg%Lradar_sim) then +! print*,'Ecriture sorties Radar' +! if (cfg%Lcfad_dbze94) then +! print*,'Ecriture de cfad_dbze94.nc ' +! A revoir l axe vertical Nlvgrid +! do ii=1,DBZE_BINS +! dbze_ax(ii) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(ii - 0.5) +! enddo +! call write_netcdf4d('cfad_dbze94.nc',use_vgrid,nlon,nlat,Nlevout,DBZE_BINS, & +! x,y,out_levs,dbze_ax,i,ndays,time,stradar%cfad_ze) +! endif +! if (cfg%Lclcalipso2) then +! call write_netcdf3d('clcalipso2.nc',use_vgrid,'clcalipso2', & +! nlon,nlat,Nlevout,x,y,out_levs,i,ndays,time,stradar%lidar_only_freq_cloud) +! endif +! if (cfg%Ldbze94) then +! do ii=1,Ncolumns +! xcol(ii)=float(i) +! enddo +! call write_netcdf4d('dbze94.nc',use_vgrid,nlon,nlat,Nlevout,Ncolumns, & +! x,y,out_levs,xcol,i,ndays,time,sgradar%Ze_tot) +! endif +! if (cfg%Lcltlidarradar) then +! call write_netcdf2d('cltlidarradar.nc','cltlidarradar', & +! nlon,nlat,x,y,i,ndays,time,stradar%radar_lidar_tcc) +! endif +! endif ! Radar + +! Sorties MISR +!Attention A FAIRE +! if (cfg%Lmisr_sim) then +! print*,'Ecriture sorties Misr' +! call write_netcdf4d('clMISR.nc',use_vgrid,nlon,nlat,MISR_N_CTH,7, & +! x,y,MISR_CTH,ISCCP_TAU,i,ndays,time,misr%fq_MISR) +! endif + +! Sorties ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lclisccp2) then + do ii=1,7 + CALL histwrite_phy(nid_mth_cosp,lCOSP,"clisccp2_"//chcol(ii), & + itau_wcosp,isccp%fq_isccp(:,ii,:)) + enddo + endif + if (cfg%Lboxtauisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"boxtauisccp", & + itau_wcosp,isccp%boxtau) + endif + if (cfg%Lboxptopisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"boxptopisccp", & + itau_wcosp,isccp%boxptop) + endif + if (cfg%Ltclisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"tclisccp", & + itau_wcosp,isccp%totalcldarea) + endif + if (cfg%Lctpisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"ctpisccp", & + itau_wcosp,isccp%meanptop) + endif + if (cfg%Ltauisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"tauisccp", & + itau_wcosp,isccp%meantaucld) + endif + if (cfg%Lalbisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"albisccp", & + itau_wcosp,isccp%meanalbedocld) + endif + if (cfg%Lmeantbisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"meantbisccp", & + itau_wcosp,isccp%meantb) + endif + if (cfg%Lmeantbclrisccp) then + CALL histwrite_phy(nid_mth_cosp,lCOSP,"meantbclrisccp", & + itau_wcosp,isccp%meantbclr) + endif + endif ! Isccp + +! if (ok_sync) then +!$OMP MASTER + call histsync(nid_mth_cosp) +!$OMP END MASTER +! endif + + ENDIF ! if freq_COSP Index: LMDZ5/branches/LMDZ5_AR5/libf/cosp/zeff.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/cosp/zeff.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/cosp/zeff.F90 (revision 1634) @@ -0,0 +1,161 @@ + subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e) + use math_lib + use optics_lib + implicit none + +! Purpose: +! Simulates radar return of a volume given DSD of spheres +! Part of QuickBeam v1.03 by John Haynes +! http://reef.atmos.colostate.edu/haynes/radarsim +! +! Inputs: +! [freq] radar frequency (GHz) +! [D] discrete drop sizes (um) +! [N] discrete concentrations (cm^-3 um^-1) +! [nsizes] number of discrete drop sizes +! [k2] |K|^2, -1=use frequency dependent default +! [tt] hydrometeor temperature (C) +! [ice] indicates volume consists of ice +! [xr] perform Rayleigh calculations? +! [qe] if using a mie table, these contain ext/sca ... +! [qs] ... efficiencies; otherwise set to -1 +! [rho_e] medium effective density (kg m^-3) (-1 = pure) +! +! Outputs: +! [z_eff] unattenuated effective reflectivity factor (mm^6/m^3) +! [z_ray] reflectivity factor, Rayleigh only (mm^6/m^3) +! [kr] attenuation coefficient (db km^-1) +! +! Created: +! 11/28/05 John Haynes (haynes@atmos.colostate.edu) + +! ----- INPUTS ----- + integer, intent(in) :: ice, xr + integer, intent(in) :: nsizes + real*8, intent(in) :: freq,D(nsizes),N(nsizes),tt,qe(nsizes), & + qs(nsizes), rho_e(nsizes) + real*8, intent(inout) :: k2 + +! ----- OUTPUTS ----- + real*8, intent(out) :: z_eff,z_ray,kr + +! ----- INTERNAL ----- + integer :: & + correct_for_rho ! correct for density flag + real*8, dimension(nsizes) :: & + D0, & ! D in (m) + N0, & ! N in m^-3 m^-1 + sizep, & ! size parameter + qext, & ! extinction efficiency + qbsca, & ! backscatter efficiency + rho_ice, & ! bulk density ice (kg m^-3) + f ! ice fraction + real*8 :: & + wl, & ! wavelength (m) + cr ! kr(dB/km) = cr * kr(1/km) + complex*16 :: & + m ! complex index of refraction of bulk form + complex*16, dimension(nsizes) :: & + m0 ! complex index of refraction + + integer*4 :: i,one + real*8 :: pi + real*8 :: eta_sum, eta_mie, const, z0_eff, z0_ray, k_sum, & + n_r, n_i, dqv(1), dqxt, dqsc, dbsc, dg, dph(1) + integer*4 :: err + complex*16 :: Xs1(1), Xs2(1) + + one=1 + pi = acos(-1.0) + rho_ice(:) = 917 + z0_ray = 0.0 + +! // conversions + D0 = d*1E-6 ! m + N0 = n*1E12 ! 1/(m^3 m) + wl = 2.99792458/(freq*10) ! m + +! // dielectric constant |k^2| defaults + if (k2 < 0) then + k2 = 0.933 + if (abs(94.-freq) < 3.) k2=0.75 + if (abs(35.-freq) < 3.) k2=0.88 + if (abs(13.8-freq) < 3.) k2=0.925 + endif + + if (qe(1) < -9) then + +! // get the refractive index of the bulk hydrometeors + if (ice == 0) then + call m_wat(freq,tt,n_r,n_i) + else + call m_ice(freq,tt,n_r,n_i) + endif + m = cmplx(n_r,-n_i) + m0(:) = m + + correct_for_rho = 0 + if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1 + +! :: correct refractive index for ice density if needed + if (correct_for_rho == 1) then + f = rho_e/rho_ice + m0 = ((2+m0**2+2*f*(m0**2-1))/(2+m0**2+f*(1-m0**2)))**(0.5) + endif + +! :: Mie calculations + sizep = (pi*D0)/wl + dqv(1) = 0. + do i=1,nsizes + call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), & + dg, xs1, xs2, dph, err) + end do + + else +! // Mie table used + + qext = qe + qbsca = qs + + endif + +! // eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD] +! <--------- eta_sum ---------> +! // z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie + eta_sum = 0. + if (size(D0) == 1) then + eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)**2 + else + call avint(qbsca*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum) + endif + + eta_mie = eta_sum*0.25*pi + const = (wl**4/pi**5)*(1./k2) + z0_eff = const*eta_mie + +! // kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD] +! <---------- k_sum ---------> + k_sum = 0. + if (size(D0) == 1) then + k_sum = qext(1)*(n(1)*1E6)*D0(1)**2 + else + call avint(qext*N0*D0**2,D0,nsizes,D0(1),D0(size(D0,1)),k_sum) + endif + cr = 10./log(10.) + kr = k_sum*0.25*pi*(1000.*cr) + +! // z_ray = sum[D^6*N(D)*deltaD] + if (xr == 1) then + z0_ray = 0. + if (size(D0) == 1) then + z0_ray = (n(1)*1E6)*D0(1)**6 + else + call avint(N0*D0**6,D0,nsizes,D0(1),D0(size(D0)),z0_ray) + endif + endif + +! // convert to mm^6/m^3 + z_eff = z0_eff*1E18 ! 10.*alog10(z0_eff*1E18) + z_ray = z0_ray*1E18 ! 10.*alog10(z0_ray*1E18) + + end subroutine zeff Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/PVtheta.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/PVtheta.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/PVtheta.F (revision 1634) @@ -0,0 +1,196 @@ + SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ nbteta,theta,PVteta) + IMPLICIT none + +c======================================================================= +c +c Auteur: I. Musat +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c Calcul de la vorticite potentielle PVteta sur des iso-theta selon +c la methodologie du NCEP/NCAR : +c 1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les +c niveaux du modele => N2 +c 2) on interpole les vents, la temperature et le N**2 sur des isentropes +c (en fait sur des iso-theta) lineairement en log(theta) => +c ucovteta, vcovteta, N2teta +c 3) on calcule la vorticite absolue sur des iso-theta => vorateta +c 4) on calcule la densite rho sur des iso-theta => rhoteta +c +c rhoteta = (T/theta)**(cp/R)*p0/(R*T) +c +c 5) on calcule la vorticite potentielle sur des iso-theta => PVteta +c +c PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU +c +c NB: 1PVU=10**(-6) K*m**2/(s * kg) +c +c PVteta = vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s) +c +c +c ******************************************************************* +c +c +c Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta +c -> sur la grille dynamique +c Variable de sortie : PVteta +c -> sur la grille physique +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +c +c variables Input +c + INTEGER ilon, ilev + REAL pvcov(iip1,jjm,ilev) + REAL pucov(iip1,jjp1,ilev) + REAL pteta(iip1,jjp1,ilev) + REAL ztfi(ilon,ilev) + REAL zplay(ilon,ilev), zplev(ilon,ilev+1) + INTEGER nbteta + REAL theta(nbteta) +c +c variable Output +c + REAL PVteta(ilon,nbteta) +c +c variables locales +c + INTEGER i, j, l, ig0 + REAL SSUM + REAL teta(ilon, ilev) + REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev) + REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev) + REAL N2(ilon,ilev-1), N2teta(ilon,nbteta) + REAL ztfiteta(ilon,nbteta) + REAL rhoteta(ilon,nbteta) + REAL vorateta(iip1,jjm,nbteta) + REAL voratetafi(ilon,nbteta), vorpol(iim) +c +#include "comgeom2.h" +#include "comconst.h" +#include "comvert.h" +c +c projection teta sur la grille physique +c + DO l=1,llm + teta(1,l) = pteta(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i = 1, iim + teta(ig0,l) = pteta(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + teta(ig0,l) = pteta(1,jjp1,l) + ENDDO +c +c calcul pteta sur les grilles U et V +c + DO l=1, llm + DO j=1, jjp1 + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetau(ig0,l)=pteta(i,j,l) + ENDDO !i + ENDDO !j + DO j=1, jjm + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l)) + ENDDO !i + ENDDO !j + ENDDO !l +c +c projection pucov, pvcov sur une surface de theta constante +c + DO l=1, nbteta +cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l), + CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l), + . pucov,ucovteta(:,l)) +cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l), + CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l), + . pvcov,vcovteta(:,l)) + ENDDO !l +c +c calcul vorticite absolue sur une iso-theta : vorateta +c + CALL tourabs(nbteta,vcovteta,ucovteta,vorateta) +c +c projection vorateta sur la grille physique => voratetafi +c + DO l=1,nbteta + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) + + $ vorateta(i+1,j-1,l) * alpha1(i+1,j) + + $ vorateta(i ,j ,l) * alpha3(i+1,j) + + $ vorateta(i+1,j ,l) * alpha2(i+1,j) + ENDDO + voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l) + ENDDO + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,1,l)*aire(i,1) + ENDDO + voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,jjm,l)* aire(i,jjm +1) + ENDDO + voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols + ENDDO +c +c calcul N**2 sur la grille physique => N2 +c + DO l=1, llm-1 + DO i=1, ilon + N2(i,l) = (g**2 * zplay(i,l) * + $ (ztfi(i,l+1)-ztfi(i,l)) )/ + $ (R*ztfi(i,l)*ztfi(i,l)* + $ (zplev(i,l)-zplev(i,l+1)) )+ + $ (g**2)/(ztfi(i,l)*CPP) + ENDDO !i + ENDDO !l +c +c calcul N2 sur une iso-theta => N2teta +c + DO l=1, nbteta + CALL tetalevel(ilon,llm-1,.true.,teta,theta(l), + $ N2,N2teta(:,l)) + CALL tetalevel(ilon,llm,.true.,teta,theta(l), + $ ztfi,ztfiteta(:,l)) + ENDDO !l=1, nbteta +c +c calcul rho et PV sur une iso-theta : rhoteta, PVteta +c + DO l=1, nbteta + DO i=1, ilon + rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)* + $ (preff/(R*ztfiteta(i,l))) +c +c PVteta en PVU +c + PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) +c +c PVteta en 1/(Pa*s) +c + PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) + ENDDO !i + ENDDO !l +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/abort_gcm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/abort_gcm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/abort_gcm.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Id$ +! +c +c + SUBROUTINE abort_gcm(modname, message, ierr) + +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin_dump + USE ioipsl_getincom +#endif +#include "iniprint.h" + +C +C Stops the simulation cleanly, closing files and printing various +C comments +C +C Input: modname = name of calling program +C message = stuff to print +C ierr = severity of situation ( = 0 normal ) + + character(len=*) modname + integer ierr + character(len=*) message + + write(lunout,*) 'in abort_gcm' +#ifdef CPP_IOIPSL + call histclo + call restclo +#endif + call getin_dump +c call histclo(2) +c call histclo(3) +c call histclo(4) +c call histclo(5) + write(lunout,*) 'Stopping in ', modname + write(lunout,*) 'Reason = ',message + if (ierr .eq. 0) then + write(lunout,*) 'Everything is cool' + stop + else + write(lunout,*) 'Houston, we have a problem ', ierr + stop 1 + endif + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/academic.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/academic.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/academic.h (revision 1634) @@ -0,0 +1,9 @@ +! +! $Id$ +! + common/academic/tetarappel,knewt_t,kfrict,knewt_g,clat4 + real :: tetarappel(ip1jmp1,llm) + real :: knewt_t(llm) + real :: kfrict(llm) + real :: knewt_g + real :: clat4(ip1jmp1) Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/adaptdt.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/adaptdt.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/adaptdt.F (revision 1634) @@ -0,0 +1,59 @@ +! +! $Id$ +! + subroutine adaptdt(nadv,dtbon,n,pbaru, + c masse) + + USE control_mod + IMPLICIT NONE + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + +c---------------------------------------------------------- +c Arguments +c---------------------------------------------------------- + INTEGER n,nadv + REAL dtbon + REAL pbaru(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) +c---------------------------------------------------------- +c Local +c---------------------------------------------------------- + INTEGER i,j,l + REAL CFLmax,aaa,bbb + + CFLmax=0. + do l=1,llm + do j=2,jjm + do i=1,iim + aaa=pbaru(i,j,l)*dtvr/masse(i,j,l) + CFLmax=max(CFLmax,aaa) + bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l) + CFLmax=max(CFLmax,bbb) + enddo + enddo + enddo + n=int(CFLmax)+1 +c pour reproduire cas VL du code qui appele x,y,z,y,x +c if (nadv.eq.30) n=n/2 ! Pour Prather + dtbon=dtvr/n + + return + end + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/addfi.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/addfi.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/addfi.F (revision 1634) @@ -0,0 +1,181 @@ +! +! $Id$ +! + SUBROUTINE addfi(pdt, leapf, forward, + S pucov, pvcov, pteta, pq , pps , + S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) + + USE infotrac, ONLY : nqtot + USE control_mod, ONLY : planet_type + IMPLICIT NONE +c +c======================================================================= +c +c Addition of the physical tendencies +c +c Interface : +c ----------- +c +c Input : +c ------- +c pdt time step of integration +c leapf logical +c forward logical +c pucov(ip1jmp1,llm) first component of the covariant velocity +c pvcov(ip1ip1jm,llm) second component of the covariant velocity +c pteta(ip1jmp1,llm) potential temperature +c pts(ip1jmp1,llm) surface temperature +c pdufi(ip1jmp1,llm) | +c pdvfi(ip1jm,llm) | respective +c pdhfi(ip1jmp1) | tendencies +c pdtsfi(ip1jmp1) | +c +c Output : +c -------- +c pucov +c pvcov +c ph +c pts +c +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" +c +c Arguments : +c ----------- +c + REAL pdt +c + REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm) + REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1) +c + REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm) + REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1) +c + LOGICAL leapf,forward +c +c +c Local variables : +c ----------------- +c + REAL xpn(iim),xps(iim),tpn,tps + INTEGER j,k,iq,ij + REAL qtestw, qtestt + PARAMETER ( qtestw = 1.0e-15 ) + PARAMETER ( qtestt = 1.0e-40 ) + + REAL SSUM +c +c----------------------------------------------------------------------- + + DO k = 1,llm + DO j = 1,ip1jmp1 + pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt + ENDDO + ENDDO + + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pteta( ij ,k) + xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k) + ENDDO + tpn = SSUM(iim,xpn,1)/ apoln + tps = SSUM(iim,xps,1)/ apols + + DO ij = 1, iip1 + pteta( ij ,k) = tpn + pteta(ij+ip1jm,k) = tps + ENDDO + ENDDO +c + + DO k = 1,llm + DO j = iip2,ip1jm + pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt + ENDDO + ENDDO + + DO k = 1,llm + DO j = 1,ip1jm + pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt + ENDDO + ENDDO + +c + DO j = 1,ip1jmp1 + pps(j) = pps(j) + pdpfi(j) * pdt + ENDDO + + if (planet_type=="earth") then + ! earth case, special treatment for first 2 tracers (water) + DO iq = 1, 2 + DO k = 1,llm + DO j = 1,ip1jmp1 + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw ) + ENDDO + ENDDO + ENDDO + + DO iq = 3, nqtot + DO k = 1,llm + DO j = 1,ip1jmp1 + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO + ENDDO + else + ! general case, treat all tracers equally) + DO iq = 1, nqtot + DO k = 1,llm + DO j = 1,ip1jmp1 + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO + ENDDO + endif ! of if (planet_type=="earth") + + + DO ij = 1, iim + xpn(ij) = aire( ij ) * pps( ij ) + xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm ) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pps ( ij ) = tpn + pps ( ij+ip1jm ) = tps + ENDDO + + + DO iq = 1, nqtot + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pq( ij ,k,iq) + xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pq ( ij ,k,iq) = tpn + pq (ij+ip1jm,k,iq) = tps + ENDDO + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advect.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advect.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advect.F (revision 1634) @@ -0,0 +1,166 @@ +! +! $Header$ +! + SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta) + + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) + +c Local: +c ------ + + REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1) + REAL unsaire2(ip1jmp1), ge(ip1jmp1) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l + + REAL SSUM + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + + DO l=1,llm + DO ij = iip2, ip1jmp1 + uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) + ENDDO + DO ij = iip2, ip1jm + uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) + ENDDO + DO ij = 1, iip1 + uav(ij ,l) = 0. + uav(ip1jm+ij,l) = 0. + ENDDO + ENDDO + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + DO l=1,llm + DO ij = 2, ip1jm + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + DO ij = 1,ip1jm,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + DO ij = 1, ip1jm-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + DO ij = 1, ip1jm, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + ENDDO + +c----------------------------------------------------------------------- + +c + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + + DO 5 ij = 1, ip1jmp1 + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + DO 6 ij = iip2 ,ip1jm-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du(ij,l) = du(ij,l) - ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ..... correction pour du(iip1,j,l) ........ +c ..... du(iip1,j,l)= du(1,j,l) ..... + +CDIR$ IVDEP + DO 7 ij = iip1 +iip1, ip1jm, iip1 + du( ij, l ) = du( ij -iim, l ) + du( ij,l+1 ) = du( ij -iim,l+1 ) + 7 CONTINUE + +c ................. calcul pour dv ..................... + + DO 8 ij = 1, ip1jm + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv(ij,l) = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + + DO 15 ij = 1, ip1jmp1 + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta(ij, l ) = dteta(ij, l ) - ww + dteta(ij,l+1) = dteta(ij,l+1) + ww + 15 CONTINUE + + IF( conser) THEN + DO 17 ij = 1,ip1jmp1 + ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) + 17 CONTINUE + gt = SSUM( ip1jmp1,ge,1 ) + gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) + END IF + + 20 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advn.F (revision 1634) @@ -0,0 +1,983 @@ +! +! $Header$ +! + SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "iniprint.h" + +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + integer ijlqmin,iqmin,jqmin,lqmin + integer ismin +c + real zm(ip1jmp1,llm),newmasse + real mu(ip1jmp1,llm) + real mv(ip1jm,llm) + real mw(ip1jmp1,llm+1) + real zq(ip1jmp1,llm),zz,qpn,qps + real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm) + real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm) + real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm) + real temps0,temps1,temps2,temps3 + real ztemps1,ztemps2,ztemps3,ssum + logical testcpu + save testcpu + save temps1,temps2,temps3 + real zzpbar,zzw + +#ifdef CRAY + real second +#endif + + real qmin,qmax + data qmin,qmax/0.,1./ + data testcpu/.false./ + data temps1,temps2,temps3/0.,0.,0./ + + zzpbar = 0.5 * pdt + zzw = pdt + + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + do l=1,llm + qpn=0. + qps=0. + do ij=1,iim + qpn=qpn+q(ij,l)*masse(ij,l) + qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l) + enddo + qpn=qpn/ssum(iim,masse(1,l),1) + qps=qps/ssum(iim,masse(ip1jm+1,l),1) + do ij=1,iip1 + q(ij,l)=qpn + q(ip1jm+ij,l)=qps + enddo + enddo + + do ij=1,ip1jmp1 + mw(ij,llm+1)=0. + enddo + do l=1,llm + do ij=1,ip1jmp1 + zq(ij,l)=q(ij,l) + zm(ij,l)=masse(ij,l) + enddo + enddo + +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqz(zq,zqh,zqb) + call advnz(zq,zqh,zqb,zm,mw) +c call vlz(zq,0.,zm,mw) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) +c call minmaxq(zq,qmin,qmax,'apres vlx ') + +#ifdef CRAY + if(testcpu) then + ztemps1=second(0.) + temps1=temps1+ztemps1-ztemps2 + print*,'VLSPLT X:',temps1,' Y:',temps2,' Z:',temps3 + endif +#endif + do l=1,llm + do ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + enddo + do ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + enddo + enddo + + RETURN + END + + SUBROUTINE advnqx(q,qg,qd) +c +c Auteurs: Calcul des valeurs de q aux point u. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dxqu(ip1jmp1),zqu(ip1jmp1) + real zqmax(ip1jmp1),zqmin(ip1jmp1) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jm + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + enddo + enddo + else + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + zqu(ij)=0.5*(q(ij+1,l)+q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2,ip1jm-1 + zqu(ij)=zqu(ij)-dxqu(ij+1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2+1,ip1jm + zqu(ij)=zqu(ij)+dxqu(ij-1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij-iim)=zqu(ij) + enddo + +c calcul des valeurs max et min acceptees aux interfaces + + do ij=iip2,ip1jm-1 + zqmax(ij)=max(q(ij+1,l),q(ij,l)) + zqmin(ij)=min(q(ij+1,l),q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqmax(ij)=zqmax(ij-iim) + zqmin(ij)=zqmin(ij-iim) + enddo + do ij=iip2+1,ip1jm + extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0. + enddo + do ij=iip1+iip1,ip1jm,iip1 + extremum(ij-iim)=extremum(ij) + enddo + do ij=iip2,ip1jm + zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij)) + enddo + do ij=iip2+1,ip1jm + if(extremum(ij)) then + qg(ij,l)=q(ij,l) + qd(ij,l)=q(ij,l) + else + qd(ij,l)=zqu(ij) + qg(ij,l)=zqu(ij-1) + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + qg(ij-iim,l)=qg(ij,l) + enddo + + goto 8888 + + do ij=iip2+1,ip1jm + if(extremum(ij).and..not.extremum(ij-1)) + s qd(ij-1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + enddo + do ij=iip2,ip1jm-1 + if (extremum(ij).and..not.extremum(ij+1)) + s qg(ij+1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qg(ij,l)=qg(ij-iim,l) + enddo +8888 continue + enddo + endif + RETURN + END + SUBROUTINE advnqy(q,qs,qn) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dyqv(ip1jm),zqv(ip1jm,llm) + real zqmax(ip1jm),zqmin(ip1jm) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qn(ij,l)=q(ij,l) + qs(ij,l)=q(ij,l) + enddo + enddo + else + +c calcul des pentes en u: +c ----------------------- + do l = 1, llm + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + enddo + + do ij=iip2,ip1jm-iip1 + zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l)) + zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12. + enddo + + do ij=iip2,ip1jm + extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0. + enddo + +c Pas de pentes aux poles + do ij=1,iip1 + zqv(ij,l)=q(ij,l) + zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l) + extremum(ij)=.true. + extremum(ip1jmp1-iip1+ij)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do ij=1,ip1jm + zqmax(ij)=max(q(ij+iip1,l),q(ij,l)) + zqmin(ij)=min(q(ij+iip1,l),q(ij,l)) + enddo + + do ij=1,ip1jm + zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij)) + enddo + + do ij=iip2,ip1jm + if(extremum(ij)) then + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) +c if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l) +c if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l) + else + qs(ij,l)=zqv(ij,l) + qn(ij,l)=zqv(ij-iip1,l) + endif + enddo + + do ij=1,iip1 + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) + qs(ip1jm+ij,l)=q(ip1jm+ij,l) + qn(ip1jm+ij,l)=q(ip1jm+ij,l) + enddo + + enddo + endif + RETURN + END + + SUBROUTINE advnqz(q,qh,qb) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1) + real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm) + logical extremum(ip1jmp1,llm) + + integer mode + save mode + + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qb(ij,l)=q(ij,l) + qh(ij,l)=q(ij,l) + enddo + enddo + else + do l = 2, llm + do ij=1,ip1jmp1 + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l)) + enddo + enddo + do ij=1,ip1jmp1 + dzqw(ij,1)=0. + dzqw(ij,llm+1)=0. + enddo + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12. + enddo + enddo + do l=2,llm-1 + do ij=1,ip1jmp1 + extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0. + enddo + enddo + +c Pas de pentes en bas et en haut + do ij=1,ip1jmp1 + zqw(ij,2)=q(ij,1) + zqw(ij,llm)=q(ij,llm) + extremum(ij,1)=.true. + extremum(ij,llm)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do l=2,llm + do ij=1,ip1jmp1 + zqmax(ij,l)=max(q(ij,l-1),q(ij,l)) + zqmin(ij,l)=min(q(ij,l-1),q(ij,l)) + enddo + enddo + + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l)) + enddo + enddo + + do l=2,llm-1 + do ij=1,ip1jmp1 + if(extremum(ij,l)) then + qh(ij,l)=q(ij,l) + qb(ij,l)=q(ij,l) + else + qh(ij,l)=zqw(ij,l+1) + qb(ij,l)=zqw(ij,l) + endif + enddo + enddo +c do l=2,llm-1 +c do ij=1,ip1jmp1 +c if(extremum(ij,l)) then +c if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l) +c if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l) +c endif +c enddo +c enddo + + do ij=1,ip1jmp1 + qb(ij,1)=q(ij,1) + qh(ij,1)=q(ij,1) + qb(ij,llm)=q(ij,llm) + qh(ij,llm)=q(ij,llm) + enddo + + endif + + RETURN + END + + SUBROUTINE advnx(q,qg,qd,masse,u_m,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + real u_m( ip1jmp1,llm ) + real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq + integer n0,nl(llm) +c + real new_m,zu_m,zdq,zz + real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig + real u_mq(ip1jmp1,llm) + + real zm,zq,zsigm,zsigp,zqm,zqp,zu + + logical ladvplus(ip1jmp1,llm) + + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + + do l=1,llm + do ij=iip2,ip1jm + zdq=qd(ij,l)-qg(ij,l) +c if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qd(ij,l),q(ij,l),qg(ij,l) +c qd(ij,l)=q(ij,l) +c qg(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq + zsigg(ij,l)=1.-zsigd(ij,l) +c if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and. +c s zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigg=',zsigg(ij,l),' sigd=',zsigd(ij,l) +c print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq +c stop +c endif + else + zsigd(ij,l)=0.5 + zsigg(ij,l)=0.5 + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + endif + enddo + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=1,llm + do ij=iip2,ip1jm-1 + if (u_m(ij,l).ge.0.) then + zsigp=zsigd(ij,l) + zsigm=zsigg(ij,l) + zqp=qd(ij,l) + zqm=qg(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigd(ij+1,l) + zsigp=zsigg(ij+1,l) + zqm=qd(ij+1,l) + zqp=qg(ij+1,l) + zm=masse(ij+1,l) + zq=q(ij+1,l) + endif + zu=abs(u_m(ij,l)) + ladvplus(ij,l)=zu.gt.zm + zsig=zu/zm + if(zsig.eq.0.) zsigp=0.1 + if (mode.eq.1) then + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*zqp + else if (mode.eq.1) then + u_mq(ij,l)= + s sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm) + endif + else + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + endif +c if(zsig.lt.0.) then +c print*,'au point ij=',ij,' l=',l,' sig=',zsig +c stop +c endif + enddo + enddo + + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ladvplus(ij,l)=ladvplus(ij-iim,l) + enddo + enddo + +c================================================================= +C SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES +c================================================================= +c tris des regions a traiter + n0=0 + do l=1,llm + nl(l)=0 + do ij=iip2,ip1jm + if(ladvplus(ij,l)) then + nl(l)=nl(l)+1 + u_mq(ij,l)=0. + endif + enddo + n0=n0+nl(l) + enddo + + if(n0.gt.1) then + IF (prt_level > 9) WRITE(lunout,*) + & 'Nombre de points pour lesquels on advect plus que le' + & ,'contenu de la maille : ',n0 + + do l=1,llm + if(nl(l).gt.0) then + iju=0 +c indicage des mailles concernees par le traitement special + do ij=iip2,ip1jm + if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then + iju=iju+1 + indu(iju)=ij + endif + enddo + niju=iju +c print*,'niju,nl',niju,nl(l) + +c traitement des mailles + do iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + if(zu_m.gt.0.) then + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + enddo +c MODIFS SPECIFIQUES DU SCHEMA +c ajout de la maille non completement advectee + zsig=zu_m/masse(ijq,l) + if(zsig.le.zsigd(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l) + s -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 8888 + zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme2 au point ij=',ij, + s ' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*( + s 0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l) + s +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) ) + endif + else + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + enddo +c ajout de la maille non completement advectee +c 2eme MODIF SPECIFIQUE + zsig=-zu_m/masse(ij+1,l) + if(zsig.le.zsigg(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l) + s -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 9999 + zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme22 au point ij=',ij + s ,' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*( + s 0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l) + s +(zsig-zsigg(ijq,l))* + s (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) ) + endif +c fin de la modif + endif + enddo + endif + enddo + endif ! n0.gt.0 + +c bouclage en latitude + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + enddo + enddo + +c================================================================= +c CALCUL DE LA CONVERGENCE DES FLUX +c================================================================= + + do l=1,llm + do ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + do ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + enddo + enddo + + RETURN + END + SUBROUTINE advny(q,qs,qn,masse,v_m) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real v_m( ip1jm,llm ) + real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigs(ip1jmp1),zsign(ip1jmp1),zsig + real v_mq(ip1jm,llm) + real convpn,convps,convmpn,convmps,massen,masses + real zm,zq,zsigm,zsigp,zqm,zqp + real ssum + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + do l=1,llm + do ij=1,ip1jmp1 + zdq=qn(ij,l)-qs(ij,l) +c if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l,' advnqx' +c print*,qn(ij,l),q(ij,l),qs(ij,l) +c qn(ij,l)=q(ij,l) +c qs(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsign(ij)=(q(ij,l)-qs(ij,l))/zdq + zsigs(ij)=1.-zsign(ij) +c if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and. +c s zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigs=',zsigs(ij),' sign=',zsign(ij) +c stop +c endif + else + zsign(ij)=0.5 + zsigs(ij)=0.5 + endif + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=1,ip1jm + if (v_m(ij,l).ge.0.) then + zsigp=zsign(ij+iip1) + zsigm=zsigs(ij+iip1) + zqp=qn(ij+iip1,l) + zqm=qs(ij+iip1,l) + zm=masse(ij+iip1,l) + zq=q(ij+iip1,l) + else + zsigm=zsign(ij) + zsigp=zsigs(ij) + zqm=qn(ij,l) + zqp=qs(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + endif + zsig=abs(v_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do l=1,llm + do ij=iip2,ip1jm + new_m=masse(ij,l) + & +v_m(ij,l)-v_m(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l)) + & /new_m + masse(ij,l)=new_m + enddo +c.-. ancienne version + convpn=SSUM(iim,v_mq(1,l),1) + convmpn=ssum(iim,v_m(1,l),1) + massen=ssum(iim,masse(1,l),1) + new_m=massen+convmpn + q(1,l)=(q(1,l)*massen+convpn)/new_m + do ij = 1,iip1 + q(ij,l)=q(1,l) + masse(ij,l)=new_m*aire(ij)/apoln + enddo + + convps=-SSUM(iim,v_mq(ip1jm-iim,l),1) + convmps=-ssum(iim,v_m(ip1jm-iim,l),1) + masses=ssum(iim,masse(ip1jm+1,l),1) + new_m=masses+convmps + q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m + do ij = ip1jm+1,ip1jmp1 + q(ij,l)=q(ip1jm+1,l) + masse(ij,l)=new_m*aire(ij)/apols + enddo + enddo + + RETURN + END + SUBROUTINE advnz(q,qh,qb,masse,w_m) +c +c Auteurs: F.Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c b designe le bas et h le haut +c il y a une correspondance entre le b en z et le d en x +c ******************************************************************** +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real w_m( ip1jmp1,llm+1) + real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm) + +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig + real w_mq(ip1jmp1,llm+1) + real zm,zq,zsigm,zsigp,zqm,zqp + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-13/ +#endif + + do l=1,llm + do ij=1,ip1jmp1 + zdq=qb(ij,l)-qh(ij,l) +c if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qh(ij,l),q(ij,l),qb(ij,l) +c qh(ij,l)=q(ij,l) +c qb(ij,l)=q(ij,l) +c endif + + if(abs(zdq).gt.prec) then + zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq + zsigh(ij,l)=1.-zsigb(ij,l) + zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.) + else + zsigb(ij,l)=0.5 + zsigh(ij,l)=0.5 + endif + enddo + enddo + +c print*,'ok1' +c calcul de la pente maximum dans la maille en valeur absolue + do l=2,llm + do ij=1,ip1jmp1 + if (w_m(ij,l).ge.0.) then + zsigp=zsigb(ij,l) + zsigm=zsigh(ij,l) + zqp=qb(ij,l) + zqm=qh(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigb(ij,l-1) + zsigp=zsigh(ij,l-1) + zqm=qb(ij,l-1) + zqp=qh(ij,l-1) + zm=masse(ij,l-1) + zq=q(ij,l-1) + endif + zsig=abs(w_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do ij=1,ip1jmp1 + w_mq(ij,llm+1)=0. + w_mq(ij,1)=0. + enddo + + do l=1,llm + do ij=1,ip1jmp1 + new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo + enddo +c print*,'ok3' + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advtrac.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advtrac.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advtrac.F90 (revision 1634) @@ -0,0 +1,396 @@ +! $Id$ + +SUBROUTINE advtrac(pbaru,pbarv , p, masse,q,iapptrac,teta, flxw, pk) + ! Auteur : F. Hourdin + ! + ! Modif. P. Le Van (20/12/97) + ! F. Codron (10/99) + ! D. Le Croller (07/2001) + ! M.A Filiberti (04/2002) + ! + USE infotrac + USE control_mod + + + IMPLICIT NONE + ! + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comvert.h" + include "comdissip.h" + include "comgeom2.h" + include "logic.h" + include "temps.h" + include "ener.h" + include "description.h" + include "iniprint.h" + + !------------------------------------------------------------------- + ! Arguments + !------------------------------------------------------------------- + ! Ajout PPM + !-------------------------------------------------------- + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm) + !-------------------------------------------------------- + INTEGER iapptrac + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm) + REAL pk(ip1jmp1,llm) + REAL flxw(ip1jmp1,llm) + + !------------------------------------------------------------- + ! Variables locales + !------------------------------------------------------------- + + REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),zdp(ip1jmp1) + REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) + REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu + INTEGER iadvtr + INTEGER ij,l,iq,iiq + REAL zdpmin, zdpmax + EXTERNAL minmax + SAVE iadvtr, massem, pbaruc, pbarvc + DATA iadvtr/0/ + !---------------------------------------------------------- + ! Rajouts pour PPM + !---------------------------------------------------------- + INTEGER indice,n + REAL dtbon ! Pas de temps adaptatif pour que CFL<1 + REAL CFLmaxz,aaa,bbb ! CFL maximum + REAL psppm(iim,jjp1) ! pression au sol + REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm) + REAL qppm(iim*jjp1,llm,nqtot) + REAL fluxwppm(iim,jjp1,llm) + REAL apppm(llmp1), bpppm(llmp1) + LOGICAL dum,fill + DATA fill/.true./ + DATA dum/.true./ + + integer,save :: countcfl=0 + real cflx(ip1jmp1,llm) + real cfly(ip1jm,llm) + real cflz(ip1jmp1,llm) + real, save :: cflxmax(llm),cflymax(llm),cflzmax(llm) + + IF(iadvtr.EQ.0) THEN + CALL initial0(ijp1llm,pbaruc) + CALL initial0(ijmllm,pbarvc) + ENDIF + + ! accumulation des flux de masse horizontaux + DO l=1,llm + DO ij = 1,ip1jmp1 + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + ENDDO + DO ij = 1,ip1jm + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO + + ! selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + + CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) + !cc CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 ) + ! + ENDIF + + iadvtr = iadvtr+1 + iapptrac = iadvtr + + + ! Test pour savoir si on advecte a ce pas de temps + IF ( iadvtr.EQ.iapp_tracvl ) THEN + + !c .. Modif P.Le Van ( 20/12/97 ) .... + !c + + ! traitement des flux de masse avant advection. + ! 1. calcul de w + ! 2. groupement des mailles pres du pole. + + CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + + ! ... Flux de masse diaganostiques traceurs + flxw = wg / REAL(iapp_tracvl) + + ! test sur l'eventuelle creation de valeurs negatives de la masse + DO l=1,llm-1 + DO ij = iip2+1,ip1jm + zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) & + - pbarvg(ij-iip1,l) + pbarvg(ij,l) & + + wg(ij,l+1) - wg(ij,l) + ENDDO + CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) + DO ij = iip2,ip1jm + zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) + ENDDO + + + CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) + + IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN + PRINT*,'WARNING DP/P l=',l,' MIN:',zdpmin, & + ' MAX:', zdpmax + ENDIF + + ENDDO + + + !------------------------------------------------------------------- + ! Calcul des criteres CFL en X, Y et Z + !------------------------------------------------------------------- + + if (countcfl == 0. ) then + cflxmax(:)=0. + cflymax(:)=0. + cflzmax(:)=0. + endif + + countcfl=countcfl+iapp_tracvl + cflx(:,:)=0. + cfly(:,:)=0. + cflz(:,:)=0. + do l=1,llm + do ij=iip2,ip1jm-1 + if (pbarug(ij,l)>=0.) then + cflx(ij,l)=pbarug(ij,l)*dtvr/masse(ij,l) + else + cflx(ij,l)=-pbarug(ij,l)*dtvr/masse(ij+1,l) + endif + enddo + enddo + do l=1,llm + do ij=iip2,ip1jm-1,iip1 + cflx(ij+iip1,l)=cflx(ij,l) + enddo + enddo + + do l=1,llm + do ij=1,ip1jm + if (pbarvg(ij,l)>=0.) then + cfly(ij,l)=pbarvg(ij,l)*dtvr/masse(ij,l) + else + cfly(ij,l)=-pbarvg(ij,l)*dtvr/masse(ij+iip1,l) + endif + enddo + enddo + + do l=2,llm + do ij=1,ip1jm + if (wg(ij,l)>=0.) then + cflz(ij,l)=wg(ij,l)*dtvr/masse(ij,l) + else + cflz(ij,l)=-wg(ij,l)*dtvr/masse(ij,l-1) + endif + enddo + enddo + + do l=1,llm + cflxmax(l)=max(cflxmax(l),maxval(cflx(:,l))) + cflymax(l)=max(cflymax(l),maxval(cfly(:,l))) + cflzmax(l)=max(cflzmax(l),maxval(cflz(:,l))) + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Par defaut, on sort le diagnostic des CFL tous les jours. + ! Si on veut le sortir a chaque pas d'advection en cas de plantage + ! if (countcfl==iapp_tracvl) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (countcfl==day_step) then + do l=1,llm + write(lunout,*) 'L, CFLmax ' & + ,l,maxval(cflx(:,l)),maxval(cfly(:,l)),maxval(cflz(:,l)) + enddo + countcfl=0 + endif + + !------------------------------------------------------------------- + ! Advection proprement dite (Modification Le Croller (07/2001) + !------------------------------------------------------------------- + + !---------------------------------------------------- + ! Calcul des moyennes basées sur la masse + !---------------------------------------------------- + call massbar(massem,massebx,masseby) + + !----------------------------------------------------------- + ! Appel des sous programmes d'advection + !----------------------------------------------------------- + do iq=1,nqtot + ! call clock(t_initial) + if(iadv(iq) == 0) cycle + ! ---------------------------------------------------------------- + ! Schema de Van Leer I MUSCL + ! ---------------------------------------------------------------- + if(iadv(iq).eq.10) THEN + call vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) + + ! ---------------------------------------------------------------- + ! Schema "pseudo amont" + test sur humidite specifique + ! pour la vapeur d'eau. F. Codron + ! ---------------------------------------------------------------- + else if(iadv(iq).eq.14) then + ! + CALL vlspltqs( q(1,1,1), 2., massem, wg , & + pbarug,pbarvg,dtvr,p,pk,teta ) + ! ---------------------------------------------------------------- + ! Schema de Frederic Hourdin + ! ---------------------------------------------------------------- + else if(iadv(iq).eq.12) then + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) + end do + else if(iadv(iq).eq.13) then + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) + end do + ! ---------------------------------------------------------------- + ! Schema de pente SLOPES + ! ---------------------------------------------------------------- + else if (iadv(iq).eq.20) then + call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) + + ! ---------------------------------------------------------------- + ! Schema de Prather + ! ---------------------------------------------------------------- + else if (iadv(iq).eq.30) then + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + call prather(q(1,1,iq),wg,massem,pbarug,pbarvg, & + n,dtbon) + + ! ---------------------------------------------------------------- + ! Schemas PPM Lin et Rood + ! ---------------------------------------------------------------- + else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. & + iadv(iq).LE.18)) then + + ! Test sur le flux horizontal + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + ! Test sur le flux vertical + CFLmaxz=0. + do l=2,llm + do ij=iip2,ip1jm + aaa=wg(ij,l)*dtvr/massem(ij,l) + CFLmaxz=max(CFLmaxz,aaa) + bbb=-wg(ij,l)*dtvr/massem(ij,l-1) + CFLmaxz=max(CFLmaxz,bbb) + enddo + enddo + if (CFLmaxz.GE.1) then + write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz + endif + + !----------------------------------------------------------- + ! Ss-prg interface LMDZ.4->PPM3d + !----------------------------------------------------------- + + call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, & + apppm,bpppm,massebx,masseby,pbarug,pbarvg, & + unatppm,vnatppm,psppm) + + do indice=1,n + !---------------------------------------------------------------- + ! VL (version PPM) horiz. et PPM vert. + !---------------------------------------------------------------- + if (iadv(iq).eq.11) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + + !------------------------------------------------------------- + ! Monotonic PPM + !------------------------------------------------------------- + else if (iadv(iq).eq.16) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + !------------------------------------------------------------- + + !------------------------------------------------------------- + ! Semi Monotonic PPM + !------------------------------------------------------------- + else if (iadv(iq).eq.17) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + !------------------------------------------------------------- + + !------------------------------------------------------------- + ! Positive Definite PPM + !------------------------------------------------------------- + else if (iadv(iq).eq.18) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + !------------------------------------------------------------- + endif + enddo + !----------------------------------------------------------------- + ! Ss-prg interface PPM3d-LMDZ.4 + !----------------------------------------------------------------- + call interpost(q(1,1,iq),qppm(1,1,iq)) + endif + !---------------------------------------------------------------------- + + !----------------------------------------------------------------- + ! On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1 + ! et Nord j=1 + !----------------------------------------------------------------- + + ! call traceurpole(q(1,1,iq),massem) + + ! calcul du temps cpu pour un schema donne + + ! call clock(t_final) + !ym tps_cpu=t_final-t_initial + !ym cpuadv(iq)=cpuadv(iq)+tps_cpu + + end DO + + + !------------------------------------------------------------------ + ! on reinitialise a zero les flux de masse cumules + !--------------------------------------------------- + iadvtr=0 + + ENDIF ! if iadvtr.EQ.iapp_tracvl + +END SUBROUTINE advtrac Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advx.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advx.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advx.F (revision 1634) @@ -0,0 +1,499 @@ +! +! $Header$ +! + SUBROUTINE advx(limit,dtx,pbaru,sm,s0, + $ sx,sy,sz,lati,latf) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in X direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz C +C sont des arguments d'entree pour le s-pg... C +C C +C sm,s0,sx,sy,sz C +C sont les arguments de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C Arguments : +C ----------- +C dtx : frequence fictive d'appel du transport +C pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + +C ATTENTION partout ou on trouve ntra, insertion de boucle +C possible dans l'avenir. + + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + $ ,sy(iip1,jjp1,llm,ntra) + REAL sz(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C Ti are the moments for the current latitude and level +C + REAL TM(iim) + REAL T0(iim,ntra),TX(iim,ntra) + REAL TY(iim,ntra),TZ(iim,ntra) + REAL TEMPTM ! just a temporary variable +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM(iim) + REAL F0(iim,ntra),FX(iim,ntra) + REAL FY(iim,ntra),FZ(iim,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) +C + REAL SMNEW(iim),UEXT(iim) +C + REAL sqi,sqf + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,itrac + + lon = iim + niv = llm + +C *** Test de passage d'arguments ****** + + +C ------------------------------------- + DO 300 j = 1,jjp1 + NUM(j) = 1 + 300 CONTINUE + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqi = sqi + S0(i,j,l,9) + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------' + PRINT*,'sqi=',sqi + + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjm+1 + DO 500 i = 1,iip1 +C ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g ) + ugri (i,j,llm+1-l) = pbaru (i,j,l) + 500 CONTINUE + + +C --------------------------------------------------------- +C --------------------------------------------------------- +C --------------------------------------------------------- + +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0(I,JV)=0. + TX(I,JV)=0. + TY(I,JV)=0. + TZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + 113 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I) + $ *S0(I3,K,L,JV) + T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TX(I,JV)=ALF(I) *sx(I3,K,L,JV)+ + $ ALF1(I)*TX(I,JV) +3.*TEMPTM + TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV) + ENDDO + ENDDO +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0(I,JV)=S0(I,K,L,JV) + TX(I,JV)=sx(I,K,L,JV) + TY(I,JV)=sy(I,K,L,JV) + TZ(I,JV)=sz(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV)) + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) ) + FX(I,JV)=ALFQ(I)*TX(I+1,JV) + FY(I,JV)=ALF (I)*TY(I+1,JV) + FZ(I,JV)=ALF (I)*TZ(I+1,JV) +C + T0(I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV) + TY(I+1,JV)=TY(I+1,JV)-FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) ) + FX (I,JV)=ALFQ(I)*TX(1,JV) + FY (I,JV)=ALF (I)*TY(1,JV) + FZ (I,JV)=ALF (I)*TZ(1,JV) +C + T0(1,JV)=T0(1,JV)-F0(I,JV) + TX(1,JV)=ALF1Q(I)*TX(1,JV) + TY(1,JV)=TY(1,JV)-FY(I,JV) + TZ(1,JV)=TZ(1,JV)-FZ(I,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) ) + FX(I,JV)=ALFQ(I)*TX(I,JV) + FY(I,JV)=ALF (I)*TY(I,JV) + FZ(I,JV)=ALF (I)*TZ(I,JV) +C + T0(I,JV)=T0(I,JV)-F0(I,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-FY(I,JV) + TZ(I,JV)=TZ(I,JV)-FZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0(I,JV)=T0(I,JV)+F0(I,JV) + TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TY(I,JV)=TY(I,JV)+FY(I,JV) + TZ(I,JV)=TZ(I,JV)+FZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0(I+1,JV)=T0(I+1,JV)+F0(I,JV) + TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM + TY(I+1,JV)=TY(I+1,JV)+FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0(1,JV)=T0(1,JV)+F0(I,JV) + TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TY(1,JV)=TY(1,JV)+FY(I,JV) + TZ(1,JV)=TZ(1,JV)+FZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 180 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 180 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK +C + I3=I2+(I-1)*NUMK + S0(I3,K,L,JV)=ALF (I) + $ * (T0(I,JV)-ALF1(I)*TX(I,JV)) + sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV) + sy(I3,K,L,JV)=ALF (I)*TY(I,JV) + sz(I3,K,L,JV)=ALF (I)*TZ(I,JV) +C +C reajusts moments remaining in the box +C + T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV) + ENDDO + ENDDO +C +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0(I,K,L,JV)=T0(I,JV) + sx(I,K,L,JV)=TX(I,JV) + sy(I,K,L,JV)=TY(I,JV) + sz(I,K,L,JV)=TZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* +c OK +c DO 9998 l = 1, llm +c DO 9998 j = 1, jjp1 +c DO 9998 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVX' +c PRINT*,'SM(',i,j,l,')=',SM(i,j,l) +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1' +cc STOP +c ENDIF +c 9998 CONTINUE +c +C ---------- bouclage cyclique + DO itrac=1,ntra + DO l = 1,llm + DO j = lati,latf + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,itrac) = S0(1,j,l,itrac) + sx(iip1,j,l,itrac) = sx(1,j,l,itrac) + sy(iip1,j,l,itrac) = sy(1,j,l,itrac) + sz(iip1,j,l,itrac) = sz(1,j,l,itrac) + END DO + END DO + ENDDO + +c ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim +cIM 240405 sqf = sqf + S0(i,j,l,9) + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO +c + PRINT*,'------ DIAG DANS ADVX - SORTIE -----' + PRINT*,'sqf=',sqf +c------------- + + RETURN + END +C_________________________________________________________________ +C_________________________________________________________________ Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advxp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advxp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advxp.F (revision 1634) @@ -0,0 +1,650 @@ +! +! $Header$ +! + SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in X direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + + INTEGER ntra +c PARAMETER (ntra = 1) +C +C definition de la grille du modele +C + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) +C +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C Sij 2nd order moment in i and j directions +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + REAL SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C +C Tij are the moments for the current latitude and level +C + REAL TM (iim) + REAL T0 (iim,NTRA),TX (iim,NTRA) + REAL TY (iim,NTRA),TZ (iim,NTRA) + REAL TXX(iim,NTRA),TXY(iim,NTRA) + REAL TXZ(iim,NTRA),TYY(iim,NTRA) + REAL TYZ(iim,NTRA),TZZ(iim,NTRA) +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM (iim) + REAL F0 (iim,NTRA),FX (iim,NTRA) + REAL FY (iim,NTRA),FZ (iim,NTRA) + REAL FXX(iim,NTRA),FXY(iim,NTRA) + REAL FXZ(iim,NTRA),FYY(iim,NTRA) + REAL FYZ(iim,NTRA),FZZ(iim,NTRA) +C +C work arrays +C + REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim),ALF4(iim) +C + REAL SMNEW(iim),UEXT(iim) + REAL sqi,sqf + REAL TEMPTM + REAL SLPMAX + REAL S1MAX,S1NEW,S2NEW + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,iter + + lon = iim + lati=2 + latf = jjm + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP' +cc STOP +c ENDIF +c 399 CONTINUE + +C *** Test : diagnostique de la qtite totale de traceur +C dans l'atmosphere avant l'advection +c + sqi =0. + sqf =0. +c + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----' + PRINT*,'sqi=',sqi +c test +c ------------------------------------- + DO 300 j =1,jjp1 + NUM(j) =1 + 300 CONTINUE +c DO l=1,llm +c NUM(2,l)=6 +c NUM(3,l)=6 +c NUM(jjm-1,l)=6 +c NUM(jjm,l)=6 +c ENDDO +c DO j=2,6 +c NUM(j)=12 +c ENDDO +c DO j=jjm-5,jjm-1 +c NUM(j)=12 +c ENDDO + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + ugri (i,j,llm+1-l) =pbaru (i,j,l) + 500 CONTINUE + +C --------------------------------------------------------- +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf + +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0 (I,JV)=0. + TX (I,JV)=0. + TY (I,JV)=0. + TZ (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + TYY(I,JV)=0. + TYZ(I,JV)=0. + TZZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 113 CONTINUE +C + DO 114 JV=1,NTRA + DO 1140 I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV) + T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV) + 1140 CONTINUE + 114 CONTINUE +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0 (I,JV)=S0 (I,K,L,JV) + TX (I,JV)=SSX (I,K,L,JV) + TY (I,JV)=SY (I,K,L,JV) + TZ (I,JV)=SZ (I,K,L,JV) + TXX(I,JV)=SSXX(I,K,L,JV) + TXY(I,JV)=SSXY(I,K,L,JV) + TXZ(I,JV)=SSXZ(I,K,L,JV) + TYY(I,JV)=SYY(I,K,L,JV) + TYZ(I,JV)=SYZ(I,K,L,JV) + TZZ(I,JV)=SZZ(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + IF(T0(I,JV).GT.0.) THEN + SLPMAX=T0(I,JV) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) ) + TX (I,JV)=S1NEW + TXX(I,JV)=S2NEW + TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV))) + TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV))) + ELSE + TX (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + ENDIF + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* + + ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV)) + FXX(I,JV)=ALF3(I)*TXX(I+1,JV) + FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV)) + FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I+1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV) + FYY(I,JV)=ALF (I)*TYY(I+1,JV) + FYZ(I,JV)=ALF (I)*TYZ(I+1,JV) + FZZ(I,JV)=ALF (I)*TZZ(I+1,JV) +C + T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV)) + TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV) + TY (I+1,JV)=TY (I+1,JV)-FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV) + TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV) + TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* + + ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV)) + FXX(I,JV)=ALF3(I)*TXX(1,JV) + FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV)) + FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(1,JV) + FYY(I,JV)=ALF (I)*TYY(1,JV) + FYZ(I,JV)=ALF (I)*TYZ(1,JV) + FZZ(I,JV)=ALF (I)*TZZ(1,JV) +C + T0 (1,JV)=T0(1,JV)-F0(I,JV) + TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV)) + TXX(1,JV)=ALF4(I)*TXX(1,JV) + TY (1,JV)=TY (1,JV)-FY (I,JV) + TZ (1,JV)=TZ (1,JV)-FZ (I,JV) + TYY(1,JV)=TYY(1,JV)-FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV) + TXY(1,JV)=ALF1Q(I)*TXY(1,JV) + TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* + + ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV)) + FXX(I,JV)=ALF3(I)*TXX(I,JV) + FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV)) + FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I,JV) + FYY(I,JV)=ALF (I)*TYY(I,JV) + FYZ(I,JV)=ALF (I)*TYZ(I,JV) + FZZ(I,JV)=ALF (I)*TZZ(I,JV) +C + T0 (I,JV)=T0(I,JV)-F0(I,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4(I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-FY (I,JV) + TZ (I,JV)=TZ (I,JV)-FZ (I,JV) + TYY(I,JV)=TYY(I,JV)-FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0 (I,JV)=T0(I,JV)+F0(I,JV) + TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+FY (I,JV) + TZ (I,JV)=TZ (I,JV)+FZ (I,JV) + TYY(I,JV)=TYY(I,JV)+FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV) + TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) + + +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (I+1,JV)=ALF(I)*FX (I ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM + TXY(I+1,JV)=ALF(I)*FXY(I ,JV)+ALF1(I)*TXY(I+1,JV) + + +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I ,JV)) + TXZ(I+1,JV)=ALF(I)*FXZ(I ,JV)+ALF1(I)*TXZ(I+1,JV) + + +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I ,JV)) + TY (I+1,JV)=TY (I+1,JV)+FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0 (1,JV)=T0(1,JV)+F0(I,JV) + TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) + + +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) + + +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV)) + TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) + + +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV)) + TY (1,JV)=TY (1,JV)+FY (I,JV) + TZ (1,JV)=TZ (1,JV)+FZ (I,JV) + TYY(1,JV)=TYY(1,JV)+FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 18 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) +C + 180 CONTINUE +C + DO 181 JV=1,NTRA + DO 181 I=1,LONK +C + I3=I2+(I-1)*NUMK + S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* + + ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) ) + SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV)) + SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV) + SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV)) + SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV)) + SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV) + SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV) + SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV) + SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV) + SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV) +C +C reajusts moments remaining in the box +C + T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4 (I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + 181 CONTINUE +C + 18 CONTINUE +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0 (I,K,L,JV)=T0 (I,JV) + SSX (I,K,L,JV)=TX (I,JV) + SY (I,K,L,JV)=TY (I,JV) + SZ (I,K,L,JV)=TZ (I,JV) + SSXX(I,K,L,JV)=TXX(I,JV) + SSXY(I,K,L,JV)=TXY(I,JV) + SSXZ(I,K,L,JV)=TXZ(I,JV) + SYY(I,K,L,JV)=TYY(I,JV) + SYZ(I,K,L,JV)=TYZ(I,JV) + SZZ(I,K,L,JV)=TZZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVXP' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP' +c STOP +c ENDIF +c 9999 CONTINUE +c ---------- bouclage cyclique + + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + END DO + END DO + +C ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + + PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----' + PRINT*,'sqf=',sqf +c------------------------------------------------------------- + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advy.F (revision 1634) @@ -0,0 +1,422 @@ +! +! $Header$ +! + SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (SOM) advection of tracer in Y direction C +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 15/12/94 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL s1v(llm),slatv(llm) + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + real smpn,smps,s0pn,s0ps + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv=llm + +C +C the moments Fi are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C + + DO l = 1,llm + DO j = 1,jjm + DO i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l) + enddo + enddo + do i=1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + enddo + enddo + + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sy(I,K,L,JV))),sy(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) +C + 21 CONTINUE +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* + + ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV) + sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV) + sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALF1(I,0)=1.-ALF(I,0) +C + 25 CONTINUE +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 300 CONTINUE + 30 CONTINUE +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV) + FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV) + FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV) +C + S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV) + sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV) +C + ELSE +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV) + FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV) + FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) + + +3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) + + +3.*TEMPTM + sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 41 CONTINUE +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV) + sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 45 CONTINUE +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +C + 1 CONTINUE +C + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advyp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advyp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advyp.F (revision 1634) @@ -0,0 +1,653 @@ +! +! $Header$ +! + SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Y direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/10/95 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra +C PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra) + REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra) + REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1) + REAL ALF4(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C initialisations + + sbms = 0. + sfms = 0. + sfzs = 0. + sbmn = 0. + sfmn = 0. + sfzn = 0. + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg +C-AA 20/10/94 le signe -1 est necessaire car indexation opposee + + DO 500 l = 1,llm + DO 500 j = 1,jjm + DO 500 i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l) + 500 CONTINUE + +CAA Initialisation de flux fictifs aux bords sup. des boites pol. + + DO l = 1,llm + DO i = 1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + ENDDO + ENDDO +c +c----------------- START HERE ----------------------- +C boucle sur les niveaux +C + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=AMAX1(S0(I,K,L,JV),0.) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) ) + SY (I,K,L,JV)=S1NEW + SYY(I,K,L,JV)=S2NEW + SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SY (I,K,L,JV)=0. + SYY(I,K,L,JV)=0. + SSXY(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF(I,0)*ALFQ(I,0) + ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0) +C + 21 CONTINUE +c print*,'ADVYP 21' +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* + + ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + SY (I,1,L,JV)=ALF1Q(I,0)* + + (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV)) + SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV) + SSX (I,1,L,JV)=ALF1 (I,0)* + + (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) ) + SZ (I,1,L,JV)=ALF1 (I,0)* + + (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) ) + SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV) + SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV) + SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV) + SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C +c print*,'av ADVYP 25' + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF1(I,0)*ALF(I,0) +C + 25 CONTINUE +c print*,'av ADVYP 25' +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) + + +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM ) + SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM + SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV) +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C +c print*,'av ADVYP 30' + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 300 CONTINUE + 30 CONTINUE +c print*,'ap ADVYP 30' +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* + + ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV) + FX (I,K,JV)=ALF (I,K)* + + (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV)) + FZ (I,K,JV)=ALF (I,K)* + + (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV) +C + S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + SY (I,KP,L,JV)=ALF1Q(I,K)* + + (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV)) + SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV) + SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV) + SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV) +C + ELSE +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV) + FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV)) + FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +c print*,'ap ADVYP 31' +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +c print*,'ap ADVYP 32' +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) + + +3.*TEMPTM + SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) + + +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) + + +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) + + +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM ) + SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) + + +3.*TEMPTM + SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) + + +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV)) + SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) + + +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV)) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +c print*,'ap ADVYP 33' +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 41 CONTINUE +c print*,'ap ADVYP 41' +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV)) + SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV)) + SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV) + SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +c print*,'ap ADVYP 42' +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +c print*,'ap ADVYP 43' +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 45 CONTINUE +c print*,'ap ADVYP 45' +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM + SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV) +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +c print*,'ap ADVYP 46' +C + 1 CONTINUE + +c-------------------------------------------------- +C bouclage cyclique horizontal . + + DO l = 1,llm + DO jv = 1,ntra + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,jv) = S0(1,j,l,jv) + SSX(iip1,j,l,jv) = SSX(1,j,l,jv) + SY(iip1,j,l,jv) = SY(1,j,l,jv) + SZ(iip1,j,l,jv) = SZ(1,j,l,jv) + END DO + END DO + END DO + +c ------------------------------------------------------------------- +C *** Test negativite: + +c DO jv = 1,ntra +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iip1 +c IF (s0( i,j,l,jv ).lt.0.) THEN +c PRINT*, '------ S0 < 0 en FIN ADVYP ---' +c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv) +cc STOP +c ENDIF +c ENDDO +c ENDDO +c ENDDO +c ENDDO + + +c ------------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - SORTIE --------' + PRINT*,'sqf=',sqf +c print*,'ap ADVYP fin' + +c----------------------------------------------------------------- +C + RETURN + END + + + + + + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advz.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advz.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advz.F (revision 1634) @@ -0,0 +1,322 @@ +! +! $Header$ +! + SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in Z direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C C +C sont des arguments d'entree pour le s-pg... C +C C +C dq est l'argument de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C #include "traceur.h" + +C Arguments : +C ----------- +C dtz : frequence fictive d'appel du transport +C w : flux de masse en z en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dtz + REAL w ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL WGRI(iip1,jjp1,0:llm) + +C +C the moments F are used as temporary storage for +C portions of grid boxes in transit at the current latitude +C + REAL FM(iim,llm) + REAL F0(iim,llm,ntra),FX(iim,llm,ntra) + REAL FY(iim,llm,ntra),FZ(iim,llm,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL TEMPTM ! Just temporal variable + REAL sqi,sqf +C + LOGICAL LIMIT + INTEGER lon,lat,niv + INTEGER i,j,jv,k,l,lp + + lon = iim + lat = jjp1 + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ' +c STOP +c ENDIF + 399 CONTINUE + +C----------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqi = sqi + S0(i,j,l,9) + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------' + PRINT*,'sqi=',sqi + +C----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion du flux de masse en kg.s-1 + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 +c wgri (i,j,llm+1-l) = w (i,j,l) / g + wgri (i,j,llm+1-l) = w (i,j,l) +c wgri (i,j,0) = 0. ! a detruire ult. +c wgri (i,j,l) = 0.1 ! w (i,j,l) +c wgri (i,j,llm) = 0. ! a detruire ult. + 500 CONTINUE + DO j = 1,jjp1 + DO i = 1,iip1 + wgri(i,j,0)=0. + enddo + enddo + +C----------------------------------------------------------------- + +C start here +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sz(I,K,L,JV))),sz(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV) +C + S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV) + sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV) + sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV) +C + ELSE +C + F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,L,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV) + sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV) + + +3.*TEMPTM + sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C +C------------------------------------------------------------- +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVZ' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1' +c STOP +c ENDIF + 9999 CONTINUE + +C *** ------------------- bouclage cyclique en X ------------ + +c DO l = 1,llm +c DO j = 1,jjp1 +c SM(iip1,j,l) = SM(1,j,l) +c S0(iip1,j,l,ntra) = S0(1,j,l,ntra) +C sx(iip1,j,l,ntra) = sx(1,j,l,ntra) +c sy(iip1,j,l,ntra) = sy(1,j,l,ntra) +c sz(iip1,j,l,ntra) = sz(1,j,l,ntra) +c ENDDO +c ENDDO + +C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqf = sqf + S0(i,j,l,9) + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + +C------------------------------------------------------------- + RETURN + END +C_______________________________________________________________ +C_______________________________________________________________ Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advzp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advzp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/advzp.F (revision 1634) @@ -0,0 +1,378 @@ +! +! $Header$ +! + SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Z direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/11/95 LAST C +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C + +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +C +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 +c + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l,lp + INTEGER ntra +c PARAMETER (ntra = 1) +c + REAL dtz + REAL w ( iip1,jjp1,llm ) +c +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- +C +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : +C + REAL WGRI(iip1,jjp1,0:llm) + +C Rem : UGRI et VGRI ne sont pas utilises dans +C cette subroutine ( advection en z uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C attention a celui de WGRI +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,llm,ntra),FM(iim,llm) + REAL FX(iim,llm,ntra),FY(iim,llm,ntra) + REAL FZ(iim,llm,ntra) + REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra) + REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra) + REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim),ALF1(iim) + REAL ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim) + REAL ALF4(iim) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. +c + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + wgri (i,j,llm+1-l) = w (i,j,l) + 500 CONTINUE + do j=1,jjp1 + do i=1,iip1 + wgri(i,j,0)=0. + enddo + enddo +c +cAA rem : Je ne suis pas sur du signe +cAA Je ne suis pas sur pour le 0:llm +c +c----------------------------------------------------------------- +C---------------------- START HERE ------------------------------- +C +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=S0(I,K,L,JV) + S1MAX =1.5*SLPMAX + S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV))) + S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) ) + SZ (I,K,L,JV)=S1NEW + SZZ(I,K,L,JV)=S2NEW + SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SZ (I,K,L,JV)=0. + SZZ(I,K,L,JV)=0. + SSXZ(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2 (I)=ALF1(I)-ALF(I) + ALF3 (I)=ALF(I)*ALFQ(I) + ALF4 (I)=ALF1(I)*ALF1Q(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* + + ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV) +C + S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV) + SZ (I,K,LP,JV)=ALF1Q(I) + + *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV)) + SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV) + SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV) + SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV) +C + ELSE +C + F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) + + +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV) + SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV)) + SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF(I)*ALF1(I) + ALF3(I)=ALF1(I)-ALF(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) + + +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM ) + SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) + + +3.*TEMPTM + SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) + + +3.*(ALF1(I)*FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) + + +3.*(ALF1(I)*FY (I,L,JV)-ALF (I)*SY (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) + + +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM ) + SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) + + +3.*TEMPTM + SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) + + +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV)) + SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) + + +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV)) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + ENDDO + ENDDO +c C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de tarceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/bernoui.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/bernoui.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/bernoui.F (revision 1634) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay) +c +c Local: +c ------ +c + INTEGER ijl +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + DO 4 ijl = 1,ngrid*nlay + pbern( ijl ) = pphi( ijl ) + pecin( ijl ) + 4 CONTINUE +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/bilan_dyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/bilan_dyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/bilan_dyn.F (revision 1634) @@ -0,0 +1,586 @@ +! +! $Id$ +! + SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum, + s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + +c AFAIRE +c Prevoir en champ nq+1 le diagnostique de l'energie +c en faisant Qzon=Cv T + L * ... +c vQ..A=Cp T + L * ... + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "temps.h" +#include "iniprint.h" + +c==================================================================== +c +c Sous-programme consacre à des diagnostics dynamiques de base +c +c +c De facon generale, les moyennes des scalaires Q sont ponderees par +c la masse. +c +c Les flux de masse sont eux simplement moyennes. +c +c==================================================================== + +c Arguments : +c =========== + + integer ntrac + real dt_app,dt_cum + real ps(iip1,jjp1) + real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) + real flux_u(iip1,jjp1,llm) + real flux_v(iip1,jjm,llm) + real teta(iip1,jjp1,llm) + real phi(iip1,jjp1,llm) + real ucov(iip1,jjp1,llm) + real vcov(iip1,jjm,llm) + real trac(iip1,jjp1,llm,ntrac) + +c Local : +c ======= + + integer icum,ncum + logical first + real zz,zqy,zfactv(jjm,llm) + + integer nQ + parameter (nQ=7) + + +cym character*6 nom(nQ) +cym character*6 unites(nQ) + character*6,save :: nom(nQ) + character*6,save :: unites(nQ) + + character*10 file + integer ifile + parameter (ifile=4) + + integer itemp,igeop,iecin,iang,iu,iovap,iun + integer i_sortie + + save first,icum,ncum + save itemp,igeop,iecin,iang,iu,iovap,iun + save i_sortie + + real time + integer itau + save time,itau + data time,itau/0.,0/ + + data first/.true./ + data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/ + data i_sortie/1/ + + real ww + +c variables dynamiques intermédiaires + REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm) + REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm) + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + REAL vorpot(iip1,jjm,llm) + REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm) + REAL bern(iip1,jjp1,llm) + +c champ contenant les scalaires advectés. + real Q(iip1,jjp1,llm,nQ) + +c champs cumulés + real ps_cum(iip1,jjp1) + real masse_cum(iip1,jjp1,llm) + real flux_u_cum(iip1,jjp1,llm) + real flux_v_cum(iip1,jjm,llm) + real Q_cum(iip1,jjp1,llm,nQ) + real flux_uQ_cum(iip1,jjp1,llm,nQ) + real flux_vQ_cum(iip1,jjm,llm,nQ) + real flux_wQ_cum(iip1,jjp1,llm,nQ) + real dQ(iip1,jjp1,llm,nQ) + + save ps_cum,masse_cum,flux_u_cum,flux_v_cum + save Q_cum,flux_uQ_cum,flux_vQ_cum + +c champs de tansport en moyenne zonale + integer ntr,itr + parameter (ntr=5) + +cym character*10 znom(ntr,nQ) +cym character*20 znoml(ntr,nQ) +cym character*10 zunites(ntr,nQ) + character*10,save :: znom(ntr,nQ) + character*20,save :: znoml(ntr,nQ) + character*10,save :: zunites(ntr,nQ) + + integer iave,itot,immc,itrs,istn + data iave,itot,immc,itrs,istn/1,2,3,4,5/ + character*3 ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm) + real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ) + real zmasse(jjm,llm),zamasse(jjm) + + real zv(jjm,llm),psi(jjm,llm+1) + + integer i,j,l,iQ + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + character*10 infile + + integer fileid + integer thoriid, zvertiid + save fileid + + integer ndex3d(jjm*llm) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer ii,jj + integer zan, dayref +C + real rlong(jjm),rlatg(jjm) + + + +c===================================================================== +c Initialisation +c===================================================================== + + time=time+dt_app + itau=itau+1 +cIM + ndex3d=0 + + if (first) then + + + icum=0 +c initialisation des fichiers + first=.false. +c ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + WRITE(lunout,*) + . 'Pb : le pas de cumule doit etre multiple du pas' + WRITE(lunout,*)'dt_app=',dt_app + WRITE(lunout,*)'dt_cum=',dt_cum + stop + endif + + if (i_sortie.eq.1) then + file='dynzon' + call inigrads(ifile,1 + s ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dt_cum,file,'dyn_zon ') + endif + + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + infile='dynzon' + + zan = annee_ref + dayref = day_ref + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + rlong=0. + rlatg=rlatv*180./pi + + call histbeg(infile, 1, rlong, jjm, rlatg, + . 1, 1, 1, jjm, + . tau0, zjulian, dt_cum, thoriid, fileid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', + . llm, presnivs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + +c Declarations des champs avec dimension verticale +c print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + IF (prt_level > 5) + . WRITE(lunout,*)'var ',itr,iQ + . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo +c Declarations pour les fonctions de courant +c print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) + . ,'stream fn. '//znoml(itot,iQ), + . zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + + +c Declarations pour les champs de transport d'air +c print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', + . 'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', + . 'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) +c Declarations pour les fonctions de courant +c print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', + . 1,jjm,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + + +c Declaration des champs 1D de transport en latitude +c print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + +c print*,'8HISTDEF' + CALL histend(fileid) + + + endif + + +c===================================================================== +c Calcul des champs dynamiques +c ---------------------------- + +c énergie cinétique + ucont(:,:,:)=0 + CALL covcont(llm,ucov,vcov,ucont,vcont) + CALL enercin(vcov,ucov,vcont,ucont,ecin) + +c moment cinétique + do l=1,llm + ang(:,:,l)=ucov(:,:,l)+constang(:,:) + unat(:,:,l)=ucont(:,:,l)*cu(:,:) + enddo + + Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp + Q(:,:,:,igeop)=phi(:,:,:) + Q(:,:,:,iecin)=ecin(:,:,:) + Q(:,:,:,iang)=ang(:,:,:) + Q(:,:,:,iu)=unat(:,:,:) + Q(:,:,:,iovap)=trac(:,:,:,1) + Q(:,:,:,iun)=1. + + +c===================================================================== +c Cumul +c===================================================================== +c + if(icum.EQ.0) then + ps_cum=0. + masse_cum=0. + flux_u_cum=0. + flux_v_cum=0. + Q_cum=0. + flux_vQ_cum=0. + flux_uQ_cum=0. + endif + + IF (prt_level > 5) + . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + +c accumulation des flux de masse horizontaux + ps_cum=ps_cum+ps + masse_cum=masse_cum+masse + flux_u_cum=flux_u_cum+flux_u + flux_v_cum=flux_v_cum+flux_v + do iQ=1,nQ + Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:) + enddo + +c===================================================================== +c FLUX ET TENDANCES +c===================================================================== + +c Flux longitudinal +c ----------------- + do iQ=1,nQ + do l=1,llm + do j=1,jjp1 + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) + s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo + enddo + +c flux méridien +c ------------- + do iQ=1,nQ + do l=1,llm + do j=1,jjm + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) + s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo + enddo + + +c tendances +c --------- + +c convergence horizontale + call convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + +c calcul de la vitesse verticale + call convmas(flux_u_cum,flux_v_cum,convm) + CALL vitvert(convm,w) + + do iQ=1,nQ + do l=1,llm-1 + do j=1,jjp1 + do i=1,iip1 + ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) + dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww + dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww + enddo + enddo + enddo + enddo + IF (prt_level > 5) + . WRITE(lunout,*)'Apres les calculs fait a chaque pas' +c===================================================================== +c PAS DE TEMPS D'ECRITURE +c===================================================================== + if (icum.eq.ncum) then +c===================================================================== + + IF (prt_level > 5) + . WRITE(lunout,*)'Pas d ecriture' + +c Normalisation + do iQ=1,nQ + Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:) + enddo + zz=1./REAL(ncum) + ps_cum=ps_cum*zz + masse_cum=masse_cum*zz + flux_u_cum=flux_u_cum*zz + flux_v_cum=flux_v_cum*zz + flux_uQ_cum=flux_uQ_cum*zz + flux_vQ_cum=flux_vQ_cum*zz + dQ=dQ*zz + + +c A retravailler eventuellement +c division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ + dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:) + enddo + +c===================================================================== +c Transport méridien +c===================================================================== + +c cumul zonal des masses des mailles +c ---------------------------------- + zv=0. + zmasse=0. + call massbar(masse_cum,massebx,masseby) + do l=1,llm + do j=1,jjm + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo + +c print*,'3OK' +c -------------------------------------------------------------- +c calcul de la moyenne zonale du transport : +c ------------------------------------------ +c +c -- +c TOT : la circulation totale [ vq ] +c +c - - +c MMC : mean meridional circulation [ v ] [ q ] +c +c ---- -- - - +c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] +c +c - * - * - - - - +c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] +c +c - - +c on utilise aussi l'intermediaire TMP : [ v q ] +c +c la variable zfactv transforme un transport meridien cumule +c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte +c +c -------------------------------------------------------------- + + +c ---------------------------------------- +c Transport dans le plan latitude-altitude +c ---------------------------------------- + + zvQ=0. + psiQ=0. + do iQ=1,nQ + zvQtmp=0. + do l=1,llm + do j=1,jjm +c print*,'j,l,iQ=',j,l,iQ +c Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) + s +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ + s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy + s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo +c print*,'aOK' +c Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +c fonction de courant meridienne pour la quantite Q + do l=llm,1,-1 + do j=1,jjm + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo + enddo + +c fonction de courant pour la circulation meridienne moyenne + psi=0. + do l=llm,1,-1 + do j=1,jjm + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo + +c print*,'4OK' +c sorties proprement dites + if (i_sortie.eq.1) then + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ) + s ,jjm*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ) + s ,jjm*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse + s ,jjm*llm,ndex3d) + call histwrite(fileid,'v',itau,zv + s ,jjm*llm,ndex3d) + psi=psi*1.e-9 + call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d) + + endif + + +c ----------------- +c Moyenne verticale +c ----------------- + + zamasse=0. + do l=1,llm + zamasse(:)=zamasse(:)+zmasse(:,l) + enddo + zavQ=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l) + enddo + zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:) + call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ) + s ,jjm*llm,ndex3d) + enddo + enddo + +c on doit pouvoir tracer systematiquement la fonction de courant. + +c===================================================================== +c///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// +c///////////////////////////////////////////////////////////////////// +c===================================================================== + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caladvtrac.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caladvtrac.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caladvtrac.F (revision 1634) @@ -0,0 +1,113 @@ +! +! $Id$ +! +c +c + SUBROUTINE caladvtrac(q,pbaru,pbarv , + * p ,masse, dq , teta, + * flxw, pk) +c + USE infotrac, ONLY : nqtot + USE control_mod, ONLY : iapp_tracvl,planet_type + + IMPLICIT NONE +c +c Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron +c +c F.Codron (10/99) : ajout humidite specifique pour eau vapeur +c======================================================================= +c +c Shema de Van Leer +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + +c Arguments: +c ---------- + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqtot) + real :: dq(ip1jmp1,llm,nqtot) + REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) + +c .................................................................. +c +c .. dq n'est utilise et dimensionne que pour l'eau vapeur et liqu. +c +c .................................................................. +c +c Local: +c ------ + + EXTERNAL advtrac,minmaxq, qminimum + INTEGER ij,l, iq, iapptrac + REAL finmasse(ip1jmp1,llm), dtvrtrac + +cc +c +! Earth-specific stuff for the first 2 tracers (water) + if (planet_type.eq."earth") then +C initialisation + dq(:,:,1:2)=q(:,:,1:2) + +c test des valeurs minmax +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ') + endif ! of if (planet_type.eq."earth") +c advection + + CALL advtrac( pbaru,pbarv, + * p, masse,q,iapptrac, teta, + . flxw, pk) + +c + + IF( iapptrac.EQ.iapp_tracvl ) THEN + if (planet_type.eq."earth") then +! Earth-specific treatment for the first 2 tracers (water) +c +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide ') + +cc .... Calcul de deltap qu'on stocke dans finmasse ... +c + DO l = 1, llm + DO ij = 1, ip1jmp1 + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO + + CALL qminimum( q, 2, finmasse ) + + CALL SCOPY ( ip1jmp1*llm, masse, 1, finmasse, 1 ) + CALL filtreg ( finmasse , jjp1, llm, -2, 2, .TRUE., 1 ) +c +c ***** Calcul de dq pour l'eau , pour le passer a la physique ****** +c ******************************************************************** +c + dtvrtrac = iapp_tracvl * dtvr +c + DO iq = 1 , 2 + DO l = 1 , llm + DO ij = 1,ip1jmp1 + dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l) + * / dtvrtrac + ENDDO + ENDDO + ENDDO +c + endif ! of if (planet_type.eq."earth") + ELSE + if (planet_type.eq."earth") then +! Earth-specific treatment for the first 2 tracers (water) + dq(:,:,1:2)=0. + endif ! of if (planet_type.eq."earth") + ENDIF ! of IF( iapptrac.EQ.iapp_tracvl ) + + END + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caldyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caldyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caldyn.F (revision 1634) @@ -0,0 +1,122 @@ +! +! $Header$ +! +c +c + SUBROUTINE caldyn + $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + LOGICAL conser + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) + REAL vorpot(ip1jm,llm) + REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) + REAL bern(ip1jmp1,llm) + REAL massebxy(ip1jm,llm) + + + INTEGER ij,l + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL pression ( ip1jmp1, ap , bp , ps , p ) + CALL psextbar ( ps , psexbarxy ) + CALL massdair ( p , masse ) + CALL massbar ( masse, massebx , masseby ) + call massbarxy( masse, massebxy ) + CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL dteta1 ( teta , pbaru , pbarv, dteta ) + CALL convmas ( pbaru, pbarv , convm ) + + DO ij =1, ip1jmp1 + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO + + CALL vitvert ( convm , w ) + CALL tourpot ( vcov , ucov , massebxy , vorpot ) + CALL dudv1 ( vorpot , pbaru , pbarv , du , dv ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) + CALL dudv2 ( teta , pkf , bern , du , dv ) + + + DO l=1,llm + DO ij=1,ip1jmp1 + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO + + + CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta ) + +C WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi +C probablement. Observe sur le code compile avec pgf90 3.0-1 + + DO l = 1, llm + DO ij = 1, ip1jm, iip1 + IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN +c PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', +c , ' dans caldyn' +c PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) + dv(ij+iim,l) = dv(ij,l) + endif + enddo + enddo +c----------------------------------------------------------------------- +c Sorties eventuelles des variables de controle: +c ---------------------------------------------- + + IF( conser ) THEN + CALL sortvarc + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + ENDIF + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caldyn0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caldyn0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/caldyn0.F (revision 1634) @@ -0,0 +1,89 @@ +! +! $Header$ +! + SUBROUTINE caldyn0 + $ (itau,ucov,vcov,teta,ps,masse,pk,phis , + $ phi,w,pbaru,pbarv,time ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) + REAL vorpot(ip1jm,llm) + REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) + REAL bern(ip1jmp1,llm) + REAL massebxy(ip1jm,llm), dp(ip1jmp1) + + + INTEGER ij,l + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL pression ( ip1jmp1, ap , bp , ps , p ) + CALL psextbar ( ps , psexbarxy ) + CALL massdair ( p , masse ) + CALL massbar ( masse, massebx , masseby ) + CALL massbarxy( masse, massebxy ) + CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL convmas ( pbaru, pbarv , convm ) + + DO ij =1, ip1jmp1 + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO + + CALL vitvert ( convm , w ) + CALL tourpot ( vcov , ucov , massebxy , vorpot ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) + + DO l=1,llm + DO ij=1,ip1jmp1 + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO + + CALL sortvarc0 + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/calfis.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/calfis.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/calfis.F (revision 1634) @@ -0,0 +1,656 @@ +! +! $Id$ +! +C +C + SUBROUTINE calfis(lafin, + $ jD_cur, jH_cur, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ flxw, + $ clesphy0, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +c +c Auteur : P. Le Van, F. Hourdin +c ......... + USE infotrac + USE control_mod + + + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c callrad clef d'appel au rayonnement +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature +c pdtsfi tendency for the surface temperature +c +c pdtrad radiative tendencies \ both input +c pfluxrad radiative fluxes / and output +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" + + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "iniprint.h" + +c Arguments : +c ----------- + LOGICAL lafin + + + REAL pvcov(iip1,jjm,llm) + REAL pucov(iip1,jjp1,llm) + REAL pteta(iip1,jjp1,llm) + REAL pmasse(iip1,jjp1,llm) + REAL pq(iip1,jjp1,llm,nqtot) + REAL pphis(iip1,jjp1) + REAL pphi(iip1,jjp1,llm) +c + REAL pdvcov(iip1,jjm,llm) + REAL pducov(iip1,jjp1,llm) + REAL pdteta(iip1,jjp1,llm) + REAL pdq(iip1,jjp1,llm,nqtot) +c + REAL pps(iip1,jjp1) + REAL pp(iip1,jjp1,llmp1) + REAL ppk(iip1,jjp1,llm) +c + REAL pdvfi(iip1,jjm,llm) + REAL pdufi(iip1,jjp1,llm) + REAL pdhfi(iip1,jjp1,llm) + REAL pdqfi(iip1,jjp1,llm,nqtot) + REAL pdpsfi(iip1,jjp1) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq,iiq + REAL zpsrf(ngridmx) + REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm) + REAL zphi(ngridmx,llm),zphis(ngridmx) +c + REAL zufi(ngridmx,llm), zvfi(ngridmx,llm) + REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot) +c + REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm) + REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2) +c + REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm) + REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot) + REAL zdpsrf(ngridmx) +c + REAL zdufic(ngridmx,llm),zdvfic(ngridmx,llm) + REAL zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot) + REAL jH_cur_split,zdt_split + LOGICAL debut_split,lafin_split + INTEGER isplit + + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp +c +cIM diagnostique PVteta, Amip2 + INTEGER ntetaSTD + PARAMETER(ntetaSTD=3) + REAL rtetaSTD(ntetaSTD) + DATA rtetaSTD/350., 380., 405./ + REAL PVteta(ngridmx,ntetaSTD) +c + REAL flxw(iip1,jjp1,llm) ! Flux de masse verticale sur la grille dynamique + REAL flxwfi(ngridmx,llm) ! Flux de masse verticale sur la grille physiq +c + + REAL SSUM + + LOGICAL firstcal, debut + DATA firstcal/.true./ + SAVE firstcal,debut +! REAL rdayvrai + REAL, intent(in):: jD_cur, jH_cur +c +c----------------------------------------------------------------------- +c +c 1. Initialisations : +c -------------------- +c +c + IF ( firstcal ) THEN + debut = .TRUE. + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + write(lunout,*) 'STOP dans calfis' + write(lunout,*) + & 'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + write(lunout,*) ' ngridmx jjm iim ' + write(lunout,*) ngridmx,jjm,iim + STOP + ENDIF + ELSE + debut = .FALSE. + ENDIF ! of IF (firstcal) + +c +c +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + + + zpsrf(1) = pps(1,1) + + ig0 = 2 + DO j = 2,jjm + CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 ) + ig0 = ig0+iim + ENDDO + + zpsrf(ngridmx) = pps(1,jjp1) + + +c 42. pression intercouches : +c +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... +c + unskap = 1./ kappa +c + DO l = 1, llmp1 + zplev( 1,l ) = pp(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i =1, iim + zplev( ig0,l ) = pp(i,j,l) + ig0 = ig0 +1 + ENDDO + ENDDO + zplev( ngridmx,l ) = pp(1,jjp1,l) + ENDDO +c +c + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- + + DO l=1,llm + + pksurcp = ppk(1,1,l) / cpp + zplay(1,l) = preff * pksurcp ** unskap + ztfi(1,l) = pteta(1,1,l) * pksurcp + pcvgt(1,l) = pdteta(1,1,l) * pksurcp / pmasse(1,1,l) + ig0 = 2 + + DO j = 2, jjm + DO i = 1, iim + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi(ig0,l) = pteta(i,j,l) * pksurcp + pcvgt(ig0,l) = pdteta(i,j,l) * pksurcp / pmasse(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + + pksurcp = ppk(1,jjp1,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi (ig0,l) = pteta(1,jjp1,l) * pksurcp + pcvgt(ig0,l) = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l) + + ENDDO + +c 43.bis traceurs +c --------------- +c + DO iq=1,nqtot + iiq=niadv(iq) + DO l=1,llm + zqfi(1,l,iq) = pq(1,1,l,iiq) + ig0 = 2 + DO j=2,jjm + DO i = 1, iim + zqfi(ig0,l,iq) = pq(i,j,l,iiq) + ig0 = ig0 + 1 + ENDDO + ENDDO + zqfi(ig0,l,iq) = pq(1,jjp1,l,iiq) + ENDDO + ENDDO + +c convergence dynamique pour les traceurs "EAU" +! Earth-specific treatment of first 2 tracers (water) + if (planet_type=="earth") then + DO iq=1,2 + DO l=1,llm + pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l) + ig0 = 2 + DO j=2,jjm + DO i = 1, iim + pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l) + ENDDO + ENDDO + endif ! of if (planet_type=="earth") + + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis) + DO l=1,llm + DO ig=1,ngridmx + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO + +c .... Calcul de la vitesse verticale ( en Pa*m*s ou Kg/s ) .... +c JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux +c de masse est calclue dans advtrac.F +c DO l=1,llm +c pvervel(1,l)=pw(1,1,l) * g /apoln +c ig0=2 +c DO j=2,jjm +c DO i = 1, iim +c pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j) +c ig0 = ig0 + 1 +c ENDDO +c ENDDO +c pvervel(ig0,l)=pw(1,jjp1,l) * g /apols +c ENDDO + +c +c 45. champ u: +c ------------ + + DO 50 l=1,llm + + DO 25 j=2,jjm + ig0 = 1+(j-2)*iim + zufi(ig0+1,l)= 0.5 * + $ ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) ) + pcvgu(ig0+1,l)= 0.5 * + $ ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) ) + DO 10 i=2,iim + zufi(ig0+i,l)= 0.5 * + $ ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) ) + pcvgu(ig0+i,l)= 0.5 * + $ ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) ) +10 CONTINUE +25 CONTINUE + +50 CONTINUE + + +c 46.champ v: +c ----------- + + DO l=1,llm + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + zvfi(ig0+i,l)= 0.5 * + $ ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) ) + pcvgv(ig0+i,l)= 0.5 * + $ ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) ) + ENDDO + ENDDO + ENDDO + + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i)= COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i)= SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi + pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi + pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi + + ENDDO + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i) = COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i) = SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(ngridmx,l) = SSUM(iim,zcos,1)/pi + pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi + zvfi(ngridmx,l) = SSUM(iim,zsin,1)/pi + pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi + + ENDDO +c + if (planet_type=="earth") then +#ifdef CPP_EARTH +cIM calcul PV a teta=350, 380, 405K + CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ ntetaSTD,rtetaSTD,PVteta) +#endif + endif +c +c On change de grille, dynamique vers physiq, pour le flux de masse verticale + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi) + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + + + if (planet_type=="earth") then +#ifdef CPP_EARTH + +! write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys + zdt_split=dtphys/nsplit_phys + zdufic(:,:)=0. + zdvfic(:,:)=0. + zdtfic(:,:)=0. + zdqfic(:,:,:)=0. + + do isplit=1,nsplit_phys + + jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys) + debut_split=debut.and.isplit==1 + lafin_split=lafin.and.isplit==nsplit_phys + + CALL physiq (ngridmx, + . llm, + . debut_split, + . lafin_split, + . jD_cur, + . jH_cur_split, + . zdt_split, + . zplev, + . zplay, + . zphi, + . zphis, + . presnivs, + . clesphy0, + . zufi, + . zvfi, + . ztfi, + . zqfi, + . flxwfi, + . zdufi, + . zdvfi, + . zdtfi, + . zdqfi, + . zdpsrf, +cIM diagnostique PVteta, Amip2 + . pducov, + . PVteta) + + zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split + zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split + ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split + zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split + + zdufic(:,:)=zdufic(:,:)+zdufi(:,:) + zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:) + zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:) + zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:) + + enddo + zdufi(:,:)=zdufic(:,:)/nsplit_phys + zdvfi(:,:)=zdvfic(:,:)/nsplit_phys + zdtfi(:,:)=zdtfic(:,:)/nsplit_phys + zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys + +#endif + endif !of if (planet_type=="earth") + +500 CONTINUE + +c----------------------------------------------------------------------- +c transformation des tendances physiques en tendances dynamiques: +c --------------------------------------------------------------- + +c tendance sur la pression : +c ----------------------------------- + + CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi) +c +c 62. enthalpie potentielle +c --------------------- + + DO l=1,llm + + DO i=1,iip1 + pdhfi(i,1,l) = cpp * zdtfi(1,l) / ppk(i, 1 ,l) + pdhfi(i,jjp1,l) = cpp * zdtfi(ngridmx,l)/ ppk(i,jjp1,l) + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l) + ENDDO + pdhfi(iip1,j,l) = pdhfi(1,j,l) + ENDDO + + ENDDO + + +c 62. humidite specifique +c --------------------- +! Ehouarn: removed this useless bit: was overwritten at step 63 anyways +! DO iq=1,nqtot +! DO l=1,llm +! DO i=1,iip1 +! pdqfi(i,1,l,iq) = zdqfi(1,l,iq) +! pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq) +! ENDDO +! DO j=2,jjm +! ig0=1+(j-2)*iim +! DO i=1,iim +! pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq) +! ENDDO +! pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq) +! ENDDO +! ENDDO +! ENDDO + +c 63. traceurs +c ------------ +C initialisation des tendances + pdqfi(:,:,:,:)=0. +C + DO iq=1,nqtot + iiq=niadv(iq) + DO l=1,llm + DO i=1,iip1 + pdqfi(i,1,l,iiq) = zdqfi(1,l,iq) + pdqfi(i,jjp1,l,iiq) = zdqfi(ngridmx,l,iq) + ENDDO + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdqfi(i,j,l,iiq) = zdqfi(ig0+i,l,iq) + ENDDO + pdqfi(iip1,j,l,iiq) = pdqfi(1,j,l,iq) + ENDDO + ENDDO + ENDDO + +c 65. champ u: +c ------------ + + DO l=1,llm + + DO i=1,iip1 + pdufi(i,1,l) = 0. + pdufi(i,jjp1,l) = 0. + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim-1 + pdufi(i,j,l)= + $ 0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j) + ENDDO + pdufi(iim,j,l)= + $ 0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j) + pdufi(iip1,j,l)=pdufi(1,j,l) + ENDDO + + ENDDO + + +c 67. champ v: +c ------------ + + DO l=1,llm + + DO j=2,jjm-1 + ig0=1+(j-2)*iim + DO i=1,iim + pdvfi(i,j,l)= + $ 0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j) + ENDDO + pdvfi(iip1,j,l) = pdvfi(1,j,l) + ENDDO + ENDDO + + +c 68. champ v pres des poles: +c --------------------------- +c v = U * cos(long) + V * SIN(long) + + DO l=1,llm + + DO i=1,iim + pdvfi(i,1,l)= + $ zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i)) + pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) + $ +zdvfi(ngridmx,l)*SIN(rlonv(i)) + pdvfi(i,1,l)= + $ 0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1) + pdvfi(i,jjm,l)= + $ 0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm) + ENDDO + + pdvfi(iip1,1,l) = pdvfi(1,1,l) + pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l) + + ENDDO + +c----------------------------------------------------------------------- + +700 CONTINUE + + firstcal = .FALSE. + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ce0l.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ce0l.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ce0l.F90 (revision 1634) @@ -0,0 +1,107 @@ +! +! $Id$ +! +!------------------------------------------------------------------------------- +! +PROGRAM ce0l +!------------------------------------------------------------------------------- +! Purpose: Calls etat0, creates initial states and limit_netcdf +! +! interbar=.T. for barycentric interpolation inter_barxy +! extrap =.T. for data extrapolation, like for the SSTs when file does not +! contain ocean points only. +! oldice =.T. for old-style ice, obtained using grille_m (grid_atob). +! masque is created in etat0, passed to limit to ensure consistancy. +!------------------------------------------------------------------------------- + USE control_mod +#ifdef CPP_EARTH +! This prog. is designed to work for Earth + USE dimphy + USE comgeomphy + USE infotrac + +#ifdef CPP_IOIPSL + USE ioipsl, ONLY: ioconf_calendar +#endif + +#endif + IMPLICIT NONE +#ifndef CPP_EARTH + WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics' +#else +!------------------------------------------------------------------------------- +! Local variables: + LOGICAL, PARAMETER :: interbar=.TRUE., extrap=.FALSE., oldice=.FALSE. +#include "dimensions.h" +#include "paramet.h" +#include "indicesol.h" +#include "iniprint.h" +#include "temps.h" +#include "logic.h" + INTEGER, PARAMETER :: longcles=20 + REAL, DIMENSION(longcles) :: clesphy0 + REAL, DIMENSION(iip1,jjp1) :: masque + CHARACTER(LEN=15) :: calnd + REAL, DIMENSION(iip1,jjp1) :: phis ! geopotentiel au sol +!------------------------------------------------------------------------------- + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + + CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/)) + WRITE(lunout,*)'---> klon=',klon + CALL InitComgeomphy + +#ifdef CPP_IOIPSL + SELECT CASE(calend) + CASE('earth_360d');CALL ioconf_calendar('360d'); calnd='a 360 jours/an' + CASE('earth_365d');CALL ioconf_calendar('noleap'); calnd='a 365 jours/an' + CASE('earth_366d');CALL ioconf_calendar('366d'); calnd='bissextile' + CASE('gregorian'); CALL ioconf_calendar('gregorian'); calnd='gregorien' + CASE('standard'); CALL ioconf_calendar('gregorian'); calnd='gregorien' + CASE('julian'); CALL ioconf_calendar('julian'); calnd='julien' + CASE('proleptic_gregorian'); CALL ioconf_calendar('gregorian') + !--- DC Bof... => IOIPSL a mettre a jour: proleptic_gregorian /= gregorian + CASE DEFAULT + CALL abort_gcm('ce0l','Mauvais choix de calendrier',1) + END SELECT + WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre '//TRIM(calnd) +#endif + + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday) + CALL init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0) + WRITE(lunout,*)'nbtr =' , nbtr +#endif + END IF + + WRITE(lunout,'(//)') + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,*) ' *** etat0_netcdf *** ' + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,'(//)') + WRITE(lunout,*) ' interbar = ',interbar + CALL etat0_netcdf(interbar,masque,phis,ok_etat0) + + IF(ok_limit) THEN + WRITE(lunout,'(//)') + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,*) ' *** Limit_netcdf *** ' + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,'(//)') + CALL limit_netcdf(interbar,extrap,oldice,masque) + END IF + + IF (grilles_gcm_netcdf) THEN + WRITE(lunout,'(//)') + WRITE(lunout,*) ' *************************** ' + WRITE(lunout,*) ' *** grilles_gcm_netcdf *** ' + WRITE(lunout,*) ' *************************** ' + WRITE(lunout,'(//)') + CALL grilles_gcm_netcdf_sub(masque,phis) + END IF +#endif +! of #ifndef CPP_EARTH #else + +END PROGRAM ce0l +! +!------------------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/clesph0.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/clesph0.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/clesph0.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! +c..include clesph0.h +c + COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr , + , ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con +c + LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq + LOGICAL ok_limitvrai + INTEGER nbapp_rad, iflag_con Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/coefpoly.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/coefpoly.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/coefpoly.F (revision 1634) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 , + , a0,a1,a2,a3 ) + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c +c Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui +c satisfait aux 4 equations suivantes : + +c a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1 +c a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2 +c a1 + 2.*a2*xtild1 + 3.*a3*xtild1*xtild1 = Xprim1 +c a1 + 2.*a2*xtild2 + 3.*a3*xtild2*xtild2 = Xprim2 + +c On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3 + + REAL(KIND=8) Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi + REAL(KIND=8) Xfout, Xprim + REAL(KIND=8) a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car + + xtil1car = xtild1 * xtild1 + xtil2car = xtild2 * xtild2 + + derr= 2. *(Xf2-Xf1)/( xtild1-xtild2) + + x1x2car = ( xtild1-xtild2)*(xtild1-xtild2) + + a3 = (derr + Xprim1+Xprim2 )/x1x2car + a2 = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) ) / + / ( 2.* ( xtild1 - xtild2 ) ) + + a1 = Xprim1 -3.* a3 * xtil1car -2.* a2 * xtild1 + a0 = Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1 + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/com_io_dyn_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/com_io_dyn_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/com_io_dyn_mod.F90 (revision 1634) @@ -0,0 +1,31 @@ +! +! $Id $ +! +module com_io_dyn_mod + + implicit none + +! Names of various files for outputs (in the dynamics) + ! to store instantaneous values: + character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid + character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid + character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid + + ! to store averaged values: + character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc" + character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc" + character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc" + +! Ids of various files for outputs (in the dynamics) + + ! instantaneous (these are set by inithist.F) + integer :: histid + integer :: histvid + integer :: histuid + + ! averages (these are set by initdynav.F) + integer :: histaveid + integer :: histvaveid + integer :: histuaveid + +end module com_io_dyn_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comconst.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comconst.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comconst.h (revision 1634) @@ -0,0 +1,39 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE comconst.h + + COMMON/comconsti/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl, & + & iflag_top_bound + COMMON/comconstr/dtvr,daysec, & + & pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg & + & ,dissip_factz,dissip_deltaz,dissip_zref & + & ,tau_top_bound, & + & daylen,year_day,molmass, ihf + + + INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl + REAL dtvr ! dynamical time step (in s) + REAL daysec !length (in s) of a standard day + REAL pi ! something like 3.14159.... + REAL dtphys ! (s) time step for the physics + REAL dtdiss ! (s) time step for the dissipation + REAL rad ! (m) radius of the planet + REAL r ! Gas constant R=8.31 J.K-1.mol-1 + REAL cpp ! Cp + REAL kappa ! kappa=R/Cp + REAL cotot + REAL unsim ! = 1./iim + REAL g ! (m/s2) gravity + REAL omeg ! (rad/s) rotation rate of the planet + REAL dissip_factz,dissip_deltaz,dissip_zref + INTEGER iflag_top_bound + REAL tau_top_bound + REAL daylen ! length of solar day, in 'standard' day length + REAL year_day ! Number of standard days in a year + REAL molmass ! (g/mol) molar mass of the atmosphere + + REAL ihf ! (W/m2) Intrinsic heat flux (for giant planets) + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissip.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissip.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissip.h (revision 1634) @@ -0,0 +1,15 @@ +! +! $Header$ +! +!----------------------------------------------------------------------- +! INCLUDE comdissip.h + + COMMON/comdissip/ & + & niterdis,coefdis,tetavel,tetatemp,gamdissip + + + INTEGER niterdis + + REAL tetavel,tetatemp,coefdis,gamdissip + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissipn.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissipn.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissipn.h (revision 1634) @@ -0,0 +1,20 @@ +! +! $Header$ +! +! Attention : ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +!----------------------------------------------------------------------- +! INCLUDE comdissipn.h + + REAL tetaudiv, tetaurot, tetah, cdivu, crot, cdivh +! + COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm) , & + & cdivu, crot, cdivh + +! +! Les parametres de ce common proviennent des calculs effectues dans +! Inidissip . +! +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissnew.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissnew.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comdissnew.h (revision 1634) @@ -0,0 +1,24 @@ +! +! $Id$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!----------------------------------------------------------------------- +! INCLUDE 'comdissnew.h' + + COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv, & + & tetagrot,tetatemp,coefdis + + LOGICAL lstardis + INTEGER nitergdiv, nitergrot, niterh + REAL tetagdiv, tetagrot, tetatemp, coefdis + +! +! ... Les parametres de ce common comdissnew sont lues par defrun_new +! sur le fichier run.def .... +! +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comgeom.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comgeom.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comgeom.h (revision 1634) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom + COMMON/comgeom/ & + & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm), & + & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1), & + & airev(ip1jm),unsaire(ip1jmp1),apoln,apols, & + & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm), & + & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1), & + & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1), & + & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1), & + & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1), & + & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm), & + & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm), & + & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1), & + & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1), & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2, & + & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm), & + & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1) + +! + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln ,& + & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,& + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,& + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 ,& + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2& + & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam ,& + & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu& + & , xprimv +! Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comgeom2.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comgeom2.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comgeom2.h (revision 1634) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom2 + COMMON/comgeom/ & + & cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm) , & + & aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1) , & + & airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols , & + & unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm) , & + & aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1) , & + & aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1) , & + & alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1) , & + & alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1) , & + & fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm) , & + & cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1) , & + & cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), & + & cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2 , & + & unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1) , & + & unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm) & + & , xprimu(iip1),xprimv(iip1) + + + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire & + & ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4 , & + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , & + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 , & + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1 , & + & unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2 , & + & unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu , & + & cusurcvu,xprimu,xprimv Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comvert.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comvert.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/comvert.h (revision 1634) @@ -0,0 +1,32 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE 'comvert.h' + + COMMON/comvertr/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm), & + & pa,preff,nivsigs(llm),nivsig(llm+1), & + & aps(llm),bps(llm),scaleheight + + common/comverti/disvert_type + + real ap ! hybrid pressure contribution at interlayers + real bp ! hybrid sigma contribution at interlayer + real presnivs ! (reference) pressure at mid-layers + real dpres + real pa ! reference pressure (Pa) at which hybrid coordinates + ! become purely pressure + real preff ! reference surface pressure (Pa) + real nivsigs + real nivsig + real aps ! hybrid pressure contribution at mid-layers + real bps ! hybrid sigma contribution at mid-layers + real scaleheight ! atmospheric (reference) scale height (km) + + integer disvert_type ! type of vertical discretization: + ! 1: Earth (default for planet_type==earth), + ! automatic generation + ! 2: Planets (default for planet_type!=earth), + ! using 'z2sig.def' (or 'esasig.def) file + + !----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_dat2d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_dat2d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_dat2d.F (revision 1634) @@ -0,0 +1,221 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd , + , interbar ) +c +c Auteur : P. Le Van + +c Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que +c qu'on ait - pi a pi en longitude +c et qu'on ait pi/2. a - pi/2. en latitude +c +c xd et yd sont les longitudes et latitudes initiales +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . + + IMPLICIT NONE + +c *** Arguments en entree *** + INTEGER lons,lats + CHARACTER*25 title + REAL xd(lons),yd(lats) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons),yf(lats) +c +c *** Arguments en entree et sortie *** + REAL champd(lons,lats) + +c *** Variables locales *** +c + REAL pi,pis2,depi + LOGICAL radianlon, invlon ,radianlat, invlat, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: champf(:,:) + +c +c WRITE(6,*) ' conf_dat2d pour la variable ', title + + ALLOCATE( xtemp(lons) ) + ALLOCATE( ytemp(lats) ) + ALLOCATE( champf(lons,lats) ) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + radianlon = .FALSE. + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + IF ( invlon ) THEN + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO j = 1,lats + + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j) = champf (i,j) + ENDDO + + DO i= ind +1,lons + champd (i,j) = champf (i-ind,j) + ENDDO + + ENDDO + + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + DO j = 1,lats + yf(j) = ytemp(j) + ENDDO + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1) = champf (i,j) + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** + +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + + ENDIF +c + DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + deallocate(xtemp) + deallocate(ytemp) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_dat3d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_dat3d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_dat3d.F (revision 1634) @@ -0,0 +1,296 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf, + , champd , interbar ) +c +c Auteur : P. Le Van +c +c Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon +c qu'on ait - pi a pi en longitude +c qu'on ait pi/2. a - pi/2. en latitude +c et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos. +c ( en Pascals ) . +c +c xd et yd sont les longitudes et latitudes initiales +c zd les pressions initiales +c +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . +c zf les pressions en sortie +c +c champd en meme temps le champ initial et final +c +c interbar = .TRUE. si on appelle l'interpo. barycentrique inter_barxy +c sinon , l'interpolation grille_m ( grid_atob ) . +c + + IMPLICIT NONE + +c *** Arguments en entree *** + CHARACTER*(*) :: title + INTEGER lons, lats, levs + REAL xd(lons), yd(lats), zd(levs) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons), yf(lats), zf(levs) + +c *** Arguments en entree et sortie *** + REAL champd(lons,lats,levs) + +c *** Variables locales *** +c + REAL pi,pis2,depi,presmax + LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind,l + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: ztemp(:) + REAL, ALLOCATABLE :: champf(:,:,:) + + +c WRITE(6,*) ' Conf_dat3d pour ',title + + ALLOCATE(xtemp(lons)) + ALLOCATE(ytemp(lats)) + ALLOCATE(ztemp(levs)) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + DO l = 1, levs + ztemp(l) = zd(l) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + alloc =.FALSE. + + IF ( invlon ) THEN + + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO + + DO l = 1, levs + DO j = 1, lats + DO i= 1, lons + champf (i,j,l) = champd (i,j,l) + ENDDO + ENDDO + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO l = 1,levs + DO j = 1,lats + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j,l) = champf (i,j,l) + ENDDO + + DO i= ind +1,lons + champd (i,j,l) = champf (i-ind,j,l) + ENDDO + ENDDO + ENDDO + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1,l) = champf (i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** +c +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + ENDIF +c + + invlev = .FALSE. + IF( ztemp(1).LT.ztemp(levs) ) invlev = .TRUE. + + presmax = MAX( ztemp(1), ztemp(levs) ) + IF( presmax.LT.1200. ) THEN + DO l = 1,levs + ztemp(l) = ztemp(l) * 100. + ENDDO + ENDIF + + IF( invlev ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO l = 1,levs + zf(l) = ztemp(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + ENDDO + + DO l = 1,levs + ztemp(levs+1-l) = zf(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champd(i,j,levs+1-l) = champf(i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF(alloc) DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + DO l = 1, levs + zf(l) = ztemp(l) + ENDDO + + DEALLOCATE(xtemp) + DEALLOCATE(ytemp) + DEALLOCATE(ztemp) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_gcm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_gcm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_gcm.F (revision 1634) @@ -0,0 +1,899 @@ +! +! $Id$ +! +c +c + SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 ) +c + USE control_mod +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +#include "temps.h" +#include "comconst.h" + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! #include "clesphys.h" +#include "iniprint.h" +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy, tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + LOGICAL use_filtre_fft +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + +!Config Key = lunout +!Config Desc = unite de fichier pour les impressions +!Config Def = 6 +!Config Help = unite de fichier pour les impressions +!Config (defaut sortie standard = 6) + lunout=6 + CALL getin('lunout', lunout) + IF (lunout /= 5 .and. lunout /= 6) THEN + OPEN(lunout,FILE='lmdz.out') + ENDIF + +!Config Key = prt_level +!Config Desc = niveau d'impressions de débogage +!Config Def = 0 +!Config Help = Niveau d'impression pour le débogage +!Config (0 = minimum d'impression) + prt_level = 0 + CALL getin('prt_level',prt_level) + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- +!Config Key = planet_type +!Config Desc = planet type ("earth", "mars", "venus", ...) +!Config Def = earth +!Config Help = this flag sets the type of atymosphere that is considered + planet_type="earth" + CALL getin('planet_type',planet_type) + +!Config Key = calend +!Config Desc = type de calendrier utilise +!Config Def = earth_360d +!Config Help = valeur possible: earth_360d, earth_365d, earth_366d +!Config + calend = 'earth_360d' + CALL getin('calend', calend) + +!Config Key = dayref +!Config Desc = Jour de l'etat initial +!Config Def = 1 +!Config Help = Jour de l'etat initial ( = 350 si 20 Decembre , +!Config par expl. ,comme ici ) ... A completer + dayref=1 + CALL getin('dayref', dayref) + +!Config Key = anneeref +!Config Desc = Annee de l'etat initial +!Config Def = 1998 +!Config Help = Annee de l'etat initial +!Config ( avec 4 chiffres ) ... A completer + anneeref = 1998 + CALL getin('anneeref',anneeref) + +!Config Key = raz_date +!Config Desc = Remise a zero de la date initiale +!Config Def = 0 (pas de remise a zero) +!Config Help = Remise a zero de la date initiale +!Config 0 pas de remise a zero, on garde la date du fichier restart +!Config 1 prise en compte de la date de gcm.def avec remise a zero +!Config des compteurs de pas de temps + raz_date = 0 + CALL getin('raz_date', raz_date) + +!Config Key = nday +!Config Desc = Nombre de jours d'integration +!Config Def = 10 +!Config Help = Nombre de jours d'integration +!Config ... On pourait aussi permettre des mois ou des annees ! + nday = 10 + CALL getin('nday',nday) + +!Config Key = day_step +!Config Desc = nombre de pas par jour +!Config Def = 240 +!Config Help = nombre de pas par jour (multiple de iperiod) ( +!Config ici pour dt = 1 min ) + day_step = 240 + CALL getin('day_step',day_step) + +!Config Key = nsplit_phys +!Config Desc = nombre de pas par jour +!Config Def = 1 +!Config Help = nombre de pas par jour (multiple de iperiod) ( +!Config ici pour dt = 1 min ) + nsplit_phys = 1 + CALL getin('nsplit_phys',nsplit_phys) + +!Config Key = iperiod +!Config Desc = periode pour le pas Matsuno +!Config Def = 5 +!Config Help = periode pour le pas Matsuno (en pas de temps) + iperiod = 5 + CALL getin('iperiod',iperiod) + +!Config Key = iapp_tracvl +!Config Desc = frequence du groupement des flux +!Config Def = iperiod +!Config Help = frequence du groupement des flux (en pas de temps) + iapp_tracvl = iperiod + CALL getin('iapp_tracvl',iapp_tracvl) + +!Config Key = iconser +!Config Desc = periode de sortie des variables de controle +!Config Def = 240 +!Config Help = periode de sortie des variables de controle +!Config (En pas de temps) + iconser = 240 + CALL getin('iconser', iconser) + +!Config Key = iecri +!Config Desc = periode d'ecriture du fichier histoire +!Config Def = 1 +!Config Help = periode d'ecriture du fichier histoire (en jour) + iecri = 1 + CALL getin('iecri',iecri) + + +!Config Key = periodav +!Config Desc = periode de stockage fichier histmoy +!Config Def = 1 +!Config Help = periode de stockage fichier histmoy (en jour) + periodav = 1. + CALL getin('periodav',periodav) + +!Config Key = output_grads_dyn +!Config Desc = output dynamics diagnostics in 'dyn.dat' file +!Config Def = n +!Config Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file + output_grads_dyn=.false. + CALL getin('output_grads_dyn',output_grads_dyn) + +!Config Key = dissip_period +!Config Desc = periode de la dissipation +!Config Def = 0 +!Config Help = periode de la dissipation +!Config dissip_period=0 => la valeur sera calcule dans inidissip +!Config dissip_period>0 => on prend cette valeur + dissip_period = 0 + CALL getin('dissip_period',dissip_period) + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + +!Config Key = lstardis +!Config Desc = choix de l'operateur de dissipation +!Config Def = y +!Config Help = choix de l'operateur de dissipation +!Config 'y' si on veut star et 'n' si on veut non-start ! +!Config Moi y en a pas comprendre ! + lstardis = .TRUE. + CALL getin('lstardis',lstardis) + + +!Config Key = nitergdiv +!Config Desc = Nombre d'iteration de gradiv +!Config Def = 1 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config gradiv + nitergdiv = 1 + CALL getin('nitergdiv',nitergdiv) + +!Config Key = nitergrot +!Config Desc = nombre d'iterations de nxgradrot +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config nxgradrot + nitergrot = 2 + CALL getin('nitergrot',nitergrot) + + +!Config Key = niterh +!Config Desc = nombre d'iterations de divgrad +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config divgrad + niterh = 2 + CALL getin('niterh',niterh) + + +!Config Key = tetagdiv +!Config Desc = temps de dissipation pour div +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (gradiv) + tetagdiv = 7200. + CALL getin('tetagdiv',tetagdiv) + +!Config Key = tetagrot +!Config Desc = temps de dissipation pour grad +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (nxgradrot) + tetagrot = 7200. + CALL getin('tetagrot',tetagrot) + +!Config Key = tetatemp +!Config Desc = temps de dissipation pour h +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour h (divgrad) + tetatemp = 7200. + CALL getin('tetatemp',tetatemp ) + +! Parametres controlant la variation sur la verticale des constantes de +! dissipation. +! Pour le moment actifs uniquement dans la version a 39 niveaux +! avec ok_strato=y + + dissip_factz=4. + dissip_deltaz=10. + dissip_zref=30. + CALL getin('dissip_factz',dissip_factz ) + CALL getin('dissip_deltaz',dissip_deltaz ) + CALL getin('dissip_zref',dissip_zref ) + + iflag_top_bound=1 + tau_top_bound=1.e-5 + CALL getin('iflag_top_bound',iflag_top_bound) + CALL getin('tau_top_bound',tau_top_bound) + +!Config Key = coefdis +!Config Desc = coefficient pour gamdissip +!Config Def = 0 +!Config Help = coefficient pour gamdissip + coefdis = 0. + CALL getin('coefdis',coefdis) + +!Config Key = purmats +!Config Desc = Schema d'integration +!Config Def = n +!Config Help = Choix du schema d'integration temporel. +!Config y = pure Matsuno sinon c'est du Matsuno-leapfrog + purmats = .FALSE. + CALL getin('purmats',purmats) + +!Config Key = ok_guide +!Config Desc = Guidage +!Config Def = n +!Config Help = Guidage + ok_guide = .FALSE. + CALL getin('ok_guide',ok_guide) + +c ............................................................... + +!Config Key = read_start +!Config Desc = Initialize model using a 'start.nc' file +!Config Def = y +!Config Help = y: intialize dynamical fields using a 'start.nc' file +! n: fields are initialized by 'iniacademic' routine + read_start= .true. + CALL getin('read_start',read_start) + +!Config Key = iflag_phys +!Config Desc = Avec ls physique +!Config Def = 1 +!Config Help = Permet de faire tourner le modele sans +!Config physique. + iflag_phys = 1 + CALL getin('iflag_phys',iflag_phys) + + +!Config Key = iphysiq +!Config Desc = Periode de la physique +!Config Def = 5 +!Config Help = Periode de la physique en pas de temps de la dynamique. + iphysiq = 5 + CALL getin('iphysiq', iphysiq) + +!Config Key = ip_ebil_dyn +!Config Desc = PRINT level for energy conserv. diag. +!Config Def = 0 +!Config Help = PRINT level for energy conservation diag. ; +! les options suivantes existent : +!Config 0 pas de print +!Config 1 pas de print +!Config 2 print, + ip_ebil_dyn = 0 + CALL getin('ip_ebil_dyn',ip_ebil_dyn) +! + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clonn = 0. + CALL getin('clon',clonn) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clatt = 0. + CALL getin('clat',clatt) + +c +c + IF( ABS(clat - clatt).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de clat passee par run.def', + & ' est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismxx = 1.0 + CALL getin('grossismx',grossismxx) + + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismx passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismyy = 1.0 + CALL getin('grossismy',grossismyy) + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismy passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypbb = .TRUE. + CALL getin('fxyhypb',fxyhypbb) + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'F alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'T alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF +c +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomxx = 0.0 + CALL getin('dzoomx',dzoomxx) + + IF( fxyhypb ) THEN + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomyy = 0.0 + CALL getin('dzoomy',dzoomyy) + + IF( fxyhypb ) THEN + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + tauxx = 3.0 + CALL getin('taux',tauxx) + + IF( fxyhypb ) THEN + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de taux passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = tauyy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauyy = 3.0 + CALL getin('tauy',tauyy) + + IF( fxyhypb ) THEN + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de tauy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinuss = .TRUE. + CALL getin('ysinus',ysinuss) + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF + ENDIF ! of IF( .NOT.fxyhypb ) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + +!Config Key = ok_dynzon +!Config Desc = calcul et sortie des transports +!Config Def = n +!Config Help = Permet de mettre en route le calcul des transports +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + +!Config Key = ok_dyn_ins +!Config Desc = sorties instantanees dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ins = .FALSE. + CALL getin('ok_dyn_ins',ok_dyn_ins) + +!Config Key = ok_dyn_ave +!Config Desc = sorties moyennes dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ave = .FALSE. + CALL getin('ok_dyn_ave',ok_dyn_ave) + + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' dissip_period = ', dissip_period + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clonn = ', clonn + write(lunout,*)' clatt = ', clatt + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypbb = ', fxyhypbb + write(lunout,*)' dzoomxx = ', dzoomxx + write(lunout,*)' dzoomy = ', dzoomyy + write(lunout,*)' tauxx = ', tauxx + write(lunout,*)' tauyy = ', tauyy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins + write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave + + RETURN +c ............................................... +c +100 CONTINUE +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clon = 0. + CALL getin('clon',clon) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clat = 0. + CALL getin('clat',clat) + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismx = 1.0 + CALL getin('grossismx',grossismx) + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismy = 1.0 + CALL getin('grossismy',grossismy) + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypb = .TRUE. + CALL getin('fxyhypb',fxyhypb) + +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomx = 0.0 + CALL getin('dzoomx',dzoomx) + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomy = 0.0 + CALL getin('dzoomy',dzoomy) + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + taux = 3.0 + CALL getin('taux',taux) + +!Config Key = tauy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauy = 3.0 + CALL getin('tauy',tauy) + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinus = .TRUE. + CALL getin('ysinus',ysinus) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + +!Config Key = ok_dynzon +!Config Desc = sortie des transports zonaux dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + +!Config Key = ok_dyn_ins +!Config Desc = sorties instantanees dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ins = .FALSE. + CALL getin('ok_dyn_ins',ok_dyn_ins) + +!Config Key = ok_dyn_ave +!Config Desc = sorties moyennes dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ave = .FALSE. + CALL getin('ok_dyn_ave',ok_dyn_ave) + +!Config Key = use_filtre_fft +!Config Desc = flag d'activation des FFT pour le filtre +!Config Def = false +!Config Help = permet d'activer l'utilisation des FFT pour effectuer +!Config le filtrage aux poles. +! Le filtre fft n'est pas implemente dans dyn3d + use_filtre_fft=.FALSE. + CALL getin('use_filtre_fft',use_filtre_fft) + + IF (use_filtre_fft) THEN + write(lunout,*)'STOP !!!' + write(lunout,*)'use_filtre_fft n est pas implemente dans dyn3d' + STOP + ENDIF + +!Config key = ok_strato +!Config Desc = activation de la version strato +!Config Def = .FALSE. +!Config Help = active la version stratosphérique de LMDZ de F. Lott + + ok_strato=.FALSE. + CALL getin('ok_strato',ok_strato) + +!Config Key = ok_gradsfile +!Config Desc = activation des sorties grads du guidage +!Config Def = n +!Config Help = active les sorties grads du guidage + + ok_gradsfile = .FALSE. + CALL getin('ok_gradsfile',ok_gradsfile) + +!Config Key = ok_limit +!Config Desc = creation des fichiers limit dans create_etat0_limit +!Config Def = y +!Config Help = production du fichier limit.nc requise + + ok_limit = .TRUE. + CALL getin('ok_limit',ok_limit) + +!Config Key = ok_etat0 +!Config Desc = creation des fichiers etat0 dans create_etat0_limit +!Config Def = y +!Config Help = production des fichiers start.nc, startphy.nc requise + + ok_etat0 = .TRUE. + CALL getin('ok_etat0',ok_etat0) + +!Config Key = grilles_gcm_netcdf +!Config Desc = creation de fichier grilles_gcm.nc dans create_etat0_limit +!Config Def = n + grilles_gcm_netcdf = .FALSE. + CALL getin('grilles_gcm_netcdf',grilles_gcm_netcdf) + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres de cel0' + & //'_limit: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' dissip_period = ', dissip_period + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clon = ', clon + write(lunout,*)' clat = ', clat + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypb = ', fxyhypb + write(lunout,*)' dzoomx = ', dzoomx + write(lunout,*)' dzoomy = ', dzoomy + write(lunout,*)' taux = ', taux + write(lunout,*)' tauy = ', tauy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins + write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave + write(lunout,*)' ok_strato = ', ok_strato + write(lunout,*)' ok_gradsfile = ', ok_gradsfile + write(lunout,*)' ok_limit = ', ok_limit + write(lunout,*)' ok_etat0 = ', ok_etat0 + write(lunout,*)' grilles_gcm_netcdf = ', grilles_gcm_netcdf +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_planete.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_planete.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/conf_planete.F90 (revision 1634) @@ -0,0 +1,70 @@ +! +! $Id$ +! +SUBROUTINE conf_planete +! +#ifdef CPP_IOIPSL +USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin +USE ioipsl_getincom +#endif +IMPLICIT NONE +! +! +! Declarations : +! -------------- +#include "dimensions.h" +#include "comconst.h" +#include "comvert.h" +! +! local: +! ------ + +! --------------------------------------------- +! Initialisations de constantes de la dynamique +! --------------------------------------------- +! Pi +pi=2.*asin(1.) + +!Reference surface pressure (Pa) +preff=101325. +CALL getin('preff', preff) +! Reference pressure at which hybrid coord. become purely pressure +! pa=50000. +pa=preff/2. +CALL getin('pa', pa) +! Gravity +g=9.80665 +CALL getin('g',g) +! Molar mass of the atmosphere +molmass = 28.9644 +CALL getin('molmass',molmass) +! kappa=R/Cp et Cp +kappa = 2./7. +CALL getin('kappa',kappa) +cpp=8.3145/molmass/kappa*1000. +CALL getin('cpp',cpp) +! Radius of the planet +rad = 6371229. +CALL getin('radius',rad) +! Length of a standard day (s) +daysec=86400. +CALL getin('daysec',daysec) +! Rotation rate of the planet: +! Length of a solar day, in standard days +daylen = 1. +CALL getin('daylen',daylen) +! Number of days (standard) per year: +year_day = 365.25 +CALL getin('year_day',year_day) +! Omega +! omeg=2.*pi/86400. +omeg=2.*pi/daysec*(1./daylen+1./year_day) +CALL getin('omeg',omeg) + +! Intrinsic heat flux (default: none) (only used if planet_type="giant") +ihf = 0. +call getin('ihf',ihf) + +END SUBROUTINE conf_planete Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/control_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/control_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/control_mod.F90 (revision 1634) @@ -0,0 +1,27 @@ +! +! $Id $ +! + +MODULE control_mod + +! LF 01/2010 +! Remplacement du fichier et common control + + IMPLICIT NONE + + REAL :: periodav + INTEGER :: nday,day_step,iperiod,iapp_tracvl,nsplit_phys + INTEGER :: iconser,iecri,dissip_period,iphysiq,iecrimoy + INTEGER :: dayref,anneeref, raz_date, ip_ebil_dyn + LOGICAL :: offline + CHARACTER (len=4) :: config_inca + CHARACTER (len=10) :: planet_type ! planet type ('earth','mars',...) + LOGICAL output_grads_dyn ! output dynamics diagnostics in + ! binary grads file 'dyn.dat' (y/n) + LOGICAL ok_dynzon ! output zonal transports in dynzon.nc file + LOGICAL ok_dyn_ins ! output instantaneous values of fields + ! in the dynamics in NetCDF files dyn_hist*nc + LOGICAL ok_dyn_ave ! output averaged values of fields in the dynamics + ! in NetCDF files dyn_hist*ave.nc + +END MODULE Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/convflu.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/convflu.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/convflu.F (revision 1634) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE convflu( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + REAL SSUM +c +c +#include "comgeom.h" +c + DO 5 l = 1,nbniv +c + DO 2 ij = iip2, ip1jm - 1 + convfl( ij + 1,l ) = xflu( ij,l ) - xflu( ij + 1,l ) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + DO 4 ij = 1,iip1 + convfl( ij ,l ) = convpn * aire( ij ) / apoln + convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols + 4 CONTINUE +c + 5 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/convmas.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/convmas.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/convmas.F (revision 1634) @@ -0,0 +1,63 @@ +! +! $Header$ +! + SUBROUTINE convmas (pbaru, pbarv, convm ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm( ip1jmp1,llm ) + INTEGER l,ij + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + + DO l = llmm1, 1, -1 + DO ij = 1, ip1jmp1 + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/coordij.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/coordij.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/coordij.F (revision 1634) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE coordij(lon,lat,ilon,jlat) + +c======================================================================= +c +c calcul des coordonnees i et j de la maille scalaire dans +c laquelle se trouve le point (lon,lat) en radian +c +c======================================================================= + + IMPLICIT NONE + REAL lon,lat + INTEGER ilon,jlat + INTEGER i,j + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" + + real zlon,zlat + + zlon=lon*pi/180. + zlat=lat*pi/180. + + DO i=1,iim+1 + IF (rlonu(i).GT.zlon) THEN + ilon=i + GOTO 10 + ENDIF + ENDDO +10 CONTINUE + + j=0 + DO j=1,jjm + IF(rlatv(j).LT.zlat) THEN + jlat=j + GOTO 20 + ENDIF + ENDDO +20 CONTINUE + IF(j.EQ.0) j=jjm+1 + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/covcont.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/covcont.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/covcont.F (revision 1634) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) + INTEGER l,ij + + + DO 10 l = 1,klevel + + DO 2 ij = iip2, ip1jm + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = 1,ip1jm + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/covnat.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/covnat.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/covnat.F (revision 1634) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: F Hourdin Phu LeVan +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. naturelles a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) + INTEGER l,ij + + + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + + DO ij = iip2, ip1jm + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + + DO ij = 1,ip1jm + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + + ENDDO + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/cray.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/cray.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/cray.F (revision 1634) @@ -0,0 +1,42 @@ +! +! $Header$ +! +#ifdef CRAY + SUBROUTINE riencray + END +#else + subroutine scopy(n,sx,incx,sy,incy) +c + IMPLICIT NONE +c + integer n,incx,incy,ix,iy,i + real sx((n-1)*incx+1),sy((n-1)*incy+1) +c + iy=1 + ix=1 + do 10 i=1,n + sy(iy)=sx(ix) + ix=ix+incx + iy=iy+incy +10 continue +c + return + end + + function ssum(n,sx,incx) +c + IMPLICIT NONE +c + integer n,incx,i,ix + real ssum,sx((n-1)*incx+1) +c + ssum=0. + ix=1 + do 10 i=1,n + ssum=ssum+sx(ix) + ix=ix+incx +10 continue +c + return + end +#endif Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/defrun.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/defrun.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/defrun.F (revision 1634) @@ -0,0 +1,496 @@ +! +! $Id$ +! +c +c + SUBROUTINE defrun( tapedef, etatinit, clesphy0 ) +c + USE control_mod + + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +#include "clesph0.h" +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + INTEGER tapeout + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy,tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + + tapeout = 6 + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- + + OPEN( tapedef,file ='gcm.def',status='old',form='formatted') + + + READ (tapedef,9000) ch1,ch2,ch3 + WRITE(tapeout,9000) ch1,ch2,ch3 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dayref + WRITE(tapeout,9001) ch1,'dayref' + WRITE(tapeout,*) dayref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) anneeref + WRITE(tapeout,9001) ch1,'anneeref' + WRITE(tapeout,*) anneeref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nday + WRITE(tapeout,9001) ch1,'nday' + WRITE(tapeout,*) nday + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) day_step + WRITE(tapeout,9001) ch1,'day_step' + WRITE(tapeout,*) day_step + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iperiod + WRITE(tapeout,9001) ch1,'iperiod' + WRITE(tapeout,*) iperiod + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iapp_tracvl + WRITE(tapeout,9001) ch1,'iapp_tracvl' + WRITE(tapeout,*) iapp_tracvl + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iconser + WRITE(tapeout,9001) ch1,'iconser' + WRITE(tapeout,*) iconser + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iecri + WRITE(tapeout,9001) ch1,'iecri' + WRITE(tapeout,*) iecri + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) periodav + WRITE(tapeout,9001) ch1,'periodav' + WRITE(tapeout,*) periodav + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dissip_period + WRITE(tapeout,9001) ch1,'dissip_period' + WRITE(tapeout,*) dissip_period + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) lstardis + WRITE(tapeout,9001) ch1,'lstardis' + WRITE(tapeout,*) lstardis + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergdiv + WRITE(tapeout,9001) ch1,'nitergdiv' + WRITE(tapeout,*) nitergdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergrot + WRITE(tapeout,9001) ch1,'nitergrot' + WRITE(tapeout,*) nitergrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) niterh + WRITE(tapeout,9001) ch1,'niterh' + WRITE(tapeout,*) niterh + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagdiv + WRITE(tapeout,9001) ch1,'tetagdiv' + WRITE(tapeout,*) tetagdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagrot + WRITE(tapeout,9001) ch1,'tetagrot' + WRITE(tapeout,*) tetagrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetatemp + WRITE(tapeout,9001) ch1,'tetatemp' + WRITE(tapeout,*) tetatemp + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) coefdis + WRITE(tapeout,9001) ch1,'coefdis' + WRITE(tapeout,*) coefdis +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) purmats + WRITE(tapeout,9001) ch1,'purmats' + WRITE(tapeout,*) purmats + +c ............................................................... + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_phys + WRITE(tapeout,9001) ch1,'iflag_phys' + WRITE(tapeout,*) iflag_phys + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iphysiq + WRITE(tapeout,9001) ch1,'iphysiq' + WRITE(tapeout,*) iphysiq + + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) cycle_diurne + WRITE(tapeout,9001) ch1,'cycle_diurne' + WRITE(tapeout,*) cycle_diurne + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) soil_model + WRITE(tapeout,9001) ch1,'soil_model' + WRITE(tapeout,*) soil_model + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) new_oliq + WRITE(tapeout,9001) ch1,'new_oliq' + WRITE(tapeout,*) new_oliq + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orodr + WRITE(tapeout,9001) ch1,'ok_orodr' + WRITE(tapeout,*) ok_orodr + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orolf + WRITE(tapeout,9001) ch1,'ok_orolf' + WRITE(tapeout,*) ok_orolf + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_limitvrai + WRITE(tapeout,9001) ch1,'ok_limitvrai' + WRITE(tapeout,*) ok_limitvrai + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nbapp_rad + WRITE(tapeout,9001) ch1,'nbapp_rad' + WRITE(tapeout,*) nbapp_rad + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_con + WRITE(tapeout,9001) ch1,'iflag_con' + WRITE(tapeout,*) iflag_con + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + clesphy0(1) = REAL( iflag_con ) + clesphy0(2) = REAL( nbapp_rad ) + + IF( cycle_diurne ) clesphy0(3) = 1. + IF( soil_model ) clesphy0(4) = 1. + IF( new_oliq ) clesphy0(5) = 1. + IF( ok_orodr ) clesphy0(6) = 1. + IF( ok_orolf ) clesphy0(7) = 1. + IF( ok_limitvrai ) clesphy0(8) = 1. + + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clonn + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clonn + IF( ABS(clon - clonn).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clatt + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clatt + + IF( ABS(clat - clatt).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismxx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismxx + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismyy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismyy + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypbb + WRITE(tapeout,9001) ch1,'fxyhypbb' + WRITE(tapeout,*) fxyhypbb + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F' + *, ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t' + *, ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomxx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomyy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomyy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauxx + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) tauxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauyy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauyy + + IF( fxyhypb ) THEN + + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de taux passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de tauy passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinuss + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinuss + + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF + ENDIF +c + WRITE(6,*) ' alphax alphay defrun ',alphax,alphay + + CLOSE(tapedef) + + RETURN +c ............................................... +c +100 CONTINUE +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clon + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clon +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clat + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clat + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismy + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) '*** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypb + WRITE(tapeout,9001) ch1,'fxyhypb' + WRITE(tapeout,*) fxyhypb + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) taux + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) taux +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinus + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinus + + WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay +c +9000 FORMAT(3(/,a72)) +9001 FORMAT(/,a72,/,a12) +cc + CLOSE(tapedef) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/description.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/description.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/description.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + character *120 descript + common /titre/descript Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diagedyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diagedyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diagedyn.F (revision 1634) @@ -0,0 +1,321 @@ +! +! $Id$ +! + +C====================================================================== + SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime + e , ucov , vcov , ps, p ,pk , teta , q, ql) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la dynamique. +C +C +c====================================================================== +C Arguments: +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +C uconv, vconv-input-R- vents covariants (m/s) +C ps-------input-R- Surface pressure (Pa) +C p--------input-R- pressure at the interfaces +C pk-------input-R- pk= (p/Pref)**kappa +c teta-----input-R- potential temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c aire-----input-R- mesh surafce (m2) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C +C J.L. Dufresne, July 2002 +c====================================================================== + + IMPLICIT NONE +C +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" + +#ifdef CPP_EARTH +#include "../phylmd/YOMCST.h" +#include "../phylmd/YOETHF.h" +#endif +C + INTEGER imjmp1 + PARAMETER( imjmp1=iim*jjp1) +c Input variables + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pk (ip1jmp1,llm ) ! = (p/Pref)**kappa + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm) ! champs eau vapeur + REAL ql(ip1jmp1,llm) ! champs eau liquide + + +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL masse(ip1jmp1,llm) ! masse d'air + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL ecin(ip1jmp1,llm) + + REAL zaire(imjmp1) + REAL zps(imjmp1) + REAL zairm(imjmp1,llm) + REAL zecin(imjmp1,llm) + REAL zpaprs(imjmp1,llm) + REAL zpk(imjmp1,llm) + REAL zt(imjmp1,llm) + REAL zh(imjmp1,llm) + REAL zqw(imjmp1,llm) + REAL zql(imjmp1,llm) + REAL zqs(imjmp1,llm) + + REAL zqw_col(imjmp1) + REAL zql_col(imjmp1) + REAL zqs_col(imjmp1) + REAL zec_col(imjmp1) + REAL zh_dair_col(imjmp1) + REAL zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k, jj, ij , l ,ip1jjm1 +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre + + +#ifdef CPP_EARTH +c====================================================================== +C Compute Kinetic enrgy + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL massdair( p, masse ) +c====================================================================== +C +C + print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?' + return +C On ne garde les donnees que dans les colonnes i=1,iim + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zaire(i)=aire(ij+ip1jjm1) + zps(i)=ps(ij+ip1jjm1) + ENDDO + ENDDO +C 3D arrays + DO l = 1, llm + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zairm(i,l) = masse(ij+ip1jjm1,l) + zecin(i,l) = ecin(ij+ip1jjm1,l) + zpaprs(i,l) = p(ij+ip1jjm1,l) + zpk(i,l) = pk(ij+ip1jjm1,l) + zh(i,l) = teta(ij+ip1jjm1,l) + zqw(i,l) = q(ij+ip1jjm1,l) + zql(i,l) = ql(ij+ip1jjm1,l) + zqs(i,l) = 0. + ENDDO + ENDDO + ENDDO +C +C Reset variables + DO i = 1, imjmp1 + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, llm + DO i = 1, imjmp1 +C Watter mass + zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +zecin(i,k)*zairm(i,k) +C Air enthalpy + zt(i,k)= zh(i,k) * zpk(i,k) / RCPD + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) + $ - RLVTT*zql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) + $ - RLSTT*zqs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,imjmp1 + qw_tot = qw_tot + zqw_col(i) + ql_tot = ql_tot + zql_col(i) + qs_tot = qs_tot + zqs_col(i) + ec_tot = ec_tot + zec_col(i) + h_dair_tot = h_dair_tot + zh_dair_col(i) + h_qw_tot = h_qw_tot + zh_qw_col(i) + h_ql_tot = h_ql_tot + zh_ql_col(i) + h_qs_tot = h_qs_tot + zh_qs_col(i) + airetot=airetot+zaire(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) +C WRITE(6,9003) tit,pas(idiag), ec_tot + 9003 format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6)) + WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec + 9004 format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C +#else + write(lunout,*)'diagedyn: Needs Earth physics to function' +#endif +! #endif of #ifdef CPP_EARTH + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dissip.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dissip.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dissip.F (revision 1634) @@ -0,0 +1,143 @@ +! +! $Header$ +! + SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh ) +c + IMPLICIT NONE + + +c .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... +c ( 10/01/98 ) + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c Dissipation horizontale +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comdissnew.h" +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm) + +c Local: +c ------ + + REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm) + REAL grx(ip1jmp1,llm),gry(ip1jm,llm) + REAL te1dt(llm),te2dt(llm),te3dt(llm) + REAL deltapres(ip1jmp1,llm) + + INTEGER l,ij + + REAL SSUM + +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + + DO l=1,llm + te1dt(l) = tetaudiv(l) * dtdiss + te2dt(l) = tetaurot(l) * dtdiss + te3dt(l) = tetah(l) * dtdiss + ENDDO + du=0. + dv=0. + dh=0. + +c----------------------------------------------------------------------- +c Calcul de la dissipation: +c ------------------------- + +c Calcul de la partie grad ( div ) : +c ------------------------------------- + + + IF(lstardis) THEN + CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ELSE + CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ENDIF + + DO l=1,llm + + DO ij = 1, iip1 + gdx( ij ,l) = 0. + gdx(ij+ip1jm,l) = 0. + ENDDO + + DO ij = iip2,ip1jm + du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) + ENDDO + DO ij = 1,ip1jm + dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) + ENDDO + + ENDDO + +c calcul de la partie n X grad ( rot ): +c --------------------------------------- + + IF(lstardis) THEN + CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry ) + ELSE + CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry ) + ENDIF + + + DO l=1,llm + DO ij = 1, iip1 + grx(ij,l) = 0. + ENDDO + + DO ij = iip2,ip1jm + du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) + ENDDO + DO ij = 1, ip1jm + dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) + ENDDO + ENDDO + +c calcul de la partie div ( grad ): +c ----------------------------------- + + + IF(lstardis) THEN + + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) + ENDDO + ENDDO + + CALL divgrad2( llm,teta, deltapres ,niterh, gdx ) + ELSE + CALL divgrad ( llm,teta, niterh, gdx ) + ENDIF + + DO l = 1,llm + DO ij = 1,ip1jmp1 + dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/disvert.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/disvert.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/disvert.F90 (revision 1634) @@ -0,0 +1,150 @@ +! $Id$ + +SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,scaleheight) + + ! Auteur : P. Le Van + + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "iniprint.h" + include "logic.h" + + ! s = sigma ** kappa : coordonnee verticale + ! dsig(l) : epaisseur de la couche l ds la coord. s + ! sig(l) : sigma a l'interface des couches l et l-1 + ! ds(l) : distance entre les couches l et l-1 en coord.s + + real,intent(in) :: pa, preff + real,intent(out) :: ap(llmp1), bp(llmp1) + real,intent(out) :: dpres(llm), nivsigs(llm), nivsig(llmp1) + real,intent(out) :: presnivs(llm) + real,intent(out) :: scaleheight + + REAL sig(llm+1), dsig(llm) + real zk, zkm1, dzk1, dzk2, k0, k1 + + INTEGER l + REAL dsigmin + REAL alpha, beta, deltaz + INTEGER iostat + REAL x + character(len=*),parameter :: modname="disvert" + + !----------------------------------------------------------------------- + + ! default scaleheight is 8km for earth + scaleheight=8. + + OPEN(99, file='sigma.def', status='old', form='formatted', iostat=iostat) + + IF (iostat == 0) THEN + ! cas 1 on lit les options dans sigma.def: + READ(99, *) scaleheight ! hauteur d'echelle 8. + READ(99, *) deltaz ! epaiseur de la premiere couche 0.04 + READ(99, *) beta ! facteur d'acroissement en haut 1.3 + READ(99, *) k0 ! nombre de couches dans la transition surf + READ(99, *) k1 ! nombre de couches dans la transition haute + CLOSE(99) + alpha=deltaz/(llm*scaleheight) + write(lunout, *)trim(modname),':scaleheight, alpha, k0, k1, beta', & + scaleheight, alpha, k0, k1, beta + + alpha=deltaz/tanh(1./k0)*2. + zkm1=0. + sig(1)=1. + do l=1, llm + sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) & + *exp(-alpha/scaleheight*tanh((llm-k1)/k0) & + *beta**(l-(llm-k1))/log(beta)) + zk=-scaleheight*log(sig(l+1)) + + dzk1=alpha*tanh(l/k0) + dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta) + write(lunout, *)l, sig(l+1), zk, zk-zkm1, dzk1, dzk2 + zkm1=zk + enddo + + sig(llm+1)=0. + + DO l = 1, llm + dsig(l) = sig(l)-sig(l+1) + end DO + ELSE + if (ok_strato) then + if (llm==39) then + dsigmin=0.3 + else if (llm==50) then + dsigmin=1. + else + write(lunout,*) trim(modname), & + ' ATTENTION discretisation z a ajuster' + dsigmin=1. + endif + write(lunout,*) trim(modname), & + ' Discretisation verticale DSIGMIN=',dsigmin + endif + + DO l = 1, llm + x = 2*asin(1.) * (l - 0.5) / (llm + 1) + + IF (ok_strato) THEN + dsig(l) =(dsigmin + 7. * SIN(x)**2) & + *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2 + ELSE + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + ENDIF + ENDDO + dsig = dsig / sum(dsig) + sig(llm+1) = 0. + DO l = llm, 1, -1 + sig(l) = sig(l+1) + dsig(l) + ENDDO + ENDIF + + DO l=1, llm + nivsigs(l) = REAL(l) + ENDDO + + DO l=1, llmp1 + nivsig(l)= REAL(l) + ENDDO + + ! .... Calculs de ap(l) et de bp(l) .... + ! ..... pa et preff sont lus sur les fichiers start par lectba ..... + + bp(llmp1) = 0. + + DO l = 1, llm + bp(l) = EXP( 1. -1./( sig(l)*sig(l)) ) + ap(l) = pa * ( sig(l) - bp(l) ) + ENDDO + + bp(1)=1. + ap(1)=0. + + ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) ) + + write(lunout, *) trim(modname),': BP ' + write(lunout, *) bp + write(lunout, *) trim(modname),': AP ' + write(lunout, *) ap + + write(lunout, *) 'Niveaux de pressions approximatifs aux centres des' + write(lunout, *)'couches calcules pour une pression de surface =', preff + write(lunout, *) 'et altitudes equivalentes pour une hauteur d echelle de ' + write(lunout, *) scaleheight,' km' + DO l = 1, llm + dpres(l) = bp(l) - bp(l+1) + presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff ) + write(lunout, *)'PRESNIVS(', l, ')=', presnivs(l), ' Z ~ ', & + log(preff/presnivs(l))*scaleheight & + , ' DZ ~ ', scaleheight*log((ap(l)+bp(l)*preff)/ & + max(ap(l+1)+bp(l+1)*preff, 1.e-10)) + ENDDO + + write(lunout, *) trim(modname),': PRESNIVS ' + write(lunout, *) presnivs + +END SUBROUTINE disvert Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/disvert_noterre.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/disvert_noterre.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/disvert_noterre.F (revision 1634) @@ -0,0 +1,331 @@ +! $Id: $ + SUBROUTINE disvert_noterre + +c Auteur : F. Forget Y. Wanherdrick, P. Levan +c Nouvelle version 100% Mars !! +c On l'utilise aussi pour Venus et Titan, legerment modifiee. + +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "logic.h" +#include "iniprint.h" +c +c======================================================================= +c Discretisation verticale en coordonnée hybride (ou sigma) +c +c======================================================================= +c +c declarations: +c ------------- +c +c + INTEGER l,ll + REAL snorm + REAL alpha,beta,gama,delta,deltaz + real quoi,quand + REAL zsig(llm),sig(llm+1) + INTEGER np,ierr + integer :: ierr1,ierr2,ierr3,ierr4 + REAL x + + REAL SSUM + EXTERNAL SSUM + real newsig + REAL dz0,dz1,nhaut,sig1,esig,csig,zz + real tt,rr,gg, prevz + real s(llm),dsig(llm) + real pseudoalt(llm) + + integer iz + real z, ps,p + character(len=*),parameter :: modname="disvert_noterre" + +c +c----------------------------------------------------------------------- +c +! Initializations: +! pi=2.*ASIN(1.) ! already done in iniconst + + hybrid=.true. ! default value for hybrid (ie: use hybrid coordinates) + CALL getin('hybrid',hybrid) + write(lunout,*) trim(modname),': hybrid=',hybrid + +! Ouverture possible de fichiers typiquement E.T. + + open(99,file="esasig.def",status='old',form='formatted', + s iostat=ierr2) + if(ierr2.ne.0) then + close(99) + open(99,file="z2sig.def",status='old',form='formatted', + s iostat=ierr4) + endif + +c----------------------------------------------------------------------- +c cas 1 on lit les options dans esasig.def: +c ---------------------------------------- + + IF(ierr2.eq.0) then + +c Lecture de esasig.def : +c Systeme peu souple, mais qui respecte en theorie +c La conservation de l'energie (conversion Energie potentielle +c <-> energie cinetique, d'apres la note de Frederic Hourdin... + + write(lunout,*)'*****************************' + write(lunout,*)'WARNING reading esasig.def' + write(lunout,*)'*****************************' + READ(99,*) scaleheight + READ(99,*) dz0 + READ(99,*) dz1 + READ(99,*) nhaut + CLOSE(99) + + dz0=dz0/scaleheight + dz1=dz1/scaleheight + + sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut) + + esig=1. + + do l=1,20 + esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.) + enddo + csig=(1./sig1-1.)/(exp(esig)-1.) + + DO L = 2, llm + zz=csig*(exp(esig*(l-1.))-1.) + sig(l) =1./(1.+zz) + & * tanh(.5*(llm+1-l)/nhaut) + ENDDO + sig(1)=1. + sig(llm+1)=0. + quoi = 1. + 2.* kappa + s( llm ) = 1. + s(llm-1) = quoi + IF( llm.gt.2 ) THEN + DO ll = 2, llm-1 + l = llm+1 - ll + quand = sig(l+1)/ sig(l) + s(l-1) = quoi * (1.-quand) * s(l) + quand * s(l+1) + ENDDO + END IF +c + snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2) + DO l = 1, llm + s(l) = s(l)/ snorm + ENDDO + +c----------------------------------------------------------------------- +c cas 2 on lit les options dans z2sig.def: +c ---------------------------------------- + + ELSE IF(ierr4.eq.0) then + write(lunout,*)'****************************' + write(lunout,*)'Reading z2sig.def' + write(lunout,*)'****************************' + + READ(99,*) scaleheight + do l=1,llm + read(99,*) zsig(l) + end do + CLOSE(99) + + sig(1) =1 + do l=2,llm + sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + + & exp(-zsig(l-1)/scaleheight) ) + end do + sig(llm+1) =0 + +c----------------------------------------------------------------------- + ELSE + write(lunout,*) 'didn t you forget something ??? ' + write(lunout,*) 'We need file z2sig.def ! (OR esasig.def)' + stop + ENDIF +c----------------------------------------------------------------------- + + DO l=1,llm + nivsigs(l) = REAL(l) + ENDDO + + DO l=1,llmp1 + nivsig(l)= REAL(l) + ENDDO + + +c----------------------------------------------------------------------- +c .... Calculs de ap(l) et de bp(l) .... +c ......................................... +c +c ..... pa et preff sont lus sur les fichiers start par dynetat0 ..... +c----------------------------------------------------------------------- +c + + if (hybrid) then ! use hybrid coordinates + write(lunout,*) "*********************************" + write(lunout,*) "Using hybrid vertical coordinates" + write(lunout,*) +c Coordonnees hybrides avec mod + DO l = 1, llm + + call sig_hybrid(sig(l),pa,preff,newsig) + bp(l) = EXP( 1. - 1./(newsig**2) ) + ap(l) = pa * (newsig - bp(l) ) + enddo + bp(llmp1) = 0. + ap(llmp1) = 0. + else ! use sigma coordinates + write(lunout,*) "********************************" + write(lunout,*) "Using sigma vertical coordinates" + write(lunout,*) +c Pour ne pas passer en coordonnees hybrides + DO l = 1, llm + ap(l) = 0. + bp(l) = sig(l) + ENDDO + ap(llmp1) = 0. + endif + + bp(llmp1) = 0. + + write(lunout,*) trim(modname),': BP ' + write(lunout,*) bp + write(lunout,*) trim(modname),': AP ' + write(lunout,*) ap + +c Calcul au milieu des couches : +c WARNING : le choix de placer le milieu des couches au niveau de +c pression intermédiaire est arbitraire et pourrait etre modifié. +c Le calcul du niveau pour la derniere couche +c (on met la meme distance (en log pression) entre P(llm) +c et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est +c Specifique. Ce choix est spécifié ici ET dans exner_milieu.F + + DO l = 1, llm-1 + aps(l) = 0.5 *( ap(l) +ap(l+1)) + bps(l) = 0.5 *( bp(l) +bp(l+1)) + ENDDO + + if (hybrid) then + aps(llm) = aps(llm-1)**2 / aps(llm-2) + bps(llm) = 0.5*(bp(llm) + bp(llm+1)) + else + bps(llm) = bps(llm-1)**2 / bps(llm-2) + aps(llm) = 0. + end if + + write(lunout,*) trim(modname),': BPs ' + write(lunout,*) bps + write(lunout,*) trim(modname),': APs' + write(lunout,*) aps + + DO l = 1, llm + presnivs(l) = aps(l)+bps(l)*preff + pseudoalt(l) = -scaleheight*log(presnivs(l)/preff) + ENDDO + + write(lunout,*)trim(modname),' : PRESNIVS' + write(lunout,*)presnivs + write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ', + & 'height of ',scaleheight,' km)' + write(lunout,*)pseudoalt + +c -------------------------------------------------- +c This can be used to plot the vertical discretization +c (> xmgrace -nxy testhybrid.tab ) +c -------------------------------------------------- +c open (53,file='testhybrid.tab') +c scaleheight=15.5 +c do iz=0,34 +c z = -5 + min(iz,34-iz) +c approximation of scale height for Venus +c scaleheight = 15.5 - z/55.*10. +c ps = preff*exp(-z/scaleheight) +c zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff) +c do l=2,llm +c approximation of scale height for Venus +c if (zsig(l-1).le.55.) then +c scaleheight = 15.5 - zsig(l-1)/55.*10. +c else +c scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2. +c endif +c zsig(l)= zsig(l-1)-scaleheight* +c . log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps)) +c end do +c write(53,'(I3,50F10.5)') iz, zsig +c end do +c close(53) +c -------------------------------------------------- + + + RETURN + END + +c ************************************************************ + subroutine sig_hybrid(sig,pa,preff,newsig) +c ---------------------------------------------- +c Subroutine utilisee pour calculer des valeurs de sigma modifie +c pour conserver les coordonnees verticales decrites dans +c esasig.def/z2sig.def lors du passage en coordonnees hybrides +c F. Forget 2002 +c Connaissant sig (niveaux "sigma" ou on veut mettre les couches) +c L'objectif est de calculer newsig telle que +c (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig +c Cela ne se résoud pas analytiquement: +c => on résoud par iterration bourrine +c ---------------------------------------------- +c Information : where exp(1-1./x**2) become << x +c x exp(1-1./x**2) /x +c 1 1 +c 0.68 0.5 +c 0.5 1.E-1 +c 0.391 1.E-2 +c 0.333 1.E-3 +c 0.295 1.E-4 +c 0.269 1.E-5 +c 0.248 1.E-6 +c => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25 + + + implicit none + real x1, x2, sig,pa,preff, newsig, F + integer j + + newsig = sig + x1=0 + x2=1 + if (sig.ge.1) then + newsig= sig + else if (sig*preff/pa.ge.0.25) then + DO J=1,9999 ! nombre d''iteration max + F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig +c write(0,*) J, ' newsig =', newsig, ' F= ', F + if (F.gt.1) then + X2 = newsig + newsig=(X1+newsig)*0.5 + else + X1 = newsig + newsig=(X2+newsig)*0.5 + end if +c Test : on arete lorsque on approxime sig à moins de 0.01 m près +c (en pseudo altitude) : + IF(abs(10.*log(F)).LT.1.E-5) goto 999 + END DO + else ! if (sig*preff/pa.le.0.25) then + newsig= sig*preff/pa + end if + 999 continue + Return + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diverg.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diverg.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diverg.F (revision 1634) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE diverg(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diverg_gam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diverg_gam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/diverg_gam.F (revision 1634) @@ -0,0 +1,80 @@ +! +! $Header$ +! + SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divergf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divergf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divergf.F (revision 1634) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE divergf(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divergst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divergst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divergst.F (revision 1634) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE divergst(klevel,x,y,div) + IMPLICIT NONE +c +c P. Le Van +c +c ****************************************************************** +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y... +c x et y etant des composantes contravariantes ... +c **************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c ------------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER ij,l,i + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO 1 ij = iip2, ip1jm - 1 + div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l) + 1 CONTINUE +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + 3 CONTINUE +c +c .... calcul aux poles ..... +c +c + DO 5 i = 1,iim + aiy1(i)= y(i,l) + aiy2(i)= y(i+ip1jmi1,l) + 5 CONTINUE + sumypn = SSUM ( iim,aiy1,1 ) + sumyps = SSUM ( iim,aiy2,1 ) + DO 7 i = 1,iip1 + div( i , l ) = - sumypn/iim + div( i + ip1jm, l ) = sumyps/iim + 7 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divgrad.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divgrad.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divgrad.F (revision 1634) @@ -0,0 +1,56 @@ +! +! $Header$ +! + SUBROUTINE divgrad (klevel,h, lh, divgra ) + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c +c +c + CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) +c + DO 10 iter = 1,lh + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1 ) + + CALL grad (klevel,divgra, ghx , ghy ) + CALL diverg (klevel, ghx , ghy , divgra ) + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1) + + DO 5 l = 1,klevel + DO 4 ij = 1, ip1jmp1 + divgra( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divgrad2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divgrad2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/divgrad2.F (revision 1634) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra( ip1jmp1,klevel) +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + + CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + +c + CALL laplacien( klevel, divgra, divgra ) + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 + CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c + CALL laplacien ( klevel, divgra, divgra ) +c + DO l = 1,klevel + DO ij = 1,ip1jmp1 + divgra(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dteta1.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dteta1.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dteta1.F (revision 1634) @@ -0,0 +1,68 @@ +! +! $Header$ +! + SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c Modif F.Forget 03/94 (on retire q et dq pour construire dteta1) +c +c ******************************************************************** +c ... calcul du terme de convergence horizontale du flux d'enthalpie +c potentielle ...... +c ******************************************************************** +c .. teta,pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c dteta sont des arguments de sortie pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" + + REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL dteta( ip1jmp1,llm ) + INTEGER l,ij + + REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm ) + +c + + DO 5 l = 1,llm + + DO 1 ij = iip2, ip1jm - 1 + hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) ) + 1 CONTINUE + +c .... correction pour hbxu(iip1,j,l) ..... +c .... hbxu(iip1,j,l)= hbxu(1,j,l) .... + +CDIR$ IVDEP + DO 2 ij = iip1+ iip1, ip1jm, iip1 + hbxu( ij, l ) = hbxu( ij - iim, l ) + 2 CONTINUE + + + DO 3 ij = 1,ip1jm + hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) ) + 3 CONTINUE + + 5 CONTINUE + + + CALL convflu ( hbxu, hbyv, llm, dteta ) + + +c stockage dans dh de la convergence horizont. filtree' du flux +c .... ........... +c d'enthalpie potentielle . + + CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1) + +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dudv1.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dudv1.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dudv1.F (revision 1634) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv ) + IMPLICIT NONE +c +c----------------------------------------------------------------------- +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul du terme de rotation +c ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. +c vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. +c du et dv sont des arguments de sortie pour le s-pg .. +c +c----------------------------------------------------------------------- + +#include "dimensions.h" +#include "paramet.h" + + REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) , + * pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm ) + INTEGER l,ij +c +c + DO 10 l = 1,llm +c + DO 2 ij = iip2, ip1jm - 1 + du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * + * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + + * pbarv( ij , l) + pbarv(ij+ 1 , l) ) + 2 CONTINUE +c + DO 3 ij = 1, ip1jm - 1 + dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * + * ( pbaru(ij, l) + pbaru(ij+1 , l) + + * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) + 3 CONTINUE +c +c .... correction pour dv( 1,j,l ) ..... +c .... dv(1,j,l)= dv(iip1,j,l) .... +c +CDIR$ IVDEP + DO 4 ij = 1, ip1jm, iip1 + dv( ij,l ) = dv( ij + iim, l ) + 4 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dudv2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dudv2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dudv2.F (revision 1634) @@ -0,0 +1,63 @@ +! +! $Header$ +! + SUBROUTINE dudv2 ( teta, pkf, bern, du, dv ) + + IMPLICIT NONE +c +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ***************************************************************** +c ..... calcul du terme de pression (gradient de p/densite ) et +c du terme de ( -gradient de la fonction de Bernouilli ) ... +c ***************************************************************** +c Ces termes sont ajoutes a d(ucov)/dt et a d(vcov)/dt .. +c +c +c teta , pkf, bern sont des arguments d'entree pour le s-pg .... +c du et dv sont des arguments de sortie pour le s-pg .... +c +c======================================================================= +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ), + * du( ip1jmp1,llm ), dv( ip1jm,llm ) + INTEGER l,ij +c +c + DO 5 l = 1,llm +c + DO 2 ij = iip2, ip1jm - 1 + du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * + * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) + 2 CONTINUE +c +c +c ..... correction pour du(iip1,j,l), j=2,jjm ...... +c ... du(iip1,j,l) = du(1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = iip1+ iip1, ip1jm, iip1 + du( ij,l ) = du( ij - iim,l ) + 3 CONTINUE +c +c + DO 4 ij = 1,ip1jm + dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * + * ( pkf(ij+iip1,l) - pkf( ij,l ) ) + * + bern( ij+iip1,l ) - bern( ij ,l ) + 4 CONTINUE +c + 5 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dump2d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dump2d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dump2d.F (revision 1634) @@ -0,0 +1,46 @@ +! +! $Id$ +! + SUBROUTINE dump2d(im,jm,z,nom_z) + IMPLICIT NONE + INTEGER im,jm + REAL z(im,jm) + CHARACTER (len=*) :: nom_z + + INTEGER i,j,imin,illm,jmin,jllm + REAL zmin,zllm + + WRITE(*,*) "dump2d: ",trim(nom_z) + + zmin=z(1,1) + zllm=z(1,1) + imin=1 + illm=1 + jmin=1 + jllm=1 + + DO j=1,jm + DO i=1,im + IF(z(i,j).GT.zllm) THEN + illm=i + jllm=j + zllm=z(i,j) + ENDIF + IF(z(i,j).LT.zmin) THEN + imin=i + jmin=j + zmin=z(i,j) + ENDIF + ENDDO + ENDDO + + PRINT*,'MIN: ',zmin + PRINT*,'MAX: ',zllm + + IF(zllm.GT.zmin) THEN + DO j=1,jm + WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im) + ENDDO + ENDIF + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dynetat0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dynetat0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dynetat0.F (revision 1634) @@ -0,0 +1,386 @@ +! +! $Id $ +! + SUBROUTINE dynetat0(fichnom,vcov,ucov, + . teta,q,masse,ps,phis,time) + + USE infotrac + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "logic.h" +#include "iniprint.h" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + + REAL time + +c Variables +c + INTEGER length,iq + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr, nid, nvarid + +c----------------------------------------------------------------------- + +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(lunout,*)'dynetat0: Pb d''ouverture du fichier start.nc' + write(lunout,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) +c ................................................................. +c +c + write(lunout,*)'dynetat0: rad,omeg,g,cpp,kappa', + & rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + + IF(nqtot.GE.1) THEN + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le traceur <"//trim(tname(iq))// + & "> est absent" + write(lunout,*)" Il est donc initialise a zero" + q(:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + ENDIF + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dynredem.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dynredem.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/dynredem.F (revision 1634) @@ -0,0 +1,765 @@ +! +! $Id$ +! +c + SUBROUTINE dynredem0(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac + + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + + +c----------------------------------------------------------------------- + modname='dynredem0' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + tab_cntrl(4) = REAL(day_ref) + tab_cntrl(5) = REAL(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = REAL(iday_end) + tab_cntrl(31) = REAL(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + write(lunout,*)"dynredem0: Pb d ouverture du fichier " + & //trim(fichnom) + write(lunout,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + IF(nqtot.GE.1) THEN + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO + ENDIF +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + write(lunout,*)'dynredem0: iim,jjm,llm,iday_end', + & iim,jjm,llm,iday_end + write(lunout,*)'dynredem0: rad,omeg,g,cpp,kappa', + & rad,omeg,g,cpp,kappa + + RETURN + END + SUBROUTINE dynredem1(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE infotrac + USE control_mod + + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "iniprint.h" + + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynredem1: Pb. d ouverture "//trim(fichnom) + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*) NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + write(lunout,*) "dynredem1: Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = REAL(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable ucov n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable vcov n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable teta n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(lunout,*)'dynredem1: Pb d''ouverture du fichier', + & ' start_trac.nc' + write(lunout,*)' ierr = ', ierr_file + ENDIF + END IF + + IF(nqtot.GE.1) THEN + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable tname(iq) n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*) "dynredem1: ",trim(tname(iq)), + & " est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable "// + & trim(tname(iq))//" n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + write(lunout,*) "dynredem1: ",trim(tname(iq)), + & " est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Lecture echouee pour"// + & trim(tname(iq)) + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable "// + & trim(tname(iq))//" n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable "// + & trim(tname(iq))//" n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + ENDIF +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable masse n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable ps n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ener.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ener.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ener.h (revision 1634) @@ -0,0 +1,18 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! INCLUDE 'ener.h' + + COMMON/ener/ang0,etot0,ptot0,ztot0,stot0, & + & ang,etot,ptot,ztot,stot,rmsdpdt , & + & rmsv,gtot(llmm1) + + REAL ang0,etot0,ptot0,ztot0,stot0, & + & ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/enercin.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/enercin.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/enercin.F (revision 1634) @@ -0,0 +1,98 @@ +! +! $Header$ +! + SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), + * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i + + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + + + DO 5 l = 1,llm + + DO 1 ij = iip2, ip1jm -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = iip2, ip1jm, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + + DO 3 i = 1, iim + ecinni(i) = vcov( i , l) * vcont( i ,l) * aire( i ) + ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + 3 CONTINUE + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO 4 ij = 1,iip1 + ecin( ij , l ) = ecinpn + ecin( ij+ ip1jm, l ) = ecinps + 4 CONTINUE + + 5 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/etat0_netcdf.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/etat0_netcdf.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/etat0_netcdf.F90 (revision 1634) @@ -0,0 +1,530 @@ +! +! $Id$ +! +!------------------------------------------------------------------------------- +! +SUBROUTINE etat0_netcdf(ib, masque, phis, letat0) +! +!------------------------------------------------------------------------------- +! Purpose: Creates initial states +!------------------------------------------------------------------------------- +! Note: This routine is designed to work for Earth +!------------------------------------------------------------------------------- + USE control_mod +#ifdef CPP_EARTH + USE startvar + USE ioipsl + USE dimphy + USE infotrac + USE fonte_neige_mod + USE pbl_surface_mod + USE phys_state_var_mod + USE filtreg_mod + USE regr_lat_time_climoz_m, ONLY: regr_lat_time_climoz + USE conf_phys_m, ONLY: conf_phys +! For parameterization of ozone chemistry: + use regr_lat_time_coefoz_m, only: regr_lat_time_coefoz + use press_coefoz_m, only: press_coefoz + use regr_pr_o3_m, only: regr_pr_o3 + USE netcdf, ONLY : NF90_OPEN, NF90_NOWRITE, NF90_CLOSE, NF90_NOERR +#endif + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" + LOGICAL, INTENT(IN) :: ib ! barycentric interpolat. + REAL, DIMENSION(iip1,jjp1), INTENT(INOUT) :: masque ! land mask + REAL, DIMENSION(iip1,jjp1), INTENT(OUT) :: phis ! geopotentiel au sol + LOGICAL, INTENT(IN) :: letat0 ! F: masque only required +#ifndef CPP_EARTH + WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics' +#else +!------------------------------------------------------------------------------- +! Local variables: +#include "comgeom2.h" +#include "comvert.h" +#include "comconst.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "temps.h" + REAL, DIMENSION(klon) :: tsol, qsol + REAL, DIMENSION(klon) :: sn, rugmer, run_off_lic_0 + REAL, DIMENSION(iip1,jjp1) :: orog, rugo, psol + REAL, DIMENSION(iip1,jjp1,llm+1) :: p3d + REAL, DIMENSION(iip1,jjp1,llm) :: uvent, t3d, tpot, qsat, qd + REAL, DIMENSION(iip1,jjm ,llm) :: vvent + REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: q3d + REAL, DIMENSION(klon,nbsrf) :: qsolsrf, snsrf, evap + REAL, DIMENSION(klon,nbsrf) :: frugs, agesno + REAL, DIMENSION(klon,nsoilmx,nbsrf) :: tsoil + +!--- Local variables for sea-ice reading: + INTEGER :: iml_lic, jml_lic, llm_tmp + INTEGER :: ttm_tmp, iret, fid + INTEGER, DIMENSION(1) :: itaul + REAL, DIMENSION(1) :: lev + REAL :: date + REAL, DIMENSION(:,:), ALLOCATABLE :: lon_lic, lat_lic, fraclic + REAL, DIMENSION(:), ALLOCATABLE :: dlon_lic, dlat_lic + REAL, DIMENSION(iip1,jjp1) :: flic_tmp + +!--- Misc + CHARACTER(LEN=80) :: x, fmt + INTEGER :: i, j, l, ji + REAL, DIMENSION(iip1,jjp1,llm) :: alpha, beta, pk, pls, y + REAL, DIMENSION(ip1jmp1) :: pks + +#include "comdissnew.h" +#include "serre.h" +#include "clesphys.h" + + REAL, DIMENSION(iip1,jjp1,llm) :: masse + INTEGER :: itau, iday + REAL :: xpn, xps, time, phystep + REAL, DIMENSION(iim) :: xppn, xpps + REAL, DIMENSION(ip1jmp1,llm) :: pbaru, phi, w + REAL, DIMENSION(ip1jm ,llm) :: pbarv + REAL, DIMENSION(klon) :: fder + +!--- Local variables for ocean mask reading: + INTEGER :: nid_o2a, iml_omask, jml_omask + LOGICAL :: couple=.FALSE. + REAL, DIMENSION(:,:), ALLOCATABLE :: lon_omask, lat_omask, ocemask, ocetmp + REAL, DIMENSION(:), ALLOCATABLE :: dlon_omask,dlat_omask + REAL, DIMENSION(klon) :: ocemask_fi + INTEGER, DIMENSION(klon-2) :: isst + REAL, DIMENSION(iim,jjp1) :: zx_tmp_2d + REAL :: dummy + LOGICAL :: ok_newmicro, ok_journe, ok_mensuel, ok_instan, ok_hf + LOGICAL :: ok_LES, ok_ade, ok_aie, aerosol_couple, new_aod, callstats + INTEGER :: iflag_radia, flag_aerosol + REAL :: bl95_b0, bl95_b1, fact_cldcon, facttemps, ratqsbas, ratqshaut + REAL :: tau_ratqs + INTEGER :: iflag_cldcon, iflag_ratqs, iflag_coupl, iflag_clos, iflag_wake + INTEGER :: iflag_thermals, nsplit_thermals + INTEGER :: iflag_thermals_ed, iflag_thermals_optflux + REAL :: tau_thermals, solarlong0, seuil_inversion + INTEGER :: read_climoz ! read ozone climatology +! Allowed values are 0, 1 and 2 +! 0: do not read an ozone climatology +! 1: read a single ozone climatology that will be used day and night +! 2: read two ozone climatologies, the average day and night +! climatology and the daylight climatology +!------------------------------------------------------------------------------- + REAL :: alp_offset + logical found + +!--- Constants + pi = 4. * ATAN(1.) + rad = 6371229. + daysec = 86400. + omeg = 2.*pi/daysec + g = 9.8 + kappa = 0.2857143 + cpp = 1004.70885 + preff = 101325. + pa = 50000. + jmp1 = jjm + 1 + +!--- CONSTRUCT A GRID + CALL conf_phys( ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, & + callstats, & + solarlong0,seuil_inversion, & + fact_cldcon, facttemps,ok_newmicro,iflag_radia, & + iflag_cldcon, & + iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + ok_ade, ok_aie, aerosol_couple, & + flag_aerosol, new_aod, & + bl95_b0, bl95_b1, & + read_climoz, & + alp_offset) + +! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value) + co2_ppm0 = co2_ppm + + dtvr = daysec/FLOAT(day_step) + WRITE(lunout,*)'dtvr',dtvr + + CALL iniconst() + CALL inigeom() + +!--- Initializations for tracers + CALL infotrac_init + ALLOCATE(q3d(iip1,jjp1,llm,nqtot)) + + CALL inifilr() + CALL phys_state_var_init(read_climoz) + + rlat(1) = ASIN(1.0) + DO j=2,jjm; rlat((j-2)*iim+2:(j-1)*iim+1)=rlatu(j); END DO + rlat(klon) = - ASIN(1.0) + rlat(:)=rlat(:)*(180.0/pi) + + rlon(1) = 0.0 + DO j=2,jjm; rlon((j-2)*iim+2:(j-1)*iim+1)=rlonv(1:iim); END DO + rlon(klon) = 0.0 + rlon(:)=rlon(:)*(180.0/pi) + +! For a coupled simulation, the ocean mask from ocean model is used to compute +! the weights an to insure ocean fractions are the same for atmosphere and ocean +! Otherwise, mask is created using Relief file. + + WRITE(lunout,*)'Essai de lecture masque ocean' + iret = NF90_OPEN("o2a.nc", NF90_NOWRITE, nid_o2a) + IF(iret/=NF90_NOERR) THEN + WRITE(lunout,*)'ATTENTION!! pas de fichier o2a.nc trouve' + WRITE(lunout,*)'Run force' + x='masque' + masque(:,:)=0.0 + CALL startget_phys2d(x, iip1, jjp1, rlonv, rlatu, masque, 0.0, jjm, & + & rlonu, rlatv, ib) + WRITE(lunout,*)'MASQUE construit : Masque' + WRITE(lunout,'(97I1)') nINT(masque) + CALL gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq) + WHERE( zmasq(:)=1) CALL regr_lat_time_climoz(read_climoz) + + x = 'tsol'; tsol(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,tsol,0.0,jjm,rlonu,rlatv,ib) + + x = 'qsol'; qsol(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,qsol,0.0,jjm,rlonu,rlatv,ib) + + x = 'snow'; sn(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,sn,0.0,jjm,rlonu,rlatv,ib) + + x = 'rads'; radsol(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0,jjm,rlonu,rlatv,ib) + + x = 'rugmer'; rugmer(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0,jjm,rlonu,rlatv,ib) + + x = 'zmea'; zmea(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0,jjm,rlonu,rlatv,ib) + + x = 'zstd'; zstd(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0,jjm,rlonu,rlatv,ib) + + x = 'zsig'; zsig(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0,jjm,rlonu,rlatv,ib) + + x = 'zgam'; zgam(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0,jjm,rlonu,rlatv,ib) + + x = 'zthe'; zthe(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0,jjm,rlonu,rlatv,ib) + + x = 'zpic'; zpic(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0,jjm,rlonu,rlatv,ib) + + x = 'zval'; zval(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zval,0.0,jjm,rlonu,rlatv,ib) + +! WRITE(lunout,'(48I3)') 'TSOL :', INT(tsol(2:klon)-273) + +! Soil ice file reading for soil fraction and soil ice fraction +!******************************************************************************* + CALL flininfo("landiceref.nc", iml_lic, jml_lic, llm_tmp, ttm_tmp, fid) + ALLOCATE( lat_lic(iml_lic,jml_lic),lon_lic(iml_lic, jml_lic)) + ALLOCATE(dlat_lic(jml_lic), dlon_lic(iml_lic)) + ALLOCATE( fraclic(iml_lic,jml_lic)) + CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp, & + & lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp, 1,1, fraclic) + CALL flinclo(fid) + +! Interpolation on model T-grid +!******************************************************************************* + WRITE(lunout,*)'dimensions de landice iml_lic, jml_lic : ',iml_lic,jml_lic +! conversion if coordinates are in degrees + IF(MAXVAL(lon_lic)>pi) lon_lic=lon_lic*pi/180. + IF(MAXVAL(lat_lic)>pi) lat_lic=lat_lic*pi/180. + dlon_lic(:)=lon_lic(:,1) + dlat_lic(:)=lat_lic(1,:) + CALL grille_m( iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic, iim,jjp1, & + & rlonv, rlatu, flic_tmp(1:iim,:) ) + flic_tmp(iip1,:)=flic_tmp(1,:) + +!--- To the physical grid + CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, pctsrf(:,is_lic)) + +!--- Adequation with soil/sea mask + WHERE(pctsrf(:,is_lic)EPSFRA) THEN + IF(pctsrf(ji,is_lic)>=zmasq(ji)) THEN + pctsrf(ji,is_lic)=zmasq(ji) + pctsrf(ji,is_ter)=0. + ELSE + pctsrf(ji,is_ter)=zmasq(ji)-pctsrf(ji,is_lic) + IF(pctsrf(ji,is_ter)0.) isst=1 + +! It is checked that the sub-surfaces sum is equal to 1 +!******************************************************************************* + ji=COUNT((ABS(SUM(pctsrf(:,:),dim=2))-1.0)>EPSFRA) + IF(ji/=0) WRITE(lunout,*) 'pb repartition sous maille pour ',ji,' points' + CALL gr_fi_ecrit(1, klon, iim, jjp1, zmasq, zx_tmp_2d) +! WRITE(fmt,"(i3,')')")iim; fmt='(i'//ADJUSTL(fmt) +! WRITE(lunout,*)'zmasq = ' +! WRITE(lunout,TRIM(fmt))NINT(zx_tmp_2d) + CALL gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + WRITE(fmt,"(i4,'i1)')")iip1 ; fmt='('//ADJUSTL(fmt) + WRITE(lunout,*) 'MASQUE construit : Masque' + WRITE(lunout,TRIM(fmt))NINT(masque(:,:)) + +! Intermediate computation +!******************************************************************************* + CALL massdair(p3d,masse) + WRITE(lunout,*)' ALPHAX ',alphax + DO l=1,llm + xppn(:)=aire(1:iim,1 )*masse(1:iim,1 ,l) + xpps(:)=aire(1:iim,jjp1)*masse(1:iim,jjp1,l) + xpn=SUM(xppn)/apoln + xps=SUM(xpps)/apols + masse(:,1 ,l)=xpn + masse(:,jjp1,l)=xps + END DO + q3d(iip1,:,:,:)=q3d(1,:,:,:) + phis(iip1,:) = phis(1,:) + + IF(.NOT.letat0) RETURN + +! Writing +!******************************************************************************* + CALL inidissip(lstardis,nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,tetatemp) + WRITE(lunout,*)'sortie inidissip' + itau=0 + itau_dyn=0 + itau_phy=0 + iday=dayref+itau/day_step + time=FLOAT(itau-(iday-dayref)*day_step)/day_step + IF(time>1.) THEN + time=time-1 + iday=iday+1 + END IF + day_ref=dayref + annee_ref=anneeref + + CALL geopot( ip1jmp1, tpot, pk, pks, phis, phi ) + WRITE(lunout,*)'sortie geopot' + + CALL caldyn0( itau, uvent, vvent, tpot, psol, masse, pk, phis, & + phi, w, pbaru, pbarv, time+iday-dayref) + WRITE(lunout,*)'sortie caldyn0' + CALL dynredem0( "start.nc", dayref, phis) + WRITE(lunout,*)'sortie dynredem0' + CALL dynredem1( "start.nc", 0.0, vvent, uvent, tpot, q3d, masse, psol) + WRITE(lunout,*)'sortie dynredem1' + +! Physical initial state writting +!******************************************************************************* + WRITE(lunout,*)'phystep ',dtvr,iphysiq,nbapp_rad + phystep = dtvr * FLOAT(iphysiq) + radpas = NINT (86400./phystep/ FLOAT(nbapp_rad) ) + WRITE(lunout,*)'phystep =', phystep, radpas + +! Init: tsol, qsol, sn, evap, tsoil, rain_fall, snow_fall, solsw, sollw, frugs +!******************************************************************************* + DO i=1,nbsrf; ftsol(:,i) = tsol; END DO + DO i=1,nbsrf; snsrf(:,i) = sn; END DO + falb1(:,is_ter) = 0.08; falb1(:,is_lic) = 0.6 + falb1(:,is_oce) = 0.5; falb1(:,is_sic) = 0.6 + falb2 = falb1 + evap(:,:) = 0. + DO i=1,nbsrf; qsolsrf(:,i)=150.; END DO + DO i=1,nbsrf; DO j=1,nsoilmx; tsoil(:,j,i) = tsol; END DO; END DO + rain_fall = 0.; snow_fall = 0. + solsw = 165.; sollw = -53. + t_ancien = 273.15 + q_ancien = 0. + agesno = 0. + frugs(:,is_oce) = rugmer(:) + frugs(:,is_ter) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0) + frugs(:,is_lic) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0) + frugs(:,is_sic) = 0.001 + fder = 0.0 + clwcon = 0.0 + rnebcon = 0.0 + ratqs = 0.0 + run_off_lic_0 = 0.0 + rugoro = 0.0 + +! Before phyredem calling, surface modules and values to be saved in startphy.nc +! are initialized +!******************************************************************************* + dummy = 1.0 + pbl_tke(:,:,:) = 1.e-8 + zmax0(:) = 40. + f0(:) = 1.e-5 + ema_work1(:,:) = 0. + ema_work2(:,:) = 0. + wake_deltat(:,:) = 0. + wake_deltaq(:,:) = 0. + wake_s(:) = 0. + wake_cstar(:) = 0. + wake_fip(:) = 0. + wake_pe = 0. + fm_therm = 0. + entr_therm = 0. + detr_therm = 0. + + CALL fonte_neige_init(run_off_lic_0) + CALL pbl_surface_init( qsol, fder, snsrf, qsolsrf, evap, frugs, agesno, tsoil ) + CALL phyredem( "startphy.nc" ) + +! WRITE(lunout,*)'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0' +! WRITE(lunout,*)'entree histclo' + CALL histclo() + +#endif +!#endif of #ifdef CPP_EARTH + RETURN + +END SUBROUTINE etat0_netcdf +! +!------------------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/exner_hyb.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/exner_hyb.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/exner_hyb.F (revision 1634) @@ -0,0 +1,159 @@ +! +! $Id $ +! + SUBROUTINE exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) +c +c Auteurs : P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c -------- z +c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et +c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) +c ( voir note de Fr.Hourdin ) , +c +c on determine successivement , du haut vers le bas des couches, les +c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), +c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, +c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM +c + logical,save :: firstcall=.true. + character(len=*),parameter :: modname="exner_hyb" + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.1) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==1",42) + endif + + ! sanity checks for Shallow Water case (1 vertical layer) + if (llm.eq.1) then + if (kappa.ne.1) then + call abort_gcm(modname, + & "kappa!=1 , but running in Shallow Water mode!!",42) + endif + if (cpp.ne.r) then + call abort_gcm(modname, + & "cpp!=r , but running in Shallow Water mode!!",42) + endif + endif ! of if (llm.eq.1) + + firstcall=.false. + endif ! of if (firstcall) + + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + + DO ij = 1, ngrid + pks(ij) = (cpp/preff) * ps(ij) + pk(ij,1) = .5*pks(ij) + ENDDO + + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + + endif ! of if (llm.eq.1) + +!!!! General case: + + unpl2k = 1.+ 2.* kappa +c + DO ij = 1, ngrid + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO + + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij ) = xpn + pks( ij+ip1jm ) = xps + ENDDO +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c + DO ij = 1, ngrid + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c + DO ij = 1, ngrid + dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) + alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) + beta (ij,l) = p(ij,l ) / dellta + ENDDO +c + ENDDO +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c + DO ij = 1, ngrid + pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / + * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) + ENDDO +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm + DO ij = 1, ngrid + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO + ENDDO +c +c + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/exner_milieu.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/exner_milieu.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/exner_milieu.F (revision 1634) @@ -0,0 +1,151 @@ +! +! $Id $ +! + SUBROUTINE exner_milieu ( ngrid, ps, p,beta, pks, pk, pkf ) +c +c Auteurs : F. Forget , Y. Wanherdrick +c P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c WARNING : CECI est une version speciale de exner_hyb originale +c Utilise dans la version martienne pour pouvoir +c tourner avec des coordonnees verticales complexe +c => Il ne verifie PAS la condition la proportionalite en +c energie totale/ interne / potentielle (F.Forget 2001) +c ( voir note de Fr.Hourdin ) , +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL dum1 + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + logical,save :: firstcall=.true. + character(len=*),parameter :: modname="exner_milieu" + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.2) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==2",42) + endif + + ! sanity checks for Shallow Water case (1 vertical layer) + if (llm.eq.1) then + if (kappa.ne.1) then + call abort_gcm(modname, + & "kappa!=1 , but running in Shallow Water mode!!",42) + endif + if (cpp.ne.r) then + call abort_gcm(modname, + & "cpp!=r , but running in Shallow Water mode!!",42) + endif + endif ! of if (llm.eq.1) + + firstcall=.false. + endif ! of if (firstcall) + +!!!! Specific behaviour for Shallow Water (1 vertical layer) case: + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + + DO ij = 1, ngrid + pks(ij) = (cpp/preff) * ps(ij) + pk(ij,1) = .5*pks(ij) + ENDDO + + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + + endif ! of if (llm.eq.1) + +!!!! General case: + +c ------------- +c Calcul de pks +c ------------- + + DO ij = 1, ngrid + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO + + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij ) = xpn + pks( ij+ip1jm ) = xps + ENDDO +c +c +c .... Calcul de pk pour la couche l +c -------------------------------------------- +c + dum1 = cpp * (2*preff)**(-kappa) + DO l = 1, llm-1 + DO ij = 1, ngrid + pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa + ENDDO + ENDDO + +c .... Calcul de pk pour la couche l = llm .. +c (on met la meme distance (en log pression) entre Pk(llm) +c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) + + DO ij = 1, ngrid + pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) + ENDDO + + +c calcul de pkf +c ------------- + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + +c EST-CE UTILE ?? : calcul de beta +c -------------------------------- + DO l = 2, llm + DO ij = 1, ngrid + beta(ij,l) = pk(ij,l) / pk(ij,l-1) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/extrapol.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/extrapol.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/extrapol.F (revision 1634) @@ -0,0 +1,200 @@ +! +! $Id$ +! +C +C + SUBROUTINE extrapol (pfild, kxlon, kylat, pmask, + . norsud, ldper, knbor, pwork) + IMPLICIT none +c +c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997) +c Fill up missed values by using the neighbor points +c + INTEGER kxlon, kylat ! longitude and latitude dimensions (Input) + INTEGER knbor ! minimum neighbor number (Input) + LOGICAL norsud ! True if field is from North to South (Input) + LOGICAL ldper ! True if take into account the periodicity (Input) + REAL pmask ! mask value (Input) + REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output) + REAL pwork(kxlon,kylat) ! working space +c + REAL zwmsk + INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat + INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates + REAL zmask(9) +C +C We search over the eight closest neighbors +C +C j+1 7 8 9 +C j 4 5 6 Current point 5 --> (i,j) +C j-1 1 2 3 +C i-1 i i+1 +c +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + incre = 0 +c + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,j) + ENDDO + ENDDO +c +C* To avoid problems in floating point tests + zwmsk = pmask - 1.0 +c +200 CONTINUE + incre = incre + 1 + DO 99999 j = 1, kylat + DO 99999 i = 1, kxlon + IF (pfild(i,j).GT. zwmsk) THEN + pwork(i,j) = pfild(i,j) + inbor = 0 + ideb = 1 + ifin = 9 +C +C* Fill up ix array + ix(1) = MAX (1,i-1) + ix(2) = i + ix(3) = MIN (kxlon,i+1) + ix(4) = MAX (1,i-1) + ix(5) = i + ix(6) = MIN (kxlon,i+1) + ix(7) = MAX (1,i-1) + ix(8) = i + ix(9) = MIN (kxlon,i+1) +C +C* Fill up iy array + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = MAX (1,j-1) + jy(4) = j + jy(5) = j + jy(6) = j + jy(7) = MIN (kylat,j+1) + jy(8) = MIN (kylat,j+1) + jy(9) = MIN (kylat,j+1) +C +C* Correct latitude bounds if southernmost or northernmost points + IF (j .EQ. 1) ideb = 4 + IF (j .EQ. kylat) ifin = 6 +C +C* Account for periodicity in longitude +C + IF (ldper) THEN + IF (i .EQ. kxlon) THEN + ix(3) = 1 + ix(6) = 1 + ix(9) = 1 + ELSE IF (i .EQ. 1) THEN + ix(1) = kxlon + ix(4) = kxlon + ix(7) = kxlon + ENDIF + ELSE + IF (i .EQ. 1) THEN + ix(1) = i + ix(2) = i + 1 + ix(3) = i + ix(4) = i + 1 + ix(5) = i + ix(6) = i + 1 + ENDIF + IF (i .EQ. kxlon) THEN + ix(1) = i -1 + ix(2) = i + ix(3) = i - 1 + ix(4) = i + ix(5) = i - 1 + ix(6) = i + ENDIF +C + IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = j + jy(4) = j + jy(5) = MIN (kylat,j+1) + jy(6) = MIN (kylat,j+1) +C + ideb = 1 + ifin = 6 + IF (j .EQ. 1) ideb = 3 + IF (j .EQ. kylat) ifin = 4 + ENDIF + ENDIF ! end for ldper test +C +C* Find unmasked neighbors +C + DO 230 k = ideb, ifin + zmask(k) = 0. + ilon = ix(k) + jlat = jy(k) + IF (pfild(ilon,jlat) .LT. zwmsk) THEN + zmask(k) = 1. + inbor = inbor + 1 + ENDIF + 230 CONTINUE +C +C* Not enough points around point P are unmasked; interpolation on P +C will be done in a future call to extrap. +C + IF (inbor .GE. knbor) THEN + pwork(i,j) = 0. + DO k = ideb, ifin + ilon = ix(k) + jlat = jy(k) + pwork(i,j) = pwork(i,j) + $ + pfild(ilon,jlat) * zmask(k)/REAL(inbor) + ENDDO + ENDIF +C + ENDIF +99999 CONTINUE +C +C* 3. Writing back unmasked field in pfild +C ------------------------------------ +C +C* pfild then contains: +C - Values which were not masked +C - Interpolated values from the inbor neighbors +C - Values which are not yet interpolated +C + idoit = 0 + DO j = 1, kylat + DO i = 1, kxlon + IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1 + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO +c + IF (idoit .ne. 0) GOTO 200 +ccc PRINT*, "Number of extrapolation steps incre =", incre +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/flumass.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/flumass.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/flumass.F (revision 1634) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , + * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), + * pbarv( ip1jm,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + + REAL SSUM + + + DO 5 l = 1,llm + + DO 1 ij = iip2,ip1jm + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + DO 3 ij = 1,ip1jm + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE + +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + + DO 20 l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + + pbaru( 1 ,l )= pbarv( 1 ,l ) - ctn * aire( 1 ) + pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 ) + + DO 11 i = 2,iim + pbaru( i ,l ) = pbaru( i - 1 ,l ) + + * pbarv( i ,l ) - ctn * aire( i ) + + pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l ) - + * pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm) + 11 CONTINUE + DO 12 i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + 12 CONTINUE + ctn0 = -SSUM( iim,apbarun,1 )/saireun + cts0 = -SSUM( iim,apbarus,1 )/saireus + DO 14 i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + 14 CONTINUE + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + 20 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fluxstokenc.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fluxstokenc.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fluxstokenc.F (revision 1634) @@ -0,0 +1,173 @@ +! +! $Id$ +! + SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, + . time_step,itau ) +#ifdef CPP_IOIPSL +! This routine is designed to work with ioipsl + + USE IOIPSL +c +c Auteur : F. Hourdin +c +c +ccc .. Modif. P. Le Van ( 20/12/97 ) ... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "tracstoke.h" +#include "temps.h" +#include "iniprint.h" + + REAL time_step,t_wrt, t_ops + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL phis(ip1jmp1) + + REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm) + + REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm) + + REAL pbarvst(iip1,jjp1,llm),zistdyn + real dtcum + + INTEGER iadvtr,ndex(1) + integer nscal + real tst(1),ist(1),istp(1) + INTEGER ij,l,irec,i,j,itau + INTEGER, SAVE :: fluxid, fluxvid,fluxdid + + SAVE iadvtr, massem,pbaruc,pbarvc,irec + SAVE phic,tetac + logical first + save first + data first/.true./ + DATA iadvtr/0/ + + +c AC initialisations + pbarug(:,:) = 0. + pbarvg(:,:,:) = 0. + wg(:,:) = 0. + + + if(first) then + + CALL initfluxsto( 'fluxstoke', + . time_step,istdyn* time_step,istdyn* time_step, + . fluxid,fluxvid,fluxdid) + + ndex(1) = 0 + call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex) + call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex) + + ndex(1) = 0 + nscal = 1 + tst(1) = time_step + call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex) + ist(1)=istdyn + call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex) + istp(1)= istphy + call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex) + + first = .false. + + endif + + + IF(iadvtr.EQ.0) THEN + CALL initial0(ijp1llm,phic) + CALL initial0(ijp1llm,tetac) + CALL initial0(ijp1llm,pbaruc) + CALL initial0(ijmllm,pbarvc) + ENDIF + +c accumulation des flux de masse horizontaux + DO l=1,llm + DO ij = 1,ip1jmp1 + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + tetac(ij,l) = tetac(ij,l) + teta(ij,l) + phic(ij,l) = phic(ij,l) + phi(ij,l) + ENDDO + DO ij = 1,ip1jm + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO + +c selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) + ENDIF + + iadvtr = iadvtr+1 + + +c Test pour savoir si on advecte a ce pas de temps + IF ( iadvtr.EQ.istdyn ) THEN +c normalisation + DO l=1,llm + DO ij = 1,ip1jmp1 + pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn) + tetac(ij,l) = tetac(ij,l)/REAL(istdyn) + phic(ij,l) = phic(ij,l)/REAL(istdyn) + ENDDO + DO ij = 1,ip1jm + pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn) + ENDDO + ENDDO + +c traitement des flux de masse avant advection. +c 1. calcul de w +c 2. groupement des mailles pres du pole. + + CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + + do l=1,llm + do j=1,jjm + do i=1,iip1 + pbarvst(i,j,l)=pbarvg(i,j,l) + enddo + enddo + do i=1,iip1 + pbarvst(i,jjp1,l)=0. + enddo + enddo + + iadvtr=0 + write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau + + call histwrite(fluxid, 'masse', itau, massem, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxid, 'pbaru', itau, pbarug, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxvid, 'pbarv', itau, pbarvg, + . iip1*jjm*llm, ndex) + + call histwrite(fluxid, 'w' ,itau, wg, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxid, 'teta' ,itau, tetac, + . iip1*jjp1*llm, ndex) + + call histwrite(fluxid, 'phi' ,itau, phic, + . iip1*jjp1*llm, ndex) + +C + + ENDIF ! if iadvtr.EQ.istdyn + +#else + write(lunout,*) + & 'fluxstokenc: Needs IOIPSL to function' +#endif +! of #ifdef CPP_IOIPSL + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/friction.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/friction.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/friction.F (revision 1634) @@ -0,0 +1,136 @@ +! +! $Id$ +! +c======================================================================= + SUBROUTINE friction(ucov,vcov,pdt) + + USE control_mod +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + IMPLICIT NONE + +!======================================================================= +! +! Friction for the Newtonian case: +! -------------------------------- +! 2 possibilities (depending on flag 'friction_type' +! friction_type=0 : A friction that is only applied to the lowermost +! atmospheric layer +! friction_type=1 : Friction applied on all atmospheric layer (but +! (default) with stronger magnitude near the surface; see +! iniacademic.F) +!======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" +#include "iniprint.h" +#include "academic.h" + +! arguments: + REAL,INTENT(out) :: ucov( iip1,jjp1,llm ) + REAL,INTENT(out) :: vcov( iip1,jjm,llm ) + REAL,INTENT(in) :: pdt ! time step + +! local variables: + + REAL modv(iip1,jjp1),zco,zsi + REAL vpn,vps,upoln,upols,vpols,vpoln + REAL u2(iip1,jjp1),v2(iip1,jjm) + INTEGER i,j,l + REAL,PARAMETER :: cfric=1.e-5 + LOGICAL,SAVE :: firstcall=.true. + INTEGER,SAVE :: friction_type=1 + CHARACTER(len=20) :: modname="friction" + CHARACTER(len=80) :: abort_message + + IF (firstcall) THEN + ! set friction type + call getin("friction_type",friction_type) + if ((friction_type.lt.0).or.(friction_type.gt.1)) then + abort_message="wrong friction type" + write(lunout,*)'Friction: wrong friction type',friction_type + call abort_gcm(modname,abort_message,42) + endif + firstcall=.false. + ENDIF + + if (friction_type.eq.0) then +c calcul des composantes au carre du vent naturel + do j=1,jjp1 + do i=1,iip1 + u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) + enddo + enddo + do j=1,jjm + do i=1,iip1 + v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) + enddo + enddo + +c calcul du module de V en dehors des poles + do j=2,jjm + do i=2,iip1 + modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) + enddo + modv(1,j)=modv(iip1,j) + enddo + +c les deux composantes du vent au pole sont obtenues comme +c premiers modes de fourier de v pres du pole + upoln=0. + vpoln=0. + upols=0. + vpols=0. + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vpn=vcov(i,1,1)/cv(i,1) + vps=vcov(i,jjm,1)/cv(i,jjm) + upoln=upoln+zco*vpn + vpoln=vpoln+zsi*vpn + upols=upols+zco*vps + vpols=vpols+zsi*vps + enddo + vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi + vps=sqrt(upols*upols+vpols*vpols)/pi + do i=1,iip1 +c modv(i,1)=vpn +c modv(i,jjp1)=vps + modv(i,1)=modv(i,2) + modv(i,jjp1)=modv(i,jjm) + enddo + +c calcul du frottement au sol. + do j=2,jjm + do i=1,iim + ucov(i,j,1)=ucov(i,j,1) + s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) + enddo + ucov(iip1,j,1)=ucov(1,j,1) + enddo + do j=1,jjm + do i=1,iip1 + vcov(i,j,1)=vcov(i,j,1) + s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) + enddo + vcov(iip1,j,1)=vcov(1,j,1) + enddo + endif ! of if (friction_type.eq.0) + + if (friction_type.eq.1) then + do l=1,llm + ucov(:,:,l)=ucov(:,:,l)*(1.-pdt*kfrict(l)) + vcov(:,:,l)=vcov(:,:,l)*(1.-pdt*kfrict(l)) + enddo + endif + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxhyp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxhyp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxhyp.F (revision 1634) @@ -0,0 +1,448 @@ +! +! $Id$ +! +c +c + SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau , + , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025, + , champmin,champmax ) + +c Auteur : P. Le Van + + IMPLICIT NONE + +c Calcule les longitudes et derivees dans la grille du GCM pour une +c fonction f(x) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.) +c dzoom etant la distance totale de la zone du zoom +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c On doit avoir grossism x dzoom < pi ( radians ) , en longitude. +c ******************************************************************** + + + INTEGER nmax, nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c + LOGICAL scal180 + PARAMETER ( scal180 = .TRUE. ) + +c scal180 = .TRUE. si on veut avoir le premier point scalaire pour +c une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres. +c sinon scal180 = .FALSE. + +#include "dimensions.h" +#include "paramet.h" + +c ...... arguments d'entree ....... +c + REAL xzoomdeg,dzooma,tau,grossism + +c ...... arguments de sortie ...... + + REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1), + , rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1) + +c .... variables locales .... +c + REAL dzoom + REAL(KIND=8) xlon(iip1),xprimm(iip1),xuv + REAL(KIND=8) xtild(0:nmax2) + REAL(KIND=8) fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2) + REAL(KIND=8) Xf(0:nmax2),xxpr(0:nmax2) + REAL(KIND=8) xvrai(iip1),xxprim(iip1) + REAL(KIND=8) pi,depi,epsilon,xzoom,fa,fb + REAL(KIND=8) Xf1, Xfi , a0,a1,a2,a3,xi2 + INTEGER i,it,ik,iter,ii,idif,ii1,ii2 + REAL(KIND=8) xi,xo1,xmoy,xlon2,fxm,Xprimin + REAL(KIND=8) champmin,champmax,decalx + INTEGER is2 + SAVE is2 + + REAL(KIND=8) heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + epsilon = 1.e-3 + xzoom = xzoomdeg * pi/180. +c + decalx = .75 + IF( grossism.EQ.1..AND.scal180 ) THEN + decalx = 1. + ENDIF + + WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx +c + IF( dzooma.LT.1.) THEN + dzoom = dzooma * depi + ELSEIF( dzooma.LT. 25. ) THEN + WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) xzoom,grossism,tau,dzoom + + DO i = 0, nmax2 + xtild(i) = - pi + REAL(i) * depi /nmax2 + ENDDO + + DO i = nmax, nmax2 + + fa = tau* ( dzoom/2. - xtild(i) ) + fb = xtild(i) * ( pi - xtild(i) ) + + IF( 200.* fb .LT. - fa ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fhyp ( i) = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fhyp ( i ) = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fhyp ( i ) = 1. + ENDIF + ELSE + fhyp ( i ) = TANH ( fa/fb ) + ENDIF + ENDIF + IF ( xtild(i).EQ. 0. ) fhyp(i) = 1. + IF ( xtild(i).EQ. pi ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... + + ffdx = 0. + + DO i = nmax +1,nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fxm = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fxm = 1. + ENDIF + ELSE + fxm = TANH ( fa/fb ) + ENDIF + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + + ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) ) + + ENDDO + + beta = ( grossism * ffdx - pi ) / ( ffdx - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fxhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismx ,tau ou dzoomx ', + , ' et relancer ! *** ' + CALL ABORT + ENDIF +c +c ..... calcul de Xprimt ..... +c + + DO i = nmax, nmax2 + Xprimt(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO +c + DO i = nmax+1, nmax2 + Xprimt( nmax2 - i ) = Xprimt( i ) + ENDDO +c + +c ..... Calcul de Xf ........ + + Xf(0) = - pi + + DO i = nmax +1, nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + fxm = TANH ( fa/fb ) + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + xxpr(i) = beta + ( grossism - beta ) * fxm + + ENDDO + + DO i = nmax+1, nmax2 + xxpr(nmax2-i+1) = xxpr(i) + ENDDO + + DO i=1,nmax2 + Xf(i) = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) ) + ENDDO + + +c ***************************************************************** +c + +c ..... xuv = 0. si calcul aux pts scalaires ........ +c ..... xuv = 0.5 si calcul aux pts U ........ +c + WRITE(6,18) +c + DO 5000 ik = 1, 4 + + IF( ik.EQ.1 ) THEN + xuv = -0.25 + ELSE IF ( ik.EQ.2 ) THEN + xuv = 0. + ELSE IF ( ik.EQ.3 ) THEN + xuv = 0.50 + ELSE IF ( ik.EQ.4 ) THEN + xuv = 0.25 + ENDIF + + xo1 = 0. + + ii1=1 + ii2=iim + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + ii1 = 2 + ii2 = iim+1 + ENDIF + DO 1500 i = ii1, ii2 + + xlon2 = - pi + (REAL(i) + xuv - decalx) * depi / REAL(iim) + + Xfi = xlon2 +c + DO 250 it = nmax2,0,-1 + IF( Xfi.GE.Xf(it)) GO TO 350 +250 CONTINUE + + it = 0 + +350 CONTINUE + +c ...... Calcul de Xf(xi) ...... +c + xi = xtild(it) + + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Xf(it+1) = pi + ENDIF +c ..................................................................... +c +c Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un +c polynome de degre 3 qui passe par les points (Xf(it),xtild(it) ) +c et (Xf(it+1),xtild(it+1) ) + + CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1), + , xtild(it),xtild(it+1), a0, a1, a2, a3 ) + + Xf1 = Xf(it) + Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi + + DO 500 iter = 1,300 + xi = xi - ( Xf1 - Xfi )/ Xprimin + + IF( ABS(xi-xo1).LE.epsilon) GO TO 550 + xo1 = xi + xi2 = xi * xi + Xf1 = a0 + a1 * xi + a2 * xi2 + a3 * xi2 * xi + Xprimin = a1 + 2.* a2 * xi + 3.* a3 * xi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter + STOP 6 +550 CONTINUE + + xxprim(i) = depi/ ( REAL(iim) * Xprimin ) + xvrai(i) = xi + xzoom + +1500 CONTINUE + + + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + xvrai(1) = xvrai(iip1)-depi + xxprim(1) = xxprim(iip1) + ENDIF + DO i = 1 , iim + xlon(i) = xvrai(i) + xprimm(i) = xxprim(i) + ENDDO + DO i = 1, iim -1 + IF( xvrai(i+1). LT. xvrai(i) ) THEN + WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i, + , ')' + STOP 7 + ENDIF + ENDDO +c +c ... Reorganisation des longitudes pour les avoir entre - pi et pi .. +c ........................................................................ + + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin,xvrai(i) ) + champmax = MAX( champmax,xvrai(i) ) + ENDDO + + IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 ) THEN + GO TO 1600 + ELSE + WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi', + , ' et pi ' +c + IF( xzoom.LE.0.) THEN + IF( ik.EQ. 1 ) THEN + DO i = 1, iim + IF( xvrai(i).GE. - pi ) GO TO 80 + ENDDO + WRITE(6,*) ' PBS. 1 ! Xvrai plus petit que - pi ! ' + STOP 8 + 80 CONTINUE + is2 = i + ENDIF + + IF( is2.NE. 1 ) THEN + DO ii = is2 , iim + xlon (ii-is2+1) = xvrai(ii) + xprimm(ii-is2+1) = xxprim(ii) + ENDDO + DO ii = 1 , is2 -1 + xlon (ii+iim-is2+1) = xvrai(ii) + depi + xprimm(ii+iim-is2+1) = xxprim(ii) + ENDDO + ENDIF + ELSE + IF( ik.EQ.1 ) THEN + DO i = iim,1,-1 + IF( xvrai(i).LE. pi ) GO TO 90 + ENDDO + WRITE(6,*) ' PBS. 2 ! Xvrai plus grand que pi ! ' + STOP 9 + 90 CONTINUE + is2 = i + ENDIF + idif = iim -is2 + DO ii = 1, is2 + xlon (ii+idif) = xvrai(ii) + xprimm(ii+idif) = xxprim(ii) + ENDDO + DO ii = 1, idif + xlon (ii) = xvrai (ii+is2) - depi + xprimm(ii) = xxprim(ii+is2) + ENDDO + ENDIF + ENDIF +c +c ......... Fin de la reorganisation ............................ + + 1600 CONTINUE + + + xlon ( iip1) = xlon(1) + depi + xprimm( iip1 ) = xprimm (1 ) + + DO i = 1, iim+1 + xvrai(i) = xlon(i)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,*) ' XLON aux pts. V-0.25 apres ( en deg. ) ' +c WRITE(6,18) +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim +1 + rlonm025(i) = xlon( i ) + xprimm025(i) = xprimm(i) + ENDDO + ELSE IF( ik.EQ.2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonv(i) = xlon( i ) + xprimv(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.3) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. U apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonu(i) = xlon( i ) + xprimu(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V+0.25 apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonp025(i) = xlon( i ) + xprimp025(i) = xprimm(i) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ........... fin de la boucle do 5000 ............ + + DO i = 1, iim + xlon(i) = rlonv(i+1) - rlonv(i) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin, xlon(i) ) + champmax = MAX( champmax, xlon(i) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +18 FORMAT(/) +24 FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3) +68 FORMAT(1x,7f9.2) +566 FORMAT(1x,7f9.4) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxy.F (revision 1634) @@ -0,0 +1,69 @@ +! +! $Id$ +! + SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE + +c Auteur : P. Le Van +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c a tangente sinusoidale et eventuellement avec zoom . +c +c +#include "dimensions.h" +#include "paramet.h" +#include "serre.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_new.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( REAL( j ) ) + yprimu(j) = fyprim( REAL( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( REAL( j ) + 0.5 ) + rlatu1(j) = fy ( REAL( j ) + 0.25 ) + rlatu2(j) = fy ( REAL( j ) + 0.75 ) + + yprimv(j) = fyprim( REAL( j ) + 0.5 ) + yprimu1(j) = fyprim( REAL( j ) + 0.25 ) + yprimu2(j) = fyprim( REAL( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( REAL( i ) ) + rlonu(i) = fx ( REAL( i ) + 0.5 ) + rlonm025(i) = fx ( REAL( i ) - 0.25 ) + rlonp025(i) = fx ( REAL( i ) + 0.25 ) + + xprimv (i) = fxprim ( REAL( i ) ) + xprimu (i) = fxprim ( REAL( i ) + 0.5 ) + xprimm025(i) = fxprim ( REAL( i ) - 0.25 ) + xprimp025(i) = fxprim ( REAL( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxyhyper.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxyhyper.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxyhyper.F (revision 1634) @@ -0,0 +1,139 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy , + , xzoom, grossx, dzoomx,taux , + , rlatu,yprimu,rlatv,yprimv,rlatu1, yprimu1, rlatu2, yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE +c +c Auteur : P. Le Van . +c +c d'apres formulations de R. Sadourny . +c +c +c Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp ) +c par des fonctions a tangente hyperbolique . +c +c Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom +c et yzoom ) : +c +c a) le grossissement du zoom : grossy ( en y ) et grossx ( en x ) +c b) l' extension du zoom : dzoomy ( en y ) et dzoomx ( en x ) +c c) la raideur de la transition du zoom : taux et tauy +c +c N.B : Il vaut mieux avoir : grossx * dzoomx < pi ( radians ) +c ****** +c et grossy * dzoomy < pi/2 ( radians ) +c +#include "dimensions.h" +#include "paramet.h" + + +c ..... Arguments ... +c + REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + REAL(KIND=8) dxmin, dxmax , dymin, dymax + +c .... var. locales ..... +c + INTEGER i,j +c + + CALL fyhyp ( yzoom, grossy, dzoomy,tauy , + , rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , dymin,dymax ) + + CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv, + , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax ) + + + DO i = 1, iip1 + IF(rlonp025(i).LT.rlonv(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 < rlonv',i + STOP + ENDIF + + IF(rlonv(i).LT.rlonm025(i)) THEN + WRITE(6,*) ' Attention ! rlonm025 > rlonv',i + STOP + ENDIF + + IF(rlonp025(i).GT.rlonu(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 > rlonu',i + STOP + ENDIF + ENDDO + + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FX **** ' + +c + DO j = 1, jjm +c + IF(rlatu1(j).LE.rlatu2(j)) THEN + WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j + STOP 13 + ENDIF +c + IF(rlatu2(j).LE.rlatu(j+1)) THEN + WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j + STOP 14 + ENDIF +c + IF(rlatu(j).LE.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j + STOP 15 + ENDIF +c + IF(rlatv(j).LE.rlatu2(j)) THEN + WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j + STOP 16 + ENDIF +c + IF(rlatv(j).ge.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j + STOP 17 + ENDIF +c + IF(rlatv(j).ge.rlatu(j)) THEN + WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j + STOP 18 + ENDIF +c + ENDDO +c + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FY **** ' +c + WRITE(6,18) + WRITE(6,*) ' Latitudes ' + WRITE(6,*) ' *********** ' + WRITE(6,18) + WRITE(6,3) dymin, dymax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' +c + WRITE(6,18) + WRITE(6,*) ' Longitudes ' + WRITE(6,*) ' ************ ' + WRITE(6,18) + WRITE(6,3) dxmin, dxmax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' + WRITE(6,18) +c +3 Format(1x, ' Au centre du zoom , la longueur de la maille est', + , ' d environ ',f8.2 ,' degres ', + , ' alors que la maille en dehors de la zone du zoom est d environ + , ', f8.2,' degres ' ) +18 FORMAT(/) + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxysinus.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxysinus.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fxysinus.F (revision 1634) @@ -0,0 +1,69 @@ +! +! $Id$ +! + SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + + IMPLICIT NONE +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c avec y = Asin( j ) . +c +c Auteur : P. Le Van +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_sin.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( REAL( j ) ) + yprimu(j) = fyprim( REAL( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( REAL( j ) + 0.5 ) + rlatu1(j) = fy ( REAL( j ) + 0.25 ) + rlatu2(j) = fy ( REAL( j ) + 0.75 ) + + yprimv(j) = fyprim( REAL( j ) + 0.5 ) + yprimu1(j) = fyprim( REAL( j ) + 0.25 ) + yprimu2(j) = fyprim( REAL( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( REAL( i ) ) + rlonu(i) = fx ( REAL( i ) + 0.5 ) + rlonm025(i) = fx ( REAL( i ) - 0.25 ) + rlonp025(i) = fx ( REAL( i ) + 0.25 ) + + xprimv (i) = fxprim ( REAL( i ) ) + xprimu (i) = fxprim ( REAL( i ) + 0.5 ) + xprimm025(i) = fxprim ( REAL( i ) - 0.25 ) + xprimp025(i) = fxprim ( REAL( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fyhyp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fyhyp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/fyhyp.F (revision 1634) @@ -0,0 +1,378 @@ +! +! $Id$ +! +c +c + SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau , + , rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , champmin,champmax ) + +cc ... Version du 01/04/2001 .... + + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c ....... d'apres formulations de R. Sadourny ....... +c +c Calcule les latitudes et derivees dans la grille du GCM pour une +c fonction f(y) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc) +c dzoom etant la distance totale de la zone du zoom ( en radians ) +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c +c N.B : Il vaut mieux avoir : grossism * dzoom < pi/2 (radians) ,en lati. +c ******************************************************************** +c +c +#include "dimensions.h" +#include "paramet.h" + + INTEGER nmax , nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c +c +c ....... arguments d'entree ....... +c + REAL yzoomdeg, grossism,dzooma,tau +c ( rentres par run.def ) + +c ....... arguments de sortie ....... +c + REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + +c +c ..... champs locaux ..... +c + + REAL dzoom + REAL(KIND=8) ylat(jjp1), yprim(jjp1) + REAL(KIND=8) yuv + REAL(KIND=8) yt(0:nmax2) + REAL(KIND=8) fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2) + SAVE Ytprim, yt,Yf + REAL(KIND=8) Yf(0:nmax2),yypr(0:nmax2) + REAL(KIND=8) yvrai(jjp1), yprimm(jjp1),ylatt(jjp1) + REAL(KIND=8) pi,depi,pis2,epsilon,y0,pisjm + REAL(KIND=8) yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax + REAL(KIND=8) yfi,Yf1,ffdy + REAL(KIND=8) ypn,deply,y00 + SAVE y00, deply + + INTEGER i,j,it,ik,iter,jlat + INTEGER jpn,jjpn + SAVE jpn + REAL(KIND=8) a0,a1,a2,a3,yi2,heavyy0,heavyy0m + REAL(KIND=8) fa(0:nmax2),fb(0:nmax2) + REAL y0min,y0max + + REAL(KIND=8) heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + pis2 = pi/2. + pisjm = pi/ REAL(jjm) + epsilon = 1.e-3 + y0 = yzoomdeg * pi/180. + + IF( dzooma.LT.1.) THEN + dzoom = dzooma * pi + ELSEIF( dzooma.LT. 12. ) THEN + WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,18) + WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) y0,grossism,tau,dzoom + + DO i = 0, nmax2 + yt(i) = - pis2 + REAL(i)* pi /nmax2 + ENDDO + + heavyy0m = heavyside( -y0 ) + heavyy0 = heavyside( y0 ) + y0min = 2.*y0*heavyy0m - pis2 + y0max = 2.*y0*heavyy0 + pis2 + + fa = 999.999 + fb = 999.999 + + DO i = 0, nmax2 + IF( yt(i).LT.y0 ) THEN + fa (i) = tau* (yt(i)-y0+dzoom/2. ) + fb(i) = (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) ) + ELSEIF ( yt(i).GT.y0 ) THEN + fa(i) = tau *(y0-yt(i)+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fhyp ( i) = 1. + ELSE + fhyp(i) = TANH ( fa(i)/fb(i) ) + ENDIF + + IF( yt(i).EQ.y0 ) fhyp(i) = 1. + IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... +c + ffdy = 0. + + DO i = 1, nmax2 + ymoy = 0.5 * ( yt(i-1) + yt( i ) ) + IF( ymoy.LT.y0 ) THEN + fa(i)= tau * ( ymoy-y0+dzoom/2.) + fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy ) + ELSEIF ( ymoy.GT.y0 ) THEN + fa(i)= tau * ( y0-ymoy+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fxm ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fxm ( i) = 1. + ELSE + fxm(i) = TANH ( fa(i)/fb(i) ) + ENDIF + IF( ymoy.EQ.y0 ) fxm(i) = 1. + IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1. + ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) ) + + ENDDO + + beta = ( grossism * ffdy - pi ) / ( ffdy - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fyhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismy ,tauy ou dzoomy', + , ' et relancer ! *** ' + CALL ABORT + + ENDIF +c +c ..... calcul de Ytprim ..... +c + + DO i = 0, nmax2 + Ytprim(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO + +c ..... Calcul de Yf ........ + + Yf(0) = - pis2 + DO i = 1, nmax2 + yypr(i) = beta + ( grossism - beta ) * fxm(i) + ENDDO + + DO i=1,nmax2 + Yf(i) = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) ) + ENDDO + +c **************************************************************** +c +c ..... yuv = 0. si calcul des latitudes aux pts. U ..... +c ..... yuv = 0.5 si calcul des latitudes aux pts. V ..... +c + WRITE(6,18) +c + DO 5000 ik = 1,4 + + IF( ik.EQ.1 ) THEN + yuv = 0. + jlat = jjm + 1 + ELSE IF ( ik.EQ.2 ) THEN + yuv = 0.5 + jlat = jjm + ELSE IF ( ik.EQ.3 ) THEN + yuv = 0.25 + jlat = jjm + ELSE IF ( ik.EQ.4 ) THEN + yuv = 0.75 + jlat = jjm + ENDIF +c + yo1 = 0. + DO 1500 j = 1,jlat + yo1 = 0. + ylon2 = - pis2 + pisjm * ( REAL(j) + yuv -1.) + yfi = ylon2 +c + DO 250 it = nmax2,0,-1 + IF( yfi.GE.Yf(it)) GO TO 350 +250 CONTINUE + it = 0 +350 CONTINUE + + yi = yt(it) + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Yf(it+1) = pis2 + ENDIF +c ................................................................. +c .... Interpolation entre yi(it) et yi(it+1) pour avoir Y(yi) +c ..... et Y'(yi) ..... +c ................................................................. + + CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1), + , yt(it),yt(it+1) , a0,a1,a2,a3 ) + + Yf1 = Yf(it) + Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi + + DO 500 iter = 1,300 + yi = yi - ( Yf1 - yfi )/ Yprimin + + IF( ABS(yi-yo1).LE.epsilon) GO TO 550 + yo1 = yi + yi2 = yi * yi + Yf1 = a0 + a1 * yi + a2 * yi2 + a3 * yi2 * yi + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter + STOP 2 +550 CONTINUE +c + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi* yi + yprim(j) = pi / ( jjm * Yprimin ) + yvrai(j) = yi + +1500 CONTINUE + + DO j = 1, jlat -1 + IF( yvrai(j+1). LT. yvrai(j) ) THEN + WRITE(6,*) ' PBS. avec rlat(',j+1,') plus petit que rlat(',j, + , ')' + STOP 3 + ENDIF + ENDDO + + WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2' + , ,' et pi/2 ' +c + IF( ik.EQ.1 ) THEN + ypn = pis2 + DO j = jlat,1,-1 + IF( yvrai(j).LE. ypn ) GO TO 1502 + ENDDO +1502 CONTINUE + + jpn = j + y00 = yvrai(jpn) + deply = pis2 - y00 + ENDIF + + DO j = 1, jjm +1 - jpn + ylatt (j) = -pis2 - y00 + yvrai(jpn+j-1) + yprimm(j) = yprim(jpn+j-1) + ENDDO + + jjpn = jpn + IF( jlat.EQ. jjm ) jjpn = jpn -1 + + DO j = 1,jjpn + ylatt (j + jjm+1 -jpn) = yvrai(j) + deply + yprimm(j + jjm+1 -jpn) = yprim(j) + ENDDO + +c *********** Fin de la reorganisation ************* +c + 1600 CONTINUE + + DO j = 1, jlat + ylat(j) = ylatt( jlat +1 -j ) + yprim(j) = yprimm( jlat +1 -j ) + ENDDO + + DO j = 1, jlat + yvrai(j) = ylat(j)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatu(j) = ylat( j ) + yyprimu(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en V apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*)' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatv(j) = ylat( j ) + yyprimv(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 3 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.75 apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu2(j) = ylat( j ) + yprimu2(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.25 apres ( en deg. ) ' +c WRITE(6,68)(yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,68) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu1(j) = ylat( j ) + yprimu1(j) = yprim( j ) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ..... fin de la boucle do 5000 ..... + + DO j = 1, jjm + ylat(j) = rrlatu(j) - rrlatu(j+1) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO j = 1, jjm + champmin = MIN( champmin, ylat(j) ) + champmax = MAX( champmax, ylat(j) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +24 FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3) +18 FORMAT(/) +68 FORMAT(1x,7f9.2) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gcm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gcm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gcm.F (revision 1634) @@ -0,0 +1,522 @@ +! +! $Id$ +! +c +c + PROGRAM gcm + +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + USE filtreg_mod + USE infotrac + USE control_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! A nettoyer. On ne veut qu'une ou deux routines d'interface +! dynamique -> physique pour l'initialisation +! Ehouarn: for now these only apply to Earth: +#ifdef CPP_EARTH + USE dimphy + USE comgeomphy + USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb +#endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. +c ... Possibilite de choisir le schema pour l'advection de +c q , en modifiant iadv dans traceur.def (MAF,10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +!!!!!!!!!!!#include "control.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +!#include "com_io_dyn.h" +#include "iniprint.h" +#include "tracstoke.h" +#ifdef INCA +! Only INCA needs these informations (from the Earth's physics) +#include "indicesol.h" +#endif + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + SAVE clesphy0 + + + + REAL zdtvr + INTEGER nbetatmoy, nbetatdem,nbetat + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL time_0 + + LOGICAL lafin + INTEGER ij,iq,l,i,j + + + real time_step, t_wrt, t_ops + + LOGICAL first + + LOGICAL call_iniphys + data call_iniphys/.true./ + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) +c+jld variables test conservation energie +c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation + REAL dhecdt(ip1jmp1,llm) +c REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) +c REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER (len=15) :: ztit +c-jld + + + character (len=80) :: dynhist_file, dynhistave_file + character (len=20) :: modname + character (len=80) :: abort_message +! locales pour gestion du temps + INTEGER :: an, mois, jour + REAL :: heure + + +c----------------------------------------------------------------------- +c variables pour l'initialisation de la physique : +c ------------------------------------------------ + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + REAL zcufi(ngridmx),zcvfi(ngridmx) + REAL latfi(ngridmx),lonfi(ngridmx) + REAL airefi(ngridmx) + SAVE latfi, lonfi, airefi + +c----------------------------------------------------------------------- +c Initialisations: +c ---------------- + + abort_message = 'last timestep reached' + modname = 'gcm' + descript = 'Run GCM LMDZ' + lafin = .FALSE. + dynhist_file = 'dyn_hist.nc' + dynhistave_file = 'dyn_hist_ave.nc' + + + +c---------------------------------------------------------------------- +c lecture des fichiers gcm.def ou run.def +c --------------------------------------- +c +! Ehouarn: dump possibility of using defrun +!#ifdef CPP_IOIPSL + CALL conf_gcm( 99, .TRUE. , clesphy0 ) +!#else +! CALL defrun( 99, .TRUE. , clesphy0 ) +!#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/02 +! A nettoyer. On ne veut qu'une ou deux routines d'interface +! dynamique -> physique pour l'initialisation +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/)) + call InitComgeomphy +#endif + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c----------------------------------------------------------------------- +c Choix du calendrier +c ------------------- + +c calend = 'earth_365d' + +#ifdef CPP_IOIPSL + if (calend == 'earth_360d') then + call ioconf_calendar('360d') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an' + else if (calend == 'earth_365d') then + call ioconf_calendar('noleap') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an' + else if (calend == 'earth_366d') then + call ioconf_calendar('gregorian') + write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile' + else + abort_message = 'Mauvais choix de calendrier' + call abort_gcm(modname,abort_message,1) + endif +#endif +c----------------------------------------------------------------------- + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz(nbtr,anneeref,dayref,iphysiq,day_step,nday, + $ nbsrf, is_oce,is_sic,is_ter,is_lic) + call init_inca_para(iim,jjm+1,klon,1,klon_mpi_para_nb,0) +#endif + END IF +c +c +c------------------------------------ +c Initialisation partie parallele +c------------------------------------ + +c +c +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l'advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + allocate(q(ip1jmp1,llm,nqtot)) + +c----------------------------------------------------------------------- +c Lecture de l'etat initial : +c --------------------------- + +c lecture du fichier start.nc + if (read_start) then + ! we still need to run iniacademic to initialize some + ! constants & fields, if we run the 'newtonian' or 'SW' cases: + if (iflag_phys.ne.1) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif + +! if (planet_type.eq."earth") then +! Load an Earth-format start file + CALL dynetat0("start.nc",vcov,ucov, + & teta,q,masse,ps,phis, time_0) +! endif ! of if (planet_type.eq."earth") + +c write(73,*) 'ucov',ucov +c write(74,*) 'vcov',vcov +c write(75,*) 'teta',teta +c write(76,*) 'ps',ps +c write(77,*) 'q',q + + endif ! of if (read_start) + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_inca_dim(klon,llm,iim,jjm, + $ rlonu,rlatu,rlonv,rlatv) +#endif + END IF + + +c le cas echeant, creation d un etat initial + IF (prt_level > 9) WRITE(lunout,*) + . 'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT' + if (.not.read_start) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif + + +c----------------------------------------------------------------------- +c Lecture des parametres de controle pour la simulation : +c ------------------------------------------------------- +c on recalcule eventuellement le pas de temps + + IF(MOD(day_step,iperiod).NE.0) THEN + abort_message = + . 'Il faut choisir un nb de pas par jour multiple de iperiod' + call abort_gcm(modname,abort_message,1) + ENDIF + + IF(MOD(day_step,iphysiq).NE.0) THEN + abort_message = + * 'Il faut choisir un nb de pas par jour multiple de iphysiq' + call abort_gcm(modname,abort_message,1) + ENDIF + + zdtvr = daysec/REAL(day_step) + IF(dtvr.NE.zdtvr) THEN + WRITE(lunout,*) + . 'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr + ENDIF + +C +C on remet le calendrier à zero si demande +c + IF (raz_date == 1) THEN + annee_ref = anneeref + day_ref = dayref + day_ini = dayref + itau_dyn = 0 + itau_phy = 0 + time_0 = 0. + write(lunout,*) + . 'GCM: On reinitialise a la date lue dans gcm.def' + ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN + write(lunout,*) + . 'GCM: Attention les dates initiales lues dans le fichier' + write(lunout,*) + . ' restart ne correspondent pas a celles lues dans ' + write(lunout,*)' gcm.def' + write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref + write(lunout,*)' day_ref=',day_ref," dayref=",dayref + write(lunout,*)' Pas de remise a zero' + ENDIF + +c if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then +c write(lunout,*) +c . 'GCM: Attention les dates initiales lues dans le fichier' +c write(lunout,*) +c . ' restart ne correspondent pas a celles lues dans ' +c write(lunout,*)' gcm.def' +c write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref +c write(lunout,*)' day_ref=',day_ref," dayref=",dayref +c if (raz_date .ne. 1) then +c write(lunout,*) +c . 'GCM: On garde les dates du fichier restart' +c else +c annee_ref = anneeref +c day_ref = dayref +c day_ini = dayref +c itau_dyn = 0 +c itau_phy = 0 +c time_0 = 0. +c write(lunout,*) +c . 'GCM: On reinitialise a la date lue dans gcm.def' +c endif +c ELSE +c raz_date = 0 +c endif + +#ifdef CPP_IOIPSL + mois = 1 + heure = 0. + call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref) + jH_ref = jD_ref - int(jD_ref) + jD_ref = int(jD_ref) + + call ioconf_startdate(INT(jD_ref), jH_ref) + + write(lunout,*)'DEBUG' + write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref' + write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref + call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure) + write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure' + write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure +#else +! Ehouarn: we still need to define JD_ref and JH_ref +! and since we don't know how many days there are in a year +! we set JD_ref to 0 (this should be improved ...) + jD_ref=0 + jH_ref=0 +#endif + +c nombre d'etats dans les fichiers demarrage et histoire + nbetatdem = nday / iecri + nbetatmoy = nday / periodav + 1 + + if (iflag_phys.eq.1) then + ! these initialisations have already been done (via iniacademic) + ! if running in SW or Newtonian mode +c----------------------------------------------------------------------- +c Initialisation des constantes dynamiques : +c ------------------------------------------ + dtvr = zdtvr + CALL iniconst + +c----------------------------------------------------------------------- +c Initialisation de la geometrie : +c -------------------------------- + CALL inigeom + +c----------------------------------------------------------------------- +c Initialisation du filtre : +c -------------------------- + CALL inifilr + endif ! of if (iflag_phys.eq.1) +c +c----------------------------------------------------------------------- +c Initialisation de la dissipation : +c ---------------------------------- + + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + +c----------------------------------------------------------------------- +c Initialisation de la physique : +c ------------------------------- + + IF (call_iniphys.and.(iflag_phys==1.or.iflag_phys>=100)) THEN + latfi(1)=rlatu(1) + lonfi(1)=0. + zcufi(1) = cu(1) + zcvfi(1) = cv(1) + DO j=2,jjm + DO i=1,iim + latfi((j-2)*iim+1+i)= rlatu(j) + lonfi((j-2)*iim+1+i)= rlonv(i) + zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i) + zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i) + ENDDO + ENDDO + latfi(ngridmx)= rlatu(jjp1) + lonfi(ngridmx)= 0. + zcufi(ngridmx) = cu(ip1jm+1) + zcvfi(ngridmx) = cv(ip1jm-iim) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi) + WRITE(lunout,*) + . 'GCM: WARNING!!! vitesse verticale nulle dans la physique' +! Earth: + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys , + , latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp ) +#endif + endif ! of if (planet_type.eq."earth") + call_iniphys=.false. + ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1)) +!#endif + +c numero de stockage pour les fichiers de redemarrage: + +c----------------------------------------------------------------------- +c Initialisation des I/O : +c ------------------------ + + + day_end = day_ini + nday + WRITE(lunout,300)day_ini,day_end + 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//) + +#ifdef CPP_IOIPSL + call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure) + write (lunout,301)jour, mois, an + call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure) + write (lunout,302)jour, mois, an + 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4) + 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4) +#endif + +#ifdef CPP_EARTH +! Create start file (startphy.nc) and boundary conditions (limit.nc) +! for the Earth verstion + if (iflag_phys>=100) then + call iniaqua(ngridmx,latfi,lonfi,iflag_phys) + endif +#endif + +! if (planet_type.eq."earth") then +! Write an Earth-format restart file + + CALL dynredem0("restart.nc", day_end, phis) +! endif + + ecripar = .TRUE. + +#ifdef CPP_IOIPSL + time_step = zdtvr + if (ok_dyn_ins) then + ! initialize output file for instantaneous outputs + ! t_ops = iecri * daysec ! do operations every t_ops + t_ops =((1.0*iecri)/day_step) * daysec + t_wrt = daysec ! iecri * daysec ! write output every t_wrt + CALL inithist(day_ref,annee_ref,time_step, + & t_ops,t_wrt) + endif + + IF (ok_dyn_ave) THEN + ! initialize output file for averaged outputs + t_ops = iperiod * time_step ! do operations every t_ops + t_wrt = periodav * daysec ! write output every t_wrt + CALL initdynav(day_ref,annee_ref,time_step, + & t_ops,t_wrt) + END IF + dtav = iperiod*dtvr/daysec +#endif +! #endif of #ifdef CPP_IOIPSL + +c Choix des frequences de stokage pour le offline +c istdyn=day_step/4 ! stockage toutes les 6h=1jour/4 +c istdyn=day_step/12 ! stockage toutes les 2h=1jour/12 + istdyn=day_step/4 ! stockage toutes les 6h=1jour/12 + istphy=istdyn/iphysiq + + +c +c----------------------------------------------------------------------- +c Integration temporelle du modele : +c ---------------------------------- + +c write(78,*) 'ucov',ucov +c write(78,*) 'vcov',vcov +c write(78,*) 'teta',teta +c write(78,*) 'ps',ps +c write(78,*) 'q',q + + + CALL leapfrog(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + . time_0) + + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/geopot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/geopot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/geopot.F (revision 1634) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + + DO 1 ij = 1, ngrid + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + 1 CONTINUE + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = 1,ngrid + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/getparam.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/getparam.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/getparam.F90 (revision 1634) @@ -0,0 +1,106 @@ +! +! $Id$ +! +MODULE getparam +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + INTERFACE getpar + MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml + END INTERFACE + + INTEGER, PARAMETER :: out_eff=99 + +CONTAINS + SUBROUTINE ini_getparam(fichier) + ! + IMPLICIT NONE + ! + CHARACTER*(*) :: fichier + open(out_eff,file=fichier,status='unknown',form='formatted') + END SUBROUTINE ini_getparam + + SUBROUTINE fin_getparam + ! + IMPLICIT NONE + ! + close(out_eff) + + END SUBROUTINE fin_getparam + + SUBROUTINE getparamr(TARGET,def_val,ret_val,comment) + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + REAL :: def_val + REAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + + END SUBROUTINE getparamr + + SUBROUTINE getparami(TARGET,def_val,ret_val,comment) + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + INTEGER :: def_val + INTEGER :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) comment + write(out_eff,*) TARGET,'=',ret_val + + END SUBROUTINE getparami + + SUBROUTINE getparaml(TARGET,def_val,ret_val,comment) + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + LOGICAL :: def_val + LOGICAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + + END SUBROUTINE getparaml + + +END MODULE getparam Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_dyn_fi.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_dyn_fi.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_dyn_fi.F (revision 1634) @@ -0,0 +1,38 @@ +! +! $Header$ +! + SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles + CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid) + CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid) + +c traitement des point normaux + DO ifield=1,nfield + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_ecrit_fi.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_ecrit_fi.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_ecrit_fi.F (revision 1634) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi) + + IMPLICIT none + +c Transformer une variable de la grille d'ecriture a la grille physique + + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield) +c + INTEGER i, j, n, ig +c +c print*,'iim jjm ',iim,jjm + +c modif par abd 21 02 01 + + jjm = jjmp1 - 1 + do n = 1, nfield + fi(1,n) = ecrit(1,1,n) + fi(nlon,n) = ecrit(1,jjm+1,n) + DO j = 2, jjm + ig = 2+(j-2)*iim + DO i = 1, iim + fi(ig-1+i,n) = ecrit(i,j,n) + ENDDO + ENDDO + ENDDO + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_fi_dyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_fi_dyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_fi_dyn.F (revision 1634) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + DO ifield=1,nfield +c traitement des poles + DO i=1,im + pdyn(i,1,ifield)=pfi(1,ifield) + pdyn(i,jm,ifield)=pfi(ngrid,ifield) + ENDDO + +c traitement des point normaux + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1) + pdyn(im,j,ifield)=pdyn(1,j,ifield) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_int_dyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_int_dyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_int_dyn.F (revision 1634) @@ -0,0 +1,49 @@ +! +! $Header$ +! + subroutine gr_int_dyn(champin,champdyn,iim,jp1) + implicit none +c======================================================================= +c passage d'un champ interpole a un champ sur grille scalaire +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER iim + integer ip1, jp1 + REAL champin(iim, jp1) + REAL champdyn(iim+1, jp1) + + INTEGER i, j + real polenord, polesud + +c----------------------------------------------------------------------- +c calcul: +c ------- + + ip1 = iim + 1 + polenord = 0. + polesud = 0. + do i = 1, iim + polenord = polenord + champin (i, 1) + polesud = polesud + champin (i, jp1) + enddo + polenord = polenord / iim + polesud = polesud / iim + do j = 1, jp1 + do i = 1, iim + if (j .eq. 1) then + champdyn(i, j) = polenord + else if (j .eq. jp1) then + champdyn(i, j) = polesud + else + champdyn(i, j) = champin (i, j) + endif + enddo + champdyn(ip1, j) = champdyn(1, j) + enddo + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_u_scal.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_u_scal.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_u_scal.F (revision 1634) @@ -0,0 +1,60 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=ip1jmp1,2,-1 + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + + CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_v_scal.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_v_scal.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gr_v_scal.F (revision 1634) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=iip2,ip1jm + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grad.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grad.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grad.F (revision 1634) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE grad(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij +c +c + DO 6 l = 1,klevel +c + DO 2 ij = 1, ip1jmp1 - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = iip1, ip1jmp1, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + DO 4 ij = 1,ip1jm + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradiv.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradiv.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradiv.F (revision 1634) @@ -0,0 +1,57 @@ +! +! $Header$ +! + SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) + + REAL div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c +c +c + CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) + CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) +c + DO 10 iter = 1,ld +c + CALL diverg( klevel, gdx , gdy, div ) + CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 ) + CALL grad( klevel, div, gdx, gdy ) +c + DO 5 l = 1, klevel + DO 3 ij = 1, ip1jmp1 + gdx( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + DO 4 ij = 1, ip1jm + gdy( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradiv2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradiv2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradiv2.F (revision 1634) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL div(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + +c ........................................................ +c +c + CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) + CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf( klevel, gdx, gdy , div ) + + IF( ld.GT.1 ) THEN + + CALL laplacien ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... + + DO iter = 1, ld -2 + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO + + ENDIF + + + CALL filtreg( div , jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel, div, gdx, gdy ) + +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + gdx( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + DO ij = 1, ip1jm + gdy( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradsdef.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradsdef.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/gradsdef.h (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! + integer nfmx,imx,jmx,lmx,nvarmx + parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000) + + real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx) + + integer imd(imx),jmd(jmx),lmd(lmx) + integer iid(imx),jid(jmx) + integer ifd(imx),jfd(jmx) + integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx) + + integer nvar(nfmx),ivar(nfmx) + logical firsttime(nfmx) + + character*10 var(nvarmx,nfmx),fichier(nfmx) + character*40 title(nfmx),tvar(nvarmx,nfmx) + + common/gradsdef/xd,yd,zd,dtime, + s imd,jmd,lmd,iid,jid,ifd,jfd, + s unit,irec,nvar,ivar,itime,nld,firsttime, + s var,fichier,title,tvar Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grid_atob.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grid_atob.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grid_atob.F (revision 1634) @@ -0,0 +1,971 @@ +! +! $Id$ +! + SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Aucune ponderation est consideree (voir grille_p) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) + REAL distans(2200*1100) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c +c Calculer les limites des zones des nouveaux points +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO +c +c Determiner la zone sur laquelle chaque ancien point se trouve +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + sortie(ii,jj) = sortie(ii,jj) + entree(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c Si aucun ancien point tombe sur une zone, c'est un probleme +c + + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ENDDO + ENDDO + + RETURN + END + + + SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Consideration de la distance des points (voir grille_m) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(200),d(200) + REAL number(400,200) + INTEGER indx(400,200), indy(400,200) + REAL dist(400,200), distsom(400,200) +c + IF (imar.GT.400 .OR. jmar.GT.200) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + IF (imdep.GT.400 .OR. jmdep.GT.200) THEN + PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep + CALL ABORT + ENDIF +c +c calculer les bords a et b de la nouvelle grille +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + +c +c calculer les bords c et d de la nouvelle grille +c + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + +c +c trouver les indices (indx,indy) de la nouvelle grille sur laquelle +c un point de l'ancienne grille est tombe. +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + indx(i,j) = ii + indy(i,j) = jj + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c faire une verification +c + + DO i = 1, imdep + DO j = 1, jmdep + IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN + PRINT*, 'Probleme grave,i,j,indx,indy=', + . i,j,indx(i,j),indy(i,j) + CALL abort + ENDIF + ENDDO + ENDDO + +c +c calculer la distance des anciens points avec le nouveau point, +c on prend ensuite une sorte d'inverse pour ponderation. +c + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + distsom(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2 + . +(ydata(j)-y(indy(i,j)))**2 ) + distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j)) + . + dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1. + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j)) + ENDDO + ENDDO + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j)) + . + entree(i,j) * dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) + . + dist(i,j) + ENDDO + ENDDO + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief, + . imar, jmar, x, y, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique +c un champ indicateur (masque) terre/ocean +c terre:1; ocean:0 +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL relief(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL num_tot(2200,1100), num_oce(2200,1100) +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_oce(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) ) + . num_oce(ii,jj) = num_oce(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c +c + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN + mask(i,j) = 0. + ELSE + mask(i,j) = 1. + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END +c +c + + + SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une +c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur +c fixe (0.001m). +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar), mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_tot(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + sortie(ii,jj) = sortie(ii,jj) + LOG(entree(i,j)) + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c + + DO i = 1, imar + DO j = 1, jmar + IF (NINT(mask(i,j)).EQ.1) THEN + IF (num_tot(i,j) .GT. 0.0) THEN + sortie(i,j) = sortie(i,j) / num_tot(i,j) + sortie(i,j) = EXP(sortie(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ELSE + sortie(i,j) = 0.001 + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + + SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01, + . imar, jmar, x, y, frac_ice) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la +c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace +c (entre 0 et 1) dans une grille plus grossiere. +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL glace01(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL frac_ice(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400), num_ice(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_ice(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (NINT(glace01(i,j)).EQ.1 ) + . num_ice(ii,jj) = num_ice(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF (num_ice(i,j).GT.0.001) THEN + frac_ice(i,j) = num_ice(i,j) / num_tot(i,j) + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN + frac_ice(i,j) = 1.0 + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief, + . immod, jmmod, xmod, ymod, rugs) +c======================================================================= +c Calculer la longueur de rugosite liee au relief en utilisant +c l'ecart-type dans une maille de 1x1 +C======================================================================= + IMPLICIT none +c +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + REAL amin, AMAX +c + INTEGER imrel, jmrel + REAL xrel(imrel),yrel(jmrel) + REAL relief(imrel,jmrel) +c + INTEGER immod, jmmod + REAL xmod(immod),ymod(jmmod) + REAL rugs(immod,jmmod) +c + INTEGER imtmp, jmtmp + PARAMETER (imtmp=360,jmtmp=180) + REAL xtmp(imtmp), ytmp(jmtmp) + REAL(KIND=8) cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp) + REAL zzzz +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) +c + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +c + IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN + PRINT*, 'immod ou jmmod trop grand', immod, jmmod + CALL ABORT + ENDIF +c +c Calculs intermediares: +c + xtmp(1) = -180.0 + 360.0/REAL(imtmp) / 2.0 + DO i = 2, imtmp + xtmp(i) = xtmp(i-1) + 360.0/REAL(imtmp) + ENDDO + DO i = 1, imtmp + xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0) + ENDDO + ytmp(1) = -90.0 + 180.0/REAL(jmtmp) / 2.0 + DO j = 2, jmtmp + ytmp(j) = ytmp(j-1) + 180.0/REAL(jmtmp) + ENDDO + DO j = 1, jmtmp + ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0) + ENDDO +c + a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0 + b(1) = (xtmp(1)+xtmp(2))/2.0 + DO i = 2, imtmp-1 + a(i) = b(i-1) + b(i) = (xtmp(i)+xtmp(i+1))/2.0 + ENDDO + a(imtmp) = b(imtmp-1) + b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0 + + c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0 + d(1) = (ytmp(1)+ytmp(2))/2.0 + DO j = 2, jmtmp-1 + c(j) = d(j-1) + d(j) = (ytmp(j)+ytmp(j+1))/2.0 + ENDDO + c(jmtmp) = d(jmtmp-1) + d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0 + + DO i = 1, imtmp + DO j = 1, jmtmp + number(i,j) = 0.0 + cham1tmp(i,j) = 0.0 + cham2tmp(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imtmp + DO jj = 1, jmtmp + DO i = 1, imrel + IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR. + . ( xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmrel + IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR. + . ( yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j) + cham2tmp(ii,jj) = cham2tmp(ii,jj) + . + relief(i,j)*relief(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, imtmp + DO j = 1, jmtmp + IF (number(i,j) .GT. 0.001) THEN + cham1tmp(i,j) = cham1tmp(i,j) / number(i,j) + cham2tmp(i,j) = cham2tmp(i,j) / number(i,j) + zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2 + if (zzzz .lt. 0.0) then + if (zzzz .gt. -7.5) then + zzzz = 0.0 + print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0' + else + stop 'Pb rugsoro, zzzz <-7.5' + endif + endif + cham2tmp(i,j) = SQRT(zzzz) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO +c + amin = cham2tmp(1,1) + AMAX = cham2tmp(1,1) + DO j = 1, jmtmp + DO i = 1, imtmp + IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j) + IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type 1x1:', amin, AMAX +c +c +c + a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0 + b(1) = (xmod(1)+xmod(2))/2.0 + DO i = 2, immod-1 + a(i) = b(i-1) + b(i) = (xmod(i)+xmod(i+1))/2.0 + ENDDO + a(immod) = b(immod-1) + b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0 + + c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0 + d(1) = (ymod(1)+ymod(2))/2.0 + DO j = 2, jmmod-1 + c(j) = d(j-1) + d(j) = (ymod(j)+ymod(j+1))/2.0 + ENDDO + c(jmmod) = d(jmmod-1) + d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0 +c + DO i = 1, immod + DO j = 1, jmmod + number(i,j) = 0.0 + rugs(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, immod + DO jj = 1, jmmod + DO i = 1, imtmp + IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR. + . ( xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmtmp + IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR. + . ( ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + rugs(ii,jj) = rugs(ii,jj) + . + LOG(MAX(0.001_8,cham2tmp(i,j))) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, immod + DO j = 1, jmmod + IF (number(i,j) .GT. 0.001) THEN + rugs(i,j) = rugs(i,j) / number(i,j) + rugs(i,j) = EXP(rugs(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans) +#ifdef CRAY + ij_proche = ISMIN(imtmp*jmtmp,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imtmp*jmtmp + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imtmp + 1 + i_proche = ij_proche - (j_proche-1)*imtmp + PRINT*, "solution:", ij_proche, i_proche, j_proche + rugs(i,j) = LOG(MAX(0.001_8,cham2tmp(i_proche,j_proche))) + ENDIF + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type du modele:', amin, AMAX +c + DO j = 1, jmmod + DO i = 1, immod + rugs(i,j) = rugs(i,j) / AMAX * 20.0 + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Longueur de rugosite du modele:', amin, AMAX +c + RETURN + END +c + SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance) +c +c Auteur: Laurent Li (le 30 decembre 1996) +c +c Ce programme calcule la distance minimale (selon le grand cercle) +c entre deux points sur la terre +c +c Input: + INTEGER im, jm ! dimensions + REAL rf_lon ! longitude du point de reference (degres) + REAL rf_lat ! latitude du point de reference (degres) + REAL rlon(im), rlat(jm) ! longitude et latitude des points +c +c Output: + REAL distance(im,jm) ! distances en metre +c + REAL rlon1, rlat1 + REAL rlon2, rlat2 + REAL dist + REAL pa, pb, p, pi +c + REAL radius + PARAMETER (radius=6371229.) +c + pi = 4.0 * ATAN(1.0) +c + DO 9999 j = 1, jm + DO 9999 i = 1, im +c + rlon1=rf_lon + rlat1=rf_lat + rlon2=rlon(i) + rlat2=rlat(j) + pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a + pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b + p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens) +c + dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p)) + dist = radius * dist + distance(i,j) = dist +c + 9999 CONTINUE +c + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grid_noro.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grid_noro.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grid_noro.F (revision 1634) @@ -0,0 +1,521 @@ +! +! $Id$ +! +c +c + SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata, + . imar, jmar, x, y, + . zphi,zmea,zstd,zsig,zgam,zthe, + . zpic,zval,mask) +c======================================================================= +c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) +c +c Compute the Parameters of the SSO scheme as described in +c LOTT & MILLER (1997) and LOTT(1999). +c Target points are on a rectangular grid: +c iim+1 latitudes including North and South Poles; +c jjm+1 longitudes, with periodicity jjm+1=1. +c aux poles. At the poles the fields value is repeated +c jjm+1 time. +c The parameters a,b,c,d represent the limite of the target +c gridpoint region. The means over this region are calculated +c from USN data, ponderated by a weight proportional to the +c surface occupated by the data inside the model gridpoint area. +c In most circumstances, this weight is the ratio between the +c surface of the USN gridpoint area and the surface of the +c model gridpoint area. +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X and Y input field +c xdata, ydata: coordinates X and Y input field +c zdata: Input field +c In this version it is assumed that the entry data come from +c the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080. +c OUTPUT: +c imar, jmar: dimensions X and Y Output field +c x, y: ccordinates X and Y Output field. +c zmea: Mean orographie +c zstd: Standard deviation +c zsig: Slope +c zgam: Anisotropy +c zthe: Orientation of the small axis +c zpic: Maximum altitude +c zval: Minimum altitude +C======================================================================= + + IMPLICIT INTEGER (I,J) + IMPLICIT REAL(X,Z) + + parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5) +#include "dimensions.h" + REAL xusn(iusn+2*iext),yusn(jusn+2) + REAL zusn(iusn+2*iext,jusn+2) + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL zdata(imdep,jmdep) +c + INTEGER imar, jmar + +C INTERMEDIATE FIELDS (CORRELATIONS OF OROGRAPHY GRADIENT) + + REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1) + REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1) + REAL weight(iim+1,jjm+1) + +C CORRELATIONS OF USN OROGRAPHY GRADIENTS + + REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2) + REAL zxtzyusn(iusn+2*iext,jusn+2) + REAL x(imar+1),y(jmar),zphi(imar+1,jmar) + REAL zmea(imar+1,jmar),zstd(imar+1,jmar) + REAL zmea0(imar+1,jmar) ! GK211005 (CG) + REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) + REAL zpic(imar+1,jmar),zval(imar+1,jmar) +cx$$ PB integer mask(imar+1,jmar) + real mask(imar+1,jmar), mask_tmp(imar+1,jmar) + real num_tot(2200,1100),num_lan(2200,1100) +c + REAL a(2200),b(2200),c(1100),d(1100) + logical masque_lu +c + print *,' parametres de l orographie a l echelle sous maille' + xpi=acos(-1.) + rad = 6 371 229. + zdeltay=2.*xpi/REAL(jusn)*rad +c +c utilise-t'on un masque lu? +c + masque_lu = .true. + if (maxval(mask) == -99999 .and. minval(mask) == -99999) then + masque_lu= .false. + masque = 0.0 + endif + write(*,*)'Masque lu', masque_lu +c +c quelques tests de dimensions: +c +c + if(iim.ne.imar) STOP 'Problem dim. x' + if(jjm.ne.jmar-1) STOP 'Problem dim. y' + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar or jmar too big', imar, jmar + CALL ABORT + ENDIF + + IF(imdep.ne.iusn.or.jmdep.ne.jusn)then + print *,' imdep or jmdep bad dimensions:',imdep,jmdep + call abort + ENDIF + + IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN + print *,' imar or jmar bad dimensions:',imar,jmar + call abort + ENDIF + + +c print *,'xdata:',xdata +c print *,'ydata:',ydata +c print *,'x:',x +c print *,'y:',y +c +C EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT +C BOUNDARIES: +c + DO j=1,jusn + yusn(j+1)=ydata(j) + DO i=1,iusn + zusn(i+iext,j+1)=zdata(i,j) + xusn(i+iext)=xdata(i) + ENDDO + DO i=1,iext + zusn(i,j+1)=zdata(iusn-iext+i,j) + xusn(i)=xdata(iusn-iext+i)-2.*xpi + zusn(iusn+iext+i,j+1)=zdata(i,j) + xusn(iusn+iext+i)=xdata(i)+2.*xpi + ENDDO + ENDDO + + yusn(1)=ydata(1)+(ydata(1)-ydata(2)) + yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1)) + DO i=1,iusn/2+iext + zusn(i,1)=zusn(i+iusn/2,2) + zusn(i+iusn/2+iext,1)=zusn(i,2) + zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1) + zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1) + ENDDO +c +c COMPUTE LIMITS OF MODEL GRIDPOINT AREA +C ( REGULAR GRID) +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar+1) = b(imar) + b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 +c +c initialisations: +c + DO i = 1, imar+1 + DO j = 1, jmar + weight(i,j) = 0.0 + zxtzx(i,j) = 0.0 + zytzy(i,j) = 0.0 + zxtzy(i,j) = 0.0 + ztz(i,j) = 0.0 + zmea(i,j) = 0.0 + zpic(i,j) =-1.E+10 + zval(i,j) = 1.E+10 + ENDDO + ENDDO +c +c COMPUTE SLOPES CORRELATIONS ON USN GRID +c + DO j = 1,jusn+2 + DO i = 1, iusn+2*iext + zytzyusn(i,j)=0.0 + zxtzxusn(i,j)=0.0 + zxtzyusn(i,j)=0.0 + ENDDO + ENDDO + + + DO j = 2,jusn+1 + zdeltax=zdeltay*cos(yusn(j)) + DO i = 2, iusn+2*iext-1 + zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 + zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2 + zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay + * *(zusn(i+1,j)-zusn(i-1,j))/zdeltax + ENDDO + ENDDO +c +c SUMMATION OVER GRIDPOINT AREA +c + zleny=xpi/REAL(jusn)*rad + xincr=xpi/2./REAL(jusn) + DO ii = 1, imar+1 + DO jj = 1, jmar + num_tot(ii,jj)=0. + num_lan(ii,jj)=0. +c PRINT *,' iteration ii jj:',ii,jj + DO j = 2,jusn+1 +c DO j = 3,jusn + zlenx=zleny*cos(yusn(j)) + zdeltax=zdeltay*cos(yusn(j)) + zbordnor=(c(jj)-yusn(j)+xincr)*rad + zbordsud=(yusn(j)-d(jj)+xincr)*rad + weighy=AMAX1(0., + * amin1(zbordnor,zbordsud,zleny)) + IF(weighy.ne.0)THEN + DO i = 2, iusn+2*iext-1 + zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j)) + zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j)) + weighx=AMAX1(0., + * amin1(zbordest,zbordoue,zlenx)) + IF(weighx.ne.0)THEN + num_tot(ii,jj)=num_tot(ii,jj)+1.0 + if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0 + weight(ii,jj)=weight(ii,jj)+weighx*weighy + zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy + zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy + zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy + ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy +c mean + zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy +c peacks + zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j)) +c valleys + zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND +C LOTT (1999) SSO SCHEME. +c + zllmmea=0. + zllmstd=0. + zllmsig=0. + zllmgam=0. + zllmpic=0. + zllmval=0. + zllmthe=0. + zminthe=0. +c print 100,' ' +c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') + DO ii = 1, imar+1 + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Mask +cx$$ if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then +cx$$ mask(ii,jj)=1 +cx$$ else +cx$$ mask(ii,jj)=0 +cx$$ ENDIF + if (.not. masque_lu) then + mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj) + endif +c Mean Orography: + zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) + zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) + zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) + zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) + ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) +c Standard deviation: + zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) + ELSE + PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + ENDDO + ENDDO + +C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES: + + DO ii = 1, imar+1 + zxtzx(ii,1)=zxtzx(ii,2) + zxtzx(ii,jmar)=zxtzx(ii,jmar-1) + zxtzy(ii,1)=zxtzy(ii,2) + zxtzy(ii,jmar)=zxtzy(ii,jmar-1) + zytzy(ii,1)=zytzy(ii,2) + zytzy(ii,jmar)=zytzy(ii,jmar-1) + ENDDO + +C FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME. + +C FIRST FILTER, MOVING AVERAGE OVER 9 POINTS. + + zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee + CALL MVA9(zmea,iim+1,jjm+1) + CALL MVA9(zstd,iim+1,jjm+1) + CALL MVA9(zpic,iim+1,jjm+1) + CALL MVA9(zval,iim+1,jjm+1) + CALL MVA9(zxtzx,iim+1,jjm+1) + CALL MVA9(zxtzy,iim+1,jjm+1) + CALL MVA9(zytzy,iim+1,jjm+1) +Cx$$ Masque prenant en compte maximum de terre +Cx$$ On seuil a 10% de terre de terre car en dessous les parametres de surface n'on +Cx$$ pas de sens (PB) + mask_tmp= 0.0 + WHERE(mask .GE. 0.1) mask_tmp = 1. + + DO ii = 1, imar + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Coefficients K, L et M: + xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. + xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. + xm=zxtzy(ii,jj) + xp=xk-sqrt(xl**2+xm**2) + xq=xk+sqrt(xl**2+xm**2) + xw=1.e-8 + if(xp.le.xw) xp=0. + if(xq.le.xw) xq=xw + if(abs(xm).le.xw) xm=xw*sign(1.,xm) +c slope: +cx$$ zsig(ii,jj)=sqrt(xq)*mask(ii,jj) +cx$$c isotropy: +cx$$ zgam(ii,jj)=xp/xq*mask(ii,jj) +cx$$c angle theta: +cx$$ zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj) +cx$$ zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cx$$ zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cx$$ zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj) +cx$$ zval(ii,jj)=zval(ii,jj)*mask(ii,jj) +cx$$ zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj) +Cx$* PB modif pour maque de terre fractionnaire +c slope: + zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj) +c isotropy: + zgam(ii,jj)=xp/xq*mask_tmp(ii,jj) +c angle theta: + zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj) + ! GK211005 (CG) ne pas forcement lisser la topo + ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj) + ! + zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj) + zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj) + zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj) +c print 101,ii,jj, +c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), +c * zthe(ii,jj) +c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) + ELSE +c PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + zllmmea=AMAX1(zmea(ii,jj),zllmmea) + zllmstd=AMAX1(zstd(ii,jj),zllmstd) + zllmsig=AMAX1(zsig(ii,jj),zllmsig) + zllmgam=AMAX1(zgam(ii,jj),zllmgam) + zllmthe=AMAX1(zthe(ii,jj),zllmthe) + zminthe=amin1(zthe(ii,jj),zminthe) + zllmpic=AMAX1(zpic(ii,jj),zllmpic) + zllmval=AMAX1(zval(ii,jj),zllmval) + ENDDO + ENDDO + print *,' MEAN ORO:',zllmmea + print *,' ST. DEV.:',zllmstd + print *,' PENTE:',zllmsig + print *,' ANISOTROP:',zllmgam + print *,' ANGLE:',zminthe,zllmthe + print *,' pic:',zllmpic + print *,' val:',zllmval + +C +c gamma and theta a 1. and 0. at poles +c + DO jj=1,jmar + zmea(imar+1,jj)=zmea(1,jj) + zphi(imar+1,jj)=zphi(1,jj) + zpic(imar+1,jj)=zpic(1,jj) + zval(imar+1,jj)=zval(1,jj) + zstd(imar+1,jj)=zstd(1,jj) + zsig(imar+1,jj)=zsig(1,jj) + zgam(imar+1,jj)=zgam(1,jj) + zthe(imar+1,jj)=zthe(1,jj) + ENDDO + + + zmeanor=0.0 + zmeasud=0.0 + zstdnor=0.0 + zstdsud=0.0 + zsignor=0.0 + zsigsud=0.0 + zweinor=0.0 + zweisud=0.0 + zpicnor=0.0 + zpicsud=0.0 + zvalnor=0.0 + zvalsud=0.0 + + DO ii=1,imar + zweinor=zweinor+ weight(ii, 1) + zweisud=zweisud+ weight(ii,jmar) + zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) + zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) + zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) + zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) + zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) + zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) + zpicnor=zpicnor+zpic(ii, 1)*weight(ii, 1) + zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar) + zvalnor=zvalnor+zval(ii, 1)*weight(ii, 1) + zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar) + ENDDO + + DO ii=1,imar+1 + zmea(ii, 1)=zmeanor/zweinor + zmea(ii,jmar)=zmeasud/zweisud + zphi(ii, 1)=zmeanor/zweinor + zphi(ii,jmar)=zmeasud/zweisud + zpic(ii, 1)=zpicnor/zweinor + zpic(ii,jmar)=zpicsud/zweisud + zval(ii, 1)=zvalnor/zweinor + zval(ii,jmar)=zvalsud/zweisud + zstd(ii, 1)=zstdnor/zweinor + zstd(ii,jmar)=zstdsud/zweisud + zsig(ii, 1)=zsignor/zweinor + zsig(ii,jmar)=zsigsud/zweisud + zgam(ii, 1)=1. + zgam(ii,jmar)=1. + zthe(ii, 1)=0. + zthe(ii,jmar)=0. + ENDDO + + RETURN + END + + SUBROUTINE MVA9(X,IMAR,JMAR) + +C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS + + REAL X(IMAR,JMAR),XF(IMAR,JMAR) + real WEIGHTpb(-1:1,-1:1) + + + SUM=0. + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=1./REAL((1+IS**2)*(1+JS**2)) + SUM=SUM+WEIGHTpb(IS,JS) + ENDDO + ENDDO + +c WRITE(*,*) 'MVA9 ', IMAR, JMAR +c WRITE(*,*) 'MVA9 ', WEIGHTpb +c WRITE(*,*) 'MVA9 SUM ', SUM + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM + ENDDO + ENDDO + + DO J=2,JMAR-1 + DO I=2,IMAR-1 + XF(I,J)=0. + DO IS=-1,1 + DO JS=-1,1 + XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + ENDDO + ENDDO + + DO J=2,JMAR-1 + XF(1,J)=0. + IS=IMAR-1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS) + ENDDO + DO IS=0,1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + XF(IMAR,J)=XF(1,J) + ENDDO + + DO I=1,IMAR + XF(I,1)=XF(I,2) + XF(I,JMAR)=XF(I,JMAR-1) + ENDDO + + DO I=1,IMAR + DO J=1,JMAR + X(I,J)=XF(I,J) + ENDDO + ENDDO + + RETURN + END + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grilles_gcm_netcdf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grilles_gcm_netcdf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grilles_gcm_netcdf.F (revision 1634) @@ -0,0 +1,305 @@ +! +! $Id$ +! +c +c + + PROGRAM create_fausse_var +C + IMPLICIT NONE +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" + + real temp(iim+1,jjm+1) +#include "netcdf.inc" + +c Attributs netcdf sortie + character*64 fich_out + integer*4 ncid_out,rcode_out + integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid + integer*4 out_varid + integer*4 out_lonudim,out_lonvdim + integer*4 out_latudim,out_latvdim,out_dim(3) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + integer start(4),count(4) + + integer status,i,j + real rlatudeg(jjp1),rlatvdeg(jjm) + real rlonudeg(iip1),rlonvdeg(iip1) + + real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + real acoslat,dxkm,dykm,resol(iip1,jjp1) + +#include "serre.h" +#include "fxyprim.h" + + print*,'OK0' + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + +c open(99,file='run.def',status='old',form='formatted') +c CALL defrun_new( 99, .TRUE.,clesphy0 ) +c close(99) + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + + print*,'OK1' + do j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + enddo + do j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + enddo + + do i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + enddo + + + print*,'OK2' +c 2 ----- OUVERTURE DE LA SORTIE NETCDF +c --------------------------------------------------- +c CREATION OUTPUT +c ouverture fichier netcdf de sortie out + fich_out='grilles_gcm.nc' + + status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + print*,'OK3' +c Longitudes en u + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, + % out_lonuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name', + % 9,'Longitude en u') + +c Longitudes en v + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, + % out_lonvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', + % 9,'Longitude en v') + +c Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, + % out_latuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', + % 8,'Latitude en u') + +c Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, + % out_latvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', + % 8,'Latitude en v') + +c ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + +c ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point v') + +c ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + + + print*,'OK4' + status=NF_ENDDEF(ncid_out) +c 5) ----- FERMETURE DES FICHIERS NETCDF------------------ +c -------------------------------------------------------- +c 3-b- Ecriture de la grille pour la sortie +c rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + count(1)=iim+1 + count(2)=jjm+1 + count(3)=1 + count(4)=1 + + do j=1,jjm+1 + do i=1,iim+1 + temp(i,j)=mod(i,2)+mod(j,2) + enddo + enddo + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, + s count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, + s count,temp) +#endif + + +c fermeture du fichier netcdf + call ncclos(ncid_out,rcode_out) + write(*,*) 'Fermeture: ',fich_out + + + print*,'OK5' +c Ecriture grads + open (20,file='grille.dat',form='unformatted',access='direct' + s ,recl=4*ip1jmp1) + write(20,rec=1) ((REAL(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1) + write(20,rec=2) ((REAL(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1) + do j=2,jjm + dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi +c dlat2(j)=180.*fyprim(REAL(j))/pi + enddo + do i=2,iip1 + dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi +c dlon2(i)=180.*fxprim(REAL(i))/pi + enddo + do j=2,jjm + dykm=(rlatv(j)-rlatv(j-1))*6400. + acoslat=6400.*cos(rlatu(j)) + do i=2,iip1 + dxkm=acoslat*(rlonu(i)-rlonu(i-1)) + resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm) + enddo + resol(1,j)=resol(iip1,j) + enddo + write(20,rec=3) resol + dlon1(1)=dlon1(iip1) + dlon2(1)=dlon2(iip1) + write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1) + write(20,rec=5) ((dlon1(i)*pi/180.*0.001* + s cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1) + write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1) + write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1) + write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1) + write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1) + + print*,'I, LON, DX (km)' + do i=1,iip1 + print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001* + s cos(clat*pi/180.)*rad + enddo + print*,'J, LAT, DY (km)' + do j=1,jjp1 + print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad + enddo + + open (21,file='grille.ctl',form='formatted') + +c WARNING! on reecrase le fichier .ctl a chaque ecriture + write(21,'(a5,1x,a40)') + & 'DSET ','^grille.dat' + + write(21,'(a12)') 'UNDEF 1.0E30' + write(21,'(a5,1x,a40)') 'TITLE ','grille' + call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF') + call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF') + call formcoord(21,1,0.,1.,.false.,'ZDEF') + write(21,'(a4,i10,a30)') + & 'TDEF ',1,' LINEAR 23OCT1994 3hr ' + write(21,'(a4,2x,i5)') 'VARS',9 + write(21,'(a18)') 'grille 0 99 grille' + write(21,'(a18)') 'gril 0 99 gril ' + write(21,'(a29)') 'resol 0 99 resolution (km) ' + write(21,'(a18)') 'dlon1 0 99 dlon1 ' + write(21,'(a20)') 'dx 0 99 dx (km) ' + write(21,'(a18)') 'dlon2 0 99 dlon2 ' + write(21,'(a18)') 'dlat1 0 99 dlat1 ' + write(21,'(a20)') 'dy 0 99 dy (km) ' + write(21,'(a18)') 'dlat2 0 99 dlat2 ' + write(21,'(a7)') 'ENDVARS' + + + + + + print*,'OK6' + end + + + + subroutine handle_err(status) +#include "netcdf.inc" + + + integer status + print *,'handle code err: ',NF_NOERR + IF (status.NE.nf_noerr) THEN + print *,NF_STRERROR(status) + stop 'stopped' + ENDIF + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grilles_gcm_netcdf_sub.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grilles_gcm_netcdf_sub.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/grilles_gcm_netcdf_sub.F90 (revision 1634) @@ -0,0 +1,237 @@ +! +! $Header$ +! +! This subroutine creates the file grilles_gcm.nc containg longitudes and +! latitudes in degrees for grid u and v. This subroutine is called from +! ce0l if grilles_gcm_netcdf=TRUE. This subroutine corresponds to the first +! part in the program create_fausse_var. +! +SUBROUTINE grilles_gcm_netcdf_sub(masque,phis) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comgeom.h" + INCLUDE "comvert.h" + INCLUDE "netcdf.inc" + INCLUDE "serre.h" + + + REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: masque ! masque terre/mer + REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: phis ! geopotentiel au sol + + REAL temp(iim+1,jjm+1) + ! Attributs netcdf sortie + INTEGER ncid_out,rcode_out + INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid,out_levid + INTEGER out_varid + INTEGER out_lonudim,out_lonvdim + INTEGER out_latudim,out_latvdim,out_dim(3) + INTEGER out_levdim + + INTEGER, PARAMETER :: longcles = 20 + REAL clesphy0(longcles) + + INTEGER start(4),COUNT(4) + + INTEGER status,i,j + REAL rlatudeg(jjp1),rlatvdeg(jjm),rlevdeg(llm) + REAL rlonudeg(iip1),rlonvdeg(iip1) + + REAL dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + REAL acoslat,dxkm,dykm,resol(iip1,jjp1) + REAL,DIMENSION(iip1,jjp1) :: phis_loc + INTEGER masque_int(iip1,jjp1) + INTEGER :: phis_id + INTEGER :: area_id + INTEGER :: mask_id + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + DO j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + ENDDO + DO j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + ENDDO + + DO i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + ENDDO + + + ! 2 ----- OUVERTURE DE LA SORTIE NETCDF + ! --------------------------------------------------- + ! CREATION OUTPUT + ! ouverture fichier netcdf de sortie out + status=NF_CREATE('grilles_gcm.nc',NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + ! Longitudes en u + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, out_lonuid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',9,'Longitude en u') + + ! Longitudes en v + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, out_lonvid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', 9,'Longitude en v') + + ! Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, out_latuid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', 8,'Latitude en u') + + ! Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, out_latvid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', 8,'Latitude en v') + + ! ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point u') + + ! ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point v') + + ! ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',16,'Grille aux point u') + + status=NF_ENDDEF(ncid_out) + ! 5) ----- FERMETURE DES FICHIERS NETCDF------------------ + ! -------------------------------------------------------- + ! 3-b- Ecriture de la grille pour la sortie + ! rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + COUNT(1)=iim+1 + COUNT(2)=jjm+1 + COUNT(3)=1 + COUNT(4)=1 + + DO j=1,jjm+1 + DO i=1,iim+1 + temp(i,j)=MOD(i,2)+MOD(j,2) + ENDDO + ENDDO + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, count,temp) +#endif + + ! On re-ouvre le fichier pour rajouter 4 nouvelles variables necessaire pour INCA +! lev - phis - aire - mask + rlevdeg(:) = presnivs + phis_loc(:,:) = phis(:,:)/g + +! niveaux de pression verticaux + status = NF_REDEF (ncid_out) + status=NF_DEF_DIM(ncid_out,'lev',llm,out_levdim) + +! fields + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + + status = nf_def_var(ncid_out,'phis',NF_FLOAT,2,out_dim,phis_id) + CALL handle_err(status) + status = nf_def_var(ncid_out,'aire',NF_FLOAT,2,out_dim,area_id) + CALL handle_err(status) + status = nf_def_var(ncid_out,'mask',NF_INT ,2,out_dim,mask_id) + CALL handle_err(status) + + status=NF_ENDDEF(ncid_out) + + ! ecriture des variables +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_levid,1,llm,rlevdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_levid,1,llm,rlevdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=0 + COUNT(1)=iip1 + COUNT(2)=jjp1 + COUNT(3)=1 + COUNT(4)=0 + + status = nf_put_vara_double(ncid_out, phis_id,start,count, phis_loc) + status = nf_put_vara_double(ncid_out, area_id,start,count, aire) + masque_int(:,:) = nINT(masque(:,:)) + status = nf_put_vara_int(ncid_out, mask_id,start,count,masque_int) + CALL handle_err(status) + + ! fermeture du fichier netcdf + CALL ncclos(ncid_out,rcode_out) + +END SUBROUTINE grilles_gcm_netcdf_sub + + + +SUBROUTINE handle_err(status) + INCLUDE "netcdf.inc" + + INTEGER status + IF (status.NE.nf_noerr) THEN + PRINT *,NF_STRERROR(status) + CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1) + ENDIF +END SUBROUTINE handle_err + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/groupe.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/groupe.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/groupe.F (revision 1634) @@ -0,0 +1,97 @@ +! +! $Header$ +! + subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm) + implicit none + +c sous-programme servant a fitlrer les champs de flux de masse aux +c poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur +c et a mesure qu'on se rapproche du pole. +c +c en entree: pext, pbaru et pbarv +c +c en sortie: pbarum,pbarvm et wm. +c +c remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc +c pas besoin de w en entree. + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "comvert.h" + + integer ngroup + parameter (ngroup=3) + + + real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) + real pext(iip1,jjp1,llm) + + real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm) + real wm(iip1,jjp1,llm) + + real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm) + + real uu + + integer i,j,l + + logical firstcall + save firstcall + + data firstcall/.true./ + + if (firstcall) then + if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point' + firstcall=.false. + endif + +c Champs 1D + + call convflu(pbaru,pbarv,llm,zconvm) + +c + call scopy(ijp1llm,zconvm,1,zconvmm,1) + call scopy(ijmllm,pbarv,1,pbarvm,1) + +c + call groupeun(jjp1,llm,zconvmm) + call groupeun(jjm,llm,pbarvm) + +c Champs 3D + + do l=1,llm + do j=2,jjm + uu=pbaru(iim,j,l) + do i=1,iim + uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l) + pbarum(i,j,l)=uu +c zconvm(i,j,l ) = xflu(i-1,j,l)-xflu(i,j,l)+ +c * yflu(i,j,l)-yflu(i,j-1,l) + enddo + pbarum(iip1,j,l)=pbarum(1,j,l) + enddo + enddo + +c integration de la convergence de masse de haut en bas ...... + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + zconvmm(i,j,l)=zconvmm(i,j,l) + enddo + enddo + enddo + do l = llm-1,1,-1 + do j=1,jjp1 + do i=1,iip1 + zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1) + enddo + enddo + enddo + + CALL vitvert(zconvmm,wm) + + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/groupeun.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/groupeun.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/groupeun.F (revision 1634) @@ -0,0 +1,200 @@ +! +! $Header$ +! + SUBROUTINE groupeun(jjmax,llmax,q) + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER jjmax,llmax + REAL q(iip1,jjmax,llmax) + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airecn,qn + REAL airecs,qs + + INTEGER i,j,l,ig,ig2,j1,j2,i0,jd + +c--------------------------------------------------------------------c +c Strategie d'optimisation c +c stocker les valeurs systematiquement recalculees c +c et identiques d'un pas de temps sur l'autre. Il s'agit des c +c aires des cellules qui sont sommees. S'il n'y a pas de changement c +c de grille au cours de la simulation tout devrait bien se passer. c +c Autre optimisation : determination des bornes entre lesquelles "j" c +c varie, au lieu de faire un test à chaque fois... +c--------------------------------------------------------------------c + + INTEGER j_start, j_finish + + REAL, SAVE :: airen_tab(iip1,jjp1,0:1) + REAL, SAVE :: aires_tab(iip1,jjp1,0:1) + + LOGICAL, SAVE :: first = .TRUE. + INTEGER,SAVE :: i_index(iim,ngroup) + INTEGER :: offset + REAL :: qsum(iim/ngroup) + + IF (first) THEN + CALL INIT_GROUPEUN(airen_tab, aires_tab) + first = .FALSE. + ENDIF + + +c Champs 3D + jd=jjp1-jjmax +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + j1=1+jd + j2=2 + DO ig=1,ngroup + +c Concerne le pole nord + j_start = j1-jd + j_finish = j2-jd + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(airen_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd) + ENDDO + q(iip1,j,l)=q(1,j,l) + ENDDO + +!c Concerne le pole sud + j_start = j1-jd + j_finish = j2-jd + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) + & +q(i0+offset,jjp1-j+1-jd,l) + ENDDO + ENDDO + ENDDO + + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), + & jjp1-j+1-jd,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(aires_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* + & aires_tab(i,jjp1-j+1,jd) + ENDDO + q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) + ENDDO + + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO +!$OMP END DO NOWAIT + + RETURN + END + + + + + SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab) + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airen,airecn + REAL aires,airecs + + INTEGER i,j,l,ig,j1,j2,i0,jd + + INTEGER j_start, j_finish + + REAL :: airen_tab(iip1,jjp1,0:1) + REAL :: aires_tab(iip1,jjp1,0:1) + + DO jd=0, 1 + j1=1+jd + j2=2 + DO ig=1,ngroup + +! c Concerne le pole nord + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + airen=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen = airen+aire(i,j) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen_tab(i,j,jd) = + & aire(i,j) / airen + ENDDO + ENDDO + ENDDO + +! c Concerne le pole sud + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + aires=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires=aires+aire(i,jjp1-j+1) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires_tab(i,jjp1-j+1,jd) = + & aire(i,jjp1-j+1) / aires + ENDDO + ENDDO + ENDDO + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/guide_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/guide_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/guide_mod.F90 (revision 1634) @@ -0,0 +1,1552 @@ +! +! $Id$ +! +MODULE guide_mod + +!======================================================================= +! Auteur: F.Hourdin +! F. Codron 01/09 +!======================================================================= + + USE getparam + USE Write_Field + use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close + + IMPLICIT NONE + +! --------------------------------------------- +! Declarations des cles logiques et parametres +! --------------------------------------------- + INTEGER, PRIVATE, SAVE :: iguide_read,iguide_int,iguide_sav + INTEGER, PRIVATE, SAVE :: nlevnc + LOGICAL, PRIVATE, SAVE :: guide_u,guide_v,guide_T,guide_Q,guide_P + LOGICAL, PRIVATE, SAVE :: guide_hr,guide_teta + LOGICAL, PRIVATE, SAVE :: guide_BL,guide_reg,guide_add,gamma4,guide_zon + LOGICAL, PRIVATE, SAVE :: guide_modele,invert_p,invert_y,ini_anal + LOGICAL, PRIVATE, SAVE :: guide_2D,guide_sav + + REAL, PRIVATE, SAVE :: tau_min_u,tau_max_u + REAL, PRIVATE, SAVE :: tau_min_v,tau_max_v + REAL, PRIVATE, SAVE :: tau_min_T,tau_max_T + REAL, PRIVATE, SAVE :: tau_min_Q,tau_max_Q + REAL, PRIVATE, SAVE :: tau_min_P,tau_max_P + + REAL, PRIVATE, SAVE :: lat_min_g,lat_max_g + REAL, PRIVATE, SAVE :: lon_min_g,lon_max_g + REAL, PRIVATE, SAVE :: tau_lon,tau_lat + + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u,alpha_v + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T,alpha_Q + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P,alpha_pcor + +! --------------------------------------------- +! Variables de guidage +! --------------------------------------------- +! Variables des fichiers de guidage + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: unat1,unat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: vnat1,vnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: tnat1,tnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: qnat1,qnat2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: psnat1,psnat2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc,bpnc +! Variables aux dimensions du modele + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: ugui1,ugui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: vgui1,vgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tgui1,tgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qgui1,qgui2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1,psgui2 + +CONTAINS +!======================================================================= + + SUBROUTINE guide_init + + USE control_mod + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + + INTEGER :: error,ncidpl,rid,rcod + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_init' + +! --------------------------------------------- +! Lecture des parametres: +! --------------------------------------------- +! Variables guidees + CALL getpar('guide_u',.true.,guide_u,'guidage de u') + CALL getpar('guide_v',.true.,guide_v,'guidage de v') + CALL getpar('guide_T',.true.,guide_T,'guidage de T') + CALL getpar('guide_P',.true.,guide_P,'guidage de P') + CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q') + CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R') + CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta') + + CALL getpar('guide_add',.false.,guide_add,'for�age constant?') + CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale') + +! Constantes de rappel. Unite : fraction de jour + CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u') + CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u') + CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v') + CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v') + CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T') + CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T') + CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q') + CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q') + CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P') + CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P') + CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie') + CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim') + +! Sauvegarde du for�age + CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage') + CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage') + ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois. + IF (iguide_sav.GT.0) THEN + iguide_sav=day_step/iguide_sav + ELSE + iguide_sav=day_step*iguide_sav + ENDIF + +! Guidage regional seulement (sinon constant ou suivant le zoom) + CALL getpar('guide_reg',.false.,guide_reg,'guidage regional') + CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ') + CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ') + CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ') + CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ') + CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ') + CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ') + +! Parametres pour lecture des fichiers + CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage') + CALL getpar('iguide_int',4,iguide_int,'freq. lecture guidage') + IF (iguide_int.GT.0) THEN + iguide_int=day_step/iguide_int + ELSE + iguide_int=day_step*iguide_int + ENDIF + CALL getpar('guide_modele',.false.,guide_modele,'guidage niveaux modele') + CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse') + CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses') + CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S') + CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P') + +! --------------------------------------------- +! Determination du nombre de niveaux verticaux +! des fichiers guidage +! --------------------------------------------- + ncidpl=-99 + if (guide_modele) then + if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl) + else + if (guide_u) then + if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_v) then + if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl) + elseif (guide_T) then + if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl) + elseif (guide_Q) then + if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl) + endif + endif + error=NF_INQ_DIMID(ncidpl,'LEVEL',rid) + IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid) + IF (error.NE.NF_NOERR) THEN + print *,'Guide: probleme lecture niveaux pression' + CALL abort_gcm(modname,abort_message,1) + ENDIF + error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc) + print *,'Guide: nombre niveaux vert. nlevnc', nlevnc + rcod = nf90_close(ncidpl) + +! --------------------------------------------- +! Allocation des variables +! --------------------------------------------- + abort_message='pb in allocation guide' + + ALLOCATE(apnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(bpnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + apnc=0.;bpnc=0. + + ALLOCATE(alpha_pcor(llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_u(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_v(ip1jm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_T(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_Q(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_P(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0 + + IF (guide_u) THEN + ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + unat1=0.;unat2=0.;ugui1=0.;ugui2=0. + ENDIF + + IF (guide_T) THEN + ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0. + ENDIF + + IF (guide_Q) THEN + ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0. + ENDIF + + IF (guide_v) THEN + ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui1(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui2(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0. + ENDIF + + IF (guide_P.OR.guide_modele) THEN + ALLOCATE(psnat1(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psnat2(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psnat1=0.;psnat2=0.; + ENDIF + IF (guide_P) THEN + ALLOCATE(psgui2(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psgui1(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psgui1=0.;psgui2=0. + ENDIF + +! --------------------------------------------- +! Lecture du premier etat de guidage. +! --------------------------------------------- + IF (guide_2D) THEN + CALL guide_read2D(1) + ELSE + CALL guide_read(1) + ENDIF + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_P.OR.guide_modele) psnat1=psnat2 + + END SUBROUTINE guide_init + +!======================================================================= + SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) + + USE control_mod + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + INTEGER, INTENT(IN) :: itau !pas de temps + REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse + REAL, DIMENSION (ip1jm,llm), INTENT(INOUT) :: vcov + REAL, DIMENSION (ip1jmp1), INTENT(INOUT) :: ps + + ! Variables locales + LOGICAL, SAVE :: first=.TRUE. + LOGICAL :: f_out ! sortie guidage + REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage + REAL, DIMENSION (ip1jmp1,llm) :: p ! besoin si guide_P + ! Compteurs temps: + INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage + REAL :: ditau, dday_step + REAL :: tau,reste ! position entre 2 etats de guidage + REAL, SAVE :: factt ! pas de temps en fraction de jour + + INTEGER :: l + +!----------------------------------------------------------------------- +! Initialisations au premier passage +!----------------------------------------------------------------------- + IF (first) THEN + first=.FALSE. + CALL guide_init + itau_test=1001 + step_rea=1 + count_no_rea=0 +! Calcul des constantes de rappel + factt=dtvr*iperiod/daysec + call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v) + call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u) + call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T) + call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P) + call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q) +! correction de rappel dans couche limite + if (guide_BL) then + alpha_pcor(:)=1. + else + do l=1,llm + alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2. + enddo + endif +! ini_anal: etat initial egal au guidage + IF (ini_anal) THEN + CALL guide_interp(ps,teta) + IF (guide_u) ucov=ugui2 + IF (guide_v) vcov=ugui2 + IF (guide_T) teta=tgui2 + IF (guide_Q) q=qgui2 + IF (guide_P) THEN + ps=psgui2 + CALL pression(ip1jmp1,ap,bp,ps,p) + CALL massdair(p,masse) + ENDIF + RETURN + ENDIF +! Verification structure guidage + IF (guide_u) THEN + CALL writefield('unat',unat1) + CALL writefield('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/))) + ENDIF + IF (guide_T) THEN + CALL writefield('tnat',tnat1) + CALL writefield('teta',RESHAPE(teta,(/iip1,jjp1,llm/))) + ENDIF + + ENDIF !first + +!----------------------------------------------------------------------- +! Lecture des fichiers de guidage ? +!----------------------------------------------------------------------- + IF (iguide_read.NE.0) THEN + ditau=real(itau) + dday_step=real(day_step) + IF (iguide_read.LT.0) THEN + tau=ditau/dday_step/REAL(iguide_read) + ELSE + tau=REAL(iguide_read)*ditau/dday_step + ENDIF + reste=tau-AINT(tau) + IF (reste.EQ.0.) THEN + IF (itau_test.EQ.itau) THEN + write(*,*)'deuxieme passage de advreel a itau=',itau + stop + ELSE + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_P.OR.guide_modele) psnat1=psnat2 + step_rea=step_rea+1 + itau_test=itau + print*,'Lecture fichiers guidage, pas ',step_rea, & + 'apres ',count_no_rea,' non lectures' + IF (guide_2D) THEN + CALL guide_read2D(step_rea) + ELSE + CALL guide_read(step_rea) + ENDIF + count_no_rea=0 + ENDIF + ELSE + count_no_rea=count_no_rea+1 + + ENDIF + ENDIF !iguide_read=0 + +!----------------------------------------------------------------------- +! Interpolation et conversion des champs de guidage +!----------------------------------------------------------------------- + IF (MOD(itau,iguide_int).EQ.0) THEN + CALL guide_interp(ps,teta) + ENDIF +! Repartition entre 2 etats de guidage + IF (iguide_read.NE.0) THEN + tau=reste + ELSE + tau=1. + ENDIF + +!----------------------------------------------------------------------- +! Ajout des champs de guidage +!----------------------------------------------------------------------- +! Sauvegarde du guidage? + f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav) + IF (f_out) CALL guide_out("S",jjp1,1,ps) + + if (guide_u) then + if (guide_add) then + f_add=(1.-tau)*ugui1+tau*ugui2 + else + f_add=(1.-tau)*ugui1+tau*ugui2-ucov + endif + if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u) + IF (f_out) CALL guide_out("U",jjp1,llm,f_add/factt) + ucov=ucov+f_add + endif + + if (guide_T) then + if (guide_add) then + f_add=(1.-tau)*tgui1+tau*tgui2 + else + f_add=(1.-tau)*tgui1+tau*tgui2-teta + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T) + IF (f_out) CALL guide_out("T",jjp1,llm,f_add/factt) + teta=teta+f_add + endif + + if (guide_P) then + if (guide_add) then + f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2 + else + f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2-ps + endif + if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1)) + CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P) + IF (f_out) CALL guide_out("P",jjp1,1,f_add(1:ip1jmp1,1)/factt) + ps=ps+f_add(1:ip1jmp1,1) + CALL pression(ip1jmp1,ap,bp,ps,p) + CALL massdair(p,masse) + endif + + if (guide_Q) then + if (guide_add) then + f_add=(1.-tau)*qgui1+tau*qgui2 + else + f_add=(1.-tau)*qgui1+tau*qgui2-q + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q) + IF (f_out) CALL guide_out("Q",jjp1,llm,f_add/factt) + q=q+f_add + endif + + if (guide_v) then + if (guide_add) then + f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2 + else + f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2-vcov + endif + if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:)) + CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v) + IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:)/factt) + vcov=vcov+f_add(1:ip1jm,:) + endif + END SUBROUTINE guide_main + +!======================================================================= + SUBROUTINE guide_addfield(hsize,vsize,field,alpha) +! field1=a*field1+alpha*field2 + + IMPLICIT NONE + + ! input variables + INTEGER, INTENT(IN) :: hsize + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(hsize), INTENT(IN) :: alpha + REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field + + ! Local variables + INTEGER :: l + + do l=1,vsize + field(:,l)=alpha*field(:,l)*alpha_pcor(l) + enddo + + END SUBROUTINE guide_addfield + +!======================================================================= + SUBROUTINE guide_zonave(typ,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comgeom.h" + INCLUDE "comconst.h" + + ! input/output variables + INTEGER, INTENT(IN) :: typ + INTEGER, INTENT(IN) :: vsize + INTEGER, INTENT(IN) :: hsize + REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field + + ! Local variables + LOGICAL, SAVE :: first=.TRUE. + INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain + INTEGER :: i,j,l,ij + REAL, DIMENSION (iip1) :: lond ! longitude in Deg. + REAL, DIMENSION (hsize,vsize):: fieldm ! zon-averaged field + + IF (first) THEN + first=.FALSE. +!Compute domain for averaging + lond=rlonu*180./pi + imin(1)=1;imax(1)=iip1; + imin(2)=1;imax(2)=iip1; + IF (guide_reg) THEN + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(1)=i + IF (lond(i).LE.lon_max_g) imax(1)=i + ENDDO + lond=rlonv*180./pi + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(2)=i + IF (lond(i).LE.lon_max_g) imax(2)=i + ENDDO + ENDIF + ENDIF + + fieldm=0. + DO l=1,vsize + ! Compute zonal average + DO j=1,hsize + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=1,hsize + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE guide_zonave + +!======================================================================= + SUBROUTINE guide_interp(psi,teta) + + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comgeom2.h" + include "comconst.h" + + REAL, DIMENSION (iip1,jjp1), INTENT(IN) :: psi ! Psol gcm + REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm + + LOGICAL, SAVE :: first=.TRUE. + ! Variables pour niveaux pression: + REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage + REAL, DIMENSION (iip1,jjp1,llm) :: plunc,plsnc !niveaux pression modele + REAL, DIMENSION (iip1,jjm,llm) :: plvnc !niveaux pression modele + REAL, DIMENSION (iip1,jjp1,llmp1) :: p ! pression intercouches + REAL, DIMENSION (iip1,jjp1,llm) :: pls, pext ! var intermediaire + REAL, DIMENSION (iip1,jjp1,llm) :: pbarx + REAL, DIMENSION (iip1,jjm,llm) :: pbary + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf + REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta + REAL, DIMENSION (iip1,jjp1) :: pks + REAL :: prefkap,unskap + ! Pression de vapeur saturante + REAL, DIMENSION (ip1jmp1,llm) :: qsat + !Variables intermediaires interpolation + REAL, DIMENSION (iip1,jjp1,llm) :: zu1,zu2 + REAL, DIMENSION (iip1,jjm,llm) :: zv1,zv2 + + INTEGER :: i,j,l,ij + + print *,'Guide: conversion variables guidage' +! ----------------------------------------------------------------- +! Calcul des niveaux de pression champs guidage +! ----------------------------------------------------------------- +if (guide_modele) then + do i=1,iip1 + do j=1,jjp1 + do l=1,nlevnc + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + enddo + enddo + enddo +else + do i=1,iip1 + do j=1,jjp1 + do l=1,nlevnc + plnc2(i,j,l)=apnc(l) + plnc1(i,j,l)=apnc(l) + enddo + enddo + enddo + +endif + if (first) then + first=.FALSE. + print*,'Guide: verification ordre niveaux verticaux' + print*,'LMDZ :' + do l=1,llm + print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. & + +psi(1,jjp1)*(bp(l)+bp(l+1))/2. + enddo + print*,'Fichiers guidage' + do l=1,nlevnc + print*,'PL(',l,')=',plnc2(1,1,l) + enddo + print *,'inversion de l''ordre: invert_p=',invert_p + if (guide_u) then + do l=1,nlevnc + print*,'U(',l,')=',unat2(1,1,l) + enddo + endif + if (guide_T) then + do l=1,nlevnc + print*,'T(',l,')=',tnat2(1,1,l) + enddo + endif + endif + +! ----------------------------------------------------------------- +! Calcul niveaux pression modele +! ----------------------------------------------------------------- + CALL pression( ip1jmp1, ap, bp, psi, p ) + if (disvert_type==1) then + CALL exner_hyb(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu(ip1jmp1,psi,p,beta,pks,pk,pkf) + endif +! .... Calcul de pls , pression au milieu des couches ,en Pascals + unskap=1./kappa + prefkap = preff ** kappa + DO l = 1, llm + DO j=1,jjp1 + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + +! calcul des pressions pour les grilles u et v + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + pext(i,j,l)=pls(i,j,l)*aire(i,j) + enddo + enddo + enddo + call massbar(pext, pbarx, pbary ) + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j) + plsnc(i,j,l)=pls(i,j,l) + enddo + enddo + enddo + do l=1,llm + do j=1,jjm + do i=1,iip1 + plvnc(i,j,l)=pbary(i,j,l)/airev(i,j) + enddo + enddo + enddo + +! ----------------------------------------------------------------- +! Interpolation champs guidage sur niveaux modele (+inversion N/S) +! Conversion en variables gcm (ucov, vcov...) +! ----------------------------------------------------------------- + if (guide_P) then + do j=1,jjp1 + do i=1,iim + ij=(j-1)*iip1+i + psgui1(ij)=psnat1(i,j) + psgui2(ij)=psnat2(i,j) + enddo + psgui1(iip1*j)=psnat1(1,j) + psgui2(iip1*j)=psnat2(1,j) + enddo + endif + + IF (guide_u) THEN + CALL pres2lev(unat1,zu1,nlevnc,llm,plnc1,plunc,iip1,jjp1,invert_p) + CALL pres2lev(unat2,zu2,nlevnc,llm,plnc2,plunc,iip1,jjp1,invert_p) + do l=1,llm + do j=1,jjp1 + do i=1,iim + ij=(j-1)*iip1+i + ugui1(ij,l)=zu1(i,j,l)*cu(i,j) + ugui2(ij,l)=zu2(i,j,l)*cu(i,j) + enddo + ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l) + ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + ugui1(i,l)=0. + ugui1(ip1jm+i,l)=0. + ugui2(i,l)=0. + ugui2(ip1jm+i,l)=0. + enddo + enddo + ENDIF + + IF (guide_T) THEN + CALL pres2lev(tnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p) + CALL pres2lev(tnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p) + do l=1,llm + do j=1,jjp1 + IF (guide_teta) THEN + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l) + tgui2(ij,l)=zu2(i,j,l) + enddo + ELSE + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l) + tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l) + enddo + ENDIF + tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l) + tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + tgui1(i,l)=tgui1(1,l) + tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) + tgui2(i,l)=tgui2(1,l) + tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) + enddo + enddo + ENDIF + + IF (guide_v) THEN + + CALL pres2lev(vnat1,zv1,nlevnc,llm,plnc1(:,:jjm,:),plvnc,iip1,jjm,invert_p) + CALL pres2lev(vnat2,zv2,nlevnc,llm,plnc2(:,:jjm,:),plvnc,iip1,jjm,invert_p) + + do l=1,llm + do j=1,jjm + do i=1,iim + ij=(j-1)*iip1+i + vgui1(ij,l)=zv1(i,j,l)*cv(i,j) + vgui2(ij,l)=zv2(i,j,l)*cv(i,j) + enddo + vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l) + vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l) + enddo + enddo + ENDIF + + IF (guide_Q) THEN + ! On suppose qu'on a la bonne variable dans le fichier de guidage: + ! Hum.Rel si guide_hr, Hum.Spec. sinon. + CALL pres2lev(qnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p) + CALL pres2lev(qnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p) + do l=1,llm + do j=1,jjp1 + do i=1,iim + ij=(j-1)*iip1+i + qgui1(ij,l)=zu1(i,j,l) + qgui2(ij,l)=zu2(i,j,l) + enddo + qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l) + qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + qgui1(i,l)=qgui1(1,l) + qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) + qgui2(i,l)=qgui2(1,l) + qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) + enddo + enddo + IF (guide_hr) THEN + CALL q_sat(iip1*jjp1*llm,teta*pk/cpp,plsnc,qsat) + qgui1=qgui1*qsat*0.01 !hum. rel. en % + qgui2=qgui2*qsat*0.01 + ENDIF + ENDIF + + END SUBROUTINE guide_interp + +!======================================================================= + SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha) + +! Calcul des constantes de rappel alpha (=1/tau) + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + include "serre.h" + +! input arguments : + INTEGER, INTENT(IN) :: typ ! u(2),v(3), ou scalaire(1) + INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon + REAL, INTENT(IN) :: factt ! pas de temps en fraction de jour + REAL, INTENT(IN) :: taumin,taumax +! output arguments: + REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha + +! local variables: + LOGICAL, SAVE :: first=.TRUE. + REAL, SAVE :: gamma,dxdy_min,dxdy_max + REAL, DIMENSION (iip1,jjp1) :: zdx,zdy + REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu + REAL, DIMENSION (iip1,jjm) :: dxdyv + real dxdy_ + real zlat,zlon + real alphamin,alphamax,xi + integer i,j,ilon,ilat + + + alphamin=factt/taumax + alphamax=factt/taumin + IF (guide_reg.OR.guide_add) THEN + alpha=alphamax +!----------------------------------------------------------------------- +! guide_reg: alpha=alpha_min dans region, 0. sinon. +!----------------------------------------------------------------------- + IF (guide_reg) THEN + do j=1,pjm + do i=1,pim + if (typ.eq.2) then + zlat=rlatu(j)*180./pi + zlon=rlonu(i)*180./pi + elseif (typ.eq.1) then + zlat=rlatu(j)*180./pi + zlon=rlonv(i)*180./pi + elseif (typ.eq.3) then + zlat=rlatv(j)*180./pi + zlon=rlonv(i)*180./pi + endif + alpha(i,j)=alphamax/16.* & + (1.+tanh((zlat-lat_min_g)/tau_lat))* & + (1.+tanh((lat_max_g-zlat)/tau_lat))* & + (1.+tanh((zlon-lon_min_g)/tau_lon))* & + (1.+tanh((lon_max_g-zlon)/tau_lon)) + enddo + enddo + ENDIF + ELSE +!----------------------------------------------------------------------- +! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom. +!----------------------------------------------------------------------- +!Calcul de l'aire des mailles + do j=2,jjm + do i=2,iip1 + zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j)) + enddo + zdx(1,j)=zdx(iip1,j) + enddo + do j=2,jjm + do i=1,iip1 + zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j)) + enddo + enddo + do i=1,iip1 + zdx(i,1)=zdx(i,2) + zdx(i,jjp1)=zdx(i,jjm) + zdy(i,1)=zdy(i,2) + zdy(i,jjp1)=zdy(i,jjm) + enddo + do j=1,jjp1 + do i=1,iip1 + dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j)) + enddo + enddo + IF (typ.EQ.2) THEN + do j=1,jjp1 + do i=1,iim + dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) + enddo + dxdyu(iip1,j)=dxdyu(1,j) + enddo + ENDIF + IF (typ.EQ.3) THEN + do j=1,jjm + do i=1,iip1 + dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1)) + enddo + enddo + ENDIF +! Premier appel: calcul des aires min et max et de gamma. + IF (first) THEN + first=.FALSE. + ! coordonnees du centre du zoom + CALL coordij(clon,clat,ilon,ilat) + ! aire de la maille au centre du zoom + dxdy_min=dxdys(ilon,ilat) + ! dxdy maximale de la maille + dxdy_max=0. + do j=1,jjp1 + do i=1,iip1 + dxdy_max=max(dxdy_max,dxdys(i,j)) + enddo + enddo + ! Calcul de gamma + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + print*,'ATTENTION modele peu zoome' + print*,'ATTENTION on prend une constante de guidage cste' + gamma=0. + else + gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min) + print*,'gamma=',gamma + if (gamma.lt.1.e-5) then + print*,'gamma =',gamma,'<1e-5' + stop + endif + gamma=log(0.5)/log(gamma) + if (gamma4) then + gamma=min(gamma,4.) + endif + print*,'gamma=',gamma + endif + ENDIF !first + + do j=1,pjm + do i=1,pim + if (typ.eq.1) then + dxdy_=dxdys(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.2) then + dxdy_=dxdyu(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.3) then + dxdy_=dxdyv(i,j) + zlat=rlatv(j)*180./pi + endif + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin + alpha(i,j)=alphamin + else + xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma + xi=min(xi,1.) + if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then + alpha(i,j)=xi*alphamin+(1.-xi)*alphamax + else + alpha(i,j)=0. + endif + endif + enddo + enddo + ENDIF ! guide_reg + + END SUBROUTINE tau2alpha + +!======================================================================= + SUBROUTINE guide_read(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=iip1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,unat2) + ENDIF + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,nlevnc,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read + +!======================================================================= + SUBROUTINE guide_read2D(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode +! Variables for 3D extension: + REAL, DIMENSION (jjp1,llm) :: zu + REAL, DIMENSION (jjm,llm) :: zv + INTEGER :: i + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu) +#endif + DO i=1,iip1 + unat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu) +#endif + DO i=1,iip1 + tnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,tnat2) + ENDIF + + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu) +#endif + DO i=1,iip1 + qnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv) +#endif + DO i=1,iip1 + vnat2(i,:,:)=zv(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,nlevnc,vnat2) + ENDIF + + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1)) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1)) +#endif + DO i=1,iip1 + psnat2(i,:)=zu(:,1) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + + endif + + END SUBROUTINE guide_read2D + +!======================================================================= + SUBROUTINE guide_out(varname,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "comgeom2.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + CHARACTER, INTENT(IN) :: varname + INTEGER, INTENT (IN) :: hsize,vsize + REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field + + ! Variables locales + INTEGER, SAVE :: timestep=0 + ! Identites fichier netcdf + INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev + INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev + INTEGER, DIMENSION (3) :: dim3 + INTEGER, DIMENSION (4) :: dim4,count,start + INTEGER :: ierr, varid + + print *,'Guide: output timestep',timestep,'var ',varname + IF (timestep.EQ.0) THEN +! ---------------------------------------------- +! initialisation fichier de sortie +! ---------------------------------------------- +! Ouverture du fichier + ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid) +! Definition des dimensions + ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) + ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) + ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) + ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) + ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev) + ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim) + +! Creation des variables dimensions + ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu) + ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv) + ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu) + ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv) + ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev) + ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu) + ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv) + + ierr=NF_ENDDEF(nid) + +! Enregistrement des variables dimensions +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv) +#else + ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu) + ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv) +#endif +! -------------------------------------------------------------------- +! Cr�ation des variables sauvegard�es +! -------------------------------------------------------------------- + ierr = NF_REDEF(nid) +! Surface pressure (GCM) + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,3,dim3,varid) +! Surface pressure (guidage) + IF (guide_P) THEN + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid) + ENDIF +! Zonal wind + IF (guide_u) THEN + dim4=(/id_lonu,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid) + ENDIF +! Merid. wind + IF (guide_v) THEN + dim4=(/id_lonv,id_latv,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid) + ENDIF +! Pot. Temperature + IF (guide_T) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid) + ENDIF +! Specific Humidity + IF (guide_Q) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid) + ENDIF + + ierr = NF_ENDDEF(nid) + ierr = NF_CLOSE(nid) + ENDIF ! timestep=0 + +! -------------------------------------------------------------------- +! Enregistrement du champ +! -------------------------------------------------------------------- + ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid) + + SELECT CASE (varname) + CASE ("S") + timestep=timestep+1 + ierr = NF_INQ_VARID(nid,"SP",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("P") + ierr = NF_INQ_VARID(nid,"ps",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("U") + ierr = NF_INQ_VARID(nid,"ucov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("V") + ierr = NF_INQ_VARID(nid,"vcov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjm,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("T") + ierr = NF_INQ_VARID(nid,"teta",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("Q") + ierr = NF_INQ_VARID(nid,"q",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + END SELECT + + ierr = NF_CLOSE(nid) + + END SUBROUTINE guide_out + + +!=========================================================================== + subroutine correctbid(iim,nl,x) + integer iim,nl + real x(iim+1,nl) + integer i,l + real zz + + do l=1,nl + do i=2,iim-1 + if(abs(x(i,l)).gt.1.e10) then + zz=0.5*(x(i-1,l)+x(i+1,l)) + print*,'correction ',i,l,x(i,l),zz + x(i,l)=zz + endif + enddo + enddo + return + end subroutine correctbid + +!=========================================================================== +END MODULE guide_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/heavyside.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/heavyside.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/heavyside.F (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! +c +c + FUNCTION heavyside(a) + +c ... P. Le Van .... +c + IMPLICIT NONE + + REAL(KIND=8) heavyside , a + + IF ( a.LE.0. ) THEN + heavyside = 0. + ELSE + heavyside = 1. + ENDIF + + RETURN + END + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/infotrac.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/infotrac.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/infotrac.F90 (revision 1634) @@ -0,0 +1,352 @@ +! $Id$ +! +MODULE infotrac + +! nqtot : total number of tracers and higher order of moment, water vapor and liquid included + INTEGER, SAVE :: nqtot + +! nbtr : number of tracers not including higher order of moment or water vapor or liquid +! number of tracers used in the physics + INTEGER, SAVE :: nbtr + +! Name variables + CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics + CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics + +! iadv : index of trasport schema for each tracer + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: iadv + +! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the +! dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: niadv ! equivalent dyn / physique + +! conv_flg(it)=0 : convection desactivated for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: conv_flg +! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: pbl_flg + + CHARACTER(len=4),SAVE :: type_trac + +CONTAINS + + SUBROUTINE infotrac_init + USE control_mod + IMPLICIT NONE +!======================================================================= +! +! Auteur: P. Le Van /L. Fairhead/F.Hourdin +! ------- +! Modif special traceur F.Forget 05/94 +! Modif M-A Filiberti 02/02 lecture de traceur.def +! +! Objet: +! ------ +! GCM LMD nouvelle grille +! +!======================================================================= +! ... modification de l'integration de q ( 26/04/94 ) .... +!----------------------------------------------------------------------- +! Declarations + + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" + +! Local variables + INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv ! index of horizontal trasport schema + INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv ! index of vertical trasport schema + + CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0 ! tracer short name + CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA + CHARACTER(len=3), DIMENSION(30) :: descrq + CHARACTER(len=1), DIMENSION(3) :: txts + CHARACTER(len=2), DIMENSION(9) :: txtp + CHARACTER(len=23) :: str1,str2 + + INTEGER :: nqtrue ! number of tracers read from tracer.def, without higer order of moment + INTEGER :: iq, new_iq, iiq, jq, ierr + + character(len=*),parameter :: modname="infotrac_init" +!----------------------------------------------------------------------- +! Initialization : +! + txts=(/'x','y','z'/) + txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/) + + descrq(14)='VLH' + descrq(10)='VL1' + descrq(11)='VLP' + descrq(12)='FH1' + descrq(13)='FH2' + descrq(16)='PPM' + descrq(17)='PPS' + descrq(18)='PPP' + descrq(20)='SLP' + descrq(30)='PRA' + + + IF (config_inca=='none') THEN + type_trac='lmdz' + ELSE + type_trac='inca' + END IF + +!----------------------------------------------------------------------- +! +! 1) Get the true number of tracers + water vapor/liquid +! Here true tracers (nqtrue) means declared tracers (only first order) +! +!----------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr) + IF(ierr.EQ.0) THEN + WRITE(lunout,*) trim(modname),': Open traceur.def : ok' + READ(90,*) nqtrue + ELSE + WRITE(lunout,*) trim(modname),': Problem in opening traceur.def' + WRITE(lunout,*) trim(modname),': WARNING using defaut values' + if (planet_type=='earth') then + nqtrue=4 ! Default value for Earth + else + nqtrue=1 ! Default value for other planets + endif + END IF + if ( planet_type=='earth') then + ! For Earth, water vapour & liquid tracers are not in the physics + nbtr=nqtrue-2 + else + ! Other planets (for now); we have the same number of tracers + ! in the dynamics than in the physics + nbtr=nqtrue + endif + ELSE + ! nbtr has been read from INCA by init_cont_lmdz() in gcm.F + nqtrue=nbtr+2 + END IF + + IF ((planet_type=="earth").and.(nqtrue < 2)) THEN + WRITE(lunout,*) trim(modname),': nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum' + CALL abort_gcm('infotrac_init','Not enough tracers',1) + END IF +! +! Allocate variables depending on nqtrue and nbtr +! + ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue)) + ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr)) + conv_flg(:) = 1 ! convection activated for all tracers + pbl_flg(:) = 1 ! boundary layer activated for all tracers + +!----------------------------------------------------------------------- +! 2) Choix des schemas d'advection pour l'eau et les traceurs +! +! iadv = 1 schema transport type "humidite specifique LMD" +! iadv = 2 schema amont +! iadv = 14 schema Van-leer + humidite specifique +! Modif F.Codron +! iadv = 10 schema Van-leer (retenu pour l'eau vapeur et liquide) +! iadv = 11 schema Van-Leer pour hadv et version PPM (Monotone) pour vadv +! iadv = 12 schema Frederic Hourdin I +! iadv = 13 schema Frederic Hourdin II +! iadv = 16 schema PPM Monotone(Collela & Woodward 1984) +! iadv = 17 schema PPM Semi Monotone (overshoots autorisés) +! iadv = 18 schema PPM Positif Defini (overshoots undershoots autorisés) +! iadv = 20 schema Slopes +! iadv = 30 schema Prather +! +! Dans le tableau q(ij,l,iq) : iq = 1 pour l'eau vapeur +! iq = 2 pour l'eau liquide +! Et eventuellement iq = 3,nqtot pour les autres traceurs +! +! iadv(1): choix pour l'eau vap. et iadv(2) : choix pour l'eau liq. +!------------------------------------------------------------------------ +! +! Get choice of advection schema from file tracer.def or from INCA +!--------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + IF(ierr.EQ.0) THEN + ! Continue to read tracer.def + DO iq=1,nqtrue + READ(90,*) hadv(iq),vadv(iq),tnom_0(iq) + END DO + CLOSE(90) + ELSE ! Without tracer.def, set default values + if (planet_type=="earth") then + ! for Earth, default is to have 4 tracers + hadv(1) = 14 + vadv(1) = 14 + tnom_0(1) = 'H2Ov' + hadv(2) = 10 + vadv(2) = 10 + tnom_0(2) = 'H2Ol' + hadv(3) = 10 + vadv(3) = 10 + tnom_0(3) = 'RN' + hadv(4) = 10 + vadv(4) = 10 + tnom_0(4) = 'PB' + else ! default for other planets + hadv(1) = 10 + vadv(1) = 10 + tnom_0(1) = 'dummy' + endif ! of if (planet_type=="earth") + END IF + + WRITE(lunout,*) trim(modname),': Valeur de traceur.def :' + WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue + DO iq=1,nqtrue + WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq) + END DO + + ELSE ! type_trac=inca : config_inca='aero' ou 'chem' +! le module de chimie fournit les noms des traceurs +! et les schemas d'advection associes. + +#ifdef INCA + CALL init_transport( & + hadv, & + vadv, & + conv_flg, & + pbl_flg, & + tracnam) +#endif + tnom_0(1)='H2Ov' + tnom_0(2)='H2Ol' + + DO iq =3,nqtrue + tnom_0(iq)=tracnam(iq-2) + END DO + + END IF ! type_trac + +!----------------------------------------------------------------------- +! +! 3) Verify if advection schema 20 or 30 choosen +! Calculate total number of tracers needed: nqtot +! Allocate variables depending on total number of tracers +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + ! Add tracers for certain advection schema + IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN + new_iq=new_iq+1 ! no tracers added + ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN + new_iq=new_iq+4 ! 3 tracers added + ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN + new_iq=new_iq+10 ! 9 tracers added + ELSE + WRITE(lunout,*) trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq) + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1) + END IF + END DO + + IF (new_iq /= nqtrue) THEN + ! The choice of advection schema imposes more tracers + ! Assigne total number of tracers + nqtot = new_iq + + WRITE(lunout,*) trim(modname),': The choice of advection schema for one or more tracers' + WRITE(lunout,*) 'makes it necessary to add tracers' + WRITE(lunout,*) trim(modname)//': ',nqtrue,' is the number of true tracers' + WRITE(lunout,*) trim(modname)//': ',nqtot, ' is the total number of tracers needed' + + ELSE + ! The true number of tracers is also the total number + nqtot = nqtrue + END IF + +! +! Allocate variables with total number of tracers, nqtot +! + ALLOCATE(tname(nqtot), ttext(nqtot)) + ALLOCATE(iadv(nqtot), niadv(nqtot)) + +!----------------------------------------------------------------------- +! +! 4) Determine iadv, long and short name +! +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + new_iq=new_iq+1 + + ! Verify choice of advection schema + IF (hadv(iq)==vadv(iq)) THEN + iadv(new_iq)=hadv(iq) + ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN + iadv(new_iq)=11 + ELSE + WRITE(lunout,*)trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq) + + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1) + END IF + + str1=tnom_0(iq) + tname(new_iq)= tnom_0(iq) + IF (iadv(new_iq)==0) THEN + ttext(new_iq)=trim(str1) + ELSE + ttext(new_iq)=trim(tnom_0(iq))//descrq(iadv(new_iq)) + END IF + + ! schemas tenant compte des moments d'ordre superieur + str2=ttext(new_iq) + IF (iadv(new_iq)==20) THEN + DO jq=1,3 + new_iq=new_iq+1 + iadv(new_iq)=-20 + ttext(new_iq)=trim(str2)//txts(jq) + tname(new_iq)=trim(str1)//txts(jq) + END DO + ELSE IF (iadv(new_iq)==30) THEN + DO jq=1,9 + new_iq=new_iq+1 + iadv(new_iq)=-30 + ttext(new_iq)=trim(str2)//txtp(jq) + tname(new_iq)=trim(str1)//txtp(jq) + END DO + END IF + END DO + +! +! Find vector keeping the correspodence between true and total tracers +! + niadv(:)=0 + iiq=0 + DO iq=1,nqtot + IF(iadv(iq).GE.0) THEN + ! True tracer + iiq=iiq+1 + niadv(iiq)=iq + ENDIF + END DO + + + WRITE(lunout,*) trim(modname),': Information stored in infotrac :' + WRITE(lunout,*) trim(modname),': iadv niadv tname ttext :' + DO iq=1,nqtot + WRITE(lunout,*) iadv(iq),niadv(iq),& + ' ',trim(tname(iq)),' ',trim(ttext(iq)) + END DO + +! +! Test for advection schema. +! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) . +! + DO iq=1,nqtot + IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN + WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1) + ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN + WRITE(lunout,*)trim(modname),'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1) + END IF + END DO + +!----------------------------------------------------------------------- +! Finalize : +! + DEALLOCATE(tnom_0, hadv, vadv) + DEALLOCATE(tracnam) + + END SUBROUTINE infotrac_init + +END MODULE infotrac Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ini_paramLMDZ_dyn.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ini_paramLMDZ_dyn.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ini_paramLMDZ_dyn.h (revision 1634) @@ -0,0 +1,214 @@ +c + dt_cum = dtvr*day_step + +! zan = annee_ref +! dayref = day_ref +! CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn +c + pi = 4.0 * ATAN(1.0) + degres = 180./pi + rlong = rlonu * degres + rlatg = rlatu * degres +c + CALL histbeg("paramLMDZ_dyn.nc", + . iip1,rlong, jjp1,rlatg, + . 1,1,1,1, + . tau0, jD_ref+jH_ref , dt_cum, + . thoriid, nid_ctesGCM) +c + CALL histdef(nid_ctesGCM, "prt_level", + . "Niveau impression debuggage dynamique", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "dayref", + . "Jour de l etat initial ( = 350 si 20 Decembre par ex.)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "anneeref", + . "Annee de l etat initial", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "anneelim", + . "Annee du fichier limitxxxx.nc si ok_limitvrai =y", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "raz_date", + . "Remise a zero (raz) date init.: 0 pas de raz;1=date gcm.def", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "nday", + . "Nombre de jours d integration", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "day_step", + . "nombre de pas par jour pour dt = 1 min", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iperiod", + . "periode pour le pas Matsuno (en pas de temps)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iapp_tracvl", + . "frequence du groupement des flux (en pas de temps)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iconser", + . "periode de sortie des variables de controle (en pas de temps)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iecri", + . "periode d ecriture du fichier histoire (en jour)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "periodav", + . "periode de stockage fichier histmoy (en jour)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "dissip_period", + . "periode de la dissipation (en pas) ... a completer", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "lstardis", + . "choix de l operateur de dissipation: 1= star,0=non-star ??", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "nitergdiv", + . "nombre d iterations de l operateur de dissipation gradiv", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "nitergrot", + . "nombre d iterations de l operateur de dissipation nxgradrot", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "niterh", + . "nombre d iterations de l operateur de dissipation divgrad", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tetagdiv", + ."temps dissipation des + petites long. d ondes pour u,v (gradiv)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tetagrot", + ."temps diss. des + petites long. d ondes pour u,v (nxgradrot)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tetatemp", + ."temps diss. des + petites long. d ondes pour h (divgrad)", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "coefdis", + ."coefficient pour gamdissip", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "purmats", + ."Choix schema integration temporel: 1=Matsuno,0=Matsuno-leapfrog", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "ok_guide", + ."Guidage: 1=true ,0=false", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "true_calendar", + ."Choix du calendrier", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "guide_calend", + ."Guidage calendrier gregorien: 1=oui ,0=non", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iflag_phys", + ."Permet de faire tourner le modele sans physique: 1=avec ,0=sans", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "iphysiq", + ."Periode de la physique en pas de temps de la dynamique", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "clon", + ."longitude en degres du centre du zoom", + . "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "clat", + ."latitude en degres du centre du zoom", + . "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "grossismx", + ."facteur de grossissement du zoom, selon la longitude", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "grossismy", + ."facteur de grossissement du zoom, selon la latitude", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "fxyhypb", + ."Fonction f(y) hyperbolique si true=1, sinusoidale si false=0", + . "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "dzoomx", + ."extension en longitude de la zone du zoom (fraction zone totale)" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "dzoomy", + ."extension en latitude de la zone du zoom (fraction zone totale)" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "taux", + ."raideur du zoom en X" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "tauy", + ."raideur du zoom en Y" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "ysinus", + ."ysinus=1: Ftion f(y) avec y=Sin(latit.)/ ysinus=0: y = latit" + . ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c + CALL histdef(nid_ctesGCM, "ip_ebil_dyn", + ."PRINTlevel for energy conservation diag.; 0/1= pas de print, + . 2= print","-",iip1,jjp1,thoriid, 1,1,1, -99, 32, + . "once", dt_cum,dt_cum) +c +c================================================================= +c + CALL histend(nid_ctesGCM) +c +c================================================================= Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniacademic.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniacademic.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniacademic.F90 (revision 1634) @@ -0,0 +1,276 @@ +! +! $Id$ +! +SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + + USE filtreg_mod + USE infotrac, ONLY : nqtot + USE control_mod, ONLY: day_step,planet_type +#ifdef CPP_IOIPSL + USE IOIPSL +#else + ! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + USE Write_Field + + ! Author: Frederic Hourdin original: 15/01/93 + ! The forcing defined here is from Held and Suarez, 1994, Bulletin + ! of the American Meteorological Society, 75, 1825. + + IMPLICIT NONE + + ! Declararations: + ! --------------- + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comconst.h" + include "comgeom.h" + include "academic.h" + include "ener.h" + include "temps.h" + include "iniprint.h" + include "logic.h" + + ! Arguments: + ! ---------- + + real time_0 + + ! variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm,nqtot) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + + ! Local: + ! ------ + + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL ddsin,zsig,tetapv,w_pv ! variables auxiliaires + real tetastrat ! potential temperature in the stratosphere, in K + real tetajl(jjp1,llm) + INTEGER i,j,l,lsup,ij + + REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T + REAL k_f,k_c_a,k_c_s ! Constantes de rappel + LOGICAL ok_geost ! Initialisation vent geost. ou nul + LOGICAL ok_pv ! Polar Vortex + REAL phi_pv,dphi_pv,gam_pv ! Constantes pour polar vortex + + real zz,ran1 + integer idum + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr + + character(len=*),parameter :: modname="iniacademic" + character(len=80) :: abort_message + + !----------------------------------------------------------------------- + ! 1. Initializations for Earth-like case + ! -------------------------------------- + ! + ! initialize planet radius, rotation rate,... + call conf_planete + + time_0=0. + day_ref=1 + annee_ref=0 + + im = iim + jm = jjm + day_ini = 1 + dtvr = daysec/REAL(day_step) + zdtvr=dtvr + etot0 = 0. + ptot0 = 0. + ztot0 = 0. + stot0 = 0. + ang0 = 0. + + if (llm == 1) then + ! specific initializations for the shallow water case + kappa=1 + endif + + CALL iniconst + CALL inigeom + CALL inifilr + + if (llm == 1) then + ! initialize fields for the shallow water case, if required + if (.not.read_start) then + phis(:)=0. + q(:,:,:)=0 + CALL sw_case_williamson91_6(vcov,ucov,teta,masse,ps) + endif + endif + + academic_case: if (iflag_phys >= 2) then + ! initializations + + ! 1. local parameters + ! by convention, winter is in the southern hemisphere + ! Geostrophic wind or no wind? + ok_geost=.TRUE. + CALL getin('ok_geost',ok_geost) + ! Constants for Newtonian relaxation and friction + k_f=1. !friction + CALL getin('k_j',k_f) + k_f=1./(daysec*k_f) + k_c_s=4. !cooling surface + CALL getin('k_c_s',k_c_s) + k_c_s=1./(daysec*k_c_s) + k_c_a=40. !cooling free atm + CALL getin('k_c_a',k_c_a) + k_c_a=1./(daysec*k_c_a) + ! Constants for Teta equilibrium profile + teta0=315. ! mean Teta (S.H. 315K) + CALL getin('teta0',teta0) + ttp=200. ! Tropopause temperature (S.H. 200K) + CALL getin('ttp',ttp) + eps=0. ! Deviation to N-S symmetry(~0-20K) + CALL getin('eps',eps) + delt_y=60. ! Merid Temp. Gradient (S.H. 60K) + CALL getin('delt_y',delt_y) + delt_z=10. ! Vertical Gradient (S.H. 10K) + CALL getin('delt_z',delt_z) + ! Polar vortex + ok_pv=.false. + CALL getin('ok_pv',ok_pv) + phi_pv=-50. ! Latitude of edge of vortex + CALL getin('phi_pv',phi_pv) + phi_pv=phi_pv*pi/180. + dphi_pv=5. ! Width of the edge + CALL getin('dphi_pv',dphi_pv) + dphi_pv=dphi_pv*pi/180. + gam_pv=4. ! -dT/dz vortex (in K/km) + CALL getin('gam_pv',gam_pv) + + ! 2. Initialize fields towards which to relax + ! Friction + knewt_g=k_c_a + DO l=1,llm + zsig=presnivs(l)/preff + knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3) + kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3) + ENDDO + DO j=1,jjp1 + clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4 + ENDDO + + ! Potential temperature + DO l=1,llm + zsig=presnivs(l)/preff + tetastrat=ttp*zsig**(-kappa) + tetapv=tetastrat + IF ((ok_pv).AND.(zsig.LT.0.1)) THEN + tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g) + ENDIF + DO j=1,jjp1 + ! Troposphere + ddsin=sin(rlatu(j)) + tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin & + -delt_z*(1.-ddsin*ddsin)*log(zsig) + if (planet_type=="giant") then + tetajl(j,l)=teta0+(delt_y* & + ((sin(rlatu(j)*3.14159*eps+0.0001))**2) & + / ((rlatu(j)*3.14159*eps+0.0001)**2)) & + -delt_z*log(zsig) + endif + ! Profil stratospherique isotherme (+vortex) + w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2. + tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv + tetajl(j,l)=MAX(tetajl(j,l),tetastrat) + ENDDO + ENDDO + + ! CALL writefield('theta_eq',tetajl) + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + ij=(j-1)*iip1+i + tetarappel(ij,l)=tetajl(j,l) + enddo + enddo + enddo + + ! 3. Initialize fields (if necessary) + IF (.NOT. read_start) THEN + ! surface pressure + if (iflag_phys>2) then + ps(:)=preff + else + ps(:)=101080. + endif + ! ground geopotential + phis(:)=0. + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (disvert_type.eq.1) then + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + elseif (disvert_type.eq.2) then + call exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf) + else + write(abort_message,*) "Wrong value for disvert_type: ", & + disvert_type + call abort_gcm(modname,abort_message,0) + endif + CALL massdair(p,masse) + + ! bulk initialization of temperature + teta(:,:)=tetarappel(:,:) + + ! geopotential + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + + ! winds + if (ok_geost) then + call ugeostr(phi,ucov) + else + ucov(:,:)=0. + endif + vcov(:,:)=0. + + ! bulk initialization of tracers + if (planet_type=="earth") then + ! Earth: first two tracers will be water + do i=1,nqtot + if (i == 1) q(:,:,i)=1.e-10 + if (i == 2) q(:,:,i)=1.e-15 + if (i.gt.2) q(:,:,i)=0. + enddo + else + q(:,:,:)=0 + endif ! of if (planet_type=="earth") + + ! add random perturbation to temperature + idum = -1 + zz = ran1(idum) + idum = 0 + do l=1,llm + do ij=iip2,ip1jm + teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum)) + enddo + enddo + + ! maintain periodicity in longitude + do l=1,llm + do ij=1,ip1jmp1,iip1 + teta(ij+iim,l)=teta(ij,l) + enddo + enddo + + ENDIF ! of IF (.NOT. read_start) + endif academic_case + +END SUBROUTINE iniacademic Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniconst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniconst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniconst.F (revision 1634) @@ -0,0 +1,84 @@ +! +! $Id$ +! + SUBROUTINE iniconst + + USE control_mod +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + + IMPLICIT NONE +c +c P. Le Van +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "temps.h" +#include "comvert.h" +#include "iniprint.h" + + character(len=*),parameter :: modname="iniconst" + character(len=80) :: abort_message +c +c +c +c----------------------------------------------------------------------- +c dimension des boucles: +c ---------------------- + + im = iim + jm = jjm + lllm = llm + imp1 = iim + jmp1 = jjm + 1 + lllmm1 = llm - 1 + lllmp1 = llm + 1 + +c----------------------------------------------------------------------- + + dtphys = iphysiq * dtvr + unsim = 1./iim + pi = 2.*ASIN( 1. ) + +c----------------------------------------------------------------------- +c + + r = cpp * kappa + + write(lunout,*) trim(modname),': R CP Kappa ',r,cpp,kappa +c +c----------------------------------------------------------------------- + +! vertical discretization: default behavior depends on planet_type flag + if (planet_type=="earth") then + disvert_type=1 + else + disvert_type=2 + endif + ! but user can also specify using one or the other in run.def: + call getin('disvert_type',disvert_type) + write(lunout,*) trim(modname),': disvert_type=',disvert_type + + if (disvert_type==1) then + ! standard case for Earth (automatic generation of levels) + call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig, + & scaleheight) + else if (disvert_type==2) then + ! standard case for planets (levels generated using z2sig.def file) + call disvert_noterre + else + write(abort_message,*) "Wrong value for disvert_type: ", + & disvert_type + call abort_gcm(modname,abort_message,0) + endif + + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inidissip.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inidissip.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inidissip.F90 (revision 1634) @@ -0,0 +1,232 @@ +! +! $Id$ +! +SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh , & + tetagdiv,tetagrot,tetatemp ) + !======================================================================= + ! initialisation de la dissipation horizontale + !======================================================================= + !----------------------------------------------------------------------- + ! declarations: + ! ------------- + + USE control_mod, only : dissip_period,iperiod + + IMPLICIT NONE + include "dimensions.h" + include "paramet.h" + include "comdissipn.h" + include "comconst.h" + include "comvert.h" + include "logic.h" + include "iniprint.h" + + LOGICAL,INTENT(in) :: lstardis + INTEGER,INTENT(in) :: nitergdiv,nitergrot,niterh + REAL,INTENT(in) :: tetagdiv,tetagrot,tetatemp + +! Local variables: + REAL fact,zvert(llm),zz + REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm) + REAL ullm,vllm,umin,vmin,zhmin,zhmax + REAL zllm,z1llm + + INTEGER l,ij,idum,ii + REAL tetamin + REAL pseudoz + character (len=80) :: abort_message + + REAL ran1 + + + !----------------------------------------------------------------------- + ! + ! calcul des valeurs propres des operateurs par methode iterrative: + ! ----------------------------------------------------------------- + + crot = -1. + cdivu = -1. + cdivh = -1. + + ! calcul de la valeur propre de divgrad: + ! -------------------------------------- + idum = 0 + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltap(ij,l) = 1. + ENDDO + ENDDO + + idum = -1 + zh(1) = RAN1(idum)-.5 + idum = 0 + DO ij = 2, ip1jmp1 + zh(ij) = RAN1(idum) -.5 + ENDDO + + CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1) + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + IF ( zhmin .GE. zhmax ) THEN + write(lunout,*)' Inidissip zh min max ',zhmin,zhmax + abort_message='probleme generateur alleatoire dans inidissip' + call abort_gcm('inidissip',abort_message,1) + ENDIF + + zllm = ABS( zhmax ) + DO l = 1,50 + IF(lstardis) THEN + CALL divgrad2(1,zh,deltap,niterh,zh) + ELSE + CALL divgrad (1,zh,niterh,zh) + ENDIF + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + zllm = ABS( zhmax ) + z1llm = 1./zllm + DO ij = 1,ip1jmp1 + zh(ij) = zh(ij)* z1llm + ENDDO + ENDDO + + IF(lstardis) THEN + cdivh = 1./ zllm + ELSE + cdivh = zllm ** ( -1./niterh ) + ENDIF + + ! calcul des valeurs propres de gradiv (ii =1) et nxgrarot(ii=2) + ! ----------------------------------------------------------------- + write(lunout,*)'inidissip: calcul des valeurs propres' + + DO ii = 1, 2 + ! + DO ij = 1, ip1jmp1 + zu(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1) + DO ij = 1, ip1jm + zv(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zv,jjm,1,2,1,.FALSE.,1) + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + DO l = 1, 50 + IF(ii.EQ.1) THEN + !cccc CALL covcont( 1,zu,zv,zu,zv ) + IF(lstardis) THEN + CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv ) + ELSE + CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv ) + ENDIF + ELSE + IF(lstardis) THEN + CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv ) + ELSE + CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv ) + ENDIF + ENDIF + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + zllm = MAX( ullm,vllm ) + z1llm = 1./ zllm + DO ij = 1, ip1jmp1 + zu(ij) = zu(ij)* z1llm + ENDDO + DO ij = 1, ip1jm + zv(ij) = zv(ij)* z1llm + ENDDO + end DO + + IF ( ii.EQ.1 ) THEN + IF(lstardis) THEN + cdivu = 1./zllm + ELSE + cdivu = zllm **( -1./nitergdiv ) + ENDIF + ELSE + IF(lstardis) THEN + crot = 1./ zllm + ELSE + crot = zllm **( -1./nitergrot ) + ENDIF + ENDIF + + end DO + + ! petit test pour les operateurs non star: + ! ---------------------------------------- + + ! IF(.NOT.lstardis) THEN + fact = rad*24./REAL(jjm) + fact = fact*fact + write(lunout,*)'inidissip: coef u ', fact/cdivu, 1./cdivu + write(lunout,*)'inidissip: coef r ', fact/crot , 1./crot + write(lunout,*)'inidissip: coef h ', fact/cdivh, 1./cdivh + ! ENDIF + + !----------------------------------------------------------------------- + ! variation verticale du coefficient de dissipation: + ! -------------------------------------------------- + + if (ok_strato .and. llm==39) then + do l=1,llm + pseudoz=8.*log(preff/presnivs(l)) + zvert(l)=1+ & + (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. & + *(dissip_factz-1.) + enddo + else + DO l=1,llm + zvert(l)=1. + ENDDO + fact=2. + DO l = 1, llm + zz = 1. - preff/presnivs(l) + zvert(l)= fact -( fact-1.)/( 1.+zz*zz ) + ENDDO + endif + + + write(lunout,*)'inidissip: Constantes de temps de la diffusion horizontale' + + tetamin = 1.e+6 + + DO l=1,llm + tetaudiv(l) = zvert(l)/tetagdiv + tetaurot(l) = zvert(l)/tetagrot + tetah(l) = zvert(l)/tetatemp + + IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l) + IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l) + IF( tetamin.GT. (1./ tetah(l)) ) tetamin = 1./ tetah(l) + ENDDO + + ! If dissip_period=0 calculate value for dissipation period, else keep value read from gcm.def + IF (dissip_period == 0) THEN + dissip_period = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod + write(lunout,*)'inidissip: tetamin dtvr iperiod dissip_period(intermed) ',tetamin,dtvr,iperiod,dissip_period + dissip_period = MAX(iperiod,dissip_period) + END IF + + dtdiss = dissip_period * dtvr + write(lunout,*)'inidissip: dissip_period=',dissip_period,' dtdiss=',dtdiss,' dtvr=',dtvr + + DO l = 1,llm + write(lunout,*)zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), & + dtdiss*tetah(l) + ENDDO + +END SUBROUTINE inidissip Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inigeom.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inigeom.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inigeom.F (revision 1634) @@ -0,0 +1,699 @@ +! +! $Id$ +! +c +c + SUBROUTINE inigeom +c +c Auteur : P. Le Van +c +c ............ Version du 01/04/2001 ........................ +c +c Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4 aux memes en- +c endroits que les aires aireij1,..aireij4 . + +c Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol. +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "serre.h" +#include "logic.h" +#include "comdissnew.h" + +c----------------------------------------------------------------------- +c .... Variables locales .... +c + INTEGER i,j,itmax,itmay,iter + REAL cvu(iip1,jjp1),cuv(iip1,jjm) + REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm + REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm + REAL coslatm,coslatp,radclatm,radclatp + REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1), + * cuij4(iip1,jjp1) + REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1), + * cvij4(iip1,jjp1) + REAL rlonvv(iip1),rlatuu(jjp1) + REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) , + * yprimv(jjm),yprimu(jjp1) + REAL gamdi_gdiv, gamdi_grot, gamdi_h + + REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1), + , xprimp025(iip1) + SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu + SAVE rlonm025,xprimm025,rlonp025,xprimp025 + + REAL SSUM +c +c +c ------------------------------------------------------------------ +c - - +c - calcul des coeff. ( cu, cv , 1./cu**2, 1./cv**2 ) - +c - - +c ------------------------------------------------------------------ +c +c les coef. ( cu, cv ) permettent de passer des vitesses naturelles +c aux vitesses covariantes et contravariantes , ou vice-versa ... +c +c +c on a : u (covariant) = cu * u (naturel) , u(contrav)= u(nat)/cu +c v (covariant) = cv * v (naturel) , v(contrav)= v(nat)/cv +c +c on en tire : u(covariant) = cu * cu * u(contravariant) +c v(covariant) = cv * cv * v(contravariant) +c +c +c on a l'application ( x(X) , y(Y) ) avec - im/2 +1 < X < im/2 +c = = +c et - jm/2 < Y < jm/2 +c = = +c +c ................................................... +c ................................................... +c . x est la longitude du point en radians . +c . y est la latitude du point en radians . +c . . +c . on a : cu(i,j) = rad * COS(y) * dx/dX . +c . cv( j ) = rad * dy/dY . +c . aire(i,j) = cu(i,j) * cv(j) . +c . . +c . y, dx/dX, dy/dY calcules aux points concernes . +c . . +c ................................................... +c ................................................... +c +c +c +c , +c cv , bien que dependant de j uniquement,sera ici indice aussi en i +c pour un adressage plus facile en ij . +c +c +c +c ************** aux points u et v , ***************** +c xprimu et xprimv sont respectivement les valeurs de dx/dX +c yprimu et yprimv . . . . . . . . . . . dy/dY +c rlatu et rlatv . . . . . . . . . . .la latitude +c cvu et cv . . . . . . . . . . . cv +c +c ************** aux points u, v, scalaires, et z **************** +c cu, cuv, cuscal, cuz sont respectiv. les valeurs de cu +c +c +c +c Exemple de distribution de variables sur la grille dans le +c domaine de travail ( X,Y ) . +c ................................................................ +c DX=DY= 1 +c +c +c + represente un point scalaire ( p.exp la pression ) +c > represente la composante zonale du vent +c V represente la composante meridienne du vent +c o represente la vorticite +c +c ---- , car aux poles , les comp.zonales covariantes sont nulles +c +c +c +c i -> +c +c 1 2 3 4 5 6 7 8 +c j +c v 1 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c V o V o V o V o V o V o V o V o +c +c 2 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 3 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 4 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 5 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c +c Ci-dessus, on voit que le nombre de pts.en longitude est egal +c a IM = 8 +c De meme , le nombre d'intervalles entre les 2 poles est egal +c a JM = 4 +c +c Les points scalaires ( + ) correspondent donc a des valeurs +c entieres de i ( 1 a IM ) et de j ( 1 a JM +1 ) . +c +c Les vents U ( > ) correspondent a des valeurs semi- +c entieres de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1) +c +c Les vents V ( V ) correspondent a des valeurs entieres +c de i ( 1 a IM ) et semi-entieres de j ( 1 +0.5 a JM +0.5) +c +c +c + WRITE(6,3) + 3 FORMAT( // 10x,' .... INIGEOM date du 01/06/98 ..... ', + * //5x,' Calcul des elongations cu et cv comme sommes des 4 ' / + * 5x,' elong. cuij1, .. 4 , cvij1,.. 4 qui les entourent , aux + * '/ 5x,' memes endroits que les aires aireij1,...j4 . ' / ) +c +c + IF( nitergdiv.NE.2 ) THEN + gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. ) + ELSE + gamdi_gdiv = 0. + ENDIF + IF( nitergrot.NE.2 ) THEN + gamdi_grot = coefdis/ ( REAL(nitergrot) -2. ) + ELSE + gamdi_grot = 0. + ENDIF + IF( niterh.NE.2 ) THEN + gamdi_h = coefdis/ ( REAL(niterh) -2. ) + ELSE + gamdi_h = 0. + ENDIF + + WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis, + * nitergdiv,nitergrot,niterh +c + pi = 2.* ASIN(1.) +c + WRITE(6,990) + +c ---------------------------------------------------------------- +c + IF( .NOT.fxyhypb ) THEN +c +c + IF( ysinus ) THEN +c + WRITE(6,*) ' *** Inigeom , Y = Sinus ( Latitude ) *** ' +c +c .... utilisation de f(x,y ) avec y = sinus de la latitude ..... + + CALL fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ELSE +c + WRITE(6,*) '*** Inigeom , Y = Latitude , der. sinusoid . ***' + +c .... utilisation de f(x,y) a tangente sinusoidale , y etant la latit. ... +c + + pxo = clon *pi /180. + pyo = 2.* clat* pi /180. +c +c .... determination de transx ( pour le zoom ) par Newton-Raphson ... +c + itmax = 10 + eps = .1e-7 +c + xo1 = 0. + DO 10 iter = 1, itmax + x1 = xo1 + f = x1+ alphax *SIN(x1-pxo) + df = 1.+ alphax *COS(x1-pxo) + x1 = x1 - f/df + xdm = ABS( x1- xo1 ) + IF( xdm.LE.eps )GO TO 11 + xo1 = x1 + 10 CONTINUE + 11 CONTINUE +c + transx = xo1 + + itmay = 10 + eps = .1e-7 +C + yo1 = 0. + DO 15 iter = 1,itmay + y1 = yo1 + f = y1 + alphay* SIN(y1-pyo) + df = 1. + alphay* COS(y1-pyo) + y1 = y1 -f/df + ydm = ABS(y1-yo1) + IF(ydm.LE.eps) GO TO 17 + yo1 = y1 + 15 CONTINUE +c + 17 CONTINUE + transy = yo1 + + CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ENDIF +c + ELSE +c +c .... Utilisation de fxyhyper , f(x,y) a derivee tangente hyperbol. +c ..................................................................... + + WRITE(6,*)'*** Inigeom , Y = Latitude , der.tg. hyperbolique ***' + + CALL fxyhyper( clat, grossismy, dzoomy, tauy , + , clon, grossismx, dzoomx, taux , + , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 ) + + + ENDIF +c +c ------------------------------------------------------------------- + +c + rlatu(1) = ASIN(1.) + rlatu(jjp1) = - rlatu(1) +c +c +c .... calcul aux poles .... +c + yprimu(1) = 0. + yprimu(jjp1) = 0. +c +c + un4rad2 = 0.25 * rad * rad +c +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c - - +c - calcul des aires ( aire,aireu,airev, 1./aire, 1./airez ) - +c - et de fext , force de coriolis extensive . - +c - - +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c +c +c +c A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont +c affectees 4 aires entourant P , calculees respectivement aux points +c ( i + 1/4, j - 1/4 ) : aireij1 (i,j) +c ( i + 1/4, j + 1/4 ) : aireij2 (i,j) +c ( i - 1/4, j + 1/4 ) : aireij3 (i,j) +c ( i - 1/4, j - 1/4 ) : aireij4 (i,j) +c +c , +c Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y). +c Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme +c des 4 aires aireij1,aireij2,aireij3,aireij4 qui sont affectees au +c point (i,j) . +c On definit en outre les coefficients alpha comme etant egaux a +c (aireij / aire), c.a.d par exp. alpha1(i,j)=aireij1(i,j)/aire(i,j) +c +c De meme, toute aire centree en 1 point U est egale a la somme des +c 4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U . +c Idem pour airev, airez . +c +c On a ,pour chaque maille : dX = dY = 1 +c +c +c . V +c +c aireij4 . . aireij1 +c +c U . . P . U +c +c aireij3 . . aireij2 +c +c . V +c +c +c +c +c +c .................................................................... +c +c Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4 +c qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen +c taires cuij et les 4 elongat. cvij qui sont calculees aux memes +c endroits que les aireij . +c +c .................................................................... +c +c ....... do 35 : boucle sur les jjm + 1 latitudes ..... +c +c + DO 35 j = 1, jjp1 +c + IF ( j. eq. 1 ) THEN +c + yprm = yprimu1(j) + rlatm = rlatu1(j) +c + coslatm = COS( rlatm ) + radclatm = 0.5* rad * coslatm +c + DO 30 i = 1, iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij2( i,1 ) = un4rad2 * coslatm * xprp * yprm + aireij3( i,1 ) = un4rad2 * coslatm * xprm * yprm + cuij2 ( i,1 ) = radclatm * xprp + cuij3 ( i,1 ) = radclatm * xprm + cvij2 ( i,1 ) = 0.5* rad * yprm + cvij3 ( i,1 ) = cvij2(i,1) + 30 CONTINUE +c + DO i = 1, iim + aireij1( i,1 ) = 0. + aireij4( i,1 ) = 0. + cuij1 ( i,1 ) = 0. + cuij4 ( i,1 ) = 0. + cvij1 ( i,1 ) = 0. + cvij4 ( i,1 ) = 0. + ENDDO +c + END IF +c + IF ( j. eq. jjp1 ) THEN + yprp = yprimu2(j-1) + rlatp = rlatu2 (j-1) +ccc yprp = fyprim( REAL(j) - 0.25 ) +ccc rlatp = fy ( REAL(j) - 0.25 ) +c + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp +c + DO 31 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij1( i,jjp1 ) = un4rad2 * coslatp * xprp * yprp + aireij4( i,jjp1 ) = un4rad2 * coslatp * xprm * yprp + cuij1(i,jjp1) = radclatp * xprp + cuij4(i,jjp1) = radclatp * xprm + cvij1(i,jjp1) = 0.5 * rad* yprp + cvij4(i,jjp1) = cvij1(i,jjp1) + 31 CONTINUE +c + DO i = 1, iim + aireij2( i,jjp1 ) = 0. + aireij3( i,jjp1 ) = 0. + cvij2 ( i,jjp1 ) = 0. + cvij3 ( i,jjp1 ) = 0. + cuij2 ( i,jjp1 ) = 0. + cuij3 ( i,jjp1 ) = 0. + ENDDO +c + END IF +c + + IF ( j .gt. 1 .AND. j .lt. jjp1 ) THEN +c + rlatp = rlatu2 ( j-1 ) + yprp = yprimu2( j-1 ) + rlatm = rlatu1 ( j ) + yprm = yprimu1( j ) +cc rlatp = fy ( REAL(j) - 0.25 ) +cc yprp = fyprim( REAL(j) - 0.25 ) +cc rlatm = fy ( REAL(j) + 0.25 ) +cc yprm = fyprim( REAL(j) + 0.25 ) + + coslatm = COS( rlatm ) + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp + radclatm = 0.5* rad * coslatm +c + DO 32 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + + ai14 = un4rad2 * coslatp * yprp + ai23 = un4rad2 * coslatm * yprm + aireij1 ( i,j ) = ai14 * xprp + aireij2 ( i,j ) = ai23 * xprp + aireij3 ( i,j ) = ai23 * xprm + aireij4 ( i,j ) = ai14 * xprm + cuij1 ( i,j ) = radclatp * xprp + cuij2 ( i,j ) = radclatm * xprp + cuij3 ( i,j ) = radclatm * xprm + cuij4 ( i,j ) = radclatp * xprm + cvij1 ( i,j ) = 0.5* rad * yprp + cvij2 ( i,j ) = 0.5* rad * yprm + cvij3 ( i,j ) = cvij2(i,j) + cvij4 ( i,j ) = cvij1(i,j) + 32 CONTINUE +c + END IF +c +c ........ periodicite ............ +c + cvij1 (iip1,j) = cvij1 (1,j) + cvij2 (iip1,j) = cvij2 (1,j) + cvij3 (iip1,j) = cvij3 (1,j) + cvij4 (iip1,j) = cvij4 (1,j) + cuij1 (iip1,j) = cuij1 (1,j) + cuij2 (iip1,j) = cuij2 (1,j) + cuij3 (iip1,j) = cuij3 (1,j) + cuij4 (iip1,j) = cuij4 (1,j) + aireij1 (iip1,j) = aireij1 (1,j ) + aireij2 (iip1,j) = aireij2 (1,j ) + aireij3 (iip1,j) = aireij3 (1,j ) + aireij4 (iip1,j) = aireij4 (1,j ) + + 35 CONTINUE +c +c .............................................................. +c + DO 37 j = 1, jjp1 + DO 36 i = 1, iim + aire ( i,j ) = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) + + * aireij4(i,j) + alpha1 ( i,j ) = aireij1(i,j) / aire(i,j) + alpha2 ( i,j ) = aireij2(i,j) / aire(i,j) + alpha3 ( i,j ) = aireij3(i,j) / aire(i,j) + alpha4 ( i,j ) = aireij4(i,j) / aire(i,j) + alpha1p2( i,j ) = alpha1 (i,j) + alpha2 (i,j) + alpha1p4( i,j ) = alpha1 (i,j) + alpha4 (i,j) + alpha2p3( i,j ) = alpha2 (i,j) + alpha3 (i,j) + alpha3p4( i,j ) = alpha3 (i,j) + alpha4 (i,j) + 36 CONTINUE +c +c + aire (iip1,j) = aire (1,j) + alpha1 (iip1,j) = alpha1 (1,j) + alpha2 (iip1,j) = alpha2 (1,j) + alpha3 (iip1,j) = alpha3 (1,j) + alpha4 (iip1,j) = alpha4 (1,j) + alpha1p2(iip1,j) = alpha1p2(1,j) + alpha1p4(iip1,j) = alpha1p4(1,j) + alpha2p3(iip1,j) = alpha2p3(1,j) + alpha3p4(iip1,j) = alpha3p4(1,j) + 37 CONTINUE +c + + DO 42 j = 1,jjp1 + DO 41 i = 1,iim + aireu (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) + + * aireij3(i+1,j) + unsaire ( i,j)= 1./ aire(i,j) + unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv ) + unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h ) + airesurg ( i,j)= aire(i,j)/ g + 41 CONTINUE + aireu (iip1,j) = aireu (1,j) + unsaire (iip1,j) = unsaire(1,j) + unsair_gam1(iip1,j) = unsair_gam1(1,j) + unsair_gam2(iip1,j) = unsair_gam2(1,j) + airesurg (iip1,j) = airesurg(1,j) + 42 CONTINUE +c +c + DO 48 j = 1,jjm +c + DO i=1,iim + airev (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) + + * aireij4(i,j+1) + ENDDO + DO i=1,iim + airez = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) + + * aireij4(i+1,j+1) + unsairez(i,j) = 1./ airez + unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot ) + fext (i,j) = airez * SIN(rlatv(j))* 2.* omeg + ENDDO + airev (iip1,j) = airev(1,j) + unsairez (iip1,j) = unsairez(1,j) + fext (iip1,j) = fext(1,j) + unsairz_gam(iip1,j) = unsairz_gam(1,j) +c + 48 CONTINUE +c +c +c ..... Calcul des elongations cu,cv, cvu ......... +c + DO j = 1, jjm + DO i = 1, iim + cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1)) + cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j) +cvij3(i,j) ) + cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1)) + unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) ) + ENDDO + DO i = 1, iim + cuvsurcv (i,j) = airev(i,j) * unscv2(i,j) + cvsurcuv (i,j) = 1./cuvsurcv(i,j) + cuvscvgam1(i,j) = cuvsurcv (i,j) ** ( - gamdi_gdiv ) + cuvscvgam2(i,j) = cuvsurcv (i,j) ** ( - gamdi_h ) + cvscuvgam(i,j) = cvsurcuv (i,j) ** ( - gamdi_grot ) + ENDDO + cv (iip1,j) = cv (1,j) + cvu (iip1,j) = cvu (1,j) + unscv2 (iip1,j) = unscv2 (1,j) + cuv (iip1,j) = cuv (1,j) + cuvsurcv (iip1,j) = cuvsurcv (1,j) + cvsurcuv (iip1,j) = cvsurcuv (1,j) + cuvscvgam1(iip1,j) = cuvscvgam1(1,j) + cuvscvgam2(iip1,j) = cuvscvgam2(1,j) + cvscuvgam(iip1,j) = cvscuvgam(1,j) + ENDDO + + DO j = 2, jjm + DO i = 1, iim + cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j)) + unscu2 (i,j) = 1./ ( cu(i,j) * cu(i,j) ) + cvusurcu (i,j) = aireu(i,j) * unscu2(i,j) + cusurcvu (i,j) = 1./ cvusurcu(i,j) + cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) + cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h ) + cuscvugam (i,j) = cusurcvu(i,j) ** ( - gamdi_grot ) + ENDDO + cu (iip1,j) = cu(1,j) + unscu2 (iip1,j) = unscu2(1,j) + cvusurcu (iip1,j) = cvusurcu(1,j) + cusurcvu (iip1,j) = cusurcvu(1,j) + cvuscugam1(iip1,j) = cvuscugam1(1,j) + cvuscugam2(iip1,j) = cvuscugam2(1,j) + cuscvugam (iip1,j) = cuscvugam(1,j) + ENDDO + +c +c .... calcul aux poles .... +c + DO i = 1, iip1 + cu ( i, 1 ) = 0. + unscu2( i, 1 ) = 0. + cvu ( i, 1 ) = 0. +c + cu (i, jjp1) = 0. + unscu2(i, jjp1) = 0. + cvu (i, jjp1) = 0. + ENDDO +c +c .............................................................. +c + DO j = 1, jjm + DO i= 1, iim + airvscu2 (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) ) + aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot ) + ENDDO + airvscu2 (iip1,j) = airvscu2(1,j) + aivscu2gam(iip1,j) = aivscu2gam(1,j) + ENDDO + + DO j=2,jjm + DO i=1,iim + airuscv2 (i,j) = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) ) + aiuscv2gam (i,j) = airuscv2(i,j)** ( - gamdi_grot ) + ENDDO + airuscv2 (iip1,j) = airuscv2 (1,j) + aiuscv2gam(iip1,j) = aiuscv2gam(1,j) + ENDDO + +c +c calcul des aires aux poles : +c ----------------------------- +c + apoln = SSUM(iim,aire(1,1),1) + apols = SSUM(iim,aire(1,jjp1),1) + unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) ) + unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) ) + unsapolnga2 = 1./ ( apoln ** ( - gamdi_h ) ) + unsapolsga2 = 1./ ( apols ** ( - gamdi_h ) ) +c +c----------------------------------------------------------------------- +c gtitre='Coriolis version ancienne' +c gfichier='fext1' +c CALL writestd(fext,iip1*jjm) +c +c changement F. Hourdin calcul conservatif pour fext +c constang contient le produit a * cos ( latitude ) * omega +c + DO i=1,iim + constang(i,1) = 0. + ENDDO + DO j=1,jjm-1 + DO i=1,iim + constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1)) + ENDDO + ENDDO + DO i=1,iim + constang(i,jjp1) = 0. + ENDDO +c +c periodicite en longitude +c + DO j=1,jjm + fext(iip1,j) = fext(1,j) + ENDDO + DO j=1,jjp1 + constang(iip1,j) = constang(1,j) + ENDDO + +c fin du changement + +c +c----------------------------------------------------------------------- +c + WRITE(6,*) ' *** Coordonnees de la grille *** ' + WRITE(6,995) +c + WRITE(6,*) ' LONGITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,iip1 + rlonvv(i) = rlonv(i)*180./pi + ENDDO + WRITE(6,400) rlonvv +c + WRITE(6,995) + WRITE(6,*) ' LATITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,jjm + rlatuu(i)=rlatv(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjm) +c + DO i=1,iip1 + rlonvv(i)=rlonu(i)*180./pi + ENDDO + WRITE(6,995) + WRITE(6,*) ' LONGITUDES aux pts. U ( degres ) ' + WRITE(6,995) + WRITE(6,400) rlonvv + WRITE(6,995) + + WRITE(6,*) ' LATITUDES aux pts. U ( degres ) ' + WRITE(6,995) + DO i=1,jjp1 + rlatuu(i)=rlatu(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjp1) + WRITE(6,995) +c +444 format(f10.3,f6.0) +400 FORMAT(1x,8f8.2) +990 FORMAT(//) +995 FORMAT(/) +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inigrads.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inigrads.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inigrads.F (revision 1634) @@ -0,0 +1,92 @@ +! +! $Header$ +! + subroutine inigrads(if,im + s ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz + s ,dt,file,titlel) + + + implicit none + + integer if,im,jm,lm,i,j,l,lnblnk + real x(im),y(jm),z(lm),fx,fy,fz,dt + real xmin,xmax,ymin,ymax + + character file*10,titlel*40 + +#include "gradsdef.h" + +c data unit/66,32,34,36,38,40,42,44,46,48/ + integer nf + save nf + data nf/0/ + + unit(1)=66 + unit(2)=32 + unit(3)=34 + unit(4)=36 + unit(5)=38 + unit(6)=40 + unit(7)=42 + unit(8)=44 + unit(9)=46 + + if (if.le.nf) stop'verifier les appels a inigrads' + + print*,'Entree dans inigrads' + + nf=if + title(if)=titlel + ivar(if)=0 + + fichier(if)=file(1:lnblnk(file)) + + firsttime(if)=.true. + dtime(if)=dt + + iid(if)=1 + ifd(if)=im + imd(if)=im + do i=1,im + xd(i,if)=x(i)*fx + if(xd(i,if).lt.xmin) iid(if)=i+1 + if(xd(i,if).le.xmax) ifd(if)=i + enddo + print*,'On stoke du point ',iid(if),' a ',ifd(if),' en x' + + jid(if)=1 + jfd(if)=jm + jmd(if)=jm + do j=1,jm + yd(j,if)=y(j)*fy + if(yd(j,if).gt.ymax) jid(if)=j+1 + if(yd(j,if).ge.ymin) jfd(if)=j + enddo + print*,'On stoke du point ',jid(if),' a ',jfd(if),' en y' + + print*,'Open de dat' + print*,'file=',file + print*,'fichier(if)=',fichier(if) + + print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if)) + print*,file(1:lnblnk(file))//'.dat' + + OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat' + s ,FORM='unformatted', + s ACCESS='direct' + s ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1)) + + print*,'Open de dat ok' + + lmd(if)=lm + do l=1,lm + zd(l,if)=z(l)*fz + enddo + + irec(if)=0 + + print*,if,imd(if),jmd(if),lmd(if) + print*,'if,imd(if),jmd(if),lmd(if)' + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniinterp_horiz.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniinterp_horiz.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniinterp_horiz.F (revision 1634) @@ -0,0 +1,179 @@ +C +C $Header$ +C + subroutine iniinterp_horiz (imo,jmo,imn,jmn ,kllm, + & rlonuo,rlatvo,rlonun,rlatvn, + & ktotal,iik,jjk,jk,ik,intersec,airen) + + implicit none + + + +c --------------------------------------------------------- +c Prepare l' interpolation des variables d'une grille LMDZ +c dans une autre grille LMDZ en conservant la quantite +c totale pour les variables intensives (/m2) : ex : Pression au sol +c +c (Pour chaque case autour d'un point scalaire de la nouvelle +c grille, on calcule la surface (en m2)en intersection avec chaque +c case de l'ancienne grille , pour la future interpolation) +c +c on calcule aussi l' aire dans la nouvelle grille +c +c +c Auteur: F.Forget 01/1995 +c ------- +c +c --------------------------------------------------------- +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" +c INPUT + integer imo, jmo ! dimensions ancienne grille + integer imn,jmn ! dimensions nouvelle grille + integer kllm ! taille du tableau des intersections + real rlonuo(imo+1) ! Latitude et + real rlatvo(jmo) ! longitude des + real rlonun(imn+1) ! bord des + real rlatvn(jmn) ! cases "scalaires" (input) + +c OUTPUT + integer ktotal ! nombre totale d'intersections reperees + integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm) + real intersec(kllm) ! surface des intersections (m2) + real airen (imn+1,jmn+1) ! aire dans la nouvelle grille + + + + +c Autres variables +c """""""""""""""" + integer i,j,ii,jj,k + real a(imo+1),b(imo+1),c(jmo+1),d(jmo+1) + real an(imn+1),bn(imn+1),cn(jmn+1),dn(jmn+1) + real aa, bb,cc,dd + real pi + + pi = 2.*ASIN( 1. ) + + + +c On repere les frontieres des cases : +c =================================== +c +c Attention, on ruse avec des latitudes = 90 deg au pole. + + +c ANcienne grile +c """""""""""""" + a(1) = - rlonuo(imo+1) + b(1) = rlonuo(1) + do i=2,imo+1 + a(i) = rlonuo(i-1) + b(i) = rlonuo(i) + end do + + d(1) = pi/2 + do j=1,jmo + c(j) = rlatvo(j) + d(j+1) = rlatvo(j) + end do + c(jmo+1) = -pi/2 + + +c Nouvelle grille +c """"""""""""""" + an(1) = - rlonun(imn+1) + bn(1) = rlonun(1) + do i=2,imn+1 + an(i) = rlonun(i-1) + bn(i) = rlonun(i) + end do + + dn(1) = pi/2 + do j=1,jmn + cn(j) = rlatvn(j) + dn(j+1) = rlatvn(j) + end do + cn(jmn+1) = -pi/2 + +c Calcul de la surface des cases scalaires de la nouvelle grille +c ============================================================== + do ii=1,imn + 1 + do jj = 1,jmn+1 + airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj))) + end do + end do + +c Calcul de la surface des intersections +c ====================================== + +c boucle sur la nouvelle grille +c """""""""""""""""""""""""""" + ktotal = 0 + do jj = 1,jmn+1 + do j=1, jmo+1 + if((cn(jj).lt.d(j)).and.(dn(jj).gt.c(j)))then + do ii=1,imn + 1 + do i=1, imo +1 + if ( ((an(ii).lt.b(i)).and.(bn(ii).gt.a(i))) + & .or. ((an(ii).lt.b(i)-2*pi).and.(bn(ii).gt.a(i)-2*pi) + & .and.(b(i)-2*pi.lt.-pi) ) + & .or. ((an(ii).lt.b(i)+2*pi).and.(bn(ii).gt.a(i)+2*pi) + & .and.(a(i)+2*pi.gt.pi) ) + & )then + ktotal = ktotal +1 + iik(ktotal) =ii + jjk(ktotal) =jj + ik(ktotal) =i + jk(ktotal) =j + + dd = min(d(j), dn(jj)) + cc = cn(jj) + if (cc.lt. c(j))cc=c(j) + if((an(ii).lt.b(i)-2*pi).and. + & (bn(ii).gt.a(i)-2*pi)) then + bb = min(b(i)-2*pi,bn(ii)) + aa = an(ii) + if (aa.lt.a(i)-2*pi) aa=a(i)-2*pi + else if((an(ii).lt.b(i)+2*pi).and. + & (bn(ii).gt.a(i)+2*pi)) then + bb = min(b(i)+2*pi,bn(ii)) + aa = an(ii) + if (aa.lt.a(i)+2*pi) aa=a(i)+2*pi + else + bb = min(b(i),bn(ii)) + aa = an(ii) + if (aa.lt.a(i)) aa=a(i) + end if + intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc)) + end if + end do + end do + end if + end do + end do + + + +c TEST INFO +c DO k=1,ktotal +c ii = iik(k) +c jj = jjk(k) +c i = ik(k) +c j = jk(k) +c if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then +c if (jj.eq.2.and.(ii.eq.1))then +c write(*,*) '**************** jj=',jj,'ii=',ii +c write(*,*) 'i,j =',i,j +c write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj) +c write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j) +c write(*,*) 'intersec(k)',intersec(k) +c write(*,*) 'airen(ii,jj)=',airen(ii,jj) +c end if +c END DO + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniprint.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniprint.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/iniprint.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! +! +! gestion des impressions de sorties et de débogage +! lunout: unité du fichier dans lequel se font les sorties +! (par defaut 6, la sortie standard) +! prt_level: niveau d'impression souhaité (0 = minimum) +! + INTEGER lunout, prt_level + COMMON /comprint/ lunout, prt_level Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/initial0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/initial0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/initial0.F (revision 1634) @@ -0,0 +1,12 @@ +! +! $Header$ +! + SUBROUTINE initial0(n,x) + IMPLICIT NONE + INTEGER n,i + REAL x(n) + DO 10 i=1,n + x(i)=0. +10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/integrd.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/integrd.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/integrd.F (revision 1634) @@ -0,0 +1,237 @@ +! +! $Id$ +! + SUBROUTINE integrd + $ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1, + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold ) + + use control_mod, only : planet_type + + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c objet: +c ------ +c +c Incrementation des tendances dynamiques +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "logic.h" +#include "temps.h" +#include "serre.h" + +c Arguments: +c ---------- + + INTEGER nq + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq) + REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1) + + REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm) + + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm) + +c Local: +c ------ + + REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1) + REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm) + REAL p(ip1jmp1,llmp1) + REAL tpn,tps,tppn(iim),tpps(iim) + REAL qpn,qps,qppn(iim),qpps(iim) + REAL deltap( ip1jmp1,llm ) + + INTEGER l,ij,iq + + REAL SSUM + +c----------------------------------------------------------------------- + + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij , l) = 0. + ucov( ij +ip1jm, l) = 0. + uscr( ij ) = 0. + uscr( ij +ip1jm ) = 0. + ENDDO + ENDDO + + +c ............ integration de ps .............. + + CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1) + + DO ij = 1,ip1jmp1 + pscr (ij) = ps(ij) + ps (ij) = psm1(ij) + dt * dp(ij) + ENDDO +c + DO ij = 1,ip1jmp1 + IF( ps(ij).LT.0. ) THEN + PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij) + print *, ' dans integrd' + stop 1 + ENDIF + ENDDO +c + DO ij = 1, iim + tppn(ij) = aire( ij ) * ps( ij ) + tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + DO ij = 1, iip1 + ps( ij ) = tpn + ps(ij+ip1jm) = tps + ENDDO +c +c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ... +c + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL massdair ( p , masse ) + + CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 ) + CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1 ) +c + +c ............ integration de ucov, vcov, h .............. + + DO l = 1,llm + + DO ij = iip2,ip1jm + uscr( ij ) = ucov( ij,l ) + ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l ) + ENDDO + + DO ij = 1,ip1jm + vscr( ij ) = vcov( ij,l ) + vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l ) + ENDDO + + DO ij = 1,ip1jmp1 + hscr( ij ) = teta(ij,l) + teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l) + & + dt * dteta(ij,l) / masse(ij,l) + ENDDO + +c .... Calcul de la valeur moyenne, unique aux poles pour teta ...... +c +c + DO ij = 1, iim + tppn(ij) = aire( ij ) * teta( ij ,l) + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta( ij ,l) = tpn + teta(ij+ip1jm,l) = tps + ENDDO +c + + IF(leapf) THEN + CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 ) + CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 ) + CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 ) + END IF + + ENDDO ! of DO l = 1,llm + + +c +c ....... integration de q ...... +c +c$$$ IF( iadv(1).NE.3.AND.iadv(2).NE.3 ) THEN +c$$$c +c$$$ IF( forward. OR . leapf ) THEN +c$$$ DO iq = 1,2 +c$$$ DO l = 1,llm +c$$$ DO ij = 1,ip1jmp1 +c$$$ q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/ +c$$$ $ finvmasse(ij,l) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$ ELSE +c$$$ DO iq = 1,2 +c$$$ DO l = 1,llm +c$$$ DO ij = 1,ip1jmp1 +c$$$ q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l) +c$$$ ENDDO +c$$$ ENDDO +c$$$ ENDDO +c$$$ +c$$$ END IF +c$$$c +c$$$ ENDIF + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltap(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO + + CALL qminimum( q, nq, deltap ) + +c +c ..... Calcul de la valeur moyenne, unique aux poles pour q ..... +c + + DO iq = 1, nq + DO l = 1, llm + + DO ij = 1, iim + qppn(ij) = aire( ij ) * q( ij ,l,iq) + qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq) + ENDDO + qpn = SSUM(iim,qppn,1)/apoln + qps = SSUM(iim,qpps,1)/apols + + DO ij = 1, iip1 + q( ij ,l,iq) = qpn + q(ij+ip1jm,l,iq) = qps + ENDDO + + ENDDO + ENDDO + + + CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 ) + + endif ! of if (planet_type.eq."earth") +c +c +c ..... FIN de l'integration de q ....... + +c ................................................................. + + + IF( leapf ) THEN + CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 ) + CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 ) + END IF + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inter_barxy_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inter_barxy_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/inter_barxy_m.F90 (revision 1634) @@ -0,0 +1,453 @@ +! +! $Id$ +! +module inter_barxy_m + + ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ + + implicit none + + private + public inter_barxy + +contains + + SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint) + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + + include "dimensions.h" + ! (for "iim", "jjm") + + include "paramet.h" + ! (for other included files) + + include "comgeom2.h" + ! (for "aire", "apoln", "apols") + + REAL, intent(in):: dlonid(:) + ! (longitude from input file, in rad, from -pi to pi) + + REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:) + + REAL, intent(in):: rlatimod(:) + ! (latitude angle, in degrees or rad, in strictly decreasing order) + + real, intent(out):: champint(:, :) + ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les + ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U) + ! Si taille de la seconde dim = jjm, on veut interpoler sur les + ! jjm latitudes rlatv du modele (latitudes de V) + + ! Variables local to the procedure: + + REAL champy(iim, size(champ, 2)) + integer j, i, jnterfd, jmods + + REAL yjmod(size(champint, 2)) + ! (angle, in degrees, in strictly increasing order) + + REAL yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order + LOGICAL decrois ! "dlatid" is in decreasing order + + !----------------------------------- + + jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), & + "inter_barxy jnterfd") + jmods = size(champint, 2) + call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)") + call assert((/size(rlonimod), size(champint, 1)/) == iim, & + "inter_barxy iim") + call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods') + call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)") + + ! Check decreasing order for "rlatimod": + DO i = 2, jjm + IF (rlatimod(i) >= rlatimod(i-1)) stop & + '"inter_barxy": "rlatimod" should be strictly decreasing' + ENDDO + + yjmod(:jjm) = ord_coordm(rlatimod) + IF (jmods == jjm + 1) THEN + IF (90. - yjmod(jjm) < 0.01) stop & + '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.' + ELSE + ! jmods = jjm + IF (ABS(yjmod(jjm) - 90.) > 0.01) stop & + '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.' + ENDIF + + if (jmods == jjm + 1) yjmod(jjm + 1) = 90. + + DO j = 1, jnterfd + 1 + champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod) + ENDDO + + CALL ord_coord(dlatid, yjdat, decrois) + IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1) + DO i = 1, iim + champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod) + ENDDO + champint(:, :) = champint(:, jmods:1:-1) + + IF (jmods == jjm + 1) THEN + ! Valeurs uniques aux poles + champint(:, 1) = SUM(aire(:iim, 1) * champint(:, 1)) / apoln + champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) & + * champint(:, jjm + 1)) / apols + ENDIF + + END SUBROUTINE inter_barxy + + !****************************** + + function inter_barx(dlonid, fdat, rlonimod) + + ! INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES + ! VERSION UNIDIMENSIONNELLE , EN LONGITUDE . + + ! idat : indice du champ de donnees, de 1 a idatmax + ! imod : indice du champ du modele, de 1 a imodmax + ! fdat(idat) : champ de donnees (entrees) + ! inter_barx(imod) : champ du modele (sorties) + ! dlonid(idat): abscisses des interfaces des mailles donnees + ! rlonimod(imod): abscisses des interfaces des mailles modele + ! ( L'indice 1 correspond a l'interface mailLE 1 / maille 2) + ! ( Les abscisses sont exprimees en degres) + + use assert_eq_m, only: assert_eq + + IMPLICIT NONE + + REAL, intent(in):: dlonid(:) + real, intent(in):: fdat(:) + real, intent(in):: rlonimod(:) + + real inter_barx(size(rlonimod)) + + ! ... Variables locales ... + + INTEGER idatmax, imodmax + REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1) + REAL fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1) + REAL xxim(size(rlonimod)) + + REAL x0, xim0, dx, dxm + REAL chmin, chmax, pi + + INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1 + + !----------------------------------------------------- + + idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax") + imodmax = size(rlonimod) + + pi = 2. * ASIN(1.) + + ! REDEFINITION DE L'ORIGINE DES ABSCISSES + ! A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE + DO imod = 1, imodmax + xxim(imod) = rlonimod(imod) + ENDDO + + CALL minmax( imodmax, xxim, chmin, chmax) + IF( chmax.LT.6.50 ) THEN + DO imod = 1, imodmax + xxim(imod) = xxim(imod) * 180./pi + ENDDO + ENDIF + + xim0 = xxim(imodmax) - 360. + + DO imod = 1, imodmax + xxim(imod) = xxim(imod) - xim0 + ENDDO + + idatmax1 = idatmax +1 + + DO idat = 1, idatmax + xxd(idat) = dlonid(idat) + ENDDO + + CALL minmax( idatmax, xxd, chmin, chmax) + IF( chmax.LT.6.50 ) THEN + DO idat = 1, idatmax + xxd(idat) = xxd(idat) * 180./pi + ENDDO + ENDIF + + DO idat = 1, idatmax + xxd(idat) = MOD( xxd(idat) - xim0, 360. ) + fdd(idat) = fdat (idat) + ENDDO + + i = 2 + DO while (xxd(i) >= xxd(i-1) .and. i < idatmax) + i = i + 1 + ENDDO + IF (xxd(i) < xxd(i-1)) THEN + ichang = i + ! *** reorganisation des longitudes entre 0. et 360. degres **** + nid = idatmax - ichang +1 + DO i = 1, nid + xchan (i) = xxd(i+ichang -1 ) + fdchan(i) = fdd(i+ichang -1 ) + ENDDO + DO i=1, ichang -1 + xchan (i+ nid) = xxd(i) + fdchan(i+nid) = fdd(i) + ENDDO + DO i =1, idatmax + xxd(i) = xchan(i) + fdd(i) = fdchan(i) + ENDDO + end IF + + ! translation des champs de donnees par rapport + ! a la nouvelle origine, avec redondance de la + ! maille a cheval sur les bords + + id0 = 0 + id1 = 0 + + DO idat = 1, idatmax + IF ( xxd( idatmax1- idat ).LT.360.) exit + id1 = id1 + 1 + ENDDO + + DO idat = 1, idatmax + IF (xxd(idat).GT.0.) exit + id0 = id0 + 1 + END DO + + IF( id1 /= 0 ) then + DO idat = 1, id1 + xxid(idat) = xxd(idatmax - id1 + idat) - 360. + fxd (idat) = fdd(idatmax - id1 + idat) + END DO + DO idat = 1, idatmax - id1 + xxid(idat + id1) = xxd(idat) + fxd (idat + id1) = fdd(idat) + END DO + end IF + + IF(id0 /= 0) then + DO idat = 1, idatmax - id0 + xxid(idat) = xxd(idat + id0) + fxd (idat) = fdd(idat + id0) + END DO + + DO idat = 1, id0 + xxid (idatmax - id0 + idat) = xxd(idat) + 360. + fxd (idatmax - id0 + idat) = fdd(idat) + END DO + else + DO idat = 1, idatmax + xxid(idat) = xxd(idat) + fxd (idat) = fdd(idat) + ENDDO + end IF + xxid(idatmax1) = xxid(1) + 360. + fxd (idatmax1) = fxd(1) + + ! initialisation du champ du modele + + inter_barx(:) = 0. + + ! iteration + + x0 = xim0 + dxm = 0. + imod = 1 + idat = 1 + + do while (imod <= imodmax) + do while (xxim(imod).GT.xxid(idat)) + dx = xxid(idat) - x0 + dxm = dxm + dx + inter_barx(imod) = inter_barx(imod) + dx * fxd(idat) + x0 = xxid(idat) + idat = idat + 1 + end do + IF (xxim(imod).LT.xxid(idat)) THEN + dx = xxim(imod) - x0 + dxm = dxm + dx + inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + ELSE + dx = xxim(imod) - x0 + dxm = dxm + dx + inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + idat = idat + 1 + END IF + end do + + END function inter_barx + + !****************************** + + function inter_bary(yjdat, fdat, yjmod) + + ! Interpolation barycentrique basée sur les aires. + ! Version unidimensionnelle, en latitude. + ! L'indice 1 correspond à l'interface maille 1 -- maille 2. + + use assert_m, only: assert + + IMPLICIT NONE + + REAL, intent(in):: yjdat(:) + ! (angles, ordonnées des interfaces des mailles des données, in + ! degrees, in increasing order) + + REAL, intent(in):: fdat(:) ! champ de données + + REAL, intent(in):: yjmod(:) + ! (ordonnées des interfaces des mailles du modèle) + ! (in degrees, in strictly increasing order) + + REAL inter_bary(size(yjmod)) ! champ du modèle + + ! Variables local to the procedure: + + REAL y0, dy, dym + INTEGER jdat ! indice du champ de données + integer jmod ! indice du champ du modèle + + !------------------------------------ + + call assert(size(yjdat) == size(fdat), "inter_bary") + + ! Initialisation des variables + inter_bary(:) = 0. + y0 = -90. + dym = 0. + jmod = 1 + jdat = 1 + + do while (jmod <= size(yjmod)) + do while (yjmod(jmod) > yjdat(jdat)) + dy = yjdat(jdat) - y0 + dym = dym + dy + inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat) + y0 = yjdat(jdat) + jdat = jdat + 1 + end do + IF (yjmod(jmod) < yjdat(jdat)) THEN + dy = yjmod(jmod) - y0 + dym = dym + dy + inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + ELSE + ! {yjmod(jmod) == yjdat(jdat)} + dy = yjmod(jmod) - y0 + dym = dym + dy + inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + jdat = jdat + 1 + END IF + end do + ! Le test de fin suppose que l'interface 0 est commune aux deux + ! grilles "yjdat" et "yjmod". + + END function inter_bary + + !****************************** + + SUBROUTINE ord_coord(xi, xo, decrois) + + ! This procedure receives an array of latitudes. + ! It converts them to degrees if they are in radians. + ! If the input latitudes are in decreasing order, the procedure + ! reverses their order. + ! Finally, the procedure adds 90° as the last value of the array. + + use assert_eq_m, only: assert_eq + + IMPLICIT NONE + + include "comconst.h" + ! (for "pi") + + REAL, intent(in):: xi(:) + ! (latitude, in degrees or radians, in increasing or decreasing order) + ! ("xi" should contain latitudes from pole to pole. + ! "xi" should contain the latitudes of the boundaries of grid + ! cells, not the centers of grid cells. + ! So the extreme values should not be 90° and -90°.) + + REAL, intent(out):: xo(:) ! angles in degrees + LOGICAL, intent(out):: decrois + + ! Variables local to the procedure: + INTEGER nmax, i + + !-------------------- + + nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord") + + ! Check monotonicity: + decrois = xi(2) < xi(1) + DO i = 3, nmax + IF (decrois .neqv. xi(i) < xi(i-1)) stop & + '"ord_coord": latitudes are not monotonic' + ENDDO + + IF (abs(xi(1)) < pi) then + ! "xi" contains latitudes in radians + xo(:nmax) = xi(:) * 180. / pi + else + ! "xi" contains latitudes in degrees + xo(:nmax) = xi(:) + end IF + + IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN + print *, "ord_coord" + PRINT *, '"xi" should contain the latitudes of the boundaries of ' & + // 'grid cells, not the centers of grid cells.' + STOP + ENDIF + + IF (decrois) xo(:nmax) = xo(nmax:1:- 1) + xo(nmax + 1) = 90. + + END SUBROUTINE ord_coord + + !*********************************** + + function ord_coordm(xi) + + ! This procedure converts to degrees, if necessary, and inverts the + ! order. + + IMPLICIT NONE + + include "comconst.h" + ! (for "pi") + + REAL, intent(in):: xi(:) ! angle, in rad or degrees + REAL ord_coordm(size(xi)) ! angle, in degrees + + !----------------------------- + + IF (xi(1) < 6.5) THEN + ! "xi" is in rad + ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi + else + ! "xi" is in degrees + ord_coordm(:) = xi(size(xi):1:-1) + ENDIF + + END function ord_coordm + +end module inter_barxy_m Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interp_horiz.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interp_horiz.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interp_horiz.F (revision 1634) @@ -0,0 +1,154 @@ +c +c $Id$ +c + subroutine interp_horiz (varo,varn,imo,jmo,imn,jmn,lm, + & rlonuo,rlatvo,rlonun,rlatvn) + +c=========================================================== +c Interpolation Horizontales des variables d'une grille LMDZ +c (des points SCALAIRES au point SCALAIRES) +c dans une autre grille LMDZ en conservant la quantite +c totale pour les variables intensives (/m2) : ex : Pression au sol +c +c Francois Forget (01/1995) +c=========================================================== + + IMPLICIT NONE + +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" + + integer imo, jmo ! dimensions ancienne grille (input) + integer imn,jmn ! dimensions nouvelle grille (input) + + real rlonuo(imo+1) ! Latitude et + real rlatvo(jmo) ! longitude des + real rlonun(imn+1) ! bord des + real rlatvn(jmn) ! cases "scalaires" (input) + + integer lm ! dimension verticale (input) + real varo (imo+1, jmo+1,lm) ! var dans l'ancienne grille (input) + real varn (imn+1,jmn+1,lm) ! var dans la nouvelle grille (output) + +c Autres variables +c """""""""""""""" + real airetest(imn+1,jmn+1) + integer ii,jj,l + + real airen (imn+1,jmn+1) ! aire dans la nouvelle grille +c Info sur les ktotal intersection entre les cases new/old grille + integer kllm, k, ktotal + parameter (kllm = 400*200*10) + integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm) + real intersec(kllm) + real R + real totn, tots + + logical firstcall, firsttest, aire_ok + save firsttest + data firsttest /.true./ + data aire_ok /.true./ + + + + + +c initialisation +c -------------- +c Si c'est le premier appel, on prepare l'interpolation +c en calculant pour chaque case autour d'un point scalaire de la +c nouvelle grille, la surface de intersection avec chaque +c case de l'ancienne grille. + + + call iniinterp_horiz (imo,jmo,imn,jmn ,kllm, + & rlonuo,rlatvo,rlonun,rlatvn, + & ktotal,iik,jjk,jk,ik,intersec,airen) + + do l=1,lm + do jj =1 , jmn+1 + do ii=1, imn+1 + varn(ii,jj,l) =0. + end do + end do + end do + +c Interpolation horizontale +c ------------------------- +c boucle sur toute les ktotal intersections entre les cases +c de l'ancienne et la nouvelle grille +c + PRINT *, 'ktotal 1 = ', ktotal + + do k=1,ktotal + do l=1,lm + varn(iik(k),jjk(k),l) = varn(iik(k),jjk(k),l) + & + varo(ik(k), jk(k),l)*intersec(k)/airen(iik(k),jjk(k)) + end do + end do + +c Une seule valeur au pole pour les variables ! : +c ----------------------------------------------- + do l=1, lm + totn =0. + tots =0. + do ii =1, imn+1 + totn = totn + varn(ii,1,l) + tots = tots + varn (ii,jmn+1,l) + end do + do ii =1, imn+1 + varn(ii,1,l) = totn/REAL(imn+1) + varn(ii,jmn+1,l) = tots/REAL(imn+1) + end do + end do + + +c--------------------------------------------------------------- +c TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST +!! if (.not.(firsttest)) goto 99 +!! firsttest = .false. +!! ! write (*,*) 'INTERP. HORIZ. : TEST SUR LES AIRES:' +!! do jj =1 , jmn+1 +!! do ii=1, imn+1 +!! airetest(ii,jj) =0. +!! end do +!! end do +!! PRINT *, 'ktotal = ', ktotal +!! PRINT *, 'jmn+1 =', jmn+1, 'imn+1', imn+1 +!! +!! do k=1,ktotal +!! airetest(iik(k),jjk(k))= airetest(iik(k),jjk(k)) +intersec(k) +!! end DO +!! +!! +!! PRINT *, 'fin boucle' +!! do jj =1 , jmn+1 +!! do ii=1, imn+1 +!! r = airen(ii,jj)/airetest(ii,jj) +!! if ((r.gt.1.001).or.(r.lt.0.999)) then +!! ! write (*,*) '********** PROBLEME D'' AIRES !!!', +!! ! & ' DANS L''INTERPOLATION HORIZONTALE' +!! ! write(*,*)'ii,jj,airen,airetest', +!! ! & ii,jj,airen(ii,jj),airetest(ii,jj) +!! aire_ok = .false. +!! end if +!! end do +!! end do +!! ! if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK' +!! 99 continue + +c FIN TEST FIN TEST FIN TEST FIN TEST FIN TEST FIN TEST FIN TEST +c--------------------------------------------------------------- + + + + + + + + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interpost.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interpost.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interpost.F (revision 1634) @@ -0,0 +1,45 @@ +! +! $Header$ +! + subroutine interpost(q,qppm) + + implicit none + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments + real q(iip1,jjp1,llm) + real qppm(iim,jjp1,llm) +c Local + integer l,i,j + +c RE-INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux de Lin à ceux du LMDZ + + do l=1,llm + do j=1,jjp1 + do i=1,iim + q(i,j,l)=qppm(i,j,llm-l+1) + enddo + enddo + enddo + +c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D + + do l=1,llm + do j=1,jjp1 + q(iip1,j,l)=q(1,j,l) + enddo + enddo + + + return + + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interpre.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interpre.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/interpre.F (revision 1634) @@ -0,0 +1,133 @@ +! +! $Id$ +! + subroutine interpre(q,qppm,w,fluxwppm,masse, + s apppm,bpppm,massebx,masseby,pbaru,pbarv, + s unatppm,vnatppm,psppm) + + USE control_mod + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + +c--------------------------------------------------- +c Arguments + real apppm(llm+1),bpppm(llm+1) + real q(iip1,jjp1,llm),qppm(iim,jjp1,llm) +c--------------------------------------------------- + real masse(iip1,jjp1,llm) + real massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + real w(iip1,jjp1,llm+1) + real fluxwppm(iim,jjp1,llm) + real pbaru(iip1,jjp1,llm ) + real pbarv(iip1,jjm,llm) + real unatppm(iim,jjp1,llm) + real vnatppm(iim,jjp1,llm) + real psppm(iim,jjp1) +c--------------------------------------------------- +c Local + real vnat(iip1,jjp1,llm) + real unat(iip1,jjp1,llm) + real fluxw(iip1,jjp1,llm) + real smass(iip1,jjp1) +c---------------------------------------------------- + integer l,ij,i,j + +c CALCUL DE LA PRESSION DE SURFACE +c Les coefficients ap et bp sont passés en common +c Calcul de la pression au sol en mb optimisée pour +c la vectorialisation + + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=0. + enddo + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=smass(i,j)+masse(i,j,l) + enddo + enddo + enddo + + do j=1,jjp1 + do i=1,iim + psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01 + end do + end do + +c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS +c Le programme ppm3d travaille avec les composantes +c de vitesse et pas les flux, on doit donc passer de l'un à l'autre +c Dans le même temps, on fait le changement d'orientation du vent en v + do l=1,llm + do j=1,jjm + do i=1,iip1 + vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j) + enddo + enddo + do i=1,iim + vnat(i,jjp1,l)=0. + enddo + do j=1,jjp1 + do i=1,iip1 + unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j) + enddo + enddo + enddo + +c CALCUL DU FLUX MASSIQUE VERTICAL +c Flux en l=1 (sol) nul + fluxw=0. + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j) +C print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l), +C c 'w(i,j,l)=',w(i,j,l) + enddo + enddo + enddo + +c INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux du LMDZ à ceux de Lin + + do l=1,llm+1 + apppm(l)=ap(llm+2-l) + bpppm(l)=bp(llm+2-l) + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iim + unatppm(i,j,l)=unat(i,j,llm-l+1) + vnatppm(i,j,l)=vnat(i,j,llm-l+1) + fluxwppm(i,j,l)=fluxw(i,j,llm-l+1) + qppm(i,j,l)=q(i,j,llm-l+1) + enddo + enddo + enddo + + return + end + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/invert_lat.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/invert_lat.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/invert_lat.F90 (revision 1634) @@ -0,0 +1,21 @@ + +SUBROUTINE invert_lat(xsize,ysize,vsize,field) + + IMPLICIT NONE + +! Input variables + INTEGER, INTENT(IN) :: xsize,ysize,vsize + REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field +! Local variables + REAL, DIMENSION (xsize,ysize,vsize) :: f_aux + INTEGER :: l,j + + DO l=1,vsize + DO j=1,ysize + f_aux(:,j,l)=field(:,ysize+1-j,l) + END DO + END DO + + field=f_aux + + END SUBROUTINE invert_lat Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ismax.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ismax.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ismax.F (revision 1634) @@ -0,0 +1,24 @@ +! +! $Header$ +! + function ismax(n,sx,incx) +c + IMPLICIT NONE +c + INTEGER n,i,incx,ismax,ix + real sx((n-1)*incx+1),sxmax +c + ix=1 + ismax=1 + sxmax=sx(1) + do 10 i=1,n-1 + ix=ix+incx + if(sx(ix).gt.sxmax) then + sxmax=sx(ix) + ismax=i+1 + endif +10 continue +c + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ismin.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ismin.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ismin.F (revision 1634) @@ -0,0 +1,24 @@ +! +! $Header$ +! + FUNCTION ismin(n,sx,incx) +c + IMPLICIT NONE +c + integer n,i,incx,ismin,ix + real sx((n-1)*incx+1),sxmin +c + ix=1 + ismin=1 + sxmin=sx(1) + DO i=1,n-1 + ix=ix+incx + if(sx(ix).lt.sxmin) then + sxmin=sx(ix) + ismin=i+1 + endif + ENDDO +c + return + end +C Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/juldate.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/juldate.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/juldate.F (revision 1634) @@ -0,0 +1,33 @@ +! +! $Id$ +! + subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec) +c Sous-routine de changement de date: +c gregorien>>>date julienne +c En entree:an,mois,jour,heure,min.,sec. +c En sortie:tjd + implicit real (a-h,o-z) + frac=((os/60.+om)/60.+oh)/24. + ojou=dfloat(ijou)+frac + year=dfloat(ian) + rmon=dfloat(imoi) + if (imoi .le. 2) then + year=year-1. + rmon=rmon+12. + endif + cf=year+(rmon/100.)+(ojou/10000.) + if (cf .ge. 1582.1015) then + a=int(year/100) + b=2-a+int(a/4) + else + b=0 + endif + tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou) + + +1720994.5+b + tjdsec=(ojou-int(ojou))+(tjd-int(tjd)) + tjd=int(tjd)+int(tjdsec) + tjdsec=tjdsec-int(tjdsec) + return + end + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien.F (revision 1634) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE laplacien ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + +c + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + CALL filtreg( divgra, jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel,divgra, ghx , ghy ) + CALL divergf ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_gam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_gam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_gam.F (revision 1634) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) +c + CALL grad ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_rot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_rot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_rot.F (revision 1634) @@ -0,0 +1,39 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + CALL filtreg ( rotin , jjm, klevel, 2, 1, .FALSE., 1 ) + + CALL nxgrad ( klevel, rotin, ghx , ghy ) + CALL rotatf ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_rotgam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_rotgam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/laplacien_rotgam.F (revision 1634) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c +c + + CALL nxgrad_gam ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil ( klevel, ghx , ghy , rotout ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/leapfrog.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/leapfrog.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/leapfrog.F (revision 1634) @@ -0,0 +1,778 @@ +! +! $Id$ +! +c +c + SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + & time_0) + + +cIM : pour sortir les param. du modele dans un fis. netcdf 110106 +#ifdef CPP_IOIPSL + use IOIPSL +#endif + USE infotrac + USE guide_mod, ONLY : guide_main + USE write_field + USE control_mod + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. + +c ... Possibilite de choisir le shema pour l'advection de +c q , en modifiant iadv dans traceur.def (10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +!#include "com_io_dyn.h" +#include "iniprint.h" +#include "academic.h" + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! #include "clesphys.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + real zqmin,zqmax + INTEGER nbetatmoy, nbetatdem,nbetat + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm,nqtot) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse + +c variables dynamiques au pas -1 + REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1) + REAL massem1(ip1jmp1,llm) + +c tendances dynamiques + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqtot),dp(ip1jmp1) + +c tendances de la dissipation + REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm) + REAL dtetadis(ip1jmp1,llm) + +c tendances physiques + REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm) + REAL dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqtot),dpfi(ip1jmp1) + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL tppn(iim),tpps(iim),tpn,tps +c + INTEGER itau,itaufinp1,iav +! INTEGER iday ! jour julien + REAL time + + REAL SSUM + REAL time_0 , finvmaold(ip1jmp1,llm) + +cym LOGICAL lafin + LOGICAL :: lafin=.false. + INTEGER ij,iq,l + INTEGER ik + + real time_step, t_wrt, t_ops + +! REAL rdayvrai,rdaym_ini +! jD_cur: jour julien courant +! jH_cur: heure julienne courante + REAL :: jD_cur, jH_cur + INTEGER :: an, mois, jour + REAL :: secondes + + LOGICAL first,callinigrads +cIM : pour sortir les param. du modele dans un fis. netcdf 110106 + save first + data first/.true./ + real dt_cum + character*10 infile + integer zan, tau0, thoriid + integer nid_ctesGCM + save nid_ctesGCM + real degres + real rlong(iip1), rlatg(jjp1) + real zx_tmp_2d(iip1,jjp1) + integer ndex2d(iip1*jjp1) + logical ok_sync + parameter (ok_sync = .true.) + logical physic + + data callinigrads/.true./ + character*10 string10 + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) ! flux de masse verticale + +c+jld variables test conservation energie + REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation + REAL dtetaecdt(ip1jmp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER*15 ztit +!IM INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. +!IM SAVE ip_ebil_dyn +!IM DATA ip_ebil_dyn/0/ +c-jld + + character*80 dynhist_file, dynhistave_file + character(len=*),parameter :: modname="leapfrog" + character*80 abort_message + + logical dissip_conservative + save dissip_conservative + data dissip_conservative/.true./ + + LOGICAL prem + save prem + DATA prem/.true./ + INTEGER testita + PARAMETER (testita = 9) + + logical , parameter :: flag_verif = .false. + + + integer itau_w ! pas de temps ecriture = itap + itau_phy + + + itaufin = nday*day_step + itaufinp1 = itaufin +1 + itau = 0 + physic=.true. + if (iflag_phys==0.or.iflag_phys==2) physic=.false. + +c iday = day_ini+itau/day_step +c time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +c IF(time.GT.1.) THEN +c time = time-1. +c iday = iday+1 +c ENDIF + + +c----------------------------------------------------------------------- +c On initialise la pression et la fonction d'Exner : +c -------------------------------------------------- + + dq(:,:,:)=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf ) + endif + +c----------------------------------------------------------------------- +c Debut de l'integration temporelle: +c ---------------------------------- + + 1 CONTINUE + + jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) + + +#ifdef CPP_IOIPSL + if (ok_guide) then + call guide_main(itau,ucov,vcov,teta,q,masse,ps) + endif +#endif + + +c +c IF( MOD( itau, 10* day_step ).EQ.0 ) THEN +c CALL test_period ( ucov,vcov,teta,q,p,phis ) +c PRINT *,' ---- Test_period apres continue OK ! -----', itau +c ENDIF +c + +! Save fields obtained at previous time step as '...m1' + CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) + CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) + CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) + CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) + CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) + + forward = .TRUE. + leapf = .FALSE. + dt = dtvr + +c ... P.Le Van .26/04/94 .... + + CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) + CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) + + 2 CONTINUE + +c----------------------------------------------------------------------- + +c date: +c ----- + + +c gestion des appels de la physique et des dissipations: +c ------------------------------------------------------ +c +c ... P.Le Van ( 6/02/95 ) .... + + apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + apdiss = .FALSE. + + IF( purmats ) THEN + ! Purely Matsuno time stepping + IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. + IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) + s apdiss = .TRUE. + IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward + s .and. physic ) apphys = .TRUE. + ELSE + ! Leapfrog/Matsuno time stepping + IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. + IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) + s apdiss = .TRUE. + IF( MOD(itau+1,iphysiq).EQ.0.AND.physic ) apphys=.TRUE. + END IF + +! Ehouarn: for Shallow Water case (ie: 1 vertical layer), +! supress dissipation step + if (llm.eq.1) then + apdiss=.false. + endif + +c----------------------------------------------------------------------- +c calcul des tendances dynamiques: +c -------------------------------- + + CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) + + time = jD_cur + jH_cur + CALL caldyn + $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time ) + + +c----------------------------------------------------------------------- +c calcul des tendances advection des traceurs (dont l'humidite) +c ------------------------------------------------------------- + + IF( forward. OR . leapf ) THEN + + CALL caladvtrac(q,pbaru,pbarv, + * p, masse, dq, teta, + . flxw, pk) + + IF (offline) THEN +Cmaf stokage du flux de masse pour traceurs OFF-LINE + +#ifdef CPP_IOIPSL + CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, + . dtvr, itau) +#endif + + + ENDIF ! of IF (offline) +c + ENDIF ! of IF( forward. OR . leapf ) + + +c----------------------------------------------------------------------- +c integrations dynamique et traceurs: +c ---------------------------------- + + + CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 , + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis , + $ finvmaold ) + + +c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) +c +c----------------------------------------------------------------------- +c calcul des tendances physiques: +c ------------------------------- +c ######## P.Le Van ( Modif le 6/02/95 ) ########### +c + IF( purmats ) THEN + IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. + ELSE + IF( itau+1. EQ. itaufin ) lafin = .TRUE. + ENDIF +c +c + IF( apphys ) THEN +c +c ....... Ajout P.Le Van ( 17/04/96 ) ........... +c + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta,pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf ) + endif + +! rdaym_ini = itau * dtvr / daysec +! rdayvrai = rdaym_ini + day_ini + jD_cur = jD_ref + day_ini - day_ref + $ + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) +! write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur +! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes) +! write(lunout,*)'current date = ',an, mois, jour, secondes + +c rajout debug +c lafin = .true. + + +c Inbterface avec les routines de phylmd (phymars ... ) +c ----------------------------------------------------- + +c+jld + +c Diagnostique de conservation de l'énergie : initialisation + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil dyn' +! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)! + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys + & , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF ! of IF (ip_ebil_dyn.ge.1 ) +c-jld +#ifdef CPP_IOIPSL +cIM : pour sortir les param. du modele dans un fis. netcdf 110106 + IF (first) THEN + first=.false. +#include "ini_paramLMDZ_dyn.h" + ENDIF +c +#include "write_paramLMDZ_dyn.h" +c +#endif +! #endif of #ifdef CPP_IOIPSL + CALL calfis( lafin , jD_cur, jH_cur, + $ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , + $ du,dv,dteta,dq, + $ flxw, + $ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) + + IF (ok_strato) THEN + CALL top_bound( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + ENDIF + +c ajout des tendances physiques: +c ------------------------------ + CALL addfi( dtphys, leapf, forward , + $ ucov, vcov, teta , q ,ps , + $ dufi, dvfi, dtetafi , dqfi ,dpfi ) +c +c Diagnostique de conservation de l'énergie : difference + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil phys' + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys + & , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF ! of IF (ip_ebil_dyn.ge.1 ) + + ENDIF ! of IF( apphys ) + + IF(iflag_phys.EQ.2) THEN ! "Newtonian" case +! Academic case : Simple friction and Newtonan relaxation +! ------------------------------------------------------- + DO l=1,llm + DO ij=1,ip1jmp1 + teta(ij,l)=teta(ij,l)-dtvr* + & (teta(ij,l)-tetarappel(ij,l))*(knewt_g+knewt_t(l)*clat4(ij)) + ENDDO + ENDDO ! of DO l=1,llm + + if (planet_type.eq."giant") then + ! add an intrinsic heat flux at the base of the atmosphere + teta(:,1)=teta(:,1)+dtvr*aire(:)*ihf/cpp/masse(:,1) + endif + + call friction(ucov,vcov,dtvr) + + ! Sponge layer (if any) + IF (ok_strato) THEN + dufi(:,:)=0. + dvfi(:,:)=0. + dtetafi(:,:)=0. + dqfi(:,:,:)=0. + dpfi(:)=0. + CALL top_bound(vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + CALL addfi( dtvr, leapf, forward , + $ ucov, vcov, teta , q ,ps , + $ dufi, dvfi, dtetafi , dqfi ,dpfi ) + ENDIF ! of IF (ok_strato) + ENDIF ! of IF (iflag_phys.EQ.2) + + +c-jld + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf ) + endif + + +c----------------------------------------------------------------------- +c dissipation horizontale et verticale des petites echelles: +c ---------------------------------------------------------- + + IF(apdiss) THEN + + +c calcul de l'energie cinetique avant dissipation + call covcont(llm,ucov,vcov,ucont,vcont) + call enercin(vcov,ucov,vcont,ucont,ecin0) + +c dissipation + CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis) + ucov=ucov+dudis + vcov=vcov+dvdis +c teta=teta+dtetadis + + +c------------------------------------------------------------------------ + if (dissip_conservative) then +C On rajoute la tendance due a la transform. Ec -> E therm. cree +C lors de la dissipation + call covcont(llm,ucov,vcov,ucont,vcont) + call enercin(vcov,ucov,vcont,ucont,ecin) + dtetaecdt= (ecin0-ecin)/ pk +c teta=teta+dtetaecdt + dtetadis=dtetadis+dtetaecdt + endif + teta=teta+dtetadis +c------------------------------------------------------------------------ + + +c ....... P. Le Van ( ajout le 17/04/96 ) ........... +c ... Calcul de la valeur moyenne, unique de h aux poles ..... +c + + DO l = 1, llm + DO ij = 1,iim + tppn(ij) = aire( ij ) * teta( ij ,l) + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta( ij ,l) = tpn + teta(ij+ip1jm,l) = tps + ENDDO + ENDDO + + DO ij = 1,iim + tppn(ij) = aire( ij ) * ps ( ij ) + tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + ps( ij ) = tpn + ps(ij+ip1jm) = tps + ENDDO + + + END IF ! of IF(apdiss) + +c ajout debug +c IF( lafin ) then +c abort_message = 'Simulation finished' +c call abort_gcm(modname,abort_message,0) +c ENDIF + +c ******************************************************************** +c ******************************************************************** +c .... fin de l'integration dynamique et physique pour le pas itau .. +c ******************************************************************** +c ******************************************************************** + +c preparation du pas d'integration suivant ...... + + IF ( .NOT.purmats ) THEN +c ........................................................ +c .............. schema matsuno + leapfrog .............. +c ........................................................ + + IF(forward. OR. leapf) THEN + itau= itau + 1 +c iday= day_ini+itau/day_step +c time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +c IF(time.GT.1.) THEN +c time = time-1. +c iday = iday+1 +c ENDIF + ENDIF + + + IF( itau. EQ. itaufinp1 ) then + if (flag_verif) then + write(79,*) 'ucov',ucov + write(80,*) 'vcov',vcov + write(81,*) 'teta',teta + write(82,*) 'ps',ps + write(83,*) 'q',q + WRITE(85,*) 'q1 = ',q(:,:,1) + WRITE(86,*) 'q3 = ',q(:,:,3) + endif + + abort_message = 'Simulation finished' + + call abort_gcm(modname,abort_message,0) + ENDIF +c----------------------------------------------------------------------- +c ecriture du fichier histoire moyenne: +c ------------------------------------- + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + + IF (ok_dynzon) THEN +#ifdef CPP_IOIPSL + CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, + & ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +#endif + END IF + IF (ok_dyn_ave) THEN +#ifdef CPP_IOIPSL + CALL writedynav(itau,vcov, + & ucov,teta,pk,phi,q,masse,ps,phis) +#endif + ENDIF + + ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin)) + +c----------------------------------------------------------------------- +c ecriture de la bande histoire: +c ------------------------------ + + IF( MOD(itau,iecri).EQ.0) THEN + ! Ehouarn: output only during LF or Backward Matsuno + if (leapf.or.(.not.leapf.and.(.not.forward))) then + nbetat = nbetatdem + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + unat=0. + do l=1,llm + unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) + vnat(:,l)=vcov(:,l)/cv(:) + enddo +#ifdef CPP_IOIPSL + if (ok_dyn_ins) then +! write(lunout,*) "leapfrog: call writehist, itau=",itau + CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) +! call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +! call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/))) +! call WriteField('teta',reshape(teta,(/iip1,jmp1,llm/))) +! call WriteField('ps',reshape(ps,(/iip1,jmp1/))) +! call WriteField('masse',reshape(masse,(/iip1,jmp1,llm/))) + endif ! of if (ok_dyn_ins) +#endif +! For some Grads outputs of fields + if (output_grads_dyn) then +#include "write_grads_dyn.h" + endif + endif ! of if (leapf.or.(.not.leapf.and.(.not.forward))) + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + IF(itau.EQ.itaufin) THEN + + +! if (planet_type.eq."earth") then +! Write an Earth-format restart file + CALL dynredem1("restart.nc",0.0, + & vcov,ucov,teta,q,masse,ps) +! endif ! of if (planet_type.eq."earth") + + CLOSE(99) + ENDIF ! of IF (itau.EQ.itaufin) + +c----------------------------------------------------------------------- +c gestion de l'integration temporelle: +c ------------------------------------ + + IF( MOD(itau,iperiod).EQ.0 ) THEN + GO TO 1 + ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN + + IF( forward ) THEN +c fin du pas forward et debut du pas backward + + forward = .FALSE. + leapf = .FALSE. + GO TO 2 + + ELSE +c fin du pas backward et debut du premier pas leapfrog + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (forward) + ELSE + +c ...... pas leapfrog ..... + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (MOD(itau,iperiod).EQ.0) + ! ELSEIF (MOD(itau-1,iperiod).EQ.0) + + ELSE ! of IF (.not.purmats) + +c ........................................................ +c .............. schema matsuno ............... +c ........................................................ + IF( forward ) THEN + + itau = itau + 1 +c iday = day_ini+itau/day_step +c time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +c +c IF(time.GT.1.) THEN +c time = time-1. +c iday = iday+1 +c ENDIF + + forward = .FALSE. + IF( itau. EQ. itaufinp1 ) then + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + ENDIF + GO TO 2 + + ELSE ! of IF(forward) i.e. backward step + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + + IF (ok_dynzon) THEN +#ifdef CPP_IOIPSL + CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, + & ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +#endif + ENDIF + IF (ok_dyn_ave) THEN +#ifdef CPP_IOIPSL + CALL writedynav(itau,vcov, + & ucov,teta,pk,phi,q,masse,ps,phis) +#endif + ENDIF + + ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) + + IF(MOD(itau,iecri ).EQ.0) THEN +c IF(MOD(itau,iecri*day_step).EQ.0) THEN + nbetat = nbetatdem + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + unat=0. + do l=1,llm + unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) + vnat(:,l)=vcov(:,l)/cv(:) + enddo +#ifdef CPP_IOIPSL + if (ok_dyn_ins) then +! write(lunout,*) "leapfrog: call writehist (b)", +! & itau,iecri + CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) + endif ! of if (ok_dyn_ins) +#endif +! For some Grads outputs + if (output_grads_dyn) then +#include "write_grads_dyn.h" + endif + + ENDIF ! of IF(MOD(itau,iecri ).EQ.0) + + IF(itau.EQ.itaufin) THEN +! if (planet_type.eq."earth") then + CALL dynredem1("restart.nc",0.0, + & vcov,ucov,teta,q,masse,ps) +! endif ! of if (planet_type.eq."earth") + ENDIF ! of IF(itau.EQ.itaufin) + + forward = .TRUE. + GO TO 1 + + ENDIF ! of IF (forward) + + END IF ! of IF(.not.purmats) + + STOP + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limit_netcdf.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limit_netcdf.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limit_netcdf.F90 (revision 1634) @@ -0,0 +1,642 @@ +! +! $Id$ +!------------------------------------------------------------------------------- +! +SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque) +! +!------------------------------------------------------------------------------- +! Author : L. Fairhead, 27/01/94 +!------------------------------------------------------------------------------- +! Purpose: Boundary conditions files building for new model using climatologies. +! Both grids have to be regular. +!------------------------------------------------------------------------------- +! Note: This routine is designed to work for Earth +!------------------------------------------------------------------------------- +! Modification history: +! * 23/03/1994: Z. X. Li +! * 09/1999: L. Fairhead (netcdf reading in LMDZ.3.3) +! * 07/2001: P. Le Van +! * 11/2009: L. Guez (ozone day & night climatos, see etat0_netcdf.F90) +! * 12/2009: D. Cugnet (f77->f90, calendars, files from coupled runs) +!------------------------------------------------------------------------------- + USE control_mod +#ifdef CPP_EARTH + USE dimphy + USE ioipsl, ONLY : ioget_year_len + USE phys_state_var_mod, ONLY : pctsrf + USE netcdf, ONLY : NF90_OPEN, NF90_CREATE, NF90_CLOSE, & + NF90_DEF_DIM, NF90_DEF_VAR, NF90_PUT_VAR, NF90_PUT_ATT, & + NF90_NOERR, NF90_NOWRITE, NF90_DOUBLE, NF90_GLOBAL, & + NF90_CLOBBER, NF90_ENDDEF, NF90_UNLIMITED, NF90_FLOAT + USE inter_barxy_m, only: inter_barxy +#endif + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" + LOGICAL, INTENT(IN) :: interbar ! barycentric interpolation + LOGICAL, INTENT(IN) :: extrap ! SST extrapolation flag + LOGICAL, INTENT(IN) :: oldice ! old way ice computation + REAL, DIMENSION(iip1,jjp1), INTENT(IN) :: masque ! land mask +#ifndef CPP_EARTH + CALL abort_gcm('limit_netcdf','Earth-specific routine, needs Earth physics',1) +#else +!------------------------------------------------------------------------------- +! Local variables: +#include "logic.h" +#include "comvert.h" +#include "comgeom2.h" +#include "comconst.h" +#include "indicesol.h" + +!--- INPUT NETCDF FILES NAMES -------------------------------------------------- + CHARACTER(LEN=25) :: icefile, sstfile, dumstr + CHARACTER(LEN=25), PARAMETER :: famipsst='amipbc_sst_1x1.nc ', & + famipsic='amipbc_sic_1x1.nc ', & + fcpldsst='cpl_atm_sst.nc ', & + fcpldsic='cpl_atm_sic.nc ', & + fhistsst='histmth_sst.nc ', & + fhistsic='histmth_sic.nc ', & + frugo ='Rugos.nc ', & + falbe ='Albedo.nc ' + CHARACTER(LEN=10) :: varname +!--- OUTPUT VARIABLES FOR NETCDF FILE ------------------------------------------ + REAL, DIMENSION(klon) :: fi_ice, verif + REAL, DIMENSION(:,:), POINTER :: phy_rug=>NULL(), phy_ice=>NULL() + REAL, DIMENSION(:,:), POINTER :: phy_sst=>NULL(), phy_alb=>NULL() + REAL, DIMENSION(:,:), ALLOCATABLE :: phy_bil + REAL, DIMENSION(:,:,:), ALLOCATABLE :: pctsrf_t + INTEGER :: nbad + +!--- VARIABLES FOR OUTPUT FILE WRITING ----------------------------------------- + INTEGER :: ierr, nid, ndim, ntim, k + INTEGER, DIMENSION(2) :: dims + INTEGER :: id_tim, id_SST, id_BILS, id_RUG, id_ALB + INTEGER :: id_FOCE, id_FSIC, id_FTER, id_FLIC + INTEGER :: NF90_FORMAT + INTEGER :: ndays !--- Depending on the output calendar + +!--- INITIALIZATIONS ----------------------------------------------------------- +#ifdef NC_DOUBLE + NF90_FORMAT=NF90_DOUBLE +#else + NF90_FORMAT=NF90_FLOAT +#endif + + pi = 4.*ATAN(1.) + rad = 6371229. + daysec= 86400. + omeg = 2.*pi/daysec + g = 9.8 + kappa = 0.2857143 + cpp = 1004.70885 + dtvr = daysec/REAL(day_step) + CALL inigeom + +!--- Beware: anneeref (from gcm.def) is used to determine output time sampling + ndays=ioget_year_len(anneeref) + +!--- RUGOSITY TREATMENT -------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de la rugosite' + varname='RUGOS' + CALL get_2Dfield(frugo,varname,'RUG',interbar,ndays,phy_rug,mask=masque(1:iim,:)) + +!--- OCEAN TREATMENT ----------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de la glace oceanique' + +! Input SIC file selection +! Open file only to test if available + IF ( NF90_OPEN(TRIM(famipsic),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + icefile=TRIM(famipsic) + varname='sicbcs' + ELSE IF( NF90_OPEN(TRIM(fcpldsic),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + icefile=TRIM(fcpldsic) + varname='SIICECOV' + ELSE IF ( NF90_OPEN(TRIM(fhistsic),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + icefile=TRIM(fhistsic) + varname='pourc_sic' + ELSE + WRITE(lunout,*) 'ERROR! No sea-ice input file was found.' + WRITE(lunout,*) 'One of following files must be availible : ',trim(famipsic),', ',trim(fcpldsic),', ',trim(fhistsic) + CALL abort_gcm('limit_netcdf','No sea-ice file was found',1) + END IF + ierr=NF90_CLOSE(nid) + IF (prt_level>=0) WRITE(lunout,*)'Pour la glace de mer a ete choisi le fichier '//TRIM(icefile) + + CALL get_2Dfield(icefile,varname, 'SIC',interbar,ndays,phy_ice,flag=oldice) + + ALLOCATE(pctsrf_t(klon,nbsrf,ndays)) + DO k=1,ndays + fi_ice=phy_ice(:,k) + WHERE(fi_ice>=1.0 ) fi_ice=1.0 + WHERE(fi_ice=1.0-zmasq) + pctsrf_t(:,is_sic,k)=1.0-zmasq + pctsrf_t(:,is_oce,k)=0.0 + ELSEWHERE + pctsrf_t(:,is_oce,k)=1.0-zmasq-pctsrf_t(:,is_sic,k) + WHERE(pctsrf_t(:,is_oce,k)0) WRITE(lunout,*) 'pb sous maille pour nb point = ',nbad + nbad=COUNT(abs(sum(pctsrf_t(:,:,k),dim=2)-1.0)>EPSFRA) + IF(nbad>0) WRITE(lunout,*) 'pb sous surface pour nb points = ',nbad + END DO + DEALLOCATE(phy_ice) + +!--- SST TREATMENT ------------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de la sst' + +! Input SST file selection +! Open file only to test if available + IF ( NF90_OPEN(TRIM(famipsst),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + sstfile=TRIM(famipsst) + varname='tosbcs' + ELSE IF ( NF90_OPEN(TRIM(fcpldsst),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + sstfile=TRIM(fcpldsst) + varname='SISUTESW' + ELSE IF ( NF90_OPEN(TRIM(fhistsst),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + sstfile=TRIM(fhistsst) + varname='tsol_oce' + ELSE + WRITE(lunout,*) 'ERROR! No sst input file was found.' + WRITE(lunout,*) 'One of following files must be availible : ',trim(famipsst),trim(fcpldsst),trim(fhistsst) + CALL abort_gcm('limit_netcdf','No sst file was found',1) + END IF + ierr=NF90_CLOSE(nid) + IF (prt_level>=0) WRITE(lunout,*)'Pour la temperature de mer a ete choisi un fichier '//TRIM(sstfile) + + CALL get_2Dfield(sstfile,varname,'SST',interbar,ndays,phy_sst,flag=extrap) + +!--- ALBEDO TREATMENT ---------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de l albedo' + varname='ALBEDO' + CALL get_2Dfield(falbe,varname,'ALB',interbar,ndays,phy_alb) + +!--- REFERENCE GROUND HEAT FLUX TREATMENT -------------------------------------- + ALLOCATE(phy_bil(klon,ndays)); phy_bil=0.0 + +!--- OUTPUT FILE WRITING ------------------------------------------------------- + IF (prt_level>5) WRITE(lunout,*) 'Ecriture du fichier limit : debut' + + !--- File creation + ierr=NF90_CREATE("limit.nc",NF90_CLOBBER,nid) + ierr=NF90_PUT_ATT(nid,NF90_GLOBAL,"title","Fichier conditions aux limites") + + !--- Dimensions creation + ierr=NF90_DEF_DIM(nid,"points_physiques",klon,ndim) + ierr=NF90_DEF_DIM(nid,"time",NF90_UNLIMITED,ntim) + + dims=(/ndim,ntim/) + + !--- Variables creation + ierr=NF90_DEF_VAR(nid,"TEMPS",NF90_FORMAT,(/ntim/),id_tim) + ierr=NF90_DEF_VAR(nid,"FOCE", NF90_FORMAT,dims,id_FOCE) + ierr=NF90_DEF_VAR(nid,"FSIC", NF90_FORMAT,dims,id_FSIC) + ierr=NF90_DEF_VAR(nid,"FTER", NF90_FORMAT,dims,id_FTER) + ierr=NF90_DEF_VAR(nid,"FLIC", NF90_FORMAT,dims,id_FLIC) + ierr=NF90_DEF_VAR(nid,"SST", NF90_FORMAT,dims,id_SST) + ierr=NF90_DEF_VAR(nid,"BILS", NF90_FORMAT,dims,id_BILS) + ierr=NF90_DEF_VAR(nid,"ALB", NF90_FORMAT,dims,id_ALB) + ierr=NF90_DEF_VAR(nid,"RUG", NF90_FORMAT,dims,id_RUG) + + !--- Attributes creation + ierr=NF90_PUT_ATT(nid,id_tim, "title","Jour dans l annee") + ierr=NF90_PUT_ATT(nid,id_FOCE,"title","Fraction ocean") + ierr=NF90_PUT_ATT(nid,id_FSIC,"title","Fraction glace de mer") + ierr=NF90_PUT_ATT(nid,id_FTER,"title","Fraction terre") + ierr=NF90_PUT_ATT(nid,id_FLIC,"title","Fraction land ice") + ierr=NF90_PUT_ATT(nid,id_SST ,"title","Temperature superficielle de la mer") + ierr=NF90_PUT_ATT(nid,id_BILS,"title","Reference flux de chaleur au sol") + ierr=NF90_PUT_ATT(nid,id_ALB, "title","Albedo a la surface") + ierr=NF90_PUT_ATT(nid,id_RUG, "title","Rugosite") + + ierr=NF90_ENDDEF(nid) + + !--- Variables saving + ierr=NF90_PUT_VAR(nid,id_tim,(/(REAL(k),k=1,ndays)/)) + ierr=NF90_PUT_VAR(nid,id_FOCE,pctsrf_t(:,is_oce,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_FSIC,pctsrf_t(:,is_sic,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_FTER,pctsrf_t(:,is_ter,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_FLIC,pctsrf_t(:,is_lic,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_SST ,phy_sst(:,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_BILS,phy_bil(:,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_ALB ,phy_alb(:,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_RUG ,phy_rug(:,:),(/1,1/),(/klon,ndays/)) + + ierr=NF90_CLOSE(nid) + + IF (prt_level>5) WRITE(lunout,*) 'Ecriture du fichier limit : fin' + + DEALLOCATE(pctsrf_t,phy_sst,phy_bil,phy_alb,phy_rug) + + +!=============================================================================== +! + CONTAINS +! +!=============================================================================== + + +!------------------------------------------------------------------------------- +! +SUBROUTINE get_2Dfield(fnam, varname, mode, ibar, ndays, champo, flag, mask) +! +!----------------------------------------------------------------------------- +! Comments: +! There are two assumptions concerning the NetCDF files, that are satisfied +! with files that are conforming NC convention: +! 1) The last dimension of the variables used is the time record. +! 2) Dimensional variables have the same names as corresponding dimensions. +!----------------------------------------------------------------------------- + USE netcdf, ONLY: NF90_OPEN, NF90_INQ_VARID, NF90_INQUIRE_VARIABLE, & + NF90_CLOSE, NF90_INQ_DIMID, NF90_INQUIRE_DIMENSION, NF90_GET_VAR, & + NF90_GET_ATT + USE dimphy, ONLY : klon + USE phys_state_var_mod, ONLY : pctsrf + USE control_mod + use pchsp_95_m, only: pchsp_95 + use pchfe_95_m, only: pchfe_95 + use arth_m, only: arth + + IMPLICIT NONE +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "indicesol.h" +#include "iniprint.h" +!----------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: fnam ! NetCDF file name + CHARACTER(LEN=10), INTENT(IN) :: varname ! NetCDF variable name + CHARACTER(LEN=3), INTENT(IN) :: mode ! RUG, SIC, SST or ALB + LOGICAL, INTENT(IN) :: ibar ! interp on pressure levels + INTEGER, INTENT(IN) :: ndays ! current year number of days + REAL, POINTER, DIMENSION(:, :) :: champo ! output field = f(t) + LOGICAL, OPTIONAL, INTENT(IN) :: flag ! extrapol. (SST) old ice (SIC) + REAL, OPTIONAL, DIMENSION(iim, jjp1), INTENT(IN) :: mask +!------------------------------------------------------------------------------ +! Local variables: +!--- NetCDF + INTEGER :: ncid, varid ! NetCDF identifiers + CHARACTER(LEN=30) :: dnam ! dimension name +!--- dimensions + INTEGER, DIMENSION(4) :: dids ! NetCDF dimensions identifiers + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_ini ! initial longitudes vector + REAL, ALLOCATABLE, DIMENSION(:) :: dlat_ini ! initial latitudes vector + REAL, POINTER, DIMENSION(:) :: dlon, dlat ! reordered lon/lat vectors +!--- fields + INTEGER :: imdep, jmdep, lmdep ! dimensions of 'champ' + REAL, ALLOCATABLE, DIMENSION(:, :) :: champ ! wanted field on initial grid + REAL, ALLOCATABLE, DIMENSION(:) :: yder, timeyear + REAL, DIMENSION(iim, jjp1) :: champint ! interpolated field + REAL, ALLOCATABLE, DIMENSION(:, :, :) :: champtime + REAL, ALLOCATABLE, DIMENSION(:, :, :) :: champan +!--- input files + CHARACTER(LEN=20) :: cal_in ! calendar + CHARACTER(LEN=20) :: unit_sic ! attribute unit in sea-ice file + INTEGER :: ndays_in ! number of days +!--- misc + INTEGER :: i, j, k, l ! loop counters + REAL, ALLOCATABLE, DIMENSION(:, :) :: work ! used for extrapolation + CHARACTER(LEN=25) :: title ! for messages + LOGICAL :: extrp ! flag for extrapolation + LOGICAL :: oldice ! flag for old way ice computation + REAL :: chmin, chmax + INTEGER ierr + integer n_extrap ! number of extrapolated points + logical skip + +!------------------------------------------------------------------------------ +!---Variables depending on keyword 'mode' ------------------------------------- + NULLIFY(champo) + + SELECT CASE(mode) + CASE('RUG'); title='Rugosite' + CASE('SIC'); title='Sea-ice' + CASE('SST'); title='SST' + CASE('ALB'); title='Albedo' + END SELECT + + + extrp=.FALSE. + oldice=.FALSE. + IF ( PRESENT(flag) ) THEN + IF ( flag .AND. mode=='SST' ) extrp=.TRUE. + IF ( flag .AND. mode=='SIC' ) oldice=.TRUE. + END IF + +!--- GETTING SOME DIMENSIONAL VARIABLES FROM FILE ----------------------------- + IF (prt_level>5) WRITE(lunout,*) ' Now reading file : ',fnam + ierr=NF90_OPEN(fnam, NF90_NOWRITE, ncid); CALL ncerr(ierr, fnam) + ierr=NF90_INQ_VARID(ncid, trim(varname), varid); CALL ncerr(ierr, fnam) + ierr=NF90_INQUIRE_VARIABLE(ncid, varid, dimids=dids); CALL ncerr(ierr, fnam) + +!--- Read unit for sea-ice variable only + IF (mode=='SIC') THEN + ierr=NF90_GET_ATT(ncid, varid, 'units', unit_sic) + IF(ierr/=NF90_NOERR) THEN + IF (prt_level>5) WRITE(lunout,*) 'No unit was given in sea-ice file. Take percentage as default value' + unit_sic='X' + ELSE + IF (prt_level>5) WRITE(lunout,*) ' Sea-ice cover has unit=',unit_sic + END IF + END IF + +!--- Longitude + ierr=NF90_INQUIRE_DIMENSION(ncid, dids(1), name=dnam, len=imdep) + CALL ncerr(ierr, fnam); ALLOCATE(dlon_ini(imdep), dlon(imdep)) + ierr=NF90_INQ_VARID(ncid, dnam, varid); CALL ncerr(ierr, fnam) + ierr=NF90_GET_VAR(ncid, varid, dlon_ini); CALL ncerr(ierr, fnam) + IF (prt_level>5) WRITE(lunout, *) 'variable ', dnam, 'dimension ', imdep + +!--- Latitude + ierr=NF90_INQUIRE_DIMENSION(ncid, dids(2), name=dnam, len=jmdep) + CALL ncerr(ierr, fnam); ALLOCATE(dlat_ini(jmdep), dlat(jmdep)) + ierr=NF90_INQ_VARID(ncid, dnam, varid); CALL ncerr(ierr, fnam) + ierr=NF90_GET_VAR(ncid, varid, dlat_ini); CALL ncerr(ierr, fnam) + IF (prt_level>5) WRITE(lunout, *) 'variable ', dnam, 'dimension ', jmdep + +!--- Time (variable is not needed - it is rebuilt - but calendar is) + ierr=NF90_INQUIRE_DIMENSION(ncid, dids(3), name=dnam, len=lmdep) + CALL ncerr(ierr, fnam); ALLOCATE(timeyear(lmdep)) + ierr=NF90_INQ_VARID(ncid, dnam, varid); CALL ncerr(ierr, fnam) + cal_in=' ' + ierr=NF90_GET_ATT(ncid, varid, 'calendar', cal_in) + IF(ierr/=NF90_NOERR) THEN + SELECT CASE(mode) + CASE('RUG', 'ALB'); cal_in='360d' + CASE('SIC', 'SST'); cal_in='gregorian' + END SELECT + IF (prt_level>5) WRITE(lunout, *)'ATTENTION: variable "time" sans attribut "calendrier" ' & + // 'dans '//TRIM(fnam)//'. On choisit la valeur par defaut.' + END IF + IF (prt_level>5) WRITE(lunout, *) 'variable ', dnam, 'dimension ', lmdep, 'calendrier ', & + cal_in + + +!--- CONSTRUCTING THE INPUT TIME VECTOR FOR INTERPOLATION -------------------- + !--- Determining input file number of days, depending on calendar + ndays_in=year_len(anneeref, cal_in) + +!--- Time vector reconstruction (time vector from file is not trusted) +!--- If input records are not monthly, time sampling has to be constant ! + timeyear=mid_months(anneeref, cal_in, lmdep) + IF (lmdep /= 12) WRITE(lunout,*) 'Note : les fichiers de ', TRIM(mode), & + ' ne comportent pas 12, mais ', lmdep, ' enregistrements.' + +!--- GETTING THE FIELD AND INTERPOLATING IT ---------------------------------- + ALLOCATE(champ(imdep, jmdep), champtime(iim, jjp1, lmdep)) + IF(extrp) ALLOCATE(work(imdep, jmdep)) + + IF (prt_level>5) WRITE(lunout, *) + IF (prt_level>5) WRITE(lunout,*)'LECTURE ET INTERPOLATION HORIZ. DE ', lmdep, ' CHAMPS.' + ierr=NF90_INQ_VARID(ncid, varname, varid); CALL ncerr(ierr, fnam) + DO l=1, lmdep + ierr=NF90_GET_VAR(ncid, varid, champ, (/1, 1, l/), (/imdep, jmdep, 1/)) + CALL ncerr(ierr, fnam) + CALL conf_dat2d(title, imdep, jmdep, dlon_ini, dlat_ini, dlon, dlat, & + champ, ibar) + + IF (extrp) CALL extrapol(champ, imdep, jmdep, 999999., .TRUE., .TRUE., 2, & + work) + + IF(ibar .AND. .NOT.oldice) THEN + IF(l==1 .AND. prt_level>5) THEN + WRITE(lunout, *) '-------------------------------------------------------------------------' + WRITE(lunout, *) 'Utilisation de l''interpolation barycentrique pour ',TRIM(title),' $$$' + WRITE(lunout, *) '-------------------------------------------------------------------------' + END IF + IF(mode=='RUG') champ=LOG(champ) + CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim), & + rlatv, champint) + IF(mode=='RUG') THEN + champint=EXP(champint) + WHERE(NINT(mask)/=1) champint=0.001 + END IF + ELSE + SELECT CASE(mode) + CASE('RUG'); CALL rugosite(imdep, jmdep, dlon, dlat, champ, & + iim, jjp1, rlonv, rlatu, champint, mask) + CASE('SIC'); CALL sea_ice (imdep, jmdep, dlon, dlat, champ, & + iim, jjp1, rlonv, rlatu, champint) + CASE('SST', 'ALB'); CALL grille_m(imdep, jmdep, dlon, dlat, champ, & + iim, jjp1, rlonv, rlatu, champint) + END SELECT + END IF + champtime(:, :, l)=champint + END DO + ierr=NF90_CLOSE(ncid); CALL ncerr(ierr, fnam) + + DEALLOCATE(dlon_ini, dlat_ini, dlon, dlat, champ) + IF(extrp) DEALLOCATE(work) + +!--- TIME INTERPOLATION ------------------------------------------------------ + IF (prt_level>5) THEN + WRITE(lunout, *) + WRITE(lunout, *)'INTERPOLATION TEMPORELLE.' + WRITE(lunout, *)' Vecteur temps en entree: ', timeyear + WRITE(lunout, *)' Vecteur temps en sortie de 0 a ', ndays + END IF + + ALLOCATE(yder(lmdep), champan(iip1, jjp1, ndays)) + skip = .false. + n_extrap = 0 + DO j=1, jjp1 + DO i=1, iim + yder = pchsp_95(timeyear, champtime(i, j, :), ibeg=2, iend=2, & + vc_beg=0., vc_end=0.) + CALL pchfe_95(timeyear, champtime(i, j, :), yder, skip, & + arth(0., real(ndays_in) / ndays, ndays), champan(i, j, :), ierr) + if (ierr < 0) stop 1 + n_extrap = n_extrap + ierr + END DO + END DO + if (n_extrap /= 0) then + WRITE(lunout,*) "get_2Dfield pchfe_95: n_extrap = ", n_extrap + end if + champan(iip1, :, :)=champan(1, :, :) + DEALLOCATE(yder, champtime, timeyear) + +!--- Checking the result + DO j=1, jjp1 + CALL minmax(iip1, champan(1, j, 10), chmin, chmax) + IF (prt_level>5) WRITE(lunout, *)' ',TRIM(title),' au temps 10 ', chmin, chmax, j + END DO + +!--- SPECIAL FILTER FOR SST: SST>271.38 -------------------------------------- + IF(mode=='SST') THEN + IF (prt_level>5) WRITE(lunout, *) 'Filtrage de la SST: SST >= 271.38' + WHERE(champan<271.38) champan=271.38 + END IF + +!--- SPECIAL FILTER FOR SIC: 0.05) WRITE(lunout, *) 'Filtrage de la SIC: 0.0 < Sea-ice < 1.0' + + IF (unit_sic=='1') THEN + ! Nothing to be done for sea-ice field is already in fraction of 1 + ! This is the case for sea-ice in file cpl_atm_sic.nc + IF (prt_level>5) WRITE(lunout,*) 'Sea-ice field already in fraction of 1' + ELSE + ! Convert sea ice from percentage to fraction of 1 + IF (prt_level>5) WRITE(lunout,*) 'Transformt sea-ice field from percentage to fraction of 1.' + champan(:, :, :)=champan(:, :, :)/100. + END IF + + champan(iip1, :, :)=champan(1, :, :) + WHERE(champan>1.0) champan=1.0 + WHERE(champan<0.0) champan=0.0 + END IF + +!--- DYNAMICAL TO PHYSICAL GRID ---------------------------------------------- + ALLOCATE(champo(klon, ndays)) + DO k=1, ndays + CALL gr_dyn_fi(1, iip1, jjp1, klon, champan(1, 1, k), champo(1, k)) + END DO + DEALLOCATE(champan) + +END SUBROUTINE get_2Dfield +! +!------------------------------------------------------------------------------- + + + +!------------------------------------------------------------------------------- +! +FUNCTION year_len(y,cal_in) +! +!------------------------------------------------------------------------------- + USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_year_len + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + INTEGER :: year_len + INTEGER, INTENT(IN) :: y + CHARACTER(LEN=*), INTENT(IN) :: cal_in +!------------------------------------------------------------------------------- +! Local variables: + CHARACTER(LEN=20) :: cal_out ! calendar (for outputs) +!------------------------------------------------------------------------------- +!--- Getting the input calendar to reset at the end of the function + CALL ioget_calendar(cal_out) + +!--- Unlocking calendar and setting it to wanted one + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in)) + +!--- Getting the number of days in this year + year_len=ioget_year_len(y) + +!--- Back to original calendar + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out)) + +END FUNCTION year_len +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +FUNCTION mid_months(y,cal_in,nm) +! +!------------------------------------------------------------------------------- + USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_mon_len + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: y ! year + CHARACTER(LEN=*), INTENT(IN) :: cal_in ! calendar + INTEGER, INTENT(IN) :: nm ! months/year number + REAL, DIMENSION(nm) :: mid_months ! mid-month times +!------------------------------------------------------------------------------- +! Local variables: + CHARACTER(LEN=99) :: mess ! error message + CHARACTER(LEN=20) :: cal_out ! calendar (for outputs) + INTEGER, DIMENSION(nm) :: mnth ! months lengths (days) + INTEGER :: m ! months counter + INTEGER :: nd ! number of days +!------------------------------------------------------------------------------- + nd=year_len(y,cal_in) + + IF(nm==12) THEN + + !--- Getting the input calendar to reset at the end of the function + CALL ioget_calendar(cal_out) + + !--- Unlocking calendar and setting it to wanted one + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in)) + + !--- Getting the length of each month + DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO + + !--- Back to original calendar + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out)) + + ELSE IF(MODULO(nd,nm)/=0) THEN + WRITE(mess,'(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',& + nm,' months/year. Months number should divide days number.' + CALL abort_gcm('mid_months',TRIM(mess),1) + + ELSE + mnth=(/(m,m=1,nm,nd/nm)/) + END IF + +!--- Mid-months times + mid_months(1)=0.5*REAL(mnth(1)) + DO k=2,nm + mid_months(k)=mid_months(k-1)+0.5*REAL(mnth(k-1)+mnth(k)) + END DO + +END FUNCTION mid_months +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE ncerr(ncres,fnam) +! +!------------------------------------------------------------------------------- +! Purpose: NetCDF errors handling. +!------------------------------------------------------------------------------- + USE netcdf, ONLY : NF90_NOERR, NF90_STRERROR + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: ncres + CHARACTER(LEN=*), INTENT(IN) :: fnam +!------------------------------------------------------------------------------- +#include "iniprint.h" + IF(ncres/=NF90_NOERR) THEN + WRITE(lunout,*)'Problem with file '//TRIM(fnam)//' in routine limit_netcdf.' + CALL abort_gcm('limit_netcdf',NF90_STRERROR(ncres),1) + END IF + +END SUBROUTINE ncerr +! +!------------------------------------------------------------------------------- + +#endif +! of #ifdef CPP_EARTH + +END SUBROUTINE limit_netcdf Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limx.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limx.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limx.F (revision 1634) @@ -0,0 +1,110 @@ +! +! $Header$ +! + SUBROUTINE limx(s0,sx,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sx(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dxq(ip1jmp1,llm) + + + REAL new_m,zm + real dxqu(ip1jmp1) + real adxqu(ip1jmp1),dxqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dxq(ij,l) = sx(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente a droite et a gauche de la maille + + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + enddo + + do ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=iip2+1,ip1jm + dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij)) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim)=dxqmax(ij) + enddo + +c calcul de la pente avec limitation + + do ij=iip2+1,ip1jm + if( dxqu(ij-1)*dxqu(ij).gt.0. + & .and. dxq(ij,l)*dxqu(ij).gt.0.) then + dxq(ij,l)= + & sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l)) + else +c extremum local + dxq(ij,l)=0. + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + enddo + + DO ij=1,ip1jmp1 + sx(ij,l) = dxq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limy.F (revision 1634) @@ -0,0 +1,194 @@ +c +c $Id$ +c + SUBROUTINE limy(s0,sy,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL q(ip1jmp1,llm) + REAL airej2,airejjm,airescb(iim),airesch(iim) + real sigv,dyq(ip1jmp1),dyqv(ip1jm) + real adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2 + Logical extremum,first + save first + + real convpn,convps,convmpn,convmps + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon +c +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + endif + +c + + do l = 1, llm +c + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dyq(ij) = sy(ij,l) / sm ( ij,l ) + ENDDO +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + do ij=iip2,ip1jm + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + enddo + +c calcul des pentes aux poles + +c calcul des pentes limites aux poles + +c print*,dyqv(iip1+1) +c appn=abs(dyq(1)/dyqv(iip1+1)) +c print*,dyq(ip1jm+1) +c print*,dyqv(ip1jm-iip1+1) +c apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +c do ij=2,iim +c appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) +c apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) +c enddo +c appn=min(pente_max/appn,1.) +c apps=min(pente_max/apps,1.) + + +c cas ou on a un extremum au pole + +c if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +c & appn=0. +c if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +c & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +c & apps=0. + +c limitation des pentes aux poles +c do ij=1,iip1 +c dyq(ij)=appn*dyq(ij) +c dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) +c enddo + +c test +c do ij=1,iip1 +c dyq(iip1+ij)=0. +c dyq(ip1jm+ij-iip1)=0. +c enddo +c do ij=1,ip1jmp1 +c dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +c enddo + + if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) + & then + do ij=1,iip1 + dyqmax(ij)=0. + enddo + else + do ij=1,iip1 + dyqmax(ij)=pente_max*abs(dyqv(ij)) + enddo + endif + + if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* + & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) + &then + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=0. + enddo + else + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) + enddo + endif + +c calcul des pentes limitees + + do ij=1,ip1jmp1 + if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then + dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij)) + else + dyq(ij)=0. + endif + enddo + + DO ij=1,ip1jmp1 + sy(ij,l) = dyq(ij) * sm ( ij,l ) + ENDDO + + enddo ! fin de la boucle sur les couches verticales + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limz.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limz.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/limz.F (revision 1634) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE limz(s0,sz,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sz(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dzq(ip1jmp1,llm) + + + REAL new_m,zm + real dzqw(ip1jmp1) + real adzqw(ip1jmp1),dzqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dzq(ij,l) = sz(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente en haut et en bas de la maille + do ij=1,ip1jmp1 + do l = 1, llm-1 + dzqw(l)=q(ij,l+1)-q(ij,l) + enddo + dzqw(llm)=0. + + do l=1,llm + adzqw(l)=abs(dzqw(l)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=2,llm-1 + dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l)) + enddo + +c calcul de la pente avec limitation + + do l=2,llm-1 + if( dzqw(l-1)*dzqw(l).gt.0. + & .and. dzq(ij,l)*dzqw(l).gt.0.) then + dzq(ij,l)= + & sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l)) + else +c extremum local + dzq(ij,l)=0. + endif + enddo + + DO l=1,llm + sz(ij,l) = dzq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/logic.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/logic.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/logic.h (revision 1634) @@ -0,0 +1,25 @@ +! +! $Id$ +! +! +! NB: keep items of different kinds in seperate common blocs to avoid +! "misaligned commons" issues +!----------------------------------------------------------------------- +! INCLUDE 'logic.h' + + COMMON/logicl/ purmats,forward,leapf,apphys, & + & statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile & + & ,ok_limit,ok_etat0,grilles_gcm_netcdf,hybrid + + COMMON/logici/ iflag_phys,iflag_trac + + LOGICAL purmats,forward,leapf,apphys,statcl,conser, & + & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile & + & ,ok_limit,ok_etat0,grilles_gcm_netcdf + logical hybrid ! vertical coordinate is hybrid if true (sigma otherwise) + ! (only used if disvert_type==2) + + integer iflag_phys,iflag_trac +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massbar.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massbar.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massbar.F (revision 1634) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE massbar( masse, massebx, masseby ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , + * masseby( ip1jm,llm ) +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + DO ij = iip1, ip1jmp1, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + DO ij = 1,ip1jm + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massbarxy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massbarxy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massbarxy.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE massbarxy( masse, massebxy ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebxy( ip1jm,llm ) +c + + DO 100 l = 1 , llm +c + DO 5 ij = 1, ip1jm - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massdair.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massdair.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/massdair.F (revision 1634) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE massdair( p, masse ) +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) + +c .... Variables locales ..... + + INTEGER l,ij + REAL massemoyn, massemoys + + REAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = 1, ip1jmp1,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/minmax.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/minmax.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/minmax.F (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! + SUBROUTINE minmax(imax, xi, zmin, zmax ) +c +c P. Le Van + + INTEGER imax + REAL xi(imax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/minmax2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/minmax2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/minmax2.F (revision 1634) @@ -0,0 +1,20 @@ +! +! $Header$ +! + SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax ) +c + INTEGER lmax,jmax,imax + REAL xi(imax*jmax*lmax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax*jmax*lmax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/mod_const_para.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/mod_const_para.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/mod_const_para.F90 (revision 1634) @@ -0,0 +1,16 @@ +MODULE mod_const_mpi + + INTEGER :: COMM_LMDZ + INTEGER :: MPI_REAL_LMDZ + + +CONTAINS + + SUBROUTINE Init_const_mpi + IMPLICIT NONE + + COMM_LMDZ=0 + MPI_REAL_LMDZ=0 + END SUBROUTINE Init_const_mpi + +END MODULE mod_const_mpi Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrad.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrad.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrad.F (revision 1634) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE nxgrad (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrad_gam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrad_gam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrad_gam.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgrad_gam( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgradst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgradst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgradst.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgradst (klevel,rot, x, y ) +c + IMPLICIT NONE +c Auteur : P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y(ij,l)=( rot(ij,l) - rot(ij-1,l)) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... + + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x(ij,l)= rot(ij,l)-rot(ij-iip1,l) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgraro2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgraro2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgraro2.F (revision 1634) @@ -0,0 +1,68 @@ +! +! $Header$ +! + SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL rot(ip1jm,llm) , signe, nugradrs + INTEGER l,ij,iter,lr +c ........................................................ +c +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c + CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) +c + CALL rotatf ( klevel, grx, gry, rot ) +c + CALL laplacien_rot ( klevel, rot, rot,grx,gry ) + +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 + CALL laplacien_rotgam ( klevel, rot, rot ) + ENDDO +c +c + CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1) + CALL nxgrad ( klevel, rot, grx, gry ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + gry( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + DO ij = 1, ip1jmp1 + grx( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrarot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrarot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/nxgrarot.F (revision 1634) @@ -0,0 +1,55 @@ +! +! $Header$ +! + SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c + REAL rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c +c +c + CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + DO 10 iter = 1,lr + CALL rotat (klevel,grx, gry, rot ) + CALL filtreg( rot, jjm, klevel, 2,1, .false.,2) + CALL nxgrad (klevel,rot, grx, gry ) +c + DO 5 l = 1, klevel + DO 2 ij = 1, ip1jm + gry( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + DO 3 ij = 1, ip1jmp1 + grx( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/paramet.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/paramet.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/paramet.h (revision 1634) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +!----------------------------------------------------------------------- +! INCLUDE 'paramet.h' + + INTEGER iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1 + INTEGER kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm + INTEGER ijmllm,mvar + INTEGER jcfil,jcfllm + + PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3 & + & ,jjp1=jjm+1-1/jjm) + PARAMETER( llmp1 = llm+1, llmp2 = llm+2, llmm1 = llm-1 ) + PARAMETER( kftd = iim/2 -ndm ) + PARAMETER( ip1jm = iip1*jjm, ip1jmp1= iip1*jjp1 ) + PARAMETER( ip1jmi1= ip1jm - iip1 ) + PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm ) + PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm ) + PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm ) + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pbar.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pbar.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pbar.F (revision 1634) @@ -0,0 +1,124 @@ +! +! $Header$ +! + SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************* +c +c pext est un argum. d'entree pour le s-pg .. +c pbarx,pbary et pbarxy sont des argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" + +#include "comgeom.h" + + REAL pext( ip1jmp1 ), pbarx ( ip1jmp1 ) + REAL pbary( ip1jm ), pbarxy( ip1jm ) + + INTEGER ij + + + + DO 1 ij = 1, ip1jmp1 - 1 + pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1) + 1 CONTINUE + +c .... correction pour pbarx( iip1,j) ..... + +c ... pbarx(iip1,j)= pbarx(1,j) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jmp1, iip1 + pbarx( ij ) = pbarx( ij - iim ) + 2 CONTINUE + + + DO 3 ij = 1,ip1jm + pbary( ij ) = pext( ij ) * alpha2p3( ij ) + + * pext( ij+iip1 ) * alpha1p4( ij+iip1 ) + 3 CONTINUE + + + DO 5 ij = 1, ip1jm - 1 + pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour pbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + pbarxy( ij ) = pbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pentes_ini.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pentes_ini.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pentes_ini.F (revision 1634) @@ -0,0 +1,478 @@ +! +! $Header$ +! + SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ******************************************************************** +c Transport des traceurs par la methode des pentes +c ******************************************************************** +c Reference possible : Russel. G.L., Lerner J.A.: +c A new Finite-Differencing Scheme for Traceur Transport +c Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 +c ******************************************************************** +c q,w,masse,pbaru et pbarv +c sont des arguments d'entree pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + integer mode + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL q( iip1,jjp1,llm,0:3) + REAL w( ip1jmp1,llm ) + REAL masse( iip1,jjp1,llm) +c Local: +c ------ + LOGICAL limit + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + real masn,mass,zz + INTEGER i,j,l,iq + +c modif Fred 24 03 96 + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2 + real qpn,qps,dqzpn,dqzps + real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1) + real qmin,zq,pente_max +c + REAL SSUM + integer ismax,ismin,lati,latf + EXTERNAL SSUM, convflu,ismin,ismax + logical first + save first +c fin modif + +c EXTERNAL masskg + EXTERNAL advx + EXTERNAL advy + EXTERNAL advz + +c modif Fred 24 03 96 + data first/.true./ + + limit = .TRUE. + pente_max=2 +c if (mode.eq.1.or.mode.eq.3) then +c if (mode.eq.1) then + if (mode.ge.1) then + lati=2 + latf=jjm + else + lati=1 + latf=jjp1 + endif + + qmin=0.4995 + qmin=0. + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + print*,coslondlon(i),sinlondlon(i) + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1) + print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1) + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q ( i,j,l,1 )=0. + q ( i,j,l,2 )=0. + q ( i,j,l,3 )=0. + ENDDO + ENDDO + ENDDO + + endif +c Fin modif Fred + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q +c *** Rem : utilisation de SCOPY ulterieurement + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,llm+1-l ) = q ( i,j,l,0 ) + sx( i,j,llm+1-l ) = q ( i,j,l,1 ) + sy( i,j,llm+1-l ) = q ( i,j,l,2 ) + sz( i,j,llm+1-l ) = q ( i,j,l,3 ) + ENDDO + ENDDO + ENDDO + +c PRINT*,'----- S0 just before conversion -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) +c PRINT*,'Q(16,12,1,4)=',q(16,12,1,4) + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm ( i,j,llm+1-l)=masse( i,j,l ) + ENDDO + ENDDO + ENDDO + +c *** On converti les champs S en atome (resp. kg) +c *** Les routines d'advection traitent les champs +c *** a advecter si ces derniers sont en atome (resp. kg) +c *** A optimiser !!! + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0(i,j,l) = s0(i,j,l) * sm ( i,j,l ) + sx(i,j,l) = sx(i,j,l) * sm ( i,j,l ) + sy(i,j,l) = sy(i,j,l) * sm ( i,j,l ) + sz(i,j,l) = sz(i,j,l) * sm ( i,j,l ) + ENDDO + ENDDO + ENDDO + +c ss0 = 0. +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iim +c ss0 = ss0 + s0 ( i,j,l ) +c ENDDO +c ENDDO +c ENDDO +c PRINT*, 'valeur tot s0 avant advection=',ss0 + +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- +c PRINT*,'----- S0 just before ADVX -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) + +c----------------------------------------------------------- +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'avant advx1, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +CCC + if(mode.eq.2) then + do l=1,llm + s0s=0. + s0n=0. + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + smn=0. + sms=0. + do i=1,iim + smn=smn+sm(i,1,l) + sms=sms+sm(i,jjp1,l) + s0n=s0n+s0(i,1,l) + s0s=s0s+s0(i,jjp1,l) + zz=sy(i,1,l)/sm(i,1,l) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=sy(i,jjp1,l)/sm(i,jjp1,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i) + sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i) + enddo + do i=1,iim + s0(i,1,l)=s0n/smn+sy(i,1,l) + s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l) + enddo + + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + + do i=1,iim + sxn(i)=s0(i+1,1,l)-s0(i,1,l) + sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l) +c on rerentre les masses + enddo + do i=1,iim + sy(i,1,l)=sy(i,1,l)*sm(i,1,l) + sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l) + s0(i,1,l)=s0(i,1,l)*sm(i,1,l) + s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l) + sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l) + enddo + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + sy(iip1,1,l)=sy(1,1,l) + sy(iip1,jjp1,l)=sy(1,jjp1,l) + sx(1,1,l)=sx(iip1,1,l) + sx(1,jjp1,l)=sx(iip1,jjp1,l) + enddo + endif + + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'avant advy ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) +c call minmaxq(zq,1.e33,-1.e33,'avant advz ') + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + enddo + enddo + call limz(s0,sz,sm,pente_max) + call advz( limit,dtvr,w,sm,s0,sx,sy,sz ) + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) + do l=1,llm + do j=1,jjp1 + sm(iip1,j,l)=sm(1,j,l) + s0(iip1,j,l)=s0(1,j,l) + sx(iip1,j,l)=sx(1,j,l) + sy(iip1,j,l)=sy(1,j,l) + sz(iip1,j,l)=sz(1,j,l) + enddo + enddo + + +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'apres advx ') +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'apres advx2, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +c *** On repasse les S dans la variable q directement 14/10/94 +c On revient a des rapports de melange en divisant par la masse + +c En dehors des poles: + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c Traitements specifiques au pole + + if(mode.ge.1) then + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo + if(mode.eq.3) then + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l) + dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l) + dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2) + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2) + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + endif + if(mode.eq.1) then +c on filtre les valeurs au bord de la "grande maille pole" + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + enddo + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1) + + endif + + ENDDO + endif + +c bouclage en longitude + do iq=0,3 + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,iq)=q(1,j,l,iq) + enddo + enddo + enddo + +c PRINT*, ' SORTIE DE PENTES --- ca peut glisser ....' + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN +c PRINT*,'------------ BIP-----------' +c PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0) +c PRINT*,'QX(',i,j,l,')=',q(i,j,l,1) +c PRINT*,'QY(',i,j,l,')=',q(i,j,l,2) +c PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE DE PENTES' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + ENDDO + +c PRINT*, '-------------------------------------------' + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + if(q(i,j,l,0).lt.qmin) + , print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0) + enddo + enddo + enddo + RETURN + END + + + + + + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ppm3d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ppm3d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ppm3d.F (revision 1634) @@ -0,0 +1,2001 @@ +! +! $Id$ +! + +cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998 +cDate: Wed, 15 Apr 1998 11:37:03 -0400 +cFrom: lin@explorer.gsfc.nasa.gov +cTo: Frederic.Hourdin@lmd.jussieu.fr +cSubject: 3D transport module of the GSFC CTM and GEOS GCM + + +cThis code is sent to you by S-J Lin, DAO, NASA-GSFC + +cNote: this version is intended for machines like CRAY +C-90. No multitasking directives implemented. + + +C ******************************************************************** +C +C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard +C Earth Observing System General Circulation Model (GEOS-GCM), and Data +C Assimilation System (GEOS-DAS). +C +C ******************************************************************** +C +C Purpose: given horizontal winds on a hybrid sigma-p surfaces, +C one call to tpcore updates the 3-D mixing ratio +C fields one time step (NDT). [vertical mass flux is computed +C internally consistent with the discretized hydrostatic mass +C continuity equation of the C-Grid GEOS-GCM (for IGD=1)]. +C +C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based +C on the van Leer or PPM. +C (see Lin and Rood 1996). +C Version 4.5 +C Last modified: Dec. 5, 1996 +C Major changes from version 4.0: a more general vertical hybrid sigma- +C pressure coordinate. +C Subroutines modified: xtp, ytp, fzppm, qckxyz +C Subroutines deleted: vanz +C +C Author: Shian-Jiann Lin +C mail address: +C Shian-Jiann Lin* +C Code 910.3, NASA/GSFC, Greenbelt, MD 20771 +C Phone: 301-286-9540 +C E-mail: lin@dao.gsfc.nasa.gov +C +C *affiliation: +C Joint Center for Earth Systems Technology +C The University of Maryland Baltimore County +C NASA - Goddard Space Flight Center +C References: +C +C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- +C Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. +C +C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of +C the van Leer-type transport schemes and its applications to the moist- +C ure transport in a General Circulation Model. Mon. Wea. Rev., 122, +C 1575-1593. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C + subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR, + & JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax) + +c implicit none + +c rajout de déclarations +c integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd +c integer iu,iiu,j2,jmr,js0,jt +c real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp +c real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru +C +C ******************************************************************** +C +C ============= +C INPUT: +C ============= +C +C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t) +C NC: total # of constituents +C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR +C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1 +C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at +C the model top to NLAY near the surface (see fig. below). +C It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation) +C +C PS1(IMR,JNP): surface pressure at current time (t) +C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2) +C PS2 is replaced by the predicted PS (at t+NDT) on output. +C Note: surface pressure can have any unit or can be multiplied by any +C const. +C +C The pressure at layer edges are defined as follows: +C +C p(i,j,k) = AP(k)*PT + BP(k)*PS(i,j) (1) +C +C Where PT is a constant having the same unit as PS. +C AP and BP are unitless constants given at layer edges +C defining the vertical coordinate. +C BP(1) = 0., BP(NLAY+1) = 1. +C The pressure at the model top is PTOP = AP(1)*PT +C +C For pure sigma system set AP(k) = 1 for all k, PT = PTOP, +C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP. +C +C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn +C is a subset of the following even more general sigma-P-thelta coord. +C currently under development. +C p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa)) +C +C ///////////////////////////////// +C / \ ------------- PTOP -------------- AP(1), BP(1) +C | +C delp(1) | ........... Q(i,j,1) ............ +C | +C W(1) \ / --------------------------------- AP(2), BP(2) +C +C +C +C W(k-1) / \ --------------------------------- AP(k), BP(k) +C | +C delp(K) | ........... Q(i,j,k) ............ +C | +C W(k) \ / --------------------------------- AP(k+1), BP(k+1) +C +C +C +C / \ --------------------------------- AP(NLAY), BP(NLAY) +C | +C delp(NLAY) | ........... Q(i,j,NLAY) ......... +C | +C W(NLAY)=0 \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1) +C ////////////////////////////////// +C +C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2) +C U and V may need to be polar filtered in advance in some cases. +C +C IGD: grid type on which winds are defined. +C IGD = 0: A-Grid [all variables defined at the same point from south +C pole (j=1) to north pole (j=JNP) ] +C +C IGD = 1 GEOS-GCM C-Grid +C [North] +C +C V(i,j) +C | +C | +C | +C U(i-1,j)---Q(i,j)---U(i,j) [EAST] +C | +C | +C | +C V(i,j-1) +C +C U(i, 1) is defined at South Pole. +C V(i, 1) is half grid north of the South Pole. +C V(i,JMR) is half grid south of the North Pole. +C +C V must be defined at j=1 and j=JMR if IGD=1 +C V at JNP need not be given. +C +C NDT: time step in seconds (need not be constant during the course of +C the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5 +C (Lat-Lon) resolution. Smaller values are recommanded if the model +C has a well-resolved stratosphere. +C +C J1 defines the size of the polar cap: +C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg. +C North polar cap edge is located at 90 - (j1-1.5)*180/(JNP-1) deg. +C There are currently only two choices (j1=2 or 3). +C IMR must be an even integer if j1 = 2. Recommended value: J1=3. +C +C IORD, JORD, and KORD are integers controlling various options in E-W, N-S, +C and vertical transport, respectively. Recommended values for positive +C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non- +C positive definite scalars or when linear correlation between constituents +C is to be maintained. +C +C _ORD= +C 1: 1st order upstream scheme (too diffusive, not a useful option; it +C can be used for debugging purposes; this is THE only known "linear" +C monotonic advection scheme.). +C 2: 2nd order van Leer (full monotonicity constraint; +C see Lin et al 1994, MWR) +C 3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984) +C 4: semi-monotonic PPM (same as 3, but overshoots are allowed) +C 5: positive-definite PPM (constraint on the subgrid distribution is +C only strong enough to prevent generation of negative values; +C both overshoots & undershoots are possible). +C 6: un-constrained PPM (nearly diffusion free; slightly faster but +C positivity not quaranteed. Use this option only when the fields +C and winds are very smooth). +C +C *PPM: Piece-wise Parabolic Method +C +C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5. +C for non-positive definite scalars (such as Ertel Potential Vorticity). +C +C The implicit numerical diffusion decreases as _ORD increases. +C The last two options (ORDER=5, 6) should only be used when there is +C significant explicit diffusion (such as a turbulence parameterization). You +C might get dispersive results otherwise. +C No filter of any kind is applied to the constituent fields here. +C +C AE: Radius of the sphere (meters). +C Recommended value for the planet earth: 6.371E6 +C +C fill(logical): flag to do filling for negatives (see note below). +C +C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s). +C (220 m/s is a good value for troposphere model; 280 m/s otherwise) +C +C ============= +C Output +C ============= +C +C Q: mixing ratios at future time (t+NDT) (original values are over-written) +C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic +C relationship. W will have the same unit as PS1 and PS2 (eg, mb). +C W must be divided by NDT to get the correct mass-flux unit. +C The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND +C is the pressure thickness in the "upwind" direction. For example, +C C(k) = W(k)/delp(k) if W(k) > 0; +C C(k) = W(k)/delp(k+1) if W(k) < 0. +C ( W > 0 is downward, ie, toward surface) +C PS2: predicted PS at t+NDT (original values are over-written) +C +C ******************************************************************** +C NOTES: +C This forward-in-time upstream-biased transport scheme reduces to +C the 2nd order center-in-time center-in-space mass continuity eqn. +C if Q = 1 (constant fields will remain constant). This also ensures +C that the computed vertical velocity to be identical to GEOS-1 GCM +C for on-line transport. +C +C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when +C winds are noisy near poles). +C +C Flux-Form Semi-Lagrangian transport in the East-West direction is used +C when and where Courant # is greater than one. +C +C The user needs to change the parameter Jmax or Kmax if the resolution +C is greater than 0.5 deg in N-S or 150 layers in the vertical direction. +C (this TransPort Core is otherwise resolution independent and can be used +C as a library routine). +C +C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd +C order accurate for non-uniform grid (vertical sigma coord.). +C +C Time step is limitted only by transport in the meridional direction. +C (the FFSL scheme is not implemented in the meridional direction). +C +C Since only 1-D limiters are applied, negative values could +C potentially be generated when large time step is used and when the +C initial fields contain discontinuities. +C This does not necessarily imply the integration is unstable. +C These negatives are typically very small. A filling algorithm is +C activated if the user set "fill" to be true. +C +C The van Leer scheme used here is nearly as accurate as the original PPM +C due to the use of a 4th order accurate reference slope. The PPM imple- +C mented here is an improvement over the original and is also based on +C the 4th order reference slope. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C User modifiable parameters +C + parameter (Jmax = 361, kmax = 150) +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C Input-Output arrays +C + + real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP), + & U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1), + & BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax + integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE + integer IMRD2 + real PT + logical cross, fill, dum +C +C Local dynamic arrays +C + real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP), + & fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY), + & WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP), + & delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP), + & UA(IMR,JNP),qtmp(-IMR:2*IMR) +C +C Local static arrays +C + real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax), + & cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax) + data NDT0, NSTEP /0, 0/ + data cross /.true./ + SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML, + & DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK +C + + JMR = JNP -1 + IMJM = IMR*JNP + j2 = JNP - j1 + 1 + NSTEP = NSTEP + 1 +C +C *********** Initialization ********************** + if(NSTEP.eq.1) then +c + write(6,*) '------------------------------------ ' + write(6,*) 'NASA/GSFC Transport Core Version 4.5' + write(6,*) '------------------------------------ ' +c + WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1 + WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT +C +C controles sur les parametres + if(NLAY.LT.6) then + write(6,*) 'NLAY must be >= 6' + stop + endif + if (JNP.LT.NLAY) then + write(6,*) 'JNP must be >= NLAY' + stop + endif + IMRD2=mod(IMR,2) + if (j1.eq.2.and.IMRD2.NE.0) then + write(6,*) 'if j1=2 IMR must be an even integer' + stop + endif + +C + if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then + write(6,*) 'Jmax or Kmax is too small' + stop + endif +C + DO k=1,NLAY + DAP(k) = (AP(k+1) - AP(k))*PT + DBK(k) = BP(k+1) - BP(k) + ENDDO +C + PI = 4. * ATAN(1.) + DL = 2.*PI / REAL(IMR) + DP = PI / REAL(JMR) +C + if(IGD.eq.0) then +C Compute analytic cosine at cell edges + call cosa(cosp,cose,JNP,PI,DP) + else +C Define cosine consistent with GEOS-GCM (using dycore2.0 or later) + call cosc(cosp,cose,JNP,PI,DP) + endif +C + do 15 J=2,JMR +15 acosp(j) = 1. / cosp(j) +C +C Inverse of the Scaled polar cap area. +C + RCAP = DP / (IMR*(1.-COS((j1-1.5)*DP))) + acosp(1) = RCAP + acosp(JNP) = RCAP + endif +C + if(NDT0 .ne. NDT) then + DT = NDT + NDT0 = NDT + + if(Umax .lt. 180.) then + write(6,*) 'Umax may be too small!' + endif + CR1 = abs(Umax*DT)/(DL*AE) + MaxDT = DP*AE / abs(Umax) + 0.5 + write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT + if(MaxDT .lt. abs(NDT)) then + write(6,*) 'Warning!!! NDT maybe too large!' + endif +C + if(CR1.ge.0.95) then + JS0 = 0 + JN0 = 0 + IML = IMR-2 + ZTC = 0. + else + ZTC = acos(CR1) * (180./PI) +C + JS0 = REAL(JMR)*(90.-ZTC)/180. + 2 + JS0 = max(JS0, J1+1) + IML = min(6*JS0/(J1-1)+2, 4*IMR/5) + JN0 = JNP-JS0+1 + endif +C +C + do J=2,JMR + DTDX(j) = DT / ( DL*AE*COSP(J) ) + +c print*,'dtdx=',dtdx(j) + DTDX5(j) = 0.5*DTDX(j) + enddo +C + + DTDY = DT /(AE*DP) +c print*,'dtdy=',dtdy + DTDY5 = 0.5*DTDY +C +c write(6,*) 'J1=',J1,' J2=', J2 + endif +C +C *********** End Initialization ********************** +C +C delp = pressure thickness: the psudo-density in a hydrostatic system. + do k=1,NLAY + do j=1,JNP + do i=1,IMR + delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j) + delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j) + enddo + enddo + enddo + +C + if(j1.ne.2) then + DO 40 IC=1,NC + DO 40 L=1,NLAY + DO 40 I=1,IMR + Q(I, 2,L,IC) = Q(I, 1,L,IC) +40 Q(I,JMR,L,IC) = Q(I,JNP,L,IC) + endif +C +C Compute "tracer density" + DO 550 IC=1,NC + DO 44 k=1,NLAY + DO 44 j=1,JNP + DO 44 i=1,IMR +44 DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k) +550 continue +C + do 1500 k=1,NLAY +C + if(IGD.eq.0) then +C Convert winds on A-Grid to Courant # on C-Grid. + call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + else +C Convert winds on C-grid to Courant # + do 45 j=j1,j2 + do 45 i=2,IMR +45 CRX(i,J) = dtdx(j)*U(i-1,j,k) + +C + do 50 j=j1,j2 +50 CRX(1,J) = dtdx(j)*U(IMR,j,k) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY*V(i,1,k) + endif +C +C Determine JS and JN + JS = j1 + JN = j2 +C + do j=JS0,j1+1,-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JS = j + go to 2222 + endif + enddo + enddo +C +2222 continue + do j=JN0,j2-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JN = j + go to 2233 + endif + enddo + enddo +2233 continue +C + if(j1.ne.2) then ! Enlarged polar cap. + do i=1,IMR + DPI(i, 2,k) = 0. + DPI(i,JMR,k) = 0. + enddo + endif +C +C ******* Compute horizontal mass fluxes ************ +C +C N-S component + do j=j1,j2+1 + D5 = 0.5 * COSE(j) + do i=1,IMR + ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k)) + enddo + enddo +C + do 95 j=j1,j2 + DO 95 i=1,IMR +95 DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j) +C +C Poles + sum1 = ymass(IMR,j1 ) + sum2 = ymass(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + ymass(i,j1 ) + sum2 = sum2 + ymass(i,J2+1) + enddo +C + sum1 = - sum1 * RCAP + sum2 = sum2 * RCAP + do i=1,IMR + DPI(i, 1,k) = sum1 + DPI(i,JNP,k) = sum2 + enddo +C +C E-W component +C + do j=j1,j2 + do i=2,IMR + PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k)) + enddo + enddo +C + do j=j1,j2 + PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k)) + enddo +C + do 110 j=j1,j2 + DO 110 i=1,IMR +110 xmass(i,j) = PU(i,j)*CRX(i,j) +C + DO 120 j=j1,j2 + DO 120 i=1,IMR-1 +120 DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j) +C + DO 130 j=j1,j2 +130 DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j) +C + DO j=j1,j2 + do i=1,IMR-1 + UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j)) + enddo + enddo +C + DO j=j1,j2 + UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j)) + enddo +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajouts pour LMDZ.3.3 +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc + do i=1,IMR + do j=1,JNP + VA(i,j)=0. + enddo + enddo + + do i=1,imr*(JMR-1) + VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3)) + enddo +C + if(j1.eq.2) then + IMH = IMR/2 + do i=1,IMH + VA(i, 1) = 0.5*(CRY(i,2)-CRY(i+IMH,2)) + VA(i+IMH, 1) = -VA(i,1) + VA(i, JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR)) + VA(i+IMH,JNP) = -VA(i,JNP) + enddo + VA(IMR,1)=VA(1,1) + VA(IMR,JNP)=VA(1,JNP) + endif +C +C ****6***0*********0*********0*********0*********0*********0**********72 + do 1000 IC=1,NC +C + do i=1,IMJM + wk1(i,1,1) = 0. + wk1(i,1,2) = 0. + enddo +C +C E-W advective cross term + do 250 j=J1,J2 + if(J.GT.JS .and. J.LT.JN) GO TO 250 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j,k,IC) + qtmp(IMR+1-i) = q(1-i,j,k,IC) + enddo +C + DO 230 i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + wk1(i,j,1) = wk1(i,j,1) - qtmp(i) +230 continue +250 continue +C + if(JN.ne.0) then + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + qtmp(0) = q(IMR,J,k,IC) + qtmp(IMR+1) = q( 1,J,k,IC) +C + do i=1,imr + iu = i - UA(i,j) + wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1)) + enddo + enddo + endif +C ****6***0*********0*********0*********0*********0*********0**********72 +C Contribution from the N-S advection + do i=1,imr*(j2-j1+1) + JT = REAL(J1) - VA(i,j1) + wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC)) + enddo +C + do i=1,IMJM + wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1) + wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2) + enddo +C + if(cross) then +C Add cross terms in the vertical direction. + if(IORD .GE. 2) then + iad = 2 + else + iad = 1 + endif +C + if(JORD .GE. 2) then + jad = 2 + else + jad = 1 + endif + call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad) + call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad) + do j=1,JNP + do i=1,IMR + q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j) + enddo + enddo + endif +C + call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2) + & ,CRX,fx1,xmass,IORD) + + call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY, + & DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD) +C +1000 continue +1500 continue +C +C ******* Compute vertical mass flux (same unit as PS) *********** +C +C 1st step: compute total column mass CONVERGENCE. +C + do 320 j=1,JNP + do 320 i=1,IMR +320 CRY(i,j) = DPI(i,j,1) +C + do 330 k=2,NLAY + do 330 j=1,JNP + do 330 i=1,IMR + CRY(i,j) = CRY(i,j) + DPI(i,j,k) +330 continue +C + do 360 j=1,JNP + do 360 i=1,IMR +C +C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption. +C Changes (increases) to surface pressure = total column mass convergence +C + PS2(i,j) = PS1(i,j) + CRY(i,j) +C +C 3rd step: compute vertical mass flux from mass conservation principle. +C + W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j) + W(i,j,NLAY) = 0. +360 continue +C + do 370 k=2,NLAY-1 + do 370 j=1,JNP + do 370 i=1,IMR + W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j) +370 continue +C + DO 380 k=1,NLAY + DO 380 j=1,JNP + DO 380 i=1,IMR + delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j) +380 continue +C + KRD = max(3, KORD) + do 4000 IC=1,NC +C +C****6***0*********0*********0*********0*********0*********0**********72 + + call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI, + & DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD) +C + + if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2, + & cosp,acosp,.false.,IC,NSTEP) +C +C Recover tracer mixing ratio from "density" using predicted +C "air density" (pressure thickness) at time-level n+1 +C + DO k=1,NLAY + DO j=1,JNP + DO i=1,IMR + Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k) +c print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC) + enddo + enddo + enddo +C + if(j1.ne.2) then + DO 400 k=1,NLAY + DO 400 I=1,IMR +c j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord + Q(I, 2,k,IC) = Q(I, 1,k,IC) + Q(I,JMR,k,IC) = Q(I,JNP,k,IC) +400 CONTINUE + endif +4000 continue +C + if(j1.ne.2) then + DO 5000 k=1,NLAY + DO 5000 i=1,IMR + W(i, 2,k) = W(i, 1,k) + W(i,JMR,k) = W(i,JNP,k) +5000 continue + endif +C + RETURN + END +C +C****6***0*********0*********0*********0*********0*********0**********72 + subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6, + & flux,wk1,wk2,wz2,delp,KORD) + parameter ( kmax = 150 ) + parameter ( R23 = 2./3., R3 = 1./3.) + real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY), + & wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY), + & DQDT(IMR,JNP,NLAY) +C Assuming JNP >= NLAY + real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*), + & wz2(IMR,*) +C + JMR = JNP - 1 + IMJM = IMR*JNP + NLAYM1 = NLAY - 1 +C + LMT = KORD - 3 +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Compute DC for PPM +C ****6***0*********0*********0*********0*********0*********0**********72 +C + do 1000 k=1,NLAYM1 + do 1000 i=1,IMJM + DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k) +1000 continue +C + DO 1220 k=2,NLAYM1 + DO 1220 I=1,IMJM + c0 = delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1)) + c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k)) + c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k)) + tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1)) + Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k) + Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) + DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp) +1220 CONTINUE + +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Loop over latitudes (to save memory) +C ****6***0*********0*********0*********0*********0*********0**********72 +C + DO 2000 j=1,JNP + if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000 +C + DO k=1,NLAY + DO i=1,IMR + wz2(i,k) = WZ(i,j,k) + wk1(i,k) = P(i,j,k) + wk2(i,k) = delp(i,j,k) + flux(i,k) = DC(i,j,k) !this flux is actually the monotone slope + enddo + enddo +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute first guesses at cell interfaces +C First guesses are required to be continuous. +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C three-cell parabolic subgrid distribution at model top +C two-cell parabolic with zero gradient subgrid distribution +C at the surface. +C +C First guess top edge value + DO 10 i=1,IMR +C three-cell PPM +C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp + a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/ + & (wk2(i,1)+wk2(i,2)) ) / + & ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) ) + b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - + & R23*a*(2.*wk2(i,1)+wk2(i,2)) + AL(i,1) = wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b) + AL(i,2) = wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1) +C +C Check if change sign + if(wk1(i,1)*AL(i,1).le.0.) then + AL(i,1) = 0. + flux(i,1) = 0. + else + flux(i,1) = wk1(i,1) - AL(i,1) + endif +10 continue +C +C Bottom + DO 15 i=1,IMR +C 2-cell PPM with zero gradient right at the surface +C + fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 / + & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1))) + AR(i,NLAY) = wk1(i,NLAY) + fct + AL(i,NLAY) = wk1(i,NLAY) - (fct+fct) + if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0. + flux(i,NLAY) = AR(i,NLAY) - wk1(i,NLAY) +15 continue + +C +C****6***0*********0*********0*********0*********0*********0**********72 +C 4th order interpolation in the interior. +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 14 k=3,NLAYM1 + DO 12 i=1,IMR + c1 = DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k)) + c2 = 2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1)) + A1 = (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k)) + A2 = (wk2(i,k )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1)) + AL(i,k) = wk1(i,k-1) + c1 + c2 * + & ( wk2(i,k )*(c1*(A1 - A2)+A2*flux(i,k-1)) - + & wk2(i,k-1)*A1*flux(i,k) ) +C print *,'AL1',i,k, AL(i,k) +12 CONTINUE +14 continue +C + do 20 i=1,IMR*NLAYM1 + AR(i,1) = AL(i,2) +C print *,'AR1',i,AR(i,1) +20 continue +C + do 30 i=1,IMR*NLAY + A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1))) +C print *,'A61',i,A6(i,1) +30 continue +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Top & Bot always monotonic + call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0) + call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY), + & wk1(1,NLAY),IMR,0) +C +C Interior depending on KORD + if(LMT.LE.2) + & call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2), + & IMR*(NLAY-2),LMT) +C +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 140 i=1,IMR*NLAYM1 + IF(wz2(i,1).GT.0.) then + CM = wz2(i,1) / wk2(i,1) + flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM)) + else +C print *,'test2-0',i,j,wz2(i,1),wk2(i,2) + CP= wz2(i,1) / wk2(i,2) +C print *,'testCP',CP + flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP)) +C print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23 + endif +140 continue +C + DO 250 i=1,IMR*NLAYM1 + flux(i,2) = wz2(i,1) * flux(i,2) +250 continue +C + do 350 i=1,IMR + DQ(i,j, 1) = DQ(i,j, 1) - flux(i, 2) + DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY) +350 continue +C + do 360 k=2,NLAYM1 + do 360 i=1,IMR +360 DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1) +2000 continue + return + end +C + subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC, + & fx1,xmass,IORD) + dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP) + & ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML) + dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR) +C + IMP = IMR + 1 +C +C van Leer at high latitudes + jvan = max(1,JNP/18) + j1vl = j1+jvan + j2vl = j2-jvan +C + do 1310 j=j1,j2 +C + do i=1,IMR + qtmp(i) = q(i,j) + enddo +C + if(j.ge.JN .or. j.le.JS) goto 2222 +C ************* Eulerian ********** +C + qtmp(0) = q(IMR,J) + qtmp(-1) = q(IMR-1,J) + qtmp(IMP) = q(1,J) + qtmp(IMP+1) = q(2,J) +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1406 i=1,IMR + iu = REAL(i) - uc(i,j) +1406 fx1(i) = qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) + DC(0) = DC(IMR) +C + if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then + DO 1408 i=1,IMR + iu = REAL(i) - uc(i,j) +1408 fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j)) + else + call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD) + endif +C + ENDIF +C + DO 1506 i=1,IMR +1506 fx1(i) = fx1(i)*xmass(i,j) +C + goto 1309 +C +C ***** Conservative (flux-form) Semi-Lagrangian transport ***** +C +2222 continue +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j) + qtmp(IMP-i) = q(1-i,j) + enddo +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1306 i=1,IMR + itmp = INT(uc(i,j)) + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1306 fx1(i) = (uc(i,j) - itmp)*qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) +C + do i=-IML,0 + DC(i) = DC(IMR+i) + DC(IMP-i) = DC(1-i) + enddo +C + DO 1307 i=1,IMR + itmp = INT(uc(i,j)) + rut = uc(i,j) - itmp + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1307 fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut)) + ENDIF +C + do 1308 i=1,IMR + IF(uc(i,j).GT.1.) then +CDIR$ NOVECTOR + do ist = ISAVE(i),i-1 + fx1(i) = fx1(i) + qtmp(ist) + enddo + elseIF(uc(i,j).LT.-1.) then + do ist = i,ISAVE(i)-1 + fx1(i) = fx1(i) - qtmp(ist) + enddo +CDIR$ VECTOR + endif +1308 continue + do i=1,IMR + fx1(i) = PU(i,j)*fx1(i) + enddo +C +C *************************************** +C +1309 fx1(IMP) = fx1(1) + DO 1215 i=1,IMR +1215 DQ(i,j) = DQ(i,j) + fx1(i)-fx1(i+1) +C +C *************************************** +C +1310 continue + return + end +C + subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1) + DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR) + integer LMT +c logical first +c data first /.true./ +c SAVE LMT +c if(first) then +C +C correction calcul de LMT a chaque passage pour pouvoir choisir +c plusieurs schemas PPM pour differents traceurs +c IF (IORD.LE.0) then +c if(IMR.GE.144) then +c LMT = 0 +c elseif(IMR.GE.72) then +c LMT = 1 +c else +c LMT = 2 +c endif +c else +c LMT = IORD - 3 +c endif +C + LMT = IORD - 3 +c write(6,*) 'PPM option in E-W direction = ', LMT +c first = .false. +C endif +C + DO 10 i=1,IMR +10 AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3 +C + do 20 i=1,IMR-1 +20 AR(i) = AL(i+1) + AR(IMR) = AL(1) +C + do 30 i=1,IMR +30 A6(i) = 3.*(p(i)+p(i) - (AL(i)+AR(i))) +C + if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT) +C + AL(0) = AL(IMR) + AR(0) = AR(IMR) + A6(0) = A6(IMR) +C + DO i=1,IMR + IF(UT(i).GT.0.) then + flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) + + & A6(i-1)*(1.-R23*UT(i)) ) + else + flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + + & A6(i)*(1.+R23*UT(i))) + endif + enddo + return + end +C + subroutine xmist(IMR,IML,P,DC) + parameter( R24 = 1./24.) + dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML) +C + do 10 i=1,IMR + tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2)) + Pmax = max(P(i-1), p(i), p(i+1)) - p(i) + Pmin = p(i) - min(P(i-1), p(i), p(i+1)) +10 DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp) + return + end +C + subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2 + & ,ymass,fx,A6,AR,AL,JORD) + dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP) + & ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP) +C Work array + DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) +C + JMR = JNP - 1 + len = IMR*(J2-J1+2) +C + if(JORD.eq.1) then + DO 1000 i=1,len + JT = REAL(J1) - VC(i,J1) +1000 fx(i,j1) = p(i,JT) + else + + call ymist(IMR,JNP,j1,P,DC2,4) +C + if(JORD.LE.0 .or. JORD.GE.3) then + + call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD) + + else + DO 1200 i=1,len + JT = REAL(J1) - VC(i,J1) +1200 fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT) + endif + endif +C + DO 1300 i=1,len +1300 fx(i,j1) = fx(i,j1)*ymass(i,j1) +C + DO 1400 j=j1,j2 + DO 1400 i=1,IMR +1400 DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j) +C +C Poles + sum1 = fx(IMR,j1 ) + sum2 = fx(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + fx(i,j1 ) + sum2 = sum2 + fx(i,J2+1) + enddo +C + sum1 = DQ(1, 1) - sum1 * RCAP + sum2 = DQ(1,JNP) + sum2 * RCAP + do i=1,IMR + DQ(i, 1) = sum1 + DQ(i,JNP) = sum2 + enddo +C + if(j1.ne.2) then + do i=1,IMR + DQ(i, 2) = sum1 + DQ(i,JMR) = sum2 + enddo + endif +C + return + end +C + subroutine ymist(IMR,JNP,j1,P,DC,ID) + parameter ( R24 = 1./24. ) + dimension P(IMR,JNP),DC(IMR,JNP) +C + IMH = IMR / 2 + JMR = JNP - 1 + IJM3 = IMR*(JMR-3) +C + IF(ID.EQ.2) THEN + do 10 i=1,IMR*(JMR-1) + tmp = 0.25*(p(i,3) - p(i,1)) + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +10 CONTINUE + ELSE + do 12 i=1,IMH +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +12 CONTINUE + do 14 i=IMH+1,IMR +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +14 CONTINUE +C + do 15 i=1,IJM3 + tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24 + Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3) + Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4)) + DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp) +15 CONTINUE + ENDIF +C + if(j1.ne.2) then + do i=1,IMR + DC(i,1) = 0. + DC(i,JNP) = 0. + enddo + else +C Determine slopes in polar caps for scalars! +C + do 13 i=1,IMH +C South + tmp = 0.25*(p(i,2) - p(i+imh,2)) + Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1) + Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2)) + DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp) +C North. + tmp = 0.25*(p(i+imh,JMR) - p(i,JMR)) + Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP) + Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR)) + DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp) +13 continue +C + do 25 i=imh+1,IMR + DC(i, 1) = - DC(i-imh, 1) + DC(i,JNP) = - DC(i-imh,JNP) +25 continue + endif + return + end +C + subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*) +C Local work arrays. + real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) + integer LMT +c logical first +C data first /.true./ +C SAVE LMT +C + IMH = IMR / 2 + JMR = JNP - 1 + j11 = j1-1 + IMJM1 = IMR*(J2-J1+2) + len = IMR*(J2-J1+3) +C if(first) then +C IF(JORD.LE.0) then +C if(JMR.GE.90) then +C LMT = 0 +C elseif(JMR.GE.45) then +C LMT = 1 +C else +C LMT = 2 +C endif +C else +C LMT = JORD - 3 +C endif +C +C first = .false. +C endif +C +c modifs pour pouvoir choisir plusieurs schemas PPM + LMT = JORD - 3 +C + DO 10 i=1,IMR*JMR + AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3 + AR(i,1) = AL(i,2) +10 CONTINUE +C +CPoles: +C + DO i=1,IMH + AL(i,1) = AL(i+IMH,2) + AL(i+IMH,1) = AL(i,2) +C + AR(i,JNP) = AR(i+IMH,JMR) + AR(i+IMH,JNP) = AR(i,JMR) + ENDDO + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajout pour LMDZ.3.3 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + AR(IMR,1)=AL(1,1) + AR(IMR,JNP)=AL(1,JNP) +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + do 30 i=1,len +30 A6(i,j11) = 3.*(p(i,j11)+p(i,j11) - (AL(i,j11)+AR(i,j11))) +C + if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11) + & ,AL(1,j11),P(1,j11),len,LMT) +C + + DO 140 i=1,IMJM1 + IF(VC(i,j1).GT.0.) then + flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) + + & A6(i,j11)*(1.-R23*VC(i,j1)) ) + else + flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) + + & A6(i,j1)*(1.+R23*VC(i,j1))) + endif +140 continue + return + end +C + subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD) + REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP) + REAL WK(IMR,-1:JNP+2) +C + JMR = JNP-1 + IMH = IMR/2 + do j=1,JNP + do i=1,IMR + wk(i,j) = p(i,j) + enddo + enddo +C Poles: + do i=1,IMH + wk(i, -1) = p(i+IMH,3) + wk(i+IMH,-1) = p(i,3) + wk(i, 0) = p(i+IMH,2) + wk(i+IMH,0) = p(i,2) + wk(i,JNP+1) = p(i+IMH,JMR) + wk(i+IMH,JNP+1) = p(i,JMR) + wk(i,JNP+2) = p(i+IMH,JNP-2) + wk(i+IMH,JNP+2) = p(i,JNP-2) + enddo +c write(*,*) 'toto 1' +C -------------------------------- + IF(IAD.eq.2) then + do j=j1-1,j2+1 + do i=1,IMR +c write(*,*) 'avt NINT','i=',i,'j=',j + JP = NINT(VA(i,j)) + rv = JP - VA(i,j) +c write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv + JP = j - JP +c write(*,*) 'JP2=',JP + a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp) + b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1)) +c write(*,*) 'a1=',a1,'b1=',b1 + ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j) + enddo + enddo +c write(*,*) 'toto 2' +C + ELSEIF(IAD.eq.1) then + do j=j1-1,j2+1 + do i=1,imr + JP = REAL(j)-VA(i,j) + ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1)) + enddo + enddo + ENDIF +C + if(j1.ne.2) then + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,2) + sum2 = sum2 + ady(i,JMR) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 2) = sum1 + ady(i,JMR) = sum2 + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + else +C Poles: + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,1) + sum2 = sum2 + ady(i,JNP) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + endif +C + return + end +C + subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD) + REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP) +C + JMR = JNP-1 + do 1309 j=j1,j2 + if(J.GT.JS .and. J.LT.JN) GO TO 1309 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + do i=-IML,0 + qtmp(i) = p(IMR+i,j) + qtmp(IMR+1-i) = p(1-i,j) + enddo +C + IF(IAD.eq.2) THEN + DO i=1,IMR + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then + DO i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + enddo + ENDIF +C + do i=1,IMR + adx(i,j) = adx(i,j) - p(i,j) + enddo +1309 continue +C +C Eulerian upwind +C + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + qtmp(0) = p(IMR,J) + qtmp(IMR+1) = p(1,J) +C + IF(IAD.eq.2) THEN + qtmp(-1) = p(IMR-1,J) + qtmp(IMR+2) = p(2,J) + do i=1,imr + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then +C 1st order + DO i=1,IMR + IP = i - UA(i,j) + adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1)) + enddo + ENDIF + enddo +C + if(j1.ne.2) then + do i=1,IMR + adx(i, 2) = 0. + adx(i,JMR) = 0. + enddo + endif +C set cross term due to x-adv at the poles to zero. + do i=1,IMR + adx(i, 1) = 0. + adx(i,JNP) = 0. + enddo + return + end +C + subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT) +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + parameter ( R12 = 1./12. ) + dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM) +C + if(LMT.eq.0) then +C Full constraint + do 100 i=1,IM + if(DC(i).eq.0.) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + else + da1 = AR(i) - AL(i) + da2 = da1**2 + A6DA = A6(i)*da1 + if(A6DA .lt. -da2) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + elseif(A6DA .gt. da2) then + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif + endif +100 continue + elseif(LMT.eq.1) then +C Semi-monotonic constraint + do 150 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +150 continue + elseif(LMT.eq.2) then + do 250 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250 + fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12 + if(fmin.ge.0.) go to 250 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +250 continue + endif + return + end +C + subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*) +C + do 35 j=j1,j2 + do 35 i=2,IMR +35 CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j)) +C + do 45 j=j1,j2 +45 CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j)) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY5*(V(i,2)+V(i,1)) + return + end +C + subroutine cosa(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) + JMR = JNP-1 + do 55 j=2,JNP + ph5 = -0.5*PI + (REAL(J-1)-0.5)*DP +55 cose(j) = cos(ph5) +C + JEQ = (JNP+1) / 2 + if(JMR .eq. 2*(JMR/2) ) then + do j=JNP, JEQ+1, -1 + cose(j) = cose(JNP+2-j) + enddo + else +C cell edge at equator. + cose(JEQ+1) = 1. + do j=JNP, JEQ+2, -1 + cose(j) = cose(JNP+2-j) + enddo + endif +C + do 66 j=2,JMR +66 cosp(j) = 0.5*(cose(j)+cose(j+1)) + cosp(1) = 0. + cosp(JNP) = 0. + return + end +C + subroutine cosc(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) +C + phi = -0.5*PI + do 55 j=2,JNP-1 + phi = phi + DP +55 cosp(j) = cos(phi) + cosp( 1) = 0. + cosp(JNP) = 0. +C + do 66 j=2,JNP + cose(j) = 0.5*(cosp(j)+cosp(j-1)) +66 CONTINUE +C + do 77 j=2,JNP-1 + cosp(j) = 0.5*(cose(j)+cose(j+1)) +77 CONTINUE + return + end +C + SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, + & cross,IC,NSTEP) +C + parameter( tiny = 1.E-60 ) + DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*) + logical cross +C + NLAYM1 = NLAY-1 + len = IMR*(j2-j1+1) + ip = 0 +C +C Top layer + L = 1 + icr = 1 + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 50 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 50 +C + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 50 +C +C Vertical filling... + do i=1,len + IF( Q(i,j1,1).LT.0.) THEN + ip = ip + 1 + Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1) + Q(i,j1,1) = 0. + endif + enddo +C +50 continue + DO 225 L = 2,NLAYM1 + icr = 1 +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 225 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) go to 225 + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 225 +C + do i=1,len + IF( Q(I,j1,L).LT.0.) THEN +C + ip = ip + 1 +C From above + qup = Q(I,j1,L-1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,L-1) = qup - dup + Q(I,j1,L ) = dup-qly +C Below + Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L) + Q(I,j1,L) = 0. + ENDIF + ENDDO +225 CONTINUE +C +C BOTTOM LAYER + sum = 0. + L = NLAY +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 911 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 911 +C + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + if(icr.eq.0) goto 911 +C + DO I=1,len + IF( Q(I,j1,L).LT.0.) THEN + ip = ip + 1 +c +C From above +C + qup = Q(I,j1,NLAYM1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,NLAYM1) = qup - dup +C From "below" the surface. + sum = sum + qly-dup + Q(I,j1,L) = 0. + ENDIF + ENDDO +C +911 continue +C + if(ip.gt.IMR) then + write(6,*) 'IC=',IC,' STEP=',NSTEP, + & ' Vertical filling pts=',ip + endif +C + if(sum.gt.1.e-25) then + write(6,*) IC,NSTEP,' Mass source from the ground=',sum + endif + RETURN + END +C + subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + dimension q(IMR,*),cosp(*),acosp(*) + icr = 0 + do 65 j=j1+1,j2-1 + DO 50 i=1,IMR-1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(i+1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i+1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(i+1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i+1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +50 continue + if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65 + DO 55 i=2,IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(i-1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i-1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(i-1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i-1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C ***************************************** +C i=1 + i=1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(IMR,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(IMR,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(IMR,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(IMR,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +C i=IMR + i=IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +65 continue +C + do i=1,IMR + if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then + icr = 1 + goto 80 + endif + enddo +C +80 continue +C + if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then + icr = 1 + endif +C + return + end +C + subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + dimension q(IMR,*),cosp(*),acosp(*) +c logical first +c data first /.true./ +c save cap1 +C +c if(first) then + DP = 4.*ATAN(1.)/REAL(JNP-1) + CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP +c first = .false. +c endif +C + ipy = 0 + do 55 j=j1+1,j2-1 + DO 55 i=1,IMR + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C North + dn = q(i,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C + do i=1,imr + IF(q(i,j1).LT.0.) THEN + ipy = 1 + dq = - q(i,j1)*cosp(j1) +C North + dn = q(i,j1+1)*cosp(j1+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j1+1) = (dn - d1)*acosp(j1+1) + q(i,j1) = (d1 - dq)*acosp(j1) + tiny + endif + enddo +C + j = j2 + do i=1,imr + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif + enddo +C +C Check Poles. + if(q(1,1).lt.0.) then + dq = q(1,1)*cap1/REAL(IMR)*acosp(j1) + do i=1,imr + q(i,1) = 0. + q(i,j1) = q(i,j1) + dq + if(q(i,j1).lt.0.) ipy = 1 + enddo + endif +C + if(q(1,JNP).lt.0.) then + dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2) + do i=1,imr + q(i,JNP) = 0. + q(i,j2) = q(i,j2) + dq + if(q(i,j2).lt.0.) ipy = 1 + enddo + endif +C + return + end +C + subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny) + dimension q(IMR,*),qtmp(JNP,IMR) +C + ipx = 0 +C Copy & swap direction for vectorization. + do 25 i=1,imr + do 25 j=j1,j2 +25 qtmp(j,i) = q(i,j) +C + do 55 i=2,imr-1 + do 55 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +55 continue +c + i=1 + do 65 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,imr)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,imr) = qtmp(j,imr) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +65 continue + i=IMR + do 75 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,1) = qtmp(j,1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +75 continue +C + if(ipx.ne.0) then + do 85 j=j1,j2 + do 85 i=1,imr +85 q(i,j) = qtmp(j,i) + else +C +C Poles. + if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1 + endif + return + end +C + subroutine zflip(q,im,km,nc) +C This routine flip the array q (in the vertical). + real q(im,km,nc) +C local dynamic array + real qtmp(im,km) +C + do 4000 IC = 1, nc +C + do 1000 k=1,km + do 1000 i=1,im + qtmp(i,k) = q(i,km+1-k,IC) +1000 continue +C + do 2000 i=1,im*km +2000 q(i,1,IC) = qtmp(i,1) +4000 continue + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/prather.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/prather.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/prather.F (revision 1634) @@ -0,0 +1,361 @@ +! +! $Header$ +! + SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ************************************************ +c Transport des traceurs par la methode de prather +c Ref : +c +c ************************************************ +c q,w,pext,pbaru et pbarv : arguments d'entree pour le s-pg +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + INTEGER iq,nt + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL masse(iip1,jjp1,llm) + REAL q( iip1,jjp1,llm,0:9) + REAL w( ip1jmp1,llm ) + integer ordre,ilim + +c Local: +c ------ + LOGICAL limit + real zq(iip1,jjp1,llm) + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + REAL sxx( iip1,jjp1,llm) + REAL sxy( iip1,jjp1,llm) + REAL sxz( iip1,jjp1,llm) + REAL syy( iip1,jjp1,llm ) + REAL syz( iip1,jjp1,llm ) + REAL szz( iip1,jjp1,llm ),zz + INTEGER i,j,l,indice + real sxn(iip1),sxs(iip1) + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + real qmin,qmax + save qmin,qmax + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps + real masn,mass +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + logical first + save first + EXTERNAL advxp,advyp,advzp + + + data first/.true./ + data qmin,qmax/-1.e33,1.e33/ + + +c========================================================================== +c========================================================================== +c MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt +c========================================================================== +c========================================================================== + REAL dt +c========================================================================== + limit = .TRUE. + + if(first) then + print*,'SCHEMA PRATHER' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,l,1 )=0. + q( i,j,l,2)=0. + q( i,j,l,3)=0. + q( i,j,l,4)=0. + q( i,j,l,5)=0. + q( i,j,l,6)=0. + q( i,j,l,7)=0. + q( i,j,l,8)=0. + q( i,j,l,9)=0. + ENDDO + ENDDO + ENDDO + endif +c Fin modif Fred + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm( i,j,llm+1-l ) =masse(i,j,l) + ENDDO + ENDDO + ENDDO + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l) + sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l) + sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l) + sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l) + sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l) + sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l) + sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l) + syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l) + syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l) + szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l) + ENDDO + ENDDO + ENDDO +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- + do indice =1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + +c--------------------------------------------------------- + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + sxz(i,j,1)=0. + sxz(i,j,llm)=0. + syz(i,j,1)=0. + syz(i,j,llm)=0. + szz(i,j,1)=0. + szz(i,j,llm)=0. + enddo + enddo + call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + +c--------------------------------------------------------- + +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + DO l = 1,llm + DO j = 1,jjp1 + s0( iip1,j,l)=s0( 1,j,l ) + sx( iip1,j,l)=sx( 1,j,l ) + sy( iip1,j,l)=sy( 1,j,l ) + sz( iip1,j,l)=sz( 1,j,l ) + sxx( iip1,j,l)=sxx( 1,j,l ) + sxy( iip1,j,l)=sxy( 1,j,l) + sxz( iip1,j,l)=sxz( 1,j,l ) + syy( iip1,j,l)=syy( 1,j,l ) + syz( iip1,j,l)=syz( 1,j,l) + szz( iip1,j,l)=szz( 1,j,l ) + ENDDO + ENDDO + do indice=1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do +c--------------------------------------------------------- +c--------------------------------------------------------- +c *** On repasse les S dans la variable qpr +c *** On repasse les S dans la variable q directement 14/10/94 + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c--------------------------------------------------------- +c go to 777 +c filtrages aux poles + +c Traitements specifiques au pole + +c filtrages aux poles + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo +c enddo +c print*,'qpn',qpn,'qps',qps +c print*,'dqzpn',dqzpn,'dqzps',dqzps +c enddo + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + $ (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0) + $ +q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + $ (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + $ -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + END DO + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)= + $ q(iip1,jjp1,llm+1-l,1) + enddo + do l=1,llm + do i=1,iim + q( i,1,llm+1-l,4)=0. + q( i,jjp1,llm+1-l,4)=0. + q( i,1,llm+1-l,5)=0. + q( i,jjp1,llm+1-l,5)=0. + q( i,1,llm+1-l,6)=0. + q( i,jjp1,llm+1-l,6)=0. + q( i,1,llm+1-l,7)=0. + q( i,jjp1,llm+1-l,7)=0. + q( i,1,llm+1-l,8)=0. + q( i,jjp1,llm+1-l,8)=0. + q( i,1,llm+1-l,9)=0. + q( i,jjp1,llm+1-l,9)=0. + enddo + ENDDO + +777 continue +c +c bouclage en longitude + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,0)=q(1,j,l,0) + q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0) + q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1) + q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2) + q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3) + q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4) + q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5) + q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6) + q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7) + q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8) + q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9) + enddo + enddo + DO l = 1,llm + DO j = 2,jjm + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0), + $ q(i,j-1,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2), + $ q(i,j-1,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE D'' ADVZP' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + do j=1,jjp1,jjm + do i=1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP 2-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) + + q(i,j,l,0)=0. +c STOP + ENDIF + enddo + enddo + ENDDO + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pres2lev.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pres2lev.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pres2lev.F90 (revision 1634) @@ -0,0 +1,74 @@ +! $Id$ +! +!****************************************************** +SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp) +! +! interpolation lineaire pour passer +! a une nouvelle discretisation verticale pour +! les variables de GCM +! Francois Forget (01/1995) +! MOdif remy roca 12/97 pour passer de pres2sig +! Modif F.Codron 07/08 po en 3D +!********************************************************** + + IMPLICIT NONE + +! Declarations: +! ============== +! +! ARGUMENTS +! """"""""" + LOGICAL, INTENT(IN) :: ok_invertp + INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches + INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches + + REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille + REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille + + INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal + + REAL, INTENT(IN) :: varo(ni*nj,lmo) ! var dans l'ancienne grille + REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille + + REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo) + +! Autres variables +! """""""""""""""" + INTEGER :: ln ,lo, k + REAL :: coef + + +! Inversion de l'ordre des niveaux verticaux + IF (ok_invertp) THEN + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lmo+1-lo) + zvaro(k,lo)=varo(k,lmo+1-lo) + ENDDO + ENDDO + ELSE + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lo) + zvaro(k,lo)=varo(k,lo) + ENDDO + ENDDO + ENDIF + + DO ln=1,lmn + DO lo=1,lmo-1 + DO k=1,ni*nj + IF (pn(k,ln) >= zpo(k,1) ) THEN + varn(k,ln) = zvaro(k,1) + ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN + varn(k,ln) = zvaro(k,lmo) + ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN + coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo)) + varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo)) + ENDIF + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE pres2lev Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pression.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pression.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/pression.F (revision 1634) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE pression( ngrid, ap, bp, ps, p ) +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + DO l = 1, llmp1 + DO ij = 1, ngrid + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/profvert.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/profvert.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/profvert.def (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! +nom_courbes=F +titre=/home/hourdin/LMDZ4/libf/dyn3d +xinf=0. +xsup=669. +yinf=6.5 +ysup=10.5 +axtxtx=sols +axtxty=pressure (mb) +pathcham=. +lstyles=1 9999 +linewidth=.2 +lcolors=1 9999 +frwidth=.5 +repery0=T +txtheight=2.5 +freecoord=/d2/hourdin/Ames/saison.def + +determination du champ physique +xlength=195. +ylength=105. Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/psextbar.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/psextbar.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/psextbar.F (revision 1634) @@ -0,0 +1,107 @@ +! +! $Header$ +! + SUBROUTINE psextbar ( ps, psexbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************** +c +c ps est un argum. d'entree pour le s-pg .. +c psexbarxy est un argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 ) + + INTEGER l, ij +c + + DO ij = 1, ip1jmp1 + pext(ij) = ps(ij) * aire(ij) + ENDDO + + + DO 5 ij = 1, ip1jm - 1 + psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour psexbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + psexbarxy( ij ) = psexbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/q_sat.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/q_sat.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/q_sat.F (revision 1634) @@ -0,0 +1,72 @@ +! +! $Header$ +! +c +c + + subroutine q_sat(np,temp,pres,qsat) +c + IMPLICIT none +c====================================================================== +c Autheur(s): Z.X. Li (LMD/CNRS) +c reecriture vectorisee par F. Hourdin. +c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.) +c====================================================================== +c Arguments: +c kelvin---input-R: temperature en Kelvin +c millibar--input-R: pression en mb +c +c q_sat----output-R: vapeur d'eau saturante en kg/kg +c====================================================================== +c + integer np + REAL temp(np),pres(np),qsat(np) +c + REAL r2es + PARAMETER (r2es=611.14 *18.0153/28.9644) +c + REAL r3les, r3ies, r3es + PARAMETER (R3LES=17.269) + PARAMETER (R3IES=21.875) +c + REAL r4les, r4ies, r4es + PARAMETER (R4LES=35.86) + PARAMETER (R4IES=7.66) +c + REAL rtt + PARAMETER (rtt=273.16) +c + REAL retv + PARAMETER (retv=28.9644/18.0153 - 1.0) + + real zqsat + integer ip +c +C ------------------------------------------------------------------ +c +c + + do ip=1,np + +c write(*,*)'kelvin,millibar=',kelvin,millibar +c write(*,*)'temp,pres=',temp(ip),pres(ip) +c + IF (temp(ip) .LE. rtt) THEN + r3es = r3ies + r4es = r4ies + ELSE + r3es = r3les + r4es = r4les + ENDIF +c + zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es)) + zqsat=MIN(0.5,ZQSAT) + zqsat=zqsat/(1.-retv *zqsat) +c + qsat(ip)= zqsat +c write(*,*)'qsat=',qsat(ip) + + enddo +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/qminimum.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/qminimum.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/qminimum.F (revision 1634) @@ -0,0 +1,87 @@ +! +! $Header$ +! + SUBROUTINE qminimum( q,nq,deltap ) + + IMPLICIT none +c +c -- Objet : Traiter les valeurs trop petites (meme negatives) +c pour l'eau vapeur et l'eau liquide +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +c + INTEGER nq + REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm) +c + INTEGER iq_vap, iq_liq + PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur + PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide + REAL seuil_vap, seuil_liq + PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur + PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide +c +c NB. ....( Il est souhaitable mais non obligatoire que les valeurs des +c parametres seuil_vap, seuil_liq soient pareilles a celles +c qui sont utilisees dans la routine ADDFI ) +c ................................................................. +c + INTEGER i, k, iq + REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe +c + REAL SSUM +c + INTEGER imprim + SAVE imprim + DATA imprim /0/ +c +c Quand l'eau liquide est trop petite (ou negative), on prend +c l'eau vapeur de la meme couche et la convertit en eau liquide +c (sans changer la temperature !) +c + DO 1000 k = 1, llm + DO 1040 i = 1, ip1jmp1 + if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then + q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq + q(i,k,iq_liq) = seuil_liq + endif + 1040 CONTINUE + 1000 CONTINUE +c +c Quand l'eau vapeur est trop faible (ou negative), on complete +c le defaut en prennant de l'eau vapeur de la couche au-dessous. +c + iq = iq_vap +c + DO k = llm, 2, -1 +ccc zx_abc = dpres(k) / dpres(k-1) + DO i = 1, ip1jmp1 + if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then + q(i,k-1,iq) = q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) * + & deltap(i,k) / deltap(i,k-1) + q(i,k,iq) = seuil_vap + endif + ENDDO + ENDDO +c +c Quand il s'agit de la premiere couche au-dessus du sol, on +c doit imprimer un message d'avertissement (saturation possible). +c + DO i = 1, ip1jmp1 + zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) ) + q(i,1,iq) = AMAX1( q(i,1,iq), seuil_vap ) + ENDDO + pompe = SSUM(ip1jmp1,zx_pump,1) + IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN + WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe + DO i = 1, ip1jmp1 + IF (zx_pump(i).GT.0.0) THEN + imprim = imprim + 1 + PRINT*,'QMINIMUM: en ',i,zx_pump(i) + ENDIF + ENDDO + ENDIF +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ran1.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ran1.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ran1.F (revision 1634) @@ -0,0 +1,34 @@ +! +! $Id$ +! + FUNCTION RAN1(IDUM) + DIMENSION R(97) + save r + save iff,ix1,ix2,ix3 + PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6) + PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6) + PARAMETER (M3=243000,IA3=4561,IC3=51349) + DATA IFF /0/ + IF (IDUM.LT.0.OR.IFF.EQ.0) THEN + IFF=1 + IX1=MOD(IC1-IDUM,M1) + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IX1,M2) + IX1=MOD(IA1*IX1+IC1,M1) + IX3=MOD(IX1,M3) + DO 11 J=1,97 + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 +11 CONTINUE + IDUM=1 + ENDIF + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + IX3=MOD(IA3*IX3+IC3,M3) + J=1+(97*IX3)/M3 + IF(J.GT.97.OR.J.LT.1)PAUSE + RAN1=R(J) + R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotat.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotat.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotat.F (revision 1634) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotat (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotat_nfil.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotat_nfil.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotat_nfil.F (revision 1634) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE rotat_nfil (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotatf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotatf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotatf.F (revision 1634) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotatf (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotatst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotatst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/rotatst.F (revision 1634) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE rotatst (klevel,x, y, rot ) +c +c P. Le Van +c +c ***************************************************************** +c .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ..... +c ***************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c + INTEGER klevel +#include "dimensions.h" +#include "paramet.h" + + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) + INTEGER l, ij +c +c + DO 5 l = 1,klevel +c + DO 1 ij = 1, ip1jm - 1 + rot( ij,l ) = ( y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) ) + 1 CONTINUE +c +c .... correction pour rot( iip1,j,l) .... +c +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + 2 CONTINUE +c + 5 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/serre.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/serre.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/serre.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! +!c +!c +!c..include serre.h +!c + REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo, & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy + COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sort.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sort.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sort.F (revision 1634) @@ -0,0 +1,37 @@ +! +! $Header$ +! +C +C + SUBROUTINE sort(n,d) +c +c P.Le Van +c +c... cette routine met le tableau d dans l'ordre croissant .... +cc ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc +c tion situee + bas IF(d(j).LE.p) THEN par +c IF(d(j).GE.p) THEN +c + + INTEGER n + REAL d(n) , p + INTEGER i,j,k + + DO i=1,n-1 + k=i + p=d(i) + DO j=i+1,n + IF(d(j).LE.p) THEN + k=j + p=d(j) + ENDIF + ENDDO + + IF(k.ne.i) THEN + d(k)=d(i) + d(i)=p + ENDIF + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sortvarc.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sortvarc.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sortvarc.F (revision 1634) @@ -0,0 +1,166 @@ +! +! $Id$ +! + SUBROUTINE sortvarc + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = REAL( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge(:)=dp(:)*dp(:) + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot = SSUM( llm, etotl, 1 ) + ztot = SSUM( llm, ztotl, 1 ) + stot = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang = SSUM( llm, angl, 1 ) + +c rday = REAL(INT ( day_ini + time )) +c + rday = REAL(INT(time-jD_ref-jH_ref)) + IF(ptot0.eq.0.) THEN + PRINT 3500, itau, rday, heure,time + PRINT*,'WARNING!!! On recalcule les valeurs initiales de :' + PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang' + PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + etot0 = etot + ptot0 = ptot + ztot0 = ztot + stot0 = stot + ang0 = ang + END IF + + etot= etot/etot0 + rmsv= SQRT(rmsv/ptot) + ptot= ptot/ptot0 + ztot= ztot/ztot0 + stot= stot/stot0 + ang = ang /ang0 + + + PRINT 3500, itau, rday, heure, time + PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + + RETURN + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x + * ,'date',f14.4,4x,10("*")) +4000 FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie' + * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB ' + . ,f10.6,e13.6,5f10.3/ + * ) + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sortvarc0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sortvarc0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sortvarc0.F (revision 1634) @@ -0,0 +1,141 @@ +! +! $Id$ +! + SUBROUTINE sortvarc0 + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + integer ismin,ismax + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = REAL( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge=dp*dp + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot0 = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot0 = SSUM( llm, etotl, 1 ) + ztot0 = SSUM( llm, ztotl, 1 ) + stot0 = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang0 = SSUM( llm, angl, 1 ) + + rday = REAL(INT (time )) +c + PRINT 3500, itau, rday, heure, time + PRINT *, ptot0,etot0,ztot0,stot0,ang0 + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x + * ,'date',f10.5,4x,10("*")) + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/startvar.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/startvar.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/startvar.F90 (revision 1634) @@ -0,0 +1,783 @@ +! +! $Id$ +! +!******************************************************************************* +! +MODULE startvar +! +!******************************************************************************* +! +!------------------------------------------------------------------------------- +! Purpose: Access data from the database of atmospheric to initialize the model. +!------------------------------------------------------------------------------- +! Comments: +! +! * This module is designed to work for Earth (and with ioipsl) +! +! * There are three ways to acces data, depending on the type of field +! which needs to be extracted. In any case the call should come after a restget +! and should be of the type : CALL startget(...) +! +! - A 1D variable on the physical grid : +! CALL startget_phys1d((varname, iml, jml, lon_in, lat_in, nbindex, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 2D variable on the dynamical grid : +! CALL startget_phys2d(varname, iml, jml, lon_in, lat_in, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 3D variable on the dynamical grid : +! CALL startget_dyn((varname, iml, jml, lon_in, lat_in, lml, pls, workvar, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! * Data needs to be in NetCDF format +! +! * Variables should have the following names in the files: +! 'RELIEF' : High resolution orography +! 'ST' : Surface temperature +! 'CDSW' : Soil moisture +! 'Z' : Surface geopotential +! 'SP' : Surface pressure +! 'U' : East ward wind +! 'V' : Northward wind +! 'TEMP' : Temperature +! 'R' : Relative humidity +! +! * There is a big mess with the longitude size. Should it be iml or iml+1 ? +! I have chosen to use the iml+1 as an argument to this routine and we declare +! internaly smaller fields when needed. This needs to be cleared once and for +! all in LMDZ. A convention is required. +!------------------------------------------------------------------------------- +#ifdef CPP_EARTH + USE ioipsl + IMPLICIT NONE + + PRIVATE + PUBLIC startget_phys2d, startget_phys1d, startget_dyn +! INTERFACE startget +! MODULE PROCEDURE startget_phys1d, startget_phys2d, startget_dyn +! END INTERFACE + + REAL, SAVE :: deg2rad, pi + INTEGER, SAVE :: iml_rel, jml_rel + INTEGER, SAVE :: fid_phys, iml_phys, jml_phys + INTEGER, SAVE :: fid_dyn, iml_dyn, jml_dyn, llm_dyn, ttm_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_phys, lon_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_phys, lat_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_rug, lon_alb, lon_rel + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_rug, lat_alb, lat_rel + REAL, DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: levdyn_ini + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: relief, zstd, zsig, zgam + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: masque, zthe, zpic, zval + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: rugo, phis, tsol, qsol + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: psol_dyn + REAL, DIMENSION(:,:,:), ALLOCATABLE, TARGET, SAVE :: var_ana3d + + CONTAINS + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, lat_in, nbindex, champ, & + val_exp ,jml2, lon_in2, lat_in2, ibar) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: nbindex + REAL, DIMENSION(nbindex), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d +!------------------------------------------------------------------------------- + v2d=>NULL() + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('qsol') + IF(.NOT.ALLOCATED(qsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('zmea','zstd','zsig','zgam','zthe','zpic','zval') + IF(.NOT.ALLOCATED(relief)) & + CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rads','snow','tslab','seaice','rugmer','agsno') + CASE DEFAULT + WRITE(lunout,*)'startget_phys1d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('rads','snow','tslab','seaice'); champ=0.0 + CASE('rugmer'); champ(:)=0.001 + CASE('agsno'); champ(:)=50.0 + CASE DEFAULT + SELECT CASE(varname) + CASE('tsol'); v2d=>tsol + CASE('qsol'); v2d=>qsol + CASE('psol'); v2d=>psol_dyn + CASE('zmea'); v2d=>relief + CASE('zstd'); v2d=>zstd + CASE('zsig'); v2d=>zsig + CASE('zgam'); v2d=>zgam + CASE('zthe'); v2d=>zthe + CASE('zpic'); v2d=>zpic + CASE('zval'); v2d=>zval + END SELECT + IF(SIZE(v2d)/=SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + CALL gr_dyn_fi(1,iml,jml,nbindex,v2d,champ) + END SELECT + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) ALLOCATE(tsol(iml,jml)) + CALL gr_fi_dyn(1,iml,jml,nbindex,champ,tsol) + END SELECT + + END IF + +END SUBROUTINE startget_phys1d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, champ, val_exp, & + jml2, lon_in2, lat_in2 , ibar, msk) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar + REAL, DIMENSION(iml,jml), INTENT(IN), OPTIONAL :: msk +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d=>NULL() + LOGICAL :: lrelief1, lrelief2 +!------------------------------------------------------------------------------- + v2d=>NULL() + lrelief1=(.NOT.ALLOCATED(relief).AND. PRESENT(msk)) + lrelief2=(.NOT.ALLOCATED(relief).AND..NOT.PRESENT(msk)) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('relief') + IF(lrelief1) CALL start_init_orog(iml,jml,lon_in,lat_in,msk) + IF(lrelief2) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('surfgeo') + IF(.NOT.ALLOCATED(phis)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rugosite','masque') + IF(.NOT.ALLOCATED(rugo)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE DEFAULT + WRITE(lunout,*)'startget_phys2d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('psol'); v2d=>psol_dyn + CASE('relief'); v2d=>relief + CASE('rugosite'); v2d=>rugo + CASE('masque'); v2d=>masque + CASE('surfgeo'); v2d=>phis + END SELECT + IF(SIZE(champ)/=SIZE(v2d)) THEN + WRITE(lunout,*) 'STARTVAR module has been initialized to the wrong size' + STOP + END IF + + champ(:,:)=v2d(:,:) + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE ('surfgeo') + IF(.NOT.ALLOCATED(phis)) ALLOCATE(phis(iml,jml)) + IF(SIZE(phis)/=SIZE(champ)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + phis(:,:)=champ(:,:) + END SELECT + + END IF + +END SUBROUTINE startget_phys2d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_dyn(varname, lon_in, lat_in, pls,workvar,& + champ, val_exp, lon_in2, lat_in2, ibar) + + use assert_eq_m, only: assert_eq + + +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + REAL, INTENT(IN) :: lon_in(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in(:) ! dim(jml) + REAL, INTENT(IN) :: pls(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: workvar(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(INOUT) :: champ(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: val_exp + REAL, INTENT(IN) :: lon_in2(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in2(:) ! dim(jml2) + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "comconst.h" +#include "paramet.h" +#include "comgeom2.h" + INTEGER :: iml, jml + INTEGER :: lml + INTEGER :: jml2 + REAL, DIMENSION(:,:,:), POINTER :: v3d=>NULL() + CHARACTER(LEN=10) :: vname + INTEGER :: il + REAL :: xppn, xpps +!------------------------------------------------------------------------------- + NULLIFY(v3d) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + + iml = assert_eq((/size(lon_in), size(pls, 1), size(workvar, 1), & + & size(champ, 1), size(lon_in2)/), "startget_dyn iml") + jml = assert_eq(size(lat_in), size(pls, 2), size(workvar, 2), & + & size(champ, 2), "startget_dyn jml") + lml = assert_eq(size(pls, 3), size(workvar, 3), size(champ, 3), & + & "startget_dyn lml") + jml2 = size(lat_in2) + +!--- READING UNALLOCATED FILES + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + +!--- CHECKING IF THE FIELD IS KNOWN AND INTERPOLATING 3D FIELDS + SELECT CASE(varname) + CASE('u'); vname='U' + CASE('v'); vname='V' + CASE('t','tpot'); vname='TEMP' + CASE('q'); vname='R' + CASE DEFAULT + WRITE(lunout,*)'startget_dyn' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + CALL start_inter_3d(TRIM(vname), iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls, champ,ibar ) + +!--- COMPUTING THE REQUIRED FILED + SELECT CASE(varname) + CASE('u') !--- Eastward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cu(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('v') !--- Northward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cv(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('tpot') !--- Temperature + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=champ*cpp/workvar + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute potential temperature as the' + WRITE(lunout,*)'Exner function is missing or constant.'; STOP + END IF + + CASE('q') !--- Relat. humidity + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=0.01*champ*workvar + WHERE(champ<0.) champ=1.0E-10 + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute specific humidity as the' + WRITE(lunout,*)'saturated humidity is missing or constant.'; STOP + END IF + + END SELECT + + END IF + +END SUBROUTINE startget_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_orog(iml,jml,lon_in,lat_in,masque_lu) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(IN), OPTIONAL :: masque_lu +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: orofname + LOGICAL :: check=.TRUE. + REAL, DIMENSION(1) :: lev + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: fid, llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: relief_hi, tmp_var + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini +!------------------------------------------------------------------------------- + pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + + orofname = 'Relief.nc'; title='RELIEF' + IF(check) WRITE(lunout,*)'Reading the high resolution orography' + CALL flininfo(orofname, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + + ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel)) + CALL flinopen(orofname, .FALSE., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,& + lev, ttm_tmp, itau, date, dt, fid) + ALLOCATE(relief_hi(iml_rel,jml_rel)) + CALL flinget(fid, title, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1, 1, relief_hi) + CALL flinclo(fid) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel)) + lon_ini(:)=lon_rel(:,1); IF(MAXVAL(lon_rel)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_rel(1,:); IF(MAXVAL(lat_rel)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel)) + CALL conf_dat2d(title, iml_rel, jml_rel, lon_ini, lat_ini, lon_rad, lat_rad, & + relief_hi, .FALSE.) + DEALLOCATE(lon_ini,lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + IF(check) WRITE(lunout,*)'Computes all parameters needed for gravity wave dra& + &g code' + + ALLOCATE(phis(iml,jml)) ! Geopotentiel au sol + ALLOCATE(zstd(iml,jml)) ! Deviation standard de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) ! Pente de l'orographie sous-maille + ALLOCATE(zgam(iml,jml)) ! Anisotropie de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) ! Orientation axe +grande pente d'oro sous maille + ALLOCATE(zpic(iml,jml)) ! Hauteur pics de la SSO + ALLOCATE(zval(iml,jml)) ! Hauteur vallees de la SSO + ALLOCATE(relief(iml,jml)) ! Orographie moyenne + ALLOCATE(masque(iml,jml)) ! Masque terre ocean + masque = -99999. + IF(PRESENT(masque_lu)) masque=masque_lu + + CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque) + phis = phis * 9.81 + +!--- SURFACE ROUGHNESS COMPUTATION (UNUSED FOR THE MOMENT !!! ) + IF(check) WRITE(lunout,*)'Compute surface roughness induced by the orography' + ALLOCATE(rugo (iml ,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, tmp_var) + rugo(1:iml-1,:)=tmp_var; rugo(iml,:)=tmp_var(1,:) + DEALLOCATE(relief_hi,tmp_var,lon_rad,lat_rad) + RETURN + +END SUBROUTINE start_init_orog +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!------------------------------------------------------------------------------- + physfname = 'ECPHY.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*)'Opening the surface analysis' + CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, ttm_tmp, fid_phys) + + ALLOCATE(lat_phys(iml_phys,jml_phys)) + ALLOCATE(lon_phys(iml_phys,jml_phys)) + ALLOCATE(levphys_ini(llm_tmp)) + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, llm_tmp, lon_phys, & + lat_phys, levphys_ini, ttm_tmp, itau, date, dt, fid_phys) + DEALLOCATE(levphys_ini) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_phys),lat_ini(jml_phys)) + lon_ini(:)=lon_phys(:,1); IF(MAXVAL(lon_phys)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_phys(1,:); IF(MAXVAL(lat_phys)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_phys,jml_phys),lon_rad(iml_phys),lat_rad(jml_phys)) + +!--- SURFACE TEMPERATURE + title='ST' + ALLOCATE(tsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana , ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, tsol) + +!--- SOIL MOISTURE + title='CDSW' + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana, ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, qsol) + + CALL flinclo(fid_phys) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +END SUBROUTINE start_init_phys +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: i, j + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana, z + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: xppn, xpps +!------------------------------------------------------------------------------- + +!--- KINETIC ENERGY + physfname = 'ECDYN.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*) 'Opening the surface analysis' + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, fid_dyn) + IF(check) WRITE(lunout,*) 'Values read: ', iml_dyn, jml_dyn, llm_dyn, ttm_dyn + + ALLOCATE(lat_dyn(iml_dyn,jml_dyn)) + ALLOCATE(lon_dyn(iml_dyn,jml_dyn)) + ALLOCATE(levdyn_ini(llm_dyn)) + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, lon_dyn,lat_dyn,& + levdyn_ini, ttm_dyn, itau, date, dt, fid_dyn) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn),lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:,1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1,:); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_dyn,jml_dyn),lon_rad(iml_dyn),lat_rad(jml_dyn)) + +!--- SURFACE GEOPOTENTIAL + title='Z' + ALLOCATE(z(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, z) + +!--- SURFACE PRESSURE + title='SP' + ALLOCATE(psol_dyn(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, psol_dyn) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +!--- ALLOCATION OF VARIABLES CREATED IN OR COMING FROM RESTART FILE + IF(.NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + ELSE + IF(SIZE(tsol)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The temperature field we have does not have the right size' + STOP + END IF + END IF + + IF(.NOT.ALLOCATED(phis)) THEN + CALL start_init_orog(iml,jml,lon_in,lat_in) + ELSE + IF(SIZE(phis)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The orography field we have does not have the right size' + STOP + END IF + END IF + +!--- PSOL IS COMPUTED IN PASCALS + DO j = 1, jml + DO i = 1, iml-1 + psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j))/287.0/tsol(i,j)) + END DO + psol_dyn(iml,j) = psol_dyn(1,j) + END DO + DEALLOCATE(z) + + ALLOCATE(xppn(iml-1),xpps(iml-1)) + DO i = 1, iml-1 + xppn(i) = aire( i,1) * psol_dyn( i,1) + xpps(i) = aire( i,jml) * psol_dyn( i,jml) + END DO + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + END DO + DEALLOCATE(xppn,xpps) + + RETURN + +END SUBROUTINE start_init_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls_in, var3d, ibar) + + use pchsp_95_m, only: pchsp_95 + use pchfe_95_m, only: pchfe_95 + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml, lml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + REAL, DIMENSION(iml, jml, lml), INTENT(IN) :: pls_in + REAL, DIMENSION(iml, jml, lml), INTENT(OUT) :: var3d + LOGICAL, INTENT(IN) :: ibar +!---------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + LOGICAL:: check=.TRUE., skip + REAL chmin, chmax + INTEGER ii, ij, il, ierr + integer n_extrap ! number of extrapolated points + REAL, DIMENSION(iml, jml, llm_dyn):: var_tmp3d + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(llm_dyn):: lev_dyn, ax, ay, yder + +!--------------------------------------------------------------------------- + IF(check) WRITE(lunout, *)'Going into flinget to extract the 3D field.' + IF(check) WRITE(lunout, *) fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, & + ttm_dyn + IF(check) WRITE(lunout, *) 'Allocating space for interpolation', iml, jml, & + llm_dyn + + IF(.NOT.ALLOCATED(var_ana3d)) ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, 1, 1, & + var_ana3d) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn), lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:, 1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1, :); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_dyn), lat_rad(jml_dyn)) + CALL conf_dat3d (varname, iml_dyn, jml_dyn, llm_dyn, lon_ini, lat_ini, & + levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d, ibar) + DEALLOCATE(lon_ini, lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + DO il=1, llm_dyn + CALL interp_startvar(varname, ibar, il==1, iml_dyn, jml_dyn, lon_rad, & + lat_rad, var_ana3d(:, :, il), iml, jml, jml2, lon_in, lat_in, & + lon_in2, lat_in2, var_tmp3d(:, :, il)) + END DO + DEALLOCATE(lon_rad, lat_rad) + +!--- VERTICAL INTERPOLATION IS PERFORMED FROM TOP OF ATMOSPHERE TO GROUND + ax = lev_dyn(llm_dyn:1:-1) + skip = .false. + n_extrap = 0 + DO ij=1, jml + DO ii=1, iml-1 + ay = var_tmp3d(ii, ij, llm_dyn:1:-1) + yder = pchsp_95(ax, ay, ibeg=2, iend=2, vc_beg=0., vc_end=0.) + CALL pchfe_95(ax, ay, yder, skip, pls_in(ii, ij, lml:1:-1), & + var3d(ii, ij, lml:1:-1), ierr) + if (ierr < 0) stop 1 + n_extrap = n_extrap + ierr + END DO + END DO + if (n_extrap /= 0) then + print *, "start_inter_3d pchfe_95: n_extrap = ", n_extrap + end if + var3d(iml, :, :) = var3d(1, :, :) + + DO il=1, lml + CALL minmax(iml*jml, var3d(1, 1, il), chmin, chmax) + WRITE(lunout, *)' '//TRIM(varname)//' min max l ', il, chmin, chmax + END DO + +END SUBROUTINE start_inter_3d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE interp_startvar(vname, ibar, ibeg, ii, jj, lon, lat, vari, & + i1, j1, j2, lon1, lat1, lon2, lat2, varo) +! +!------------------------------------------------------------------------------- + + USE inter_barxy_m, only: inter_barxy + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: vname + LOGICAL, INTENT(IN) :: ibar, ibeg + INTEGER, INTENT(IN) :: ii, jj + REAL, DIMENSION(ii), INTENT(IN) :: lon + REAL, DIMENSION(jj), INTENT(IN) :: lat + REAL, DIMENSION(ii,jj), INTENT(IN) :: vari + INTEGER, INTENT(IN) :: i1, j1, j2 + REAL, DIMENSION(i1), INTENT(IN) :: lon1 + REAL, DIMENSION(j1), INTENT(IN) :: lat1 + REAL, DIMENSION(i1), INTENT(IN) :: lon2 + REAL, DIMENSION(j2), INTENT(IN) :: lat2 + REAL, DIMENSION(i1,j1), INTENT(OUT) :: varo +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(i1-1,j1) :: vtmp +!------------------------------------------------------------------------------- + IF(ibar) THEN + IF(ibeg) THEN + WRITE(lunout,*) & + '---------------------------------------------------------------' + WRITE(lunout,*) & + '$$$ Utilisation de l interpolation barycentrique pour '//TRIM(vname)//' $$$' + WRITE(lunout,*) & + '---------------------------------------------------------------' + END IF + CALL inter_barxy(lon, lat(:jj-1), vari, lon2(:i1-1), lat2(:j2), vtmp) + ELSE + CALL grille_m (ii, jj, lon, lat, vari, i1-1, j1, lon1, lat1, vtmp) + END IF + CALL gr_int_dyn(vtmp, varo, i1-1, j1) + +END SUBROUTINE interp_startvar +! +!------------------------------------------------------------------------------- + +#endif +! of #ifdef CPP_EARTH + +END MODULE startvar +! +!******************************************************************************* Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sw_case_williamson91_6.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sw_case_williamson91_6.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/sw_case_williamson91_6.F (revision 1634) @@ -0,0 +1,140 @@ +! +! $Id $ +! + SUBROUTINE sw_case_williamson91_6(vcov,ucov,teta,masse,ps) + +c======================================================================= +c +c Author: Thomas Dubos original: 26/01/2010 +c ------- +c +c Subject: +c ------ +c Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "iniprint.h" + +c Arguments: +c ---------- + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + +c Local: +c ------ + + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) + + REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps + INTEGER i,j,ij + + REAL, PARAMETER :: rho=1 ! masse volumique de l'air (arbitraire) + REAL, PARAMETER :: K = 7.848e-6 ! K = \omega + REAL, PARAMETER :: gh0 = 9.80616 * 8e3 + INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2 ! mode 4 +c NB : rad = 6371220 dans W91 (6371229 dans LMDZ) +c omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ) + + IF(0==0) THEN +c Williamson et al. (1991) : onde de Rossby-Haurwitz + teta = preff/rho/cpp +c geopotentiel (pression de surface) + do j=1,jjp1 + costh2 = cos(rlatu(j))**2 + Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0 + Ath = .25*(K**2)*(costh2**(R0-1))*Ath + Ath = .5*K*(2*omeg+K)*costh2 + Ath + Bth = (R1*R1+1)-R1*R1*costh2 + Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth + Cth = R1*costh2 - R2 + Cth = .25*K*K*(costh2**R0)*Cth + do i=1,iip1 + ij=(j-1)*iip1+i + lon = rlonv(i) + dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon) + ps(ij) = rho*(gh0 + (rad**2)*dps) + enddo + enddo + write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps) +c vitesse zonale ucov + do j=1,jjp1 + costh = cos(rlatu(j)) + costh2 = costh**2 + Ath = rad*K*costh + Bth = R0*(1-costh2)-costh2 + Bth = rad*K*Bth*(costh**(R0-1)) + do i=1,iip1 + ij=(j-1)*iip1+i + lon = rlonu(i) + ucov(ij,1) = (Ath + Bth*cos(R0*lon)) + enddo + enddo + write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1)) + ucov(:,1)=ucov(:,1)*cu +c vitesse meridienne vcov + do j=1,jjm + sinth = sin(rlatv(j)) + costh = cos(rlatv(j)) + Ath = -rad*K*R0*sinth*(costh**(R0-1)) + do i=1,iip1 + ij=(j-1)*iip1+i + lon = rlonv(i) + vcov(ij,1) = Ath*sin(R0*lon) + enddo + enddo + write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1)) + vcov(:,1)=vcov(:,1)*cv + +c ucov=0 +c vcov=0 + ELSE +c test non-tournant, onde se propageant en latitude + do j=1,jjp1 + do i=1,iip1 + ij=(j-1)*iip1+i + ps(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2) ) + enddo + enddo + +c rho = preff/(cpp*teta) + teta = .01*preff/cpp ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j + ucov=0. + vcov=0. + END IF + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL massdair(p,masse) + + END +c----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/temps.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/temps.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/temps.h (revision 1634) @@ -0,0 +1,24 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +! jD_ref = jour julien de la date de reference (lancement de l'experience) +! hD_ref = "heure" julienne de la date de reference +!----------------------------------------------------------------------- +! INCLUDE 'temps.h' + + COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref, & + & itau_dyn, itau_phy, jD_ref, jH_ref, calend + + INTEGER itaufin + INTEGER itau_dyn, itau_phy + INTEGER day_ini, day_end, annee_ref, day_ref + REAL dt, jD_ref, jH_ref + CHARACTER (len=10) :: calend + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/test_period.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/test_period.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/test_period.F (revision 1634) @@ -0,0 +1,115 @@ +! +! $Header$ +! + SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis ) +c +c Auteur : P. Le Van +c --------- +c .... Cette routine teste la periodicite en longitude des champs ucov, +c teta, q , p et phis .......... +c + USE infotrac +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c +c ...... Arguments ...... +c + REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) , + , q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1) +c +c ..... Variables locales ..... +c + INTEGER ij,l,nq +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( ucov(ij,l).NE.ucov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- UCOV --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + STOP + ENDIF + IF( teta(ij,l).NE.teta(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + , , teta(ij,l), teta(ij+iim,l) + STOP + ENDIF + ENDDO + + do ij=1,iim + if (teta(ij,l).ne.teta(1,l) + s .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' constant aux poles ! ' + print*,'teta(',1 ,',',l,')=',teta(1 ,l) + print*,'teta(',ij,',',l,')=',teta(ij,l) + print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l) + print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l) + stop + endif + enddo + ENDDO + +c + DO l = 1, llm + DO ij = 1, ip1jm, iip1 + IF( vcov(ij,l).NE.vcov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- VCOV --- n est pas', + , ' periodique en longitude !' + PRINT *,' l, ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l) + vcov(ij+iim,l)=vcov(ij,l) +c STOP + ENDIF + ENDDO + ENDDO + +c + DO nq =1, nqtot + DO l =1, llm + DO ij = 1, ip1jmp1, iip1 + IF( q(ij,l,nq).NE.q(ij+iim,l,nq) ) THEN + PRINT *,'STOP dans test_period car --- Q --- n est pas ', + , 'periodique en longitude !' + PRINT *,' nq , l, ij = ', nq, l, ij, ij+iim + STOP + ENDIF + ENDDO + ENDDO + ENDDO +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( p(ij,l).NE.p(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' periodique en longitude !' + PRINT *,' l ij = ',l, ij, ij+iim + STOP + ENDIF + IF( phis(ij).NE.phis(ij+iim) ) THEN + PRINT *,'STOP dans test_period car --- PHIS --- n est pas', + , ' periodique en longitude ! l, IJ = ', l, ij,ij+iim + PRINT *,' ij = ', ij, ij+iim + STOP + ENDIF + ENDDO + do ij=1,iim + if (p(ij,l).ne.p(1,l) + s .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' constant aux poles ! ' + print*,'p(',1 ,',',l,')=',p(1 ,l) + print*,'p(',ij,',',l,')=',p(ij,l) + print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l) + print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l) + stop + endif + enddo + ENDDO +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tetaleveli1j.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tetaleveli1j.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tetaleveli1j.F (revision 1634) @@ -0,0 +1,139 @@ +c================================================================ +c================================================================ + SUBROUTINE tetaleveli1j(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! USE dimphy + IMPLICIT none + +#include "dimensions.h" +ccccc#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- + +cIM 211004 +c INTEGER lt(klon), lb(klon) +c REAL ptop, pbot, aist(klon), aisb(klon) +c +#include "paramet.h" +c + INTEGER lt(ip1jm), lb(ip1jm) + REAL ptop, pbot, aist(ip1jm), aisb(ip1jm) +cMI 211004 + save lt,lb,ptop,pbot,aist,aisb + + INTEGER i, k +c +c PRINT*,'tetalevel pres=',pres +c===================================================================== + if (lnew) then +c on réinitialise les réindicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, ilon +cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF +cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', +cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) +cIM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, ilon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Frédéric Hourdin (3/01/02) + + IF(pgcm(i,lb(i)).EQ.0.OR. + $ pgcm(i,lt(i)).EQ.0.) THEN +c + PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), + . lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres +c + ENDIF +c + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) +cIM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), +cIM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon +cIM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN +c Qpres(i)=1e33 + Qpres(i)=1e+20 +cIM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tetaleveli1j1.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tetaleveli1j1.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tetaleveli1j1.F (revision 1634) @@ -0,0 +1,139 @@ +c================================================================ +c================================================================ + SUBROUTINE tetaleveli1j1(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! USE dimphy + IMPLICIT none + +#include "dimensions.h" +cccc#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- + +cIM 211004 +c INTEGER lt(klon), lb(klon) +c REAL ptop, pbot, aist(klon), aisb(klon) +c +#include "paramet.h" +c + INTEGER lt(ip1jmp1), lb(ip1jmp1) + REAL ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1) +cMI 211004 + save lt,lb,ptop,pbot,aist,aisb + + INTEGER i, k +c +c PRINT*,'tetalevel pres=',pres +c===================================================================== + if (lnew) then +c on réinitialise les réindicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, ilon +cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF +cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', +cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) +cIM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, ilon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Frédéric Hourdin (3/01/02) + + IF(pgcm(i,lb(i)).EQ.0.OR. + $ pgcm(i,lt(i)).EQ.0.) THEN +c + PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), + . lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres +c + ENDIF +c + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) +cIM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), +cIM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon +cIM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN +c Qpres(i)=1e33 + Qpres(i)=1e+20 +cIM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/top_bound.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/top_bound.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/top_bound.F (revision 1634) @@ -0,0 +1,142 @@ + SUBROUTINE top_bound( vcov,ucov,teta,masse, du,dv,dh ) + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + + +c .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, +C F. LOTT DEC. 2006 +c ( 10/12/06 ) + +c======================================================================= +c +c Auteur: F. LOTT +c ------- +c +c Objet: +c ------ +c +c Dissipation linéaire (ex top_bound de la physique) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +! #include "comgeom.h" +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),teta(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) + REAL dv(iip1,jjm,llm),du(iip1,jjp1,llm),dh(iip1,jjp1,llm) + +c Local: +c ------ + + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm + REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm) + + INTEGER NDAMP + PARAMETER (NDAMP=4) + integer i + REAL,SAVE :: rdamp(llm) +! & (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) + + LOGICAL,SAVE :: first=.true. + + INTEGER j,l + + +C CALCUL DES CHAMPS EN MOYENNE ZONALE: + + if (iflag_top_bound.eq.0) return + + if (first) then + if (iflag_top_bound.eq.1) then +! couche eponge dans les 4 dernieres couches du modele + rdamp(:)=0. + rdamp(llm)=tau_top_bound + rdamp(llm-1)=tau_top_bound/2. + rdamp(llm-2)=tau_top_bound/4. + rdamp(llm-3)=tau_top_bound/8. + else if (iflag_top_bound.eq.2) then +! couce eponge dans toutes les couches de pression plus faible que +! 100 fois la pression de la derniere couche + rdamp(:)=tau_top_bound + s *max(presnivs(llm)/presnivs(:)-0.01,0.) + endif + first=.false. + print*,'TOP_BOUND rdamp=',rdamp + endif + + CALL massbar(masse,massebx,masseby) + + do l=1,llm + do j=1,jjm + vzon(j,l)=0. + zm=0. + do i=1,iim +! Rm: on peut travailler directement avec la moyenne zonale de vcov +! plutot qu'avec celle de v car le coefficient cv qui relie les deux +! ne varie qu'en latitude + vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) + zm=zm+masseby(i,j,l) + enddo + vzon(j,l)=vzon(j,l)/zm + enddo + enddo + + do l=1,llm + do i=1,iip1 + do j=1,jjm + dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l)) + enddo + enddo + enddo + + do l=1,llm + do j=2,jjm + uzon(j,l)=0. + zm=0. + do i=1,iim + uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) + zm=zm+massebx(i,j,l) + enddo + uzon(j,l)=uzon(j,l)/zm + enddo + enddo + + do l=1,llm + do j=2,jjm + zm=0. + tzon(j,l)=0. + do i=1,iim + tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) + zm=zm+masse(i,j,l) + enddo + tzon(j,l)=tzon(j,l)/zm + enddo + enddo + +C AMORTISSEMENTS LINEAIRES: + + do l=1,llm + do i=1,iip1 + do j=2,jjm + du(i,j,l)=du(i,j,l) + s -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) + dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l)) + enddo + enddo + enddo + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tourabs.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tourabs.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tourabs.F (revision 1634) @@ -0,0 +1,98 @@ + SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs ) + IMPLICIT NONE + +c======================================================================= +c +c Modif: I. Musat (28/10/04) +c ------- +c adaptation du code tourpot.F pour le calcul de la vorticite absolue +c cf. P. Le Van +c +c Objet: +c ------ +c +c ******************************************************************* +c ............. calcul de la vorticite absolue ................. +c ******************************************************************* +c +c ntetaSTD, vcov,ucov sont des argum. d'entree pour le s-pg . +c vorabs est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" +#include "comconst.h" +c + INTEGER ntetaSTD + REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD ) + REAL vorabs( ip1jm,ntetaSTD ) +c +c variables locales + INTEGER l, ij, i, j + REAL rot( ip1jm,ntetaSTD ) + + + +c ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,ntetaSTD + + DO 2 i = 1, iip1 + DO 2 j = 1, jjm +c + ij=i+(j-1)*iip1 + IF(ij.LE.ip1jm - 1) THEN +c + IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR. + $ cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN + rot( ij,l ) = 0. + continue + ELSE + rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/ + $ (2.*pi*RAD*cos(rlatv(j)))*REAL(iim) + $ +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/ + $ (pi*RAD)*(REAL(jjm)-1.) +c + ENDIF + ENDIF !(ij.LE.ip1jm - 1) THEN + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, ntetaSTD + + DO 6 ij = 1, ip1jm - 1 + vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) ) + 6 CONTINUE + +c ..... correction pour vorabs( iip1,j,l) ..... +c .... vorabs(iip1,j,l)= vorabs(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorabs( ij,l ) = vorabs( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tourpot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tourpot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tourpot.F (revision 1634) @@ -0,0 +1,81 @@ +! +! $Header$ +! + SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ip1jm,llm ) + REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) + REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) + + INTEGER l, ij + + + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,llm + + DO 2 ij = 1, ip1jm - 1 + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, llm + + DO 6 ij = 1, ip1jm - 1 + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/traceurpole.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/traceurpole.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/traceurpole.F (revision 1634) @@ -0,0 +1,70 @@ +! +! $Id$ +! + subroutine traceurpole(q,masse) + + USE control_mod + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + + +c Arguments + integer iq + real masse(iip1,jjp1,llm) + real q(iip1,jjp1,llm) + + +c Locals + integer i,j,l + real sommemassen(llm) + real sommemqn(llm) + real sommemasses(llm) + real sommemqs(llm) + real qpolen(llm),qpoles(llm) + + +c On impose une seule valeur au pôle Sud j=jjm+1=jjp1 + sommemasses=0 + sommemqs=0 + do l=1,llm + do i=1,iip1 + sommemasses(l)=sommemasses(l)+masse(i,jjp1,l) + sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l) + enddo + qpoles(l)=sommemqs(l)/sommemasses(l) + enddo + +c On impose une seule valeur du traceur au pôle Nord j=1 + sommemassen=0 + sommemqn=0 + do l=1,llm + do i=1,iip1 + sommemassen(l)=sommemassen(l)+masse(i,1,l) + sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l) + enddo + qpolen(l)=sommemqn(l)/sommemassen(l) + enddo + +c On force le traceur à prendre cette valeur aux pôles + do l=1,llm + do i=1,iip1 + q(i,1,l)=qpolen(l) + q(i,jjp1,l)=qpoles(l) + enddo + enddo + + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tracstoke.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tracstoke.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/tracstoke.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + common /tracstoke/istdyn,istphy,unittrac + integer istdyn,istphy,unittrac Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ugeostr.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ugeostr.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/ugeostr.F90 (revision 1634) @@ -0,0 +1,68 @@ +! +! $Id$ +! +subroutine ugeostr(phi,ucov) + + ! Calcul du vent covariant geostrophique a partir du champ de + ! geopotentiel. + ! We actually compute: (1 - cos^8 \phi) u_g + ! to have a wind going smoothly to 0 at the equator. + ! We assume that the surface pressure is uniform so that model + ! levels are pressure levels. + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + + real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm) + real um(jjm,llm),fact,u(iip1,jjm,llm) + integer i,j,l + + real zlat + + um(:,:)=0 ! initialize um() + + DO j=1,jjm + + if (abs(sin(rlatv(j))).lt.1.e-4) then + zlat=1.e-4 + else + zlat=rlatv(j) + endif + fact=cos(zlat) + fact=fact*fact + fact=fact*fact + fact=fact*fact + fact=(1.-fact)/ & + (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j))) + fact=-fact/rad + DO l=1,llm + DO i=1,iim + u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l)) + um(j,l)=um(j,l)+u(i,j,l)/REAL(iim) + ENDDO + ENDDO + ENDDO + call dump2d(jjm,llm,um,'Vent-u geostrophique') + + ! calcul des champ de vent: + + DO l=1,llm + DO i=1,iip1 + ucov(i,1,l)=0. + ucov(i,jjp1,l)=0. + end DO + DO j=2,jjm + DO i=1,iim + ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j) + end DO + ucov(iip1,j,l)=ucov(1,j,l) + end DO + end DO + + print *, 301 + +end subroutine ugeostr Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vitvert.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vitvert.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vitvert.F (revision 1634) @@ -0,0 +1,52 @@ +! +! $Header$ +! + SUBROUTINE vitvert ( convm , w ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) + INTEGER l, ij + + + + DO 2 l = 1,llmm1 + + DO 1 ij = 1,ip1jmp1 + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE + + DO 5 ij = 1,ip1jmp1 + w(ij,1) = 0. +5 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vlsplt.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vlsplt.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vlsplt.F (revision 1634) @@ -0,0 +1,959 @@ +c +c $Id$ +c + + SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max +c REAL masse(iip1,jjp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) +c REAL q(iip1,jjp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + INTEGER ijlqmin,iqmin,jqmin,lqmin +c + REAL zm(ip1jmp1,llm),newmasse + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm),zz + REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm) + REAL second,temps0,temps1,temps2,temps3 + REAL ztemps1,ztemps2,ztemps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + INTEGER iminn,imaxx + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + + + zzpbar = 0.5 * pdt + zzw = pdt + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + CALL SCOPY(ijp1llm,q,1,zq,1) + CALL SCOPY(ijp1llm,masse,1,zm,1) + +cprint*,'Entree vlx1' +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call vlx(zq,pente_max,zm,mu) +cprint*,'Sortie vlx1' +c call minmaxq(zq,qmin,qmax,'apres vlx1 ') + +c print*,'Entree vly1' + call vly(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly1 ') +cprint*,'Sortie vly1' + call vlz(zq,pente_max,zm,mw) +c call minmaxq(zq,qmin,qmax,'apres vlz ') + + + call vly(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly ') + + + call vlx(zq,pente_max,zm,mu) +c call minmaxq(zq,qmin,qmax,'apres vlx2 ') + + + DO l=1,llm + DO ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + ENDDO + DO ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + RETURN + END + SUBROUTINE vlx(q,pente_max,masse,u_m) + +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c + include "dimensions.h" + include "paramet.h" + include "logic.h" + include "comvert.h" + include "comconst.h" + include "iniprint.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + Logical extremum,first,testcpu + SAVE first,testcpu + + REAL SSUM + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + + REAL z1,z2,z3 + + DATA first,testcpu/.true.,.false./ + + IF(first) THEN + temps1=0. + temps2=0. + temps3=0. + temps4=0. + temps5=0. + first=.false. + ENDIF + +c calcul de la pente a droite et a gauche de la maille + + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=iip2+1,ip1jm + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=iip2+1,ip1jm +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +cprint*,'Ok calcul des pentes' + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- + + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=iip2+1,ip1jm + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- + + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + DO ij=1,ip1jmp1 + iadvplus(ij,l)=0 + ENDDO + + ENDDO + +c print*,'Bouclage en iip1' + +c calcul des flux a gauche et a droite + +#ifdef CRAY + + DO l=1,llm + DO ij=iip2,ip1jm-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +cprint*,'Cumule ....' + + DO l=1,llm + DO ij=iip2,ip1jm-1 +c print*,'masse(',ij,')=',masse(ij,l) + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l)) + ENDIF + ENDDO + ENDDO +#endif +c stop + +c go to 9999 +c detection des points ou on advecte plus que la masse de la +c maille + DO l=1,llm + DO ij=iip2,ip1jm-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +cprint*,'Ok test 1' + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c print*,'Ok test 2' + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 + DO l=1,llm + nl(l)=0 + DO ij=iip2,ip1jm + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO + + IF(n0.gt.0) THEN + if (prt_level > 2) PRINT *, + $ 'Nombre de points pour lesquels on advect plus que le' + & ,'contenu de la maille : ',n0 + + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=iip2,ip1jm + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF ! n0.gt.0 +9999 continue + + +c bouclage en latitude +cprint*,'cvant bouclage en latitude' + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO + + +c calcul des tENDances + + DO l=1,llm + DO ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + SUBROUTINE vly(q,pente_max,masse,masse_adv_v) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm), dq( ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical extremum,first,testcpu + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + SAVE first,testcpu + + REAL convpn,convps,convmpn,convmps + real massepn,masseps,qpn,qps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon + SAVE airej2,airejjm +c +c + REAL SSUM + + DATA first,testcpu/.true.,.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + + IF(first) THEN + PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c +cPRINT*,'CALCUL EN LATITUDE' + + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + DO ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + DO ij=iip2,ip1jm + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + +c calcul des pentes aux poles + + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + +c filtrage de la derivee + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + + goto 8888 + fn=1. + fs=1. + DO ij=1,iim + IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN + fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) + ENDIF + IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN + fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) + ENDIF + ENDDO + DO ij=1,iip1 + dyq(ij,l)=fn*dyq(ij,l) + dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) + ENDDO +8888 continue + DO ij=1,iip1 + dyq(ij,l)=0. + dyq(ip1jm+ij,l)=0. + ENDDO + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C appn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) +C apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) +C ENDDO +C appn=min(pente_max/appn,1.) +C apps=min(pente_max/apps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & appn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & apps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=appn*dyq(ij) +C dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + + DO ij=iip2,ip1jm + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + DO l=1,llm + DO ij=1,ip1jm + IF(masse_adv_v(ij,l).gt.0) THEN + qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)* + , 0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)) + ELSE + qbyv(ij,l)=q(ij,l)-dyq(ij,l)* + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) + ENDIF + qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO + + + DO l=1,llm + DO ij=iip2,ip1jm + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version +c convpn=SSUM(iim,qbyv(1,l),1)/apoln +c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + + convpn=SSUM(iim,qbyv(1,l),1) + convmpn=ssum(iim,masse_adv_v(1,l),1) + massepn=ssum(iim,masse(1,l),1) + qpn=0. + do ij=1,iim + qpn=qpn+masse(ij,l)*q(ij,l) + enddo + qpn=(qpn+convpn)/(massepn+convmpn) + do ij=1,iip1 + q(ij,l)=qpn + enddo + +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols + + convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) + convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) + masseps=ssum(iim, masse(ip1jm+1,l),1) + qps=0. + do ij = ip1jm+1,ip1jmp1-1 + qps=qps+masse(ij,l)*q(ij,l) + enddo + qps=(qps+convps)/(masseps+convmps) + do ij=ip1jm+1,ip1jmp1 + q(ij,l)=qps + enddo + +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO + + RETURN + END + SUBROUTINE vlz(q,pente_max,masse,w) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm+1) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL wq(ip1jmp1,llm+1),newmasse + + REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax + REAL sigw + + LOGICAL testcpu + SAVE testcpu + + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + REAL SSUM + + DATA testcpu/.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + +c On oriente tout dans le sens de la pression c'est a dire dans le +c sens de W + +#ifdef BIDON + IF(testcpu) THEN + temps0=second(0.) + ENDIF +#endif + DO l=2,llm + DO ij=1,ip1jmp1 + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + adzqw(ij,l)=abs(dzqw(ij,l)) + ENDDO + ENDDO + + DO l=2,llm-1 + DO ij=1,ip1jmp1 +#ifdef CRAY + dzq(ij,l)=0.5* + , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) +#else + IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN + dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) + ELSE + dzq(ij,l)=0. + ENDIF +#endif + dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) + dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + dzq(ij,1)=0. + dzq(ij,llm)=0. + ENDDO + +#ifdef BIDON + IF(testcpu) THEN + temps1=temps1+second(0.)-temps0 + ENDIF +#endif +c --------------------------------------------------------------- +c .... calcul des termes d'advection verticale ....... +c --------------------------------------------------------------- + +c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq + + DO l = 1,llm-1 + do ij = 1,ip1jmp1 + IF(w(ij,l+1).gt.0.) THEN + sigw=w(ij,l+1)/masse(ij,l+1) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1)) + ELSE + sigw=w(ij,l+1)/masse(ij,l) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l)) + ENDIF + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + wq(ij,llm+1)=0. + wq(ij,1)=0. + ENDDO + + DO l=1,llm + DO ij=1,ip1jmp1 + newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO + ENDDO + + + RETURN + END +c SUBROUTINE minmaxq(zq,qmin,qmax,comment) +c +c#include "dimensions.h" +c#include "paramet.h" + +c CHARACTER*(*) comment +c real qmin,qmax +c real zq(ip1jmp1,llm) + +c INTEGER jadrs(ip1jmp1), jbad, k, i + + +c DO k = 1, llm +c jbad = 0 +c DO i = 1, ip1jmp1 +c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN +c jbad = jbad + 1 +c jadrs(jbad) = i +c ENDIF +c ENDDO +c IF (jbad.GT.0) THEN +c PRINT*, comment +c DO i = 1, jbad +cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) +c ENDDO +c ENDIF +c ENDDO + +c return +c end + subroutine minmaxq(zq,qmin,qmax,comment) + +#include "dimensions.h" +#include "paramet.h" + + character*20 comment + real qmin,qmax + real zq(ip1jmp1,llm) + real zzq(iip1,jjp1,llm) + + integer imin,jmin,lmin,ijlmin + integer imax,jmax,lmax,ijlmax + + integer ismin,ismax + +#ifdef isminismax + call scopy (ip1jmp1*llm,zq,1,zzq,1) + + ijlmin=ismin(ijp1llm,zq,1) + lmin=(ijlmin-1)/ip1jmp1+1 + ijlmin=ijlmin-(lmin-1.)*ip1jmp1 + jmin=(ijlmin-1)/iip1+1 + imin=ijlmin-(jmin-1.)*iip1 + zqmin=zq(ijlmin,lmin) + + ijlmax=ismax(ijp1llm,zq,1) + lmax=(ijlmax-1)/ip1jmp1+1 + ijlmax=ijlmax-(lmax-1.)*ip1jmp1 + jmax=(ijlmax-1)/iip1+1 + imax=ijlmax-(jmax-1.)*iip1 + zqmax=zq(ijlmax,lmax) + + if(zqmin.lt.qmin) +c s write(*,9999) comment, + s write(*,*) comment, + s imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin) + if(zqmax.gt.qmax) +c s write(*,9999) comment, + s write(*,*) comment, + s imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax) + +#endif + return +9999 format(a20,' q(',i3,',',i2,',',i2,')=',e12.5,e12.5) + end + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vlspltqs.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vlspltqs.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/vlspltqs.F (revision 1634) @@ -0,0 +1,775 @@ +c +c $Id$ +c + SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt, + , p,pk,teta ) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c + test sur humidite specifique: Q advecte< Qsat aval +c (F. Codron, 10/99) +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c teta temperature potentielle, p pression aux interfaces, +c pk exner au milieu des couches necessaire pour calculer Qsat +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt + REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL qsat(ip1jmp1,llm) + REAL zm(ip1jmp1,llm) + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm) + REAL temps1,temps2,temps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + +c--pour rapport de melange saturant-- + + REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play + REAL ptarg,pdelarg,foeew,zdelta + REAL tempe(ip1jmp1) + +c fonction psat(T) + + FOEEW ( PTARG,PDELARG ) = EXP ( + * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) + + r2es = 380.11733 + r3les = 17.269 + r3ies = 21.875 + r4les = 35.86 + r4ies = 7.66 + retv = 0.6077667 + rtt = 273.16 + +c-- Calcul de Qsat en chaque point +c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 +c pour eviter une exponentielle. + DO l = 1, llm + DO ij = 1, ip1jmp1 + tempe(ij) = teta(ij,l) * pk(ij,l) /cpp + ENDDO + DO ij = 1, ip1jmp1 + zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) + play = 0.5*(p(ij,l)+p(ij,l+1)) + qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) + qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) + ENDDO + ENDDO + +c PRINT*,'Debut vlsplt version debug sans vlyqs' + + zzpbar = 0.5 * pdt + zzw = pdt + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + CALL SCOPY(ijp1llm,q,1,zq,1) + CALL SCOPY(ijp1llm,masse,1,zm,1) + +c call minmaxq(zq,qmin,qmax,'avant vlxqs ') + call vlxqs(zq,pente_max,zm,mu,qsat) + + +c call minmaxq(zq,qmin,qmax,'avant vlyqs ') + + call vlyqs(zq,pente_max,zm,mv,qsat) + + +c call minmaxq(zq,qmin,qmax,'avant vlz ') + + call vlz(zq,pente_max,zm,mw) + + +c call minmaxq(zq,qmin,qmax,'avant vlyqs ') +c call minmaxq(zm,qmin,qmax,'M avant vlyqs ') + + call vlyqs(zq,pente_max,zm,mv,qsat) + + +c call minmaxq(zq,qmin,qmax,'avant vlxqs ') +c call minmaxq(zm,qmin,qmax,'M avant vlxqs ') + + call vlxqs(zq,pente_max,zm,mu,qsat) + +c call minmaxq(zq,qmin,qmax,'apres vlxqs ') +c call minmaxq(zm,qmin,qmax,'M apres vlxqs ') + + + DO l=1,llm + DO ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + ENDDO + DO ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + RETURN + END + SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + Logical first,testcpu + SAVE first,testcpu + + REAL SSUM + REAL temps0,temps1,temps2,temps3,temps4,temps5 + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + + + DATA first,testcpu/.true.,.false./ + + IF(first) THEN + temps1=0. + temps2=0. + temps3=0. + temps4=0. + temps5=0. + first=.false. + ENDIF + +c calcul de la pente a droite et a gauche de la maille + + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=iip2+1,ip1jm + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=iip2+1,ip1jm +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- + + DO l = 1, llm + DO ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=iip2+1,ip1jm + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- + + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + + DO ij=1,ip1jmp1 + iadvplus(ij,l)=0 + ENDDO + + ENDDO + + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c--pas encore modification sur Qsat + DO l=1,llm + DO ij=iip2,ip1jm-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind) + DO l=1,llm + DO ij=iip2,ip1jm-1 + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l)) + ENDIF + ENDDO + ENDDO +#endif + + +c detection des points ou on advecte plus que la masse de la +c maille + DO l=1,llm + DO ij=iip2,ip1jm-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO + + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c pas d'influence de la pression saturante (pour l'instant) + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 + DO l=1,llm + nl(l)=0 + DO ij=iip2,ip1jm + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO + + IF(n0.gt.0) THEN +ccc PRINT*,'Nombre de points pour lesquels on advect plus que le' +ccc & ,'contenu de la maille : ',n0 + + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=iip2,ip1jm + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF ! n0.gt.0 + + + +c bouclage en latitude + + DO l=1,llm + DO ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO + + +c calcul des tendances + + DO l=1,llm + DO ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO + +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c qsat est un argument de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical first,testcpu + REAL temps0,temps1,temps2,temps3,temps4,temps5 + SAVE temps0,temps1,temps2,temps3,temps4,temps5 + SAVE first,testcpu + + REAL convpn,convps,convmpn,convmps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon + SAVE airej2,airejjm +c +c + REAL SSUM + + DATA first,testcpu/.true.,.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + + IF(first) THEN + PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c + + + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + DO ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + DO ij=iip2,ip1jm + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + +c calcul des pentes aux poles + + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + +c filtrage de la derivee + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + + fn=1. + fs=1. + DO ij=1,iim + IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN + fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) + ENDIF + IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN + fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) + ENDIF + ENDDO + DO ij=1,iip1 + dyq(ij,l)=fn*dyq(ij,l) + dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) + ENDDO + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C appn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) +C apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) +C ENDDO +C appn=min(pente_max/appn,1.) +C apps=min(pente_max/apps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & appn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & apps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=appn*dyq(ij) +C dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + + DO ij=iip2,ip1jm + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO + + DO l=1,llm + DO ij=1,ip1jm + IF( masse_adv_v(ij,l).GT.0. ) THEN + qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l ) + + , dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))) + ELSE + qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) * + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) ) + ENDIF + qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO + + + DO l=1,llm + DO ij=iip2,ip1jm + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version + convpn=SSUM(iim,qbyv(1,l),1)/apoln + convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + DO ij = 1,iip1 + newmasse=masse(ij,l)+convmpn*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + convps = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols + convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols + DO ij = ip1jm+1,ip1jmp1 + newmasse=masse(ij,l)+convmps*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/wrgrads.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/wrgrads.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/wrgrads.F (revision 1634) @@ -0,0 +1,133 @@ +! +! $Header$ +! + subroutine wrgrads(if,nl,field,name,titlevar) + implicit none + +c Declarations +c if indice du fichier +c nl nombre de couches +c field champ +c name petit nom +c titlevar Titre + +#include "gradsdef.h" + +c arguments + integer if,nl + real field(imx*jmx*lmx) + + integer, parameter:: wp = selected_real_kind(p=6, r=36) + real(wp) field4(imx*jmx*lmx) + + character*10 name,file + character*10 titlevar + +c local + + integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf + + logical writectl + + + writectl=.false. + +c print*,if,iid(if),jid(if),ifd(if),jfd(if) + iii=iid(if) + iji=jid(if) + iif=ifd(if) + ijf=jfd(if) + im=iif-iii+1 + jm=ijf-iji+1 + lm=lmd(if) + +c print*,'im,jm,lm,name,firsttime(if)' +c print*,im,jm,lm,name,firsttime(if) + + if(firsttime(if)) then + if(name.eq.var(1,if)) then + firsttime(if)=.false. + ivar(if)=1 + print*,'fin de l initialiation de l ecriture du fichier' + print*,file + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + else + ivar(if)=ivar(if)+1 + nvar(if)=ivar(if) + var(ivar(if),if)=name + tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar)) + nld(ivar(if),if)=nl +c print*,'initialisation ecriture de ',var(ivar(if),if) +c print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) + endif + writectl=.true. + itime(if)=1 + else + ivar(if)=mod(ivar(if),nvar(if))+1 + if (ivar(if).eq.nvar(if)) then + writectl=.true. + itime(if)=itime(if)+1 + endif + + if(var(ivar(if),if).ne.name) then + print*,'Il faut stoker la meme succession de champs a chaque' + print*,'pas de temps' + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + + stop + endif + endif + +c print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' +c print*,ivar(if),nvar(if),var(ivar(if),if),writectl + field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl) + do l=1,nl + irec(if)=irec(if)+1 +c print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, +c s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii +c s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif + write(unit(if)+1,rec=irec(if)) + s ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) + s ,i=iii,iif),j=iji,ijf) + enddo + if (writectl) then + + file=fichier(if) +c WARNING! on reecrase le fichier .ctl a chaque ecriture + open(unit(if),file=file(1:lnblnk(file))//'.ctl' + & ,form='formatted',status='unknown') + write(unit(if),'(a5,1x,a40)') + & 'DSET ','^'//file(1:lnblnk(file))//'.dat' + + write(unit(if),'(a12)') 'UNDEF 1.0E30' + write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) + call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') + call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') + call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') + write(unit(if),'(a4,i10,a30)') + & 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' + write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) + do iv=1,nvar(if) +c print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' +c print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) + write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) + & ,99,tvar(iv,if) + enddo + write(unit(if),'(a7)') 'ENDVARS' +c +1000 format(a5,3x,i4,i3,1x,a39) + + close(unit(if)) + + endif ! writectl + + return + + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/write_grads_dyn.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/write_grads_dyn.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/write_grads_dyn.h (revision 1634) @@ -0,0 +1,31 @@ +! +! $Header$ +! + if (callinigrads) then + + string10='dyn' + call inigrads(1,iip1 + s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dtvr*iperiod,string10,'dyn_zon ') + + callinigrads=.false. + + + endif + + string10='ps' + CALL wrgrads(1,1,ps,string10,string10) + + string10='u' + CALL wrgrads(1,llm,unat,string10,string10) + string10='v' + CALL wrgrads(1,llm,vnat,string10,string10) + string10='teta' + CALL wrgrads(1,llm,teta,string10,string10) + do iq=1,nqtot + string10='q' + write(string10(2:2),'(i1)') iq + CALL wrgrads(1,llm,q(:,:,iq),string10,string10) + enddo + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/write_paramLMDZ_dyn.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/write_paramLMDZ_dyn.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/write_paramLMDZ_dyn.h (revision 1634) @@ -0,0 +1,246 @@ +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! Attention : il n'y a aucune raison pour ecrire ces constantes +! comme des champs 2D. A corriger un jour ... + +c + ndex2d = 0 + itau_w=itau_dyn+itau +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(prt_level) + CALL histwrite(nid_ctesGCM, "prt_level", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(dayref) + CALL histwrite(nid_ctesGCM, "dayref", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(anneeref) + CALL histwrite(nid_ctesGCM, "anneeref", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(raz_date) + CALL histwrite(nid_ctesGCM, "raz_date", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(nday) + CALL histwrite(nid_ctesGCM, "nday", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(day_step) + CALL histwrite(nid_ctesGCM, "day_step", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(iperiod) + CALL histwrite(nid_ctesGCM, "iperiod", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(iapp_tracvl) + CALL histwrite(nid_ctesGCM, "iapp_tracvl", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(iconser) + CALL histwrite(nid_ctesGCM, "iconser", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(iecri) + CALL histwrite(nid_ctesGCM, "iecri", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=periodav + CALL histwrite(nid_ctesGCM, "periodav", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(dissip_period) + CALL histwrite(nid_ctesGCM, "dissip_period", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(lstardis) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "lstardis", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(nitergdiv) + CALL histwrite(nid_ctesGCM, "nitergdiv", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(nitergrot) + CALL histwrite(nid_ctesGCM, "nitergrot", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(niterh) + CALL histwrite(nid_ctesGCM, "niterh", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tetagdiv + CALL histwrite(nid_ctesGCM, "tetagdiv", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tetagrot + CALL histwrite(nid_ctesGCM, "tetagrot", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tetatemp + CALL histwrite(nid_ctesGCM, "tetatemp", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=coefdis + CALL histwrite(nid_ctesGCM, "coefdis", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(purmats) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "purmats", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(ok_guide) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "ok_guide", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + if (calend == 'earth_360d') then + zx_tmp_2d(1:iip1,1:jjp1)=1. + else if (calend == 'earth_365d') then + zx_tmp_2d(1:iip1,1:jjp1)=2. + else if (calend == 'earth_366d') then + zx_tmp_2d(1:iip1,1:jjp1)=3. + endif + + CALL histwrite(nid_ctesGCM, "true_calendar", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(iflag_phys) + CALL histwrite(nid_ctesGCM, "iflag_phys", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=REAL(iphysiq) + CALL histwrite(nid_ctesGCM, "iphysiq", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/02 +! La variable cycle_diurne n'est pas vue par la dynamique +! IF(cycle_diurne) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "cycle_diurne", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(soil_model) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "soil_model", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(new_oliq) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "new_oliq", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(ok_orodr) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "ok_orodr", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(ok_orolf) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "ok_orolf", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! IF(ok_limitvrai) THEN +! zx_tmp_2d(1:iip1,1:jjp1)=1. +! ELSE +! zx_tmp_2d(1:iip1,1:jjp1)=0. +! ENDIF +! CALL histwrite(nid_ctesGCM, "ok_limitvrai", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! zx_tmp_2d(1:iip1,1:jjp1)=nbapp_rad +! CALL histwrite(nid_ctesGCM, "nbapp_rad", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +! +! zx_tmp_2d(1:iip1,1:jjp1)=iflag_con +! CALL histwrite(nid_ctesGCM, "iflag_con", itau_w, +! . zx_tmp_2d,iip1*jjp1,ndex2d) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + zx_tmp_2d(1:iip1,1:jjp1)=clon + CALL histwrite(nid_ctesGCM, "clon", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=clat + CALL histwrite(nid_ctesGCM, "clat", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=grossismx + CALL histwrite(nid_ctesGCM, "grossismx", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=grossismy + CALL histwrite(nid_ctesGCM, "grossismy", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(fxyhypb) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "fxyhypb", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=dzoomx + CALL histwrite(nid_ctesGCM, "dzoomx", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=dzoomy + CALL histwrite(nid_ctesGCM, "dzoomy", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=taux + CALL histwrite(nid_ctesGCM, "taux", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=tauy + CALL histwrite(nid_ctesGCM, "tauy", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + IF(ysinus) THEN + zx_tmp_2d(1:iip1,1:jjp1)=1. + ELSE + zx_tmp_2d(1:iip1,1:jjp1)=0. + ENDIF + CALL histwrite(nid_ctesGCM, "ysinus", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c + zx_tmp_2d(1:iip1,1:jjp1)=ip_ebil_dyn + CALL histwrite(nid_ctesGCM, "ip_ebil_dyn", itau_w, + . zx_tmp_2d,iip1*jjp1,ndex2d) +c +c================================================================= +c + if (ok_sync) then + call histsync(nid_ctesGCM) + endif +c +c================================================================= Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/PVtheta.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/PVtheta.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/PVtheta.F (revision 1634) @@ -0,0 +1,196 @@ + SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ nbteta,theta,PVteta) + IMPLICIT none + +c======================================================================= +c +c Auteur: I. Musat +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c Calcul de la vorticite potentielle PVteta sur des iso-theta selon +c la methodologie du NCEP/NCAR : +c 1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les +c niveaux du modele => N2 +c 2) on interpole les vents, la temperature et le N**2 sur des isentropes +c (en fait sur des iso-theta) lineairement en log(theta) => +c ucovteta, vcovteta, N2teta +c 3) on calcule la vorticite absolue sur des iso-theta => vorateta +c 4) on calcule la densite rho sur des iso-theta => rhoteta +c +c rhoteta = (T/theta)**(cp/R)*p0/(R*T) +c +c 5) on calcule la vorticite potentielle sur des iso-theta => PVteta +c +c PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU +c +c NB: 1PVU=10**(-6) K*m**2/(s * kg) +c +c PVteta = vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s) +c +c +c ******************************************************************* +c +c +c Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta +c -> sur la grille dynamique +c Variable de sortie : PVteta +c -> sur la grille physique +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +c +c variables Input +c + INTEGER ilon, ilev + REAL pvcov(iip1,jjm,ilev) + REAL pucov(iip1,jjp1,ilev) + REAL pteta(iip1,jjp1,ilev) + REAL ztfi(ilon,ilev) + REAL zplay(ilon,ilev), zplev(ilon,ilev+1) + INTEGER nbteta + REAL theta(nbteta) +c +c variable Output +c + REAL PVteta(ilon,nbteta) +c +c variables locales +c + INTEGER i, j, l, ig0 + REAL SSUM + REAL teta(ilon, ilev) + REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev) + REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev) + REAL N2(ilon,ilev-1), N2teta(ilon,nbteta) + REAL ztfiteta(ilon,nbteta) + REAL rhoteta(ilon,nbteta) + REAL vorateta(iip1,jjm,nbteta) + REAL voratetafi(ilon,nbteta), vorpol(iim) +c +#include "comgeom2.h" +#include "comconst.h" +#include "comvert.h" +c +c projection teta sur la grille physique +c + DO l=1,llm + teta(1,l) = pteta(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i = 1, iim + teta(ig0,l) = pteta(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + teta(ig0,l) = pteta(1,jjp1,l) + ENDDO +c +c calcul pteta sur les grilles U et V +c + DO l=1, llm + DO j=1, jjp1 + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetau(ig0,l)=pteta(i,j,l) + ENDDO !i + ENDDO !j + DO j=1, jjm + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l)) + ENDDO !i + ENDDO !j + ENDDO !l +c +c projection pucov, pvcov sur une surface de theta constante +c + DO l=1, nbteta +cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l), + CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l), + . pucov,ucovteta(:,l)) +cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l), + CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l), + . pvcov,vcovteta(:,l)) + ENDDO !l +c +c calcul vorticite absolue sur une iso-theta : vorateta +c + CALL tourabs(nbteta,vcovteta,ucovteta,vorateta) +c +c projection vorateta sur la grille physique => voratetafi +c + DO l=1,nbteta + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) + + $ vorateta(i+1,j-1,l) * alpha1(i+1,j) + + $ vorateta(i ,j ,l) * alpha3(i+1,j) + + $ vorateta(i+1,j ,l) * alpha2(i+1,j) + ENDDO + voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l) + ENDDO + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,1,l)*aire(i,1) + ENDDO + voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,jjm,l)* aire(i,jjm +1) + ENDDO + voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols + ENDDO +c +c calcul N**2 sur la grille physique => N2 +c + DO l=1, llm-1 + DO i=1, ilon + N2(i,l) = (g**2 * zplay(i,l) * + $ (ztfi(i,l+1)-ztfi(i,l)) )/ + $ (R*ztfi(i,l)*ztfi(i,l)* + $ (zplev(i,l)-zplev(i,l+1)) )+ + $ (g**2)/(ztfi(i,l)*CPP) + ENDDO !i + ENDDO !l +c +c calcul N2 sur une iso-theta => N2teta +c + DO l=1, nbteta + CALL tetalevel(ilon,llm-1,.true.,teta,theta(l), + $ N2,N2teta(:,l)) + CALL tetalevel(ilon,llm,.true.,teta,theta(l), + $ ztfi,ztfiteta(:,l)) + ENDDO !l=1, nbteta +c +c calcul rho et PV sur une iso-theta : rhoteta, PVteta +c + DO l=1, nbteta + DO i=1, ilon + rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)* + $ (preff/(R*ztfiteta(i,l))) +c +c PVteta en PVU +c + PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) +c +c PVteta en 1/(Pa*s) +c + PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) + ENDDO !i + ENDDO !l +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/abort_gcm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/abort_gcm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/abort_gcm.F (revision 1634) @@ -0,0 +1,51 @@ +! +! $Id$ +! +c +c + SUBROUTINE abort_gcm(modname, message, ierr) + +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin_dump + USE ioipsl_getincom +#endif + USE parallel +#include "iniprint.h" + +C +C Stops the simulation cleanly, closing files and printing various +C comments +C +C Input: modname = name of calling program +C message = stuff to print +C ierr = severity of situation ( = 0 normal ) + + character(len=*) modname + integer ierr + character(len=*) message + + write(lunout,*) 'in abort_gcm' +#ifdef CPP_IOIPSL +c$OMP MASTER + call histclo + call restclo + if (MPI_rank .eq. 0) then + call getin_dump + endif +c$OMP END MASTER +#endif +c call histclo(2) +c call histclo(3) +c call histclo(4) +c call histclo(5) + write(lunout,*) 'Stopping in ', modname + write(lunout,*) 'Reason = ',message + if (ierr .eq. 0) then + write(lunout,*) 'Everything is cool' + else + write(lunout,*) 'Houston, we have a problem ', ierr + stop 1 + endif + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/academic.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/academic.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/academic.h (revision 1634) @@ -0,0 +1,9 @@ +! +! $Id$ +! + common/academic/tetarappel,knewt_t,kfrict,knewt_g,clat4 + real :: tetarappel(ip1jmp1,llm) + real :: knewt_t(llm) + real :: kfrict(llm) + real :: knewt_g + real :: clat4(ip1jmp1) Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/adaptdt.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/adaptdt.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/adaptdt.F (revision 1634) @@ -0,0 +1,60 @@ +! +! $Id$ +! + subroutine adaptdt(nadv,dtbon,n,pbaru, + c masse) + + USE control_mod + + IMPLICIT NONE + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + +c---------------------------------------------------------- +c Arguments +c---------------------------------------------------------- + INTEGER n,nadv + REAL dtbon + REAL pbaru(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) +c---------------------------------------------------------- +c Local +c---------------------------------------------------------- + INTEGER i,j,l + REAL CFLmax,aaa,bbb + + CFLmax=0. + do l=1,llm + do j=2,jjm + do i=1,iim + aaa=pbaru(i,j,l)*dtvr/masse(i,j,l) + CFLmax=max(CFLmax,aaa) + bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l) + CFLmax=max(CFLmax,bbb) + enddo + enddo + enddo + n=int(CFLmax)+1 +c pour reproduire cas VL du code qui appele x,y,z,y,x +c if (nadv.eq.30) n=n/2 ! Pour Prather + dtbon=dtvr/n + + return + end + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/addfi_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/addfi_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/addfi_p.F (revision 1634) @@ -0,0 +1,260 @@ +! +! $Id$ +! + SUBROUTINE addfi_p(pdt, leapf, forward, + S pucov, pvcov, pteta, pq , pps , + S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) + USE parallel + USE infotrac, ONLY : nqtot + USE control_mod, ONLY : planet_type + IMPLICIT NONE +c +c======================================================================= +c +c Addition of the physical tendencies +c +c Interface : +c ----------- +c +c Input : +c ------- +c pdt time step of integration +c leapf logical +c forward logical +c pucov(ip1jmp1,llm) first component of the covariant velocity +c pvcov(ip1ip1jm,llm) second component of the covariant velocity +c pteta(ip1jmp1,llm) potential temperature +c pts(ip1jmp1,llm) surface temperature +c pdufi(ip1jmp1,llm) | +c pdvfi(ip1jm,llm) | respective +c pdhfi(ip1jmp1) | tendencies +c pdtsfi(ip1jmp1) | +c +c Output : +c -------- +c pucov +c pvcov +c ph +c pts +c +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" +c +c Arguments : +c ----------- +c + REAL pdt +c + REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm) + REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1) +c + REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm) + REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1) +c + LOGICAL leapf,forward +c +c +c Local variables : +c ----------------- +c + REAL xpn(iim),xps(iim),tpn,tps + INTEGER j,k,iq,ij + REAL qtestw, qtestt + PARAMETER ( qtestw = 1.0e-15 ) + PARAMETER ( qtestt = 1.0e-40 ) + + REAL SSUM + EXTERNAL SSUM + + INTEGER :: ijb,ije +c +c----------------------------------------------------------------------- + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pteta( ij ,k) + ENDDO + tpn = SSUM(iim,xpn,1)/ apoln + + DO ij = 1, iip1 + pteta( ij ,k) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif + + if (pole_sud) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k) + ENDDO + tps = SSUM(iim,xps,1)/ apols + + DO ij = 1, iip1 + pteta(ij+ip1jm,k) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif +c + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) ijb=ij_begin + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c + if (pole_sud) ije=ij_end +c$OMP MASTER + DO j = ijb,ije + pps(j) = pps(j) + pdpfi(j) * pdt + ENDDO +c$OMP END MASTER + + if (planet_type=="earth") then + ! earth case, special treatment for first 2 tracers (water) + DO iq = 1, 2 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + + DO iq = 3, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + else + ! general case, treat all tracers equally) + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif ! of if (planet_type=="earth") + +c$OMP MASTER + if (pole_nord) then + + DO ij = 1, iim + xpn(ij) = aire( ij ) * pps( ij ) + ENDDO + + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pps ( ij ) = tpn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm ) + ENDDO + + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pps ( ij+ip1jm ) = tps + ENDDO + + endif +c$OMP END MASTER + + if (pole_nord) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pq( ij ,k,iq) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pq ( ij ,k,iq) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + if (pole_sud) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq) + ENDDO + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pq (ij+ip1jm,k,iq) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advect_new_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advect_new_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advect_new_p.F (revision 1634) @@ -0,0 +1,284 @@ +! +! $Header$ +! + SUBROUTINE advect_new_p(ucov,vcov,teta,w,massebx,masseby, + & du,dv,dteta) + USE parallel + USE write_field_p + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) + REAL,SAVE :: dv1(ip1jm,llm),du1(ip1jmp1,llm),dteta1(ip1jmp1,llm) + REAL,SAVE :: dv2(ip1jm,llm),du2(ip1jmp1,llm),dteta2(ip1jmp1,llm) +c Local: +c ------ + + REAL,SAVE :: uav(ip1jmp1,llm),vav(ip1jm,llm) + REAL wsur2(ip1jmp1) + REAL unsaire2(ip1jmp1), ge(ip1jmp1) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l,ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + +c$OMP MASTER + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij=ijb,ije + du2(ij,1)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dv2(ij,1)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + + DO ij=ijb,ije + dteta2(ij,1)=0. + ENDDO +c$OMP END MASTER + + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c DO ij = iip2, ip1jmp1 +c uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) +c ENDDO + +c DO ij = iip2, ip1jm +c uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) +c ENDDO + + DO ij = ijb, ije + + uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) + . +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) + ENDDO + + if (pole_nord) then + DO ij = 1, iip1 + uav(ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + uav(ip1jm+ij,l) = 0. + ENDDO + endif + + ENDDO +c$OMP END DO +c call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + DO ij = ijb+1, ije + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + + DO ij = ijb,ije,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + + + DO ij = ijb, ije-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + + DO ij = ijb, ije, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + + ENDDO +c$OMP END DO +c call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) + +c----------------------------------------------------------------------- +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO 5 ij = ijb, ije + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 6 ij = ijb ,ije-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du1(ij,l) = ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du2(ij,l+1)= ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ................. calcul pour dv ..................... + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 8 ij = ijb, ije + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv1(ij,l) = ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv2(ij,l+1)= ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + ijb=ij_begin + ije=ij_end + + DO 15 ij = ijb, ije + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta1(ij, l ) = ww + dteta2(ij,l+1) = ww + 15 CONTINUE + +c ym ---> conser a voir plus tard + +c IF( conser) THEN +c +c DO 17 ij = 1,ip1jmp1 +c ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) +c 17 CONTINUE +c gt = SSUM( ip1jmp1,ge,1 ) +c gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) +c END IF + + 20 CONTINUE +c$OMP END DO + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l) + ENDDO + + DO ij = ijb+iip1-1, ije, iip1 + du( ij, l ) = du( ij -iim, l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advect_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advect_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advect_p.F (revision 1634) @@ -0,0 +1,219 @@ +! +! $Header$ +! + SUBROUTINE advect_p(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta) + USE parallel + USE write_field_p + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) + +c Local: +c ------ + + REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1) + REAL unsaire2(ip1jmp1), ge(ip1jmp1) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l,ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + + DO l=1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c DO ij = iip2, ip1jmp1 +c uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) +c ENDDO + +c DO ij = iip2, ip1jm +c uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) +c ENDDO + + DO ij = ijb, ije + + uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) + . +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) + ENDDO + + if (pole_nord) then + DO ij = 1, iip1 + uav(ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + uav(ip1jm+ij,l) = 0. + ENDDO + endif + + ENDDO + +c call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + + DO ij = ijb+1, ije + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + + DO ij = ijb,ije,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + + + DO ij = ijb, ije-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + + DO ij = ijb, ije, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + + ENDDO +c call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) +c----------------------------------------------------------------------- + + + + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO 5 ij = ijb, ije + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 6 ij = ijb ,ije-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du(ij,l) = du(ij,l) - ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ..... correction pour du(iip1,j,l) ........ +c ..... du(iip1,j,l)= du(1,j,l) ..... + +CDIR$ IVDEP + DO 7 ij = ijb+iip1-1, ije, iip1 + du( ij, l ) = du( ij -iim, l ) + du( ij,l+1 ) = du( ij -iim,l+1 ) + 7 CONTINUE + +c ................. calcul pour dv ..................... + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 8 ij = ijb, ije + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv(ij,l) = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + ijb=ij_begin + ije=ij_end + + DO 15 ij = ijb, ije + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta(ij, l ) = dteta(ij, l ) - ww + dteta(ij,l+1) = dteta(ij,l+1) + ww + 15 CONTINUE + +c ym ---> conser a voir plus tard + +c IF( conser) THEN +c +c DO 17 ij = 1,ip1jmp1 +c ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) +c 17 CONTINUE +c gt = SSUM( ip1jmp1,ge,1 ) +c gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) +c END IF + + 20 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advn.F (revision 1634) @@ -0,0 +1,983 @@ +! +! $Header$ +! + SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "iniprint.h" + +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + integer ijlqmin,iqmin,jqmin,lqmin + integer ismin +c + real zm(ip1jmp1,llm),newmasse + real mu(ip1jmp1,llm) + real mv(ip1jm,llm) + real mw(ip1jmp1,llm+1) + real zq(ip1jmp1,llm),zz,qpn,qps + real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm) + real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm) + real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm) + real temps0,temps1,temps2,temps3 + real ztemps1,ztemps2,ztemps3,ssum + logical testcpu + save testcpu + save temps1,temps2,temps3 + real zzpbar,zzw + +#ifdef CRAY + real second +#endif + + real qmin,qmax + data qmin,qmax/0.,1./ + data testcpu/.false./ + data temps1,temps2,temps3/0.,0.,0./ + + zzpbar = 0.5 * pdt + zzw = pdt + + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + do l=1,llm + qpn=0. + qps=0. + do ij=1,iim + qpn=qpn+q(ij,l)*masse(ij,l) + qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l) + enddo + qpn=qpn/ssum(iim,masse(1,l),1) + qps=qps/ssum(iim,masse(ip1jm+1,l),1) + do ij=1,iip1 + q(ij,l)=qpn + q(ip1jm+ij,l)=qps + enddo + enddo + + do ij=1,ip1jmp1 + mw(ij,llm+1)=0. + enddo + do l=1,llm + do ij=1,ip1jmp1 + zq(ij,l)=q(ij,l) + zm(ij,l)=masse(ij,l) + enddo + enddo + +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqz(zq,zqh,zqb) + call advnz(zq,zqh,zqb,zm,mw) +c call vlz(zq,0.,zm,mw) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) +c call minmaxq(zq,qmin,qmax,'apres vlx ') + +#ifdef CRAY + if(testcpu) then + ztemps1=second(0.) + temps1=temps1+ztemps1-ztemps2 + print*,'VLSPLT X:',temps1,' Y:',temps2,' Z:',temps3 + endif +#endif + do l=1,llm + do ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + enddo + do ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + enddo + enddo + + RETURN + END + + SUBROUTINE advnqx(q,qg,qd) +c +c Auteurs: Calcul des valeurs de q aux point u. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dxqu(ip1jmp1),zqu(ip1jmp1) + real zqmax(ip1jmp1),zqmin(ip1jmp1) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jm + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + enddo + enddo + else + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + zqu(ij)=0.5*(q(ij+1,l)+q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2,ip1jm-1 + zqu(ij)=zqu(ij)-dxqu(ij+1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2+1,ip1jm + zqu(ij)=zqu(ij)+dxqu(ij-1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij-iim)=zqu(ij) + enddo + +c calcul des valeurs max et min acceptees aux interfaces + + do ij=iip2,ip1jm-1 + zqmax(ij)=max(q(ij+1,l),q(ij,l)) + zqmin(ij)=min(q(ij+1,l),q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqmax(ij)=zqmax(ij-iim) + zqmin(ij)=zqmin(ij-iim) + enddo + do ij=iip2+1,ip1jm + extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0. + enddo + do ij=iip1+iip1,ip1jm,iip1 + extremum(ij-iim)=extremum(ij) + enddo + do ij=iip2,ip1jm + zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij)) + enddo + do ij=iip2+1,ip1jm + if(extremum(ij)) then + qg(ij,l)=q(ij,l) + qd(ij,l)=q(ij,l) + else + qd(ij,l)=zqu(ij) + qg(ij,l)=zqu(ij-1) + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + qg(ij-iim,l)=qg(ij,l) + enddo + + goto 8888 + + do ij=iip2+1,ip1jm + if(extremum(ij).and..not.extremum(ij-1)) + s qd(ij-1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + enddo + do ij=iip2,ip1jm-1 + if (extremum(ij).and..not.extremum(ij+1)) + s qg(ij+1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qg(ij,l)=qg(ij-iim,l) + enddo +8888 continue + enddo + endif + RETURN + END + SUBROUTINE advnqy(q,qs,qn) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dyqv(ip1jm),zqv(ip1jm,llm) + real zqmax(ip1jm),zqmin(ip1jm) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qn(ij,l)=q(ij,l) + qs(ij,l)=q(ij,l) + enddo + enddo + else + +c calcul des pentes en u: +c ----------------------- + do l = 1, llm + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + enddo + + do ij=iip2,ip1jm-iip1 + zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l)) + zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12. + enddo + + do ij=iip2,ip1jm + extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0. + enddo + +c Pas de pentes aux poles + do ij=1,iip1 + zqv(ij,l)=q(ij,l) + zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l) + extremum(ij)=.true. + extremum(ip1jmp1-iip1+ij)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do ij=1,ip1jm + zqmax(ij)=max(q(ij+iip1,l),q(ij,l)) + zqmin(ij)=min(q(ij+iip1,l),q(ij,l)) + enddo + + do ij=1,ip1jm + zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij)) + enddo + + do ij=iip2,ip1jm + if(extremum(ij)) then + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) +c if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l) +c if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l) + else + qs(ij,l)=zqv(ij,l) + qn(ij,l)=zqv(ij-iip1,l) + endif + enddo + + do ij=1,iip1 + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) + qs(ip1jm+ij,l)=q(ip1jm+ij,l) + qn(ip1jm+ij,l)=q(ip1jm+ij,l) + enddo + + enddo + endif + RETURN + END + + SUBROUTINE advnqz(q,qh,qb) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1) + real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm) + logical extremum(ip1jmp1,llm) + + integer mode + save mode + + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qb(ij,l)=q(ij,l) + qh(ij,l)=q(ij,l) + enddo + enddo + else + do l = 2, llm + do ij=1,ip1jmp1 + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l)) + enddo + enddo + do ij=1,ip1jmp1 + dzqw(ij,1)=0. + dzqw(ij,llm+1)=0. + enddo + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12. + enddo + enddo + do l=2,llm-1 + do ij=1,ip1jmp1 + extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0. + enddo + enddo + +c Pas de pentes en bas et en haut + do ij=1,ip1jmp1 + zqw(ij,2)=q(ij,1) + zqw(ij,llm)=q(ij,llm) + extremum(ij,1)=.true. + extremum(ij,llm)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do l=2,llm + do ij=1,ip1jmp1 + zqmax(ij,l)=max(q(ij,l-1),q(ij,l)) + zqmin(ij,l)=min(q(ij,l-1),q(ij,l)) + enddo + enddo + + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l)) + enddo + enddo + + do l=2,llm-1 + do ij=1,ip1jmp1 + if(extremum(ij,l)) then + qh(ij,l)=q(ij,l) + qb(ij,l)=q(ij,l) + else + qh(ij,l)=zqw(ij,l+1) + qb(ij,l)=zqw(ij,l) + endif + enddo + enddo +c do l=2,llm-1 +c do ij=1,ip1jmp1 +c if(extremum(ij,l)) then +c if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l) +c if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l) +c endif +c enddo +c enddo + + do ij=1,ip1jmp1 + qb(ij,1)=q(ij,1) + qh(ij,1)=q(ij,1) + qb(ij,llm)=q(ij,llm) + qh(ij,llm)=q(ij,llm) + enddo + + endif + + RETURN + END + + SUBROUTINE advnx(q,qg,qd,masse,u_m,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + real u_m( ip1jmp1,llm ) + real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq + integer n0,nl(llm) +c + real new_m,zu_m,zdq,zz + real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig + real u_mq(ip1jmp1,llm) + + real zm,zq,zsigm,zsigp,zqm,zqp,zu + + logical ladvplus(ip1jmp1,llm) + + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + + do l=1,llm + do ij=iip2,ip1jm + zdq=qd(ij,l)-qg(ij,l) +c if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qd(ij,l),q(ij,l),qg(ij,l) +c qd(ij,l)=q(ij,l) +c qg(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq + zsigg(ij,l)=1.-zsigd(ij,l) +c if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and. +c s zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigg=',zsigg(ij,l),' sigd=',zsigd(ij,l) +c print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq +c stop +c endif + else + zsigd(ij,l)=0.5 + zsigg(ij,l)=0.5 + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + endif + enddo + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=1,llm + do ij=iip2,ip1jm-1 + if (u_m(ij,l).ge.0.) then + zsigp=zsigd(ij,l) + zsigm=zsigg(ij,l) + zqp=qd(ij,l) + zqm=qg(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigd(ij+1,l) + zsigp=zsigg(ij+1,l) + zqm=qd(ij+1,l) + zqp=qg(ij+1,l) + zm=masse(ij+1,l) + zq=q(ij+1,l) + endif + zu=abs(u_m(ij,l)) + ladvplus(ij,l)=zu.gt.zm + zsig=zu/zm + if(zsig.eq.0.) zsigp=0.1 + if (mode.eq.1) then + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*zqp + else if (mode.eq.1) then + u_mq(ij,l)= + s sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm) + endif + else + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + endif +c if(zsig.lt.0.) then +c print*,'au point ij=',ij,' l=',l,' sig=',zsig +c stop +c endif + enddo + enddo + + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ladvplus(ij,l)=ladvplus(ij-iim,l) + enddo + enddo + +c================================================================= +C SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES +c================================================================= +c tris des regions a traiter + n0=0 + do l=1,llm + nl(l)=0 + do ij=iip2,ip1jm + if(ladvplus(ij,l)) then + nl(l)=nl(l)+1 + u_mq(ij,l)=0. + endif + enddo + n0=n0+nl(l) + enddo + + if(n0.gt.1) then + IF (prt_level > 9) WRITE(lunout,*) + & 'Nombre de points pour lesquels on advect plus que le' + & ,'contenu de la maille : ',n0 + + do l=1,llm + if(nl(l).gt.0) then + iju=0 +c indicage des mailles concernees par le traitement special + do ij=iip2,ip1jm + if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then + iju=iju+1 + indu(iju)=ij + endif + enddo + niju=iju +c print*,'niju,nl',niju,nl(l) + +c traitement des mailles + do iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + if(zu_m.gt.0.) then + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + enddo +c MODIFS SPECIFIQUES DU SCHEMA +c ajout de la maille non completement advectee + zsig=zu_m/masse(ijq,l) + if(zsig.le.zsigd(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l) + s -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 8888 + zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme2 au point ij=',ij, + s ' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*( + s 0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l) + s +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) ) + endif + else + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + enddo +c ajout de la maille non completement advectee +c 2eme MODIF SPECIFIQUE + zsig=-zu_m/masse(ij+1,l) + if(zsig.le.zsigg(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l) + s -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 9999 + zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme22 au point ij=',ij + s ,' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*( + s 0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l) + s +(zsig-zsigg(ijq,l))* + s (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) ) + endif +c fin de la modif + endif + enddo + endif + enddo + endif ! n0.gt.0 + +c bouclage en latitude + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + enddo + enddo + +c================================================================= +c CALCUL DE LA CONVERGENCE DES FLUX +c================================================================= + + do l=1,llm + do ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + do ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + enddo + enddo + + RETURN + END + SUBROUTINE advny(q,qs,qn,masse,v_m) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real v_m( ip1jm,llm ) + real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigs(ip1jmp1),zsign(ip1jmp1),zsig + real v_mq(ip1jm,llm) + real convpn,convps,convmpn,convmps,massen,masses + real zm,zq,zsigm,zsigp,zqm,zqp + real ssum + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + do l=1,llm + do ij=1,ip1jmp1 + zdq=qn(ij,l)-qs(ij,l) +c if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l,' advnqx' +c print*,qn(ij,l),q(ij,l),qs(ij,l) +c qn(ij,l)=q(ij,l) +c qs(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsign(ij)=(q(ij,l)-qs(ij,l))/zdq + zsigs(ij)=1.-zsign(ij) +c if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and. +c s zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigs=',zsigs(ij),' sign=',zsign(ij) +c stop +c endif + else + zsign(ij)=0.5 + zsigs(ij)=0.5 + endif + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=1,ip1jm + if (v_m(ij,l).ge.0.) then + zsigp=zsign(ij+iip1) + zsigm=zsigs(ij+iip1) + zqp=qn(ij+iip1,l) + zqm=qs(ij+iip1,l) + zm=masse(ij+iip1,l) + zq=q(ij+iip1,l) + else + zsigm=zsign(ij) + zsigp=zsigs(ij) + zqm=qn(ij,l) + zqp=qs(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + endif + zsig=abs(v_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do l=1,llm + do ij=iip2,ip1jm + new_m=masse(ij,l) + & +v_m(ij,l)-v_m(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l)) + & /new_m + masse(ij,l)=new_m + enddo +c.-. ancienne version + convpn=SSUM(iim,v_mq(1,l),1) + convmpn=ssum(iim,v_m(1,l),1) + massen=ssum(iim,masse(1,l),1) + new_m=massen+convmpn + q(1,l)=(q(1,l)*massen+convpn)/new_m + do ij = 1,iip1 + q(ij,l)=q(1,l) + masse(ij,l)=new_m*aire(ij)/apoln + enddo + + convps=-SSUM(iim,v_mq(ip1jm-iim,l),1) + convmps=-ssum(iim,v_m(ip1jm-iim,l),1) + masses=ssum(iim,masse(ip1jm+1,l),1) + new_m=masses+convmps + q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m + do ij = ip1jm+1,ip1jmp1 + q(ij,l)=q(ip1jm+1,l) + masse(ij,l)=new_m*aire(ij)/apols + enddo + enddo + + RETURN + END + SUBROUTINE advnz(q,qh,qb,masse,w_m) +c +c Auteurs: F.Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c b designe le bas et h le haut +c il y a une correspondance entre le b en z et le d en x +c ******************************************************************** +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real w_m( ip1jmp1,llm+1) + real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm) + +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig + real w_mq(ip1jmp1,llm+1) + real zm,zq,zsigm,zsigp,zqm,zqp + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-13/ +#endif + + do l=1,llm + do ij=1,ip1jmp1 + zdq=qb(ij,l)-qh(ij,l) +c if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qh(ij,l),q(ij,l),qb(ij,l) +c qh(ij,l)=q(ij,l) +c qb(ij,l)=q(ij,l) +c endif + + if(abs(zdq).gt.prec) then + zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq + zsigh(ij,l)=1.-zsigb(ij,l) + zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.) + else + zsigb(ij,l)=0.5 + zsigh(ij,l)=0.5 + endif + enddo + enddo + +c print*,'ok1' +c calcul de la pente maximum dans la maille en valeur absolue + do l=2,llm + do ij=1,ip1jmp1 + if (w_m(ij,l).ge.0.) then + zsigp=zsigb(ij,l) + zsigm=zsigh(ij,l) + zqp=qb(ij,l) + zqm=qh(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigb(ij,l-1) + zsigp=zsigh(ij,l-1) + zqm=qb(ij,l-1) + zqp=qh(ij,l-1) + zm=masse(ij,l-1) + zq=q(ij,l-1) + endif + zsig=abs(w_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do ij=1,ip1jmp1 + w_mq(ij,llm+1)=0. + w_mq(ij,1)=0. + enddo + + do l=1,llm + do ij=1,ip1jmp1 + new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo + enddo +c print*,'ok3' + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advtrac_p.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advtrac_p.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advtrac_p.F90 (revision 1634) @@ -0,0 +1,497 @@ +! $Id$ + +SUBROUTINE advtrac_p(pbaru,pbarv , p, masse,q,iapptrac,teta, flxw, pk) + + ! Auteur : F. Hourdin + ! + ! Modif. P. Le Van (20/12/97) + ! F. Codron (10/99) + ! D. Le Croller (07/2001) + ! M.A Filiberti (04/2002) + ! + USE parallel + USE Write_Field_p + USE Bands + USE mod_hallo + USE Vampir + USE times + USE infotrac + USE control_mod + IMPLICIT NONE + ! + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comvert.h" + include "comdissip.h" + include "comgeom2.h" + include "logic.h" + include "temps.h" + include "ener.h" + include "description.h" + + !------------------------------------------------------------------- + ! Arguments + !------------------------------------------------------------------- + ! Ajout PPM + !-------------------------------------------------------- + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm) + !-------------------------------------------------------- + INTEGER iapptrac + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm) + REAL pk(ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) + + !------------------------------------------------------------- + ! Variables locales + !------------------------------------------------------------- + + REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),zdp(ip1jmp1) + REAL,SAVE::pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) + REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu + INTEGER iadvtr + INTEGER ij,l,iq,iiq + REAL zdpmin, zdpmax + SAVE iadvtr, massem, pbaruc, pbarvc + DATA iadvtr/0/ + !$OMP THREADPRIVATE(iadvtr) + !---------------------------------------------------------- + ! Rajouts pour PPM + !---------------------------------------------------------- + INTEGER indice,n + REAL dtbon ! Pas de temps adaptatif pour que CFL<1 + REAL CFLmaxz,aaa,bbb ! CFL maximum + REAL psppm(iim,jjp1) ! pression au sol + REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm) + REAL qppm(iim*jjp1,llm,nqtot) + REAL fluxwppm(iim,jjp1,llm) + REAL apppm(llmp1), bpppm(llmp1) + LOGICAL dum,fill + DATA fill/.true./ + DATA dum/.true./ + REAL,SAVE :: finmasse(ip1jmp1,llm) + integer ijb,ije,ijb_u,ijb_v,ije_u,ije_v,j + type(Request) :: Request_vanleer + REAL,SAVE :: p_tmp( ip1jmp1,llmp1 ) + REAL,SAVE :: teta_tmp(ip1jmp1,llm) + REAL,SAVE :: pk_tmp(ip1jmp1,llm) + + ijb_u=ij_begin + ije_u=ij_end + + ijb_v=ij_begin-iip1 + ije_v=ij_end + if (pole_nord) ijb_v=ij_begin + if (pole_sud) ije_v=ij_end-iip1 + + IF(iadvtr.EQ.0) THEN + ! CALL initial0(ijp1llm,pbaruc) + ! CALL initial0(ijmllm,pbarvc) + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + pbaruc(ijb_u:ije_u,l)=0. + pbarvc(ijb_v:ije_v,l)=0. + ENDDO + !$OMP END DO NOWAIT + ENDIF + + ! accumulation des flux de masse horizontaux + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij = ijb_u,ije_u + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + ENDDO + DO ij = ijb_v,ije_v + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO + !$OMP END DO NOWAIT + + ! selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + + ! CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) + ijb=ij_begin + ije=ij_end + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + massem(ijb:ije,l)=masse(ijb:ije,l) + ENDDO + !$OMP END DO NOWAIT + + !cc CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 ) + ! + ENDIF ! of IF(iadvtr.EQ.0) + + iadvtr = iadvtr+1 + + !$OMP MASTER + iapptrac = iadvtr + !$OMP END MASTER + + ! Test pour savoir si on advecte a ce pas de temps + + IF ( iadvtr.EQ.iapp_tracvl ) THEN + !$OMP MASTER + call suspend_timer(timer_caldyn) + !$OMP END MASTER + + ijb=ij_begin + ije=ij_end + + + !c .. Modif P.Le Van ( 20/12/97 ) .... + !c + + ! traitement des flux de masse avant advection. + ! 1. calcul de w + ! 2. groupement des mailles pres du pole. + + CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + + !$OMP BARRIER + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llmp1 + p_tmp(ijb:ije,l)=p(ijb:ije,l) + ENDDO + !$OMP END DO NOWAIT + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + pk_tmp(ijb:ije,l)=pk(ijb:ije,l) + teta_tmp(ijb:ije,l)=teta(ijb:ije,l) + ENDDO + !$OMP END DO NOWAIT + + !$OMP MASTER + call VTb(VTHallo) + !$OMP END MASTER + + call Register_SwapFieldHallo(pbarug,pbarug,ip1jmp1,llm, & + jj_Nb_vanleer,0,0,Request_vanleer) + call Register_SwapFieldHallo(pbarvg,pbarvg,ip1jm,llm, & + jj_Nb_vanleer,1,0,Request_vanleer) + call Register_SwapFieldHallo(massem,massem,ip1jmp1,llm, & + jj_Nb_vanleer,0,0,Request_vanleer) + call Register_SwapFieldHallo(wg,wg,ip1jmp1,llm, & + jj_Nb_vanleer,0,0,Request_vanleer) + call Register_SwapFieldHallo(teta_tmp,teta_tmp,ip1jmp1,llm, & + jj_Nb_vanleer,1,1,Request_vanleer) + call Register_SwapFieldHallo(p_tmp,p_tmp,ip1jmp1,llmp1, & + jj_Nb_vanleer,1,1,Request_vanleer) + call Register_SwapFieldHallo(pk_tmp,pk_tmp,ip1jmp1,llm, & + jj_Nb_vanleer,1,1,Request_vanleer) + do j=1,nqtot + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, & + jj_nb_vanleer,0,0,Request_vanleer) + enddo + + call SendRequest(Request_vanleer) + !$OMP BARRIER + call WaitRequest(Request_vanleer) + + + !$OMP BARRIER + !$OMP MASTER + call SetDistrib(jj_nb_vanleer) + call VTe(VTHallo) + call VTb(VTadvection) + call start_timer(timer_vanleer) + !$OMP END MASTER + !$OMP BARRIER + + ! ... Flux de masse diaganostiques traceurs + ijb=ij_begin + ije=ij_end + flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/REAL(iapp_tracvl) + + ! test sur l'eventuelle creation de valeurs negatives de la masse + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm-1 + DO ij = ijb+1,ije + zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) & + - pbarvg(ij-iip1,l) + pbarvg(ij,l) & + + wg(ij,l+1) - wg(ij,l) + ENDDO + + ! CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) + ! ym ---> pourquoi jjm-1 et non jjm ? a cause du pole ? + + do ij=ijb,ije-iip1+1,iip1 + zdp(ij)=zdp(ij+iip1-1) + enddo + + DO ij = ijb,ije + zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) + ENDDO + + + ! CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) + ! ym ---> eventuellement a revoir + CALL minmax ( ije-ijb+1, zdp(ijb), zdpmin,zdpmax ) + + IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN + PRINT*,'WARNING DP/P l=',l,' MIN:',zdpmin, & + ' MAX:', zdpmax + ENDIF + + ENDDO + !$OMP END DO NOWAIT + + !------------------------------------------------------------------- + ! Advection proprement dite (Modification Le Croller (07/2001) + !------------------------------------------------------------------- + + !---------------------------------------------------- + ! Calcul des moyennes basées sur la masse + !---------------------------------------------------- + + !ym ----> Normalement, inutile pour les schémas classiques + !ym ----> Revérifier lors de la parallélisation des autres schemas + + !ym call massbar_p(massem,massebx,masseby) + + call vlspltgen_p( q,iadv, 2., massem, wg , & + pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp ) + + + GOTO 1234 + !----------------------------------------------------------- + ! Appel des sous programmes d'advection + !----------------------------------------------------------- + do iq=1,nqtot + ! call clock(t_initial) + if(iadv(iq) == 0) cycle + ! ---------------------------------------------------------------- + ! Schema de Van Leer I MUSCL + ! ---------------------------------------------------------------- + if(iadv(iq).eq.10) THEN + + call vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) + + ! ---------------------------------------------------------------- + ! Schema "pseudo amont" + test sur humidite specifique + ! pour la vapeur d'eau. F. Codron + ! ---------------------------------------------------------------- + else if(iadv(iq).eq.14) then + ! + !ym stop 'advtrac : appel à vlspltqs :schema non parallelise' + CALL vlspltqs_p( q(1,1,1), 2., massem, wg , & + pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp ) + ! ---------------------------------------------------------------- + ! Schema de Frederic Hourdin + ! ---------------------------------------------------------------- + else if(iadv(iq).eq.12) then + stop 'advtrac : schema non parallelise' + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) + end do + else if(iadv(iq).eq.13) then + stop 'advtrac : schema non parallelise' + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) + end do + ! ---------------------------------------------------------------- + ! Schema de pente SLOPES + ! ---------------------------------------------------------------- + else if (iadv(iq).eq.20) then + stop 'advtrac : schema non parallelise' + + call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) + + ! ---------------------------------------------------------------- + ! Schema de Prather + ! ---------------------------------------------------------------- + else if (iadv(iq).eq.30) then + stop 'advtrac : schema non parallelise' + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + call prather(q(1,1,iq),wg,massem,pbarug,pbarvg, & + n,dtbon) + ! ---------------------------------------------------------------- + ! Schemas PPM Lin et Rood + ! ---------------------------------------------------------------- + else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. & + iadv(iq).LE.18)) then + + stop 'advtrac : schema non parallelise' + + ! Test sur le flux horizontal + ! Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', & + dtvr,'n=',n + endif + ! Test sur le flux vertical + CFLmaxz=0. + do l=2,llm + do ij=iip2,ip1jm + aaa=wg(ij,l)*dtvr/massem(ij,l) + CFLmaxz=max(CFLmaxz,aaa) + bbb=-wg(ij,l)*dtvr/massem(ij,l-1) + CFLmaxz=max(CFLmaxz,bbb) + enddo + enddo + if (CFLmaxz.GE.1) then + write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz + endif + + !----------------------------------------------------------- + ! Ss-prg interface LMDZ.4->PPM3d + !----------------------------------------------------------- + + call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, & + apppm,bpppm,massebx,masseby,pbarug,pbarvg, & + unatppm,vnatppm,psppm) + + do indice=1,n + !---------------------------------------------------------------- + ! VL (version PPM) horiz. et PPM vert. + !---------------------------------------------------------------- + if (iadv(iq).eq.11) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + + !------------------------------------------------------------- + ! Monotonic PPM + !------------------------------------------------------------- + else if (iadv(iq).eq.16) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + !------------------------------------------------------------- + + !------------------------------------------------------------- + ! Semi Monotonic PPM + !------------------------------------------------------------- + else if (iadv(iq).eq.17) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + !------------------------------------------------------------- + + !------------------------------------------------------------- + ! Positive Definite PPM + !------------------------------------------------------------- + else if (iadv(iq).eq.18) then + ! Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), & + psppm,psppm, & + unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, & + iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, & + fill,dum,220.) + !------------------------------------------------------------- + endif + enddo + !----------------------------------------------------------------- + ! Ss-prg interface PPM3d-LMDZ.4 + !----------------------------------------------------------------- + call interpost(q(1,1,iq),qppm(1,1,iq)) + endif + !---------------------------------------------------------------------- + + !----------------------------------------------------------------- + ! On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1 + ! et Nord j=1 + !----------------------------------------------------------------- + + ! call traceurpole(q(1,1,iq),massem) + + ! calcul du temps cpu pour un schema donne + + ! call clock(t_final) + !ym tps_cpu=t_final-t_initial + !ym cpuadv(iq)=cpuadv(iq)+tps_cpu + + end DO + +1234 CONTINUE + !$OMP BARRIER + + if (planet_type=="earth") then + + ijb=ij_begin + ije=ij_end + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO + !$OMP END DO + + CALL qminimum_p( q, 2, finmasse ) + + !------------------------------------------------------------------ + ! on reinitialise a zero les flux de masse cumules + !--------------------------------------------------- + ! iadvtr=0 + + !$OMP MASTER + call VTe(VTadvection) + call stop_timer(timer_vanleer) + call VTb(VThallo) + !$OMP END MASTER + + do j=1,nqtot + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, & + jj_nb_caldyn,0,0,Request_vanleer) + enddo + + call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm, & + jj_nb_caldyn,0,0,Request_vanleer) + + call SendRequest(Request_vanleer) + !$OMP BARRIER + call WaitRequest(Request_vanleer) + + !$OMP BARRIER + !$OMP MASTER + call SetDistrib(jj_nb_caldyn) + call VTe(VThallo) + call resume_timer(timer_caldyn) + !$OMP END MASTER + !$OMP BARRIER + iadvtr=0 + endif ! of if (planet_type=="earth") + ENDIF ! if iadvtr.EQ.iapp_tracvl + +END SUBROUTINE advtrac_p Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advx.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advx.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advx.F (revision 1634) @@ -0,0 +1,497 @@ +! +! $Header$ +! + SUBROUTINE advx(limit,dtx,pbaru,sm,s0, + $ sx,sy,sz,lati,latf) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in X direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz C +C sont des arguments d'entree pour le s-pg... C +C C +C sm,s0,sx,sy,sz C +C sont les arguments de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C Arguments : +C ----------- +C dtx : frequence fictive d'appel du transport +C pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + +C ATTENTION partout ou on trouve ntra, insertion de boucle +C possible dans l'avenir. + + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + $ ,sy(iip1,jjp1,llm,ntra) + REAL sz(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C Ti are the moments for the current latitude and level +C + REAL TM(iim) + REAL T0(iim,ntra),TX(iim,ntra) + REAL TY(iim,ntra),TZ(iim,ntra) + REAL TEMPTM ! just a temporary variable +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM(iim) + REAL F0(iim,ntra),FX(iim,ntra) + REAL FY(iim,ntra),FZ(iim,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) +C + REAL SMNEW(iim),UEXT(iim) +C + REAL sqi,sqf + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,itrac + + lon = iim + niv = llm + +C *** Test de passage d'arguments ****** + + +C ------------------------------------- + DO 300 j = 1,jjp1 + NUM(j) = 1 + 300 CONTINUE + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------' + PRINT*,'sqi=',sqi + + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjm+1 + DO 500 i = 1,iip1 +C ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g ) + ugri (i,j,llm+1-l) = pbaru (i,j,l) + 500 CONTINUE + + +C --------------------------------------------------------- +C --------------------------------------------------------- +C --------------------------------------------------------- + +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0(I,JV)=0. + TX(I,JV)=0. + TY(I,JV)=0. + TZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + 113 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I) + $ *S0(I3,K,L,JV) + T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TX(I,JV)=ALF(I) *sx(I3,K,L,JV)+ + $ ALF1(I)*TX(I,JV) +3.*TEMPTM + TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV) + ENDDO + ENDDO +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0(I,JV)=S0(I,K,L,JV) + TX(I,JV)=sx(I,K,L,JV) + TY(I,JV)=sy(I,K,L,JV) + TZ(I,JV)=sz(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV)) + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) ) + FX(I,JV)=ALFQ(I)*TX(I+1,JV) + FY(I,JV)=ALF (I)*TY(I+1,JV) + FZ(I,JV)=ALF (I)*TZ(I+1,JV) +C + T0(I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV) + TY(I+1,JV)=TY(I+1,JV)-FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) ) + FX (I,JV)=ALFQ(I)*TX(1,JV) + FY (I,JV)=ALF (I)*TY(1,JV) + FZ (I,JV)=ALF (I)*TZ(1,JV) +C + T0(1,JV)=T0(1,JV)-F0(I,JV) + TX(1,JV)=ALF1Q(I)*TX(1,JV) + TY(1,JV)=TY(1,JV)-FY(I,JV) + TZ(1,JV)=TZ(1,JV)-FZ(I,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) ) + FX(I,JV)=ALFQ(I)*TX(I,JV) + FY(I,JV)=ALF (I)*TY(I,JV) + FZ(I,JV)=ALF (I)*TZ(I,JV) +C + T0(I,JV)=T0(I,JV)-F0(I,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-FY(I,JV) + TZ(I,JV)=TZ(I,JV)-FZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0(I,JV)=T0(I,JV)+F0(I,JV) + TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TY(I,JV)=TY(I,JV)+FY(I,JV) + TZ(I,JV)=TZ(I,JV)+FZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0(I+1,JV)=T0(I+1,JV)+F0(I,JV) + TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM + TY(I+1,JV)=TY(I+1,JV)+FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0(1,JV)=T0(1,JV)+F0(I,JV) + TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TY(1,JV)=TY(1,JV)+FY(I,JV) + TZ(1,JV)=TZ(1,JV)+FZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 180 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 180 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK +C + I3=I2+(I-1)*NUMK + S0(I3,K,L,JV)=ALF (I) + $ * (T0(I,JV)-ALF1(I)*TX(I,JV)) + sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV) + sy(I3,K,L,JV)=ALF (I)*TY(I,JV) + sz(I3,K,L,JV)=ALF (I)*TZ(I,JV) +C +C reajusts moments remaining in the box +C + T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV) + ENDDO + ENDDO +C +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0(I,K,L,JV)=T0(I,JV) + sx(I,K,L,JV)=TX(I,JV) + sy(I,K,L,JV)=TY(I,JV) + sz(I,K,L,JV)=TZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* +c OK +c DO 9998 l = 1, llm +c DO 9998 j = 1, jjp1 +c DO 9998 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVX' +c PRINT*,'SM(',i,j,l,')=',SM(i,j,l) +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1' +cc STOP +c ENDIF +c 9998 CONTINUE +c +C ---------- bouclage cyclique + DO itrac=1,ntra + DO l = 1,llm + DO j = lati,latf + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,itrac) = S0(1,j,l,itrac) + sx(iip1,j,l,itrac) = sx(1,j,l,itrac) + sy(iip1,j,l,itrac) = sy(1,j,l,itrac) + sz(iip1,j,l,itrac) = sz(1,j,l,itrac) + END DO + END DO + ENDDO + +c ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO +c + PRINT*,'------ DIAG DANS ADVX - SORTIE -----' + PRINT*,'sqf=',sqf +c------------- + + RETURN + END +C_________________________________________________________________ +C_________________________________________________________________ Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advxp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advxp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advxp.F (revision 1634) @@ -0,0 +1,650 @@ +! +! $Header$ +! + SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in X direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + + INTEGER ntra +c PARAMETER (ntra = 1) +C +C definition de la grille du modele +C + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) +C +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C Sij 2nd order moment in i and j directions +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + REAL SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C +C Tij are the moments for the current latitude and level +C + REAL TM (iim) + REAL T0 (iim,NTRA),TX (iim,NTRA) + REAL TY (iim,NTRA),TZ (iim,NTRA) + REAL TXX(iim,NTRA),TXY(iim,NTRA) + REAL TXZ(iim,NTRA),TYY(iim,NTRA) + REAL TYZ(iim,NTRA),TZZ(iim,NTRA) +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM (iim) + REAL F0 (iim,NTRA),FX (iim,NTRA) + REAL FY (iim,NTRA),FZ (iim,NTRA) + REAL FXX(iim,NTRA),FXY(iim,NTRA) + REAL FXZ(iim,NTRA),FYY(iim,NTRA) + REAL FYZ(iim,NTRA),FZZ(iim,NTRA) +C +C work arrays +C + REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim),ALF4(iim) +C + REAL SMNEW(iim),UEXT(iim) + REAL sqi,sqf + REAL TEMPTM + REAL SLPMAX + REAL S1MAX,S1NEW,S2NEW + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,iter + + lon = iim + lati=2 + latf = jjm + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP' +cc STOP +c ENDIF +c 399 CONTINUE + +C *** Test : diagnostique de la qtite totale de traceur +C dans l'atmosphere avant l'advection +c + sqi =0. + sqf =0. +c + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----' + PRINT*,'sqi=',sqi +c test +c ------------------------------------- + DO 300 j =1,jjp1 + NUM(j) =1 + 300 CONTINUE +c DO l=1,llm +c NUM(2,l)=6 +c NUM(3,l)=6 +c NUM(jjm-1,l)=6 +c NUM(jjm,l)=6 +c ENDDO +c DO j=2,6 +c NUM(j)=12 +c ENDDO +c DO j=jjm-5,jjm-1 +c NUM(j)=12 +c ENDDO + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + ugri (i,j,llm+1-l) =pbaru (i,j,l) + 500 CONTINUE + +C --------------------------------------------------------- +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf + +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0 (I,JV)=0. + TX (I,JV)=0. + TY (I,JV)=0. + TZ (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + TYY(I,JV)=0. + TYZ(I,JV)=0. + TZZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 113 CONTINUE +C + DO 114 JV=1,NTRA + DO 1140 I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV) + T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV) + 1140 CONTINUE + 114 CONTINUE +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0 (I,JV)=S0 (I,K,L,JV) + TX (I,JV)=SSX (I,K,L,JV) + TY (I,JV)=SY (I,K,L,JV) + TZ (I,JV)=SZ (I,K,L,JV) + TXX(I,JV)=SSXX(I,K,L,JV) + TXY(I,JV)=SSXY(I,K,L,JV) + TXZ(I,JV)=SSXZ(I,K,L,JV) + TYY(I,JV)=SYY(I,K,L,JV) + TYZ(I,JV)=SYZ(I,K,L,JV) + TZZ(I,JV)=SZZ(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + IF(T0(I,JV).GT.0.) THEN + SLPMAX=T0(I,JV) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) ) + TX (I,JV)=S1NEW + TXX(I,JV)=S2NEW + TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV))) + TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV))) + ELSE + TX (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + ENDIF + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* + + ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV)) + FXX(I,JV)=ALF3(I)*TXX(I+1,JV) + FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV)) + FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I+1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV) + FYY(I,JV)=ALF (I)*TYY(I+1,JV) + FYZ(I,JV)=ALF (I)*TYZ(I+1,JV) + FZZ(I,JV)=ALF (I)*TZZ(I+1,JV) +C + T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV)) + TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV) + TY (I+1,JV)=TY (I+1,JV)-FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV) + TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV) + TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* + + ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV)) + FXX(I,JV)=ALF3(I)*TXX(1,JV) + FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV)) + FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(1,JV) + FYY(I,JV)=ALF (I)*TYY(1,JV) + FYZ(I,JV)=ALF (I)*TYZ(1,JV) + FZZ(I,JV)=ALF (I)*TZZ(1,JV) +C + T0 (1,JV)=T0(1,JV)-F0(I,JV) + TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV)) + TXX(1,JV)=ALF4(I)*TXX(1,JV) + TY (1,JV)=TY (1,JV)-FY (I,JV) + TZ (1,JV)=TZ (1,JV)-FZ (I,JV) + TYY(1,JV)=TYY(1,JV)-FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV) + TXY(1,JV)=ALF1Q(I)*TXY(1,JV) + TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* + + ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV)) + FXX(I,JV)=ALF3(I)*TXX(I,JV) + FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV)) + FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I,JV) + FYY(I,JV)=ALF (I)*TYY(I,JV) + FYZ(I,JV)=ALF (I)*TYZ(I,JV) + FZZ(I,JV)=ALF (I)*TZZ(I,JV) +C + T0 (I,JV)=T0(I,JV)-F0(I,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4(I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-FY (I,JV) + TZ (I,JV)=TZ (I,JV)-FZ (I,JV) + TYY(I,JV)=TYY(I,JV)-FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0 (I,JV)=T0(I,JV)+F0(I,JV) + TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+FY (I,JV) + TZ (I,JV)=TZ (I,JV)+FZ (I,JV) + TYY(I,JV)=TYY(I,JV)+FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV) + TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) + + +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (I+1,JV)=ALF(I)*FX (I ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM + TXY(I+1,JV)=ALF(I)*FXY(I ,JV)+ALF1(I)*TXY(I+1,JV) + + +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I ,JV)) + TXZ(I+1,JV)=ALF(I)*FXZ(I ,JV)+ALF1(I)*TXZ(I+1,JV) + + +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I ,JV)) + TY (I+1,JV)=TY (I+1,JV)+FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0 (1,JV)=T0(1,JV)+F0(I,JV) + TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) + + +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) + + +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV)) + TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) + + +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV)) + TY (1,JV)=TY (1,JV)+FY (I,JV) + TZ (1,JV)=TZ (1,JV)+FZ (I,JV) + TYY(1,JV)=TYY(1,JV)+FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 18 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) +C + 180 CONTINUE +C + DO 181 JV=1,NTRA + DO 181 I=1,LONK +C + I3=I2+(I-1)*NUMK + S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* + + ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) ) + SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV)) + SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV) + SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV)) + SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV)) + SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV) + SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV) + SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV) + SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV) + SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV) +C +C reajusts moments remaining in the box +C + T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4 (I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + 181 CONTINUE +C + 18 CONTINUE +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0 (I,K,L,JV)=T0 (I,JV) + SSX (I,K,L,JV)=TX (I,JV) + SY (I,K,L,JV)=TY (I,JV) + SZ (I,K,L,JV)=TZ (I,JV) + SSXX(I,K,L,JV)=TXX(I,JV) + SSXY(I,K,L,JV)=TXY(I,JV) + SSXZ(I,K,L,JV)=TXZ(I,JV) + SYY(I,K,L,JV)=TYY(I,JV) + SYZ(I,K,L,JV)=TYZ(I,JV) + SZZ(I,K,L,JV)=TZZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVXP' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP' +c STOP +c ENDIF +c 9999 CONTINUE +c ---------- bouclage cyclique + + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + END DO + END DO + +C ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + + PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----' + PRINT*,'sqf=',sqf +c------------------------------------------------------------- + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advy.F (revision 1634) @@ -0,0 +1,422 @@ +! +! $Header$ +! + SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (SOM) advection of tracer in Y direction C +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 15/12/94 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL s1v(llm),slatv(llm) + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + real smpn,smps,s0pn,s0ps + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv=llm + +C +C the moments Fi are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C + + DO l = 1,llm + DO j = 1,jjm + DO i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l) + enddo + enddo + do i=1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + enddo + enddo + + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sy(I,K,L,JV))),sy(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) +C + 21 CONTINUE +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* + + ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV) + sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV) + sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALF1(I,0)=1.-ALF(I,0) +C + 25 CONTINUE +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 300 CONTINUE + 30 CONTINUE +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV) + FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV) + FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV) +C + S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV) + sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV) +C + ELSE +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV) + FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV) + FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) + + +3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) + + +3.*TEMPTM + sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 41 CONTINUE +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV) + sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 45 CONTINUE +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +C + 1 CONTINUE +C + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advyp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advyp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advyp.F (revision 1634) @@ -0,0 +1,653 @@ +! +! $Header$ +! + SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Y direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/10/95 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra +C PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra) + REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra) + REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1) + REAL ALF4(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C initialisations + + sbms = 0. + sfms = 0. + sfzs = 0. + sbmn = 0. + sfmn = 0. + sfzn = 0. + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg +C-AA 20/10/94 le signe -1 est necessaire car indexation opposee + + DO 500 l = 1,llm + DO 500 j = 1,jjm + DO 500 i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l) + 500 CONTINUE + +CAA Initialisation de flux fictifs aux bords sup. des boites pol. + + DO l = 1,llm + DO i = 1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + ENDDO + ENDDO +c +c----------------- START HERE ----------------------- +C boucle sur les niveaux +C + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=AMAX1(S0(I,K,L,JV),0.) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) ) + SY (I,K,L,JV)=S1NEW + SYY(I,K,L,JV)=S2NEW + SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SY (I,K,L,JV)=0. + SYY(I,K,L,JV)=0. + SSXY(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF(I,0)*ALFQ(I,0) + ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0) +C + 21 CONTINUE +c print*,'ADVYP 21' +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* + + ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + SY (I,1,L,JV)=ALF1Q(I,0)* + + (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV)) + SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV) + SSX (I,1,L,JV)=ALF1 (I,0)* + + (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) ) + SZ (I,1,L,JV)=ALF1 (I,0)* + + (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) ) + SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV) + SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV) + SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV) + SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C +c print*,'av ADVYP 25' + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF1(I,0)*ALF(I,0) +C + 25 CONTINUE +c print*,'av ADVYP 25' +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) + + +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM ) + SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM + SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV) +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C +c print*,'av ADVYP 30' + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 300 CONTINUE + 30 CONTINUE +c print*,'ap ADVYP 30' +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* + + ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV) + FX (I,K,JV)=ALF (I,K)* + + (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV)) + FZ (I,K,JV)=ALF (I,K)* + + (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV) +C + S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + SY (I,KP,L,JV)=ALF1Q(I,K)* + + (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV)) + SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV) + SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV) + SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV) +C + ELSE +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV) + FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV)) + FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +c print*,'ap ADVYP 31' +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +c print*,'ap ADVYP 32' +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) + + +3.*TEMPTM + SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) + + +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) + + +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) + + +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM ) + SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) + + +3.*TEMPTM + SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) + + +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV)) + SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) + + +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV)) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +c print*,'ap ADVYP 33' +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 41 CONTINUE +c print*,'ap ADVYP 41' +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV)) + SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV)) + SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV) + SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +c print*,'ap ADVYP 42' +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +c print*,'ap ADVYP 43' +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 45 CONTINUE +c print*,'ap ADVYP 45' +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM + SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV) +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +c print*,'ap ADVYP 46' +C + 1 CONTINUE + +c-------------------------------------------------- +C bouclage cyclique horizontal . + + DO l = 1,llm + DO jv = 1,ntra + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,jv) = S0(1,j,l,jv) + SSX(iip1,j,l,jv) = SSX(1,j,l,jv) + SY(iip1,j,l,jv) = SY(1,j,l,jv) + SZ(iip1,j,l,jv) = SZ(1,j,l,jv) + END DO + END DO + END DO + +c ------------------------------------------------------------------- +C *** Test negativite: + +c DO jv = 1,ntra +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iip1 +c IF (s0( i,j,l,jv ).lt.0.) THEN +c PRINT*, '------ S0 < 0 en FIN ADVYP ---' +c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv) +cc STOP +c ENDIF +c ENDDO +c ENDDO +c ENDDO +c ENDDO + + +c ------------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - SORTIE --------' + PRINT*,'sqf=',sqf +c print*,'ap ADVYP fin' + +c----------------------------------------------------------------- +C + RETURN + END + + + + + + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advz.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advz.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advz.F (revision 1634) @@ -0,0 +1,320 @@ +! +! $Header$ +! + SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in Z direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C C +C sont des arguments d'entree pour le s-pg... C +C C +C dq est l'argument de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C #include "traceur.h" + +C Arguments : +C ----------- +C dtz : frequence fictive d'appel du transport +C w : flux de masse en z en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dtz + REAL w ( iip1,jjp1,llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL WGRI(iip1,jjp1,0:llm) + +C +C the moments F are used as temporary storage for +C portions of grid boxes in transit at the current latitude +C + REAL FM(iim,llm) + REAL F0(iim,llm,ntra),FX(iim,llm,ntra) + REAL FY(iim,llm,ntra),FZ(iim,llm,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL TEMPTM ! Just temporal variable + REAL sqi,sqf +C + LOGICAL LIMIT + INTEGER lon,lat,niv + INTEGER i,j,jv,k,l,lp + + lon = iim + lat = jjp1 + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ' +c STOP +c ENDIF + 399 CONTINUE + +C----------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------' + PRINT*,'sqi=',sqi + +C----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion du flux de masse en kg.s-1 + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 +c wgri (i,j,llm+1-l) = w (i,j,l) / g + wgri (i,j,llm+1-l) = w (i,j,l) +c wgri (i,j,0) = 0. ! a detruire ult. +c wgri (i,j,l) = 0.1 ! w (i,j,l) +c wgri (i,j,llm) = 0. ! a detruire ult. + 500 CONTINUE + DO j = 1,jjp1 + DO i = 1,iip1 + wgri(i,j,0)=0. + enddo + enddo + +C----------------------------------------------------------------- + +C start here +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sz(I,K,L,JV))),sz(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV) +C + S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV) + sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV) + sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV) +C + ELSE +C + F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,L,JV) + FY(I,L,JV)=ALF (I)*sy(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV) + sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV) + + +3.*TEMPTM + sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C +C------------------------------------------------------------- +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVZ' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra) +c print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra) +c print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1' +c STOP +c ENDIF + 9999 CONTINUE + +C *** ------------------- bouclage cyclique en X ------------ + +c DO l = 1,llm +c DO j = 1,jjp1 +c SM(iip1,j,l) = SM(1,j,l) +c S0(iip1,j,l,ntra) = S0(1,j,l,ntra) +C sx(iip1,j,l,ntra) = sx(1,j,l,ntra) +c sy(iip1,j,l,ntra) = sy(1,j,l,ntra) +c sz(iip1,j,l,ntra) = sz(1,j,l,ntra) +c ENDDO +c ENDDO + +C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + +C------------------------------------------------------------- + RETURN + END +C_______________________________________________________________ +C_______________________________________________________________ Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advzp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advzp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/advzp.F (revision 1634) @@ -0,0 +1,378 @@ +! +! $Header$ +! + SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Z direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/11/95 LAST C +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C + +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +C +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 +c + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l,lp + INTEGER ntra +c PARAMETER (ntra = 1) +c + REAL dtz + REAL w ( iip1,jjp1,llm ) +c +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- +C +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : +C + REAL WGRI(iip1,jjp1,0:llm) + +C Rem : UGRI et VGRI ne sont pas utilises dans +C cette subroutine ( advection en z uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C attention a celui de WGRI +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,llm,ntra),FM(iim,llm) + REAL FX(iim,llm,ntra),FY(iim,llm,ntra) + REAL FZ(iim,llm,ntra) + REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra) + REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra) + REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim),ALF1(iim) + REAL ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim) + REAL ALF4(iim) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. +c + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + wgri (i,j,llm+1-l) = w (i,j,l) + 500 CONTINUE + do j=1,jjp1 + do i=1,iip1 + wgri(i,j,0)=0. + enddo + enddo +c +cAA rem : Je ne suis pas sur du signe +cAA Je ne suis pas sur pour le 0:llm +c +c----------------------------------------------------------------- +C---------------------- START HERE ------------------------------- +C +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=S0(I,K,L,JV) + S1MAX =1.5*SLPMAX + S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV))) + S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) ) + SZ (I,K,L,JV)=S1NEW + SZZ(I,K,L,JV)=S2NEW + SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SZ (I,K,L,JV)=0. + SZZ(I,K,L,JV)=0. + SSXZ(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2 (I)=ALF1(I)-ALF(I) + ALF3 (I)=ALF(I)*ALFQ(I) + ALF4 (I)=ALF1(I)*ALF1Q(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* + + ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV) +C + S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV) + SZ (I,K,LP,JV)=ALF1Q(I) + + *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV)) + SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV) + SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV) + SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV) +C + ELSE +C + F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) + + +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV) + SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV)) + SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF(I)*ALF1(I) + ALF3(I)=ALF1(I)-ALF(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) + + +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM ) + SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) + + +3.*TEMPTM + SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) + + +3.*(ALF1(I)*FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) + + +3.*(ALF1(I)*FY (I,L,JV)-ALF (I)*SY (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) + + +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM ) + SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) + + +3.*TEMPTM + SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) + + +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV)) + SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) + + +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV)) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + ENDDO + ENDDO +c C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de tarceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bands.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bands.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bands.F90 (revision 1634) @@ -0,0 +1,439 @@ +! +! $Id$ +! + module Bands + + integer, parameter :: bands_caldyn=1 + integer, parameter :: bands_vanleer=2 + integer, parameter :: bands_dissip=3 + + INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2 + INTEGER,dimension(:),allocatable :: jj_Nb_dissip + INTEGER,dimension(:),allocatable :: jj_Nb_physic + INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis + INTEGER,dimension(:),allocatable :: distrib_phys + + contains + + subroutine AllocateBands + use parallel + implicit none + + allocate(jj_Nb_Caldyn(0:MPI_Size-1)) + allocate(jj_Nb_vanleer(0:MPI_Size-1)) + allocate(jj_Nb_vanleer2(0:MPI_Size-1)) + allocate(jj_Nb_dissip(0:MPI_Size-1)) + allocate(jj_Nb_physic(0:MPI_Size-1)) + allocate(jj_Nb_physic_bis(0:MPI_Size-1)) + allocate(distrib_phys(0:MPI_Size-1)) + + end subroutine AllocateBands + + subroutine Read_distrib + use parallel + implicit none + + include "dimensions.h" + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + call AllocateBands + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_caldyn(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_vanleer(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,distrib_phys(i) + enddo + + CLOSE(unit_number) + + else + do i=0,mpi_size-1 + jj_nb_caldyn(i)=(jjm+1)/mpi_size + if (ivalue(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + if (jj_nb_caldyn(max_proc)>3) then + if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + else + if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) & + -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + end subroutine AdjustBands_caldyn + + subroutine AdjustBands_vanleer + use times + use parallel + implicit none + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_vanleer(max_proc)>3) then + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. & + timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + else + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + end subroutine AdjustBands_vanleer + + subroutine AdjustBands_dissip + use times + use parallel + implicit none + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_dissip(max_proc)>3) then + if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + else + if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) & + - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + end subroutine AdjustBands_dissip + + subroutine AdjustBands_physic + use times +#ifdef CPP_EARTH +! Ehouarn: what follows is only related to // physics; for now only for Earth + USE mod_phys_lmdz_para, only : klon_mpi_para_nb +#endif + USE parallel + implicit none + + integer :: i,Index + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: Inc + real :: medium + integer :: NbTot,sgn + + allocate(value(0:mpi_size-1)) + allocate(Inc(0:mpi_size-1)) + + + call allgather_timer_average + + medium=0 + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_physic(i),timer_physic,i) + medium=medium+value(i) + enddo + + medium=medium/mpi_size + NbTot=0 +#ifdef CPP_EARTH +! Ehouarn: what follows is only related to // physics; for now only for Earth + do i=0,mpi_size-1 + Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i)) + NbTot=NbTot+Inc(i) + enddo + + if (NbTot>=0) then + Sgn=1 + else + Sgn=-1 + NbTot=-NbTot + endif + + Index=0 + do i=1,NbTot + Inc(Index)=Inc(Index)-Sgn + Index=Index+1 + if (Index>mpi_size-1) Index=0 + enddo + + do i=0,mpi_size-1 + distrib_phys(i)=klon_mpi_para_nb(i)+inc(i) + enddo +#endif + end subroutine AdjustBands_physic + + subroutine WriteBands + USE parallel + implicit none + include "dimensions.h" + + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + +! write (unit_number,*) '*** Bandes caldyn ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_caldyn(i) + enddo + +! write (unit_number,*) '*** Bandes vanleer ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_vanleer(i) + enddo + +! write (unit_number,*) '*** Bandes dissip ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + write (unit_number,*) i,distrib_phys(i) + enddo + + CLOSE(unit_number) + else + print *,'probleme lors de l ecriture des bandes' + endif + + end subroutine WriteBands + + end module Bands + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bernoui.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bernoui.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bernoui.F (revision 1634) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay) +c +c Local: +c ------ +c + INTEGER ijl +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + DO 4 ijl = 1,ngrid*nlay + pbern( ijl ) = pphi( ijl ) + pecin( ijl ) + 4 CONTINUE +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bernoui_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bernoui_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bernoui_p.F (revision 1634) @@ -0,0 +1,74 @@ + SUBROUTINE bernoui_p (ngrid,nlay,pphi,pecin,pbern) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ngrid,nlay),pecin(ngrid,nlay),pbern(ngrid,nlay) +c +c Local: +c ------ +c + INTEGER ij,l,ijb,ije,jjb,jje +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + DO 4 ij = ijb,ije + pbern( ij,l ) = pphi( ij,l ) + pecin( ij,l ) + 4 CONTINUE + + ENDDO +c$OMP END DO NOWAIT +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + + + CALL filtreg_p( pbern,jjb,jje, jjp1, llm, 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bilan_dyn_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bilan_dyn_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/bilan_dyn_p.F (revision 1634) @@ -0,0 +1,716 @@ +! +! $Id$ +! + SUBROUTINE bilan_dyn_p (ntrac,dt_app,dt_cum, + s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + +c AFAIRE +c Prevoir en champ nq+1 le diagnostique de l'energie +c en faisant Qzon=Cv T + L * ... +c vQ..A=Cp T + L * ... + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE mod_hallo + use misc_mod + use write_field + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "temps.h" +#include "iniprint.h" + +c==================================================================== +c +c Sous-programme consacre à des diagnostics dynamiques de base +c +c +c De facon generale, les moyennes des scalaires Q sont ponderees par +c la masse. +c +c Les flux de masse sont eux simplement moyennes. +c +c==================================================================== + +c Arguments : +c =========== + + integer ntrac + real dt_app,dt_cum + real ps(iip1,jjp1) + real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) + real flux_u(iip1,jjp1,llm) + real flux_v(iip1,jjm,llm) + real teta(iip1,jjp1,llm) + real phi(iip1,jjp1,llm) + real ucov(iip1,jjp1,llm) + real vcov(iip1,jjm,llm) + real trac(iip1,jjp1,llm,ntrac) + +c Local : +c ======= + + integer icum,ncum + logical first + real zz,zqy,zfactv(jjm,llm) + + integer nQ + parameter (nQ=7) + + +cym character*6 nom(nQ) +cym character*6 unites(nQ) + character*6,save :: nom(nQ) + character*6,save :: unites(nQ) + + character*10 file + integer ifile + parameter (ifile=4) + + integer itemp,igeop,iecin,iang,iu,iovap,iun + integer i_sortie + + save first,icum,ncum + save itemp,igeop,iecin,iang,iu,iovap,iun + save i_sortie + + real time + integer itau + save time,itau + data time,itau/0.,0/ + + data first/.true./ + data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/ + data i_sortie/1/ + + real ww + +c variables dynamiques intermédiaires + REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm) + REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm) + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + REAL vorpot(iip1,jjm,llm) + REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm) + REAL bern(iip1,jjp1,llm) + +c champ contenant les scalaires advectés. + real Q(iip1,jjp1,llm,nQ) + +c champs cumulés + real ps_cum(iip1,jjp1) + real masse_cum(iip1,jjp1,llm) + real flux_u_cum(iip1,jjp1,llm) + real flux_v_cum(iip1,jjm,llm) + real Q_cum(iip1,jjp1,llm,nQ) + real flux_uQ_cum(iip1,jjp1,llm,nQ) + real flux_vQ_cum(iip1,jjm,llm,nQ) + real flux_wQ_cum(iip1,jjp1,llm,nQ) + real dQ(iip1,jjp1,llm,nQ) + + save ps_cum,masse_cum,flux_u_cum,flux_v_cum + save Q_cum,flux_uQ_cum,flux_vQ_cum + +c champs de tansport en moyenne zonale + integer ntr,itr + parameter (ntr=5) + +cym character*10 znom(ntr,nQ) +cym character*20 znoml(ntr,nQ) +cym character*10 zunites(ntr,nQ) + character*10,save :: znom(ntr,nQ) + character*20,save :: znoml(ntr,nQ) + character*10,save :: zunites(ntr,nQ) + + integer iave,itot,immc,itrs,istn + data iave,itot,immc,itrs,istn/1,2,3,4,5/ + character*3 ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm) + real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ) + real zmasse(jjm,llm),zamasse(jjm) + + real zv(jjm,llm),psi(jjm,llm+1) + + integer i,j,l,iQ + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + character*10 infile + + integer fileid + integer thoriid, zvertiid + save fileid + + integer ndex3d(jjm*llm) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer ii,jj + integer zan, dayref +C + real rlong(jjm),rlatg(jjm) + integer :: jjb,jje,jjn,ijb,ije + type(Request) :: Req + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(1) :: ddid + INTEGER,DIMENSION(1) :: dsg + INTEGER,DIMENSION(1) :: dsl + INTEGER,DIMENSION(1) :: dpf + INTEGER,DIMENSION(1) :: dpl + INTEGER,DIMENSION(1) :: dhs + INTEGER,DIMENSION(1) :: dhe + + INTEGER :: bilan_dyn_domain_id + + +c===================================================================== +c Initialisation +c===================================================================== + ndex3d=0 + if (adjust) return + + time=time+dt_app + itau=itau+1 + + if (first) then + + + icum=0 +c initialisation des fichiers + first=.false. +c ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + WRITE(lunout,*) + . 'Pb : le pas de cumule doit etre multiple du pas' + WRITE(lunout,*)'dt_app=',dt_app + WRITE(lunout,*)'dt_cum=',dt_cum + stop + endif + + if (i_sortie.eq.1) then + file='dynzon' + if (mpi_rank==0) then + call inigrads(ifile,1 + s ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dt_cum,file,'dyn_zon ') + endif + endif + + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + infile='dynzon' + + zan = annee_ref + dayref = day_ref + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + rlong=0. + rlatg=rlatv*180./pi + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + IF (pole_sud) THEN + jjn=jj_nb-1 + jje=jj_end-1 + ENDIF + + ddid=(/ 2 /) + dsg=(/ jjm /) + dsl=(/ jjn /) + dpf=(/ jjb /) + dpl=(/ jje /) + dhs=(/ 0 /) + dhe=(/ 0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',bilan_dyn_domain_id) + + call histbeg(trim(infile), + . 1, rlong(jjb:jje), jjn, rlatg(jjb:jje), + . 1, 1, 1, jjn, + . tau0, zjulian, dt_cum, thoriid, fileid, + . bilan_dyn_domain_id) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', + . llm, presnivs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + +c Declarations des champs avec dimension verticale +c print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + IF (prt_level > 5) + . WRITE(lunout,*)'var ',itr,iQ + . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo +c Declarations pour les fonctions de courant +c print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) + . ,'stream fn. '//znoml(itot,iQ), + . zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + + +c Declarations pour les champs de transport d'air +c print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', + . 'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', + . 'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) +c Declarations pour les fonctions de courant +c print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', + . 1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + + +c Declaration des champs 1D de transport en latitude +c print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + +c print*,'8HISTDEF' + CALL histend(fileid) + + + endif + + +c===================================================================== +c Calcul des champs dynamiques +c ---------------------------- + + jjb=jj_begin + jje=jj_end + +c énergie cinétique + ucont(:,jjb:jje,:)=0 + + call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Req) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Req) + call SendRequest(Req) + call WaitRequest(Req) + + CALL covcont_p(llm,ucov,vcov,ucont,vcont) + CALL enercin_p(vcov,ucov,vcont,ucont,ecin) + +c moment cinétique + do l=1,llm + ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje) + unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje) + enddo + + Q(:,jjb:jje,:,itemp)=teta(:,jjb:jje,:)*pk(:,jjb:jje,:)/cpp + Q(:,jjb:jje,:,igeop)=phi(:,jjb:jje,:) + Q(:,jjb:jje,:,iecin)=ecin(:,jjb:jje,:) + Q(:,jjb:jje,:,iang)=ang(:,jjb:jje,:) + Q(:,jjb:jje,:,iu)=unat(:,jjb:jje,:) + Q(:,jjb:jje,:,iovap)=trac(:,jjb:jje,:,1) + Q(:,jjb:jje,:,iun)=1. + + +c===================================================================== +c Cumul +c===================================================================== +c + if(icum.EQ.0) then + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=0. + masse_cum(:,jjb:jje,:)=0. + flux_u_cum(:,jjb:jje,:)=0. + Q_cum(:,jjb:jje,:,:)=0. + flux_uQ_cum(:,jjb:jje,:,:)=0. + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=0. + flux_vQ_cum(:,jjb:jje,:,:)=0. + endif + + IF (prt_level > 5) + . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + +c accumulation des flux de masse horizontaux + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje) + masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)+masse(:,jjb:jje,:) + flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:) + . +flux_u(:,jjb:jje,:) + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:) + . +flux_v(:,jjb:jje,:) + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ + Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ) + . +Q(:,jjb:jje,:,iQ)*masse(:,jjb:jje,:) + enddo + +c===================================================================== +c FLUX ET TENDANCES +c===================================================================== + +c Flux longitudinal +c ----------------- + do iQ=1,nQ + do l=1,llm + do j=jjb,jje + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) + s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo + enddo + +c flux méridien +c ------------- + do iQ=1,nQ + call Register_Hallo(Q(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req) + enddo + call SendRequest(Req) + call WaitRequest(Req) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do iQ=1,nQ + do l=1,llm + do j=jjb,jje + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) + s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo + enddo + + +c tendances +c --------- + +c convergence horizontale + call Register_Hallo(flux_uQ_cum,ip1jmp1,llm,2,2,2,2,Req) + call Register_Hallo(flux_vQ_cum,ip1jm,llm,2,2,2,2,Req) + call SendRequest(Req) + call WaitRequest(Req) + + call convflu_p(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + +c calcul de la vitesse verticale + call Register_Hallo(flux_u_cum,ip1jmp1,llm,2,2,2,2,Req) + call Register_Hallo(flux_v_cum,ip1jm,llm,2,2,2,2,Req) + call SendRequest(Req) + call WaitRequest(Req) + + call convmas_p(flux_u_cum,flux_v_cum,convm) + CALL vitvert_p(convm,w) + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ + do l=1,llm-1 + do j=jjb,jje + do i=1,iip1 + ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) + dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww + dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww + enddo + enddo + enddo + enddo + IF (prt_level > 5) + . WRITE(lunout,*)'Apres les calculs fait a chaque pas' +c===================================================================== +c PAS DE TEMPS D'ECRITURE +c===================================================================== + if (icum.eq.ncum) then +c===================================================================== + + IF (prt_level > 5) + . WRITE(lunout,*)'Pas d ecriture' + +c Normalisation + do iQ=1,nQ + Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ) + . /masse_cum(:,jjb:jje,:) + enddo + zz=1./REAL(ncum) + + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz + masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)*zz + flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:)*zz + flux_uQ_cum(:,jjb:jje,:,:)=flux_uQ_cum(:,jjb:jje,:,:)*zz + dQ(:,jjb:jje,:,:)=dQ(:,jjb:jje,:,:)*zz + + IF (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:)*zz + flux_vQ_cum(:,jjb:jje,:,:)=flux_vQ_cum(:,jjb:jje,:,:)*zz + + jjb=jj_begin + jje=jj_end + + +c A retravailler eventuellement +c division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ + dQ(:,jjb:jje,:,iQ)=dQ(:,jjb:jje,:,iQ)/masse_cum(:,jjb:jje,:) + enddo + +c===================================================================== +c Transport méridien +c===================================================================== + +c cumul zonal des masses des mailles +c ---------------------------------- + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zv(jjb:jje,:)=0. + zmasse(jjb:jje,:)=0. + + call Register_Hallo(masse_cum,ip1jmp1,llm,1,1,1,1,Req) + do iQ=1,nQ + call Register_Hallo(Q_cum(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req) + enddo + + call SendRequest(Req) + call WaitRequest(Req) + + call massbar_p(masse_cum,massebx,masseby) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do l=1,llm + do j=jjb,jje + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo + +c print*,'3OK' +c -------------------------------------------------------------- +c calcul de la moyenne zonale du transport : +c ------------------------------------------ +c +c -- +c TOT : la circulation totale [ vq ] +c +c - - +c MMC : mean meridional circulation [ v ] [ q ] +c +c ---- -- - - +c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] +c +c - * - * - - - - +c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] +c +c - - +c on utilise aussi l'intermediaire TMP : [ v q ] +c +c la variable zfactv transforme un transport meridien cumule +c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte +c +c -------------------------------------------------------------- + + +c ---------------------------------------- +c Transport dans le plan latitude-altitude +c ---------------------------------------- + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zvQ=0. + psiQ=0. + do iQ=1,nQ + zvQtmp=0. + do l=1,llm + do j=jjb,jje +c print*,'j,l,iQ=',j,l,iQ +c Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) + s +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ + s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy + s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo +c print*,'aOK' +c Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +c fonction de courant meridienne pour la quantite Q + do l=llm,1,-1 + do j=jjb,jje + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo + enddo + +c fonction de courant pour la circulation meridienne moyenne + psi(jjb:jje,:)=0. + do l=llm,1,-1 + do j=jjb,jje + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo + +c print*,'4OK' +c sorties proprement dites + if (i_sortie.eq.1) then + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau, + s zvQ(jjb:jje,:,itr,iQ) + s ,jjn*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ), + s itau,psiQ(jjb:jje,1:llm,iQ) + s ,jjn*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9 + call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), + s jjn*llm,ndex3d) + + endif + + +c ----------------- +c Moyenne verticale +c ----------------- + + zamasse(jjb:jje)=0. + do l=1,llm + zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l) + enddo + + zavQ(jjb:jje,:,:)=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) + s +zvQ(jjb:jje,l,itr,iQ) + s *zmasse(jjb:jje,l) + enddo + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje) + call histwrite(fileid,'a'//znom(itr,iQ),itau, + s zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d) + enddo + enddo + +c on doit pouvoir tracer systematiquement la fonction de courant. + +c===================================================================== +c///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// +c///////////////////////////////////////////////////////////////////// +c===================================================================== + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caladvtrac_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caladvtrac_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caladvtrac_p.F (revision 1634) @@ -0,0 +1,138 @@ +! +! $Id$ +! +c +c + SUBROUTINE caladvtrac_p(q,pbaru,pbarv , + * p ,masse, dq , teta, + * flxw, pk, iapptrac) + USE parallel + USE infotrac, ONLY : nqtot + USE control_mod, ONLY : iapp_tracvl,planet_type +c + IMPLICIT NONE +c +c Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron +c +c F.Codron (10/99) : ajout humidite specifique pour eau vapeur +c======================================================================= +c +c Shema de Van Leer +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + +c Arguments: +c ---------- + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqtot) + real :: dq( ip1jmp1,llm,nqtot) + REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm) + REAL :: flxw(ip1jmp1,llm) + + integer ijb,ije,jjb,jje + +c .................................................................. +c +c .. dq n'est utilise et dimensionne que pour l'eau vapeur et liqu. +c +c .................................................................. +c +c Local: +c ------ + + INTEGER ij,l, iq, iapptrac + REAL finmasse(ip1jmp1,llm), dtvrtrac + +cc +c +C initialisation +cym ijb=ij_begin +cym ije=ij_end + + +cym dq(ijb:ije,1:llm,1:2)=q(ijb:ije,1:llm,1:2) + +c test des valeurs minmax +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ') + +c advection +c print *,'appel a advtrac' + + CALL advtrac_p( pbaru,pbarv, + * p, masse,q,iapptrac, teta, + . flxw, pk) + + goto 9999 + IF( iapptrac.EQ.iapp_tracvl ) THEN +c +cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur ') +cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide ') + +cc .... Calcul de deltap qu'on stocke dans finmasse ... +c + DO l = 1, llm + DO ij = ijb, ije + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) + CALL qminimum_p( q, 2, finmasse ) + endif + + +cym --> le reste ne set a rien + goto 9999 + +c CALL SCOPY ( ip1jmp1*llm, masse, 1, finmasse, 1 ) + finmasse(ijb:ije,:)=masse(ijb:ije,:) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( finmasse ,jjb,jje, jjp1, llm, + * -2, 2, .TRUE., 1 ) +c +c ***** Calcul de dq pour l'eau , pour le passer a la physique ****** +c ******************************************************************** +c + dtvrtrac = iapp_tracvl * dtvr +c + DO iq = 1 , 2 + DO l = 1 , llm + DO ij = ijb,ije + dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l) + * / dtvrtrac + ENDDO + ENDDO + ENDDO +c + ELSE +cym --> le reste ne set a rien + goto 9999 + + DO iq = 1 , 2 + DO l = 1, llm + DO ij = ijb,ije + dq(ij,l,iq) = 0. + ENDDO + ENDDO + ENDDO + + ENDIF +c + + +c ... On appelle qminimum uniquement pour l'eau vapeur et liquide .. + + + 9999 RETURN + END + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caldyn0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caldyn0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caldyn0.F (revision 1634) @@ -0,0 +1,89 @@ +! +! $Header$ +! + SUBROUTINE caldyn0 + $ (itau,ucov,vcov,teta,ps,masse,pk,phis , + $ phi,w,pbaru,pbarv,time ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) + REAL vorpot(ip1jm,llm) + REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) + REAL bern(ip1jmp1,llm) + REAL massebxy(ip1jm,llm), dp(ip1jmp1) + + + INTEGER ij,l + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL pression ( ip1jmp1, ap , bp , ps , p ) + CALL psextbar ( ps , psexbarxy ) + CALL massdair ( p , masse ) + CALL massbar ( masse, massebx , masseby ) + CALL massbarxy( masse, massebxy ) + CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL convmas ( pbaru, pbarv , convm ) + + DO ij =1, ip1jmp1 + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO + + CALL vitvert ( convm , w ) + CALL tourpot ( vcov , ucov , massebxy , vorpot ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) + + DO l=1,llm + DO ij=1,ip1jmp1 + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO + + CALL sortvarc0 + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caldyn_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caldyn_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/caldyn_p.F (revision 1634) @@ -0,0 +1,191 @@ +! +! $Header$ +! +c +c +#undef DEBUG_IO +c#define DEBUG_IO + + SUBROUTINE caldyn_p + $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) + USE parallel + USE Write_Field_p + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + LOGICAL conser + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm) + REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL w(ip1jmp1,llm) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL,SAVE :: ang(ip1jmp1,llm) + REAL,SAVE :: p(ip1jmp1,llmp1) + REAL,SAVE :: massebx(ip1jmp1,llm),masseby(ip1jm,llm) + REAL,SAVE :: psexbarxy(ip1jm) + REAL,SAVE :: vorpot(ip1jm,llm) + REAL,SAVE :: ecin(ip1jmp1,llm) + REAL,SAVE :: bern(ip1jmp1,llm) + REAL,SAVE :: massebxy(ip1jm,llm) + REAL,SAVE :: convm(ip1jmp1,llm) + INTEGER ij,l,ijb,ije,ierr + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + CALL covcont_p ( llm , ucov , vcov , ucont, vcont ) + CALL pression_p ( ip1jmp1, ap , bp , ps , p ) +cym CALL psextbar ( ps , psexbarxy ) +c$OMP BARRIER + CALL massdair_p ( p , masse ) + CALL massbar_p ( masse, massebx , masseby ) + call massbarxy_p( masse, massebxy ) + CALL flumass_p ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL dteta1_p ( teta , pbaru , pbarv, dteta ) + CALL convmas1_p ( pbaru, pbarv , convm ) +c$OMP BARRIER + CALL convmas2_p ( convm ) +c$OMP BARRIER +#ifdef DEBUG_IO +c$OMP BARRIER +c$OMP MASTER + call WriteField_p('ucont',reshape(ucont,(/iip1,jmp1,llm/))) + call WriteField_p('vcont',reshape(vcont,(/iip1,jjm,llm/))) + call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/))) + call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/))) + call WriteField_p('massebx',reshape(massebx,(/iip1,jmp1,llm/))) + call WriteField_p('masseby',reshape(masseby,(/iip1,jjm,llm/))) + call WriteField_p('massebxy',reshape(massebxy,(/iip1,jjm,llm/))) + call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/))) + call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/))) + call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/))) + call WriteField_p('convm',reshape(convm,(/iip1,jmp1,llm/))) +c$OMP END MASTER +c$OMP BARRIER +#endif + +c$OMP BARRIER +c$OMP MASTER + ijb=ij_begin + ije=ij_end + + DO ij =ijb, ije + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO +c$OMP END MASTER +c$OMP BARRIER +c$OMP FLUSH + CALL vitvert_p ( convm , w ) + CALL tourpot_p ( vcov , ucov , massebxy , vorpot ) + CALL dudv1_p ( vorpot , pbaru , pbarv , du , dv ) + +#ifdef DEBUG_IO +c$OMP BARRIER +c$OMP MASTER + call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/))) + call WriteField_p('vorpot',reshape(vorpot,(/iip1,jjm,llm/))) + call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/))) + call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/))) +c$OMP END MASTER +c$OMP BARRIER +#endif + CALL enercin_p ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui_p ( ip1jmp1, llm , phi , ecin , bern ) + CALL dudv2_p ( teta , pkf , bern , du , dv ) + +#ifdef DEBUG_IO +c$OMP BARRIER +c$OMP MASTER + call WriteField_p('ecin',reshape(ecin,(/iip1,jmp1,llm/))) + call WriteField_p('bern',reshape(bern,(/iip1,jmp1,llm/))) + call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/))) + call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/))) + call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/))) +c$OMP END MASTER +c$OMP BARRIER +#endif + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO +c$OMP END DO + + CALL advect_new_p(ang,vcov,teta,w,massebx,masseby,du,dv,dteta) + +C WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi +C probablement. Observe sur le code compile avec pgf90 3.0-1 + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije, iip1 + IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN +c PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', +c , ' dans caldyn' +c PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) + dv(ij+iim,l) = dv(ij,l) + endif + enddo + enddo +c$OMP END DO NOWAIT +c----------------------------------------------------------------------- +c Sorties eventuelles des variables de controle: +c ---------------------------------------------- + + IF( conser ) THEN +c ym ---> exige communication collective ( aussi dans advect) + CALL sortvarc + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + ENDIF + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/calfis_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/calfis_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/calfis_p.F (revision 1634) @@ -0,0 +1,1119 @@ +! +! $Id$ +! +C +C + SUBROUTINE calfis_p(lafin, + $ jD_cur, jH_cur, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ flxw, + $ clesphy0, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +#ifdef CPP_EARTH +! Ehouarn: For now, calfis_p needs Earth physics +c +c Auteur : P. Le Van, F. Hourdin +c ......... + USE dimphy + USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root + USE mod_interface_dyn_phys + USE IOPHY +#endif + USE parallel, ONLY : omp_chunk, using_mpi + USE Write_Field + Use Write_field_p + USE Times + USE infotrac + USE control_mod + + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c ecritphy frequence d'ecriture (en jours)de histphy +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c callrad clef d'appel au rayonnement +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature +c pdtsfi tendency for the surface temperature +c +c pdtrad radiative tendencies \ both input +c pfluxrad radiative fluxes / and output +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" + + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "iniprint.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif +c Arguments : +c ----------- + LOGICAL lafin +! REAL heure + REAL, intent(in):: jD_cur, jH_cur + REAL pvcov(iip1,jjm,llm) + REAL pucov(iip1,jjp1,llm) + REAL pteta(iip1,jjp1,llm) + REAL pmasse(iip1,jjp1,llm) + REAL pq(iip1,jjp1,llm,nqtot) + REAL pphis(iip1,jjp1) + REAL pphi(iip1,jjp1,llm) +c + REAL pdvcov(iip1,jjm,llm) + REAL pducov(iip1,jjp1,llm) + REAL pdteta(iip1,jjp1,llm) + REAL pdq(iip1,jjp1,llm,nqtot) + REAL flxw(iip1,jjp1,llm) ! Flux de masse verticale sur la grille dynamique +c + REAL pps(iip1,jjp1) + REAL pp(iip1,jjp1,llmp1) + REAL ppk(iip1,jjp1,llm) +c + REAL pdvfi(iip1,jjm,llm) + REAL pdufi(iip1,jjp1,llm) + REAL pdhfi(iip1,jjp1,llm) + REAL pdqfi(iip1,jjp1,llm,nqtot) + REAL pdpsfi(iip1,jjp1) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + +#ifdef CPP_EARTH +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq,iiq + REAL,ALLOCATABLE,SAVE :: zpsrf(:) + REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:) + REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:) +c + REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:) +c + REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:) + REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:) +c + REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf(:) + REAL,SAVE,ALLOCATABLE :: flxwfi(:,:) ! Flux de masse verticale sur la grille physiq + +c + REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphis_omp(:) + REAL,ALLOCATABLE,SAVE :: presnivs_omp(:) + REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:) + REAL,SAVE,ALLOCATABLE :: flxwfi_omp(:,:) ! Flux de masse verticale sur la grille physiq + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Introduction du splitting (FH) +! Question pour Yann : +! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent +! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il +! soit allocatable (plutot par exemple que de passer une dimension +! dépendant du process en argument des routines) et que, du coup, +! le SAVE évite d'avoir à refaire l'allocation à chaque appel. +! Tu confirmes ? +! J'ai suivi le même principe pour les zdufic_omp +! Mais c'est surement bien que tu controles. +! + + REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:) + REAL jH_cur_split,zdt_split + LOGICAL debut_split,lafin_split + INTEGER isplit +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp, +c$OMP+ presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp, +c$OMP+ zqfi_omp,zdufi_omp,zdvfi_omp, +c$OMP+ zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp, +c$OMP+ zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp) + + LOGICAL,SAVE :: first_omp=.true. +c$OMP THREADPRIVATE(first_omp) + + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp +c +cIM diagnostique PVteta, Amip2 + INTEGER ntetaSTD + PARAMETER(ntetaSTD=3) + REAL rtetaSTD(ntetaSTD) + DATA rtetaSTD/350., 380., 405./ + REAL PVteta(klon,ntetaSTD) + + + REAL SSUM + + LOGICAL firstcal, debut + DATA firstcal/.true./ + SAVE firstcal,debut +c$OMP THREADPRIVATE(firstcal,debut) + + REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv + INTEGER :: ierr +#ifdef CPP_MPI + INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status +#else + INTEGER,dimension(1,4) :: Status +#endif + INTEGER, dimension(4) :: Req + REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:) + integer :: k,kstart,kend + INTEGER :: offset +c +c----------------------------------------------------------------------- +c +c 1. Initialisations : +c -------------------- +c + + klon=klon_mpi + + PVteta(:,:)=0. + +c + IF ( firstcal ) THEN + debut = .TRUE. + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + write(lunout,*) 'STOP dans calfis' + write(lunout,*) + & 'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + write(lunout,*) ' ngridmx jjm iim ' + write(lunout,*) ngridmx,jjm,iim + STOP + ENDIF +c$OMP MASTER + ALLOCATE(zpsrf(klon)) + ALLOCATE(zplev(klon,llm+1),zplay(klon,llm)) + ALLOCATE(zphi(klon,llm),zphis(klon)) + ALLOCATE(zufi(klon,llm), zvfi(klon,llm)) + ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot)) + ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm)) + ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2)) + ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm)) + ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot)) + ALLOCATE(zdpsrf(klon)) + ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm)) + ALLOCATE(flxwfi(klon,llm)) +c$OMP END MASTER +c$OMP BARRIER + ELSE + debut = .FALSE. + ENDIF + +c +c +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + +c$OMP MASTER + call start_timer(timer_physic) +c$OMP END MASTER + +c$OMP MASTER +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zpsrf(ig0)=pps(i,j) + enddo +c$OMP END MASTER + + +c 42. pression intercouches : +c +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... +c + unskap = 1./ kappa +c +c print *,omp_rank,'klon--->',klon +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zplev( ig0,l ) = pp(i,j,l) + enddo + ENDDO +c$OMP END DO NOWAIT +c +c + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi(ig0,l) = pteta(i,j,l) * pksurcp + enddo + + ENDDO +c$OMP END DO NOWAIT + +c 43.bis traceurs +c --------------- +c + + DO iq=1,nqtot + iiq=niadv(iq) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zqfi(ig0,l,iq) = pq(i,j,l,iiq) + enddo + ENDDO +c$OMP END DO NOWAIT + ENDDO + + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + + CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi) + + CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis) + +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ig=1,klon + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + +c +c 45. champ u: +c ------------ + + kstart=1 + kend=klon + + if (is_north_pole) kstart=2 + if (is_south_pole) kend=klon-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) +!CDIR SPARSE + do ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + if (i==1) then + zufi(ig0,l)= 0.5 *( pucov(iim,j,l)/cu(iim,j) + $ + pucov(1,j,l)/cu(1,j) ) + else + zufi(ig0,l)= 0.5*( pucov(i-1,j,l)/cu(i-1,j) + $ + pucov(i,j,l)/cu(i,j) ) + endif + enddo + ENDDO +c$OMP END DO NOWAIT + +c 46.champ v: +c ----------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + DO ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + zvfi(ig0,l)= 0.5 *( pvcov(i,j-1,l)/cv(i,j-1) + $ + pvcov(i,j,l)/cv(i,j) ) + + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_north_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi + + ENDDO +c$OMP END DO NOWAIT + endif + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_south_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(klon,l) = SSUM(iim,zcos,1)/pi + zvfi(klon,l) = SSUM(iim,zsin,1)/pi + ENDDO +c$OMP END DO NOWAIT + endif + + + IF (is_sequential) THEN +c +cIM calcul PV a teta=350, 380, 405K + CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ ntetaSTD,rtetaSTD,PVteta) +c + ENDIF + +c On change de grille, dynamique vers physiq, pour le flux de masse verticale + CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi) + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + + +c$OMP BARRIER + if (first_omp) then + klon=klon_omp + + allocate(zplev_omp(klon,llm+1)) + allocate(zplay_omp(klon,llm)) + allocate(zphi_omp(klon,llm)) + allocate(zphis_omp(klon)) + allocate(presnivs_omp(llm)) + allocate(zufi_omp(klon,llm)) + allocate(zvfi_omp(klon,llm)) + allocate(ztfi_omp(klon,llm)) + allocate(zqfi_omp(klon,llm,nqtot)) + allocate(zdufi_omp(klon,llm)) + allocate(zdvfi_omp(klon,llm)) + allocate(zdtfi_omp(klon,llm)) + allocate(zdqfi_omp(klon,llm,nqtot)) + allocate(zdufic_omp(klon,llm)) + allocate(zdvfic_omp(klon,llm)) + allocate(zdtfic_omp(klon,llm)) + allocate(zdqfic_omp(klon,llm,nqtot)) + allocate(zdpsrf_omp(klon)) + allocate(flxwfi_omp(klon,llm)) + first_omp=.false. + endif + + + klon=klon_omp + offset=klon_omp_begin-1 + + do l=1,llm+1 + do i=1,klon + zplev_omp(i,l)=zplev(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay_omp(i,l)=zplay(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi_omp(i,l)=zphi(offset+i,l) + enddo + enddo + + do i=1,klon + zphis_omp(i)=zphis(offset+i) + enddo + + + do l=1,llm + presnivs_omp(l)=presnivs(l) + enddo + + do l=1,llm + do i=1,klon + zufi_omp(i,l)=zufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi_omp(i,l)=zvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi_omp(i,l)=ztfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi_omp(i,l)=zdufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi_omp(i,l)=zdvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi_omp(i,l)=zdtfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf_omp(i)=zdpsrf(offset+i) + enddo + + do l=1,llm + do i=1,klon + flxwfi_omp(i,l)=flxwfi(offset+i,l) + enddo + enddo + +c$OMP BARRIER + + if (planet_type=="earth") then +#ifdef CPP_EARTH + +!$OMP MASTER +! write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys +!$OMP END MASTER + zdt_split=dtphys/nsplit_phys + zdufic_omp(:,:)=0. + zdvfic_omp(:,:)=0. + zdtfic_omp(:,:)=0. + zdqfic_omp(:,:,:)=0. + + do isplit=1,nsplit_phys + + jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys) + debut_split=debut.and.isplit==1 + lafin_split=lafin.and.isplit==nsplit_phys + + + CALL physiq (klon, + . llm, + . debut_split, + . lafin_split, + . jD_cur, + . jH_cur_split, + . zdt_split, + . zplev_omp, + . zplay_omp, + . zphi_omp, + . zphis_omp, + . presnivs_omp, + . clesphy0, + . zufi_omp, + . zvfi_omp, + . ztfi_omp, + . zqfi_omp, +c#ifdef INCA + . flxwfi_omp, +c#endif + . zdufi_omp, + . zdvfi_omp, + . zdtfi_omp, + . zdqfi_omp, + . zdpsrf_omp, +cIM diagnostique PVteta, Amip2 + . pducov, + . PVteta) + + zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split + zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split + ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split + zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split + + zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:) + zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:) + zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:) + zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:) + + enddo + + zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys + zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys + zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys + zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys + +#endif + endif !of if (planet_type=="earth") +c$OMP BARRIER + + do l=1,llm+1 + do i=1,klon + zplev(offset+i,l)=zplev_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay(offset+i,l)=zplay_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi(offset+i,l)=zphi_omp(i,l) + enddo + enddo + + + do i=1,klon + zphis(offset+i)=zphis_omp(i) + enddo + + + do l=1,llm + presnivs(l)=presnivs_omp(l) + enddo + + do l=1,llm + do i=1,klon + zufi(offset+i,l)=zufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi(offset+i,l)=zvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi(offset+i,l)=ztfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi(offset+i,l)=zdufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi(offset+i,l)=zdvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi(offset+i,l)=zdtfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf(offset+i)=zdpsrf_omp(i) + enddo + + + klon=klon_mpi +500 CONTINUE +c$OMP BARRIER + +c$OMP MASTER + call stop_timer(timer_physic) +c$OMP END MASTER + + IF (using_mpi) THEN + + if (MPI_rank>0) then + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du_send(1:iim,l)=zdufi(1:iim,l) + dv_send(1:iim,l)=zdvfi(1:iim,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER +#ifdef CPP_MPI +c$OMP MASTER +!$OMP CRITICAL (MPI) + call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401, + & COMM_LMDZ,Req(1),ierr) + call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402, + & COMM_LMDZ,Req(2),ierr) +!$OMP END CRITICAL (MPI) +c$OMP END MASTER +#endif +c$OMP BARRIER + + endif + + if (MPI_rank0 .and. MPI_rank< MPI_Size-1) then + call MPI_WAITALL(4,Req(1),Status,ierr) + else if (MPI_rank>0) then + call MPI_WAITALL(2,Req(1),Status,ierr) + else if (MPI_rank klon=',klon + IF (mpi_size>1 .OR. omp_size>1) THEN + CALL abort_gcm('ce0l','In parallel mode, & + & ce0l must be called only & + & for 1 process and 1 task',1) + ENDIF + + CALL InitComgeomphy + +#ifdef CPP_IOIPSL + SELECT CASE(calend) + CASE('earth_360d');CALL ioconf_calendar('360d'); calnd='a 360 jours/an' + CASE('earth_365d');CALL ioconf_calendar('noleap'); calnd='a 365 jours/an' + CASE('earth_366d');CALL ioconf_calendar('366d'); calnd='bissextile' + CASE('gregorian'); CALL ioconf_calendar('gregorian'); calnd='gregorien' + CASE('standard'); CALL ioconf_calendar('gregorian'); calnd='gregorien' + CASE('julian'); CALL ioconf_calendar('julian'); calnd='julien' + CASE('proleptic_gregorian'); CALL ioconf_calendar('gregorian') + !--- DC Bof... => IOIPSL a mettre a jour: proleptic_gregorian /= gregorian + CASE DEFAULT + CALL abort_gcm('ce0l','Mauvais choix de calendrier',1) + END SELECT + WRITE(lunout,*)'CALENDRIER CHOISI: Terrestre '//TRIM(calnd) +#endif + + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL init_const_lmdz( & + nbtr,anneeref,dayref,& + iphysiq,day_step,nday,& + nbsrf, is_oce,is_sic,& + is_ter,is_lic) + +#endif + END IF + + WRITE(lunout,'(//)') + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,*) ' *** etat0_netcdf *** ' + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,'(//)') + WRITE(lunout,*) ' interbar = ',interbar + CALL etat0_netcdf(interbar,masque,phis,ok_etat0) + + IF(ok_limit) THEN + WRITE(lunout,'(//)') + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,*) ' *** Limit_netcdf *** ' + WRITE(lunout,*) ' ********************* ' + WRITE(lunout,'(//)') + CALL limit_netcdf(interbar,extrap,oldice,masque) + END IF + + IF (grilles_gcm_netcdf) THEN + WRITE(lunout,'(//)') + WRITE(lunout,*) ' *************************** ' + WRITE(lunout,*) ' *** grilles_gcm_netcdf *** ' + WRITE(lunout,*) ' *************************** ' + WRITE(lunout,'(//)') + CALL grilles_gcm_netcdf_sub(masque,phis) + END IF + +!$OMP MASTER + CALL finalize_parallel +!$OMP END MASTER + +#endif +! of #ifndef CPP_EARTH #else + +END PROGRAM ce0l +! +!------------------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/clesph0.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/clesph0.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/clesph0.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! +c..include clesph0.h +c + COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr , + , ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con +c + LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq + LOGICAL ok_limitvrai + INTEGER nbapp_rad, iflag_con Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/coefpoly.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/coefpoly.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/coefpoly.F (revision 1634) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 , + , a0,a1,a2,a3 ) + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c +c Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui +c satisfait aux 4 equations suivantes : + +c a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1 +c a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2 +c a1 + 2.*a2*xtild1 + 3.*a3*xtild1*xtild1 = Xprim1 +c a1 + 2.*a2*xtild2 + 3.*a3*xtild2*xtild2 = Xprim2 + +c On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3 + + REAL(KIND=8) Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi + REAL(KIND=8) Xfout, Xprim + REAL(KIND=8) a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car + + xtil1car = xtild1 * xtild1 + xtil2car = xtild2 * xtild2 + + derr= 2. *(Xf2-Xf1)/( xtild1-xtild2) + + x1x2car = ( xtild1-xtild2)*(xtild1-xtild2) + + a3 = (derr + Xprim1+Xprim2 )/x1x2car + a2 = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) ) / + / ( 2.* ( xtild1 - xtild2 ) ) + + a1 = Xprim1 -3.* a3 * xtil1car -2.* a2 * xtild1 + a0 = Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1 + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/com_io_dyn_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/com_io_dyn_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/com_io_dyn_mod.F90 (revision 1634) @@ -0,0 +1,31 @@ +! +! $Id $ +! +module com_io_dyn_mod + + implicit none + +! Names of various files for outputs (in the dynamics) + ! to store instantaneous values: + character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid + character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid + character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid + + ! to store averaged values: + character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc" + character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc" + character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc" + +! Ids of various files for outputs (in the dynamics) + + ! instantaneous (these are set by inithist.F) + integer :: histid + integer :: histvid + integer :: histuid + + ! averages (these are set by initdynav.F) + integer :: histaveid + integer :: histvaveid + integer :: histuaveid + +end module com_io_dyn_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comconst.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comconst.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comconst.h (revision 1634) @@ -0,0 +1,39 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE comconst.h + + COMMON/comconsti/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl, & + & iflag_top_bound + COMMON/comconstr/dtvr,daysec, & + & pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg & + & ,dissip_factz,dissip_deltaz,dissip_zref & + & ,tau_top_bound, & + & daylen,year_day,molmass, ihf + + + INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl + REAL dtvr ! dynamical time step (in s) + REAL daysec !length (in s) of a standard day + REAL pi ! something like 3.14159.... + REAL dtphys ! (s) time step for the physics + REAL dtdiss ! (s) time step for the dissipation + REAL rad ! (m) radius of the planet + REAL r ! Gas constant R=8.31 J.K-1.mol-1 + REAL cpp ! Cp + REAL kappa ! kappa=R/Cp + REAL cotot + REAL unsim ! = 1./iim + REAL g ! (m/s2) gravity + REAL omeg ! (rad/s) rotation rate of the planet + REAL dissip_factz,dissip_deltaz,dissip_zref + INTEGER iflag_top_bound + REAL tau_top_bound + REAL daylen ! length of solar day, in 'standard' day length + REAL year_day ! Number of standard days in a year + REAL molmass ! (g/mol) molar mass of the atmosphere + + REAL ihf ! (W/m2) Intrinsic heat flux (for giant planets) + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissip.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissip.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissip.h (revision 1634) @@ -0,0 +1,15 @@ +! +! $Header$ +! +!----------------------------------------------------------------------- +! INCLUDE comdissip.h + + COMMON/comdissip/ & + & niterdis,coefdis,tetavel,tetatemp,gamdissip + + + INTEGER niterdis + + REAL tetavel,tetatemp,coefdis,gamdissip + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissipn.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissipn.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissipn.h (revision 1634) @@ -0,0 +1,20 @@ +! +! $Header$ +! +! Attention : ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +!----------------------------------------------------------------------- +! INCLUDE comdissipn.h + + REAL tetaudiv, tetaurot, tetah, cdivu, crot, cdivh +! + COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm) , & + & cdivu, crot, cdivh + +! +! Les parametres de ce common proviennent des calculs effectues dans +! Inidissip . +! +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissnew.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissnew.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comdissnew.h (revision 1634) @@ -0,0 +1,24 @@ +! +! $Id$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!----------------------------------------------------------------------- +! INCLUDE 'comdissnew.h' + + COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv, & + & tetagrot,tetatemp,coefdis + + LOGICAL lstardis + INTEGER nitergdiv, nitergrot, niterh + REAL tetagdiv, tetagrot, tetatemp, coefdis + +! +! ... Les parametres de ce common comdissnew sont lues par defrun_new +! sur le fichier run.def .... +! +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comgeom.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comgeom.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comgeom.h (revision 1634) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom + COMMON/comgeom/ & + & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm), & + & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1), & + & airev(ip1jm),unsaire(ip1jmp1),apoln,apols, & + & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm), & + & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1), & + & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1), & + & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1), & + & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1), & + & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm), & + & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm), & + & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1), & + & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1), & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2, & + & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm), & + & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1) + +! + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln ,& + & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,& + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,& + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 ,& + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2& + & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam ,& + & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu& + & , xprimv +! Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comgeom2.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comgeom2.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comgeom2.h (revision 1634) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom2 + COMMON/comgeom/ & + & cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm) , & + & aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1) , & + & airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols , & + & unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm) , & + & aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1) , & + & aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1) , & + & alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1) , & + & alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1) , & + & fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm) , & + & cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1) , & + & cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), & + & cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2 , & + & unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1) , & + & unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm) & + & , xprimu(iip1),xprimv(iip1) + + + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire & + & ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4 , & + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , & + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 , & + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1 , & + & unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2 , & + & unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu , & + & cusurcvu,xprimu,xprimv Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comvert.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comvert.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/comvert.h (revision 1634) @@ -0,0 +1,32 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE 'comvert.h' + + COMMON/comvertr/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm), & + & pa,preff,nivsigs(llm),nivsig(llm+1), & + & aps(llm),bps(llm),scaleheight + + common/comverti/disvert_type + + real ap ! hybrid pressure contribution at interlayers + real bp ! hybrid sigma contribution at interlayer + real presnivs ! (reference) pressure at mid-layers + real dpres + real pa ! reference pressure (Pa) at which hybrid coordinates + ! become purely pressure + real preff ! reference surface pressure (Pa) + real nivsigs + real nivsig + real aps ! hybrid pressure contribution at mid-layers + real bps ! hybrid sigma contribution at mid-layers + real scaleheight ! atmospheric (reference) scale height (km) + + integer disvert_type ! type of vertical discretization: + ! 1: Earth (default for planet_type==earth), + ! automatic generation + ! 2: Planets (default for planet_type!=earth), + ! using 'z2sig.def' (or 'esasig.def) file + + !----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_dat2d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_dat2d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_dat2d.F (revision 1634) @@ -0,0 +1,221 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd , + , interbar ) +c +c Auteur : P. Le Van + +c Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que +c qu'on ait - pi a pi en longitude +c et qu'on ait pi/2. a - pi/2. en latitude +c +c xd et yd sont les longitudes et latitudes initiales +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . + + IMPLICIT NONE + +c *** Arguments en entree *** + INTEGER lons,lats + CHARACTER*25 title + REAL xd(lons),yd(lats) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons),yf(lats) +c +c *** Arguments en entree et sortie *** + REAL champd(lons,lats) + +c *** Variables locales *** +c + REAL pi,pis2,depi + LOGICAL radianlon, invlon ,radianlat, invlat, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: champf(:,:) + +c +c WRITE(6,*) ' conf_dat2d pour la variable ', title + + ALLOCATE( xtemp(lons) ) + ALLOCATE( ytemp(lats) ) + ALLOCATE( champf(lons,lats) ) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + radianlon = .FALSE. + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + IF ( invlon ) THEN + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO j = 1,lats + + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j) = champf (i,j) + ENDDO + + DO i= ind +1,lons + champd (i,j) = champf (i-ind,j) + ENDDO + + ENDDO + + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + DO j = 1,lats + yf(j) = ytemp(j) + ENDDO + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1) = champf (i,j) + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** + +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + + ENDIF +c + DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + deallocate(xtemp) + deallocate(ytemp) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_dat3d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_dat3d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_dat3d.F (revision 1634) @@ -0,0 +1,296 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf, + , champd , interbar ) +c +c Auteur : P. Le Van +c +c Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon +c qu'on ait - pi a pi en longitude +c qu'on ait pi/2. a - pi/2. en latitude +c et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos. +c ( en Pascals ) . +c +c xd et yd sont les longitudes et latitudes initiales +c zd les pressions initiales +c +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . +c zf les pressions en sortie +c +c champd en meme temps le champ initial et final +c +c interbar = .TRUE. si on appelle l'interpo. barycentrique inter_barxy +c sinon , l'interpolation grille_m ( grid_atob ) . +c + + IMPLICIT NONE + +c *** Arguments en entree *** + CHARACTER*(*) :: title + INTEGER lons, lats, levs + REAL xd(lons), yd(lats), zd(levs) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons), yf(lats), zf(levs) + +c *** Arguments en entree et sortie *** + REAL champd(lons,lats,levs) + +c *** Variables locales *** +c + REAL pi,pis2,depi,presmax + LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind,l + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: ztemp(:) + REAL, ALLOCATABLE :: champf(:,:,:) + + +c WRITE(6,*) ' Conf_dat3d pour ',title + + ALLOCATE(xtemp(lons)) + ALLOCATE(ytemp(lats)) + ALLOCATE(ztemp(levs)) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + DO l = 1, levs + ztemp(l) = zd(l) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + alloc =.FALSE. + + IF ( invlon ) THEN + + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO + + DO l = 1, levs + DO j = 1, lats + DO i= 1, lons + champf (i,j,l) = champd (i,j,l) + ENDDO + ENDDO + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO l = 1,levs + DO j = 1,lats + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j,l) = champf (i,j,l) + ENDDO + + DO i= ind +1,lons + champd (i,j,l) = champf (i-ind,j,l) + ENDDO + ENDDO + ENDDO + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1,l) = champf (i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** +c +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + ENDIF +c + + invlev = .FALSE. + IF( ztemp(1).LT.ztemp(levs) ) invlev = .TRUE. + + presmax = MAX( ztemp(1), ztemp(levs) ) + IF( presmax.LT.1200. ) THEN + DO l = 1,levs + ztemp(l) = ztemp(l) * 100. + ENDDO + ENDIF + + IF( invlev ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO l = 1,levs + zf(l) = ztemp(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + ENDDO + + DO l = 1,levs + ztemp(levs+1-l) = zf(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champd(i,j,levs+1-l) = champf(i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF(alloc) DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + DO l = 1, levs + zf(l) = ztemp(l) + ENDDO + + DEALLOCATE(xtemp) + DEALLOCATE(ytemp) + DEALLOCATE(ztemp) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_gcm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_gcm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_gcm.F (revision 1634) @@ -0,0 +1,949 @@ +! +! $Id$ +! +c +c + SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 ) +c +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + use misc_mod + use mod_filtre_fft, ONLY : use_filtre_fft + use mod_hallo, ONLY : use_mpi_alloc + use parallel, ONLY : omp_chunk + USE control_mod + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +!#include "clesphys.h" +#include "iniprint.h" +#include "temps.h" +#include "comconst.h" + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy, tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + adjust=.false. + call getin('adjust',adjust) + + itaumax=0 + call getin('itaumax',itaumax); + if (itaumax<=0) itaumax=HUGE(itaumax) + +!Config Key = lunout +!Config Desc = unite de fichier pour les impressions +!Config Def = 6 +!Config Help = unite de fichier pour les impressions +!Config (defaut sortie standard = 6) + lunout=6 + CALL getin('lunout', lunout) + IF (lunout /= 5 .and. lunout /= 6) THEN + OPEN(lunout,FILE='lmdz.out') + ENDIF + +!Config Key = prt_level +!Config Desc = niveau d'impressions de débogage +!Config Def = 0 +!Config Help = Niveau d'impression pour le débogage +!Config (0 = minimum d'impression) + prt_level = 0 + CALL getin('prt_level',prt_level) + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- +!Config Key = planet_type +!Config Desc = planet type ("earth", "mars", "venus", ...) +!Config Def = earth +!Config Help = this flag sets the type of atymosphere that is considered + planet_type="earth" + CALL getin('planet_type',planet_type) + +!Config Key = calend +!Config Desc = type de calendrier utilise +!Config Def = earth_360d +!Config Help = valeur possible: earth_360d, earth_365d, earth_366d +!Config + calend = 'earth_360d' + CALL getin('calend', calend) + +!Config Key = dayref +!Config Desc = Jour de l'etat initial +!Config Def = 1 +!Config Help = Jour de l'etat initial ( = 350 si 20 Decembre , +!Config par expl. ,comme ici ) ... A completer + dayref=1 + CALL getin('dayref', dayref) + +!Config Key = anneeref +!Config Desc = Annee de l'etat initial +!Config Def = 1998 +!Config Help = Annee de l'etat initial +!Config ( avec 4 chiffres ) ... A completer + anneeref = 1998 + CALL getin('anneeref',anneeref) + +!Config Key = raz_date +!Config Desc = Remise a zero de la date initiale +!Config Def = 0 (pas de remise a zero) +!Config Help = Remise a zero de la date initiale +!Config 0 pas de remise a zero, on garde la date du fichier restart +!Config 1 prise en compte de la date de gcm.def avec remise a zero +!Config des compteurs de pas de temps + raz_date = 0 + CALL getin('raz_date', raz_date) + +!Config Key = nday +!Config Desc = Nombre de jours d'integration +!Config Def = 10 +!Config Help = Nombre de jours d'integration +!Config ... On pourait aussi permettre des mois ou des annees ! + nday = 10 + CALL getin('nday',nday) + +!Config Key = day_step +!Config Desc = nombre de pas par jour +!Config Def = 240 +!Config Help = nombre de pas par jour (multiple de iperiod) ( +!Config ici pour dt = 1 min ) + day_step = 240 + CALL getin('day_step',day_step) + +!Config Key = nsplit_phys +!Config Desc = nombre d'iteration de la physique +!Config Def = 240 +!Config Help = nombre d'itration de la physique +! + nsplit_phys = 1 + CALL getin('nsplit_phys',nsplit_phys) + +!Config Key = iperiod +!Config Desc = periode pour le pas Matsuno +!Config Def = 5 +!Config Help = periode pour le pas Matsuno (en pas de temps) + iperiod = 5 + CALL getin('iperiod',iperiod) + +!Config Key = iapp_tracvl +!Config Desc = frequence du groupement des flux +!Config Def = iperiod +!Config Help = frequence du groupement des flux (en pas de temps) + iapp_tracvl = iperiod + CALL getin('iapp_tracvl',iapp_tracvl) + +!Config Key = iconser +!Config Desc = periode de sortie des variables de controle +!Config Def = 240 +!Config Help = periode de sortie des variables de controle +!Config (En pas de temps) + iconser = 240 + CALL getin('iconser', iconser) + +!Config Key = iecri +!Config Desc = periode d'ecriture du fichier histoire +!Config Def = 1 +!Config Help = periode d'ecriture du fichier histoire (en jour) + iecri = 1 + CALL getin('iecri',iecri) + + +!Config Key = periodav +!Config Desc = periode de stockage fichier histmoy +!Config Def = 1 +!Config Help = periode de stockage fichier histmoy (en jour) + periodav = 1. + CALL getin('periodav',periodav) + +!Config Key = output_grads_dyn +!Config Desc = output dynamics diagnostics in 'dyn.dat' file +!Config Def = n +!Config Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file + output_grads_dyn=.false. + CALL getin('output_grads_dyn',output_grads_dyn) + +!Config Key = dissip_period +!Config Desc = periode de la dissipation +!Config Def = 0 +!Config Help = periode de la dissipation +!Config dissip_period=0 => la valeur sera calcule dans inidissip +!Config dissip_period>0 => on prend cette valeur + dissip_period = 0 + CALL getin('dissip_period',dissip_period) + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + +!Config Key = lstardis +!Config Desc = choix de l'operateur de dissipation +!Config Def = y +!Config Help = choix de l'operateur de dissipation +!Config 'y' si on veut star et 'n' si on veut non-start ! +!Config Moi y en a pas comprendre ! + lstardis = .TRUE. + CALL getin('lstardis',lstardis) + + +!Config Key = nitergdiv +!Config Desc = Nombre d'iteration de gradiv +!Config Def = 1 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config gradiv + nitergdiv = 1 + CALL getin('nitergdiv',nitergdiv) + +!Config Key = nitergrot +!Config Desc = nombre d'iterations de nxgradrot +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config nxgradrot + nitergrot = 2 + CALL getin('nitergrot',nitergrot) + + +!Config Key = niterh +!Config Desc = nombre d'iterations de divgrad +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config divgrad + niterh = 2 + CALL getin('niterh',niterh) + + +!Config Key = tetagdiv +!Config Desc = temps de dissipation pour div +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (gradiv) + tetagdiv = 7200. + CALL getin('tetagdiv',tetagdiv) + +!Config Key = tetagrot +!Config Desc = temps de dissipation pour grad +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (nxgradrot) + tetagrot = 7200. + CALL getin('tetagrot',tetagrot) + +!Config Key = tetatemp +!Config Desc = temps de dissipation pour h +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour h (divgrad) + tetatemp = 7200. + CALL getin('tetatemp',tetatemp ) + +! Parametres controlant la variation sur la verticale des constantes de +! dissipation. +! Pour le moment actifs uniquement dans la version a 39 niveaux +! avec ok_strato=y + + dissip_factz=4. + dissip_deltaz=10. + dissip_zref=30. + CALL getin('dissip_factz',dissip_factz ) + CALL getin('dissip_deltaz',dissip_deltaz ) + CALL getin('dissip_zref',dissip_zref ) + + iflag_top_bound=1 + tau_top_bound=1.e-5 + CALL getin('iflag_top_bound',iflag_top_bound) + CALL getin('tau_top_bound',tau_top_bound) + +! +!Config Key = coefdis +!Config Desc = coefficient pour gamdissip +!Config Def = 0 +!Config Help = coefficient pour gamdissip + coefdis = 0. + CALL getin('coefdis',coefdis) + +!Config Key = purmats +!Config Desc = Schema d'integration +!Config Def = n +!Config Help = Choix du schema d'integration temporel. +!Config y = pure Matsuno sinon c'est du Matsuno-leapfrog + purmats = .FALSE. + CALL getin('purmats',purmats) + +!Config Key = ok_guide +!Config Desc = Guidage +!Config Def = n +!Config Help = Guidage + ok_guide = .FALSE. + CALL getin('ok_guide',ok_guide) + +c ............................................................... + +!Config Key = read_start +!Config Desc = Initialize model using a 'start.nc' file +!Config Def = y +!Config Help = y: intialize dynamical fields using a 'start.nc' file +! n: fields are initialized by 'iniacademic' routine + read_start= .true. + CALL getin('read_start',read_start) + +!Config Key = iflag_phys +!Config Desc = Avec ls physique +!Config Def = 1 +!Config Help = Permet de faire tourner le modele sans +!Config physique. + iflag_phys = 1 + CALL getin('iflag_phys',iflag_phys) + + +!Config Key = iphysiq +!Config Desc = Periode de la physique +!Config Def = 5 +!Config Help = Periode de la physique en pas de temps de la dynamique. + iphysiq = 5 + CALL getin('iphysiq', iphysiq) + +!Config Key = ip_ebil_dyn +!Config Desc = PRINT level for energy conserv. diag. +!Config Def = 0 +!Config Help = PRINT level for energy conservation diag. ; +! les options suivantes existent : +!Config 0 pas de print +!Config 1 pas de print +!Config 2 print, + ip_ebil_dyn = 0 + CALL getin('ip_ebil_dyn',ip_ebil_dyn) +! + + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clonn = 0. + CALL getin('clon',clonn) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clatt = 0. + CALL getin('clat',clatt) + +c +c + IF( ABS(clat - clatt).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de clat passee par run.def', + & ' est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismxx = 1.0 + CALL getin('grossismx',grossismxx) + + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismx passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismyy = 1.0 + CALL getin('grossismy',grossismyy) + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismy passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypbb = .TRUE. + CALL getin('fxyhypb',fxyhypbb) + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'F alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'T alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF +c +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomxx = 0.0 + CALL getin('dzoomx',dzoomxx) + + IF( fxyhypb ) THEN + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomyy = 0.0 + CALL getin('dzoomy',dzoomyy) + + IF( fxyhypb ) THEN + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + tauxx = 3.0 + CALL getin('taux',tauxx) + + IF( fxyhypb ) THEN + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de taux passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = tauyy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauyy = 3.0 + CALL getin('tauy',tauyy) + + IF( fxyhypb ) THEN + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de tauy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinuss = .TRUE. + CALL getin('ysinus',ysinuss) + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF + ENDIF ! of IF( .NOT.fxyhypb ) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + IF (offline .AND. adjust) THEN + WRITE(lunout,*) + & 'WARNING : option offline does not work with adjust=y :' + WRITE(lunout,*) 'the files defstoke.nc, fluxstoke.nc ', + & 'and fluxstokev.nc will not be created' + WRITE(lunout,*) + & 'only the file phystoke.nc will still be created ' + END IF + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + +!Config Key = ok_dynzon +!Config Desc = calcul et sortie des transports +!Config Def = n +!Config Help = Permet de mettre en route le calcul des transports +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + +!Config Key = ok_dyn_ins +!Config Desc = sorties instantanees dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ins = .FALSE. + CALL getin('ok_dyn_ins',ok_dyn_ins) + +!Config Key = ok_dyn_ave +!Config Desc = sorties moyennes dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ave = .FALSE. + CALL getin('ok_dyn_ave',ok_dyn_ave) + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' nsplit_phys = ', nsplit_phys + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' dissip_period = ', dissip_period + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clonn = ', clonn + write(lunout,*)' clatt = ', clatt + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypbb = ', fxyhypbb + write(lunout,*)' dzoomxx = ', dzoomxx + write(lunout,*)' dzoomy = ', dzoomyy + write(lunout,*)' tauxx = ', tauxx + write(lunout,*)' tauyy = ', tauyy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins + write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave + + RETURN +c ............................................... +c +100 CONTINUE +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clon = 0. + CALL getin('clon',clon) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clat = 0. + CALL getin('clat',clat) + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismx = 1.0 + CALL getin('grossismx',grossismx) + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismy = 1.0 + CALL getin('grossismy',grossismy) + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypb = .TRUE. + CALL getin('fxyhypb',fxyhypb) + +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomx = 0.0 + CALL getin('dzoomx',dzoomx) + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomy = 0.0 + CALL getin('dzoomy',dzoomy) + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + taux = 3.0 + CALL getin('taux',taux) + +!Config Key = tauy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauy = 3.0 + CALL getin('tauy',tauy) + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinus = .TRUE. + CALL getin('ysinus',ysinus) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + IF (offline .AND. adjust) THEN + WRITE(lunout,*) + & 'WARNING : option offline does not work with adjust=y :' + WRITE(lunout,*) 'the files defstoke.nc, fluxstoke.nc ', + & 'and fluxstokev.nc will not be created' + WRITE(lunout,*) + & 'only the file phystoke.nc will still be created ' + END IF + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + +!Config Key = ok_dynzon +!Config Desc = calcul et sortie des transports +!Config Def = n +!Config Help = Permet de mettre en route le calcul des transports +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + +!Config Key = ok_dyn_ins +!Config Desc = sorties instantanees dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ins = .FALSE. + CALL getin('ok_dyn_ins',ok_dyn_ins) + +!Config Key = ok_dyn_ave +!Config Desc = sorties moyennes dans la dynamique +!Config Def = n +!Config Help = +!Config + ok_dyn_ave = .FALSE. + CALL getin('ok_dyn_ave',ok_dyn_ave) + +!Config Key = use_filtre_fft +!Config Desc = flag d'activation des FFT pour le filtre +!Config Def = false +!Config Help = permet d'activer l'utilisation des FFT pour effectuer +!Config le filtrage aux poles. + use_filtre_fft=.FALSE. + CALL getin('use_filtre_fft',use_filtre_fft) + + IF (use_filtre_fft .AND. grossismx /= 1.0) THEN + write(lunout,*)'WARNING !!! ' + write(lunout,*)"Le zoom en longitude est incompatible", + & " avec l'utilisation du filtre FFT ", + & "---> filtre FFT désactivé " + use_filtre_fft=.FALSE. + ENDIF + + + +!Config Key = use_mpi_alloc +!Config Desc = Utilise un buffer MPI en m�moire globale +!Config Def = false +!Config Help = permet d'activer l'utilisation d'un buffer MPI +!Config en m�moire globale a l'aide de la fonction MPI_ALLOC. +!Config Cela peut am�liorer la bande passante des transferts MPI +!Config d'un facteur 2 + use_mpi_alloc=.FALSE. + CALL getin('use_mpi_alloc',use_mpi_alloc) + +!Config Key = omp_chunk +!Config Desc = taille des blocs openmp +!Config Def = 1 +!Config Help = defini la taille des packets d'it�ration openmp +!Config distribu�e � chaque t�che lors de l'entr�e dans une +!Config boucle parall�lis�e + + omp_chunk=1 + CALL getin('omp_chunk',omp_chunk) + +!Config key = ok_strato +!Config Desc = activation de la version strato +!Config Def = .FALSE. +!Config Help = active la version stratosphérique de LMDZ de F. Lott + + ok_strato=.FALSE. + CALL getin('ok_strato',ok_strato) + +!Config Key = ok_gradsfile +!Config Desc = activation des sorties grads du guidage +!Config Def = n +!Config Help = active les sorties grads du guidage + + ok_gradsfile = .FALSE. + CALL getin('ok_gradsfile',ok_gradsfile) + +!Config Key = ok_limit +!Config Desc = creation des fichiers limit dans create_etat0_limit +!Config Def = y +!Config Help = production du fichier limit.nc requise + + ok_limit = .TRUE. + CALL getin('ok_limit',ok_limit) + +!Config Key = ok_etat0 +!Config Desc = creation des fichiers etat0 dans create_etat0_limit +!Config Def = y +!Config Help = production des fichiers start.nc, startphy.nc requise + + ok_etat0 = .TRUE. + CALL getin('ok_etat0',ok_etat0) + +!Config Key = grilles_gcm_netcdf +!Config Desc = creation de fichier grilles_gcm.nc dans create_etat0_limit +!Config Def = n + grilles_gcm_netcdf = .FALSE. + CALL getin('grilles_gcm_netcdf',grilles_gcm_netcdf) + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres de cel0' + & //'_limit: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' dissip_period = ', dissip_period + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clon = ', clon + write(lunout,*)' clat = ', clat + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypb = ', fxyhypb + write(lunout,*)' dzoomx = ', dzoomx + write(lunout,*)' dzoomy = ', dzoomy + write(lunout,*)' taux = ', taux + write(lunout,*)' tauy = ', tauy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins + write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave + write(lunout,*)' use_filtre_fft = ', use_filtre_fft + write(lunout,*)' use_mpi_alloc = ', use_mpi_alloc + write(lunout,*)' omp_chunk = ', omp_chunk + write(lunout,*)' ok_strato = ', ok_strato + write(lunout,*)' ok_gradsfile = ', ok_gradsfile + write(lunout,*)' ok_limit = ', ok_limit + write(lunout,*)' ok_etat0 = ', ok_etat0 + write(lunout,*)' grilles_gcm_netcdf = ', grilles_gcm_netcdf +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_planete.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_planete.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/conf_planete.F90 (revision 1634) @@ -0,0 +1,70 @@ +! +! $Id$ +! +SUBROUTINE conf_planete +! +#ifdef CPP_IOIPSL +USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin +USE ioipsl_getincom +#endif +IMPLICIT NONE +! +! +! Declarations : +! -------------- +#include "dimensions.h" +#include "comconst.h" +#include "comvert.h" +! +! local: +! ------ + +! --------------------------------------------- +! Initialisations de constantes de la dynamique +! --------------------------------------------- +! Pi +pi=2.*asin(1.) + +!Reference surface pressure (Pa) +preff=101325. +CALL getin('preff', preff) +! Reference pressure at which hybrid coord. become purely pressure +! pa=50000. +pa=preff/2. +CALL getin('pa', pa) +! Gravity +g=9.80665 +CALL getin('g',g) +! Molar mass of the atmosphere +molmass = 28.9644 +CALL getin('molmass',molmass) +! kappa=R/Cp et Cp +kappa = 2./7. +CALL getin('kappa',kappa) +cpp=8.3145/molmass/kappa*1000. +CALL getin('cpp',cpp) +! Radius of the planet +rad = 6371229. +CALL getin('radius',rad) +! Length of a standard day (s) +daysec=86400. +CALL getin('daysec',daysec) +! Rotation rate of the planet: +! Length of a solar day, in standard days +daylen = 1. +CALL getin('daylen',daylen) +! Number of days (standard) per year: +year_day = 365.25 +CALL getin('year_day',year_day) +! Omega +! omeg=2.*pi/86400. +omeg=2.*pi/daysec*(1./daylen+1./year_day) +CALL getin('omeg',omeg) + +! Intrinsic heat flux (default: none) (only used if planet_type="giant") +ihf = 0. +call getin('ihf',ihf) + +END SUBROUTINE conf_planete Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/control_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/control_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/control_mod.F90 (revision 1634) @@ -0,0 +1,27 @@ +! +! $Id $ +! + +MODULE control_mod + +! LF 01/2010 +! Remplacement du fichier et common control + + IMPLICIT NONE + + REAL :: periodav + INTEGER :: nday,day_step,iperiod,iapp_tracvl,nsplit_phys + INTEGER :: iconser,iecri,dissip_period,iphysiq,iecrimoy + INTEGER :: dayref,anneeref, raz_date, ip_ebil_dyn + LOGICAL :: offline + CHARACTER (len=4) :: config_inca + CHARACTER (len=10) :: planet_type ! planet type ('earth','mars',...) + LOGICAL output_grads_dyn ! output dynamics diagnostics in + ! binary grads file 'dyn.dat' (y/n) + LOGICAL ok_dynzon ! output zonal transports in dynzon.nc file + LOGICAL ok_dyn_ins ! output instantaneous values of fields + ! in the dynamics in NetCDF files dyn_hist*nc + LOGICAL ok_dyn_ave ! output averaged values of fields in the dynamics + ! in NetCDF files dyn_hist*ave.nc + +END MODULE Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convflu.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convflu.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convflu.F (revision 1634) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE convflu( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + REAL SSUM +c +c +#include "comgeom.h" +c + DO 5 l = 1,nbniv +c + DO 2 ij = iip2, ip1jm - 1 + convfl( ij + 1,l ) = xflu( ij,l ) - xflu( ij + 1,l ) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + DO 4 ij = 1,iip1 + convfl( ij ,l ) = convpn * aire( ij ) / apoln + convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols + 4 CONTINUE +c + 5 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convflu_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convflu_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convflu_p.F (revision 1634) @@ -0,0 +1,84 @@ + SUBROUTINE convflu_p( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + INTEGER ijb,ije + EXTERNAL SSUM + REAL SSUM +c +c +#include "comgeom.h" +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,nbniv +c + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_nord) ijb=ij_begin+iip1 + IF (pole_sud) ije=ij_end-iip1 + + DO 2 ij = ijb , ije - 1 + convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = ijb,ije,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + IF (pole_nord) THEN + + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij,l) = convpn * aire(ij) / apoln + ENDDO + + ENDIF + + IF (pole_sud) THEN + + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols + ENDDO + + ENDIF + + 5 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas.F (revision 1634) @@ -0,0 +1,63 @@ +! +! $Header$ +! + SUBROUTINE convmas (pbaru, pbarv, convm ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm( ip1jmp1,llm ) + INTEGER l,ij + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + + DO l = llmm1, 1, -1 + DO ij = 1, ip1jmp1 + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas1_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas1_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas1_p.F (revision 1634) @@ -0,0 +1,62 @@ + SUBROUTINE convmas1_p (pbaru, pbarv, convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL, target :: convm( ip1jmp1,llm ) + INTEGER l,ij + + INTEGER ijb,ije,jjb,jje + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu_p( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas2_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas2_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas2_p.F (revision 1634) @@ -0,0 +1,56 @@ + SUBROUTINE convmas2_p ( convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL :: convm( ip1jmp1,llm ) + INTEGER l,ij + INTEGER ijb,ije,jjb,jje + +c$OMP MASTER +c integration de la convergence de masse de haut en bas ...... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO l = llmm1, 1, -1 + DO ij = ijb, ije + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c +c$OMP END MASTER + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/convmas_p.F (revision 1634) @@ -0,0 +1,71 @@ + SUBROUTINE convmas_p (pbaru, pbarv, convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL, target :: convm( ip1jmp1,llm ) + INTEGER l,ij + + INTEGER ijb,ije,jjb,jje + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu_p( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO l = llmm1, 1, -1 + DO ij = ijb, ije + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/coordij.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/coordij.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/coordij.F (revision 1634) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE coordij(lon,lat,ilon,jlat) + +c======================================================================= +c +c calcul des coordonnees i et j de la maille scalaire dans +c laquelle se trouve le point (lon,lat) en radian +c +c======================================================================= + + IMPLICIT NONE + REAL lon,lat + INTEGER ilon,jlat + INTEGER i,j + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" + + real zlon,zlat + + zlon=lon*pi/180. + zlat=lat*pi/180. + + DO i=1,iim+1 + IF (rlonu(i).GT.zlon) THEN + ilon=i + GOTO 10 + ENDIF + ENDDO +10 CONTINUE + + j=0 + DO j=1,jjm + IF(rlatv(j).LT.zlat) THEN + jlat=j + GOTO 20 + ENDIF + ENDDO +20 CONTINUE + IF(j.EQ.0) j=jjm+1 + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covcont.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covcont.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covcont.F (revision 1634) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) + INTEGER l,ij + + + DO 10 l = 1,klevel + + DO 2 ij = iip2, ip1jm + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = 1,ip1jm + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covcont_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covcont_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covcont_p.F (revision 1634) @@ -0,0 +1,59 @@ + SUBROUTINE covcont_p (klevel,ucov, vcov, ucont, vcont ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) + INTEGER l,ij + INTEGER ijb_u,ijb_v,ije_u,ije_v + + + ijb_u=ij_begin-iip1 + ijb_v=ij_begin-iip1 + ije_u=ij_end+iip1 + ije_v=ij_end+iip1 + + if (pole_nord) then + ijb_u=ij_begin+iip1 + ijb_v=ij_begin + endif + + if (pole_sud) then + ije_u=ij_end-iip1 + ije_v=ij_end-iip1 + endif + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel + + DO 2 ij = ijb_u,ije_u + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = ijb_v,ije_v + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covnat.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covnat.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covnat.F (revision 1634) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: F Hourdin Phu LeVan +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. naturelles a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) + INTEGER l,ij + + + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + + DO ij = iip2, ip1jm + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + + DO ij = 1,ip1jm + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + + ENDDO + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covnat_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covnat_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/covnat_p.F (revision 1634) @@ -0,0 +1,76 @@ +! +! $Header$ +! + SUBROUTINE covnat_p(klevel,ucov, vcov, unat, vnat ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: F Hourdin Phu LeVan +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. naturelles a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije + + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + ENDDO + endif + + if (pole_sud) then + DO l = 1,klevel + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + ENDDO + endif + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO l = 1,klevel + DO ij = ijb, ije + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + END DO + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO l = 1,klevel + DO ij = ijb,ije + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/cray.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/cray.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/cray.F (revision 1634) @@ -0,0 +1,54 @@ +! +! $Header$ +! +#ifdef CRAY + SUBROUTINE riencray + END +#else + subroutine scopy(n,sx,incx,sy,incy) +c + IMPLICIT NONE +c + integer n,incx,incy,ix,iy,i + real sx((n-1)*incx+1),sy((n-1)*incy+1) +c + if (incx.eq.1.and.incy.eq.1) then + do 10 i=1,n + sy(i)=sx(i) +10 continue + else + iy=1 + ix=1 + do 11 i=1,n + sy(iy)=sx(ix) + ix=ix+incx + iy=iy+incy +11 continue + endif +c + return + end + + function ssum(n,sx,incx) +c + IMPLICIT NONE +c + integer n,incx,i,ix + real ssum,sx((n-1)*incx+1) +c + ssum=0. + if (incx.eq.1) then + do 10 i=1,n + ssum=ssum+sx(i) +10 continue + else + ix=1 + do 11 i=1,n + ssum=ssum+sx(ix) + ix=ix+incx +11 continue + endif +c + return + end +#endif Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/defrun.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/defrun.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/defrun.F (revision 1634) @@ -0,0 +1,497 @@ +! +! $Id$ +! +c +c + SUBROUTINE defrun( tapedef, etatinit, clesphy0 ) +c + USE control_mod + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +#include "clesph0.h" +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + INTEGER tapeout + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy,tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + + tapeout = 6 + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- + + OPEN( tapedef,file ='gcm.def',status='old',form='formatted') + + + READ (tapedef,9000) ch1,ch2,ch3 + WRITE(tapeout,9000) ch1,ch2,ch3 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dayref + WRITE(tapeout,9001) ch1,'dayref' + WRITE(tapeout,*) dayref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) anneeref + WRITE(tapeout,9001) ch1,'anneeref' + WRITE(tapeout,*) anneeref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nday + WRITE(tapeout,9001) ch1,'nday' + WRITE(tapeout,*) nday + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) day_step + WRITE(tapeout,9001) ch1,'day_step' + WRITE(tapeout,*) day_step + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iperiod + WRITE(tapeout,9001) ch1,'iperiod' + WRITE(tapeout,*) iperiod + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iapp_tracvl + WRITE(tapeout,9001) ch1,'iapp_tracvl' + WRITE(tapeout,*) iapp_tracvl + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iconser + WRITE(tapeout,9001) ch1,'iconser' + WRITE(tapeout,*) iconser + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iecri + WRITE(tapeout,9001) ch1,'iecri' + WRITE(tapeout,*) iecri + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) periodav + WRITE(tapeout,9001) ch1,'periodav' + WRITE(tapeout,*) periodav + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dissip_period + WRITE(tapeout,9001) ch1,'dissip_period' + WRITE(tapeout,*) dissip_period + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) lstardis + WRITE(tapeout,9001) ch1,'lstardis' + WRITE(tapeout,*) lstardis + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergdiv + WRITE(tapeout,9001) ch1,'nitergdiv' + WRITE(tapeout,*) nitergdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergrot + WRITE(tapeout,9001) ch1,'nitergrot' + WRITE(tapeout,*) nitergrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) niterh + WRITE(tapeout,9001) ch1,'niterh' + WRITE(tapeout,*) niterh + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagdiv + WRITE(tapeout,9001) ch1,'tetagdiv' + WRITE(tapeout,*) tetagdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagrot + WRITE(tapeout,9001) ch1,'tetagrot' + WRITE(tapeout,*) tetagrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetatemp + WRITE(tapeout,9001) ch1,'tetatemp' + WRITE(tapeout,*) tetatemp + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) coefdis + WRITE(tapeout,9001) ch1,'coefdis' + WRITE(tapeout,*) coefdis +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) purmats + WRITE(tapeout,9001) ch1,'purmats' + WRITE(tapeout,*) purmats + +c ............................................................... + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_phys + WRITE(tapeout,9001) ch1,'iflag_phys' + WRITE(tapeout,*) iflag_phys + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iphysiq + WRITE(tapeout,9001) ch1,'iphysiq' + WRITE(tapeout,*) iphysiq + + +ccc .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ... +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) cycle_diurne + WRITE(tapeout,9001) ch1,'cycle_diurne' + WRITE(tapeout,*) cycle_diurne + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) soil_model + WRITE(tapeout,9001) ch1,'soil_model' + WRITE(tapeout,*) soil_model + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) new_oliq + WRITE(tapeout,9001) ch1,'new_oliq' + WRITE(tapeout,*) new_oliq + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orodr + WRITE(tapeout,9001) ch1,'ok_orodr' + WRITE(tapeout,*) ok_orodr + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orolf + WRITE(tapeout,9001) ch1,'ok_orolf' + WRITE(tapeout,*) ok_orolf + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_limitvrai + WRITE(tapeout,9001) ch1,'ok_limitvrai' + WRITE(tapeout,*) ok_limitvrai + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nbapp_rad + WRITE(tapeout,9001) ch1,'nbapp_rad' + WRITE(tapeout,*) nbapp_rad + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_con + WRITE(tapeout,9001) ch1,'iflag_con' + WRITE(tapeout,*) iflag_con + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + clesphy0(1) = REAL( iflag_con ) + clesphy0(2) = REAL( nbapp_rad ) + + IF( cycle_diurne ) clesphy0(3) = 1. + IF( soil_model ) clesphy0(4) = 1. + IF( new_oliq ) clesphy0(5) = 1. + IF( ok_orodr ) clesphy0(6) = 1. + IF( ok_orolf ) clesphy0(7) = 1. + IF( ok_limitvrai ) clesphy0(8) = 1. + + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clonn + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clonn + IF( ABS(clon - clonn).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clatt + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clatt + + IF( ABS(clat - clatt).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismxx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismxx + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismyy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismyy + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypbb + WRITE(tapeout,9001) ch1,'fxyhypbb' + WRITE(tapeout,*) fxyhypbb + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F' + *, ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t' + *, ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomxx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomyy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomyy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauxx + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) tauxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauyy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauyy + + IF( fxyhypb ) THEN + + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de taux passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de tauy passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinuss + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinuss + + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF + ENDIF +c + WRITE(6,*) ' alphax alphay defrun ',alphax,alphay + + CLOSE(tapedef) + + RETURN +c ............................................... +c +100 CONTINUE +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clon + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clon +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clat + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clat + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismy + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) '*** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypb + WRITE(tapeout,9001) ch1,'fxyhypb' + WRITE(tapeout,*) fxyhypb + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) taux + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) taux +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinus + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinus + + WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay +c +9000 FORMAT(3(/,a72)) +9001 FORMAT(/,a72,/,a12) +cc + CLOSE(tapedef) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/description.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/description.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/description.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + character (len=120) :: descript + common /titre/descript Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diagedyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diagedyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diagedyn.F (revision 1634) @@ -0,0 +1,321 @@ +! +! $Id$ +! + +C====================================================================== + SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime + e , ucov , vcov , ps, p ,pk , teta , q, ql) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la dynamique. +C +C +c====================================================================== +C Arguments: +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +C uconv, vconv-input-R- vents covariants (m/s) +C ps-------input-R- Surface pressure (Pa) +C p--------input-R- pressure at the interfaces +C pk-------input-R- pk= (p/Pref)**kappa +c teta-----input-R- potential temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c aire-----input-R- mesh surafce (m2) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C +C J.L. Dufresne, July 2002 +c====================================================================== + + IMPLICIT NONE +C +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" + +#ifdef CPP_EARTH +#include "../phylmd/YOMCST.h" +#include "../phylmd/YOETHF.h" +#endif +C + INTEGER imjmp1 + PARAMETER( imjmp1=iim*jjp1) +c Input variables + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pk (ip1jmp1,llm ) ! = (p/Pref)**kappa + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm) ! champs eau vapeur + REAL ql(ip1jmp1,llm) ! champs eau liquide + + +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL masse(ip1jmp1,llm) ! masse d'air + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL ecin(ip1jmp1,llm) + + REAL zaire(imjmp1) + REAL zps(imjmp1) + REAL zairm(imjmp1,llm) + REAL zecin(imjmp1,llm) + REAL zpaprs(imjmp1,llm) + REAL zpk(imjmp1,llm) + REAL zt(imjmp1,llm) + REAL zh(imjmp1,llm) + REAL zqw(imjmp1,llm) + REAL zql(imjmp1,llm) + REAL zqs(imjmp1,llm) + + REAL zqw_col(imjmp1) + REAL zql_col(imjmp1) + REAL zqs_col(imjmp1) + REAL zec_col(imjmp1) + REAL zh_dair_col(imjmp1) + REAL zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k, jj, ij , l ,ip1jjm1 +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre + + +#ifdef CPP_EARTH +c====================================================================== +C Compute Kinetic enrgy + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL massdair( p, masse ) +c====================================================================== +C +C + print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?' + return +C On ne garde les donnees que dans les colonnes i=1,iim + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zaire(i)=aire(ij+ip1jjm1) + zps(i)=ps(ij+ip1jjm1) + ENDDO + ENDDO +C 3D arrays + DO l = 1, llm + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zairm(i,l) = masse(ij+ip1jjm1,l) + zecin(i,l) = ecin(ij+ip1jjm1,l) + zpaprs(i,l) = p(ij+ip1jjm1,l) + zpk(i,l) = pk(ij+ip1jjm1,l) + zh(i,l) = teta(ij+ip1jjm1,l) + zqw(i,l) = q(ij+ip1jjm1,l) + zql(i,l) = ql(ij+ip1jjm1,l) + zqs(i,l) = 0. + ENDDO + ENDDO + ENDDO +C +C Reset variables + DO i = 1, imjmp1 + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, llm + DO i = 1, imjmp1 +C Watter mass + zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +zecin(i,k)*zairm(i,k) +C Air enthalpy + zt(i,k)= zh(i,k) * zpk(i,k) / RCPD + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) + $ - RLVTT*zql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) + $ - RLSTT*zqs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,imjmp1 + qw_tot = qw_tot + zqw_col(i) + ql_tot = ql_tot + zql_col(i) + qs_tot = qs_tot + zqs_col(i) + ec_tot = ec_tot + zec_col(i) + h_dair_tot = h_dair_tot + zh_dair_col(i) + h_qw_tot = h_qw_tot + zh_qw_col(i) + h_ql_tot = h_ql_tot + zh_ql_col(i) + h_qs_tot = h_qs_tot + zh_qs_col(i) + airetot=airetot+zaire(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) +C WRITE(6,9003) tit,pas(idiag), ec_tot + 9003 format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6)) + WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec + 9004 format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C +#else + write(lunout,*)'diagedyn: Needs Earth physics to function' +#endif +! #endif of #ifdef CPP_EARTH + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dissip_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dissip_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dissip_p.F (revision 1634) @@ -0,0 +1,207 @@ + SUBROUTINE dissip_p( vcov,ucov,teta,p, dv,du,dh ) +c + USE parallel + USE write_field_p + IMPLICIT NONE + + +c .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... +c ( 10/01/98 ) + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c Dissipation horizontale +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comdissnew.h" +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL p( ip1jmp1,llmp1 ) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm) + +c Local: +c ------ + + REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm) + REAL grx(ip1jmp1,llm),gry(ip1jm,llm) + REAL te1dt(llm),te2dt(llm),te3dt(llm) + REAL deltapres(ip1jmp1,llm) + + INTEGER l,ij + + REAL SSUM + integer :: ijb,ije +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + te1dt(l) = tetaudiv(l) * dtdiss + te2dt(l) = tetaurot(l) * dtdiss + te3dt(l) = tetah(l) * dtdiss + ENDDO +c$OMP END DO NOWAIT +c CALL initial0( ijp1llm, du ) +c CALL initial0( ijmllm , dv ) +c CALL initial0( ijp1llm, dh ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du(ijb:ije,l)=0 + dh(ijb:ije,l)=0 + ENDDO +c$OMP END DO NOWAIT + + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dv(ijb:ije,l)=0 + ENDDO +c$OMP END DO NOWAIT + +c----------------------------------------------------------------------- +c Calcul de la dissipation: +c ------------------------- + +c Calcul de la partie grad ( div ) : +c ------------------------------------- + + + + IF(lstardis) THEN +c IF (.FALSE.) THEN + CALL gradiv2_p( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ELSE + CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ENDIF + + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + if (pole_nord) then + DO ij = 1, iip1 + gdx( ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + gdx(ij+ip1jm,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb,ije + dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c calcul de la partie n X grad ( rot ): +c --------------------------------------- + + IF(lstardis) THEN +c IF (.FALSE.) THEN + CALL nxgraro2_p( llm,ucov, vcov, nitergrot,grx,gry ) + ELSE + CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry ) + ENDIF + + + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + if (pole_nord) then + DO ij = 1, iip1 + grx(ij,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb, ije + dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) + ENDDO + + ENDDO +c$OMP END DO NOWAIT + +c calcul de la partie div ( grad ): +c ----------------------------------- + + + IF(lstardis) THEN +c IF (.FALSE.) THEN + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + CALL divgrad2_p( llm,teta, deltapres ,niterh, gdx ) + ELSE + CALL divgrad_p ( llm,teta, niterh, gdx ) + ENDIF + +c call write_field3d_p('gdx2',reshape(gdx,(/iip1,jmp1,llm/))) +c stop + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = ijb,ije + dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/disvert.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/disvert.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/disvert.F90 (revision 1634) @@ -0,0 +1,150 @@ +! $Id$ + +SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,scaleheight) + + ! Auteur : P. Le Van + + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "iniprint.h" + include "logic.h" + + ! s = sigma ** kappa : coordonnee verticale + ! dsig(l) : epaisseur de la couche l ds la coord. s + ! sig(l) : sigma a l'interface des couches l et l-1 + ! ds(l) : distance entre les couches l et l-1 en coord.s + + real,intent(in) :: pa, preff + real,intent(out) :: ap(llmp1), bp(llmp1) + real,intent(out) :: dpres(llm), nivsigs(llm), nivsig(llmp1) + real,intent(out) :: presnivs(llm) + real,intent(out) :: scaleheight + + REAL sig(llm+1), dsig(llm) + real zk, zkm1, dzk1, dzk2, k0, k1 + + INTEGER l + REAL dsigmin + REAL alpha, beta, deltaz + INTEGER iostat + REAL x + character(len=*),parameter :: modname="disvert" + + !----------------------------------------------------------------------- + + ! default scaleheight is 8km for earth + scaleheight=8. + + OPEN(99, file='sigma.def', status='old', form='formatted', iostat=iostat) + + IF (iostat == 0) THEN + ! cas 1 on lit les options dans sigma.def: + READ(99, *) scaleheight ! hauteur d'echelle 8. + READ(99, *) deltaz ! epaiseur de la premiere couche 0.04 + READ(99, *) beta ! facteur d'acroissement en haut 1.3 + READ(99, *) k0 ! nombre de couches dans la transition surf + READ(99, *) k1 ! nombre de couches dans la transition haute + CLOSE(99) + alpha=deltaz/(llm*scaleheight) + write(lunout, *)trim(modname),':scaleheight, alpha, k0, k1, beta', & + scaleheight, alpha, k0, k1, beta + + alpha=deltaz/tanh(1./k0)*2. + zkm1=0. + sig(1)=1. + do l=1, llm + sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) & + *exp(-alpha/scaleheight*tanh((llm-k1)/k0) & + *beta**(l-(llm-k1))/log(beta)) + zk=-scaleheight*log(sig(l+1)) + + dzk1=alpha*tanh(l/k0) + dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta) + write(lunout, *)l, sig(l+1), zk, zk-zkm1, dzk1, dzk2 + zkm1=zk + enddo + + sig(llm+1)=0. + + DO l = 1, llm + dsig(l) = sig(l)-sig(l+1) + end DO + ELSE + if (ok_strato) then + if (llm==39) then + dsigmin=0.3 + else if (llm==50) then + dsigmin=1. + else + write(lunout,*) trim(modname), & + ' ATTENTION discretisation z a ajuster' + dsigmin=1. + endif + write(lunout,*) trim(modname), & + ' Discretisation verticale DSIGMIN=',dsigmin + endif + + DO l = 1, llm + x = 2*asin(1.) * (l - 0.5) / (llm + 1) + + IF (ok_strato) THEN + dsig(l) =(dsigmin + 7. * SIN(x)**2) & + *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2 + ELSE + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + ENDIF + ENDDO + dsig = dsig / sum(dsig) + sig(llm+1) = 0. + DO l = llm, 1, -1 + sig(l) = sig(l+1) + dsig(l) + ENDDO + ENDIF + + DO l=1, llm + nivsigs(l) = REAL(l) + ENDDO + + DO l=1, llmp1 + nivsig(l)= REAL(l) + ENDDO + + ! .... Calculs de ap(l) et de bp(l) .... + ! ..... pa et preff sont lus sur les fichiers start par lectba ..... + + bp(llmp1) = 0. + + DO l = 1, llm + bp(l) = EXP( 1. -1./( sig(l)*sig(l)) ) + ap(l) = pa * ( sig(l) - bp(l) ) + ENDDO + + bp(1)=1. + ap(1)=0. + + ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) ) + + write(lunout, *) trim(modname),': BP ' + write(lunout, *) bp + write(lunout, *) trim(modname),': AP ' + write(lunout, *) ap + + write(lunout, *) 'Niveaux de pressions approximatifs aux centres des' + write(lunout, *)'couches calcules pour une pression de surface =', preff + write(lunout, *) 'et altitudes equivalentes pour une hauteur d echelle de ' + write(lunout, *) scaleheight,' km' + DO l = 1, llm + dpres(l) = bp(l) - bp(l+1) + presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff ) + write(lunout, *)'PRESNIVS(', l, ')=', presnivs(l), ' Z ~ ', & + log(preff/presnivs(l))*scaleheight & + , ' DZ ~ ', scaleheight*log((ap(l)+bp(l)*preff)/ & + max(ap(l+1)+bp(l+1)*preff, 1.e-10)) + ENDDO + + write(lunout, *) trim(modname),': PRESNIVS ' + write(lunout, *) presnivs + +END SUBROUTINE disvert Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/disvert_noterre.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/disvert_noterre.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/disvert_noterre.F (revision 1634) @@ -0,0 +1,331 @@ +! $Id: $ + SUBROUTINE disvert_noterre + +c Auteur : F. Forget Y. Wanherdrick, P. Levan +c Nouvelle version 100% Mars !! +c On l'utilise aussi pour Venus et Titan, legerment modifiee. + +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "logic.h" +#include "iniprint.h" +c +c======================================================================= +c Discretisation verticale en coordonnée hybride (ou sigma) +c +c======================================================================= +c +c declarations: +c ------------- +c +c + INTEGER l,ll + REAL snorm + REAL alpha,beta,gama,delta,deltaz + real quoi,quand + REAL zsig(llm),sig(llm+1) + INTEGER np,ierr + integer :: ierr1,ierr2,ierr3,ierr4 + REAL x + + REAL SSUM + EXTERNAL SSUM + real newsig + REAL dz0,dz1,nhaut,sig1,esig,csig,zz + real tt,rr,gg, prevz + real s(llm),dsig(llm) + real pseudoalt(llm) + + integer iz + real z, ps,p + character(len=*),parameter :: modname="disvert_noterre" + +c +c----------------------------------------------------------------------- +c +! Initializations: +! pi=2.*ASIN(1.) ! already done in iniconst + + hybrid=.true. ! default value for hybrid (ie: use hybrid coordinates) + CALL getin('hybrid',hybrid) + write(lunout,*) trim(modname),': hybrid=',hybrid + +! Ouverture possible de fichiers typiquement E.T. + + open(99,file="esasig.def",status='old',form='formatted', + s iostat=ierr2) + if(ierr2.ne.0) then + close(99) + open(99,file="z2sig.def",status='old',form='formatted', + s iostat=ierr4) + endif + +c----------------------------------------------------------------------- +c cas 1 on lit les options dans esasig.def: +c ---------------------------------------- + + IF(ierr2.eq.0) then + +c Lecture de esasig.def : +c Systeme peu souple, mais qui respecte en theorie +c La conservation de l'energie (conversion Energie potentielle +c <-> energie cinetique, d'apres la note de Frederic Hourdin... + + write(lunout,*)'*****************************' + write(lunout,*)'WARNING reading esasig.def' + write(lunout,*)'*****************************' + READ(99,*) scaleheight + READ(99,*) dz0 + READ(99,*) dz1 + READ(99,*) nhaut + CLOSE(99) + + dz0=dz0/scaleheight + dz1=dz1/scaleheight + + sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut) + + esig=1. + + do l=1,20 + esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.) + enddo + csig=(1./sig1-1.)/(exp(esig)-1.) + + DO L = 2, llm + zz=csig*(exp(esig*(l-1.))-1.) + sig(l) =1./(1.+zz) + & * tanh(.5*(llm+1-l)/nhaut) + ENDDO + sig(1)=1. + sig(llm+1)=0. + quoi = 1. + 2.* kappa + s( llm ) = 1. + s(llm-1) = quoi + IF( llm.gt.2 ) THEN + DO ll = 2, llm-1 + l = llm+1 - ll + quand = sig(l+1)/ sig(l) + s(l-1) = quoi * (1.-quand) * s(l) + quand * s(l+1) + ENDDO + END IF +c + snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2) + DO l = 1, llm + s(l) = s(l)/ snorm + ENDDO + +c----------------------------------------------------------------------- +c cas 2 on lit les options dans z2sig.def: +c ---------------------------------------- + + ELSE IF(ierr4.eq.0) then + write(lunout,*)'****************************' + write(lunout,*)'Reading z2sig.def' + write(lunout,*)'****************************' + + READ(99,*) scaleheight + do l=1,llm + read(99,*) zsig(l) + end do + CLOSE(99) + + sig(1) =1 + do l=2,llm + sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + + & exp(-zsig(l-1)/scaleheight) ) + end do + sig(llm+1) =0 + +c----------------------------------------------------------------------- + ELSE + write(lunout,*) 'didn t you forget something ??? ' + write(lunout,*) 'We need file z2sig.def ! (OR esasig.def)' + stop + ENDIF +c----------------------------------------------------------------------- + + DO l=1,llm + nivsigs(l) = REAL(l) + ENDDO + + DO l=1,llmp1 + nivsig(l)= REAL(l) + ENDDO + + +c----------------------------------------------------------------------- +c .... Calculs de ap(l) et de bp(l) .... +c ......................................... +c +c ..... pa et preff sont lus sur les fichiers start par dynetat0 ..... +c----------------------------------------------------------------------- +c + + if (hybrid) then ! use hybrid coordinates + write(lunout,*) "*********************************" + write(lunout,*) "Using hybrid vertical coordinates" + write(lunout,*) +c Coordonnees hybrides avec mod + DO l = 1, llm + + call sig_hybrid(sig(l),pa,preff,newsig) + bp(l) = EXP( 1. - 1./(newsig**2) ) + ap(l) = pa * (newsig - bp(l) ) + enddo + bp(llmp1) = 0. + ap(llmp1) = 0. + else ! use sigma coordinates + write(lunout,*) "********************************" + write(lunout,*) "Using sigma vertical coordinates" + write(lunout,*) +c Pour ne pas passer en coordonnees hybrides + DO l = 1, llm + ap(l) = 0. + bp(l) = sig(l) + ENDDO + ap(llmp1) = 0. + endif + + bp(llmp1) = 0. + + write(lunout,*) trim(modname),': BP ' + write(lunout,*) bp + write(lunout,*) trim(modname),': AP ' + write(lunout,*) ap + +c Calcul au milieu des couches : +c WARNING : le choix de placer le milieu des couches au niveau de +c pression intermédiaire est arbitraire et pourrait etre modifié. +c Le calcul du niveau pour la derniere couche +c (on met la meme distance (en log pression) entre P(llm) +c et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est +c Specifique. Ce choix est spécifié ici ET dans exner_milieu.F + + DO l = 1, llm-1 + aps(l) = 0.5 *( ap(l) +ap(l+1)) + bps(l) = 0.5 *( bp(l) +bp(l+1)) + ENDDO + + if (hybrid) then + aps(llm) = aps(llm-1)**2 / aps(llm-2) + bps(llm) = 0.5*(bp(llm) + bp(llm+1)) + else + bps(llm) = bps(llm-1)**2 / bps(llm-2) + aps(llm) = 0. + end if + + write(lunout,*) trim(modname),': BPs ' + write(lunout,*) bps + write(lunout,*) trim(modname),': APs' + write(lunout,*) aps + + DO l = 1, llm + presnivs(l) = aps(l)+bps(l)*preff + pseudoalt(l) = -scaleheight*log(presnivs(l)/preff) + ENDDO + + write(lunout,*)trim(modname),' : PRESNIVS' + write(lunout,*)presnivs + write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ', + & 'height of ',scaleheight,' km)' + write(lunout,*)pseudoalt + +c -------------------------------------------------- +c This can be used to plot the vertical discretization +c (> xmgrace -nxy testhybrid.tab ) +c -------------------------------------------------- +c open (53,file='testhybrid.tab') +c scaleheight=15.5 +c do iz=0,34 +c z = -5 + min(iz,34-iz) +c approximation of scale height for Venus +c scaleheight = 15.5 - z/55.*10. +c ps = preff*exp(-z/scaleheight) +c zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff) +c do l=2,llm +c approximation of scale height for Venus +c if (zsig(l-1).le.55.) then +c scaleheight = 15.5 - zsig(l-1)/55.*10. +c else +c scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2. +c endif +c zsig(l)= zsig(l-1)-scaleheight* +c . log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps)) +c end do +c write(53,'(I3,50F10.5)') iz, zsig +c end do +c close(53) +c -------------------------------------------------- + + + RETURN + END + +c ************************************************************ + subroutine sig_hybrid(sig,pa,preff,newsig) +c ---------------------------------------------- +c Subroutine utilisee pour calculer des valeurs de sigma modifie +c pour conserver les coordonnees verticales decrites dans +c esasig.def/z2sig.def lors du passage en coordonnees hybrides +c F. Forget 2002 +c Connaissant sig (niveaux "sigma" ou on veut mettre les couches) +c L'objectif est de calculer newsig telle que +c (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig +c Cela ne se résoud pas analytiquement: +c => on résoud par iterration bourrine +c ---------------------------------------------- +c Information : where exp(1-1./x**2) become << x +c x exp(1-1./x**2) /x +c 1 1 +c 0.68 0.5 +c 0.5 1.E-1 +c 0.391 1.E-2 +c 0.333 1.E-3 +c 0.295 1.E-4 +c 0.269 1.E-5 +c 0.248 1.E-6 +c => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25 + + + implicit none + real x1, x2, sig,pa,preff, newsig, F + integer j + + newsig = sig + x1=0 + x2=1 + if (sig.ge.1) then + newsig= sig + else if (sig*preff/pa.ge.0.25) then + DO J=1,9999 ! nombre d''iteration max + F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig +c write(0,*) J, ' newsig =', newsig, ' F= ', F + if (F.gt.1) then + X2 = newsig + newsig=(X1+newsig)*0.5 + else + X1 = newsig + newsig=(X2+newsig)*0.5 + end if +c Test : on arete lorsque on approxime sig à moins de 0.01 m près +c (en pseudo altitude) : + IF(abs(10.*log(F)).LT.1.E-5) goto 999 + END DO + else ! if (sig*preff/pa.le.0.25) then + newsig= sig*preff/pa + end if + 999 continue + Return + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg.F (revision 1634) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE diverg(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_gam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_gam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_gam.F (revision 1634) @@ -0,0 +1,80 @@ +! +! $Header$ +! + SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_gam_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_gam_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_gam_p.F (revision 1634) @@ -0,0 +1,97 @@ + SUBROUTINE diverg_gam_p(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE parallel + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iim + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + endif + 10 CONTINUE +c$OMP END DO NOWAIT +c + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/diverg_p.F (revision 1634) @@ -0,0 +1,106 @@ + SUBROUTINE diverg_p(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE parallel + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER ijb,ije +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iim + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + endif + + + 10 CONTINUE +c$OMP END DO NOWAIT +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb,ije + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergf.F (revision 1634) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE divergf(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergf_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergf_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergf_p.F (revision 1634) @@ -0,0 +1,115 @@ + SUBROUTINE divergf_p(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE PARALLEL + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO + +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1,iim + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + + endif + + 10 CONTINUE +c$OMP END DO NOWAIT + +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb,ije + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divergst.F (revision 1634) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE divergst(klevel,x,y,div) + IMPLICIT NONE +c +c P. Le Van +c +c ****************************************************************** +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y... +c x et y etant des composantes contravariantes ... +c **************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c ------------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER ij,l,i + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO 1 ij = iip2, ip1jm - 1 + div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l) + 1 CONTINUE +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + 3 CONTINUE +c +c .... calcul aux poles ..... +c +c + DO 5 i = 1,iim + aiy1(i)= y(i,l) + aiy2(i)= y(i+ip1jmi1,l) + 5 CONTINUE + sumypn = SSUM ( iim,aiy1,1 ) + sumyps = SSUM ( iim,aiy2,1 ) + DO 7 i = 1,iip1 + div( i , l ) = - sumypn/iim + div( i + ip1jm, l ) = sumyps/iim + 7 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad.F (revision 1634) @@ -0,0 +1,56 @@ +! +! $Header$ +! + SUBROUTINE divgrad (klevel,h, lh, divgra ) + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c +c +c + CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) +c + DO 10 iter = 1,lh + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1 ) + + CALL grad (klevel,divgra, ghx , ghy ) + CALL diverg (klevel, ghx , ghy , divgra ) + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1) + + DO 5 l = 1,klevel + DO 4 ij = 1, ip1jmp1 + divgra( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad2.F (revision 1634) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra( ip1jmp1,klevel) +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + + CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + +c + CALL laplacien( klevel, divgra, divgra ) + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 + CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c + CALL laplacien ( klevel, divgra, divgra ) +c + DO l = 1,klevel + DO ij = 1,ip1jmp1 + divgra(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad2_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad2_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad2_p.F (revision 1634) @@ -0,0 +1,120 @@ + SUBROUTINE divgrad2_p ( klevel, h, deltapres, lh, divgra_out ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + USE parallel + USE times + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra_out( ip1jmp1,klevel) + REAL,SAVE :: divgra( ip1jmp1,llm) + +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + Type(Request) :: request_dissip + INTEGER ijb,ije +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + +c CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + divgra(ijb:ije,l)=h(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_p( klevel, divgra, divgra ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL laplacien_gam_p ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_p ( klevel, divgra, divgra ) +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = ijb,ije + divgra_out(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/divgrad_p.F (revision 1634) @@ -0,0 +1,91 @@ + SUBROUTINE divgrad_p (klevel,h, lh, divgra_out ) + USE parallel + USE times + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra_out( ip1jmp1,klevel ) + REAL,SAVE :: divgra( ip1jmp1,llm ) + +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + divgra(ijb:ije,l)=h(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c + +c + DO 10 iter = 1,lh + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1 ) + +c call exchange_Hallo(divgra,ip1jmp1,llm,0,1) +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(divgra,ip1jmp1,llm,1,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + CALL grad_p (klevel,divgra, ghx , ghy ) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(ghy,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL diverg_p (klevel, ghx , ghy , divgra ) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,klevel + DO 4 ij = ijb, ije + divgra_out( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c$OMP END DO NOWAIT +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dteta1_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dteta1_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dteta1_p.F (revision 1634) @@ -0,0 +1,88 @@ + SUBROUTINE dteta1_p ( teta, pbaru, pbarv, dteta) + USE parallel + USE write_field_p + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c Modif F.Forget 03/94 (on retire q et dq pour construire dteta1) +c +c ******************************************************************** +c ... calcul du terme de convergence horizontale du flux d'enthalpie +c potentielle ...... +c ******************************************************************** +c .. teta,pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c dteta sont des arguments de sortie pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" + + REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL dteta( ip1jmp1,llm ) + INTEGER l,ij + + REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm ) + +c + INTEGER ijb,ije,jjb,jje + + + jjb=jj_begin + jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb, ije - 1 + hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) ) + 1 CONTINUE + +c .... correction pour hbxu(iip1,j,l) ..... +c .... hbxu(iip1,j,l)= hbxu(1,j,l) .... + +CDIR$ IVDEP + DO 2 ij = ijb+iip1-1, ije, iip1 + hbxu( ij, l ) = hbxu( ij - iim, l ) + 2 CONTINUE + + ijb=ij_begin-iip1 + if (pole_nord) ijb=ij_begin + + DO 3 ij = ijb,ije + hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) ) + 3 CONTINUE + + if (.not. pole_sud) then + hbxu(ije+1:ije+iip1,l) = 0 + hbyv(ije+1:ije+iip1,l) = 0 + endif + + 5 CONTINUE +c$OMP END DO NOWAIT + + + CALL convflu_p ( hbxu, hbyv, llm, dteta ) + + +c stockage dans dh de la convergence horizont. filtree' du flux +c .... ........... +c d'enthalpie potentielle . + + + CALL filtreg_p( dteta,jjb,jje,jjp1, llm, 2, 2, .true., 1) + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dudv1_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dudv1_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dudv1_p.F (revision 1634) @@ -0,0 +1,64 @@ + SUBROUTINE dudv1_p ( vorpot, pbaru, pbarv, du, dv ) + USE parallel + IMPLICIT NONE +c +c----------------------------------------------------------------------- +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul du terme de rotation +c ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. +c vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. +c du et dv sont des arguments de sortie pour le s-pg .. +c +c----------------------------------------------------------------------- + +#include "dimensions.h" +#include "paramet.h" + + REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) , + * pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm ) + INTEGER l,ij,ijb,ije +c +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,llm +c + ijb=ij_begin + ije=ij_end + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 2 ij = ijb, ije-1 + du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * + * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + + * pbarv( ij , l) + pbarv(ij+ 1 , l) ) + 2 CONTINUE + + +c + if (pole_nord) ijb=ij_begin + + DO 3 ij = ijb, ije-1 + dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * + * ( pbaru(ij, l) + pbaru(ij+1 , l) + + * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) + 3 CONTINUE +c +c .... correction pour dv( 1,j,l ) ..... +c .... dv(1,j,l)= dv(iip1,j,l) .... +c +CDIR$ IVDEP + DO 4 ij = ijb, ije, iip1 + dv( ij,l ) = dv( ij + iim, l ) + 4 CONTINUE +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dudv2_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dudv2_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dudv2_p.F (revision 1634) @@ -0,0 +1,69 @@ + SUBROUTINE dudv2_p ( teta, pkf, bern, du, dv ) + USE parallel + IMPLICIT NONE +c +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ***************************************************************** +c ..... calcul du terme de pression (gradient de p/densite ) et +c du terme de ( -gradient de la fonction de Bernouilli ) ... +c ***************************************************************** +c Ces termes sont ajoutes a d(ucov)/dt et a d(vcov)/dt .. +c +c +c teta , pkf, bern sont des arguments d'entree pour le s-pg .... +c du et dv sont des arguments de sortie pour le s-pg .... +c +c======================================================================= +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ), + * du( ip1jmp1,llm ), dv( ip1jm,llm ) + INTEGER l,ij,ijb,ije +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 2 ij = ijb, ije - 1 + du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * + * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) + 2 CONTINUE +c +c +c ..... correction pour du(iip1,j,l), j=2,jjm ...... +c ... du(iip1,j,l) = du(1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = ijb+iip1-1, ije, iip1 + du( ij,l ) = du( ij - iim,l ) + 3 CONTINUE +c +c + if (pole_nord) ijb=ijb-iip1 + + DO 4 ij = ijb,ije + dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * + * ( pkf(ij+iip1,l) - pkf( ij,l ) ) + * + bern( ij+iip1,l ) - bern( ij ,l ) + 4 CONTINUE +c + 5 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dump2d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dump2d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dump2d.F (revision 1634) @@ -0,0 +1,46 @@ +! +! $Id$ +! + SUBROUTINE dump2d(im,jm,z,nom_z) + IMPLICIT NONE + INTEGER im,jm + REAL z(im,jm) + CHARACTER (len=*) :: nom_z + + INTEGER i,j,imin,illm,jmin,jllm + REAL zmin,zllm + + WRITE(*,*) "dump2d: ",trim(nom_z) + + zmin=z(1,1) + zllm=z(1,1) + imin=1 + illm=1 + jmin=1 + jllm=1 + + DO j=1,jm + DO i=1,im + IF(z(i,j).GT.zllm) THEN + illm=i + jllm=j + zllm=z(i,j) + ENDIF + IF(z(i,j).LT.zmin) THEN + imin=i + jmin=j + zmin=z(i,j) + ENDIF + ENDDO + ENDDO + + PRINT*,'MIN: ',zmin + PRINT*,'MAX: ',zllm + + IF(zllm.GT.zmin) THEN + DO j=1,jm + WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im) + ENDDO + ENDIF + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynetat0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynetat0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynetat0.F (revision 1634) @@ -0,0 +1,386 @@ +! +! $Id $ +! + SUBROUTINE dynetat0(fichnom,vcov,ucov, + . teta,q,masse,ps,phis,time) + + USE infotrac + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "logic.h" +#include "iniprint.h" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + + REAL time + +c Variables +c + INTEGER length,iq + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr, nid, nvarid + +c----------------------------------------------------------------------- + +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(lunout,*)'dynetat0: Pb d''ouverture du fichier start.nc' + write(lunout,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) +c ................................................................. +c +c + write(lunout,*)'dynetat0: rad,omeg,g,cpp,kappa', + & rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + + IF(nqtot.GE.1) THEN + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le traceur <"//trim(tname(iq))// + & "> est absent" + write(lunout,*)" Il est donc initialise a zero" + q(:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + ENDIF + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps) +#endif + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynredem.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynredem.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynredem.F (revision 1634) @@ -0,0 +1,765 @@ +! +! $Id$ +! +c + SUBROUTINE dynredem0(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac + + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + + +c----------------------------------------------------------------------- + modname='dynredem0' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + tab_cntrl(4) = REAL(day_ref) + tab_cntrl(5) = REAL(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = REAL(iday_end) + tab_cntrl(31) = REAL(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + write(lunout,*)"dynredem0: Pb d ouverture du fichier " + & //trim(fichnom) + write(lunout,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + IF(nqtot.GE.1) THEN + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO + ENDIF +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + write(lunout,*)'dynredem0: iim,jjm,llm,iday_end', + & iim,jjm,llm,iday_end + write(lunout,*)'dynredem0: rad,omeg,g,cpp,kappa', + & rad,omeg,g,cpp,kappa + + RETURN + END + SUBROUTINE dynredem1(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE infotrac + USE control_mod + + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "iniprint.h" + + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*)"dynredem1: Pb. d ouverture "//trim(fichnom) + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*) NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + write(lunout,*) "dynredem1: Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = REAL(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable ucov n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable vcov n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable teta n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(lunout,*)'dynredem1: Pb d''ouverture du fichier', + & ' start_trac.nc' + write(lunout,*)' ierr = ', ierr_file + ENDIF + END IF + + IF(nqtot.GE.1) THEN + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="Variable tname(iq) n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + write(lunout,*) "dynredem1: ",trim(tname(iq)), + & " est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable "// + & trim(tname(iq))//" n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + write(lunout,*) "dynredem1: ",trim(tname(iq)), + & " est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Lecture echouee pour"// + & trim(tname(iq)) + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable "// + & trim(tname(iq))//" n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable "// + & trim(tname(iq))//" n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + ENDIF +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable masse n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Variable ps n est pas definie" + ierr=1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynredem_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynredem_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/dynredem_p.F (revision 1634) @@ -0,0 +1,769 @@ +! +! $Id$ +! +c + SUBROUTINE dynredem0_p(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE infotrac + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + +c----------------------------------------------------------------------- + if (mpi_rank==0) then + + modname='dynredem0_p' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + tab_cntrl(4) = REAL(day_ref) + tab_cntrl(5) = REAL(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = REAL(iday_end) + tab_cntrl(31) = REAL(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)" Pb d ouverture du fichier "//fichnom + WRITE(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + + PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end + PRINT*,'rad,omeg,g,cpp,kappa', + , rad,omeg,g,cpp,kappa + + endif ! mpi_rank==0 + RETURN + END + SUBROUTINE dynredem1_p(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE parallel + USE infotrac + USE control_mod + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + logical exist_file + + call Gather_Field(ucov,ip1jmp1,llm,0) + call Gather_Field(vcov,ip1jm,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(masse,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + + + if (mpi_rank==0) then + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Pb. d ouverture "//fichnom + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + PRINT*, "Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = REAL(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + inquire(FILE="start_trac.nc", EXIST=exist_file) + print *, "EXIST", exist_file + if (exist_file) then + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start_trac.nc' + write(6,*)' ierr = ', ierr_file + ENDIF + else + ierr_file = 2 + endif + END IF + + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, tname(iq),"est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + PRINT*, tname(iq), "est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Lecture echouee pour", tname(iq) + CALL abort + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + + + +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + endif ! mpi_rank==0 + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ener.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ener.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ener.h (revision 1634) @@ -0,0 +1,18 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! INCLUDE 'ener.h' + + COMMON/ener/ang0,etot0,ptot0,ztot0,stot0, & + & ang,etot,ptot,ztot,stot,rmsdpdt , & + & rmsv,gtot(llmm1) + + REAL ang0,etot0,ptot0,ztot0,stot0, & + & ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/enercin.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/enercin.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/enercin.F (revision 1634) @@ -0,0 +1,98 @@ +! +! $Header$ +! + SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), + * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i + + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + + + DO 5 l = 1,llm + + DO 1 ij = iip2, ip1jm -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = iip2, ip1jm, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + + DO 3 i = 1, iim + ecinni(i) = vcov( i , l) * vcont( i ,l) * aire( i ) + ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + 3 CONTINUE + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO 4 ij = 1,iip1 + ecin( ij , l ) = ecinpn + ecin( ij+ ip1jm, l ) = ecinps + 4 CONTINUE + + 5 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/enercin_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/enercin_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/enercin_p.F (revision 1634) @@ -0,0 +1,121 @@ + SUBROUTINE enercin_p ( vcov, ucov, vcont, ucont, ecin ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), + * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i,ijb,ije + + EXTERNAL SSUM + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_nord) ijb=ij_begin+iip1 + IF (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb, ije -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + IF (pole_nord) THEN + + DO i = 1, iim + ecinni(i) = vcov( i , l) * + * vcont( i ,l) * aire( i ) + ENDDO + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + + DO ij = 1,iip1 + ecin( ij , l ) = ecinpn + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO i = 1, iim + ecinsi(i) = vcov(i+ip1jmi1,l)* + * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + ENDDO + + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO ij = 1,iip1 + ecin( ij+ ip1jm, l ) = ecinps + ENDDO + + ENDIF + + + 5 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/etat0_netcdf.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/etat0_netcdf.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/etat0_netcdf.F90 (revision 1634) @@ -0,0 +1,530 @@ +! +! $Id$ +! +!------------------------------------------------------------------------------- +! +SUBROUTINE etat0_netcdf(ib, masque, phis, letat0) +! +!------------------------------------------------------------------------------- +! Purpose: Creates initial states +!------------------------------------------------------------------------------- +! Note: This routine is designed to work for Earth +!------------------------------------------------------------------------------- + USE control_mod +#ifdef CPP_EARTH + USE startvar + USE ioipsl + USE dimphy + USE infotrac + USE fonte_neige_mod + USE pbl_surface_mod + USE phys_state_var_mod + USE filtreg_mod + USE regr_lat_time_climoz_m, ONLY: regr_lat_time_climoz + USE conf_phys_m, ONLY: conf_phys +! For parameterization of ozone chemistry: + use regr_lat_time_coefoz_m, only: regr_lat_time_coefoz + use press_coefoz_m, only: press_coefoz + use regr_pr_o3_m, only: regr_pr_o3 + USE netcdf, ONLY : NF90_OPEN, NF90_NOWRITE, NF90_CLOSE, NF90_NOERR +#endif + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" + LOGICAL, INTENT(IN) :: ib ! barycentric interpolat. + REAL, DIMENSION(iip1,jjp1), INTENT(INOUT) :: masque ! land mask + REAL, DIMENSION(iip1,jjp1), INTENT(OUT) :: phis ! geopotentiel au sol + LOGICAL, INTENT(IN) :: letat0 ! F: masque only required +#ifndef CPP_EARTH + WRITE(lunout,*)'limit_netcdf: Earth-specific routine, needs Earth physics' +#else +!------------------------------------------------------------------------------- +! Local variables: +#include "comgeom2.h" +#include "comvert.h" +#include "comconst.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "temps.h" + REAL, DIMENSION(klon) :: tsol, qsol + REAL, DIMENSION(klon) :: sn, rugmer, run_off_lic_0 + REAL, DIMENSION(iip1,jjp1) :: orog, rugo, psol + REAL, DIMENSION(iip1,jjp1,llm+1) :: p3d + REAL, DIMENSION(iip1,jjp1,llm) :: uvent, t3d, tpot, qsat, qd + REAL, DIMENSION(iip1,jjm ,llm) :: vvent + REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: q3d + REAL, DIMENSION(klon,nbsrf) :: qsolsrf, snsrf, evap + REAL, DIMENSION(klon,nbsrf) :: frugs, agesno + REAL, DIMENSION(klon,nsoilmx,nbsrf) :: tsoil + +!--- Local variables for sea-ice reading: + INTEGER :: iml_lic, jml_lic, llm_tmp + INTEGER :: ttm_tmp, iret, fid + INTEGER, DIMENSION(1) :: itaul + REAL, DIMENSION(1) :: lev + REAL :: date + REAL, DIMENSION(:,:), ALLOCATABLE :: lon_lic, lat_lic, fraclic + REAL, DIMENSION(:), ALLOCATABLE :: dlon_lic, dlat_lic + REAL, DIMENSION(iip1,jjp1) :: flic_tmp + +!--- Misc + CHARACTER(LEN=80) :: x, fmt + INTEGER :: i, j, l, ji + REAL, DIMENSION(iip1,jjp1,llm) :: alpha, beta, pk, pls, y + REAL, DIMENSION(ip1jmp1) :: pks + +#include "comdissnew.h" +#include "serre.h" +#include "clesphys.h" + + REAL, DIMENSION(iip1,jjp1,llm) :: masse + INTEGER :: itau, iday + REAL :: xpn, xps, time, phystep + REAL, DIMENSION(iim) :: xppn, xpps + REAL, DIMENSION(ip1jmp1,llm) :: pbaru, phi, w + REAL, DIMENSION(ip1jm ,llm) :: pbarv + REAL, DIMENSION(klon) :: fder + +!--- Local variables for ocean mask reading: + INTEGER :: nid_o2a, iml_omask, jml_omask + LOGICAL :: couple=.FALSE. + REAL, DIMENSION(:,:), ALLOCATABLE :: lon_omask, lat_omask, ocemask, ocetmp + REAL, DIMENSION(:), ALLOCATABLE :: dlon_omask,dlat_omask + REAL, DIMENSION(klon) :: ocemask_fi + INTEGER, DIMENSION(klon-2) :: isst + REAL, DIMENSION(iim,jjp1) :: zx_tmp_2d + REAL :: dummy + LOGICAL :: ok_newmicro, ok_journe, ok_mensuel, ok_instan, ok_hf + LOGICAL :: ok_LES, ok_ade, ok_aie, aerosol_couple, new_aod, callstats + INTEGER :: iflag_radia, flag_aerosol + REAL :: bl95_b0, bl95_b1, fact_cldcon, facttemps, ratqsbas, ratqshaut + REAL :: tau_ratqs + INTEGER :: iflag_cldcon, iflag_ratqs, iflag_coupl, iflag_clos, iflag_wake + INTEGER :: iflag_thermals, nsplit_thermals + INTEGER :: iflag_thermals_ed, iflag_thermals_optflux + REAL :: tau_thermals, solarlong0, seuil_inversion + INTEGER :: read_climoz ! read ozone climatology +! Allowed values are 0, 1 and 2 +! 0: do not read an ozone climatology +! 1: read a single ozone climatology that will be used day and night +! 2: read two ozone climatologies, the average day and night +! climatology and the daylight climatology +!------------------------------------------------------------------------------- + REAL :: alp_offset + logical found + +!--- Constants + pi = 4. * ATAN(1.) + rad = 6371229. + daysec = 86400. + omeg = 2.*pi/daysec + g = 9.8 + kappa = 0.2857143 + cpp = 1004.70885 + preff = 101325. + pa = 50000. + jmp1 = jjm + 1 + +!--- CONSTRUCT A GRID + CALL conf_phys( ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, & + callstats, & + solarlong0,seuil_inversion, & + fact_cldcon, facttemps,ok_newmicro,iflag_radia, & + iflag_cldcon, & + iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + ok_ade, ok_aie, aerosol_couple, & + flag_aerosol, new_aod, & + bl95_b0, bl95_b1, & + read_climoz, & + alp_offset) + +! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value) + co2_ppm0 = co2_ppm + + dtvr = daysec/FLOAT(day_step) + WRITE(lunout,*)'dtvr',dtvr + + CALL iniconst() + CALL inigeom() + +!--- Initializations for tracers + CALL infotrac_init + ALLOCATE(q3d(iip1,jjp1,llm,nqtot)) + + CALL inifilr() + CALL phys_state_var_init(read_climoz) + + rlat(1) = ASIN(1.0) + DO j=2,jjm; rlat((j-2)*iim+2:(j-1)*iim+1)=rlatu(j); END DO + rlat(klon) = - ASIN(1.0) + rlat(:)=rlat(:)*(180.0/pi) + + rlon(1) = 0.0 + DO j=2,jjm; rlon((j-2)*iim+2:(j-1)*iim+1)=rlonv(1:iim); END DO + rlon(klon) = 0.0 + rlon(:)=rlon(:)*(180.0/pi) + +! For a coupled simulation, the ocean mask from ocean model is used to compute +! the weights an to insure ocean fractions are the same for atmosphere and ocean +! Otherwise, mask is created using Relief file. + + WRITE(lunout,*)'Essai de lecture masque ocean' + iret = NF90_OPEN("o2a.nc", NF90_NOWRITE, nid_o2a) + IF(iret/=NF90_NOERR) THEN + WRITE(lunout,*)'ATTENTION!! pas de fichier o2a.nc trouve' + WRITE(lunout,*)'Run force' + x='masque' + masque(:,:)=0.0 + CALL startget_phys2d(x, iip1, jjp1, rlonv, rlatu, masque, 0.0, jjm, & + & rlonu, rlatv, ib) + WRITE(lunout,*)'MASQUE construit : Masque' + WRITE(lunout,'(97I1)') nINT(masque) + CALL gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq) + WHERE( zmasq(:)=1) CALL regr_lat_time_climoz(read_climoz) + + x = 'tsol'; tsol(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,tsol,0.0,jjm,rlonu,rlatv,ib) + + x = 'qsol'; qsol(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,qsol,0.0,jjm,rlonu,rlatv,ib) + + x = 'snow'; sn(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,sn,0.0,jjm,rlonu,rlatv,ib) + + x = 'rads'; radsol(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0,jjm,rlonu,rlatv,ib) + + x = 'rugmer'; rugmer(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0,jjm,rlonu,rlatv,ib) + + x = 'zmea'; zmea(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0,jjm,rlonu,rlatv,ib) + + x = 'zstd'; zstd(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0,jjm,rlonu,rlatv,ib) + + x = 'zsig'; zsig(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0,jjm,rlonu,rlatv,ib) + + x = 'zgam'; zgam(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0,jjm,rlonu,rlatv,ib) + + x = 'zthe'; zthe(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0,jjm,rlonu,rlatv,ib) + + x = 'zpic'; zpic(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0,jjm,rlonu,rlatv,ib) + + x = 'zval'; zval(:) = 0.0 + CALL startget_phys1d(x,iip1,jjp1,rlonv,rlatu,klon,zval,0.0,jjm,rlonu,rlatv,ib) + +! WRITE(lunout,'(48I3)') 'TSOL :', INT(tsol(2:klon)-273) + +! Soil ice file reading for soil fraction and soil ice fraction +!******************************************************************************* + CALL flininfo("landiceref.nc", iml_lic, jml_lic, llm_tmp, ttm_tmp, fid) + ALLOCATE( lat_lic(iml_lic,jml_lic),lon_lic(iml_lic, jml_lic)) + ALLOCATE(dlat_lic(jml_lic), dlon_lic(iml_lic)) + ALLOCATE( fraclic(iml_lic,jml_lic)) + CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp, & + & lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp, 1,1, fraclic) + CALL flinclo(fid) + +! Interpolation on model T-grid +!******************************************************************************* + WRITE(lunout,*)'dimensions de landice iml_lic, jml_lic : ',iml_lic,jml_lic +! conversion if coordinates are in degrees + IF(MAXVAL(lon_lic)>pi) lon_lic=lon_lic*pi/180. + IF(MAXVAL(lat_lic)>pi) lat_lic=lat_lic*pi/180. + dlon_lic(:)=lon_lic(:,1) + dlat_lic(:)=lat_lic(1,:) + CALL grille_m( iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic, iim,jjp1, & + & rlonv, rlatu, flic_tmp(1:iim,:) ) + flic_tmp(iip1,:)=flic_tmp(1,:) + +!--- To the physical grid + CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, pctsrf(:,is_lic)) + +!--- Adequation with soil/sea mask + WHERE(pctsrf(:,is_lic)EPSFRA) THEN + IF(pctsrf(ji,is_lic)>=zmasq(ji)) THEN + pctsrf(ji,is_lic)=zmasq(ji) + pctsrf(ji,is_ter)=0. + ELSE + pctsrf(ji,is_ter)=zmasq(ji)-pctsrf(ji,is_lic) + IF(pctsrf(ji,is_ter)0.) isst=1 + +! It is checked that the sub-surfaces sum is equal to 1 +!******************************************************************************* + ji=COUNT((ABS(SUM(pctsrf(:,:),dim=2))-1.0)>EPSFRA) + IF(ji/=0) WRITE(lunout,*) 'pb repartition sous maille pour ',ji,' points' + CALL gr_fi_ecrit(1, klon, iim, jjp1, zmasq, zx_tmp_2d) +! WRITE(fmt,"(i3,')')")iim; fmt='(i'//ADJUSTL(fmt) +! WRITE(lunout,*)'zmasq = ' +! WRITE(lunout,TRIM(fmt))NINT(zx_tmp_2d) + CALL gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + WRITE(fmt,"(i4,'i1)')")iip1 ; fmt='('//ADJUSTL(fmt) + WRITE(lunout,*) 'MASQUE construit : Masque' + WRITE(lunout,TRIM(fmt))NINT(masque(:,:)) + +! Intermediate computation +!******************************************************************************* + CALL massdair(p3d,masse) + WRITE(lunout,*)' ALPHAX ',alphax + DO l=1,llm + xppn(:)=aire(1:iim,1 )*masse(1:iim,1 ,l) + xpps(:)=aire(1:iim,jjp1)*masse(1:iim,jjp1,l) + xpn=SUM(xppn)/apoln + xps=SUM(xpps)/apols + masse(:,1 ,l)=xpn + masse(:,jjp1,l)=xps + END DO + q3d(iip1,:,:,:)=q3d(1,:,:,:) + phis(iip1,:) = phis(1,:) + + IF(.NOT.letat0) RETURN + +! Writing +!******************************************************************************* + CALL inidissip(lstardis,nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,tetatemp) + WRITE(lunout,*)'sortie inidissip' + itau=0 + itau_dyn=0 + itau_phy=0 + iday=dayref+itau/day_step + time=FLOAT(itau-(iday-dayref)*day_step)/day_step + IF(time>1.) THEN + time=time-1 + iday=iday+1 + END IF + day_ref=dayref + annee_ref=anneeref + + CALL geopot( ip1jmp1, tpot, pk, pks, phis, phi ) + WRITE(lunout,*)'sortie geopot' + + CALL caldyn0( itau, uvent, vvent, tpot, psol, masse, pk, phis, & + phi, w, pbaru, pbarv, time+iday-dayref) + WRITE(lunout,*)'sortie caldyn0' + CALL dynredem0( "start.nc", dayref, phis) + WRITE(lunout,*)'sortie dynredem0' + CALL dynredem1( "start.nc", 0.0, vvent, uvent, tpot, q3d, masse, psol) + WRITE(lunout,*)'sortie dynredem1' + +! Physical initial state writting +!******************************************************************************* + WRITE(lunout,*)'phystep ',dtvr,iphysiq,nbapp_rad + phystep = dtvr * FLOAT(iphysiq) + radpas = NINT (86400./phystep/ FLOAT(nbapp_rad) ) + WRITE(lunout,*)'phystep =', phystep, radpas + +! Init: tsol, qsol, sn, evap, tsoil, rain_fall, snow_fall, solsw, sollw, frugs +!******************************************************************************* + DO i=1,nbsrf; ftsol(:,i) = tsol; END DO + DO i=1,nbsrf; snsrf(:,i) = sn; END DO + falb1(:,is_ter) = 0.08; falb1(:,is_lic) = 0.6 + falb1(:,is_oce) = 0.5; falb1(:,is_sic) = 0.6 + falb2 = falb1 + evap(:,:) = 0. + DO i=1,nbsrf; qsolsrf(:,i)=150.; END DO + DO i=1,nbsrf; DO j=1,nsoilmx; tsoil(:,j,i) = tsol; END DO; END DO + rain_fall = 0.; snow_fall = 0. + solsw = 165.; sollw = -53. + t_ancien = 273.15 + q_ancien = 0. + agesno = 0. + frugs(:,is_oce) = rugmer(:) + frugs(:,is_ter) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0) + frugs(:,is_lic) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0) + frugs(:,is_sic) = 0.001 + fder = 0.0 + clwcon = 0.0 + rnebcon = 0.0 + ratqs = 0.0 + run_off_lic_0 = 0.0 + rugoro = 0.0 + +! Before phyredem calling, surface modules and values to be saved in startphy.nc +! are initialized +!******************************************************************************* + dummy = 1.0 + pbl_tke(:,:,:) = 1.e-8 + zmax0(:) = 40. + f0(:) = 1.e-5 + ema_work1(:,:) = 0. + ema_work2(:,:) = 0. + wake_deltat(:,:) = 0. + wake_deltaq(:,:) = 0. + wake_s(:) = 0. + wake_cstar(:) = 0. + wake_fip(:) = 0. + wake_pe = 0. + fm_therm = 0. + entr_therm = 0. + detr_therm = 0. + + CALL fonte_neige_init(run_off_lic_0) + CALL pbl_surface_init( qsol, fder, snsrf, qsolsrf, evap, frugs, agesno, tsoil ) + CALL phyredem( "startphy.nc" ) + +! WRITE(lunout,*)'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0' +! WRITE(lunout,*)'entree histclo' + CALL histclo() + +#endif +!#endif of #ifdef CPP_EARTH + RETURN + +END SUBROUTINE etat0_netcdf +! +!------------------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_hyb.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_hyb.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_hyb.F (revision 1634) @@ -0,0 +1,159 @@ +! +! $Id $ +! + SUBROUTINE exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) +c +c Auteurs : P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c -------- z +c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et +c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) +c ( voir note de Fr.Hourdin ) , +c +c on determine successivement , du haut vers le bas des couches, les +c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), +c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, +c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM +c + logical,save :: firstcall=.true. + character(len=*),parameter :: modname="exner_hyb" + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.1) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==1",42) + endif + + ! sanity checks for Shallow Water case (1 vertical layer) + if (llm.eq.1) then + if (kappa.ne.1) then + call abort_gcm(modname, + & "kappa!=1 , but running in Shallow Water mode!!",42) + endif + if (cpp.ne.r) then + call abort_gcm(modname, + & "cpp!=r , but running in Shallow Water mode!!",42) + endif + endif ! of if (llm.eq.1) + + firstcall=.false. + endif ! of if (firstcall) + + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + + DO ij = 1, ngrid + pks(ij) = (cpp/preff) * ps(ij) + pk(ij,1) = .5*pks(ij) + ENDDO + + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + + endif ! of if (llm.eq.1) + +!!!! General case: + + unpl2k = 1.+ 2.* kappa +c + DO ij = 1, ngrid + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO + + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij ) = xpn + pks( ij+ip1jm ) = xps + ENDDO +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c + DO ij = 1, ngrid + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c + DO ij = 1, ngrid + dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) + alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) + beta (ij,l) = p(ij,l ) / dellta + ENDDO +c + ENDDO +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c + DO ij = 1, ngrid + pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / + * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) + ENDDO +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm + DO ij = 1, ngrid + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO + ENDDO +c +c + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_hyb_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_hyb_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_hyb_p.F (revision 1634) @@ -0,0 +1,237 @@ +! +! $Id $ +! + SUBROUTINE exner_hyb_p ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) +c +c Auteurs : P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c -------- z +c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et +c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) +c ( voir note de Fr.Hourdin ) , +c +c on determine successivement , du haut vers le bas des couches, les +c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), +c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, +c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . +c +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + INTEGER ije,ijb,jje,jjb + logical,save :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + character(len=*),parameter :: modname="exner_hyb_p" +c + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.1) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==1",42) + endif + + ! sanity checks for Shallow Water case (1 vertical layer) + if (llm.eq.1) then + if (kappa.ne.1) then + call abort_gcm(modname, + & "kappa!=1 , but running in Shallow Water mode!!",42) + endif + if (cpp.ne.r) then + call abort_gcm(modname, + & "cpp!=r , but running in Shallow Water mode!!",42) + endif + endif ! of if (llm.eq.1) + + firstcall=.false. + endif ! of if (firstcall) + +c$OMP BARRIER + +! Specific behaviour for Shallow Water (1 vertical layer) case + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + ijb=ij_begin + ije=ij_end +!$OMP DO SCHEDULE(STATIC) + DO ij=ijb, ije + pks(ij)=(cpp/preff)*ps(ij) + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO +!$OMP ENDDO + +!$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) + pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) + ENDDO + endif +!$OMP END MASTER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + endif ! of if (llm.eq.1) + +!!!! General case: + + unpl2k = 1.+ 2.* kappa +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO +c$OMP ENDDO +c Synchro OPENMP ici + +c$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + ENDDO + endif +c$OMP END MASTER +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb,ije + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c$OMP ENDDO NOWAIT +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) + alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) + beta (ij,l) = p(ij,l ) / dellta + ENDDO +c$OMP ENDDO NOWAIT +c + ENDDO + +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / + * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) + ENDDO +c$OMP ENDDO NOWAIT +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO +c +c +c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + DO l = 1, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pkf(ij,l)=pk(ij,l) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c$OMP BARRIER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_milieu.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_milieu.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_milieu.F (revision 1634) @@ -0,0 +1,151 @@ +! +! $Id $ +! + SUBROUTINE exner_milieu ( ngrid, ps, p,beta, pks, pk, pkf ) +c +c Auteurs : F. Forget , Y. Wanherdrick +c P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c WARNING : CECI est une version speciale de exner_hyb originale +c Utilise dans la version martienne pour pouvoir +c tourner avec des coordonnees verticales complexe +c => Il ne verifie PAS la condition la proportionalite en +c energie totale/ interne / potentielle (F.Forget 2001) +c ( voir note de Fr.Hourdin ) , +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL dum1 + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + logical,save :: firstcall=.true. + character(len=*),parameter :: modname="exner_milieu" + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.2) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==2",42) + endif + + ! sanity checks for Shallow Water case (1 vertical layer) + if (llm.eq.1) then + if (kappa.ne.1) then + call abort_gcm(modname, + & "kappa!=1 , but running in Shallow Water mode!!",42) + endif + if (cpp.ne.r) then + call abort_gcm(modname, + & "cpp!=r , but running in Shallow Water mode!!",42) + endif + endif ! of if (llm.eq.1) + + firstcall=.false. + endif ! of if (firstcall) + +!!!! Specific behaviour for Shallow Water (1 vertical layer) case: + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + + DO ij = 1, ngrid + pks(ij) = (cpp/preff) * ps(ij) + pk(ij,1) = .5*pks(ij) + ENDDO + + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + + endif ! of if (llm.eq.1) + +!!!! General case: + +c ------------- +c Calcul de pks +c ------------- + + DO ij = 1, ngrid + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO + + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij ) = xpn + pks( ij+ip1jm ) = xps + ENDDO +c +c +c .... Calcul de pk pour la couche l +c -------------------------------------------- +c + dum1 = cpp * (2*preff)**(-kappa) + DO l = 1, llm-1 + DO ij = 1, ngrid + pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa + ENDDO + ENDDO + +c .... Calcul de pk pour la couche l = llm .. +c (on met la meme distance (en log pression) entre Pk(llm) +c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) + + DO ij = 1, ngrid + pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) + ENDDO + + +c calcul de pkf +c ------------- + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + +c EST-CE UTILE ?? : calcul de beta +c -------------------------------- + DO l = 2, llm + DO ij = 1, ngrid + beta(ij,l) = pk(ij,l) / pk(ij,l-1) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_milieu_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_milieu_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/exner_milieu_p.F (revision 1634) @@ -0,0 +1,224 @@ +! +! $Id $ +! + SUBROUTINE exner_milieu_p ( ngrid, ps, p,beta, pks, pk, pkf ) +c +c Auteurs : F. Forget , Y. Wanherdrick +c P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c WARNING : CECI est une version speciale de exner_hyb originale +c Utilise dans la version martienne pour pouvoir +c tourner avec des coordonnees verticales complexe +c => Il ne verifie PAS la condition la proportionalite en +c energie totale/ interne / potentielle (F.Forget 2001) +c ( voir note de Fr.Hourdin ) , +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL dum1 + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + INTEGER ije,ijb,jje,jjb + logical,save :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + character(len=*),parameter :: modname="exner_milieu_p" + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.2) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==2",42) + endif + + ! sanity checks for Shallow Water case (1 vertical layer) + if (llm.eq.1) then + if (kappa.ne.1) then + call abort_gcm(modname, + & "kappa!=1 , but running in Shallow Water mode!!",42) + endif + if (cpp.ne.r) then + call abort_gcm(modname, + & "cpp!=r , but running in Shallow Water mode!!",42) + endif + endif ! of if (llm.eq.1) + + firstcall=.false. + endif ! of if (firstcall) + +c$OMP BARRIER + +! Specific behaviour for Shallow Water (1 vertical layer) case + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + ijb=ij_begin + ije=ij_end +!$OMP DO SCHEDULE(STATIC) + DO ij=ijb, ije + pks(ij)=(cpp/preff)*ps(ij) + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO +!$OMP ENDDO + +!$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) + pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) + ENDDO + endif +!$OMP END MASTER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + endif ! of if (llm.eq.1) + +!!!! General case: + +c ------------- +c Calcul de pks +c ------------- + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO +c$OMP ENDDO +c Synchro OPENMP ici + +c$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + ENDDO + endif +c$OMP END MASTER +c +c +c .... Calcul de pk pour la couche l +c -------------------------------------------- +c + dum1 = cpp * (2*preff)**(-kappa) + DO l = 1, llm-1 +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c .... Calcul de pk pour la couche l = llm .. +c (on met la meme distance (en log pression) entre Pk(llm) +c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) + ENDDO +c$OMP ENDDO NOWAIT + + +c calcul de pkf +c ------------- +c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + DO l = 1, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pkf(ij,l)=pk(ij,l) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c$OMP BARRIER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + +c EST-CE UTILE ?? : calcul de beta +c -------------------------------- + DO l = 2, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + beta(ij,l) = pk(ij,l) / pk(ij,l-1) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/extrapol.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/extrapol.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/extrapol.F (revision 1634) @@ -0,0 +1,200 @@ +! +! $Id$ +! +C +C + SUBROUTINE extrapol (pfild, kxlon, kylat, pmask, + . norsud, ldper, knbor, pwork) + IMPLICIT none +c +c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997) +c Fill up missed values by using the neighbor points +c + INTEGER kxlon, kylat ! longitude and latitude dimensions (Input) + INTEGER knbor ! minimum neighbor number (Input) + LOGICAL norsud ! True if field is from North to South (Input) + LOGICAL ldper ! True if take into account the periodicity (Input) + REAL pmask ! mask value (Input) + REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output) + REAL pwork(kxlon,kylat) ! working space +c + REAL zwmsk + INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat + INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates + REAL zmask(9) +C +C We search over the eight closest neighbors +C +C j+1 7 8 9 +C j 4 5 6 Current point 5 --> (i,j) +C j-1 1 2 3 +C i-1 i i+1 +c +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + incre = 0 +c + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,j) + ENDDO + ENDDO +c +C* To avoid problems in floating point tests + zwmsk = pmask - 1.0 +c +200 CONTINUE + incre = incre + 1 + DO 99999 j = 1, kylat + DO 99999 i = 1, kxlon + IF (pfild(i,j).GT. zwmsk) THEN + pwork(i,j) = pfild(i,j) + inbor = 0 + ideb = 1 + ifin = 9 +C +C* Fill up ix array + ix(1) = MAX (1,i-1) + ix(2) = i + ix(3) = MIN (kxlon,i+1) + ix(4) = MAX (1,i-1) + ix(5) = i + ix(6) = MIN (kxlon,i+1) + ix(7) = MAX (1,i-1) + ix(8) = i + ix(9) = MIN (kxlon,i+1) +C +C* Fill up iy array + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = MAX (1,j-1) + jy(4) = j + jy(5) = j + jy(6) = j + jy(7) = MIN (kylat,j+1) + jy(8) = MIN (kylat,j+1) + jy(9) = MIN (kylat,j+1) +C +C* Correct latitude bounds if southernmost or northernmost points + IF (j .EQ. 1) ideb = 4 + IF (j .EQ. kylat) ifin = 6 +C +C* Account for periodicity in longitude +C + IF (ldper) THEN + IF (i .EQ. kxlon) THEN + ix(3) = 1 + ix(6) = 1 + ix(9) = 1 + ELSE IF (i .EQ. 1) THEN + ix(1) = kxlon + ix(4) = kxlon + ix(7) = kxlon + ENDIF + ELSE + IF (i .EQ. 1) THEN + ix(1) = i + ix(2) = i + 1 + ix(3) = i + ix(4) = i + 1 + ix(5) = i + ix(6) = i + 1 + ENDIF + IF (i .EQ. kxlon) THEN + ix(1) = i -1 + ix(2) = i + ix(3) = i - 1 + ix(4) = i + ix(5) = i - 1 + ix(6) = i + ENDIF +C + IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = j + jy(4) = j + jy(5) = MIN (kylat,j+1) + jy(6) = MIN (kylat,j+1) +C + ideb = 1 + ifin = 6 + IF (j .EQ. 1) ideb = 3 + IF (j .EQ. kylat) ifin = 4 + ENDIF + ENDIF ! end for ldper test +C +C* Find unmasked neighbors +C + DO 230 k = ideb, ifin + zmask(k) = 0. + ilon = ix(k) + jlat = jy(k) + IF (pfild(ilon,jlat) .LT. zwmsk) THEN + zmask(k) = 1. + inbor = inbor + 1 + ENDIF + 230 CONTINUE +C +C* Not enough points around point P are unmasked; interpolation on P +C will be done in a future call to extrap. +C + IF (inbor .GE. knbor) THEN + pwork(i,j) = 0. + DO k = ideb, ifin + ilon = ix(k) + jlat = jy(k) + pwork(i,j) = pwork(i,j) + $ + pfild(ilon,jlat) * zmask(k)/ REAL(inbor) + ENDDO + ENDIF +C + ENDIF +99999 CONTINUE +C +C* 3. Writing back unmasked field in pfild +C ------------------------------------ +C +C* pfild then contains: +C - Values which were not masked +C - Interpolated values from the inbor neighbors +C - Values which are not yet interpolated +C + idoit = 0 + DO j = 1, kylat + DO i = 1, kxlon + IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1 + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO +c + IF (idoit .ne. 0) GOTO 200 +ccc PRINT*, "Number of extrapolation steps incre =", incre +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/filtreg_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/filtreg_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/filtreg_p.F (revision 1634) @@ -0,0 +1,400 @@ + + + SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, + & ifiltre, iaire, griscal ,iter) + USE Parallel, only : OMP_CHUNK + USE mod_filtre_fft + USE timer_filtre + + USE filtreg_mod + + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van 07/10/97 +c ------ +c +c Objet: filtre matriciel longitudinal ,avec les matrices precalculees +c pour l'operateur Filtre . +c ------ +c +c Arguments: +c ---------- +c +c +c ibeg..iend lattitude a filtrer +c nlat nombre de latitudes du champ +c nbniv nombre de niveaux verticaux a filtrer +c champ(iip1,nblat,nbniv) en entree : champ a filtrer +c en sortie : champ filtre +c ifiltre +1 Transformee directe +c -1 Transformee inverse +c +2 Filtre directe +c -2 Filtre inverse +c +c iaire 1 si champ intensif +c 2 si champ extensif (pondere par les aires) +c +c iter 1 filtre simple +c +c======================================================================= +c +c +c Variable Intensive +c ifiltre = 1 filtre directe +c ifiltre =-1 filtre inverse +c +c Variable Extensive +c ifiltre = 2 filtre directe +c ifiltre =-2 filtre inverse +c +c +#include "dimensions.h" +#include "paramet.h" +#include "coefils.h" +c + INTEGER ibeg,iend,nlat,nbniv,ifiltre,iter + INTEGER i,j,l,k + INTEGER iim2,immjm + INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil + + REAL champ( iip1,nlat,nbniv) + + LOGICAL griscal + INTEGER hemisph, iaire + + REAL :: champ_fft(iip1,nlat,nbniv) + REAL :: champ_in(iip1,nlat,nbniv) + + LOGICAL,SAVE :: first=.TRUE. +c$OMP THREADPRIVATE(first) + + REAL, DIMENSION(iip1,nlat,nbniv) :: champ_loc + INTEGER :: ll_nb, nbniv_loc + REAL, SAVE :: sdd12(iim,4) +c$OMP THREADPRIVATE(sdd12) + + INTEGER, PARAMETER :: type_sddu=1 + INTEGER, PARAMETER :: type_sddv=2 + INTEGER, PARAMETER :: type_unsddu=3 + INTEGER, PARAMETER :: type_unsddv=4 + + INTEGER :: sdd1_type, sdd2_type + + IF (first) THEN + sdd12(1:iim,type_sddu) = sddu(1:iim) + sdd12(1:iim,type_sddv) = sddv(1:iim) + sdd12(1:iim,type_unsddu) = unsddu(1:iim) + sdd12(1:iim,type_unsddv) = unsddv(1:iim) + + CALL Init_timer + first=.FALSE. + ENDIF + +c$OMP MASTER + CALL start_timer +c$OMP END MASTER + +c-------------------------------------------------------c + + IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) + & STOP'Pas de transformee simple dans cette version' + + IF( iter.EQ. 2 ) THEN + PRINT *,' Pas d iteration du filtre dans cette version !' + & , ' Utiliser old_filtreg et repasser !' + STOP + ENDIF + + IF( ifiltre.EQ. -2 .AND..NOT.griscal ) THEN + PRINT *,' Cette routine ne calcule le filtre inverse que ' + & , ' sur la grille des scalaires !' + STOP + ENDIF + + IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 ) THEN + PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' + & , ' corriger et repasser !' + STOP + ENDIF +c + + iim2 = iim * iim + immjm = iim * jjm +c +c + IF( griscal ) THEN + IF( nlat. NE. jjp1 ) THEN + PRINT 1111 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddv + sdd2_type = type_unsddv + ELSE + sdd1_type = type_unsddv + sdd2_type = type_sddv + ENDIF +c + jdfil1 = 2 + jffil1 = jfiltnu + jdfil2 = jfiltsu + jffil2 = jjm + ENDIF + ELSE + IF( nlat.NE.jjm ) THEN + PRINT 2222 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddu + sdd2_type = type_unsddu + ELSE + sdd1_type = type_unsddu + sdd2_type = type_sddu + ENDIF +c + jdfil1 = 1 + jffil1 = jfiltnv + jdfil2 = jfiltsv + jffil2 = jjm + ENDIF + ENDIF +c + DO hemisph = 1, 2 +c + IF ( hemisph.EQ.1 ) THEN +cym + jdfil = max(jdfil1,ibeg) + jffil = min(jffil1,iend) + ELSE +cym + jdfil = max(jdfil2,ibeg) + jffil = min(jffil2,iend) + ENDIF + + +cccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre classique +cccccccccccccccccccccccccccccccccccccccccccc + + IF (.NOT. use_filtre_fft) THEN + +c !---------------------------------! +c ! Agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !---------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + ll_nb = ll_nb+1 + DO j = jdfil,jffil + DO i = 1, iim + champ_loc(i,j,ll_nb) = + & champ(i,j,l) * sdd12(i,sdd1_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + nbniv_loc = ll_nb + + IF( hemisph.EQ.1 ) THEN + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvn(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE IF ( griscal ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceun(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevn(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ENDIF + + ELSE + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvs(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceus(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevs(1,1,j-jfiltsv+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ENDIF + + ENDIF +! c + IF( ifiltre.EQ.2 ) THEN + +c !-------------------------------------! +c ! Dés-agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !-------------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & + champ_fft(i,j-jdfil+1,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ELSE + + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv_loc + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & - champ_fft(i,j-jdfil+1,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ENDIF + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + DO j = jdfil,jffil + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +ccccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre FFT +ccccccccccccccccccccccccccccccccccccccccccccc + + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type) + champ_fft( i,j,l) = champ(i,j,l) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + IF (jdfil<=jffil) THEN + IF( ifiltre. EQ. -2 ) THEN + CALL Filtre_inv_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ELSE IF ( griscal ) THEN + CALL Filtre_u_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ELSE + CALL Filtre_v_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ENDIF + ENDIF + + + IF( ifiltre.EQ. 2 ) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil +! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l ) + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c Fin de la zone de filtrage + + + ENDDO + +! DO j=1,nlat +! +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)), +! & sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) +! ENDDO + +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ-champ_fft)/sum(champ) +! + +c + 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a + & filtrer, sur la grille des scalaires'/) + 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi + & ltrer, sur la grille de V ou de Z'/) +c$OMP MASTER + CALL stop_timer +c$OMP END MASTER + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/flumass.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/flumass.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/flumass.F (revision 1634) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , + * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), + * pbarv( ip1jm,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + + REAL SSUM + + + DO 5 l = 1,llm + + DO 1 ij = iip2,ip1jm + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + DO 3 ij = 1,ip1jm + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE + +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + + DO 20 l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + + pbaru( 1 ,l )= pbarv( 1 ,l ) - ctn * aire( 1 ) + pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 ) + + DO 11 i = 2,iim + pbaru( i ,l ) = pbaru( i - 1 ,l ) + + * pbarv( i ,l ) - ctn * aire( i ) + + pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l ) - + * pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm) + 11 CONTINUE + DO 12 i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + 12 CONTINUE + ctn0 = -SSUM( iim,apbarun,1 )/saireun + cts0 = -SSUM( iim,apbarus,1 )/saireus + DO 14 i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + 14 CONTINUE + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + 20 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/flumass_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/flumass_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/flumass_p.F (revision 1634) @@ -0,0 +1,152 @@ + SUBROUTINE flumass_p(massebx,masseby, vcont, ucont, pbaru, pbarv) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , + * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), + * pbarv( ip1jm,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + INTEGER ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb,ije + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO 3 ij = ijb,ije + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + IF (pole_nord) THEN + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + + pbaru(1,l)=pbarv(1,l) - ctn * aire(1) + + DO i = 2,iim + pbaru(i,l) = pbaru(i- 1,l ) + + * pbarv(i,l) - ctn * aire(i ) + ENDDO + + DO i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + ENDDO + + ctn0 = -SSUM( iim,apbarun,1 )/saireun + + DO i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + ENDDO + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + + ENDDO +c$OMP END DO NOWAIT + + ENDIF + + + IF (pole_sud) THEN + + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + pbaru(ip1jm+1,l)= - pbarv(ip1jmi1+1,l) + cts * aire(ip1jm+1) + + DO i = 2,iim + pbaru(i+ ip1jm,l) = pbaru(i+ip1jm-1,l) - + * pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm) + ENDDO + + DO i = 1,iim + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + ENDDO + + cts0 = -SSUM( iim,apbarus,1 )/saireus + + DO i = 1,iim + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + ENDDO + + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + + ENDDO +c$OMP END DO NOWAIT + ENDIF + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fluxstokenc_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fluxstokenc_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fluxstokenc_p.F (revision 1634) @@ -0,0 +1,250 @@ +! +! $Id$ +! + SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis, + . time_step,itau ) +#ifdef CPP_IOIPSL +! This routine is designed to work with ioipsl + + USE IOIPSL + USE parallel + USE misc_mod + USE mod_hallo +c +c Auteur : F. Hourdin +c +c +ccc .. Modif. P. Le Van ( 20/12/97 ) ... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "tracstoke.h" +#include "temps.h" +#include "iniprint.h" + + REAL time_step,t_wrt, t_ops + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL phis(ip1jmp1) + + REAL,SAVE :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) + REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm) + + REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm) + + REAL pbarvst(iip1,jjp1,llm),zistdyn + real dtcum + + INTEGER iadvtr,ndex(1) + integer nscal + real tst(1),ist(1),istp(1) + INTEGER ij,l,irec,i,j,itau + INTEGER,SAVE :: fluxid, fluxvid,fluxdid + + SAVE iadvtr, massem,irec + SAVE phic,tetac + logical first + save first + data first/.true./ + DATA iadvtr/0/ + integer :: ijb,ije,jjb,jje,jjn + type(Request) :: Req + +c AC initialisations + pbarug(:,:) = 0. +cym pbarvg(:,:,:) = 0. +cym wg(:,:) = 0. + +c$OMP MASTER + + if(first) then + + CALL initfluxsto_p( 'fluxstoke', + . time_step,istdyn* time_step,istdyn* time_step, + . fluxid,fluxvid,fluxdid) + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + ndex(1) = 0 + call histwrite(fluxid, 'phis', 1, phis(ijb:ije), + . iip1*jjn, ndex) + call histwrite(fluxid, 'aire', 1, aire(ijb:ije), + . iip1*jjn, ndex) + + ndex(1) = 0 + nscal = 1 + + if (mpi_rank==0) then + tst(1) = time_step + call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex) + ist(1)=istdyn + call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex) + istp(1)= istphy + call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex) + endif + first = .false. + + endif + + + IF(iadvtr.EQ.0) THEN +cym CALL initial0(ijp1llm,phic) +cym CALL initial0(ijp1llm,tetac) +cym CALL initial0(ijp1llm,pbaruc) +cym CALL initial0(ijmllm,pbarvc) + ijb=ij_begin + ije=ij_end + phic(ijb:ije,1:llm)=0 + tetac(ijb:ije,1:llm)=0 + pbaruc(ijb:ije,1:llm)=0 + + IF (pole_sud) ije=ij_end-iip1 + pbarvc(ijb:ije,1:llm)=0 + ENDIF + +c accumulation des flux de masse horizontaux + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij = ijb,ije + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + tetac(ij,l) = tetac(ij,l) + teta(ij,l) + phic(ij,l) = phic(ij,l) + phi(ij,l) + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij = ijb,ije + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO + +c selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN +cym CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) + ijb=ij_begin + ije=ij_end + massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm) + ENDIF + + iadvtr = iadvtr+1 + +c$OMP END MASTER +c$OMP BARRIER +c Test pour savoir si on advecte a ce pas de temps + IF ( iadvtr.EQ.istdyn ) THEN +c$OMP MASTER +c normalisation + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij = ijb,ije + pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn) + tetac(ij,l) = tetac(ij,l)/REAL(istdyn) + phic(ij,l) = phic(ij,l)/REAL(istdyn) + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij = ijb,ije + pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn) + ENDDO + ENDDO + +c traitement des flux de masse avant advection. +c 1. calcul de w +c 2. groupement des mailles pres du pole. +c$OMP END MASTER +c$OMP BARRIER + call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req) + call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req) + call SendRequest(Req) +c$OMP BARRIER + call WaitRequest(Req) +c$OMP BARRIER +c$OMP MASTER + CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do l=1,llm + do j=jjb,jje + do i=1,iip1 + pbarvst(i,j,l)=pbarvg(i,j,l) + enddo + enddo + enddo + + if (pole_sud) then + do i=1,iip1 + pbarvst(i,jjp1,l)=0. + enddo + endif + + iadvtr=0 + write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:), + . iip1*jjn*llm, ndex) + + call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:), + . iip1*jjn*llm, ndex) + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) then + jje=jj_end-1 + jjn=jj_nb-1 + endif + + call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:), + . iip1*jjn*llm, ndex) + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:), + . iip1*jjn*llm, ndex) + + call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:), + . iip1*jjn*llm, ndex) + + call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:), + . iip1*jjn*llm, ndex) + +C +c$OMP END MASTER + ENDIF ! if iadvtr.EQ.istdyn + +#else + write(lunout,*) + & 'fluxstokenc: Needs IOIPSL to function' +#endif +! of #ifdef CPP_IOIPSL + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/friction_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/friction_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/friction_p.F (revision 1634) @@ -0,0 +1,202 @@ +! +! $Id$ +! +c======================================================================= + SUBROUTINE friction_p(ucov,vcov,pdt) + USE parallel + USE control_mod +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + IMPLICIT NONE + +!======================================================================= +! +! Friction for the Newtonian case: +! -------------------------------- +! 2 possibilities (depending on flag 'friction_type' +! friction_type=0 : A friction that is only applied to the lowermost +! atmospheric layer +! friction_type=1 : Friction applied on all atmospheric layer (but +! (default) with stronger magnitude near the surface; see +! iniacademic.F) +!======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" +#include "iniprint.h" +#include "academic.h" + +! arguments: + REAL,INTENT(inout) :: ucov( iip1,jjp1,llm ) + REAL,INTENT(inout) :: vcov( iip1,jjm,llm ) + REAL,INTENT(in) :: pdt ! time step + +! local variables: + REAL modv(iip1,jjp1),zco,zsi + REAL vpn,vps,upoln,upols,vpols,vpoln + REAL u2(iip1,jjp1),v2(iip1,jjm) + INTEGER i,j,l + REAL,PARAMETER :: cfric=1.e-5 + LOGICAL,SAVE :: firstcall=.true. + INTEGER,SAVE :: friction_type=1 + CHARACTER(len=20) :: modname="friction_p" + CHARACTER(len=80) :: abort_message +!$OMP THREADPRIVATE(firstcall,friction_type) + integer :: jjb,jje + +!$OMP SINGLE + IF (firstcall) THEN + ! set friction type + call getin("friction_type",friction_type) + if ((friction_type.lt.0).or.(friction_type.gt.1)) then + abort_message="wrong friction type" + write(lunout,*)'Friction: wrong friction type',friction_type + call abort_gcm(modname,abort_message,42) + endif + firstcall=.false. + ENDIF +!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall) + + if (friction_type.eq.0) then ! friction on first layer only +!$OMP SINGLE +c calcul des composantes au carre du vent naturel + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + do j=jjb,jje + do i=1,iip1 + u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) + enddo + enddo + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) + enddo + enddo + +c calcul du module de V en dehors des poles + jjb=jj_begin + jje=jj_end+1 + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=2,iip1 + modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) + enddo + modv(1,j)=modv(iip1,j) + enddo + +c les deux composantes du vent au pole sont obtenues comme +c premiers modes de fourier de v pres du pole + if (pole_nord) then + + upoln=0. + vpoln=0. + + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vpn=vcov(i,1,1)/cv(i,1) + upoln=upoln+zco*vpn + vpoln=vpoln+zsi*vpn + enddo + vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi + do i=1,iip1 +c modv(i,1)=vpn + modv(i,1)=modv(i,2) + enddo + + endif + + if (pole_sud) then + + upols=0. + vpols=0. + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vps=vcov(i,jjm,1)/cv(i,jjm) + upols=upols+zco*vps + vpols=vpols+zsi*vps + enddo + vps=sqrt(upols*upols+vpols*vpols)/pi + do i=1,iip1 +c modv(i,jjp1)=vps + modv(i,jjp1)=modv(i,jjm) + enddo + + endif + +c calcul du frottement au sol. + + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iim + ucov(i,j,1)=ucov(i,j,1) + s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) + enddo + ucov(iip1,j,1)=ucov(1,j,1) + enddo + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + vcov(i,j,1)=vcov(i,j,1) + s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) + enddo + vcov(iip1,j,1)=vcov(1,j,1) + enddo +!$OMP END SINGLE + endif ! of if (friction_type.eq.0) + + if (friction_type.eq.1) then + ! for ucov() + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)* + & (1.-pdt*kfrict(l)) + enddo +!$OMP END DO NOWAIT + + ! for vcoc() + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)* + & (1.-pdt*kfrict(l)) + enddo +!$OMP END DO + endif ! of if (friction_type.eq.1) + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxhyp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxhyp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxhyp.F (revision 1634) @@ -0,0 +1,448 @@ +! +! $Id$ +! +c +c + SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau , + , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025, + , champmin,champmax ) + +c Auteur : P. Le Van + + IMPLICIT NONE + +c Calcule les longitudes et derivees dans la grille du GCM pour une +c fonction f(x) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.) +c dzoom etant la distance totale de la zone du zoom +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c On doit avoir grossism x dzoom < pi ( radians ) , en longitude. +c ******************************************************************** + + + INTEGER nmax, nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c + LOGICAL scal180 + PARAMETER ( scal180 = .TRUE. ) + +c scal180 = .TRUE. si on veut avoir le premier point scalaire pour +c une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres. +c sinon scal180 = .FALSE. + +#include "dimensions.h" +#include "paramet.h" + +c ...... arguments d'entree ....... +c + REAL xzoomdeg,dzooma,tau,grossism + +c ...... arguments de sortie ...... + + REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1), + , rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1) + +c .... variables locales .... +c + REAL dzoom + REAL*8 xlon(iip1),xprimm(iip1),xuv + REAL*8 xtild(0:nmax2) + REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2) + REAL*8 Xf(0:nmax2),xxpr(0:nmax2) + REAL*8 xvrai(iip1),xxprim(iip1) + REAL*8 pi,depi,epsilon,xzoom,fa,fb + REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2 + INTEGER i,it,ik,iter,ii,idif,ii1,ii2 + REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin + REAL*8 champmin,champmax,decalx + INTEGER is2 + SAVE is2 + + REAL*8 heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + epsilon = 1.e-3 + xzoom = xzoomdeg * pi/180. +c + decalx = .75 + IF( grossism.EQ.1..AND.scal180 ) THEN + decalx = 1. + ENDIF + + WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx +c + IF( dzooma.LT.1.) THEN + dzoom = dzooma * depi + ELSEIF( dzooma.LT. 25. ) THEN + WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) xzoom,grossism,tau,dzoom + + DO i = 0, nmax2 + xtild(i) = - pi + REAL(i) * depi /nmax2 + ENDDO + + DO i = nmax, nmax2 + + fa = tau* ( dzoom/2. - xtild(i) ) + fb = xtild(i) * ( pi - xtild(i) ) + + IF( 200.* fb .LT. - fa ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fhyp ( i) = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fhyp ( i ) = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fhyp ( i ) = 1. + ENDIF + ELSE + fhyp ( i ) = TANH ( fa/fb ) + ENDIF + ENDIF + IF ( xtild(i).EQ. 0. ) fhyp(i) = 1. + IF ( xtild(i).EQ. pi ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... + + ffdx = 0. + + DO i = nmax +1,nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fxm = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fxm = 1. + ENDIF + ELSE + fxm = TANH ( fa/fb ) + ENDIF + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + + ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) ) + + ENDDO + + beta = ( grossism * ffdx - pi ) / ( ffdx - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fxhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismx ,tau ou dzoomx ', + , ' et relancer ! *** ' + CALL ABORT + ENDIF +c +c ..... calcul de Xprimt ..... +c + + DO i = nmax, nmax2 + Xprimt(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO +c + DO i = nmax+1, nmax2 + Xprimt( nmax2 - i ) = Xprimt( i ) + ENDDO +c + +c ..... Calcul de Xf ........ + + Xf(0) = - pi + + DO i = nmax +1, nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + fxm = TANH ( fa/fb ) + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + xxpr(i) = beta + ( grossism - beta ) * fxm + + ENDDO + + DO i = nmax+1, nmax2 + xxpr(nmax2-i+1) = xxpr(i) + ENDDO + + DO i=1,nmax2 + Xf(i) = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) ) + ENDDO + + +c ***************************************************************** +c + +c ..... xuv = 0. si calcul aux pts scalaires ........ +c ..... xuv = 0.5 si calcul aux pts U ........ +c + WRITE(6,18) +c + DO 5000 ik = 1, 4 + + IF( ik.EQ.1 ) THEN + xuv = -0.25 + ELSE IF ( ik.EQ.2 ) THEN + xuv = 0. + ELSE IF ( ik.EQ.3 ) THEN + xuv = 0.50 + ELSE IF ( ik.EQ.4 ) THEN + xuv = 0.25 + ENDIF + + xo1 = 0. + + ii1=1 + ii2=iim + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + ii1 = 2 + ii2 = iim+1 + ENDIF + DO 1500 i = ii1, ii2 + + xlon2 = - pi + (REAL(i) + xuv - decalx) * depi / REAL(iim) + + Xfi = xlon2 +c + DO 250 it = nmax2,0,-1 + IF( Xfi.GE.Xf(it)) GO TO 350 +250 CONTINUE + + it = 0 + +350 CONTINUE + +c ...... Calcul de Xf(xi) ...... +c + xi = xtild(it) + + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Xf(it+1) = pi + ENDIF +c ..................................................................... +c +c Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un +c polynome de degre 3 qui passe par les points (Xf(it),xtild(it) ) +c et (Xf(it+1),xtild(it+1) ) + + CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1), + , xtild(it),xtild(it+1), a0, a1, a2, a3 ) + + Xf1 = Xf(it) + Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi + + DO 500 iter = 1,300 + xi = xi - ( Xf1 - Xfi )/ Xprimin + + IF( ABS(xi-xo1).LE.epsilon) GO TO 550 + xo1 = xi + xi2 = xi * xi + Xf1 = a0 + a1 * xi + a2 * xi2 + a3 * xi2 * xi + Xprimin = a1 + 2.* a2 * xi + 3.* a3 * xi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter + STOP 6 +550 CONTINUE + + xxprim(i) = depi/ ( REAL(iim) * Xprimin ) + xvrai(i) = xi + xzoom + +1500 CONTINUE + + + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + xvrai(1) = xvrai(iip1)-depi + xxprim(1) = xxprim(iip1) + ENDIF + DO i = 1 , iim + xlon(i) = xvrai(i) + xprimm(i) = xxprim(i) + ENDDO + DO i = 1, iim -1 + IF( xvrai(i+1). LT. xvrai(i) ) THEN + WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i, + , ')' + STOP 7 + ENDIF + ENDDO +c +c ... Reorganisation des longitudes pour les avoir entre - pi et pi .. +c ........................................................................ + + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin,xvrai(i) ) + champmax = MAX( champmax,xvrai(i) ) + ENDDO + + IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 ) THEN + GO TO 1600 + ELSE + WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi', + , ' et pi ' +c + IF( xzoom.LE.0.) THEN + IF( ik.EQ. 1 ) THEN + DO i = 1, iim + IF( xvrai(i).GE. - pi ) GO TO 80 + ENDDO + WRITE(6,*) ' PBS. 1 ! Xvrai plus petit que - pi ! ' + STOP 8 + 80 CONTINUE + is2 = i + ENDIF + + IF( is2.NE. 1 ) THEN + DO ii = is2 , iim + xlon (ii-is2+1) = xvrai(ii) + xprimm(ii-is2+1) = xxprim(ii) + ENDDO + DO ii = 1 , is2 -1 + xlon (ii+iim-is2+1) = xvrai(ii) + depi + xprimm(ii+iim-is2+1) = xxprim(ii) + ENDDO + ENDIF + ELSE + IF( ik.EQ.1 ) THEN + DO i = iim,1,-1 + IF( xvrai(i).LE. pi ) GO TO 90 + ENDDO + WRITE(6,*) ' PBS. 2 ! Xvrai plus grand que pi ! ' + STOP 9 + 90 CONTINUE + is2 = i + ENDIF + idif = iim -is2 + DO ii = 1, is2 + xlon (ii+idif) = xvrai(ii) + xprimm(ii+idif) = xxprim(ii) + ENDDO + DO ii = 1, idif + xlon (ii) = xvrai (ii+is2) - depi + xprimm(ii) = xxprim(ii+is2) + ENDDO + ENDIF + ENDIF +c +c ......... Fin de la reorganisation ............................ + + 1600 CONTINUE + + + xlon ( iip1) = xlon(1) + depi + xprimm( iip1 ) = xprimm (1 ) + + DO i = 1, iim+1 + xvrai(i) = xlon(i)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,*) ' XLON aux pts. V-0.25 apres ( en deg. ) ' +c WRITE(6,18) +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim +1 + rlonm025(i) = xlon( i ) + xprimm025(i) = xprimm(i) + ENDDO + ELSE IF( ik.EQ.2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonv(i) = xlon( i ) + xprimv(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.3) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. U apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonu(i) = xlon( i ) + xprimu(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V+0.25 apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonp025(i) = xlon( i ) + xprimp025(i) = xprimm(i) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ........... fin de la boucle do 5000 ............ + + DO i = 1, iim + xlon(i) = rlonv(i+1) - rlonv(i) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin, xlon(i) ) + champmax = MAX( champmax, xlon(i) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +18 FORMAT(/) +24 FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3) +68 FORMAT(1x,7f9.2) +566 FORMAT(1x,7f9.4) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxy.F (revision 1634) @@ -0,0 +1,69 @@ +! +! $Id$ +! + SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE + +c Auteur : P. Le Van +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c a tangente sinusoidale et eventuellement avec zoom . +c +c +#include "dimensions.h" +#include "paramet.h" +#include "serre.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_new.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( REAL( j ) ) + yprimu(j) = fyprim( REAL( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( REAL( j ) + 0.5 ) + rlatu1(j) = fy ( REAL( j ) + 0.25 ) + rlatu2(j) = fy ( REAL( j ) + 0.75 ) + + yprimv(j) = fyprim( REAL( j ) + 0.5 ) + yprimu1(j) = fyprim( REAL( j ) + 0.25 ) + yprimu2(j) = fyprim( REAL( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( REAL( i ) ) + rlonu(i) = fx ( REAL( i ) + 0.5 ) + rlonm025(i) = fx ( REAL( i ) - 0.25 ) + rlonp025(i) = fx ( REAL( i ) + 0.25 ) + + xprimv (i) = fxprim ( REAL( i ) ) + xprimu (i) = fxprim ( REAL( i ) + 0.5 ) + xprimm025(i) = fxprim ( REAL( i ) - 0.25 ) + xprimp025(i) = fxprim ( REAL( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxyhyper.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxyhyper.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxyhyper.F (revision 1634) @@ -0,0 +1,139 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy , + , xzoom, grossx, dzoomx,taux , + , rlatu,yprimu,rlatv,yprimv,rlatu1, yprimu1, rlatu2, yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE +c +c Auteur : P. Le Van . +c +c d'apres formulations de R. Sadourny . +c +c +c Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp ) +c par des fonctions a tangente hyperbolique . +c +c Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom +c et yzoom ) : +c +c a) le grossissement du zoom : grossy ( en y ) et grossx ( en x ) +c b) l' extension du zoom : dzoomy ( en y ) et dzoomx ( en x ) +c c) la raideur de la transition du zoom : taux et tauy +c +c N.B : Il vaut mieux avoir : grossx * dzoomx < pi ( radians ) +c ****** +c et grossy * dzoomy < pi/2 ( radians ) +c +#include "dimensions.h" +#include "paramet.h" + + +c ..... Arguments ... +c + REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + REAL(KIND=8) dxmin, dxmax , dymin, dymax + +c .... var. locales ..... +c + INTEGER i,j +c + + CALL fyhyp ( yzoom, grossy, dzoomy,tauy , + , rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , dymin,dymax ) + + CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv, + , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax ) + + + DO i = 1, iip1 + IF(rlonp025(i).LT.rlonv(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 < rlonv',i + STOP + ENDIF + + IF(rlonv(i).LT.rlonm025(i)) THEN + WRITE(6,*) ' Attention ! rlonm025 > rlonv',i + STOP + ENDIF + + IF(rlonp025(i).GT.rlonu(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 > rlonu',i + STOP + ENDIF + ENDDO + + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FX **** ' + +c + DO j = 1, jjm +c + IF(rlatu1(j).LE.rlatu2(j)) THEN + WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j + STOP 13 + ENDIF +c + IF(rlatu2(j).LE.rlatu(j+1)) THEN + WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j + STOP 14 + ENDIF +c + IF(rlatu(j).LE.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j + STOP 15 + ENDIF +c + IF(rlatv(j).LE.rlatu2(j)) THEN + WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j + STOP 16 + ENDIF +c + IF(rlatv(j).ge.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j + STOP 17 + ENDIF +c + IF(rlatv(j).ge.rlatu(j)) THEN + WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j + STOP 18 + ENDIF +c + ENDDO +c + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FY **** ' +c + WRITE(6,18) + WRITE(6,*) ' Latitudes ' + WRITE(6,*) ' *********** ' + WRITE(6,18) + WRITE(6,3) dymin, dymax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' +c + WRITE(6,18) + WRITE(6,*) ' Longitudes ' + WRITE(6,*) ' ************ ' + WRITE(6,18) + WRITE(6,3) dxmin, dxmax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' + WRITE(6,18) +c +3 Format(1x, ' Au centre du zoom , la longueur de la maille est', + , ' d environ ',f8.2 ,' degres ', + , ' alors que la maille en dehors de la zone du zoom est d environ + , ', f8.2,' degres ' ) +18 FORMAT(/) + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxysinus.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxysinus.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fxysinus.F (revision 1634) @@ -0,0 +1,69 @@ +! +! $Id$ +! + SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + + IMPLICIT NONE +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c avec y = Asin( j ) . +c +c Auteur : P. Le Van +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + + INTEGER i,j + + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + +#include "fxy_sin.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( REAL( j ) ) + yprimu(j) = fyprim( REAL( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( REAL( j ) + 0.5 ) + rlatu1(j) = fy ( REAL( j ) + 0.25 ) + rlatu2(j) = fy ( REAL( j ) + 0.75 ) + + yprimv(j) = fyprim( REAL( j ) + 0.5 ) + yprimu1(j) = fyprim( REAL( j ) + 0.25 ) + yprimu2(j) = fyprim( REAL( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( REAL( i ) ) + rlonu(i) = fx ( REAL( i ) + 0.5 ) + rlonm025(i) = fx ( REAL( i ) - 0.25 ) + rlonp025(i) = fx ( REAL( i ) + 0.25 ) + + xprimv (i) = fxprim ( REAL( i ) ) + xprimu (i) = fxprim ( REAL( i ) + 0.5 ) + xprimm025(i) = fxprim ( REAL( i ) - 0.25 ) + xprimp025(i) = fxprim ( REAL( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fyhyp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fyhyp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/fyhyp.F (revision 1634) @@ -0,0 +1,378 @@ +! +! $Id$ +! +c +c + SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau , + , rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , champmin,champmax ) + +cc ... Version du 01/04/2001 .... + + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c ....... d'apres formulations de R. Sadourny ....... +c +c Calcule les latitudes et derivees dans la grille du GCM pour une +c fonction f(y) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc) +c dzoom etant la distance totale de la zone du zoom ( en radians ) +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c +c N.B : Il vaut mieux avoir : grossism * dzoom < pi/2 (radians) ,en lati. +c ******************************************************************** +c +c +#include "dimensions.h" +#include "paramet.h" + + INTEGER nmax , nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c +c +c ....... arguments d'entree ....... +c + REAL yzoomdeg, grossism,dzooma,tau +c ( rentres par run.def ) + +c ....... arguments de sortie ....... +c + REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + +c +c ..... champs locaux ..... +c + + REAL dzoom + REAL(KIND=8) ylat(jjp1), yprim(jjp1) + REAL(KIND=8) yuv + REAL(KIND=8) yt(0:nmax2) + REAL(KIND=8) fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2) + SAVE Ytprim, yt,Yf + REAL(KIND=8) Yf(0:nmax2),yypr(0:nmax2) + REAL(KIND=8) yvrai(jjp1), yprimm(jjp1),ylatt(jjp1) + REAL(KIND=8) pi,depi,pis2,epsilon,y0,pisjm + REAL(KIND=8) yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax + REAL(KIND=8) yfi,Yf1,ffdy + REAL(KIND=8) ypn,deply,y00 + SAVE y00, deply + + INTEGER i,j,it,ik,iter,jlat + INTEGER jpn,jjpn + SAVE jpn + REAL(KIND=8) a0,a1,a2,a3,yi2,heavyy0,heavyy0m + REAL(KIND=8) fa(0:nmax2),fb(0:nmax2) + REAL y0min,y0max + + REAL(KIND=8) heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + pis2 = pi/2. + pisjm = pi/ REAL(jjm) + epsilon = 1.e-3 + y0 = yzoomdeg * pi/180. + + IF( dzooma.LT.1.) THEN + dzoom = dzooma * pi + ELSEIF( dzooma.LT. 12. ) THEN + WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,18) + WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) y0,grossism,tau,dzoom + + DO i = 0, nmax2 + yt(i) = - pis2 + REAL(i)* pi /nmax2 + ENDDO + + heavyy0m = heavyside( -y0 ) + heavyy0 = heavyside( y0 ) + y0min = 2.*y0*heavyy0m - pis2 + y0max = 2.*y0*heavyy0 + pis2 + + fa = 999.999 + fb = 999.999 + + DO i = 0, nmax2 + IF( yt(i).LT.y0 ) THEN + fa (i) = tau* (yt(i)-y0+dzoom/2. ) + fb(i) = (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) ) + ELSEIF ( yt(i).GT.y0 ) THEN + fa(i) = tau *(y0-yt(i)+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fhyp ( i) = 1. + ELSE + fhyp(i) = TANH ( fa(i)/fb(i) ) + ENDIF + + IF( yt(i).EQ.y0 ) fhyp(i) = 1. + IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... +c + ffdy = 0. + + DO i = 1, nmax2 + ymoy = 0.5 * ( yt(i-1) + yt( i ) ) + IF( ymoy.LT.y0 ) THEN + fa(i)= tau * ( ymoy-y0+dzoom/2.) + fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy ) + ELSEIF ( ymoy.GT.y0 ) THEN + fa(i)= tau * ( y0-ymoy+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fxm ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fxm ( i) = 1. + ELSE + fxm(i) = TANH ( fa(i)/fb(i) ) + ENDIF + IF( ymoy.EQ.y0 ) fxm(i) = 1. + IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1. + ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) ) + + ENDDO + + beta = ( grossism * ffdy - pi ) / ( ffdy - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fyhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismy ,tauy ou dzoomy', + , ' et relancer ! *** ' + CALL ABORT + + ENDIF +c +c ..... calcul de Ytprim ..... +c + + DO i = 0, nmax2 + Ytprim(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO + +c ..... Calcul de Yf ........ + + Yf(0) = - pis2 + DO i = 1, nmax2 + yypr(i) = beta + ( grossism - beta ) * fxm(i) + ENDDO + + DO i=1,nmax2 + Yf(i) = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) ) + ENDDO + +c **************************************************************** +c +c ..... yuv = 0. si calcul des latitudes aux pts. U ..... +c ..... yuv = 0.5 si calcul des latitudes aux pts. V ..... +c + WRITE(6,18) +c + DO 5000 ik = 1,4 + + IF( ik.EQ.1 ) THEN + yuv = 0. + jlat = jjm + 1 + ELSE IF ( ik.EQ.2 ) THEN + yuv = 0.5 + jlat = jjm + ELSE IF ( ik.EQ.3 ) THEN + yuv = 0.25 + jlat = jjm + ELSE IF ( ik.EQ.4 ) THEN + yuv = 0.75 + jlat = jjm + ENDIF +c + yo1 = 0. + DO 1500 j = 1,jlat + yo1 = 0. + ylon2 = - pis2 + pisjm * ( REAL(j) + yuv -1.) + yfi = ylon2 +c + DO 250 it = nmax2,0,-1 + IF( yfi.GE.Yf(it)) GO TO 350 +250 CONTINUE + it = 0 +350 CONTINUE + + yi = yt(it) + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Yf(it+1) = pis2 + ENDIF +c ................................................................. +c .... Interpolation entre yi(it) et yi(it+1) pour avoir Y(yi) +c ..... et Y'(yi) ..... +c ................................................................. + + CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1), + , yt(it),yt(it+1) , a0,a1,a2,a3 ) + + Yf1 = Yf(it) + Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi + + DO 500 iter = 1,300 + yi = yi - ( Yf1 - yfi )/ Yprimin + + IF( ABS(yi-yo1).LE.epsilon) GO TO 550 + yo1 = yi + yi2 = yi * yi + Yf1 = a0 + a1 * yi + a2 * yi2 + a3 * yi2 * yi + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter + STOP 2 +550 CONTINUE +c + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi* yi + yprim(j) = pi / ( jjm * Yprimin ) + yvrai(j) = yi + +1500 CONTINUE + + DO j = 1, jlat -1 + IF( yvrai(j+1). LT. yvrai(j) ) THEN + WRITE(6,*) ' PBS. avec rlat(',j+1,') plus petit que rlat(',j, + , ')' + STOP 3 + ENDIF + ENDDO + + WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2' + , ,' et pi/2 ' +c + IF( ik.EQ.1 ) THEN + ypn = pis2 + DO j = jlat,1,-1 + IF( yvrai(j).LE. ypn ) GO TO 1502 + ENDDO +1502 CONTINUE + + jpn = j + y00 = yvrai(jpn) + deply = pis2 - y00 + ENDIF + + DO j = 1, jjm +1 - jpn + ylatt (j) = -pis2 - y00 + yvrai(jpn+j-1) + yprimm(j) = yprim(jpn+j-1) + ENDDO + + jjpn = jpn + IF( jlat.EQ. jjm ) jjpn = jpn -1 + + DO j = 1,jjpn + ylatt (j + jjm+1 -jpn) = yvrai(j) + deply + yprimm(j + jjm+1 -jpn) = yprim(j) + ENDDO + +c *********** Fin de la reorganisation ************* +c + 1600 CONTINUE + + DO j = 1, jlat + ylat(j) = ylatt( jlat +1 -j ) + yprim(j) = yprimm( jlat +1 -j ) + ENDDO + + DO j = 1, jlat + yvrai(j) = ylat(j)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatu(j) = ylat( j ) + yyprimu(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en V apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*)' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatv(j) = ylat( j ) + yyprimv(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 3 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.75 apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu2(j) = ylat( j ) + yprimu2(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.25 apres ( en deg. ) ' +c WRITE(6,68)(yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,68) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu1(j) = ylat( j ) + yprimu1(j) = yprim( j ) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ..... fin de la boucle do 5000 ..... + + DO j = 1, jjm + ylat(j) = rrlatu(j) - rrlatu(j+1) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO j = 1, jjm + champmin = MIN( champmin, ylat(j) ) + champmax = MAX( champmax, ylat(j) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +24 FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3) +18 FORMAT(/) +68 FORMAT(1x,7f9.2) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gcm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gcm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gcm.F (revision 1634) @@ -0,0 +1,547 @@ +! +! $Id$ +! +c +c + PROGRAM gcm + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + + USE mod_const_mpi, ONLY: init_const_mpi + USE parallel + USE infotrac + USE mod_interface_dyn_phys + USE mod_hallo + USE Bands + USE getparam + USE filtreg_mod + USE control_mod + +! Ehouarn: for now these only apply to Earth: +#ifdef CPP_EARTH + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb + USE mod_phys_lmdz_omp_data, ONLY: klon_omp + USE dimphy + USE comgeomphy +#endif + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. +c ... Possibilite de choisir le schema pour l'advection de +c q , en modifiant iadv dans traceur.def (MAF,10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +!#include "com_io_dyn.h" +#include "iniprint.h" +#include "tracstoke.h" + +#ifdef INCA +! Only INCA needs these informations (from the Earth's physics) +#include "indicesol.h" +#endif + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + SAVE clesphy0 + + + + REAL zdtvr +c INTEGER nbetatmoy, nbetatdem,nbetat + INTEGER nbetatmoy, nbetatdem + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: q ! champs advectes + REAL ps(ip1jmp1) ! pression au sol +c REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches +c REAL pks(ip1jmp1) ! exner au sol +c REAL pk(ip1jmp1,llm) ! exner au milieu des couches +c REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol +c REAL phi(ip1jmp1,llm) ! geopotentiel +c REAL w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL time_0 + + LOGICAL lafin +c INTEGER ij,iq,l,i,j + INTEGER i,j + + + real time_step, t_wrt, t_ops + + + LOGICAL call_iniphys + data call_iniphys/.true./ + +c REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) +c+jld variables test conservation energie +c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation +c REAL dhecdt(ip1jmp1,llm) +c REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) +c REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec +c CHARACTER (len=15) :: ztit +c-jld + + + character (len=80) :: dynhist_file, dynhistave_file + character (len=20) :: modname + character (len=80) :: abort_message +! locales pour gestion du temps + INTEGER :: an, mois, jour + REAL :: heure + + +c----------------------------------------------------------------------- +c variables pour l'initialisation de la physique : +c ------------------------------------------------ + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + REAL zcufi(ngridmx),zcvfi(ngridmx) + REAL latfi(ngridmx),lonfi(ngridmx) + REAL airefi(ngridmx) + SAVE latfi, lonfi, airefi + + INTEGER :: ierr + + +c----------------------------------------------------------------------- +c Initialisations: +c ---------------- + + abort_message = 'last timestep reached' + modname = 'gcm' + descript = 'Run GCM LMDZ' + lafin = .FALSE. + dynhist_file = 'dyn_hist' + dynhistave_file = 'dyn_hist_ave' + + + +c---------------------------------------------------------------------- +c lecture des fichiers gcm.def ou run.def +c --------------------------------------- +c +! Ehouarn: dump possibility of using defrun +!#ifdef CPP_IOIPSL + CALL conf_gcm( 99, .TRUE. , clesphy0 ) +!#else +! CALL defrun( 99, .TRUE. , clesphy0 ) +!#endif +c +c +c------------------------------------ +c Initialisation partie parallele +c------------------------------------ + CALL init_const_mpi + + call init_parallel + call ini_getparam("out.def") + call Read_Distrib +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL Init_Phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys) +#endif + endif ! of if (planet_type.eq."earth") + CALL set_bands +#ifdef CPP_EARTH +! Ehouarn: For now only Earth physics is parallel + CALL Init_interface_dyn_phys +#endif + CALL barrier + + if (mpi_rank==0) call WriteBands + call SetDistrib(jj_Nb_Caldyn) + +c$OMP PARALLEL + call Init_Mod_hallo +c$OMP END PARALLEL + +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH +c$OMP PARALLEL + call InitComgeomphy +c$OMP END PARALLEL +#endif + endif ! of if (planet_type.eq."earth") + +c----------------------------------------------------------------------- +c Choix du calendrier +c ------------------- + +c calend = 'earth_365d' + +#ifdef CPP_IOIPSL + if (calend == 'earth_360d') then + call ioconf_calendar('360d') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an' + else if (calend == 'earth_365d') then + call ioconf_calendar('noleap') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an' + else if (calend == 'earth_366d') then + call ioconf_calendar('gregorian') + write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile' + else + abort_message = 'Mauvais choix de calendrier' + call abort_gcm(modname,abort_message,1) + endif +#endif + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz( + $ nbtr,anneeref,dayref, + $ iphysiq,day_step,nday, + $ nbsrf, is_oce,is_sic, + $ is_ter,is_lic) + + call init_inca_para( + $ iim,jjm+1,llm,klon_glo,mpi_size, + $ distrib_phys,COMM_LMDZ) +#endif + END IF + +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l'advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + ALLOCATE(q(ip1jmp1,llm,nqtot)) + +c----------------------------------------------------------------------- +c Lecture de l'etat initial : +c --------------------------- + +c lecture du fichier start.nc + if (read_start) then + ! we still need to run iniacademic to initialize some + ! constants & fields, if we run the 'newtonian' or 'SW' cases: + if (iflag_phys.ne.1) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif + +! if (planet_type.eq."earth") then +! Load an Earth-format start file + CALL dynetat0("start.nc",vcov,ucov, + & teta,q,masse,ps,phis, time_0) +! endif ! of if (planet_type.eq."earth") + +c write(73,*) 'ucov',ucov +c write(74,*) 'vcov',vcov +c write(75,*) 'teta',teta +c write(76,*) 'ps',ps +c write(77,*) 'q',q + + endif ! of if (read_start) + +c le cas echeant, creation d un etat initial + IF (prt_level > 9) WRITE(lunout,*) + . 'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT' + if (.not.read_start) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif + +c----------------------------------------------------------------------- +c Lecture des parametres de controle pour la simulation : +c ------------------------------------------------------- +c on recalcule eventuellement le pas de temps + + IF(MOD(day_step,iperiod).NE.0) THEN + abort_message = + . 'Il faut choisir un nb de pas par jour multiple de iperiod' + call abort_gcm(modname,abort_message,1) + ENDIF + + IF(MOD(day_step,iphysiq).NE.0) THEN + abort_message = + * 'Il faut choisir un nb de pas par jour multiple de iphysiq' + call abort_gcm(modname,abort_message,1) + ENDIF + + zdtvr = daysec/REAL(day_step) + IF(dtvr.NE.zdtvr) THEN + WRITE(lunout,*) + . 'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr + ENDIF + +C +C on remet le calendrier à zero si demande +c + IF (raz_date == 1) THEN + annee_ref = anneeref + day_ref = dayref + day_ini = dayref + itau_dyn = 0 + itau_phy = 0 + time_0 = 0. + write(lunout,*) + . 'GCM: On reinitialise a la date lue dans gcm.def' + ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN + write(lunout,*) + . 'GCM: Attention les dates initiales lues dans le fichier' + write(lunout,*) + . ' restart ne correspondent pas a celles lues dans ' + write(lunout,*)' gcm.def' + write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref + write(lunout,*)' day_ref=',day_ref," dayref=",dayref + write(lunout,*)' Pas de remise a zero' + ENDIF +c if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then +c write(lunout,*) +c . 'GCM: Attention les dates initiales lues dans le fichier' +c write(lunout,*) +c . ' restart ne correspondent pas a celles lues dans ' +c write(lunout,*)' gcm.def' +c write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref +c write(lunout,*)' day_ref=',day_ref," dayref=",dayref +c if (raz_date .ne. 1) then +c write(lunout,*) +c . 'GCM: On garde les dates du fichier restart' +c else +c annee_ref = anneeref +c day_ref = dayref +c day_ini = dayref +c itau_dyn = 0 +c itau_phy = 0 +c time_0 = 0. +c write(lunout,*) +c . 'GCM: On reinitialise a la date lue dans gcm.def' +c endif +c ELSE +c raz_date = 0 +c endif + +#ifdef CPP_IOIPSL + mois = 1 + heure = 0. + call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref) + jH_ref = jD_ref - int(jD_ref) + jD_ref = int(jD_ref) + + call ioconf_startdate(INT(jD_ref), jH_ref) + + write(lunout,*)'DEBUG' + write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref' + write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref + call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure) + write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure' + write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure +#else +! Ehouarn: we still need to define JD_ref and JH_ref +! and since we don't know how many days there are in a year +! we set JD_ref to 0 (this should be improved ...) + jD_ref=0 + jH_ref=0 +#endif + +c nombre d'etats dans les fichiers demarrage et histoire + nbetatdem = nday / iecri + nbetatmoy = nday / periodav + 1 + + if (iflag_phys.eq.1) then + ! these initialisations have already been done (via iniacademic) + ! if running in SW or Newtonian mode +c----------------------------------------------------------------------- +c Initialisation des constantes dynamiques : +c ------------------------------------------ + dtvr = zdtvr + CALL iniconst + +c----------------------------------------------------------------------- +c Initialisation de la geometrie : +c -------------------------------- + CALL inigeom + +c----------------------------------------------------------------------- +c Initialisation du filtre : +c -------------------------- + CALL inifilr + endif ! of if (iflag_phys.eq.1) +c +c----------------------------------------------------------------------- +c Initialisation de la dissipation : +c ---------------------------------- + + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + +c----------------------------------------------------------------------- +c Initialisation de la physique : +c ------------------------------- + IF (call_iniphys.and.iflag_phys.eq.1) THEN + latfi(1)=rlatu(1) + lonfi(1)=0. + zcufi(1) = cu(1) + zcvfi(1) = cv(1) + DO j=2,jjm + DO i=1,iim + latfi((j-2)*iim+1+i)= rlatu(j) + lonfi((j-2)*iim+1+i)= rlonv(i) + zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i) + zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i) + ENDDO + ENDDO + latfi(ngridmx)= rlatu(jjp1) + lonfi(ngridmx)= 0. + zcufi(ngridmx) = cu(ip1jm+1) + zcvfi(ngridmx) = cv(ip1jm-iim) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi) + + WRITE(lunout,*) + . 'GCM: WARNING!!! vitesse verticale nulle dans la physique' +! Earth: + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys/nsplit_phys , + , latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp ) +#endif + endif ! of if (planet_type.eq."earth") + call_iniphys=.false. + ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1)) + + +c----------------------------------------------------------------------- +c Initialisation des dimensions d'INCA : +c -------------------------------------- + IF (config_inca /= 'none') THEN +!$OMP PARALLEL +#ifdef INCA + CALL init_inca_dim(klon_omp,llm,iim,jjm, + $ rlonu,rlatu,rlonv,rlatv) +#endif +!$OMP END PARALLEL + END IF + +c----------------------------------------------------------------------- +c Initialisation des I/O : +c ------------------------ + + + day_end = day_ini + nday + WRITE(lunout,300)day_ini,day_end + 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//) + +#ifdef CPP_IOIPSL + call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure) + write (lunout,301)jour, mois, an + call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure) + write (lunout,302)jour, mois, an + 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4) + 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4) +#endif + +! if (planet_type.eq."earth") then +! Write an Earth-format restart file + CALL dynredem0_p("restart.nc", day_end, phis) +! endif + + ecripar = .TRUE. + +#ifdef CPP_IOIPSL + time_step = zdtvr + IF (mpi_rank==0) then + if (ok_dyn_ins) then + ! initialize output file for instantaneous outputs + ! t_ops = iecri * daysec ! do operations every t_ops + t_ops =((1.0*iecri)/day_step) * daysec + t_wrt = daysec ! iecri * daysec ! write output every t_wrt + t_wrt = daysec ! iecri * daysec ! write output every t_wrt + CALL inithist(day_ref,annee_ref,time_step, + & t_ops,t_wrt) + endif + + IF (ok_dyn_ave) THEN + ! initialize output file for averaged outputs + t_ops = iperiod * time_step ! do operations every t_ops + t_wrt = periodav * daysec ! write output every t_wrt + CALL initdynav(day_ref,annee_ref,time_step, + & t_ops,t_wrt) +! CALL initdynav_p(dynhistave_file,day_ref,annee_ref,time_step, +! . t_ops, t_wrt, histaveid) + END IF + ENDIF + dtav = iperiod*dtvr/daysec +#endif +! #endif of #ifdef CPP_IOIPSL + +c Choix des frequences de stokage pour le offline +c istdyn=day_step/4 ! stockage toutes les 6h=1jour/4 +c istdyn=day_step/12 ! stockage toutes les 2h=1jour/12 + istdyn=day_step/4 ! stockage toutes les 6h=1jour/12 + istphy=istdyn/iphysiq + + +c +c----------------------------------------------------------------------- +c Integration temporelle du modele : +c ---------------------------------- + +c write(78,*) 'ucov',ucov +c write(78,*) 'vcov',vcov +c write(78,*) 'teta',teta +c write(78,*) 'ps',ps +c write(78,*) 'q',q + +c$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logici/,/logicl/) + CALL leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + . time_0) +c$OMP END PARALLEL + + + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/geopot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/geopot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/geopot.F (revision 1634) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + + DO 1 ij = 1, ngrid + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + 1 CONTINUE + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = 1,ngrid + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/geopot_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/geopot_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/geopot_p.F (revision 1634) @@ -0,0 +1,66 @@ + SUBROUTINE geopot_p ( ngrid, teta, pk, pks, phis, phi ) + USE parallel + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij,ijb,ije + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_sud) ije=ij_end + + DO ij = ijb, ije + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + ENDDO + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = ijb,ije + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/getparam.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/getparam.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/getparam.F90 (revision 1634) @@ -0,0 +1,118 @@ +! +! $Id$ +! +MODULE getparam +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + INTERFACE getpar + MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml + END INTERFACE + + INTEGER, PARAMETER :: out_eff=99 + +CONTAINS + SUBROUTINE ini_getparam(fichier) + USE parallel + ! + IMPLICIT NONE + ! + CHARACTER*(*) :: fichier + IF (mpi_rank==0) OPEN(out_eff,file=fichier,status='unknown',form='formatted') + + END SUBROUTINE ini_getparam + + SUBROUTINE fin_getparam + USE parallel + ! + IMPLICIT NONE + ! + IF (mpi_rank==0) CLOSE(out_eff) + + END SUBROUTINE fin_getparam + + SUBROUTINE getparamr(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + REAL :: def_val + REAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparamr + + SUBROUTINE getparami(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + INTEGER :: def_val + INTEGER :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) comment + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparami + + SUBROUTINE getparaml(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + LOGICAL :: def_val + LOGICAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparaml + + +END MODULE getparam Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_dyn_fi.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_dyn_fi.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_dyn_fi.F (revision 1634) @@ -0,0 +1,38 @@ +! +! $Header$ +! + SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles + CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid) + CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid) + +c traitement des point normaux + DO ifield=1,nfield + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_dyn_fi_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_dyn_fi_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_dyn_fi_p.F (revision 1634) @@ -0,0 +1,49 @@ +! +! $Id$ +! + SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi) +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics + USE mod_interface_dyn_phys + USE dimphy + USE PARALLEL + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ig,l + +c----------------------------------------------------------------------- +c calcul: +c ------- + +c IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles +c traitement des point normaux +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nfield + DO ig=1,klon + i=index_i(ig) + j=index_j(ig) + pfi(ig,l)=pdyn(i,j,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +#else + write(lunout,*) "gr_fi_dyn_p : This routine should not be called", + & "without parallelized physics" + stop +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_ecrit_fi.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_ecrit_fi.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_ecrit_fi.F (revision 1634) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi) + + IMPLICIT none + +c Transformer une variable de la grille d'ecriture a la grille physique + + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield) +c + INTEGER i, j, n, ig +c +c print*,'iim jjm ',iim,jjm + +c modif par abd 21 02 01 + + jjm = jjmp1 - 1 + do n = 1, nfield + fi(1,n) = ecrit(1,1,n) + fi(nlon,n) = ecrit(1,jjm+1,n) + DO j = 2, jjm + ig = 2+(j-2)*iim + DO i = 1, iim + fi(ig-1+i,n) = ecrit(i,j,n) + ENDDO + ENDDO + ENDDO + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_fi_dyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_fi_dyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_fi_dyn.F (revision 1634) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + DO ifield=1,nfield +c traitement des poles + DO i=1,im + pdyn(i,1,ifield)=pfi(1,ifield) + pdyn(i,jm,ifield)=pfi(ngrid,ifield) + ENDDO + +c traitement des point normaux + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1) + pdyn(im,j,ifield)=pdyn(1,j,ifield) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_fi_dyn_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_fi_dyn_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_fi_dyn_p.F (revision 1634) @@ -0,0 +1,61 @@ +! +! $Id$ +! + SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn) +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics + USE mod_interface_dyn_phys + USE dimphy + use parallel + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO ifield=1,nfield + + do ig=1,klon + i=index_i(ig) + j=index_j(ig) + pdyn(i,j,ifield)=pfi(ig,ifield) + if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield) + enddo + +c traitement des poles + if (pole_nord) then + do i=1,im + pdyn(i,1,ifield)=pdyn(1,1,ifield) + enddo + endif + + if (pole_sud) then + do i=1,im + pdyn(i,jm,ifield)=pdyn(1,jm,ifield) + enddo + endif + + ENDDO +c$OMP END DO NOWAIT +#else + write(lunout,*) "gr_fi_dyn_p : This routine should not be called", + & "without parallelized physics" + stop +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_int_dyn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_int_dyn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_int_dyn.F (revision 1634) @@ -0,0 +1,49 @@ +! +! $Header$ +! + subroutine gr_int_dyn(champin,champdyn,iim,jp1) + implicit none +c======================================================================= +c passage d'un champ interpole a un champ sur grille scalaire +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER iim + integer ip1, jp1 + REAL champin(iim, jp1) + REAL champdyn(iim+1, jp1) + + INTEGER i, j + real polenord, polesud + +c----------------------------------------------------------------------- +c calcul: +c ------- + + ip1 = iim + 1 + polenord = 0. + polesud = 0. + do i = 1, iim + polenord = polenord + champin (i, 1) + polesud = polesud + champin (i, jp1) + enddo + polenord = polenord / iim + polesud = polesud / iim + do j = 1, jp1 + do i = 1, iim + if (j .eq. 1) then + champdyn(i, j) = polenord + else if (j .eq. jp1) then + champdyn(i, j) = polesud + else + champdyn(i, j) = champin (i, j) + endif + enddo + champdyn(ip1, j) = champdyn(1, j) + enddo + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_u_scal.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_u_scal.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_u_scal.F (revision 1634) @@ -0,0 +1,60 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=ip1jmp1,2,-1 + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + + CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_u_scal_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_u_scal_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_u_scal_p.F (revision 1634) @@ -0,0 +1,72 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal_p(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije + +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + + DO l=1,nx + DO ij=ijb+1,ije + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + +cym CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + ijb=ij_begin + ije=ij_end + + DO l=1,nx + DO ij=ijb,ije-iip1+1,iip1 + x_scal(ij,l)=x_scal(ij+iip1-1,l) + ENDDO + ENDDO + RETURN + + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_v_scal.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_v_scal.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_v_scal.F (revision 1634) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=iip2,ip1jm + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_v_scal_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_v_scal_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gr_v_scal_p.F (revision 1634) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal_p(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO l=1,nx + DO ij=ijb,ije + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + ENDDO + + if (pole_nord) then + DO l=1,nx + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + ENDDO + endif + + if (pole_sud) then + DO l=1,nx + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + endif + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grad.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grad.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grad.F (revision 1634) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE grad(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij +c +c + DO 6 l = 1,klevel +c + DO 2 ij = 1, ip1jmp1 - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = iip1, ip1jmp1, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + DO 4 ij = 1,ip1jm + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grad_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grad_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grad_p.F (revision 1634) @@ -0,0 +1,53 @@ + SUBROUTINE grad_p(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije,jjb,jje +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 6 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + DO 2 ij = ijb, ije - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = ijb+iip1-1, ije, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE +c$OMP END DO NOWAIT + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv.F (revision 1634) @@ -0,0 +1,57 @@ +! +! $Header$ +! + SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) + + REAL div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c +c +c + CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) + CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) +c + DO 10 iter = 1,ld +c + CALL diverg( klevel, gdx , gdy, div ) + CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 ) + CALL grad( klevel, div, gdx, gdy ) +c + DO 5 l = 1, klevel + DO 3 ij = 1, ip1jmp1 + gdx( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + DO 4 ij = 1, ip1jm + gdy( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv2.F (revision 1634) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL div(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + +c ........................................................ +c +c + CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) + CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf( klevel, gdx, gdy , div ) + + IF( ld.GT.1 ) THEN + + CALL laplacien ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... + + DO iter = 1, ld -2 + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO + + ENDIF + + + CALL filtreg( div , jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel, div, gdx, gdy ) + +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + gdx( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + DO ij = 1, ip1jm + gdy( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv2_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv2_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv2_p.F (revision 1634) @@ -0,0 +1,147 @@ + SUBROUTINE gradiv2_p(klevel, xcov, ycov, ld, gdx_out, gdy_out ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + USE Write_field_p + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: gdx( ip1jmp1,llm ), gdy( ip1jm,llm ) + REAL gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL,SAVE :: div(ip1jmp1,llm) + REAL :: tmp_div2(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + INTEGER :: ijb,ije,jjb,jje + Type(Request) :: request_dissip + +c ........................................................ +c +c +c CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) +c CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdy(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo(gdy,ip1jm,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf_p( klevel, gdx, gdy , div ) +c call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/))) + + IF( ld.GT.1 ) THEN +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + CALL laplacien_p ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... +c call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/))) + + DO iter = 1, ld -2 +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO +c call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/))) + ENDIF + + jjb=jj_begin + jje=jj_end + + CALL filtreg_p( div ,jjb,jje, jjp1, klevel, 2, 1, .TRUE., 1 ) +c call exchange_Hallo(div,ip1jmp1,llm,0,1) +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL grad_p ( klevel, div, gdx, gdy ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if (pole_sud) ije=ij_end + DO ij = ijb, ije + gdx_out( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + + if (pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gdy_out( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradiv_p.F (revision 1634) @@ -0,0 +1,109 @@ + SUBROUTINE gradiv_p(klevel, xcov, ycov, ld, gdx_out, gdy_out ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: gdx( ip1jmp1,llm ), gdy( ip1jm,llm ) + + REAL gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel ) + + REAL,SAVE :: div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) +c CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + gdx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + gdy(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + DO 10 iter = 1,ld + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(gdy,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL diverg_p( klevel, gdx , gdy, div ) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2,1, .true.,2 ) + +c call exchange_Hallo(div,ip1jmp1,llm,0,1) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(div,ip1jmp1,llm,1,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL grad_p( klevel, div, gdx, gdy ) +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1, klevel + + if(pole_sud) ije=ij_end + DO 3 ij = ijb, ije + gdx_out( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + + if(pole_sud) ije=ij_end-iip1 + DO 4 ij = ijb, ije + gdy_out( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradsdef.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradsdef.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/gradsdef.h (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! + integer nfmx,imx,jmx,lmx,nvarmx + parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000) + + real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx) + + integer imd(imx),jmd(jmx),lmd(lmx) + integer iid(imx),jid(jmx) + integer ifd(imx),jfd(jmx) + integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx) + + integer nvar(nfmx),ivar(nfmx) + logical firsttime(nfmx) + + character*10 var(nvarmx,nfmx),fichier(nfmx) + character*40 title(nfmx),tvar(nvarmx,nfmx) + + common/gradsdef/xd,yd,zd,dtime, + s imd,jmd,lmd,iid,jid,ifd,jfd, + s unit,irec,nvar,ivar,itime,nld,firsttime, + s var,fichier,title,tvar Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grid_atob.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grid_atob.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grid_atob.F (revision 1634) @@ -0,0 +1,971 @@ +! +! $Id$ +! + SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Aucune ponderation est consideree (voir grille_p) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) + REAL distans(2200*1100) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c +c Calculer les limites des zones des nouveaux points +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO +c +c Determiner la zone sur laquelle chaque ancien point se trouve +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + sortie(ii,jj) = sortie(ii,jj) + entree(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c Si aucun ancien point tombe sur une zone, c'est un probleme +c + + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ENDDO + ENDDO + + RETURN + END + + + SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Consideration de la distance des points (voir grille_m) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(200),d(200) + REAL number(400,200) + INTEGER indx(400,200), indy(400,200) + REAL dist(400,200), distsom(400,200) +c + IF (imar.GT.400 .OR. jmar.GT.200) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + IF (imdep.GT.400 .OR. jmdep.GT.200) THEN + PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep + CALL ABORT + ENDIF +c +c calculer les bords a et b de la nouvelle grille +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + +c +c calculer les bords c et d de la nouvelle grille +c + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + +c +c trouver les indices (indx,indy) de la nouvelle grille sur laquelle +c un point de l'ancienne grille est tombe. +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + indx(i,j) = ii + indy(i,j) = jj + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c faire une verification +c + + DO i = 1, imdep + DO j = 1, jmdep + IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN + PRINT*, 'Probleme grave,i,j,indx,indy=', + . i,j,indx(i,j),indy(i,j) + CALL abort + ENDIF + ENDDO + ENDDO + +c +c calculer la distance des anciens points avec le nouveau point, +c on prend ensuite une sorte d'inverse pour ponderation. +c + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + distsom(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2 + . +(ydata(j)-y(indy(i,j)))**2 ) + distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j)) + . + dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1. + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j)) + ENDDO + ENDDO + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j)) + . + entree(i,j) * dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) + . + dist(i,j) + ENDDO + ENDDO + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief, + . imar, jmar, x, y, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique +c un champ indicateur (masque) terre/ocean +c terre:1; ocean:0 +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL relief(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL num_tot(2200,1100), num_oce(2200,1100) +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_oce(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) ) + . num_oce(ii,jj) = num_oce(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c +c + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN + mask(i,j) = 0. + ELSE + mask(i,j) = 1. + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END +c +c + + + SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une +c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur +c fixe (0.001m). +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar), mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_tot(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + sortie(ii,jj) = sortie(ii,jj) + LOG(entree(i,j)) + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c + + DO i = 1, imar + DO j = 1, jmar + IF (NINT(mask(i,j)).EQ.1) THEN + IF (num_tot(i,j) .GT. 0.0) THEN + sortie(i,j) = sortie(i,j) / num_tot(i,j) + sortie(i,j) = EXP(sortie(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ELSE + sortie(i,j) = 0.001 + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + + SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01, + . imar, jmar, x, y, frac_ice) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la +c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace +c (entre 0 et 1) dans une grille plus grossiere. +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL glace01(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL frac_ice(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400), num_ice(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_ice(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (NINT(glace01(i,j)).EQ.1 ) + . num_ice(ii,jj) = num_ice(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF (num_ice(i,j).GT.0.001) THEN + frac_ice(i,j) = num_ice(i,j) / num_tot(i,j) + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN + frac_ice(i,j) = 1.0 + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief, + . immod, jmmod, xmod, ymod, rugs) +c======================================================================= +c Calculer la longueur de rugosite liee au relief en utilisant +c l'ecart-type dans une maille de 1x1 +C======================================================================= + IMPLICIT none +c +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + REAL amin, AMAX +c + INTEGER imrel, jmrel + REAL xrel(imrel),yrel(jmrel) + REAL relief(imrel,jmrel) +c + INTEGER immod, jmmod + REAL xmod(immod),ymod(jmmod) + REAL rugs(immod,jmmod) +c + INTEGER imtmp, jmtmp + PARAMETER (imtmp=360,jmtmp=180) + REAL xtmp(imtmp), ytmp(jmtmp) + REAL(KIND=8) cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp) + REAL zzzz +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) +c + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +c + IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN + PRINT*, 'immod ou jmmod trop grand', immod, jmmod + CALL ABORT + ENDIF +c +c Calculs intermediares: +c + xtmp(1) = -180.0 + 360.0/REAL(imtmp) / 2.0 + DO i = 2, imtmp + xtmp(i) = xtmp(i-1) + 360.0/REAL(imtmp) + ENDDO + DO i = 1, imtmp + xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0) + ENDDO + ytmp(1) = -90.0 + 180.0/REAL(jmtmp) / 2.0 + DO j = 2, jmtmp + ytmp(j) = ytmp(j-1) + 180.0/REAL(jmtmp) + ENDDO + DO j = 1, jmtmp + ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0) + ENDDO +c + a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0 + b(1) = (xtmp(1)+xtmp(2))/2.0 + DO i = 2, imtmp-1 + a(i) = b(i-1) + b(i) = (xtmp(i)+xtmp(i+1))/2.0 + ENDDO + a(imtmp) = b(imtmp-1) + b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0 + + c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0 + d(1) = (ytmp(1)+ytmp(2))/2.0 + DO j = 2, jmtmp-1 + c(j) = d(j-1) + d(j) = (ytmp(j)+ytmp(j+1))/2.0 + ENDDO + c(jmtmp) = d(jmtmp-1) + d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0 + + DO i = 1, imtmp + DO j = 1, jmtmp + number(i,j) = 0.0 + cham1tmp(i,j) = 0.0 + cham2tmp(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imtmp + DO jj = 1, jmtmp + DO i = 1, imrel + IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR. + . ( xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmrel + IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR. + . ( yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j) + cham2tmp(ii,jj) = cham2tmp(ii,jj) + . + relief(i,j)*relief(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, imtmp + DO j = 1, jmtmp + IF (number(i,j) .GT. 0.001) THEN + cham1tmp(i,j) = cham1tmp(i,j) / number(i,j) + cham2tmp(i,j) = cham2tmp(i,j) / number(i,j) + zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2 + if (zzzz .lt. 0.0) then + if (zzzz .gt. -7.5) then + zzzz = 0.0 + print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0' + else + stop 'Pb rugsoro, zzzz <-7.5' + endif + endif + cham2tmp(i,j) = SQRT(zzzz) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO +c + amin = cham2tmp(1,1) + AMAX = cham2tmp(1,1) + DO j = 1, jmtmp + DO i = 1, imtmp + IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j) + IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type 1x1:', amin, AMAX +c +c +c + a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0 + b(1) = (xmod(1)+xmod(2))/2.0 + DO i = 2, immod-1 + a(i) = b(i-1) + b(i) = (xmod(i)+xmod(i+1))/2.0 + ENDDO + a(immod) = b(immod-1) + b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0 + + c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0 + d(1) = (ymod(1)+ymod(2))/2.0 + DO j = 2, jmmod-1 + c(j) = d(j-1) + d(j) = (ymod(j)+ymod(j+1))/2.0 + ENDDO + c(jmmod) = d(jmmod-1) + d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0 +c + DO i = 1, immod + DO j = 1, jmmod + number(i,j) = 0.0 + rugs(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, immod + DO jj = 1, jmmod + DO i = 1, imtmp + IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR. + . ( xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmtmp + IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR. + . ( ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + rugs(ii,jj) = rugs(ii,jj) + . + LOG(MAX(0.001_8,cham2tmp(i,j))) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, immod + DO j = 1, jmmod + IF (number(i,j) .GT. 0.001) THEN + rugs(i,j) = rugs(i,j) / number(i,j) + rugs(i,j) = EXP(rugs(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans) +#ifdef CRAY + ij_proche = ISMIN(imtmp*jmtmp,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imtmp*jmtmp + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imtmp + 1 + i_proche = ij_proche - (j_proche-1)*imtmp + PRINT*, "solution:", ij_proche, i_proche, j_proche + rugs(i,j) = LOG(MAX(0.001_8,cham2tmp(i_proche,j_proche))) + ENDIF + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type du modele:', amin, AMAX +c + DO j = 1, jmmod + DO i = 1, immod + rugs(i,j) = rugs(i,j) / AMAX * 20.0 + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Longueur de rugosite du modele:', amin, AMAX +c + RETURN + END +c + SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance) +c +c Auteur: Laurent Li (le 30 decembre 1996) +c +c Ce programme calcule la distance minimale (selon le grand cercle) +c entre deux points sur la terre +c +c Input: + INTEGER im, jm ! dimensions + REAL rf_lon ! longitude du point de reference (degres) + REAL rf_lat ! latitude du point de reference (degres) + REAL rlon(im), rlat(jm) ! longitude et latitude des points +c +c Output: + REAL distance(im,jm) ! distances en metre +c + REAL rlon1, rlat1 + REAL rlon2, rlat2 + REAL dist + REAL pa, pb, p, pi +c + REAL radius + PARAMETER (radius=6371229.) +c + pi = 4.0 * ATAN(1.0) +c + DO 9999 j = 1, jm + DO 9999 i = 1, im +c + rlon1=rf_lon + rlat1=rf_lat + rlon2=rlon(i) + rlat2=rlat(j) + pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a + pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b + p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens) +c + dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p)) + dist = radius * dist + distance(i,j) = dist +c + 9999 CONTINUE +c + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grid_noro.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grid_noro.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grid_noro.F (revision 1634) @@ -0,0 +1,521 @@ +! +! $Id$ +! +c +c + SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata, + . imar, jmar, x, y, + . zphi,zmea,zstd,zsig,zgam,zthe, + . zpic,zval,mask) +c======================================================================= +c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) +c +c Compute the Parameters of the SSO scheme as described in +c LOTT & MILLER (1997) and LOTT(1999). +c Target points are on a rectangular grid: +c iim+1 latitudes including North and South Poles; +c jjm+1 longitudes, with periodicity jjm+1=1. +c aux poles. At the poles the fields value is repeated +c jjm+1 time. +c The parameters a,b,c,d represent the limite of the target +c gridpoint region. The means over this region are calculated +c from USN data, ponderated by a weight proportional to the +c surface occupated by the data inside the model gridpoint area. +c In most circumstances, this weight is the ratio between the +c surface of the USN gridpoint area and the surface of the +c model gridpoint area. +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X and Y input field +c xdata, ydata: coordinates X and Y input field +c zdata: Input field +c In this version it is assumed that the entry data come from +c the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080. +c OUTPUT: +c imar, jmar: dimensions X and Y Output field +c x, y: ccordinates X and Y Output field. +c zmea: Mean orographie +c zstd: Standard deviation +c zsig: Slope +c zgam: Anisotropy +c zthe: Orientation of the small axis +c zpic: Maximum altitude +c zval: Minimum altitude +C======================================================================= + + IMPLICIT INTEGER (I,J) + IMPLICIT REAL(X,Z) + + parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5) +#include "dimensions.h" + REAL xusn(iusn+2*iext),yusn(jusn+2) + REAL zusn(iusn+2*iext,jusn+2) + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL zdata(imdep,jmdep) +c + INTEGER imar, jmar + +C INTERMEDIATE FIELDS (CORRELATIONS OF OROGRAPHY GRADIENT) + + REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1) + REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1) + REAL weight(iim+1,jjm+1) + +C CORRELATIONS OF USN OROGRAPHY GRADIENTS + + REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2) + REAL zxtzyusn(iusn+2*iext,jusn+2) + REAL x(imar+1),y(jmar),zphi(imar+1,jmar) + REAL zmea(imar+1,jmar),zstd(imar+1,jmar) + REAL zmea0(imar+1,jmar) ! GK211005 (CG) + REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) + REAL zpic(imar+1,jmar),zval(imar+1,jmar) +cxxx PB integer mask(imar+1,jmar) + real mask(imar+1,jmar), mask_tmp(imar+1,jmar) + real num_tot(2200,1100),num_lan(2200,1100) +c + REAL a(2200),b(2200),c(1100),d(1100) + logical masque_lu +c + print *,' parametres de l orographie a l echelle sous maille' + xpi=acos(-1.) + rad = 6 371 229. + zdeltay=2.*xpi/REAL(jusn)*rad +c +c utilise-t'on un masque lu? +c + masque_lu = .true. + if (maxval(mask) == -99999 .and. minval(mask) == -99999) then + masque_lu= .false. + masque = 0.0 + endif + write(*,*)'Masque lu', masque_lu +c +c quelques tests de dimensions: +c +c + if(iim.ne.imar) STOP 'Problem dim. x' + if(jjm.ne.jmar-1) STOP 'Problem dim. y' + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar or jmar too big', imar, jmar + CALL ABORT + ENDIF + + IF(imdep.ne.iusn.or.jmdep.ne.jusn)then + print *,' imdep or jmdep bad dimensions:',imdep,jmdep + call abort + ENDIF + + IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN + print *,' imar or jmar bad dimensions:',imar,jmar + call abort + ENDIF + + +c print *,'xdata:',xdata +c print *,'ydata:',ydata +c print *,'x:',x +c print *,'y:',y +c +C EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT +C BOUNDARIES: +c + DO j=1,jusn + yusn(j+1)=ydata(j) + DO i=1,iusn + zusn(i+iext,j+1)=zdata(i,j) + xusn(i+iext)=xdata(i) + ENDDO + DO i=1,iext + zusn(i,j+1)=zdata(iusn-iext+i,j) + xusn(i)=xdata(iusn-iext+i)-2.*xpi + zusn(iusn+iext+i,j+1)=zdata(i,j) + xusn(iusn+iext+i)=xdata(i)+2.*xpi + ENDDO + ENDDO + + yusn(1)=ydata(1)+(ydata(1)-ydata(2)) + yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1)) + DO i=1,iusn/2+iext + zusn(i,1)=zusn(i+iusn/2,2) + zusn(i+iusn/2+iext,1)=zusn(i,2) + zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1) + zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1) + ENDDO +c +c COMPUTE LIMITS OF MODEL GRIDPOINT AREA +C ( REGULAR GRID) +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar+1) = b(imar) + b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 +c +c initialisations: +c + DO i = 1, imar+1 + DO j = 1, jmar + weight(i,j) = 0.0 + zxtzx(i,j) = 0.0 + zytzy(i,j) = 0.0 + zxtzy(i,j) = 0.0 + ztz(i,j) = 0.0 + zmea(i,j) = 0.0 + zpic(i,j) =-1.E+10 + zval(i,j) = 1.E+10 + ENDDO + ENDDO +c +c COMPUTE SLOPES CORRELATIONS ON USN GRID +c + DO j = 1,jusn+2 + DO i = 1, iusn+2*iext + zytzyusn(i,j)=0.0 + zxtzxusn(i,j)=0.0 + zxtzyusn(i,j)=0.0 + ENDDO + ENDDO + + + DO j = 2,jusn+1 + zdeltax=zdeltay*cos(yusn(j)) + DO i = 2, iusn+2*iext-1 + zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 + zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2 + zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay + * *(zusn(i+1,j)-zusn(i-1,j))/zdeltax + ENDDO + ENDDO +c +c SUMMATION OVER GRIDPOINT AREA +c + zleny=xpi/REAL(jusn)*rad + xincr=xpi/2./REAL(jusn) + DO ii = 1, imar+1 + DO jj = 1, jmar + num_tot(ii,jj)=0. + num_lan(ii,jj)=0. +c PRINT *,' iteration ii jj:',ii,jj + DO j = 2,jusn+1 +c DO j = 3,jusn + zlenx=zleny*cos(yusn(j)) + zdeltax=zdeltay*cos(yusn(j)) + zbordnor=(c(jj)-yusn(j)+xincr)*rad + zbordsud=(yusn(j)-d(jj)+xincr)*rad + weighy=AMAX1(0., + * amin1(zbordnor,zbordsud,zleny)) + IF(weighy.ne.0)THEN + DO i = 2, iusn+2*iext-1 + zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j)) + zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j)) + weighx=AMAX1(0., + * amin1(zbordest,zbordoue,zlenx)) + IF(weighx.ne.0)THEN + num_tot(ii,jj)=num_tot(ii,jj)+1.0 + if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0 + weight(ii,jj)=weight(ii,jj)+weighx*weighy + zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy + zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy + zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy + ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy +c mean + zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy +c peacks + zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j)) +c valleys + zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND +C LOTT (1999) SSO SCHEME. +c + zllmmea=0. + zllmstd=0. + zllmsig=0. + zllmgam=0. + zllmpic=0. + zllmval=0. + zllmthe=0. + zminthe=0. +c print 100,' ' +c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') + DO ii = 1, imar+1 + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Mask +cXXX if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then +cXXX mask(ii,jj)=1 +cXXX else +cXXX mask(ii,jj)=0 +cXXX ENDIF + if (.not. masque_lu) then + mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj) + endif +c Mean Orography: + zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) + zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) + zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) + zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) + ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) +c Standard deviation: + zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) + ELSE + PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + ENDDO + ENDDO + +C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES: + + DO ii = 1, imar+1 + zxtzx(ii,1)=zxtzx(ii,2) + zxtzx(ii,jmar)=zxtzx(ii,jmar-1) + zxtzy(ii,1)=zxtzy(ii,2) + zxtzy(ii,jmar)=zxtzy(ii,jmar-1) + zytzy(ii,1)=zytzy(ii,2) + zytzy(ii,jmar)=zytzy(ii,jmar-1) + ENDDO + +C FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME. + +C FIRST FILTER, MOVING AVERAGE OVER 9 POINTS. + + zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee + CALL MVA9(zmea,iim+1,jjm+1) + CALL MVA9(zstd,iim+1,jjm+1) + CALL MVA9(zpic,iim+1,jjm+1) + CALL MVA9(zval,iim+1,jjm+1) + CALL MVA9(zxtzx,iim+1,jjm+1) + CALL MVA9(zxtzy,iim+1,jjm+1) + CALL MVA9(zytzy,iim+1,jjm+1) +CXXX Masque prenant en compte maximum de terre +CXXX On seuil a 10% de terre de terre car en dessous les parametres de surface n'on +CXXX pas de sens (PB) + mask_tmp= 0.0 + WHERE(mask .GE. 0.1) mask_tmp = 1. + + DO ii = 1, imar + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Coefficients K, L et M: + xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. + xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. + xm=zxtzy(ii,jj) + xp=xk-sqrt(xl**2+xm**2) + xq=xk+sqrt(xl**2+xm**2) + xw=1.e-8 + if(xp.le.xw) xp=0. + if(xq.le.xw) xq=xw + if(abs(xm).le.xw) xm=xw*sign(1.,xm) +c slope: +cXXX zsig(ii,jj)=sqrt(xq)*mask(ii,jj) +cXXXc isotropy: +cXXX zgam(ii,jj)=xp/xq*mask(ii,jj) +cXXXc angle theta: +cXXX zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj) +cXXX zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cXXX zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cXXX zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj) +cXXX zval(ii,jj)=zval(ii,jj)*mask(ii,jj) +cXXX zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj) +CXX* PB modif pour maque de terre fractionnaire +c slope: + zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj) +c isotropy: + zgam(ii,jj)=xp/xq*mask_tmp(ii,jj) +c angle theta: + zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj) + ! GK211005 (CG) ne pas forcement lisser la topo + ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj) + ! + zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj) + zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj) + zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj) +c print 101,ii,jj, +c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), +c * zthe(ii,jj) +c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) + ELSE +c PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + zllmmea=AMAX1(zmea(ii,jj),zllmmea) + zllmstd=AMAX1(zstd(ii,jj),zllmstd) + zllmsig=AMAX1(zsig(ii,jj),zllmsig) + zllmgam=AMAX1(zgam(ii,jj),zllmgam) + zllmthe=AMAX1(zthe(ii,jj),zllmthe) + zminthe=amin1(zthe(ii,jj),zminthe) + zllmpic=AMAX1(zpic(ii,jj),zllmpic) + zllmval=AMAX1(zval(ii,jj),zllmval) + ENDDO + ENDDO + print *,' MEAN ORO:',zllmmea + print *,' ST. DEV.:',zllmstd + print *,' PENTE:',zllmsig + print *,' ANISOTROP:',zllmgam + print *,' ANGLE:',zminthe,zllmthe + print *,' pic:',zllmpic + print *,' val:',zllmval + +C +c gamma and theta a 1. and 0. at poles +c + DO jj=1,jmar + zmea(imar+1,jj)=zmea(1,jj) + zphi(imar+1,jj)=zphi(1,jj) + zpic(imar+1,jj)=zpic(1,jj) + zval(imar+1,jj)=zval(1,jj) + zstd(imar+1,jj)=zstd(1,jj) + zsig(imar+1,jj)=zsig(1,jj) + zgam(imar+1,jj)=zgam(1,jj) + zthe(imar+1,jj)=zthe(1,jj) + ENDDO + + + zmeanor=0.0 + zmeasud=0.0 + zstdnor=0.0 + zstdsud=0.0 + zsignor=0.0 + zsigsud=0.0 + zweinor=0.0 + zweisud=0.0 + zpicnor=0.0 + zpicsud=0.0 + zvalnor=0.0 + zvalsud=0.0 + + DO ii=1,imar + zweinor=zweinor+ weight(ii, 1) + zweisud=zweisud+ weight(ii,jmar) + zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) + zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) + zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) + zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) + zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) + zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) + zpicnor=zpicnor+zpic(ii, 1)*weight(ii, 1) + zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar) + zvalnor=zvalnor+zval(ii, 1)*weight(ii, 1) + zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar) + ENDDO + + DO ii=1,imar+1 + zmea(ii, 1)=zmeanor/zweinor + zmea(ii,jmar)=zmeasud/zweisud + zphi(ii, 1)=zmeanor/zweinor + zphi(ii,jmar)=zmeasud/zweisud + zpic(ii, 1)=zpicnor/zweinor + zpic(ii,jmar)=zpicsud/zweisud + zval(ii, 1)=zvalnor/zweinor + zval(ii,jmar)=zvalsud/zweisud + zstd(ii, 1)=zstdnor/zweinor + zstd(ii,jmar)=zstdsud/zweisud + zsig(ii, 1)=zsignor/zweinor + zsig(ii,jmar)=zsigsud/zweisud + zgam(ii, 1)=1. + zgam(ii,jmar)=1. + zthe(ii, 1)=0. + zthe(ii,jmar)=0. + ENDDO + + RETURN + END + + SUBROUTINE MVA9(X,IMAR,JMAR) + +C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS + + REAL X(IMAR,JMAR),XF(IMAR,JMAR) + real WEIGHTpb(-1:1,-1:1) + + + SUM=0. + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=1./REAL((1+IS**2)*(1+JS**2)) + SUM=SUM+WEIGHTpb(IS,JS) + ENDDO + ENDDO + +c WRITE(*,*) 'MVA9 ', IMAR, JMAR +c WRITE(*,*) 'MVA9 ', WEIGHTpb +c WRITE(*,*) 'MVA9 SUM ', SUM + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM + ENDDO + ENDDO + + DO J=2,JMAR-1 + DO I=2,IMAR-1 + XF(I,J)=0. + DO IS=-1,1 + DO JS=-1,1 + XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + ENDDO + ENDDO + + DO J=2,JMAR-1 + XF(1,J)=0. + IS=IMAR-1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS) + ENDDO + DO IS=0,1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + XF(IMAR,J)=XF(1,J) + ENDDO + + DO I=1,IMAR + XF(I,1)=XF(I,2) + XF(I,JMAR)=XF(I,JMAR-1) + ENDDO + + DO I=1,IMAR + DO J=1,JMAR + X(I,J)=XF(I,J) + ENDDO + ENDDO + + RETURN + END + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grilles_gcm_netcdf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grilles_gcm_netcdf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grilles_gcm_netcdf.F (revision 1634) @@ -0,0 +1,305 @@ +! +! $Id$ +! +c +c + + PROGRAM create_fausse_var +C + IMPLICIT NONE +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" + + real temp(iim+1,jjm+1) +#include "netcdf.inc" + +c Attributs netcdf sortie + character*64 fich_out + integer*4 ncid_out,rcode_out + integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid + integer*4 out_varid + integer*4 out_lonudim,out_lonvdim + integer*4 out_latudim,out_latvdim,out_dim(3) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + integer start(4),count(4) + + integer status,i,j + real rlatudeg(jjp1),rlatvdeg(jjm) + real rlonudeg(iip1),rlonvdeg(iip1) + + real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + real acoslat,dxkm,dykm,resol(iip1,jjp1) + +#include "serre.h" +#include "fxyprim.h" + + print*,'OK0' + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + +c open(99,file='run.def',status='old',form='formatted') +c CALL defrun_new( 99, .TRUE.,clesphy0 ) +c close(99) + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + + print*,'OK1' + do j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + enddo + do j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + enddo + + do i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + enddo + + + print*,'OK2' +c 2 ----- OUVERTURE DE LA SORTIE NETCDF +c --------------------------------------------------- +c CREATION OUTPUT +c ouverture fichier netcdf de sortie out + fich_out='grilles_gcm.nc' + + status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + print*,'OK3' +c Longitudes en u + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, + % out_lonuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name', + % 9,'Longitude en u') + +c Longitudes en v + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, + % out_lonvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', + % 9,'Longitude en v') + +c Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, + % out_latuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', + % 8,'Latitude en u') + +c Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, + % out_latvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', + % 8,'Latitude en v') + +c ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + +c ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point v') + +c ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + + + print*,'OK4' + status=NF_ENDDEF(ncid_out) +c 5) ----- FERMETURE DES FICHIERS NETCDF------------------ +c -------------------------------------------------------- +c 3-b- Ecriture de la grille pour la sortie +c rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + count(1)=iim+1 + count(2)=jjm+1 + count(3)=1 + count(4)=1 + + do j=1,jjm+1 + do i=1,iim+1 + temp(i,j)=mod(i,2)+mod(j,2) + enddo + enddo + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, + s count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, + s count,temp) +#endif + + +c fermeture du fichier netcdf + call ncclos(ncid_out,rcode_out) + write(*,*) 'Fermeture: ',fich_out + + + print*,'OK5' +c Ecriture grads + open (20,file='grille.dat',form='unformatted',access='direct' + s ,recl=4*ip1jmp1) + write(20,rec=1) (( REAL(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1) + write(20,rec=2) (( REAL(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1) + do j=2,jjm + dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi +c dlat2(j)=180.*fyprim( REAL(j))/pi + enddo + do i=2,iip1 + dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi +c dlon2(i)=180.*fxprim( REAL(i))/pi + enddo + do j=2,jjm + dykm=(rlatv(j)-rlatv(j-1))*6400. + acoslat=6400.*cos(rlatu(j)) + do i=2,iip1 + dxkm=acoslat*(rlonu(i)-rlonu(i-1)) + resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm) + enddo + resol(1,j)=resol(iip1,j) + enddo + write(20,rec=3) resol + dlon1(1)=dlon1(iip1) + dlon2(1)=dlon2(iip1) + write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1) + write(20,rec=5) ((dlon1(i)*pi/180.*0.001* + s cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1) + write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1) + write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1) + write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1) + write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1) + + print*,'I, LON, DX (km)' + do i=1,iip1 + print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001* + s cos(clat*pi/180.)*rad + enddo + print*,'J, LAT, DY (km)' + do j=1,jjp1 + print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad + enddo + + open (21,file='grille.ctl',form='formatted') + +c WARNING! on reecrase le fichier .ctl a chaque ecriture + write(21,'(a5,1x,a40)') + & 'DSET ','^grille.dat' + + write(21,'(a12)') 'UNDEF 1.0E30' + write(21,'(a5,1x,a40)') 'TITLE ','grille' + call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF') + call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF') + call formcoord(21,1,0.,1.,.false.,'ZDEF') + write(21,'(a4,i10,a30)') + & 'TDEF ',1,' LINEAR 23OCT1994 3hr ' + write(21,'(a4,2x,i5)') 'VARS',9 + write(21,'(a18)') 'grille 0 99 grille' + write(21,'(a18)') 'gril 0 99 gril ' + write(21,'(a29)') 'resol 0 99 resolution (km) ' + write(21,'(a18)') 'dlon1 0 99 dlon1 ' + write(21,'(a20)') 'dx 0 99 dx (km) ' + write(21,'(a18)') 'dlon2 0 99 dlon2 ' + write(21,'(a18)') 'dlat1 0 99 dlat1 ' + write(21,'(a20)') 'dy 0 99 dy (km) ' + write(21,'(a18)') 'dlat2 0 99 dlat2 ' + write(21,'(a7)') 'ENDVARS' + + + + + + print*,'OK6' + end + + + + subroutine handle_err(status) +#include "netcdf.inc" + + + integer status + print *,'handle code err: ',NF_NOERR + IF (status.NE.nf_noerr) THEN + print *,NF_STRERROR(status) + stop 'stopped' + ENDIF + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grilles_gcm_netcdf_sub.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grilles_gcm_netcdf_sub.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/grilles_gcm_netcdf_sub.F90 (revision 1634) @@ -0,0 +1,237 @@ +! +! $Header$ +! +! This subroutine creates the file grilles_gcm.nc containg longitudes and +! latitudes in degrees for grid u and v. This subroutine is called from +! ce0l if grilles_gcm_netcdf=TRUE. This subroutine corresponds to the first +! part in the program create_fausse_var. +! +SUBROUTINE grilles_gcm_netcdf_sub(masque,phis) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comgeom.h" + INCLUDE "comvert.h" + INCLUDE "netcdf.inc" + INCLUDE "serre.h" + + + REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: masque ! masque terre/mer + REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: phis ! geopotentiel au sol + + REAL temp(iim+1,jjm+1) + ! Attributs netcdf sortie + INTEGER ncid_out,rcode_out + INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid,out_levid + INTEGER out_varid + INTEGER out_lonudim,out_lonvdim + INTEGER out_latudim,out_latvdim,out_dim(3) + INTEGER out_levdim + + INTEGER, PARAMETER :: longcles = 20 + REAL clesphy0(longcles) + + INTEGER start(4),COUNT(4) + + INTEGER status,i,j + REAL rlatudeg(jjp1),rlatvdeg(jjm),rlevdeg(llm) + REAL rlonudeg(iip1),rlonvdeg(iip1) + + REAL dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + REAL acoslat,dxkm,dykm,resol(iip1,jjp1) + REAL,DIMENSION(iip1,jjp1) :: phis_loc + INTEGER masque_int(iip1,jjp1) + INTEGER :: phis_id + INTEGER :: area_id + INTEGER :: mask_id + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + DO j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + ENDDO + DO j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + ENDDO + + DO i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + ENDDO + + + ! 2 ----- OUVERTURE DE LA SORTIE NETCDF + ! --------------------------------------------------- + ! CREATION OUTPUT + ! ouverture fichier netcdf de sortie out + status=NF_CREATE('grilles_gcm.nc',NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + ! Longitudes en u + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, out_lonuid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',9,'Longitude en u') + + ! Longitudes en v + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, out_lonvid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', 9,'Longitude en v') + + ! Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, out_latuid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', 8,'Latitude en u') + + ! Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, out_latvid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', 8,'Latitude en v') + + ! ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point u') + + ! ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point v') + + ! ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',16,'Grille aux point u') + + status=NF_ENDDEF(ncid_out) + ! 5) ----- FERMETURE DES FICHIERS NETCDF------------------ + ! -------------------------------------------------------- + ! 3-b- Ecriture de la grille pour la sortie + ! rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + COUNT(1)=iim+1 + COUNT(2)=jjm+1 + COUNT(3)=1 + COUNT(4)=1 + + DO j=1,jjm+1 + DO i=1,iim+1 + temp(i,j)=MOD(i,2)+MOD(j,2) + ENDDO + ENDDO + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, count,temp) +#endif + + ! On re-ouvre le fichier pour rajouter 4 nouvelles variables necessaire pour INCA +! lev - phis - aire - mask + rlevdeg(:) = presnivs + phis_loc(:,:) = phis(:,:)/g + +! niveaux de pression verticaux + status = NF_REDEF (ncid_out) + status=NF_DEF_DIM(ncid_out,'lev',llm,out_levdim) + +! fields + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + + status = nf_def_var(ncid_out,'phis',NF_FLOAT,2,out_dim,phis_id) + CALL handle_err(status) + status = nf_def_var(ncid_out,'aire',NF_FLOAT,2,out_dim,area_id) + CALL handle_err(status) + status = nf_def_var(ncid_out,'mask',NF_INT ,2,out_dim,mask_id) + CALL handle_err(status) + + status=NF_ENDDEF(ncid_out) + + ! ecriture des variables +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_levid,1,llm,rlevdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_levid,1,llm,rlevdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=0 + COUNT(1)=iip1 + COUNT(2)=jjp1 + COUNT(3)=1 + COUNT(4)=0 + + status = nf_put_vara_double(ncid_out, phis_id,start,count, phis_loc) + status = nf_put_vara_double(ncid_out, area_id,start,count, aire) + masque_int(:,:) = nINT(masque(:,:)) + status = nf_put_vara_int(ncid_out, mask_id,start,count,masque_int) + CALL handle_err(status) + + ! fermeture du fichier netcdf + CALL ncclos(ncid_out,rcode_out) + +END SUBROUTINE grilles_gcm_netcdf_sub + + + +SUBROUTINE handle_err(status) + INCLUDE "netcdf.inc" + + INTEGER status + IF (status.NE.nf_noerr) THEN + PRINT *,NF_STRERROR(status) + CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1) + ENDIF +END SUBROUTINE handle_err + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/groupe_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/groupe_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/groupe_p.F (revision 1634) @@ -0,0 +1,130 @@ + subroutine groupe_p(pext,pbaru,pbarv,pbarum,pbarvm,wm) + USE parallel + implicit none + +c sous-programme servant a fitlrer les champs de flux de masse aux +c poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur +c et a mesure qu'on se rapproche du pole. +c +c en entree: pext, pbaru et pbarv +c +c en sortie: pbarum,pbarvm et wm. +c +c remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc +c pas besoin de w en entree. + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "comvert.h" + + integer ngroup + parameter (ngroup=3) + + + real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) + real pext(iip1,jjp1,llm) + + real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm) + real wm(iip1,jjp1,llm) + + real,save :: zconvm(iip1,jjp1,llm) + real,save :: zconvmm(iip1,jjp1,llm) + + real uu + + integer i,j,l + + logical firstcall + save firstcall +c$OMP THREADPRIVATE(firstcall) + + data firstcall/.true./ + integer ijb,ije,jjb,jje + + if (firstcall) then + if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point' + firstcall=.false. + endif + +c Champs 1D + + call convflu_p(pbaru,pbarv,llm,zconvm) + +c +c call scopy(ijp1llm,zconvm,1,zconvmm,1) +c call scopy(ijmllm,pbarv,1,pbarvm,1) + + jjb=jj_begin + jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l) + enddo +c$OMP END DO NOWAIT + + call groupeun_p(jjp1,llm,jjb,jje,zconvmm) + + jjb=jj_begin-1 + jje=jj_end + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l) + enddo +c$OMP END DO NOWAIT + + call groupeun_p(jjm,llm,jjb,jje,pbarvm) + +c Champs 3D + + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + uu=pbaru(iim,j,l) + do i=1,iim + uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l) + pbarum(i,j,l)=uu +c zconvm(i,j,l ) = xflu(i-1,j,l)-xflu(i,j,l)+ +c * yflu(i,j,l)-yflu(i,j-1,l) + enddo + pbarum(iip1,j,l)=pbarum(1,j,l) + enddo + enddo +c$OMP END DO NOWAIT +c integration de la convergence de masse de haut en bas ...... + + jjb=jj_begin + jje=jj_end + +c$OMP BARRIER +c$OMP MASTER + do l = llm-1,1,-1 + do j=jjb,jje + do i=1,iip1 + zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1) + enddo + enddo + enddo + + if (.not. pole_sud) then + zconvmm(:,jj_end+1,:)=0 +cym wm(:,jj_end+1,:)=0 + endif + +c$OMP END MASTER +c$OMP BARRIER + + CALL vitvert_p(zconvmm(1,1,1),wm(1,1,1)) + + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/groupeun_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/groupeun_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/groupeun_p.F (revision 1634) @@ -0,0 +1,201 @@ + SUBROUTINE groupeun_p(jjmax,llmax,jjb,jje,q) + USE parallel + USE Write_Field_p + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER jjmax,llmax,jjb,jje + REAL q(iip1,jjmax,llmax) + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airecn,qn + REAL airecs,qs + + INTEGER i,j,l,ig,ig2,j1,j2,i0,jd + +c--------------------------------------------------------------------c +c Strategie d'optimisation c +c stocker les valeurs systematiquement recalculees c +c et identiques d'un pas de temps sur l'autre. Il s'agit des c +c aires des cellules qui sont sommees. S'il n'y a pas de changement c +c de grille au cours de la simulation tout devrait bien se passer. c +c Autre optimisation : determination des bornes entre lesquelles "j" c +c varie, au lieu de faire un test à chaque fois... +c--------------------------------------------------------------------c + + INTEGER j_start, j_finish + + REAL, SAVE :: airen_tab(iip1,jjp1,0:1) + REAL, SAVE :: aires_tab(iip1,jjp1,0:1) +!$OMP THREADPRIVATE(airen_tab, aires_tab) + + LOGICAL, SAVE :: first = .TRUE. +!$OMP THREADPRIVATE(first) + INTEGER,SAVE :: i_index(iim,ngroup) + INTEGER :: offset + REAL :: qsum(iim/ngroup) + + IF (first) THEN + CALL INIT_GROUPEUN_P(airen_tab, aires_tab) + first = .FALSE. + ENDIF + +c Champs 3D + jd=jjp1-jjmax +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + j1=1+jd + j2=2 + DO ig=1,ngroup + +c Concerne le pole nord + j_start = MAX(jjb, j1-jd) + j_finish = MIN(jje, j2-jd) + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(airen_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd) + ENDDO + q(iip1,j,l)=q(1,j,l) + ENDDO + +!c Concerne le pole sud + j_start = MAX(1+jjp1-jje-jd, j1-jd) + j_finish = MIN(1+jjp1-jjb-jd, j2-jd) + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) + & +q(i0+offset,jjp1-j+1-jd,l) + ENDDO + ENDDO + ENDDO + + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), + & jjp1-j+1-jd,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(aires_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* + & aires_tab(i,jjp1-j+1,jd) + ENDDO + q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) + ENDDO + + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO +!$OMP END DO NOWAIT + + RETURN + END + + + + SUBROUTINE INIT_GROUPEUN_P(airen_tab, aires_tab) + + USE parallel + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airen,airecn + REAL aires,airecs + + INTEGER i,j,l,ig,j1,j2,i0,jd + + INTEGER j_start, j_finish + + REAL :: airen_tab(iip1,jjp1,0:1) + REAL :: aires_tab(iip1,jjp1,0:1) + + DO jd=0, 1 + j1=1+jd + j2=2 + DO ig=1,ngroup + +! c Concerne le pole nord + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + airen=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen = airen+aire(i,j) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen_tab(i,j,jd) = + & aire(i,j) / airen + ENDDO + ENDDO + ENDDO + +! c Concerne le pole sud + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + aires=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires=aires+aire(i,jjp1-j+1) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires_tab(i,jjp1-j+1,jd) = + & aire(i,jjp1-j+1) / aires + ENDDO + ENDDO + ENDDO + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/guide_p_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/guide_p_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/guide_p_mod.F90 (revision 1634) @@ -0,0 +1,1836 @@ +! +! $Id$ +! +MODULE guide_p_mod + +!======================================================================= +! Auteur: F.Hourdin +! F. Codron 01/09 +!======================================================================= + + USE getparam + USE Write_Field_p + use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close + + IMPLICIT NONE + +! --------------------------------------------- +! Declarations des cles logiques et parametres +! --------------------------------------------- + INTEGER, PRIVATE, SAVE :: iguide_read,iguide_int,iguide_sav + INTEGER, PRIVATE, SAVE :: nlevnc, guide_plevs + LOGICAL, PRIVATE, SAVE :: guide_u,guide_v,guide_T,guide_Q,guide_P + LOGICAL, PRIVATE, SAVE :: guide_hr,guide_teta + LOGICAL, PRIVATE, SAVE :: guide_BL,guide_reg,guide_add,gamma4,guide_zon + LOGICAL, PRIVATE, SAVE :: invert_p,invert_y,ini_anal + LOGICAL, PRIVATE, SAVE :: guide_2D,guide_sav,guide_modele + + REAL, PRIVATE, SAVE :: tau_min_u,tau_max_u + REAL, PRIVATE, SAVE :: tau_min_v,tau_max_v + REAL, PRIVATE, SAVE :: tau_min_T,tau_max_T + REAL, PRIVATE, SAVE :: tau_min_Q,tau_max_Q + REAL, PRIVATE, SAVE :: tau_min_P,tau_max_P + + REAL, PRIVATE, SAVE :: lat_min_g,lat_max_g + REAL, PRIVATE, SAVE :: lon_min_g,lon_max_g + REAL, PRIVATE, SAVE :: tau_lon,tau_lat + + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u,alpha_v + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T,alpha_Q + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P,alpha_pcor + +! --------------------------------------------- +! Variables de guidage +! --------------------------------------------- +! Variables des fichiers de guidage + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: unat1,unat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: vnat1,vnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: tnat1,tnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: qnat1,qnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: pnat1,pnat2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: psnat1,psnat2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc,bpnc +! Variables aux dimensions du modele + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: ugui1,ugui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: vgui1,vgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tgui1,tgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qgui1,qgui2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1,psgui2 + + INTEGER,SAVE,PRIVATE :: ijb_u,ijb_v,ije_u,ije_v,ijn_u,ijn_v + INTEGER,SAVE,PRIVATE :: jjb_u,jjb_v,jje_u,jje_v,jjn_u,jjn_v + + +CONTAINS +!======================================================================= + + SUBROUTINE guide_init + + USE control_mod + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + + INTEGER :: error,ncidpl,rid,rcod + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_init' + +! --------------------------------------------- +! Lecture des parametres: +! --------------------------------------------- +! Variables guidees + CALL getpar('guide_u',.true.,guide_u,'guidage de u') + CALL getpar('guide_v',.true.,guide_v,'guidage de v') + CALL getpar('guide_T',.true.,guide_T,'guidage de T') + CALL getpar('guide_P',.true.,guide_P,'guidage de P') + CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q') + CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R') + CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta') + + CALL getpar('guide_add',.false.,guide_add,'for�age constant?') + CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale') + +! Constantes de rappel. Unite : fraction de jour + CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u') + CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u') + CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v') + CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v') + CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T') + CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T') + CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q') + CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q') + CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P') + CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P') + CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie') + CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim') + +! Sauvegarde du for�age + CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage') + CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage') + ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois. + IF (iguide_sav.GT.0) THEN + iguide_sav=day_step/iguide_sav + ELSE + iguide_sav=day_step*iguide_sav + ENDIF + +! Guidage regional seulement (sinon constant ou suivant le zoom) + CALL getpar('guide_reg',.false.,guide_reg,'guidage regional') + CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ') + CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ') + CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ') + CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ') + CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ') + CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ') + +! Parametres pour lecture des fichiers + CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage') + CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert') + IF (iguide_int.EQ.0) THEN + iguide_int=1 + ELSEIF (iguide_int.GT.0) THEN + iguide_int=day_step/iguide_int + ELSE + iguide_int=day_step*iguide_int + ENDIF + CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage') + ! Pour compatibilite avec ancienne version avec guide_modele + CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol') + IF (guide_modele) THEN + guide_plevs=1 + ENDIF + ! Fin raccord + CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse') + CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses') + CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S') + CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P') + +! --------------------------------------------- +! Determination du nombre de niveaux verticaux +! des fichiers guidage +! --------------------------------------------- + ncidpl=-99 + if (guide_plevs.EQ.1) then + if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl) + elseif (guide_plevs.EQ.2) then + if (ncidpl.EQ.-99) rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_u) then + if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_v) then + if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl) + elseif (guide_T) then + if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl) + elseif (guide_Q) then + if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl) + endif + error=NF_INQ_DIMID(ncidpl,'LEVEL',rid) + IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid) + IF (error.NE.NF_NOERR) THEN + print *,'Guide: probleme lecture niveaux pression' + CALL abort_gcm(modname,abort_message,1) + ENDIF + error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc) + print *,'Guide: nombre niveaux vert. nlevnc', nlevnc + rcod = nf90_close(ncidpl) + +! --------------------------------------------- +! Allocation des variables +! --------------------------------------------- + abort_message='pb in allocation guide' + + ALLOCATE(apnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(bpnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + apnc=0.;bpnc=0. + + ALLOCATE(alpha_pcor(llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_u(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_v(ip1jm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_T(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_Q(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_P(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0 + + IF (guide_u) THEN + ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + unat1=0.;unat2=0.;ugui1=0.;ugui2=0. + ENDIF + + IF (guide_T) THEN + ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0. + ENDIF + + IF (guide_Q) THEN + ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0. + ENDIF + + IF (guide_v) THEN + ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui1(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui2(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0. + ENDIF + + IF (guide_plevs.EQ.2) THEN + ALLOCATE(pnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(pnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + pnat1=0.;pnat2=0.; + ENDIF + + IF (guide_P.OR.guide_plevs.EQ.1) THEN + ALLOCATE(psnat1(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psnat2(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psnat1=0.;psnat2=0.; + ENDIF + IF (guide_P) THEN + ALLOCATE(psgui2(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psgui1(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psgui1=0.;psgui2=0. + ENDIF + +! --------------------------------------------- +! Lecture du premier etat de guidage. +! --------------------------------------------- + IF (guide_2D) THEN + CALL guide_read2D(1) + ELSE + CALL guide_read(1) + ENDIF + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_plevs.EQ.2) pnat1=pnat2 + IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2 + + END SUBROUTINE guide_init + +!======================================================================= + SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) + use parallel + USE control_mod + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + INTEGER, INTENT(IN) :: itau !pas de temps + REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse + REAL, DIMENSION (ip1jm,llm), INTENT(INOUT) :: vcov + REAL, DIMENSION (ip1jmp1), INTENT(INOUT) :: ps + + ! Variables locales + LOGICAL, SAVE :: first=.TRUE. + LOGICAL :: f_out ! sortie guidage + REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf + REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta + REAL, DIMENSION (iip1,jjp1) :: pks + REAL :: unskap + REAL, DIMENSION (ip1jmp1,llmp1) :: p ! besoin si guide_P + ! Compteurs temps: + INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage + REAL :: ditau, dday_step + REAL :: tau,reste ! position entre 2 etats de guidage + REAL, SAVE :: factt ! pas de temps en fraction de jour + + INTEGER :: i,j,l + + ijb_u=ij_begin ; ije_u=ij_end ; ijn_u=ije_u-ijb_u+1 + jjb_u=jj_begin ; jje_u=jj_end ; jjn_u=jje_u-jjb_u+1 + ijb_v=ij_begin ; ije_v=ij_end ; ijn_v=ije_v-ijb_v+1 + jjb_v=jj_begin ; jje_v=jj_end ; jjn_v=jje_v-jjb_v+1 + IF (pole_sud) THEN + ije_v=ij_end-iip1 + jje_v=jj_end-1 + ijn_v=ije_v-ijb_v+1 + jjn_v=jje_v-jjb_v+1 + ENDIF + + PRINT *,'---> on rentre dans guide_main' +! CALL AllGather_Field(ucov,ip1jmp1,llm) +! CALL AllGather_Field(vcov,ip1jm,llm) +! CALL AllGather_Field(teta,ip1jmp1,llm) +! CALL AllGather_Field(ps,ip1jmp1,1) +! CALL AllGather_Field(q,ip1jmp1,llm) + +!----------------------------------------------------------------------- +! Initialisations au premier passage +!----------------------------------------------------------------------- + + IF (first) THEN + first=.FALSE. + CALL guide_init + itau_test=1001 + step_rea=1 + count_no_rea=0 +! Calcul des constantes de rappel + factt=dtvr*iperiod/daysec + call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v) + call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u) + call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T) + call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P) + call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q) +! correction de rappel dans couche limite + if (guide_BL) then + alpha_pcor(:)=1. + else + do l=1,llm + alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2. + enddo + endif +! ini_anal: etat initial egal au guidage + IF (ini_anal) THEN + CALL guide_interp(ps,teta) + IF (guide_u) ucov(ijb_u:ije_u,:)=ugui2(ijb_u:ije_u,:) + IF (guide_v) vcov(ijb_v:ije_v,:)=ugui2(ijb_v:ije_v,:) + IF (guide_T) teta(ijb_u:ije_u,:)=tgui2(ijb_u:ije_u,:) + IF (guide_Q) q(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:) + IF (guide_P) THEN + ps(ijb_u:ije_u)=psgui2(ijb_u:ije_u) + CALL pression_p(ip1jmp1,ap,bp,ps,p) + CALL massdair_p(p,masse) + ENDIF + RETURN + ENDIF +! Verification structure guidage + IF (guide_u) THEN + CALL writefield_p('unat',unat1) + CALL writefield_p('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/))) + ENDIF + IF (guide_T) THEN + CALL writefield_p('tnat',tnat1) + CALL writefield_p('teta',RESHAPE(teta,(/iip1,jjp1,llm/))) + ENDIF + + ENDIF !first + +!----------------------------------------------------------------------- +! Lecture des fichiers de guidage ? +!----------------------------------------------------------------------- + IF (iguide_read.NE.0) THEN + ditau=real(itau) + dday_step=real(day_step) + IF (iguide_read.LT.0) THEN + tau=ditau/dday_step/REAL(iguide_read) + ELSE + tau=REAL(iguide_read)*ditau/dday_step + ENDIF + reste=tau-AINT(tau) + IF (reste.EQ.0.) THEN + IF (itau_test.EQ.itau) THEN + write(*,*)'deuxieme passage de advreel a itau=',itau + stop + ELSE + IF (guide_v) vnat1(:,jjb_v:jje_v,:)=vnat2(:,jjb_v:jje_v,:) + IF (guide_u) unat1(:,jjb_u:jje_u,:)=unat2(:,jjb_u:jje_u,:) + IF (guide_T) tnat1(:,jjb_u:jje_u,:)=tnat2(:,jjb_u:jje_u,:) + IF (guide_Q) qnat1(:,jjb_u:jje_u,:)=qnat2(:,jjb_u:jje_u,:) + IF (guide_plevs.EQ.2) pnat1(:,jjb_u:jje_u,:)=pnat2(:,jjb_u:jje_u,:) + IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjb_u:jje_u)=psnat2(:,jjb_u:jje_u) + step_rea=step_rea+1 + itau_test=itau + print*,'Lecture fichiers guidage, pas ',step_rea, & + 'apres ',count_no_rea,' non lectures' + IF (guide_2D) THEN + CALL guide_read2D(step_rea) + ELSE + CALL guide_read(step_rea) + ENDIF + count_no_rea=0 + ENDIF + ELSE + count_no_rea=count_no_rea+1 + + ENDIF + ENDIF !iguide_read=0 + +!----------------------------------------------------------------------- +! Interpolation et conversion des champs de guidage +!----------------------------------------------------------------------- + IF (MOD(itau,iguide_int).EQ.0) THEN + CALL guide_interp(ps,teta) + ENDIF +! Repartition entre 2 etats de guidage + IF (iguide_read.NE.0) THEN + tau=reste + ELSE + tau=1. + ENDIF + +!----------------------------------------------------------------------- +! Ajout des champs de guidage +!----------------------------------------------------------------------- +! Sauvegarde du guidage? + f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav) + IF (f_out) THEN +! Calcul niveaux pression milieu de couches + CALL pression_p( ip1jmp1, ap, bp, ps, p ) + if (disvert_type==1) then + CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf) + else + CALL exner_milieu_p(ip1jmp1,ps,p,beta,pks,pk,pkf) + endif + unskap=1./kappa + DO l = 1, llm + DO j=jjb_u,jje_u + DO i =1, iip1 + p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + CALL guide_out("P",jjp1,llm,p(1:ip1jmp1,1:llm),1.) + ENDIF + + if (guide_u) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)-ucov(ijb_u:ije_u,:) + endif + + if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u) + IF (f_out) CALL guide_out("U",jjp1,llm,f_add(:,:),factt) + ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_T) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)-teta(ijb_u:ije_u,:) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T) + IF (f_out) CALL guide_out("T",jjp1,llm,f_add(:,:),factt) + teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_P) then + if (guide_add) then + f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u) + else + f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)-ps(ijb_u:ije_u) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1)) + CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P) + IF (f_out) CALL guide_out("SP",jjp1,1,f_add(1:ip1jmp1,1),factt) + ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1) + CALL pression_p(ip1jmp1,ap,bp,ps,p) + CALL massdair_p(p,masse) + endif + + if (guide_Q) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)-q(ijb_u:ije_u,:) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q) + IF (f_out) CALL guide_out("Q",jjp1,llm,f_add(:,:),factt) + q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_v) then + if (guide_add) then + f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:) + else + f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)-vcov(ijb_v:ije_v,:) + endif + + if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:)) + CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v) + IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:),factt) + vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:) + endif + + END SUBROUTINE guide_main + +!======================================================================= + SUBROUTINE guide_addfield(hsize,vsize,field,alpha) +! field1=a*field1+alpha*field2 + + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + + ! input variables + INTEGER, INTENT(IN) :: hsize + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(hsize), INTENT(IN) :: alpha + REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field + + ! Local variables + INTEGER :: l + + IF (hsize==ip1jm) THEN + do l=1,vsize + field(ijb_v:ije_v,l)=alpha(ijb_v:ije_v)*field(ijb_v:ije_v,l)*alpha_pcor(l) + enddo + ELSE + do l=1,vsize + field(ijb_u:ije_u,l)=alpha(ijb_u:ije_u)*field(ijb_u:ije_u,l)*alpha_pcor(l) + enddo + ENDIF + + END SUBROUTINE guide_addfield + +!======================================================================= + SUBROUTINE guide_zonave(typ,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comgeom.h" + INCLUDE "comconst.h" + + ! input/output variables + INTEGER, INTENT(IN) :: typ + INTEGER, INTENT(IN) :: vsize + INTEGER, INTENT(IN) :: hsize + REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field + + ! Local variables + LOGICAL, SAVE :: first=.TRUE. + INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain + INTEGER :: i,j,l,ij + REAL, DIMENSION (iip1) :: lond ! longitude in Deg. + REAL, DIMENSION (hsize,vsize):: fieldm ! zon-averaged field + + IF (first) THEN + first=.FALSE. +!Compute domain for averaging + lond=rlonu*180./pi + imin(1)=1;imax(1)=iip1; + imin(2)=1;imax(2)=iip1; + IF (guide_reg) THEN + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(1)=i + IF (lond(i).LE.lon_max_g) imax(1)=i + ENDDO + lond=rlonv*180./pi + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(2)=i + IF (lond(i).LE.lon_max_g) imax(2)=i + ENDDO + ENDIF + ENDIF + + fieldm=0. + + IF (hsize==jjm) THEN + DO l=1,vsize + ! Compute zonal average + DO j=jjb_v,jje_v + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjb_v,jje_v + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + ELSE + DO l=1,vsize + ! Compute zonal average + DO j=jjb_v,jje_v + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjb_u,jje_u + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE guide_zonave + +!======================================================================= + SUBROUTINE guide_interp(psi,teta) + USE parallel + USE mod_hallo + USE Bands + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comgeom2.h" + include "comconst.h" + + REAL, DIMENSION (iip1,jjp1), INTENT(IN) :: psi ! Psol gcm + REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm + + LOGICAL, SAVE :: first=.TRUE. + ! Variables pour niveaux pression: + REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage + REAL, DIMENSION (iip1,jjp1,llm) :: plunc,plsnc !niveaux pression modele + REAL, DIMENSION (iip1,jjm,llm) :: plvnc !niveaux pression modele + REAL, DIMENSION (iip1,jjp1,llmp1) :: p ! pression intercouches + REAL, DIMENSION (iip1,jjp1,llm) :: pls, pext ! var intermediaire + REAL, DIMENSION (iip1,jjp1,llm) :: pbarx + REAL, DIMENSION (iip1,jjm,llm) :: pbary + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf + REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta + REAL, DIMENSION (iip1,jjp1) :: pks + REAL :: unskap + ! Pression de vapeur saturante + REAL, DIMENSION (ip1jmp1,llm) :: qsat + !Variables intermediaires interpolation + REAL, DIMENSION (iip1,jjp1,llm) :: zu1,zu2 + REAL, DIMENSION (iip1,jjm,llm) :: zv1,zv2 + + INTEGER :: i,j,l,ij + TYPE(Request) :: Req + + print *,'Guide: conversion variables guidage' +! ----------------------------------------------------------------- +! Calcul des niveaux de pression champs guidage (pour T et Q) +! ----------------------------------------------------------------- + IF (guide_plevs.EQ.0) THEN + DO l=1,nlevnc + DO j=jjb_u,jje_u + DO i=1,iip1 + plnc2(i,j,l)=apnc(l) + plnc1(i,j,l)=apnc(l) + ENDDO + ENDDO + ENDDO + ENDIF + + if (first) then + first=.FALSE. + print*,'Guide: verification ordre niveaux verticaux' + print*,'LMDZ :' + do l=1,llm + print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. & + +psi(1,jje_u)*(bp(l)+bp(l+1))/2. + enddo + print*,'Fichiers guidage' + SELECT CASE (guide_plevs) + CASE (0) + do l=1,nlevnc + print*,'PL(',l,')=',plnc2(1,jjb_u,l) + enddo + CASE (1) + DO l=1,nlevnc + print*,'PL(',l,')=',apnc(l)+bpnc(l)*psnat2(i,jjb_u) + ENDDO + CASE (2) + do l=1,nlevnc + print*,'PL(',l,')=',pnat2(1,jjb_u,l) + enddo + END SELECT + print *,'inversion de l''ordre: invert_p=',invert_p + if (guide_u) then + do l=1,nlevnc + print*,'U(',l,')=',unat2(1,jjb_u,l) + enddo + endif + if (guide_T) then + do l=1,nlevnc + print*,'T(',l,')=',tnat2(1,jjb_u,l) + enddo + endif + endif + +! ----------------------------------------------------------------- +! Calcul niveaux pression modele +! ----------------------------------------------------------------- + +! .... Calcul de pls , pression au milieu des couches ,en Pascals + IF (guide_plevs.EQ.1) THEN + DO l=1,llm + DO j=jjb_u,jje_u + DO i =1, iip1 + pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2. + ENDDO + ENDDO + ENDDO + ELSE + CALL pression_p( ip1jmp1, ap, bp, psi, p ) + if (disvert_type==1) then + CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu_p(ip1jmp1,psi,p,beta,pks,pk,pkf) + endif + unskap=1./kappa + DO l = 1, llm + DO j=jjb_u,jje_u + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + ENDIF + +! calcul des pressions pour les grilles u et v + do l=1,llm + do j=jjb_u,jje_u + do i=1,iip1 + pext(i,j,l)=pls(i,j,l)*aire(i,j) + enddo + enddo + enddo + + CALL Register_SwapFieldHallo(pext,pext,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + + call massbar_p(pext, pbarx, pbary ) + do l=1,llm + do j=jjb_u,jje_u + do i=1,iip1 + plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j) + plsnc(i,j,l)=pls(i,j,l) + enddo + enddo + enddo + do l=1,llm + do j=jjb_v,jje_v + do i=1,iip1 + plvnc(i,j,l)=pbary(i,j,l)/airev(i,j) + enddo + enddo + enddo + +! ----------------------------------------------------------------- +! Interpolation verticale champs guidage sur niveaux modele +! Conversion en variables gcm (ucov, vcov...) +! ----------------------------------------------------------------- + if (guide_P) then + do j=jjb_u,jje_u + do i=1,iim + ij=(j-1)*iip1+i + psgui1(ij)=psnat1(i,j) + psgui2(ij)=psnat2(i,j) + enddo + psgui1(iip1*j)=psnat1(1,j) + psgui2(iip1*j)=psnat2(1,j) + enddo + endif + + IF (guide_T) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + DO l=1,nlevnc + DO j=jjb_u,jje_u + DO i=1,iip1 + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + ENDDO + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + DO l=1,nlevnc + DO j=jjb_u,jje_u + DO i=1,iip1 + plnc2(i,j,l)=pnat2(i,j,l) + plnc1(i,j,l)=pnat1(i,j,l) + ENDDO + ENDDO + ENDDO + ENDIF + + ! Interpolation verticale + CALL pres2lev(tnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(tnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + ! Conversion en variables GCM + do l=1,llm + do j=jjb_u,jje_u + IF (guide_teta) THEN + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l) + tgui2(ij,l)=zu2(i,j,l) + enddo + ELSE + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l) + tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l) + enddo + ENDIF + tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l) + tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + tgui1(i,l)=tgui1(1,l) + tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) + tgui2(i,l)=tgui2(1,l) + tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) + enddo + enddo + ENDIF + + IF (guide_Q) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + DO l=1,nlevnc + DO j=jjb_u,jje_u + DO i=1,iip1 + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + ENDDO + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + DO l=1,nlevnc + DO j=jjb_u,jje_u + DO i=1,iip1 + plnc2(i,j,l)=pnat2(i,j,l) + plnc1(i,j,l)=pnat1(i,j,l) + ENDDO + ENDDO + ENDDO + ENDIF + + ! Interpolation verticale + CALL pres2lev(qnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(qnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + ! Conversion en variables GCM + ! On suppose qu'on a la bonne variable dans le fichier de guidage: + ! Hum.Rel si guide_hr, Hum.Spec. sinon. + do l=1,llm + do j=jjb_u,jje_u + do i=1,iim + ij=(j-1)*iip1+i + qgui1(ij,l)=zu1(i,j,l) + qgui2(ij,l)=zu2(i,j,l) + enddo + qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l) + qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + qgui1(i,l)=qgui1(1,l) + qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) + qgui2(i,l)=qgui2(1,l) + qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) + enddo + enddo + IF (guide_hr) THEN + CALL q_sat(iip1*jjn_u*llm,teta(:,jjb_u:jje_u,:)*pk(:,jjb_u:jje_u,:)/cpp, & + plsnc(:,jjb_u:jje_u,:),qsat(ijb_u:ije_u,:)) + qgui1(ijb_u:ije_u,:)=qgui1(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 !hum. rel. en % + qgui2(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 + ENDIF + ENDIF + + IF (guide_u) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + DO l=1,nlevnc + DO j=jjb_u,jje_u + DO i=1,iim + plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) & + & +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) & + & +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j) + ENDDO + plnc2(iip1,j,l)=plnc2(1,j,l) + plnc1(iip1,j,l)=plnc1(1,j,l) + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + DO l=1,nlevnc + DO j=jjb_u,jje_u + DO i=1,iim + plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) & + & +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j) + plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) & + & +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j) + ENDDO + plnc2(iip1,j,l)=plnc2(1,j,l) + plnc1(iip1,j,l)=plnc1(1,j,l) + ENDDO + ENDDO + ENDIF + + ! Interpolation verticale + CALL pres2lev(unat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(unat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + ! Conversion en variables GCM + do l=1,llm + do j=jjb_u,jje_u + do i=1,iim + ij=(j-1)*iip1+i + ugui1(ij,l)=zu1(i,j,l)*cu(i,j) + ugui2(ij,l)=zu2(i,j,l)*cu(i,j) + enddo + ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l) + ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + ugui1(i,l)=0. + ugui1(ip1jm+i,l)=0. + ugui2(i,l)=0. + ugui2(ip1jm+i,l)=0. + enddo + enddo + ENDIF + + IF (guide_v) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + CALL Register_SwapFieldHallo(psnat1,psnat1,ip1jmp1,1,jj_Nb_caldyn,1,2,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + CALL Register_SwapFieldHallo(psnat2,psnat2,ip1jmp1,1,jj_Nb_caldyn,1,2,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + DO l=1,nlevnc + DO j=jjb_v,jje_v + DO i=1,iip1 + plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) & + & +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) & + & +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j) + ENDDO + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + CALL Register_SwapFieldHallo(pnat1,pnat1,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + CALL Register_SwapFieldHallo(pnat2,pnat2,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + DO l=1,nlevnc + DO j=jjb_v,jje_v + DO i=1,iip1 + plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) & + & +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j) + plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) & + & +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j) + ENDDO + ENDDO + ENDDO + ENDIF + ! Interpolation verticale + CALL pres2lev(vnat1(:,jjb_v:jje_v,:),zv1(:,jjb_v:jje_v,:),nlevnc,llm, & + plnc1(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p) + CALL pres2lev(vnat2(:,jjb_v:jje_v,:),zv2(:,jjb_v:jje_v,:),nlevnc,llm, & + plnc2(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p) + ! Conversion en variables GCM + do l=1,llm + do j=jjb_v,jje_v + do i=1,iim + ij=(j-1)*iip1+i + vgui1(ij,l)=zv1(i,j,l)*cv(i,j) + vgui2(ij,l)=zv2(i,j,l)*cv(i,j) + enddo + vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l) + vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l) + enddo + enddo + ENDIF + + + END SUBROUTINE guide_interp + +!======================================================================= + SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha) + +! Calcul des constantes de rappel alpha (=1/tau) + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + include "serre.h" + +! input arguments : + INTEGER, INTENT(IN) :: typ ! u(2),v(3), ou scalaire(1) + INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon + REAL, INTENT(IN) :: factt ! pas de temps en fraction de jour + REAL, INTENT(IN) :: taumin,taumax +! output arguments: + REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha + +! local variables: + LOGICAL, SAVE :: first=.TRUE. + REAL, SAVE :: gamma,dxdy_min,dxdy_max + REAL, DIMENSION (iip1,jjp1) :: zdx,zdy + REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu + REAL, DIMENSION (iip1,jjm) :: dxdyv + real dxdy_ + real zlat,zlon + real alphamin,alphamax,xi + integer i,j,ilon,ilat + + + alphamin=factt/taumax + alphamax=factt/taumin + IF (guide_reg.OR.guide_add) THEN + alpha=alphamax +!----------------------------------------------------------------------- +! guide_reg: alpha=alpha_min dans region, 0. sinon. +!----------------------------------------------------------------------- + IF (guide_reg) THEN + do j=1,pjm + do i=1,pim + if (typ.eq.2) then + zlat=rlatu(j)*180./pi + zlon=rlonu(i)*180./pi + elseif (typ.eq.1) then + zlat=rlatu(j)*180./pi + zlon=rlonv(i)*180./pi + elseif (typ.eq.3) then + zlat=rlatv(j)*180./pi + zlon=rlonv(i)*180./pi + endif + alpha(i,j)=alphamax/16.* & + (1.+tanh((zlat-lat_min_g)/tau_lat))* & + (1.+tanh((lat_max_g-zlat)/tau_lat))* & + (1.+tanh((zlon-lon_min_g)/tau_lon))* & + (1.+tanh((lon_max_g-zlon)/tau_lon)) + enddo + enddo + ENDIF + ELSE +!----------------------------------------------------------------------- +! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom. +!----------------------------------------------------------------------- +!Calcul de l'aire des mailles + do j=2,jjm + do i=2,iip1 + zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j)) + enddo + zdx(1,j)=zdx(iip1,j) + enddo + do j=2,jjm + do i=1,iip1 + zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j)) + enddo + enddo + do i=1,iip1 + zdx(i,1)=zdx(i,2) + zdx(i,jjp1)=zdx(i,jjm) + zdy(i,1)=zdy(i,2) + zdy(i,jjp1)=zdy(i,jjm) + enddo + do j=1,jjp1 + do i=1,iip1 + dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j)) + enddo + enddo + IF (typ.EQ.2) THEN + do j=1,jjp1 + do i=1,iim + dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) + enddo + dxdyu(iip1,j)=dxdyu(1,j) + enddo + ENDIF + IF (typ.EQ.3) THEN + do j=1,jjm + do i=1,iip1 + dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1)) + enddo + enddo + ENDIF +! Premier appel: calcul des aires min et max et de gamma. + IF (first) THEN + first=.FALSE. + ! coordonnees du centre du zoom + CALL coordij(clon,clat,ilon,ilat) + ! aire de la maille au centre du zoom + dxdy_min=dxdys(ilon,ilat) + ! dxdy maximale de la maille + dxdy_max=0. + do j=1,jjp1 + do i=1,iip1 + dxdy_max=max(dxdy_max,dxdys(i,j)) + enddo + enddo + ! Calcul de gamma + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + print*,'ATTENTION modele peu zoome' + print*,'ATTENTION on prend une constante de guidage cste' + gamma=0. + else + gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min) + print*,'gamma=',gamma + if (gamma.lt.1.e-5) then + print*,'gamma =',gamma,'<1e-5' + stop + endif + gamma=log(0.5)/log(gamma) + if (gamma4) then + gamma=min(gamma,4.) + endif + print*,'gamma=',gamma + endif + ENDIF !first + + do j=1,pjm + do i=1,pim + if (typ.eq.1) then + dxdy_=dxdys(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.2) then + dxdy_=dxdyu(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.3) then + dxdy_=dxdyv(i,j) + zlat=rlatv(j)*180./pi + endif + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin + alpha(i,j)=alphamin + else + xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma + xi=min(xi,1.) + if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then + alpha(i,j)=xi*alphamin+(1.-xi)*alphamax + else + alpha(i,j)=0. + endif + endif + enddo + enddo + ENDIF ! guide_reg + + END SUBROUTINE tau2alpha + +!======================================================================= + SUBROUTINE guide_read(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidp,varidp + INTEGER, SAVE :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Ap et Bp si Niveaux de pression hybrides + if (guide_plevs.EQ.1) then + print *,'Lecture du guidage sur niveaux modele' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Pression si guidage sur niveaux P variables + if (guide_plevs.EQ.2) then + rcode = nf90_open('P.nc', nf90_nowrite, ncidp) + rcode = nf90_inq_varid(ncidp, 'PRES', varidp) + print*,'ncidp,varidp',ncidp,varidp + if (ncidpl.eq.-99) ncidpl=ncidp + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (guide_plevs.EQ.0) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + IF (guide_plevs.EQ.1) THEN +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + ELSEIF (guide_plevs.EQ.0) THEN +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + ENDIF + first=.FALSE. + ENDIF ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=iip1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Pression + if (guide_plevs.EQ.2) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,pnat2) +#else + status=NF_GET_VARA_REAL(ncidp,varidp,start,count,pnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,pnat2) + ENDIF + endif + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,nlevnc,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read + +!======================================================================= + SUBROUTINE guide_read2D(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidp,varidp + INTEGER, SAVE :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode +! Variables for 3D extension: + REAL, DIMENSION (jjp1,llm) :: zu + REAL, DIMENSION (jjm,llm) :: zv + INTEGER :: i + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Ap et Bp si niveaux de pression hybrides + if (guide_plevs.EQ.1) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Pression + if (guide_plevs.EQ.2) then + rcode = nf90_open('P.nc', nf90_nowrite, ncidp) + rcode = nf90_inq_varid(ncidp, 'PRES', varidp) + print*,'ncidp,varidp',ncidp,varidp + if (ncidpl.eq.-99) ncidpl=ncidp + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (guide_plevs.EQ.0) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_plevs.EQ.1) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + elseif (guide_plevs.EQ.0) THEN +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Pression + if (guide_plevs.EQ.2) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidp,varidp,start,count,zu) +#endif + DO i=1,iip1 + pnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,pnat2) + ENDIF + endif +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu) +#endif + DO i=1,iip1 + unat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,unat2) + ENDIF + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu) +#endif + DO i=1,iip1 + tnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu) +#endif + DO i=1,iip1 + qnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,nlevnc,qnat2) + ENDIF + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv) +#endif + DO i=1,iip1 + vnat2(i,:,:)=zv(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,nlevnc,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1)) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1)) +#endif + DO i=1,iip1 + psnat2(i,:)=zu(:,1) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read2D + +!======================================================================= + SUBROUTINE guide_out(varname,hsize,vsize,field,factt) + USE parallel + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "comgeom2.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + CHARACTER, INTENT(IN) :: varname + INTEGER, INTENT (IN) :: hsize,vsize + REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field + REAL, INTENT (IN) :: factt + + ! Variables locales + INTEGER, SAVE :: timestep=0 + ! Identites fichier netcdf + INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev + INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev + INTEGER, DIMENSION (3) :: dim3 + INTEGER, DIMENSION (4) :: dim4,count,start + INTEGER :: ierr, varid + + CALL gather_field(field,iip1*hsize,vsize,0) + + IF (mpi_rank /= 0) RETURN + + print *,'Guide: output timestep',timestep,'var ',varname + IF (timestep.EQ.0) THEN +! ---------------------------------------------- +! initialisation fichier de sortie +! ---------------------------------------------- +! Ouverture du fichier + ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid) +! Definition des dimensions + ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) + ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) + ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) + ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) + ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev) + ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim) + +! Creation des variables dimensions + ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu) + ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv) + ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu) + ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv) + ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev) + ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu) + ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv) + + ierr=NF_ENDDEF(nid) + +! Enregistrement des variables dimensions +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv) +#else + ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu) + ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv) +#endif +! -------------------------------------------------------------------- +! Cr�ation des variables sauvegard�es +! -------------------------------------------------------------------- + ierr = NF_REDEF(nid) +! Pressure (GCM) + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"P",NF_FLOAT,4,dim4,varid) +! Surface pressure (guidage) + IF (guide_P) THEN + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid) + ENDIF +! Zonal wind + IF (guide_u) THEN + dim4=(/id_lonu,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid) + ENDIF +! Merid. wind + IF (guide_v) THEN + dim4=(/id_lonv,id_latv,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid) + ENDIF +! Pot. Temperature + IF (guide_T) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid) + ENDIF +! Specific Humidity + IF (guide_Q) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid) + ENDIF + + ierr = NF_ENDDEF(nid) + ierr = NF_CLOSE(nid) + ENDIF ! timestep=0 + +! -------------------------------------------------------------------- +! Enregistrement du champ +! -------------------------------------------------------------------- + + ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid) + + SELECT CASE (varname) + CASE ("P") + timestep=timestep+1 + ierr = NF_INQ_VARID(nid,"P",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("SP") + ierr = NF_INQ_VARID(nid,"ps",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("U") + ierr = NF_INQ_VARID(nid,"ucov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("V") + ierr = NF_INQ_VARID(nid,"vcov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjm,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("T") + ierr = NF_INQ_VARID(nid,"teta",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("Q") + ierr = NF_INQ_VARID(nid,"q",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + END SELECT + + ierr = NF_CLOSE(nid) + + END SUBROUTINE guide_out + + +!=========================================================================== + subroutine correctbid(iim,nl,x) + integer iim,nl + real x(iim+1,nl) + integer i,l + real zz + + do l=1,nl + do i=2,iim-1 + if(abs(x(i,l)).gt.1.e10) then + zz=0.5*(x(i-1,l)+x(i+1,l)) + print*,'correction ',i,l,x(i,l),zz + x(i,l)=zz + endif + enddo + enddo + return + end subroutine correctbid + +!=========================================================================== +END MODULE guide_p_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/heavyside.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/heavyside.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/heavyside.F (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! +c +c + FUNCTION heavyside(a) + +c ... P. Le Van .... +c + IMPLICIT NONE + + REAL(KIND=8) heavyside , a + + IF ( a.LE.0. ) THEN + heavyside = 0. + ELSE + heavyside = 1. + ENDIF + + RETURN + END + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/infotrac.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/infotrac.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/infotrac.F90 (revision 1634) @@ -0,0 +1,352 @@ +! $Id$ +! +MODULE infotrac + +! nqtot : total number of tracers and higher order of moment, water vapor and liquid included + INTEGER, SAVE :: nqtot + +! nbtr : number of tracers not including higher order of moment or water vapor or liquid +! number of tracers used in the physics + INTEGER, SAVE :: nbtr + +! Name variables + CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics + CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics + +! iadv : index of trasport schema for each tracer + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: iadv + +! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the +! dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: niadv ! equivalent dyn / physique + +! conv_flg(it)=0 : convection desactivated for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: conv_flg +! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: pbl_flg + + CHARACTER(len=4),SAVE :: type_trac + +CONTAINS + + SUBROUTINE infotrac_init + USE control_mod + IMPLICIT NONE +!======================================================================= +! +! Auteur: P. Le Van /L. Fairhead/F.Hourdin +! ------- +! Modif special traceur F.Forget 05/94 +! Modif M-A Filiberti 02/02 lecture de traceur.def +! +! Objet: +! ------ +! GCM LMD nouvelle grille +! +!======================================================================= +! ... modification de l'integration de q ( 26/04/94 ) .... +!----------------------------------------------------------------------- +! Declarations + + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" + +! Local variables + INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv ! index of horizontal trasport schema + INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv ! index of vertical trasport schema + + CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0 ! tracer short name + CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA + CHARACTER(len=3), DIMENSION(30) :: descrq + CHARACTER(len=1), DIMENSION(3) :: txts + CHARACTER(len=2), DIMENSION(9) :: txtp + CHARACTER(len=23) :: str1,str2 + + INTEGER :: nqtrue ! number of tracers read from tracer.def, without higer order of moment + INTEGER :: iq, new_iq, iiq, jq, ierr + + character(len=*),parameter :: modname="infotrac_init" +!----------------------------------------------------------------------- +! Initialization : +! + txts=(/'x','y','z'/) + txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/) + + descrq(14)='VLH' + descrq(10)='VL1' + descrq(11)='VLP' + descrq(12)='FH1' + descrq(13)='FH2' + descrq(16)='PPM' + descrq(17)='PPS' + descrq(18)='PPP' + descrq(20)='SLP' + descrq(30)='PRA' + + + IF (config_inca=='none') THEN + type_trac='lmdz' + ELSE + type_trac='inca' + END IF + +!----------------------------------------------------------------------- +! +! 1) Get the true number of tracers + water vapor/liquid +! Here true tracers (nqtrue) means declared tracers (only first order) +! +!----------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr) + IF(ierr.EQ.0) THEN + WRITE(lunout,*) trim(modname),': Open traceur.def : ok' + READ(90,*) nqtrue + ELSE + WRITE(lunout,*) trim(modname),': Problem in opening traceur.def' + WRITE(lunout,*) trim(modname),': WARNING using defaut values' + if (planet_type=='earth') then + nqtrue=4 ! Default value for Earth + else + nqtrue=1 ! Default value for other planets + endif + END IF + if ( planet_type=='earth') then + ! For Earth, water vapour & liquid tracers are not in the physics + nbtr=nqtrue-2 + else + ! Other planets (for now); we have the same number of tracers + ! in the dynamics than in the physics + nbtr=nqtrue + endif + ELSE + ! nbtr has been read from INCA by init_cont_lmdz() in gcm.F + nqtrue=nbtr+2 + END IF + + IF ((planet_type=="earth").and.(nqtrue < 2)) THEN + WRITE(lunout,*) trim(modname),': nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum' + CALL abort_gcm('infotrac_init','Not enough tracers',1) + END IF +! +! Allocate variables depending on nqtrue and nbtr +! + ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue)) + ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr)) + conv_flg(:) = 1 ! convection activated for all tracers + pbl_flg(:) = 1 ! boundary layer activated for all tracers + +!----------------------------------------------------------------------- +! 2) Choix des schemas d'advection pour l'eau et les traceurs +! +! iadv = 1 schema transport type "humidite specifique LMD" +! iadv = 2 schema amont +! iadv = 14 schema Van-leer + humidite specifique +! Modif F.Codron +! iadv = 10 schema Van-leer (retenu pour l'eau vapeur et liquide) +! iadv = 11 schema Van-Leer pour hadv et version PPM (Monotone) pour vadv +! iadv = 12 schema Frederic Hourdin I +! iadv = 13 schema Frederic Hourdin II +! iadv = 16 schema PPM Monotone(Collela & Woodward 1984) +! iadv = 17 schema PPM Semi Monotone (overshoots autorisés) +! iadv = 18 schema PPM Positif Defini (overshoots undershoots autorisés) +! iadv = 20 schema Slopes +! iadv = 30 schema Prather +! +! Dans le tableau q(ij,l,iq) : iq = 1 pour l'eau vapeur +! iq = 2 pour l'eau liquide +! Et eventuellement iq = 3,nqtot pour les autres traceurs +! +! iadv(1): choix pour l'eau vap. et iadv(2) : choix pour l'eau liq. +!------------------------------------------------------------------------ +! +! Get choice of advection schema from file tracer.def or from INCA +!--------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + IF(ierr.EQ.0) THEN + ! Continue to read tracer.def + DO iq=1,nqtrue + READ(90,*) hadv(iq),vadv(iq),tnom_0(iq) + END DO + CLOSE(90) + ELSE ! Without tracer.def, set default values + if (planet_type=="earth") then + ! for Earth, default is to have 4 tracers + hadv(1) = 14 + vadv(1) = 14 + tnom_0(1) = 'H2Ov' + hadv(2) = 10 + vadv(2) = 10 + tnom_0(2) = 'H2Ol' + hadv(3) = 10 + vadv(3) = 10 + tnom_0(3) = 'RN' + hadv(4) = 10 + vadv(4) = 10 + tnom_0(4) = 'PB' + else ! default for other planets + hadv(1) = 10 + vadv(1) = 10 + tnom_0(1) = 'dummy' + endif ! of if (planet_type=="earth") + END IF + + WRITE(lunout,*) trim(modname),': Valeur de traceur.def :' + WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue + DO iq=1,nqtrue + WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq) + END DO + + ELSE ! type_trac=inca : config_inca='aero' ou 'chem' +! le module de chimie fournit les noms des traceurs +! et les schemas d'advection associes. + +#ifdef INCA + CALL init_transport( & + hadv, & + vadv, & + conv_flg, & + pbl_flg, & + tracnam) +#endif + tnom_0(1)='H2Ov' + tnom_0(2)='H2Ol' + + DO iq =3,nqtrue + tnom_0(iq)=tracnam(iq-2) + END DO + + END IF ! type_trac + +!----------------------------------------------------------------------- +! +! 3) Verify if advection schema 20 or 30 choosen +! Calculate total number of tracers needed: nqtot +! Allocate variables depending on total number of tracers +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + ! Add tracers for certain advection schema + IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN + new_iq=new_iq+1 ! no tracers added + ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN + new_iq=new_iq+4 ! 3 tracers added + ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN + new_iq=new_iq+10 ! 9 tracers added + ELSE + WRITE(lunout,*) trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq) + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1) + END IF + END DO + + IF (new_iq /= nqtrue) THEN + ! The choice of advection schema imposes more tracers + ! Assigne total number of tracers + nqtot = new_iq + + WRITE(lunout,*) trim(modname),': The choice of advection schema for one or more tracers' + WRITE(lunout,*) 'makes it necessary to add tracers' + WRITE(lunout,*) trim(modname)//': ',nqtrue,' is the number of true tracers' + WRITE(lunout,*) trim(modname)//': ',nqtot, ' is the total number of tracers needed' + + ELSE + ! The true number of tracers is also the total number + nqtot = nqtrue + END IF + +! +! Allocate variables with total number of tracers, nqtot +! + ALLOCATE(tname(nqtot), ttext(nqtot)) + ALLOCATE(iadv(nqtot), niadv(nqtot)) + +!----------------------------------------------------------------------- +! +! 4) Determine iadv, long and short name +! +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + new_iq=new_iq+1 + + ! Verify choice of advection schema + IF (hadv(iq)==vadv(iq)) THEN + iadv(new_iq)=hadv(iq) + ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN + iadv(new_iq)=11 + ELSE + WRITE(lunout,*)trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq) + + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1) + END IF + + str1=tnom_0(iq) + tname(new_iq)= tnom_0(iq) + IF (iadv(new_iq)==0) THEN + ttext(new_iq)=trim(str1) + ELSE + ttext(new_iq)=trim(tnom_0(iq))//descrq(iadv(new_iq)) + END IF + + ! schemas tenant compte des moments d'ordre superieur + str2=ttext(new_iq) + IF (iadv(new_iq)==20) THEN + DO jq=1,3 + new_iq=new_iq+1 + iadv(new_iq)=-20 + ttext(new_iq)=trim(str2)//txts(jq) + tname(new_iq)=trim(str1)//txts(jq) + END DO + ELSE IF (iadv(new_iq)==30) THEN + DO jq=1,9 + new_iq=new_iq+1 + iadv(new_iq)=-30 + ttext(new_iq)=trim(str2)//txtp(jq) + tname(new_iq)=trim(str1)//txtp(jq) + END DO + END IF + END DO + +! +! Find vector keeping the correspodence between true and total tracers +! + niadv(:)=0 + iiq=0 + DO iq=1,nqtot + IF(iadv(iq).GE.0) THEN + ! True tracer + iiq=iiq+1 + niadv(iiq)=iq + ENDIF + END DO + + + WRITE(lunout,*) trim(modname),': Information stored in infotrac :' + WRITE(lunout,*) trim(modname),': iadv niadv tname ttext :' + DO iq=1,nqtot + WRITE(lunout,*) iadv(iq),niadv(iq),& + ' ',trim(tname(iq)),' ',trim(ttext(iq)) + END DO + +! +! Test for advection schema. +! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) . +! + DO iq=1,nqtot + IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN + WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1) + ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN + WRITE(lunout,*)trim(modname),'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1) + END IF + END DO + +!----------------------------------------------------------------------- +! Finalize : +! + DEALLOCATE(tnom_0, hadv, vadv) + DEALLOCATE(tracnam) + + END SUBROUTINE infotrac_init + +END MODULE infotrac Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniacademic.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniacademic.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniacademic.F90 (revision 1634) @@ -0,0 +1,272 @@ +! +! $Id$ +! +SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + + USE filtreg_mod + USE infotrac, ONLY : nqtot + USE control_mod, ONLY: day_step,planet_type +#ifdef CPP_IOIPSL + USE IOIPSL +#else + ! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + USE Write_Field + + ! Author: Frederic Hourdin original: 15/01/93 + ! The forcing defined here is from Held and Suarez, 1994, Bulletin + ! of the American Meteorological Society, 75, 1825. + + IMPLICIT NONE + + ! Declararations: + ! --------------- + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comconst.h" + include "comgeom.h" + include "academic.h" + include "ener.h" + include "temps.h" + include "iniprint.h" + include "logic.h" + + ! Arguments: + ! ---------- + + real time_0 + + ! variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm,nqtot) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + + ! Local: + ! ------ + + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL ddsin,zsig,tetapv,w_pv ! variables auxiliaires + real tetastrat ! potential temperature in the stratosphere, in K + real tetajl(jjp1,llm) + INTEGER i,j,l,lsup,ij + + REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T + REAL k_f,k_c_a,k_c_s ! Constantes de rappel + LOGICAL ok_geost ! Initialisation vent geost. ou nul + LOGICAL ok_pv ! Polar Vortex + REAL phi_pv,dphi_pv,gam_pv ! Constantes pour polar vortex + + real zz,ran1 + integer idum + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr + + character(len=*),parameter :: modname="iniacademic" + character(len=80) :: abort_message + + !----------------------------------------------------------------------- + ! 1. Initializations for Earth-like case + ! -------------------------------------- + ! + ! initialize planet radius, rotation rate,... + call conf_planete + + time_0=0. + day_ref=1 + annee_ref=0 + + im = iim + jm = jjm + day_ini = 1 + dtvr = daysec/REAL(day_step) + zdtvr=dtvr + etot0 = 0. + ptot0 = 0. + ztot0 = 0. + stot0 = 0. + ang0 = 0. + + if (llm == 1) then + ! specific initializations for the shallow water case + kappa=1 + endif + + CALL iniconst + CALL inigeom + CALL inifilr + + if (llm == 1) then + ! initialize fields for the shallow water case, if required + if (.not.read_start) then + phis(:)=0. + q(:,:,:)=0 + CALL sw_case_williamson91_6(vcov,ucov,teta,masse,ps) + endif + endif + + academic_case: if (iflag_phys == 2) then + ! initializations + + ! 1. local parameters + ! by convention, winter is in the southern hemisphere + ! Geostrophic wind or no wind? + ok_geost=.TRUE. + CALL getin('ok_geost',ok_geost) + ! Constants for Newtonian relaxation and friction + k_f=1. !friction + CALL getin('k_j',k_f) + k_f=1./(daysec*k_f) + k_c_s=4. !cooling surface + CALL getin('k_c_s',k_c_s) + k_c_s=1./(daysec*k_c_s) + k_c_a=40. !cooling free atm + CALL getin('k_c_a',k_c_a) + k_c_a=1./(daysec*k_c_a) + ! Constants for Teta equilibrium profile + teta0=315. ! mean Teta (S.H. 315K) + CALL getin('teta0',teta0) + ttp=200. ! Tropopause temperature (S.H. 200K) + CALL getin('ttp',ttp) + eps=0. ! Deviation to N-S symmetry(~0-20K) + CALL getin('eps',eps) + delt_y=60. ! Merid Temp. Gradient (S.H. 60K) + CALL getin('delt_y',delt_y) + delt_z=10. ! Vertical Gradient (S.H. 10K) + CALL getin('delt_z',delt_z) + ! Polar vortex + ok_pv=.false. + CALL getin('ok_pv',ok_pv) + phi_pv=-50. ! Latitude of edge of vortex + CALL getin('phi_pv',phi_pv) + phi_pv=phi_pv*pi/180. + dphi_pv=5. ! Width of the edge + CALL getin('dphi_pv',dphi_pv) + dphi_pv=dphi_pv*pi/180. + gam_pv=4. ! -dT/dz vortex (in K/km) + CALL getin('gam_pv',gam_pv) + + ! 2. Initialize fields towards which to relax + ! Friction + knewt_g=k_c_a + DO l=1,llm + zsig=presnivs(l)/preff + knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3) + kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3) + ENDDO + DO j=1,jjp1 + clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4 + ENDDO + + ! Potential temperature + DO l=1,llm + zsig=presnivs(l)/preff + tetastrat=ttp*zsig**(-kappa) + tetapv=tetastrat + IF ((ok_pv).AND.(zsig.LT.0.1)) THEN + tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g) + ENDIF + DO j=1,jjp1 + ! Troposphere + ddsin=sin(rlatu(j)) + tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin & + -delt_z*(1.-ddsin*ddsin)*log(zsig) + if (planet_type=="giant") then + tetajl(j,l)=teta0+(delt_y* & + ((sin(rlatu(j)*3.14159*eps+0.0001))**2) & + / ((rlatu(j)*3.14159*eps+0.0001)**2)) & + -delt_z*log(zsig) + endif + ! Profil stratospherique isotherme (+vortex) + w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2. + tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv + tetajl(j,l)=MAX(tetajl(j,l),tetastrat) + ENDDO + ENDDO + + ! CALL writefield('theta_eq',tetajl) + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + ij=(j-1)*iip1+i + tetarappel(ij,l)=tetajl(j,l) + enddo + enddo + enddo + + ! 3. Initialize fields (if necessary) + IF (.NOT. read_start) THEN + ! surface pressure + ps(:)=preff + ! ground geopotential + phis(:)=0. + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (disvert_type.eq.1) then + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + elseif (disvert_type.eq.2) then + call exner_milieu(ip1jmp1,ps,p,beta,pks,pk,pkf) + else + write(abort_message,*) "Wrong value for disvert_type: ", & + disvert_type + call abort_gcm(modname,abort_message,0) + endif + CALL massdair(p,masse) + + ! bulk initialization of temperature + teta(:,:)=tetarappel(:,:) + + ! geopotential + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + + ! winds + if (ok_geost) then + call ugeostr(phi,ucov) + else + ucov(:,:)=0. + endif + vcov(:,:)=0. + + ! bulk initialization of tracers + if (planet_type=="earth") then + ! Earth: first two tracers will be water + do i=1,nqtot + if (i == 1) q(:,:,i)=1.e-10 + if (i == 2) q(:,:,i)=1.e-15 + if (i.gt.2) q(:,:,i)=0. + enddo + else + q(:,:,:)=0 + endif ! of if (planet_type=="earth") + + ! add random perturbation to temperature + idum = -1 + zz = ran1(idum) + idum = 0 + do l=1,llm + do ij=iip2,ip1jm + teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum)) + enddo + enddo + + ! maintain periodicity in longitude + do l=1,llm + do ij=1,ip1jmp1,iip1 + teta(ij+iim,l)=teta(ij,l) + enddo + enddo + + ENDIF ! of IF (.NOT. read_start) + endif academic_case + +END SUBROUTINE iniacademic Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniconst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniconst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniconst.F (revision 1634) @@ -0,0 +1,84 @@ +! +! $Id$ +! + SUBROUTINE iniconst + + USE control_mod +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + + IMPLICIT NONE +c +c P. Le Van +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "temps.h" +#include "comvert.h" +#include "iniprint.h" + + character(len=*),parameter :: modname="iniconst" + character(len=80) :: abort_message +c +c +c +c----------------------------------------------------------------------- +c dimension des boucles: +c ---------------------- + + im = iim + jm = jjm + lllm = llm + imp1 = iim + jmp1 = jjm + 1 + lllmm1 = llm - 1 + lllmp1 = llm + 1 + +c----------------------------------------------------------------------- + + dtphys = iphysiq * dtvr + unsim = 1./iim + pi = 2.*ASIN( 1. ) + +c----------------------------------------------------------------------- +c + + r = cpp * kappa + + write(lunout,*) trim(modname),': R CP Kappa ',r,cpp,kappa +c +c----------------------------------------------------------------------- + +! vertical discretization: default behavior depends on planet_type flag + if (planet_type=="earth") then + disvert_type=1 + else + disvert_type=2 + endif + ! but user can also specify using one or the other in run.def: + call getin('disvert_type',disvert_type) + write(lunout,*) trim(modname),': disvert_type=',disvert_type + + if (disvert_type==1) then + ! standard case for Earth (automatic generation of levels) + call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig, + & scaleheight) + else if (disvert_type==2) then + ! standard case for planets (levels generated using z2sig.def file) + call disvert_noterre + else + write(abort_message,*) "Wrong value for disvert_type: ", + & disvert_type + call abort_gcm(modname,abort_message,0) + endif + + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inidissip.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inidissip.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inidissip.F90 (revision 1634) @@ -0,0 +1,232 @@ +! +! $Id$ +! +SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh , & + tetagdiv,tetagrot,tetatemp ) + !======================================================================= + ! initialisation de la dissipation horizontale + !======================================================================= + !----------------------------------------------------------------------- + ! declarations: + ! ------------- + + USE control_mod, only : dissip_period,iperiod + + IMPLICIT NONE + include "dimensions.h" + include "paramet.h" + include "comdissipn.h" + include "comconst.h" + include "comvert.h" + include "logic.h" + include "iniprint.h" + + LOGICAL,INTENT(in) :: lstardis + INTEGER,INTENT(in) :: nitergdiv,nitergrot,niterh + REAL,INTENT(in) :: tetagdiv,tetagrot,tetatemp + +! Local variables: + REAL fact,zvert(llm),zz + REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm) + REAL ullm,vllm,umin,vmin,zhmin,zhmax + REAL zllm,z1llm + + INTEGER l,ij,idum,ii + REAL tetamin + REAL pseudoz + character (len=80) :: abort_message + + REAL ran1 + + + !----------------------------------------------------------------------- + ! + ! calcul des valeurs propres des operateurs par methode iterrative: + ! ----------------------------------------------------------------- + + crot = -1. + cdivu = -1. + cdivh = -1. + + ! calcul de la valeur propre de divgrad: + ! -------------------------------------- + idum = 0 + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltap(ij,l) = 1. + ENDDO + ENDDO + + idum = -1 + zh(1) = RAN1(idum)-.5 + idum = 0 + DO ij = 2, ip1jmp1 + zh(ij) = RAN1(idum) -.5 + ENDDO + + CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1) + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + IF ( zhmin .GE. zhmax ) THEN + write(lunout,*)' Inidissip zh min max ',zhmin,zhmax + abort_message='probleme generateur alleatoire dans inidissip' + call abort_gcm('inidissip',abort_message,1) + ENDIF + + zllm = ABS( zhmax ) + DO l = 1,50 + IF(lstardis) THEN + CALL divgrad2(1,zh,deltap,niterh,zh) + ELSE + CALL divgrad (1,zh,niterh,zh) + ENDIF + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + zllm = ABS( zhmax ) + z1llm = 1./zllm + DO ij = 1,ip1jmp1 + zh(ij) = zh(ij)* z1llm + ENDDO + ENDDO + + IF(lstardis) THEN + cdivh = 1./ zllm + ELSE + cdivh = zllm ** ( -1./niterh ) + ENDIF + + ! calcul des valeurs propres de gradiv (ii =1) et nxgrarot(ii=2) + ! ----------------------------------------------------------------- + write(lunout,*)'inidissip: calcul des valeurs propres' + + DO ii = 1, 2 + ! + DO ij = 1, ip1jmp1 + zu(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1) + DO ij = 1, ip1jm + zv(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zv,jjm,1,2,1,.FALSE.,1) + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + DO l = 1, 50 + IF(ii.EQ.1) THEN + !cccc CALL covcont( 1,zu,zv,zu,zv ) + IF(lstardis) THEN + CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv ) + ELSE + CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv ) + ENDIF + ELSE + IF(lstardis) THEN + CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv ) + ELSE + CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv ) + ENDIF + ENDIF + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + zllm = MAX( ullm,vllm ) + z1llm = 1./ zllm + DO ij = 1, ip1jmp1 + zu(ij) = zu(ij)* z1llm + ENDDO + DO ij = 1, ip1jm + zv(ij) = zv(ij)* z1llm + ENDDO + end DO + + IF ( ii.EQ.1 ) THEN + IF(lstardis) THEN + cdivu = 1./zllm + ELSE + cdivu = zllm **( -1./nitergdiv ) + ENDIF + ELSE + IF(lstardis) THEN + crot = 1./ zllm + ELSE + crot = zllm **( -1./nitergrot ) + ENDIF + ENDIF + + end DO + + ! petit test pour les operateurs non star: + ! ---------------------------------------- + + ! IF(.NOT.lstardis) THEN + fact = rad*24./REAL(jjm) + fact = fact*fact + write(lunout,*)'inidissip: coef u ', fact/cdivu, 1./cdivu + write(lunout,*)'inidissip: coef r ', fact/crot , 1./crot + write(lunout,*)'inidissip: coef h ', fact/cdivh, 1./cdivh + ! ENDIF + + !----------------------------------------------------------------------- + ! variation verticale du coefficient de dissipation: + ! -------------------------------------------------- + + if (ok_strato .and. llm==39) then + do l=1,llm + pseudoz=8.*log(preff/presnivs(l)) + zvert(l)=1+ & + (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. & + *(dissip_factz-1.) + enddo + else + DO l=1,llm + zvert(l)=1. + ENDDO + fact=2. + DO l = 1, llm + zz = 1. - preff/presnivs(l) + zvert(l)= fact -( fact-1.)/( 1.+zz*zz ) + ENDDO + endif + + + write(lunout,*)'inidissip: Constantes de temps de la diffusion horizontale' + + tetamin = 1.e+6 + + DO l=1,llm + tetaudiv(l) = zvert(l)/tetagdiv + tetaurot(l) = zvert(l)/tetagrot + tetah(l) = zvert(l)/tetatemp + + IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l) + IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l) + IF( tetamin.GT. (1./ tetah(l)) ) tetamin = 1./ tetah(l) + ENDDO + + ! If dissip_period=0 calculate value for dissipation period, else keep value read from gcm.def + IF (dissip_period == 0) THEN + dissip_period = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod + write(lunout,*)'inidissip: tetamin dtvr iperiod dissip_period(intermed) ',tetamin,dtvr,iperiod,dissip_period + dissip_period = MAX(iperiod,dissip_period) + END IF + + dtdiss = dissip_period * dtvr + write(lunout,*)'inidissip: dissip_period=',dissip_period,' dtdiss=',dtdiss,' dtvr=',dtvr + + DO l = 1,llm + write(lunout,*)zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), & + dtdiss*tetah(l) + ENDDO + +END SUBROUTINE inidissip Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inigeom.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inigeom.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inigeom.F (revision 1634) @@ -0,0 +1,699 @@ +! +! $Id$ +! +c +c + SUBROUTINE inigeom +c +c Auteur : P. Le Van +c +c ............ Version du 01/04/2001 ........................ +c +c Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4 aux memes en- +c endroits que les aires aireij1,..aireij4 . + +c Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol. +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "serre.h" +#include "logic.h" +#include "comdissnew.h" + +c----------------------------------------------------------------------- +c .... Variables locales .... +c + INTEGER i,j,itmax,itmay,iter + REAL cvu(iip1,jjp1),cuv(iip1,jjm) + REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm + REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm + REAL coslatm,coslatp,radclatm,radclatp + REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1), + * cuij4(iip1,jjp1) + REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1), + * cvij4(iip1,jjp1) + REAL rlonvv(iip1),rlatuu(jjp1) + REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) , + * yprimv(jjm),yprimu(jjp1) + REAL gamdi_gdiv, gamdi_grot, gamdi_h + + REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1), + , xprimp025(iip1) + SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu + SAVE rlonm025,xprimm025,rlonp025,xprimp025 + + REAL SSUM +c +c +c ------------------------------------------------------------------ +c - - +c - calcul des coeff. ( cu, cv , 1./cu**2, 1./cv**2 ) - +c - - +c ------------------------------------------------------------------ +c +c les coef. ( cu, cv ) permettent de passer des vitesses naturelles +c aux vitesses covariantes et contravariantes , ou vice-versa ... +c +c +c on a : u (covariant) = cu * u (naturel) , u(contrav)= u(nat)/cu +c v (covariant) = cv * v (naturel) , v(contrav)= v(nat)/cv +c +c on en tire : u(covariant) = cu * cu * u(contravariant) +c v(covariant) = cv * cv * v(contravariant) +c +c +c on a l'application ( x(X) , y(Y) ) avec - im/2 +1 < X < im/2 +c = = +c et - jm/2 < Y < jm/2 +c = = +c +c ................................................... +c ................................................... +c . x est la longitude du point en radians . +c . y est la latitude du point en radians . +c . . +c . on a : cu(i,j) = rad * COS(y) * dx/dX . +c . cv( j ) = rad * dy/dY . +c . aire(i,j) = cu(i,j) * cv(j) . +c . . +c . y, dx/dX, dy/dY calcules aux points concernes . +c . . +c ................................................... +c ................................................... +c +c +c +c , +c cv , bien que dependant de j uniquement,sera ici indice aussi en i +c pour un adressage plus facile en ij . +c +c +c +c ************** aux points u et v , ***************** +c xprimu et xprimv sont respectivement les valeurs de dx/dX +c yprimu et yprimv . . . . . . . . . . . dy/dY +c rlatu et rlatv . . . . . . . . . . .la latitude +c cvu et cv . . . . . . . . . . . cv +c +c ************** aux points u, v, scalaires, et z **************** +c cu, cuv, cuscal, cuz sont respectiv. les valeurs de cu +c +c +c +c Exemple de distribution de variables sur la grille dans le +c domaine de travail ( X,Y ) . +c ................................................................ +c DX=DY= 1 +c +c +c + represente un point scalaire ( p.exp la pression ) +c > represente la composante zonale du vent +c V represente la composante meridienne du vent +c o represente la vorticite +c +c ---- , car aux poles , les comp.zonales covariantes sont nulles +c +c +c +c i -> +c +c 1 2 3 4 5 6 7 8 +c j +c v 1 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c V o V o V o V o V o V o V o V o +c +c 2 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 3 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 4 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 5 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c +c Ci-dessus, on voit que le nombre de pts.en longitude est egal +c a IM = 8 +c De meme , le nombre d'intervalles entre les 2 poles est egal +c a JM = 4 +c +c Les points scalaires ( + ) correspondent donc a des valeurs +c entieres de i ( 1 a IM ) et de j ( 1 a JM +1 ) . +c +c Les vents U ( > ) correspondent a des valeurs semi- +c entieres de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1) +c +c Les vents V ( V ) correspondent a des valeurs entieres +c de i ( 1 a IM ) et semi-entieres de j ( 1 +0.5 a JM +0.5) +c +c +c + WRITE(6,3) + 3 FORMAT( // 10x,' .... INIGEOM date du 01/06/98 ..... ', + * //5x,' Calcul des elongations cu et cv comme sommes des 4 ' / + * 5x,' elong. cuij1, .. 4 , cvij1,.. 4 qui les entourent , aux + * '/ 5x,' memes endroits que les aires aireij1,...j4 . ' / ) +c +c + IF( nitergdiv.NE.2 ) THEN + gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. ) + ELSE + gamdi_gdiv = 0. + ENDIF + IF( nitergrot.NE.2 ) THEN + gamdi_grot = coefdis/ ( REAL(nitergrot) -2. ) + ELSE + gamdi_grot = 0. + ENDIF + IF( niterh.NE.2 ) THEN + gamdi_h = coefdis/ ( REAL(niterh) -2. ) + ELSE + gamdi_h = 0. + ENDIF + + WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis, + * nitergdiv,nitergrot,niterh +c + pi = 2.* ASIN(1.) +c + WRITE(6,990) + +c ---------------------------------------------------------------- +c + IF( .NOT.fxyhypb ) THEN +c +c + IF( ysinus ) THEN +c + WRITE(6,*) ' *** Inigeom , Y = Sinus ( Latitude ) *** ' +c +c .... utilisation de f(x,y ) avec y = sinus de la latitude ..... + + CALL fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ELSE +c + WRITE(6,*) '*** Inigeom , Y = Latitude , der. sinusoid . ***' + +c .... utilisation de f(x,y) a tangente sinusoidale , y etant la latit. ... +c + + pxo = clon *pi /180. + pyo = 2.* clat* pi /180. +c +c .... determination de transx ( pour le zoom ) par Newton-Raphson ... +c + itmax = 10 + eps = .1e-7 +c + xo1 = 0. + DO 10 iter = 1, itmax + x1 = xo1 + f = x1+ alphax *SIN(x1-pxo) + df = 1.+ alphax *COS(x1-pxo) + x1 = x1 - f/df + xdm = ABS( x1- xo1 ) + IF( xdm.LE.eps )GO TO 11 + xo1 = x1 + 10 CONTINUE + 11 CONTINUE +c + transx = xo1 + + itmay = 10 + eps = .1e-7 +C + yo1 = 0. + DO 15 iter = 1,itmay + y1 = yo1 + f = y1 + alphay* SIN(y1-pyo) + df = 1. + alphay* COS(y1-pyo) + y1 = y1 -f/df + ydm = ABS(y1-yo1) + IF(ydm.LE.eps) GO TO 17 + yo1 = y1 + 15 CONTINUE +c + 17 CONTINUE + transy = yo1 + + CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ENDIF +c + ELSE +c +c .... Utilisation de fxyhyper , f(x,y) a derivee tangente hyperbol. +c ..................................................................... + + WRITE(6,*)'*** Inigeom , Y = Latitude , der.tg. hyperbolique ***' + + CALL fxyhyper( clat, grossismy, dzoomy, tauy , + , clon, grossismx, dzoomx, taux , + , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 ) + + + ENDIF +c +c ------------------------------------------------------------------- + +c + rlatu(1) = ASIN(1.) + rlatu(jjp1) = - rlatu(1) +c +c +c .... calcul aux poles .... +c + yprimu(1) = 0. + yprimu(jjp1) = 0. +c +c + un4rad2 = 0.25 * rad * rad +c +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c - - +c - calcul des aires ( aire,aireu,airev, 1./aire, 1./airez ) - +c - et de fext , force de coriolis extensive . - +c - - +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c +c +c +c A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont +c affectees 4 aires entourant P , calculees respectivement aux points +c ( i + 1/4, j - 1/4 ) : aireij1 (i,j) +c ( i + 1/4, j + 1/4 ) : aireij2 (i,j) +c ( i - 1/4, j + 1/4 ) : aireij3 (i,j) +c ( i - 1/4, j - 1/4 ) : aireij4 (i,j) +c +c , +c Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y). +c Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme +c des 4 aires aireij1,aireij2,aireij3,aireij4 qui sont affectees au +c point (i,j) . +c On definit en outre les coefficients alpha comme etant egaux a +c (aireij / aire), c.a.d par exp. alpha1(i,j)=aireij1(i,j)/aire(i,j) +c +c De meme, toute aire centree en 1 point U est egale a la somme des +c 4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U . +c Idem pour airev, airez . +c +c On a ,pour chaque maille : dX = dY = 1 +c +c +c . V +c +c aireij4 . . aireij1 +c +c U . . P . U +c +c aireij3 . . aireij2 +c +c . V +c +c +c +c +c +c .................................................................... +c +c Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4 +c qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen +c taires cuij et les 4 elongat. cvij qui sont calculees aux memes +c endroits que les aireij . +c +c .................................................................... +c +c ....... do 35 : boucle sur les jjm + 1 latitudes ..... +c +c + DO 35 j = 1, jjp1 +c + IF ( j. eq. 1 ) THEN +c + yprm = yprimu1(j) + rlatm = rlatu1(j) +c + coslatm = COS( rlatm ) + radclatm = 0.5* rad * coslatm +c + DO 30 i = 1, iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij2( i,1 ) = un4rad2 * coslatm * xprp * yprm + aireij3( i,1 ) = un4rad2 * coslatm * xprm * yprm + cuij2 ( i,1 ) = radclatm * xprp + cuij3 ( i,1 ) = radclatm * xprm + cvij2 ( i,1 ) = 0.5* rad * yprm + cvij3 ( i,1 ) = cvij2(i,1) + 30 CONTINUE +c + DO i = 1, iim + aireij1( i,1 ) = 0. + aireij4( i,1 ) = 0. + cuij1 ( i,1 ) = 0. + cuij4 ( i,1 ) = 0. + cvij1 ( i,1 ) = 0. + cvij4 ( i,1 ) = 0. + ENDDO +c + END IF +c + IF ( j. eq. jjp1 ) THEN + yprp = yprimu2(j-1) + rlatp = rlatu2 (j-1) +ccc yprp = fyprim( REAL(j) - 0.25 ) +ccc rlatp = fy ( REAL(j) - 0.25 ) +c + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp +c + DO 31 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij1( i,jjp1 ) = un4rad2 * coslatp * xprp * yprp + aireij4( i,jjp1 ) = un4rad2 * coslatp * xprm * yprp + cuij1(i,jjp1) = radclatp * xprp + cuij4(i,jjp1) = radclatp * xprm + cvij1(i,jjp1) = 0.5 * rad* yprp + cvij4(i,jjp1) = cvij1(i,jjp1) + 31 CONTINUE +c + DO i = 1, iim + aireij2( i,jjp1 ) = 0. + aireij3( i,jjp1 ) = 0. + cvij2 ( i,jjp1 ) = 0. + cvij3 ( i,jjp1 ) = 0. + cuij2 ( i,jjp1 ) = 0. + cuij3 ( i,jjp1 ) = 0. + ENDDO +c + END IF +c + + IF ( j .gt. 1 .AND. j .lt. jjp1 ) THEN +c + rlatp = rlatu2 ( j-1 ) + yprp = yprimu2( j-1 ) + rlatm = rlatu1 ( j ) + yprm = yprimu1( j ) +cc rlatp = fy ( REAL(j) - 0.25 ) +cc yprp = fyprim( REAL(j) - 0.25 ) +cc rlatm = fy ( REAL(j) + 0.25 ) +cc yprm = fyprim( REAL(j) + 0.25 ) + + coslatm = COS( rlatm ) + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp + radclatm = 0.5* rad * coslatm +c + DO 32 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + + ai14 = un4rad2 * coslatp * yprp + ai23 = un4rad2 * coslatm * yprm + aireij1 ( i,j ) = ai14 * xprp + aireij2 ( i,j ) = ai23 * xprp + aireij3 ( i,j ) = ai23 * xprm + aireij4 ( i,j ) = ai14 * xprm + cuij1 ( i,j ) = radclatp * xprp + cuij2 ( i,j ) = radclatm * xprp + cuij3 ( i,j ) = radclatm * xprm + cuij4 ( i,j ) = radclatp * xprm + cvij1 ( i,j ) = 0.5* rad * yprp + cvij2 ( i,j ) = 0.5* rad * yprm + cvij3 ( i,j ) = cvij2(i,j) + cvij4 ( i,j ) = cvij1(i,j) + 32 CONTINUE +c + END IF +c +c ........ periodicite ............ +c + cvij1 (iip1,j) = cvij1 (1,j) + cvij2 (iip1,j) = cvij2 (1,j) + cvij3 (iip1,j) = cvij3 (1,j) + cvij4 (iip1,j) = cvij4 (1,j) + cuij1 (iip1,j) = cuij1 (1,j) + cuij2 (iip1,j) = cuij2 (1,j) + cuij3 (iip1,j) = cuij3 (1,j) + cuij4 (iip1,j) = cuij4 (1,j) + aireij1 (iip1,j) = aireij1 (1,j ) + aireij2 (iip1,j) = aireij2 (1,j ) + aireij3 (iip1,j) = aireij3 (1,j ) + aireij4 (iip1,j) = aireij4 (1,j ) + + 35 CONTINUE +c +c .............................................................. +c + DO 37 j = 1, jjp1 + DO 36 i = 1, iim + aire ( i,j ) = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) + + * aireij4(i,j) + alpha1 ( i,j ) = aireij1(i,j) / aire(i,j) + alpha2 ( i,j ) = aireij2(i,j) / aire(i,j) + alpha3 ( i,j ) = aireij3(i,j) / aire(i,j) + alpha4 ( i,j ) = aireij4(i,j) / aire(i,j) + alpha1p2( i,j ) = alpha1 (i,j) + alpha2 (i,j) + alpha1p4( i,j ) = alpha1 (i,j) + alpha4 (i,j) + alpha2p3( i,j ) = alpha2 (i,j) + alpha3 (i,j) + alpha3p4( i,j ) = alpha3 (i,j) + alpha4 (i,j) + 36 CONTINUE +c +c + aire (iip1,j) = aire (1,j) + alpha1 (iip1,j) = alpha1 (1,j) + alpha2 (iip1,j) = alpha2 (1,j) + alpha3 (iip1,j) = alpha3 (1,j) + alpha4 (iip1,j) = alpha4 (1,j) + alpha1p2(iip1,j) = alpha1p2(1,j) + alpha1p4(iip1,j) = alpha1p4(1,j) + alpha2p3(iip1,j) = alpha2p3(1,j) + alpha3p4(iip1,j) = alpha3p4(1,j) + 37 CONTINUE +c + + DO 42 j = 1,jjp1 + DO 41 i = 1,iim + aireu (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) + + * aireij3(i+1,j) + unsaire ( i,j)= 1./ aire(i,j) + unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv ) + unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h ) + airesurg ( i,j)= aire(i,j)/ g + 41 CONTINUE + aireu (iip1,j) = aireu (1,j) + unsaire (iip1,j) = unsaire(1,j) + unsair_gam1(iip1,j) = unsair_gam1(1,j) + unsair_gam2(iip1,j) = unsair_gam2(1,j) + airesurg (iip1,j) = airesurg(1,j) + 42 CONTINUE +c +c + DO 48 j = 1,jjm +c + DO i=1,iim + airev (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) + + * aireij4(i,j+1) + ENDDO + DO i=1,iim + airez = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) + + * aireij4(i+1,j+1) + unsairez(i,j) = 1./ airez + unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot ) + fext (i,j) = airez * SIN(rlatv(j))* 2.* omeg + ENDDO + airev (iip1,j) = airev(1,j) + unsairez (iip1,j) = unsairez(1,j) + fext (iip1,j) = fext(1,j) + unsairz_gam(iip1,j) = unsairz_gam(1,j) +c + 48 CONTINUE +c +c +c ..... Calcul des elongations cu,cv, cvu ......... +c + DO j = 1, jjm + DO i = 1, iim + cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1)) + cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j) +cvij3(i,j) ) + cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1)) + unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) ) + ENDDO + DO i = 1, iim + cuvsurcv (i,j) = airev(i,j) * unscv2(i,j) + cvsurcuv (i,j) = 1./cuvsurcv(i,j) + cuvscvgam1(i,j) = cuvsurcv (i,j) ** ( - gamdi_gdiv ) + cuvscvgam2(i,j) = cuvsurcv (i,j) ** ( - gamdi_h ) + cvscuvgam(i,j) = cvsurcuv (i,j) ** ( - gamdi_grot ) + ENDDO + cv (iip1,j) = cv (1,j) + cvu (iip1,j) = cvu (1,j) + unscv2 (iip1,j) = unscv2 (1,j) + cuv (iip1,j) = cuv (1,j) + cuvsurcv (iip1,j) = cuvsurcv (1,j) + cvsurcuv (iip1,j) = cvsurcuv (1,j) + cuvscvgam1(iip1,j) = cuvscvgam1(1,j) + cuvscvgam2(iip1,j) = cuvscvgam2(1,j) + cvscuvgam(iip1,j) = cvscuvgam(1,j) + ENDDO + + DO j = 2, jjm + DO i = 1, iim + cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j)) + unscu2 (i,j) = 1./ ( cu(i,j) * cu(i,j) ) + cvusurcu (i,j) = aireu(i,j) * unscu2(i,j) + cusurcvu (i,j) = 1./ cvusurcu(i,j) + cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) + cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h ) + cuscvugam (i,j) = cusurcvu(i,j) ** ( - gamdi_grot ) + ENDDO + cu (iip1,j) = cu(1,j) + unscu2 (iip1,j) = unscu2(1,j) + cvusurcu (iip1,j) = cvusurcu(1,j) + cusurcvu (iip1,j) = cusurcvu(1,j) + cvuscugam1(iip1,j) = cvuscugam1(1,j) + cvuscugam2(iip1,j) = cvuscugam2(1,j) + cuscvugam (iip1,j) = cuscvugam(1,j) + ENDDO + +c +c .... calcul aux poles .... +c + DO i = 1, iip1 + cu ( i, 1 ) = 0. + unscu2( i, 1 ) = 0. + cvu ( i, 1 ) = 0. +c + cu (i, jjp1) = 0. + unscu2(i, jjp1) = 0. + cvu (i, jjp1) = 0. + ENDDO +c +c .............................................................. +c + DO j = 1, jjm + DO i= 1, iim + airvscu2 (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) ) + aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot ) + ENDDO + airvscu2 (iip1,j) = airvscu2(1,j) + aivscu2gam(iip1,j) = aivscu2gam(1,j) + ENDDO + + DO j=2,jjm + DO i=1,iim + airuscv2 (i,j) = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) ) + aiuscv2gam (i,j) = airuscv2(i,j)** ( - gamdi_grot ) + ENDDO + airuscv2 (iip1,j) = airuscv2 (1,j) + aiuscv2gam(iip1,j) = aiuscv2gam(1,j) + ENDDO + +c +c calcul des aires aux poles : +c ----------------------------- +c + apoln = SSUM(iim,aire(1,1),1) + apols = SSUM(iim,aire(1,jjp1),1) + unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) ) + unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) ) + unsapolnga2 = 1./ ( apoln ** ( - gamdi_h ) ) + unsapolsga2 = 1./ ( apols ** ( - gamdi_h ) ) +c +c----------------------------------------------------------------------- +c gtitre='Coriolis version ancienne' +c gfichier='fext1' +c CALL writestd(fext,iip1*jjm) +c +c changement F. Hourdin calcul conservatif pour fext +c constang contient le produit a * cos ( latitude ) * omega +c + DO i=1,iim + constang(i,1) = 0. + ENDDO + DO j=1,jjm-1 + DO i=1,iim + constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1)) + ENDDO + ENDDO + DO i=1,iim + constang(i,jjp1) = 0. + ENDDO +c +c periodicite en longitude +c + DO j=1,jjm + fext(iip1,j) = fext(1,j) + ENDDO + DO j=1,jjp1 + constang(iip1,j) = constang(1,j) + ENDDO + +c fin du changement + +c +c----------------------------------------------------------------------- +c + WRITE(6,*) ' *** Coordonnees de la grille *** ' + WRITE(6,995) +c + WRITE(6,*) ' LONGITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,iip1 + rlonvv(i) = rlonv(i)*180./pi + ENDDO + WRITE(6,400) rlonvv +c + WRITE(6,995) + WRITE(6,*) ' LATITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,jjm + rlatuu(i)=rlatv(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjm) +c + DO i=1,iip1 + rlonvv(i)=rlonu(i)*180./pi + ENDDO + WRITE(6,995) + WRITE(6,*) ' LONGITUDES aux pts. U ( degres ) ' + WRITE(6,995) + WRITE(6,400) rlonvv + WRITE(6,995) + + WRITE(6,*) ' LATITUDES aux pts. U ( degres ) ' + WRITE(6,995) + DO i=1,jjp1 + rlatuu(i)=rlatu(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjp1) + WRITE(6,995) +c +444 format(f10.3,f6.0) +400 FORMAT(1x,8f8.2) +990 FORMAT(//) +995 FORMAT(/) +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inigrads.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inigrads.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inigrads.F (revision 1634) @@ -0,0 +1,92 @@ +! +! $Header$ +! + subroutine inigrads(if,im + s ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz + s ,dt,file,titlel) + + + implicit none + + integer if,im,jm,lm,i,j,l,lnblnk + real x(im),y(jm),z(lm),fx,fy,fz,dt + real xmin,xmax,ymin,ymax + + character file*10,titlel*40 + +#include "gradsdef.h" + +c data unit/66,32,34,36,38,40,42,44,46,48/ + integer nf + save nf + data nf/0/ + + unit(1)=66 + unit(2)=32 + unit(3)=34 + unit(4)=36 + unit(5)=38 + unit(6)=40 + unit(7)=42 + unit(8)=44 + unit(9)=46 + + if (if.le.nf) stop'verifier les appels a inigrads' + + print*,'Entree dans inigrads' + + nf=if + title(if)=titlel + ivar(if)=0 + + fichier(if)=file(1:lnblnk(file)) + + firsttime(if)=.true. + dtime(if)=dt + + iid(if)=1 + ifd(if)=im + imd(if)=im + do i=1,im + xd(i,if)=x(i)*fx + if(xd(i,if).lt.xmin) iid(if)=i+1 + if(xd(i,if).le.xmax) ifd(if)=i + enddo + print*,'On stoke du point ',iid(if),' a ',ifd(if),' en x' + + jid(if)=1 + jfd(if)=jm + jmd(if)=jm + do j=1,jm + yd(j,if)=y(j)*fy + if(yd(j,if).gt.ymax) jid(if)=j+1 + if(yd(j,if).ge.ymin) jfd(if)=j + enddo + print*,'On stoke du point ',jid(if),' a ',jfd(if),' en y' + + print*,'Open de dat' + print*,'file=',file + print*,'fichier(if)=',fichier(if) + + print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if)) + print*,file(1:lnblnk(file))//'.dat' + + OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat' + s ,FORM='unformatted', + s ACCESS='direct' + s ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1)) + + print*,'Open de dat ok' + + lmd(if)=lm + do l=1,lm + zd(l,if)=z(l)*fz + enddo + + irec(if)=0 + + print*,if,imd(if),jmd(if),lmd(if) + print*,'if,imd(if),jmd(if),lmd(if)' + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniprint.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniprint.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/iniprint.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! +! +! gestion des impressions de sorties et de débogage +! lunout: unité du fichier dans lequel se font les sorties +! (par defaut 6, la sortie standard) +! prt_level: niveau d'impression souhaité (0 = minimum) +! + INTEGER lunout, prt_level + COMMON /comprint/ lunout, prt_level Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initdynav_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initdynav_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initdynav_p.F (revision 1634) @@ -0,0 +1,204 @@ +! +! $Id$ +! + subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt,fileid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL. Initialisation du fichier histoire moyenne. +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep : frequence d'ecriture +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer thoriid, zvertiid + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynave_domain_id + + if (adjust) return +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynave_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn,tau0, zjulian, tstep, thoriid, + . fileid,dynave_domain_id) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sigss', 'Niveaux sigma','Pa', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + write(6,*)'inithistave',tstep + call histdef(fileid, 'u', 'vents u scalaires moyennes', + . 'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Vents V +C + call histdef(fileid, 'v', 'vents v scalaires moyennes', + . 'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Temperature +C + call histdef(fileid, 'temp', 'temperature moyennee', 'K', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Temperature potentielle +C + call histdef(fileid, 'theta', 'temperature potentielle', 'K', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel moyenne', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) +#else + write(lunout,*)'initdynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initfluxsto_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initfluxsto_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initfluxsto_p.F (revision 1634) @@ -0,0 +1,297 @@ +! +! $Id$ +! + subroutine initfluxsto_p + . (infile,tstep,t_ops,t_wrt, + . fileid,filevid,filedid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + real tstep, t_ops, t_wrt + integer fileid, filevid,filedid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + real nivd(1) + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1) + integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid + integer ii,jj + integer zan, idayref + logical ok_sync + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynu_domain_id + INTEGER :: dynv_domain_id + +C +C Initialisations +C + pi = 4. * atan (1.) + str='q ' + ctrac = 'traceur ' + ok_sync = .true. +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = annee_ref + idayref = day_ref + CALL ymds2ju(zan, 1, idayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynu_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, + . fileid,dynu_domain_id) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjm /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynv_domain_id) + + call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, + . filevid,dynv_domain_id) + + rl(1,1) = 1. + + if (mpi_rank==0) then + + call histbeg('defstoke.nc', 1, rl, 1, rl, + . 1, 1, 1, 1, + . tau0, zjulian, tstep, dhoriid, filedid) + + endif +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), + . 'scalar','Grille points scalaires', thoriid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +c pour le fichier def + if (mpi_rank==0) then + nivd(1) = 1 + call histvert(filedid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . 1, nivd, dvertiid) + endif +C +C Appels a histdef pour la definition des variables a sauvegarder + + CALL histdef(fileid, "phis", "Surface geop. height", "-", + . iip1,jjn,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(fileid, "aire", "Grid area", "-", + . iip1,jjn,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + if (mpi_rank==0) then + + CALL histdef(filedid, "dtvr", "tps dyn", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istdyn", "tps stock", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istphy", "tps stock phy", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + endif +C +C Masse +C + call histdef(fileid, 'masse', 'Masse', 'kg', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pbaru +C + call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', + . iip1, jjn, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Pbarv +C + if (pole_sud) jjn=jj_nb-1 + + call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', + . iip1, jjn, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C w +C + if (pole_sud) jjn=jj_nb + call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) + if (mpi_rank==0) call histend(filedid) + if (ok_sync) then + call histsync(fileid) + call histsync(filevid) + if (mpi_rank==0) call histsync(filedid) + endif + +#else + write(lunout,*)'initfluxsto_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inithist_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inithist_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inithist_p.F (revision 1634) @@ -0,0 +1,257 @@ +! +! $Id$ +! + subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt, + . fileid,filevid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid, filevid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid, zvertiid + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynu_domain_id + INTEGER :: dynv_domain_id + +C +C Initialisations +C + if (adjust) return + + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynu_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn, tau0, + . zjulian, tstep, uhoriid, fileid,dynu_domain_id) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjm /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynv_domain_id) + + call histbeg('dyn_histv', iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn, tau0, zjulian, tstep, vhoriid, + . filevid,dynv_domain_id) +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), + . 'scalar','Grille points scalaires', thoriid) +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + jjn=jj_nb + + call histdef(fileid, 'ucov', 'vents u covariants', 'm/s', + . iip1, jjn, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Vents V +C + if (pole_sud) jjn=jj_nb-1 + + call histdef(filevid, 'vcov', 'vents v covariants', 'm/s', + . iip1, jjn, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + jjn=jj_nb + + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) +#else + write(lunout,*)'inithist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initial0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initial0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/initial0.F (revision 1634) @@ -0,0 +1,12 @@ +! +! $Header$ +! + SUBROUTINE initial0(n,x) + IMPLICIT NONE + INTEGER n,i + REAL x(n) + DO 10 i=1,n + x(i)=0. +10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/integrd_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/integrd_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/integrd_p.F (revision 1634) @@ -0,0 +1,374 @@ +! +! $Id$ +! + SUBROUTINE integrd_p + $ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1, + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold) + USE parallel + USE control_mod, only : planet_type + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c objet: +c ------ +c +c Incrementation des tendances dynamiques +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "logic.h" +#include "temps.h" +#include "serre.h" + +c Arguments: +c ---------- + + INTEGER nq + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq) + REAL ps0(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1) + + REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm) + + REAL dv(ip1jm,llm),du(ip1jmp1,llm) + REAL dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm) + +c Local: +c ------ + + REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1) + REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm) + REAL,SAVE :: p(ip1jmp1,llmp1) + REAL tpn,tps,tppn(iim),tpps(iim) + REAL qpn,qps,qppn(iim),qpps(iim) + REAL,SAVE :: deltap( ip1jmp1,llm ) + + INTEGER l,ij,iq + + REAL SSUM + EXTERNAL SSUM + INTEGER ijb,ije,jjb,jje + REAL,SAVE :: ps(ip1jmp1) + LOGICAL :: checksum + INTEGER :: stop_it +c----------------------------------------------------------------------- +c$OMP BARRIER + if (pole_nord) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij , l) = 0. + uscr( ij ) = 0. + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF + + if (pole_sud) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij +ip1jm, l) = 0. + uscr( ij +ip1jm ) = 0. + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF + +c ............ integration de ps .............. + +c CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + massescr(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC) + DO 2 ij = ijb,ije + pscr (ij) = ps0(ij) + ps (ij) = psm1(ij) + dt * dp(ij) + 2 CONTINUE +c$OMP END DO +c$OMP BARRIER +c --> ici synchro OPENMP pour ps + + checksum=.TRUE. + stop_it=0 + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb,ije + IF( ps(ij).LT.0. ) THEN + IF (checksum) stop_it=ij + checksum=.FALSE. + ENDIF + ENDDO +c$OMP END DO NOWAIT + + IF( .NOT. checksum ) THEN + PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. ' + & , ps(stop_it) + print *, ' dans integrd' + stop 1 + ENDIF + +c +C$OMP MASTER + if (pole_nord) THEN + + DO ij = 1, iim + tppn(ij) = aire( ij ) * ps( ij ) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + DO ij = 1, iip1 + ps( ij ) = tpn + ENDDO + + ENDIF + + if (pole_sud) THEN + + DO ij = 1, iim + tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm) + ENDDO + tps = SSUM(iim,tpps,1)/apols + DO ij = 1, iip1 + ps(ij+ip1jm) = tps + ENDDO + + ENDIF +c$OMP END MASTER +c$OMP BARRIER +c +c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ... +c + + CALL pression_p ( ip1jmp1, ap, bp, ps, p ) +c$OMP BARRIER + CALL massdair_p ( p , masse ) + +c CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 ) + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + finvmasse(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1 ) +c + +c ............ integration de ucov, vcov, h .............. + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + uscr( ij ) = ucov( ij,l ) + ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l ) + 4 CONTINUE + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 5 ij = ijb,ije + vscr( ij ) = vcov( ij,l ) + vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l ) + 5 CONTINUE + + ijb=ij_begin + ije=ij_end + + DO 6 ij = ijb,ije + hscr( ij ) = teta(ij,l) + teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l) + $ + dt * dteta(ij,l) / masse(ij,l) + 6 CONTINUE + +c .... Calcul de la valeur moyenne, unique aux poles pour teta ...... +c +c + IF (pole_nord) THEN + + DO ij = 1, iim + tppn(ij) = aire( ij ) * teta( ij ,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + teta( ij ,l) = tpn + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO ij = 1, iim + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta(ij+ip1jm,l) = tps + ENDDO + + ENDIF +c + + IF(leapf) THEN +c CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 ) +c CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 ) +c CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 ) + ijb=ij_begin + ije=ij_end + ucovm1(ijb:ije,l)=uscr(ijb:ije) + tetam1(ijb:ije,l)=hscr(ijb:ije) + if (pole_sud) ije=ij_end-iip1 + vcovm1(ijb:ije,l)=vscr(ijb:ije) + + END IF + + 10 CONTINUE +c$OMP END DO NOWAIT + +c +c ....... integration de q ...... +c + ijb=ij_begin + ije=ij_end + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) +c$OMP BARRIER +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + deltap(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c$OMP BARRIER + + CALL qminimum_p( q, nq, deltap ) +c +c ..... Calcul de la valeur moyenne, unique aux poles pour q ..... +c +c$OMP BARRIER + IF (pole_nord) THEN + + DO iq = 1, nq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij = 1, iim + qppn(ij) = aire( ij ) * q( ij ,l,iq) + ENDDO + qpn = SSUM(iim,qppn,1)/apoln + + DO ij = 1, iip1 + q( ij ,l,iq) = qpn + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO iq = 1, nq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij = 1, iim + qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq) + ENDDO + qps = SSUM(iim,qpps,1)/apols + + DO ij = 1, iip1 + q(ij+ip1jm,l,iq) = qps + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + ENDIF + +c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + endif ! of if (planet_type.eq."earth") + +c +c +c ..... FIN de l'integration de q ....... + +15 continue + +c$OMP DO SCHEDULE(STATIC) + DO ij=ijb,ije + ps0(ij)=ps(ij) + ENDDO +c$OMP END DO NOWAIT + +c ................................................................. + + + IF( leapf ) THEN +c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 ) +c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 ) +c$OMP DO SCHEDULE(STATIC) + DO ij=ijb,ije + psm1(ij)=pscr(ij) + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + massem1(ijb:ije,l)=massescr(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + END IF +c$OMP BARRIER + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inter_barxy_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inter_barxy_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/inter_barxy_m.F90 (revision 1634) @@ -0,0 +1,453 @@ +! +! $Id$ +! +module inter_barxy_m + + ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ + + implicit none + + private + public inter_barxy + +contains + + SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint) + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + + include "dimensions.h" + ! (for "iim", "jjm") + + include "paramet.h" + ! (for other included files) + + include "comgeom2.h" + ! (for "aire", "apoln", "apols") + + REAL, intent(in):: dlonid(:) + ! (longitude from input file, in rad, from -pi to pi) + + REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:) + + REAL, intent(in):: rlatimod(:) + ! (latitude angle, in degrees or rad, in strictly decreasing order) + + real, intent(out):: champint(:, :) + ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les + ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U) + ! Si taille de la seconde dim = jjm, on veut interpoler sur les + ! jjm latitudes rlatv du modele (latitudes de V) + + ! Variables local to the procedure: + + REAL champy(iim, size(champ, 2)) + integer j, i, jnterfd, jmods + + REAL yjmod(size(champint, 2)) + ! (angle, in degrees, in strictly increasing order) + + REAL yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order + LOGICAL decrois ! "dlatid" is in decreasing order + + !----------------------------------- + + jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), & + "inter_barxy jnterfd") + jmods = size(champint, 2) + call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)") + call assert((/size(rlonimod), size(champint, 1)/) == iim, & + "inter_barxy iim") + call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods') + call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)") + + ! Check decreasing order for "rlatimod": + DO i = 2, jjm + IF (rlatimod(i) >= rlatimod(i-1)) stop & + '"inter_barxy": "rlatimod" should be strictly decreasing' + ENDDO + + yjmod(:jjm) = ord_coordm(rlatimod) + IF (jmods == jjm + 1) THEN + IF (90. - yjmod(jjm) < 0.01) stop & + '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.' + ELSE + ! jmods = jjm + IF (ABS(yjmod(jjm) - 90.) > 0.01) stop & + '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.' + ENDIF + + if (jmods == jjm + 1) yjmod(jjm + 1) = 90. + + DO j = 1, jnterfd + 1 + champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod) + ENDDO + + CALL ord_coord(dlatid, yjdat, decrois) + IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1) + DO i = 1, iim + champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod) + ENDDO + champint(:, :) = champint(:, jmods:1:-1) + + IF (jmods == jjm + 1) THEN + ! Valeurs uniques aux poles + champint(:, 1) = SUM(aire(:iim, 1) * champint(:, 1)) / apoln + champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) & + * champint(:, jjm + 1)) / apols + ENDIF + + END SUBROUTINE inter_barxy + + !****************************** + + function inter_barx(dlonid, fdat, rlonimod) + + ! INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES + ! VERSION UNIDIMENSIONNELLE , EN LONGITUDE . + + ! idat : indice du champ de donnees, de 1 a idatmax + ! imod : indice du champ du modele, de 1 a imodmax + ! fdat(idat) : champ de donnees (entrees) + ! inter_barx(imod) : champ du modele (sorties) + ! dlonid(idat): abscisses des interfaces des mailles donnees + ! rlonimod(imod): abscisses des interfaces des mailles modele + ! ( L'indice 1 correspond a l'interface mailLE 1 / maille 2) + ! ( Les abscisses sont exprimees en degres) + + use assert_eq_m, only: assert_eq + + IMPLICIT NONE + + REAL, intent(in):: dlonid(:) + real, intent(in):: fdat(:) + real, intent(in):: rlonimod(:) + + real inter_barx(size(rlonimod)) + + ! ... Variables locales ... + + INTEGER idatmax, imodmax + REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1) + REAL fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1) + REAL xxim(size(rlonimod)) + + REAL x0, xim0, dx, dxm + REAL chmin, chmax, pi + + INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1 + + !----------------------------------------------------- + + idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax") + imodmax = size(rlonimod) + + pi = 2. * ASIN(1.) + + ! REDEFINITION DE L'ORIGINE DES ABSCISSES + ! A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE + DO imod = 1, imodmax + xxim(imod) = rlonimod(imod) + ENDDO + + CALL minmax( imodmax, xxim, chmin, chmax) + IF( chmax.LT.6.50 ) THEN + DO imod = 1, imodmax + xxim(imod) = xxim(imod) * 180./pi + ENDDO + ENDIF + + xim0 = xxim(imodmax) - 360. + + DO imod = 1, imodmax + xxim(imod) = xxim(imod) - xim0 + ENDDO + + idatmax1 = idatmax +1 + + DO idat = 1, idatmax + xxd(idat) = dlonid(idat) + ENDDO + + CALL minmax( idatmax, xxd, chmin, chmax) + IF( chmax.LT.6.50 ) THEN + DO idat = 1, idatmax + xxd(idat) = xxd(idat) * 180./pi + ENDDO + ENDIF + + DO idat = 1, idatmax + xxd(idat) = MOD( xxd(idat) - xim0, 360. ) + fdd(idat) = fdat (idat) + ENDDO + + i = 2 + DO while (xxd(i) >= xxd(i-1) .and. i < idatmax) + i = i + 1 + ENDDO + IF (xxd(i) < xxd(i-1)) THEN + ichang = i + ! *** reorganisation des longitudes entre 0. et 360. degres **** + nid = idatmax - ichang +1 + DO i = 1, nid + xchan (i) = xxd(i+ichang -1 ) + fdchan(i) = fdd(i+ichang -1 ) + ENDDO + DO i=1, ichang -1 + xchan (i+ nid) = xxd(i) + fdchan(i+nid) = fdd(i) + ENDDO + DO i =1, idatmax + xxd(i) = xchan(i) + fdd(i) = fdchan(i) + ENDDO + end IF + + ! translation des champs de donnees par rapport + ! a la nouvelle origine, avec redondance de la + ! maille a cheval sur les bords + + id0 = 0 + id1 = 0 + + DO idat = 1, idatmax + IF ( xxd( idatmax1- idat ).LT.360.) exit + id1 = id1 + 1 + ENDDO + + DO idat = 1, idatmax + IF (xxd(idat).GT.0.) exit + id0 = id0 + 1 + END DO + + IF( id1 /= 0 ) then + DO idat = 1, id1 + xxid(idat) = xxd(idatmax - id1 + idat) - 360. + fxd (idat) = fdd(idatmax - id1 + idat) + END DO + DO idat = 1, idatmax - id1 + xxid(idat + id1) = xxd(idat) + fxd (idat + id1) = fdd(idat) + END DO + end IF + + IF(id0 /= 0) then + DO idat = 1, idatmax - id0 + xxid(idat) = xxd(idat + id0) + fxd (idat) = fdd(idat + id0) + END DO + + DO idat = 1, id0 + xxid (idatmax - id0 + idat) = xxd(idat) + 360. + fxd (idatmax - id0 + idat) = fdd(idat) + END DO + else + DO idat = 1, idatmax + xxid(idat) = xxd(idat) + fxd (idat) = fdd(idat) + ENDDO + end IF + xxid(idatmax1) = xxid(1) + 360. + fxd (idatmax1) = fxd(1) + + ! initialisation du champ du modele + + inter_barx(:) = 0. + + ! iteration + + x0 = xim0 + dxm = 0. + imod = 1 + idat = 1 + + do while (imod <= imodmax) + do while (xxim(imod).GT.xxid(idat)) + dx = xxid(idat) - x0 + dxm = dxm + dx + inter_barx(imod) = inter_barx(imod) + dx * fxd(idat) + x0 = xxid(idat) + idat = idat + 1 + end do + IF (xxim(imod).LT.xxid(idat)) THEN + dx = xxim(imod) - x0 + dxm = dxm + dx + inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + ELSE + dx = xxim(imod) - x0 + dxm = dxm + dx + inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + idat = idat + 1 + END IF + end do + + END function inter_barx + + !****************************** + + function inter_bary(yjdat, fdat, yjmod) + + ! Interpolation barycentrique basée sur les aires. + ! Version unidimensionnelle, en latitude. + ! L'indice 1 correspond à l'interface maille 1 -- maille 2. + + use assert_m, only: assert + + IMPLICIT NONE + + REAL, intent(in):: yjdat(:) + ! (angles, ordonnées des interfaces des mailles des données, in + ! degrees, in increasing order) + + REAL, intent(in):: fdat(:) ! champ de données + + REAL, intent(in):: yjmod(:) + ! (ordonnées des interfaces des mailles du modèle) + ! (in degrees, in strictly increasing order) + + REAL inter_bary(size(yjmod)) ! champ du modèle + + ! Variables local to the procedure: + + REAL y0, dy, dym + INTEGER jdat ! indice du champ de données + integer jmod ! indice du champ du modèle + + !------------------------------------ + + call assert(size(yjdat) == size(fdat), "inter_bary") + + ! Initialisation des variables + inter_bary(:) = 0. + y0 = -90. + dym = 0. + jmod = 1 + jdat = 1 + + do while (jmod <= size(yjmod)) + do while (yjmod(jmod) > yjdat(jdat)) + dy = yjdat(jdat) - y0 + dym = dym + dy + inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat) + y0 = yjdat(jdat) + jdat = jdat + 1 + end do + IF (yjmod(jmod) < yjdat(jdat)) THEN + dy = yjmod(jmod) - y0 + dym = dym + dy + inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + ELSE + ! {yjmod(jmod) == yjdat(jdat)} + dy = yjmod(jmod) - y0 + dym = dym + dy + inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + jdat = jdat + 1 + END IF + end do + ! Le test de fin suppose que l'interface 0 est commune aux deux + ! grilles "yjdat" et "yjmod". + + END function inter_bary + + !****************************** + + SUBROUTINE ord_coord(xi, xo, decrois) + + ! This procedure receives an array of latitudes. + ! It converts them to degrees if they are in radians. + ! If the input latitudes are in decreasing order, the procedure + ! reverses their order. + ! Finally, the procedure adds 90° as the last value of the array. + + use assert_eq_m, only: assert_eq + + IMPLICIT NONE + + include "comconst.h" + ! (for "pi") + + REAL, intent(in):: xi(:) + ! (latitude, in degrees or radians, in increasing or decreasing order) + ! ("xi" should contain latitudes from pole to pole. + ! "xi" should contain the latitudes of the boundaries of grid + ! cells, not the centers of grid cells. + ! So the extreme values should not be 90° and -90°.) + + REAL, intent(out):: xo(:) ! angles in degrees + LOGICAL, intent(out):: decrois + + ! Variables local to the procedure: + INTEGER nmax, i + + !-------------------- + + nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord") + + ! Check monotonicity: + decrois = xi(2) < xi(1) + DO i = 3, nmax + IF (decrois .neqv. xi(i) < xi(i-1)) stop & + '"ord_coord": latitudes are not monotonic' + ENDDO + + IF (abs(xi(1)) < pi) then + ! "xi" contains latitudes in radians + xo(:nmax) = xi(:) * 180. / pi + else + ! "xi" contains latitudes in degrees + xo(:nmax) = xi(:) + end IF + + IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN + print *, "ord_coord" + PRINT *, '"xi" should contain the latitudes of the boundaries of ' & + // 'grid cells, not the centers of grid cells.' + STOP + ENDIF + + IF (decrois) xo(:nmax) = xo(nmax:1:- 1) + xo(nmax + 1) = 90. + + END SUBROUTINE ord_coord + + !*********************************** + + function ord_coordm(xi) + + ! This procedure converts to degrees, if necessary, and inverts the + ! order. + + IMPLICIT NONE + + include "comconst.h" + ! (for "pi") + + REAL, intent(in):: xi(:) ! angle, in rad or degrees + REAL ord_coordm(size(xi)) ! angle, in degrees + + !----------------------------- + + IF (xi(1) < 6.5) THEN + ! "xi" is in rad + ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi + else + ! "xi" is in degrees + ord_coordm(:) = xi(size(xi):1:-1) + ENDIF + + END function ord_coordm + +end module inter_barxy_m Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/interpost.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/interpost.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/interpost.F (revision 1634) @@ -0,0 +1,45 @@ +! +! $Header$ +! + subroutine interpost(q,qppm) + + implicit none + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments + real q(iip1,jjp1,llm) + real qppm(iim,jjp1,llm) +c Local + integer l,i,j + +c RE-INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux de Lin à ceux du LMDZ + + do l=1,llm + do j=1,jjp1 + do i=1,iim + q(i,j,l)=qppm(i,j,llm-l+1) + enddo + enddo + enddo + +c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D + + do l=1,llm + do j=1,jjp1 + q(iip1,j,l)=q(1,j,l) + enddo + enddo + + + return + + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/interpre.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/interpre.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/interpre.F (revision 1634) @@ -0,0 +1,132 @@ +! +! $Id$ +! + subroutine interpre(q,qppm,w,fluxwppm,masse, + s apppm,bpppm,massebx,masseby,pbaru,pbarv, + s unatppm,vnatppm,psppm) + + USE control_mod + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + +c--------------------------------------------------- +c Arguments + real apppm(llm+1),bpppm(llm+1) + real q(iip1,jjp1,llm),qppm(iim,jjp1,llm) +c--------------------------------------------------- + real masse(iip1,jjp1,llm) + real massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + real w(iip1,jjp1,llm+1) + real fluxwppm(iim,jjp1,llm) + real pbaru(iip1,jjp1,llm ) + real pbarv(iip1,jjm,llm) + real unatppm(iim,jjp1,llm) + real vnatppm(iim,jjp1,llm) + real psppm(iim,jjp1) +c--------------------------------------------------- +c Local + real vnat(iip1,jjp1,llm) + real unat(iip1,jjp1,llm) + real fluxw(iip1,jjp1,llm) + real smass(iip1,jjp1) +c---------------------------------------------------- + integer l,ij,i,j + +c CALCUL DE LA PRESSION DE SURFACE +c Les coefficients ap et bp sont passés en common +c Calcul de la pression au sol en mb optimisée pour +c la vectorialisation + + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=0. + enddo + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=smass(i,j)+masse(i,j,l) + enddo + enddo + enddo + + do j=1,jjp1 + do i=1,iim + psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01 + end do + end do + +c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS +c Le programme ppm3d travaille avec les composantes +c de vitesse et pas les flux, on doit donc passer de l'un à l'autre +c Dans le même temps, on fait le changement d'orientation du vent en v + do l=1,llm + do j=1,jjm + do i=1,iip1 + vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j) + enddo + enddo + do i=1,iim + vnat(i,jjp1,l)=0. + enddo + do j=1,jjp1 + do i=1,iip1 + unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j) + enddo + enddo + enddo + +c CALCUL DU FLUX MASSIQUE VERTICAL +c Flux en l=1 (sol) nul + fluxw=0. + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j) +C print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l), +C c 'w(i,j,l)=',w(i,j,l) + enddo + enddo + enddo + +c INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux du LMDZ à ceux de Lin + + do l=1,llm+1 + apppm(l)=ap(llm+2-l) + bpppm(l)=bp(llm+2-l) + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iim + unatppm(i,j,l)=unat(i,j,llm-l+1) + vnatppm(i,j,l)=vnat(i,j,llm-l+1) + fluxwppm(i,j,l)=fluxw(i,j,llm-l+1) + qppm(i,j,l)=q(i,j,llm-l+1) + enddo + enddo + enddo + + return + end + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/invert_lat.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/invert_lat.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/invert_lat.F90 (revision 1634) @@ -0,0 +1,21 @@ + +SUBROUTINE invert_lat(xsize,ysize,vsize,field) + + IMPLICIT NONE + +! Input variables + INTEGER, INTENT(IN) :: xsize,ysize,vsize + REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field +! Local variables + REAL, DIMENSION (xsize,ysize,vsize) :: f_aux + INTEGER :: l,j + + DO l=1,vsize + DO j=1,ysize + f_aux(:,j,l)=field(:,ysize+1-j,l) + END DO + END DO + + field=f_aux + + END SUBROUTINE invert_lat Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ismax.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ismax.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ismax.F (revision 1634) @@ -0,0 +1,24 @@ +! +! $Header$ +! + function ismax(n,sx,incx) +c + IMPLICIT NONE +c + INTEGER n,i,incx,ismax,ix + real sx((n-1)*incx+1),sxmax +c + ix=1 + ismax=1 + sxmax=sx(1) + do 10 i=1,n-1 + ix=ix+incx + if(sx(ix).gt.sxmax) then + sxmax=sx(ix) + ismax=i+1 + endif +10 continue +c + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ismin.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ismin.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ismin.F (revision 1634) @@ -0,0 +1,24 @@ +! +! $Header$ +! + FUNCTION ismin(n,sx,incx) +c + IMPLICIT NONE +c + integer n,i,incx,ismin,ix + real sx((n-1)*incx+1),sxmin +c + ix=1 + ismin=1 + sxmin=sx(1) + DO i=1,n-1 + ix=ix+incx + if(sx(ix).lt.sxmin) then + sxmin=sx(ix) + ismin=i+1 + endif + ENDDO +c + return + end +C Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/juldate.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/juldate.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/juldate.F (revision 1634) @@ -0,0 +1,33 @@ +! +! $Header$ +! + subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec) +c Sous-routine de changement de date: +c gregorien>>>date julienne +c En entree:an,mois,jour,heure,min.,sec. +c En sortie:tjd + implicit real (a-h,o-z) + frac=((os/60.+om)/60.+oh)/24. + ojou=dfloat(ijou)+frac + year=dfloat(ian) + rmon=dfloat(imoi) + if (imoi .le. 2) then + year=year-1. + rmon=rmon+12. + endif + cf=year+(rmon/100.)+(ojou/10000.) + if (cf .ge. 1582.1015) then + a=int(year/100) + b=2-a+int(a/4) + else + b=0 + endif + tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou) + + +1720994.5+b + tjdsec=(ojou-int(ojou))+(tjd-int(tjd)) + tjd=int(tjd)+int(tjdsec) + tjdsec=tjdsec-int(tjdsec) + return + end + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien.F (revision 1634) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE laplacien ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + +c + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + CALL filtreg( divgra, jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel,divgra, ghx , ghy ) + CALL divergf ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_gam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_gam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_gam.F (revision 1634) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) +c + CALL grad ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_gam_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_gam_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_gam_p.F (revision 1634) @@ -0,0 +1,65 @@ + SUBROUTINE laplacien_gam_p ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + + INTEGER :: ijb,ije + INTEGER :: l +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL grad_p ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam_p ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_p.F (revision 1634) @@ -0,0 +1,56 @@ + SUBROUTINE laplacien_p ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + INTEGER :: l +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + + INTEGER :: ijb,ije,jjb,jje +c +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud ) jje=jj_end + + CALL filtreg_p( divgra,jjb,jje,jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad_p ( klevel,divgra, ghx , ghy ) + CALL divergf_p ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rot.F (revision 1634) @@ -0,0 +1,39 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + CALL filtreg ( rotin , jjm, klevel, 2, 1, .FALSE., 1 ) + + CALL nxgrad ( klevel, rotin, ghx , ghy ) + CALL rotatf ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rot_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rot_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rot_p.F (revision 1634) @@ -0,0 +1,45 @@ + SUBROUTINE laplacien_rot_p ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + INTEGER :: ijb,ije,jjb,jje + + jjb=jj_begin-1 + jje=jj_end+1 + + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p ( rotin ,jjb,jje,jjm, klevel,2, 1, .FALSE., 1) + + CALL nxgrad_p ( klevel, rotin, ghx , ghy ) + CALL rotatf_p ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rotgam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rotgam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rotgam.F (revision 1634) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c +c + + CALL nxgrad_gam ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil ( klevel, ghx , ghy , rotout ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rotgam_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rotgam_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/laplacien_rotgam_p.F (revision 1634) @@ -0,0 +1,48 @@ + SUBROUTINE laplacien_rotgam_p ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c + INTEGER :: ijb,ije + +c + + CALL nxgrad_gam_p ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil_p ( klevel, ghx , ghy , rotout ) +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/leapfrog_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/leapfrog_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/leapfrog_p.F (revision 1634) @@ -0,0 +1,1724 @@ +! +! $Id$ +! +c +c + + SUBROUTINE leapfrog_p(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + & time_0) + + USE misc_mod + USE parallel + USE times + USE mod_hallo + USE Bands + USE Write_Field + USE Write_Field_p + USE vampir + USE timer_filtre, ONLY : print_filtre_timer + USE infotrac + USE guide_p_mod, ONLY : guide_main + USE getparam + USE control_mod + + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. + +c ... Possibilite de choisir le shema pour l'advection de +c q , en modifiant iadv dans traceur.def (10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +!#include "com_io_dyn.h" +#include "iniprint.h" +#include "academic.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + real zqmin,zqmax + INTEGER nbetatmoy, nbetatdem,nbetat + +c variables dynamiques + REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL :: teta(ip1jmp1,llm) ! temperature potentielle + REAL :: q(ip1jmp1,llm,nqtot) ! champs advectes + REAL :: ps(ip1jmp1) ! pression au sol + REAL,SAVE :: p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL,SAVE :: pks(ip1jmp1) ! exner au sol + REAL,SAVE :: pk(ip1jmp1,llm) ! exner au milieu des couches + REAL,SAVE :: pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL :: masse(ip1jmp1,llm) ! masse d'air + REAL :: phis(ip1jmp1) ! geopotentiel au sol + REAL,SAVE :: phi(ip1jmp1,llm) ! geopotentiel + REAL,SAVE :: w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + REAL,SAVE :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse + +c variables dynamiques au pas -1 + REAL,SAVE :: vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL,SAVE :: tetam1(ip1jmp1,llm),psm1(ip1jmp1) + REAL,SAVE :: massem1(ip1jmp1,llm) + +c tendances dynamiques + REAL,SAVE :: dv(ip1jm,llm),du(ip1jmp1,llm) + REAL,SAVE :: dteta(ip1jmp1,llm),dp(ip1jmp1) + REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq + +c tendances de la dissipation + REAL,SAVE :: dvdis(ip1jm,llm),dudis(ip1jmp1,llm) + REAL,SAVE :: dtetadis(ip1jmp1,llm) + +c tendances physiques + REAL,SAVE :: dvfi(ip1jm,llm),dufi(ip1jmp1,llm) + REAL,SAVE :: dtetafi(ip1jmp1,llm) + REAL,SAVE :: dpfi(ip1jmp1) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL tppn(iim),tpps(iim),tpn,tps +c + INTEGER itau,itaufinp1,iav +! INTEGER iday ! jour julien + REAL time + + REAL SSUM + REAL time_0 + REAL,SAVE :: finvmaold(ip1jmp1,llm) + +cym LOGICAL lafin + LOGICAL :: lafin + INTEGER ij,iq,l + INTEGER ik + + real time_step, t_wrt, t_ops + +! jD_cur: jour julien courant +! jH_cur: heure julienne courante + REAL :: jD_cur, jH_cur + INTEGER :: an, mois, jour + REAL :: secondes + + LOGICAL first,callinigrads + + data callinigrads/.true./ + character*10 string10 + + REAL,SAVE :: alpha(ip1jmp1,llm),beta(ip1jmp1,llm) + REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale + +c+jld variables test conservation energie + REAL,SAVE :: ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation + REAL,SAVE :: dtetaecdt(ip1jmp1,llm) + REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL,SAVE :: vnat(ip1jm,llm),unat(ip1jmp1,llm) + REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER*15 ztit +! INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. +! SAVE ip_ebil_dyn +! DATA ip_ebil_dyn/0/ +c-jld + + character*80 dynhist_file, dynhistave_file + character(len=*),parameter :: modname="leapfrog" + character*80 abort_message + + + logical,PARAMETER :: dissip_conservative=.TRUE. + + INTEGER testita + PARAMETER (testita = 9) + + logical , parameter :: flag_verif = .false. + +c declaration liees au parallelisme + INTEGER :: ierr + LOGICAL :: FirstCaldyn + LOGICAL :: FirstPhysic + INTEGER :: ijb,ije,j,i + type(Request) :: TestRequest + type(Request) :: Request_Dissip + type(Request) :: Request_physic + REAL,SAVE :: dvfi_tmp(iip1,llm),dufi_tmp(iip1,llm) + REAL,SAVE :: dtetafi_tmp(iip1,llm) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi_tmp + REAL,SAVE :: dpfi_tmp(iip1) + + INTEGER :: true_itau + LOGICAL :: verbose=.true. + INTEGER :: iapptrac + INTEGER :: AdjustCount +! INTEGER :: var_time + LOGICAL :: ok_start_timer=.FALSE. + LOGICAL, SAVE :: firstcall=.TRUE. + +c$OMP MASTER + ItCount=0 +c$OMP END MASTER + true_itau=0 + FirstCaldyn=.TRUE. + FirstPhysic=.TRUE. + iapptrac=0 + AdjustCount = 0 + lafin=.false. + + itaufin = nday*day_step + itaufinp1 = itaufin +1 + + itau = 0 +! iday = day_ini+itau/day_step +! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + +c Allocate variables depending on dynamic variable nqtot +c$OMP MASTER + IF (firstcall) THEN + firstcall=.FALSE. + ALLOCATE(dq(ip1jmp1,llm,nqtot)) + ALLOCATE(dqfi(ip1jmp1,llm,nqtot)) + ALLOCATE(dqfi_tmp(iip1,llm,nqtot)) + END IF +c$OMP END MASTER +c$OMP BARRIER + +c----------------------------------------------------------------------- +c On initialise la pression et la fonction d'Exner : +c -------------------------------------------------- + +c$OMP MASTER + dq(:,:,:)=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p, beta, pks, pk, pkf ) + endif +c$OMP END MASTER +c----------------------------------------------------------------------- +c Debut de l'integration temporelle: +c ---------------------------------- +c et du parallelisme !! + + 1 CONTINUE + + jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) + + +#ifdef CPP_IOIPSL + if (ok_guide) then +!$OMP MASTER + call guide_main(itau,ucov,vcov,teta,q,masse,ps) +!$OMP END MASTER +!$OMP BARRIER + endif +#endif + +c +c IF( MOD( itau, 10* day_step ).EQ.0 ) THEN +c CALL test_period ( ucov,vcov,teta,q,p,phis ) +c PRINT *,' ---- Test_period apres continue OK ! -----', itau +c ENDIF +c +cym CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) +cym CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) +cym CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) +cym CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) +cym CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) + + if (FirstCaldyn) then +c$OMP MASTER + ucovm1=ucov + vcovm1=vcov + tetam1= teta + massem1= masse + psm1= ps + + finvmaold = masse + CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) +c$OMP END MASTER +c$OMP BARRIER + else +! Save fields obtained at previous time step as '...m1' + ijb=ij_begin + ije=ij_end + +c$OMP MASTER + psm1 (ijb:ije) = ps (ijb:ije) +c$OMP END MASTER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + ije=ij_end + ucovm1 (ijb:ije,l) = ucov (ijb:ije,l) + tetam1 (ijb:ije,l) = teta (ijb:ije,l) + massem1 (ijb:ije,l) = masse (ijb:ije,l) + finvmaold(ijb:ije,l)=masse(ijb:ije,l) + + if (pole_sud) ije=ij_end-iip1 + vcovm1(ijb:ije,l) = vcov (ijb:ije,l) + + + ENDDO +c$OMP ENDDO + + + CALL filtreg_p ( finvmaold ,jj_begin,jj_end,jjp1, + . llm, -2,2, .TRUE., 1 ) + + endif ! of if (FirstCaldyn) + + forward = .TRUE. + leapf = .FALSE. + dt = dtvr + +c ... P.Le Van .26/04/94 .... + +cym CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) +cym CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) + +cym ne sert a rien +cym call minmax(ijp1llm,q(:,:,3),zqmin,zqmax) + + 2 CONTINUE + +c$OMP MASTER + ItCount=ItCount+1 + if (MOD(ItCount,1)==1) then + debug=.true. + else + debug=.false. + endif +c$OMP END MASTER +c----------------------------------------------------------------------- + +c date: +c ----- + + +c gestion des appels de la physique et des dissipations: +c ------------------------------------------------------ +c +c ... P.Le Van ( 6/02/95 ) .... + + apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + apdiss = .FALSE. + + IF( purmats ) THEN + ! Purely Matsuno time stepping + IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. + IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) + s apdiss = .TRUE. + IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward + s .and. iflag_phys.EQ.1 ) apphys = .TRUE. + ELSE + ! Leapfrog/Matsuno time stepping + IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. + IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) + s apdiss = .TRUE. + IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.EQ.1) apphys=.TRUE. + END IF + +! Ehouarn: for Shallow Water case (ie: 1 vertical layer), +! supress dissipation step + if (llm.eq.1) then + apdiss=.false. + endif + +cym ---> Pour le moment +cym apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. ! ie: no output of control variables to stdout in // + + if (firstCaldyn) then +c$OMP MASTER + call SetDistrib(jj_Nb_Caldyn) +c$OMP END MASTER +c$OMP BARRIER + firstCaldyn=.FALSE. +cym call InitTime +c$OMP MASTER + call Init_timer +c$OMP END MASTER + endif + +c$OMP MASTER + IF (ok_start_timer) THEN + CALL InitTime + ok_start_timer=.FALSE. + ENDIF +c$OMP END MASTER + + if (Adjust) then +c$OMP MASTER + AdjustCount=AdjustCount+1 + if (iapptrac==iapp_tracvl .and. (forward. OR . leapf) + & .and. itau/iphysiq>2 .and. Adjustcount>30) then + AdjustCount=0 + call allgather_timer_average + + if (Verbose) then + + print *,'*********************************' + print *,'****** TIMER CALDYN ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i), + & ' : temps moyen :', + & timer_average(jj_nb_caldyn(i),timer_caldyn,i), + & '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i) + enddo + + print *,'*********************************' + print *,'****** TIMER VANLEER ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i), + & ' : temps moyen :', + & timer_average(jj_nb_vanleer(i),timer_vanleer,i), + & '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i) + enddo + + print *,'*********************************' + print *,'****** TIMER DISSIP ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i), + & ' : temps moyen :', + & timer_average(jj_nb_dissip(i),timer_dissip,i), + & '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i) + enddo + + if (mpi_rank==0) call WriteBands + + endif + + call AdjustBands_caldyn + if (mpi_rank==0) call WriteBands + + call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(ps,ps,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(pks,pks,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(phis,phis,ip1jmp1,1, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm, + & jj_Nb_caldyn,0,0,TestRequest) + + do j=1,nqtot + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, + & jj_nb_caldyn,0,0,TestRequest) + enddo + + call SetDistrib(jj_nb_caldyn) + call SendRequest(TestRequest) + call WaitRequest(TestRequest) + + call AdjustBands_dissip + call AdjustBands_physic + + endif +c$OMP END MASTER + endif + + + +c----------------------------------------------------------------------- +c calcul des tendances dynamiques: +c -------------------------------- +c$OMP BARRIER +c$OMP MASTER + call VTb(VThallo) +c$OMP END MASTER + + call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,TestRequest) + call Register_Hallo(teta,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(ps,ip1jmp1,1,1,2,2,1,TestRequest) + call Register_Hallo(pkf,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(pk,ip1jmp1,llm,1,1,1,1,TestRequest) + call Register_Hallo(pks,ip1jmp1,1,1,1,1,1,TestRequest) + call Register_Hallo(p,ip1jmp1,llmp1,1,1,1,1,TestRequest) + +c do j=1,nqtot +c call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1, +c * TestRequest) +c enddo + + call SendRequest(TestRequest) +c$OMP BARRIER + call WaitRequest(TestRequest) + +c$OMP MASTER + call VTe(VThallo) +c$OMP END MASTER +c$OMP BARRIER + + if (debug) then +!$OMP BARRIER +!$OMP MASTER + call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/))) + call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/))) + call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/))) + call WriteField_p('ps',reshape(ps,(/iip1,jmp1/))) + call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/))) + call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/))) + call WriteField_p('pks',reshape(pks,(/iip1,jmp1/))) + call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/))) + call WriteField_p('phis',reshape(phis,(/iip1,jmp1/))) + do j=1,nqtot + call WriteField_p('q'//trim(int2str(j)), + . reshape(q(:,:,j),(/iip1,jmp1,llm/))) + enddo +!$OMP END MASTER +c$OMP BARRIER + endif + + + True_itau=True_itau+1 + +c$OMP MASTER + IF (prt_level>9) THEN + WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau + ENDIF + + + call start_timer(timer_caldyn) + + CALL geopot_p ( ip1jmp1, teta , pk , pks, phis , phi ) + + + call VTb(VTcaldyn) +c$OMP END MASTER +! var_time=time+iday-day_ini + +c$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("caldyn") + time = jD_cur + jH_cur + CALL caldyn_p + $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time ) + +! CALL FTRACE_REGION_END("caldyn") + +c$OMP MASTER + call VTe(VTcaldyn) +c$OMP END MASTER + +cc$OMP BARRIER +cc$OMP MASTER +! call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/))) +! call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/))) +! call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/))) +! call WriteField_p('dp',reshape(dp,(/iip1,jmp1/))) +! call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/))) +! call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/))) +! call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/))) +! call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/))) +! call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/))) +! call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/))) +cc$OMP END MASTER + +c----------------------------------------------------------------------- +c calcul des tendances advection des traceurs (dont l'humidite) +c ------------------------------------------------------------- + + IF( forward. OR . leapf ) THEN +cc$OMP PARALLEL DEFAULT(SHARED) +c + CALL caladvtrac_p(q,pbaru,pbarv, + * p, masse, dq, teta, + . flxw,pk, iapptrac) + +C Stokage du flux de masse pour traceurs OFF-LINE + IF (offline .AND. .NOT. adjust) THEN + CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis, + . dtvr, itau) + ENDIF + + ENDIF ! of IF( forward. OR . leapf ) +cc$OMP END PARALLEL + +c----------------------------------------------------------------------- +c integrations dynamique et traceurs: +c ---------------------------------- + +c$OMP MASTER + call VTb(VTintegre) +c$OMP END MASTER +c call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/))) +c call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/))) +c call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/))) +c call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/))) +c call WriteField_p('ps',reshape(ps,(/iip1,jmp1/))) +cc$OMP PARALLEL DEFAULT(SHARED) +c$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("integrd") + + CALL integrd_p ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 , + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis , + $ finvmaold ) + +! CALL FTRACE_REGION_END("integrd") +c$OMP BARRIER +cc$OMP MASTER +c call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/))) +c call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/))) +c call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/))) +c call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/))) +c call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/))) +c +c call WriteField_p('ps',reshape(ps,(/iip1,jmp1/))) +c do j=1,nqtot +c call WriteField_p('q'//trim(int2str(j)), +c . reshape(q(:,:,j),(/iip1,jmp1,llm/))) +c call WriteField_p('dq'//trim(int2str(j)), +c . reshape(dq(:,:,j),(/iip1,jmp1,llm/))) +c enddo +cc$OMP END MASTER + + +c$OMP MASTER + call VTe(VTintegre) +c$OMP END MASTER +c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) +c +c----------------------------------------------------------------------- +c calcul des tendances physiques: +c ------------------------------- +c ######## P.Le Van ( Modif le 6/02/95 ) ########### +c + IF( purmats ) THEN + IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. + ELSE + IF( itau+1. EQ. itaufin ) lafin = .TRUE. + ENDIF + +cc$OMP END PARALLEL + +c +c + IF( apphys ) THEN +c +c ....... Ajout P.Le Van ( 17/04/96 ) ........... +c +cc$OMP PARALLEL DEFAULT(SHARED) +cc$OMP+ PRIVATE(rdaym_ini,rdayvrai,ijb,ije) + +c$OMP MASTER + call suspend_timer(timer_caldyn) + + if (prt_level >= 10) then + write(lunout,*) + & 'leapfrog_p: Entree dans la physique : Iteration No ',true_itau + endif +c$OMP END MASTER + + CALL pression_p ( ip1jmp1, ap, bp, ps, p ) + +c$OMP BARRIER + if (disvert_type==1) then + CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta,pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf ) + endif +c$OMP BARRIER + jD_cur = jD_ref + day_ini - day_ref + $ + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) +! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes) + +c rajout debug +c lafin = .true. + + +c Inbterface avec les routines de phylmd (phymars ... ) +c ----------------------------------------------------- + +c+jld + +c Diagnostique de conservation de l'energie : initialisation + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil dyn' +! Ehouarn: be careful, diagedyn is Earth-specific (includes ../phylmd/..)! + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys + & , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF +c-jld +c$OMP BARRIER +c$OMP MASTER + call VTb(VThallo) +c$OMP END MASTER + + call SetTag(Request_physic,800) + + call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm, + * jj_Nb_physic,1,2,Request_physic) + + call Register_SwapFieldHallo(p,p,ip1jmp1,llmp1, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(phis,phis,ip1jmp1,1, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call Register_SwapFieldHallo(w,w,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + +c call SetDistrib(jj_nb_vanleer) + do j=1,nqtot + + call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + enddo + + call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm, + * jj_Nb_physic,2,2,Request_physic) + + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_nb_Physic) + call VTe(VThallo) + + call VTb(VTphysiq) +c$OMP END MASTER +c$OMP BARRIER + +cc$OMP MASTER +c call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/))) +c call WriteField_p('pfi',reshape(p,(/iip1,jmp1,llmp1/))) +c call WriteField_p('pkfi',reshape(pk,(/iip1,jmp1,llm/))) +cc$OMP END MASTER +cc$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("calfis") + CALL calfis_p(lafin ,jD_cur, jH_cur, + $ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , + $ du,dv,dteta,dq, + $ flxw, + $ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) +! CALL FTRACE_REGION_END("calfis") + ijb=ij_begin + ije=ij_end + if ( .not. pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l) + dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l) + dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) + dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim) +c$OMP END MASTER + endif ! of if ( .not. pole_nord) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_nb_Physic_bis) + + call VTb(VThallo) +c$OMP END MASTER +c$OMP BARRIER + + call Register_Hallo(dufi,ip1jmp1,llm, + * 1,0,0,1,Request_physic) + + call Register_Hallo(dvfi,ip1jm,llm, + * 1,0,0,1,Request_physic) + + call Register_Hallo(dtetafi,ip1jmp1,llm, + * 1,0,0,1,Request_physic) + + call Register_Hallo(dpfi,ip1jmp1,1, + * 1,0,0,1,Request_physic) + + do j=1,nqtot + call Register_Hallo(dqfi(1,1,j),ip1jmp1,llm, + * 1,0,0,1,Request_physic) + enddo + + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + +c$OMP BARRIER +c$OMP MASTER + call VTe(VThallo) + + call SetDistrib(jj_nb_Physic) +c$OMP END MASTER +c$OMP BARRIER + ijb=ij_begin + if (.not. pole_nord) then + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l) + dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) + dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l) + & +dtetafi_tmp(1:iip1,l) + dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + & + dqfi_tmp(1:iip1,l,:) + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1) +c$OMP END MASTER + + endif ! of if (.not. pole_nord) +c$OMP BARRIER +cc$OMP MASTER +c call WriteField_p('dufi',reshape(dufi,(/iip1,jmp1,llm/))) +c call WriteField_p('dvfi',reshape(dvfi,(/iip1,jjm,llm/))) +c call WriteField_p('dtetafi',reshape(dtetafi,(/iip1,jmp1,llm/))) +c call WriteField_p('dpfi',reshape(dpfi,(/iip1,jmp1/))) +cc$OMP END MASTER +c +c do j=1,nqtot +c call WriteField_p('dqfi'//trim(int2str(j)), +c . reshape(dqfi(:,:,j),(/iip1,jmp1,llm/))) +c enddo + +c ajout des tendances physiques: +c ------------------------------ + IF (ok_strato) THEN + CALL top_bound_p( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + ENDIF + + CALL addfi_p( dtphys, leapf, forward , + $ ucov, vcov, teta , q ,ps , + $ dufi, dvfi, dtetafi , dqfi ,dpfi ) + +c$OMP BARRIER +c$OMP MASTER + call VTe(VTphysiq) + + call VTb(VThallo) +c$OMP END MASTER + + call SetTag(Request_physic,800) + call Register_SwapField(ucov,ucov,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(vcov,vcov,ip1jm,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(teta,teta,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(masse,masse,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(p,p,ip1jmp1,llmp1, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(pk,pk,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(phis,phis,ip1jmp1,1, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(phi,phi,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + call Register_SwapField(w,w,ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + do j=1,nqtot + + call Register_SwapField(q(1,1,j),q(1,1,j),ip1jmp1,llm, + * jj_Nb_caldyn,Request_physic) + + enddo + + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + +c$OMP BARRIER +c$OMP MASTER + call VTe(VThallo) + call SetDistrib(jj_Nb_caldyn) +c$OMP END MASTER +c$OMP BARRIER +c +c Diagnostique de conservation de l'energie : difference + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil phys' + CALL diagedyn(ztit,2,1,1,dtphys + e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + +cc$OMP MASTER +c if (debug) then +c call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/))) +c call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/))) +c call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/))) +c endif +cc$OMP END MASTER + + +c-jld +c$OMP MASTER + call resume_timer(timer_caldyn) + if (FirstPhysic) then + ok_start_timer=.TRUE. + FirstPhysic=.false. + endif +c$OMP END MASTER + ENDIF ! of IF( apphys ) + + IF(iflag_phys.EQ.2) THEN ! "Newtonian" case +! Academic case : Simple friction and Newtonan relaxation +! ------------------------------------------------------- + ijb=ij_begin + ije=ij_end +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + teta(ijb:ije,l)=teta(ijb:ije,l)-dtvr* + & (teta(ijb:ije,l)-tetarappel(ijb:ije,l))* + & (knewt_g+knewt_t(l)*clat4(ijb:ije)) + enddo ! of do l=1,llm +!$OMP END DO + +!$OMP MASTER + if (planet_type.eq."giant") then + ! add an intrinsic heat flux at the base of the atmosphere + teta(ijb:ije,1) = teta(ijb:ije,1) + & + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1) + endif +!$OMP END MASTER +!$OMP BARRIER + + call Register_Hallo(ucov,ip1jmp1,llm,0,1,1,0,Request_Physic) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Physic) + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) +c$OMP BARRIER + call friction_p(ucov,vcov,dtvr) +!$OMP BARRIER + + ! Sponge layer (if any) + IF (ok_strato) THEN + ! set dufi,dvfi,... to zero + ijb=ij_begin + ije=ij_end +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + dufi(ijb:ije,l)=0 + dtetafi(ijb:ije,l)=0 + dqfi(ijb:ije,l,1:nqtot)=0 + enddo +!$OMP END DO +!$OMP MASTER + dpfi(ijb:ije)=0 +!$OMP END MASTER + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ije-iip1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + dvfi(ijb:ije,l)=0 + enddo +!$OMP END DO + + CALL top_bound_p(vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + CALL addfi_p( dtvr, leapf, forward , + $ ucov, vcov, teta , q ,ps , + $ dufi, dvfi, dtetafi , dqfi ,dpfi ) +!$OMP BARRIER + ENDIF ! of IF (ok_strato) + ENDIF ! of IF(iflag_phys.EQ.2) + + + CALL pression_p ( ip1jmp1, ap, bp, ps, p ) +c$OMP BARRIER + if (disvert_type==1) then + CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu_p( ip1jmp1, ps, p, beta, pks, pk, pkf ) + endif +c$OMP BARRIER + +cc$OMP END PARALLEL + +c----------------------------------------------------------------------- +c dissipation horizontale et verticale des petites echelles: +c ---------------------------------------------------------- + + IF(apdiss) THEN +cc$OMP PARALLEL DEFAULT(SHARED) +cc$OMP+ PRIVATE(ijb,ije,tppn,tpn,tpps,tps) +c$OMP MASTER + call suspend_timer(timer_caldyn) + +c print*,'Entree dans la dissipation : Iteration No ',true_itau +c calcul de l'energie cinetique avant dissipation +c print *,'Passage dans la dissipation' + + call VTb(VThallo) +c$OMP END MASTER + +c$OMP BARRIER + + call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm, + * jj_Nb_dissip,1,1,Request_dissip) + + call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm, + * jj_Nb_dissip,1,1,Request_dissip) + + call Register_SwapField(teta,teta,ip1jmp1,llm, + * jj_Nb_dissip,Request_dissip) + + call Register_SwapField(p,p,ip1jmp1,llmp1, + * jj_Nb_dissip,Request_dissip) + + call Register_SwapField(pk,pk,ip1jmp1,llm, + * jj_Nb_dissip,Request_dissip) + + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_Nb_dissip) + call VTe(VThallo) + call VTb(VTdissipation) + call start_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + call covcont_p(llm,ucov,vcov,ucont,vcont) + call enercin_p(vcov,ucov,vcont,ucont,ecin0) + +c dissipation + +! CALL FTRACE_REGION_BEGIN("dissip") + CALL dissip_p(vcov,ucov,teta,p,dvdis,dudis,dtetadis) +! CALL FTRACE_REGION_END("dissip") + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + if (pole_sud) ije=ije-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c teta=teta+dtetadis + + +c------------------------------------------------------------------------ + if (dissip_conservative) then +C On rajoute la tendance due a la transform. Ec -> E therm. cree +C lors de la dissipation +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call VTb(VThallo) +c$OMP END MASTER + call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Request_Dissip) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Dissip) + call SendRequest(Request_Dissip) +c$OMP BARRIER + call WaitRequest(Request_Dissip) +c$OMP MASTER + call VTe(VThallo) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + call covcont_p(llm,ucov,vcov,ucont,vcont) + call enercin_p(vcov,ucov,vcont,ucont,ecin) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do ij=ijb,ije + dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l) + dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l) + enddo + enddo +c$OMP END DO NOWAIT + endif ! of if (dissip_conservative) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do ij=ijb,ije + teta(ij,l)=teta(ij,l)+dtetadis(ij,l) + enddo + enddo +c$OMP END DO NOWAIT +c------------------------------------------------------------------------ + + +c ....... P. Le Van ( ajout le 17/04/96 ) ........... +c ... Calcul de la valeur moyenne, unique de h aux poles ..... +c + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tppn(ij) = aire( ij ) * teta( ij ,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + teta( ij ,l) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij = 1,iim + tppn(ij) = aire( ij ) * ps ( ij ) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + ps( ij ) = tpn + ENDDO +c$OMP END MASTER + endif + + if (pole_sud) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta(ij+ip1jm,l) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + ps(ij+ip1jm) = tps + ENDDO +c$OMP END MASTER + endif + + +c$OMP BARRIER +c$OMP MASTER + call VTe(VTdissipation) + + call stop_timer(timer_dissip) + + call VTb(VThallo) +c$OMP END MASTER + call Register_SwapField(ucov,ucov,ip1jmp1,llm, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(vcov,vcov,ip1jm,llm, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(teta,teta,ip1jmp1,llm, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(p,p,ip1jmp1,llmp1, + * jj_Nb_caldyn,Request_dissip) + + call Register_SwapField(pk,pk,ip1jmp1,llm, + * jj_Nb_caldyn,Request_dissip) + + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER +c$OMP MASTER + call SetDistrib(jj_Nb_caldyn) + call VTe(VThallo) + call resume_timer(timer_caldyn) +c print *,'fin dissipation' +c$OMP END MASTER +c$OMP BARRIER + END IF ! of IF(apdiss) + +cc$OMP END PARALLEL + +c ajout debug +c IF( lafin ) then +c abort_message = 'Simulation finished' +c call abort_gcm(modname,abort_message,0) +c ENDIF + +c ******************************************************************** +c ******************************************************************** +c .... fin de l'integration dynamique et physique pour le pas itau .. +c ******************************************************************** +c ******************************************************************** + +c preparation du pas d'integration suivant ...... +cym call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +cym call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/))) +c$OMP MASTER + call stop_timer(timer_caldyn) +c$OMP END MASTER + IF (itau==itaumax) then +c$OMP MASTER + call allgather_timer_average + + if (mpi_rank==0) then + + print *,'*********************************' + print *,'****** TIMER CALDYN ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i), + & ' : temps moyen :', + & timer_average(jj_nb_caldyn(i),timer_caldyn,i) + enddo + + print *,'*********************************' + print *,'****** TIMER VANLEER ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i), + & ' : temps moyen :', + & timer_average(jj_nb_vanleer(i),timer_vanleer,i) + enddo + + print *,'*********************************' + print *,'****** TIMER DISSIP ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i), + & ' : temps moyen :', + & timer_average(jj_nb_dissip(i),timer_dissip,i) + enddo + + print *,'*********************************' + print *,'****** TIMER PHYSIC ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_physic(i), + & ' : temps moyen :', + & timer_average(jj_nb_physic(i),timer_physic,i) + enddo + + endif + + print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize + print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used + print *, 'Temps total ecoule sur la parallelisation :',DiffTime() + print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime() + CALL print_filtre_timer + call fin_getparam + call finalize_parallel +c$OMP END MASTER +c$OMP BARRIER + RETURN + ENDIF + + IF ( .NOT.purmats ) THEN +c ........................................................ +c .............. schema matsuno + leapfrog .............. +c ........................................................ + + IF(forward. OR. leapf) THEN + itau= itau + 1 +! iday= day_ini+itau/day_step +! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + ENDIF + + + IF( itau. EQ. itaufinp1 ) then + + if (flag_verif) then + write(79,*) 'ucov',ucov + write(80,*) 'vcov',vcov + write(81,*) 'teta',teta + write(82,*) 'ps',ps + write(83,*) 'q',q + WRITE(85,*) 'q1 = ',q(:,:,1) + WRITE(86,*) 'q3 = ',q(:,:,3) + endif + + +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + RETURN + ENDIF +c----------------------------------------------------------------------- +c ecriture du fichier histoire moyenne: +c ------------------------------------- + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN +c$OMP BARRIER + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF +#ifdef CPP_IOIPSL + IF (ok_dynzon) THEN + call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest) + call SendRequest(TestRequest) +c$OMP BARRIER + call WaitRequest(TestRequest) +c$OMP BARRIER +c$OMP MASTER +! CALL writedynav_p(histaveid, itau,vcov , +! , ucov,teta,pk,phi,q,masse,ps,phis) + +c ATTENTION!!! bilan_dyn_p ne marche probablement pas avec OpenMP + CALL bilan_dyn_p(2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +c$OMP END MASTER + ENDIF !ok_dynzon +#endif + IF (ok_dyn_ave) THEN +!$OMP MASTER +#ifdef CPP_IOIPSL +! Ehouarn: Gather fields and make master send to output + call Gather_Field(vcov,ip1jm,llm,0) + call Gather_Field(ucov,ip1jmp1,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(pk,ip1jmp1,llm,0) + call Gather_Field(phi,ip1jmp1,llm,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + call Gather_Field(masse,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + call Gather_Field(phis,ip1jmp1,1,0) + if (mpi_rank==0) then + CALL writedynav(itau,vcov, + & ucov,teta,pk,phi,q,masse,ps,phis) + endif +#endif +!$OMP END MASTER + ENDIF ! of IF (ok_dyn_ave) + ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin)) + +c----------------------------------------------------------------------- +c ecriture de la bande histoire: +c ------------------------------ + + IF( MOD(itau,iecri).EQ.0) THEN + ! Ehouarn: output only during LF or Backward Matsuno + if (leapf.or.(.not.leapf.and.(.not.forward))) then +c$OMP BARRIER +c$OMP MASTER + nbetat = nbetatdem + CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi) + +cym unat=0. + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + ijb=ij_begin+iip1 + unat(1:iip1,:)=0. + endif + + if (pole_sud) then + ije=ij_end-iip1 + unat(ij_end-iip1+1:ij_end,:)=0. + endif + + do l=1,llm + unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije) + enddo + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + do l=1,llm + vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije) + enddo + +#ifdef CPP_IOIPSL + if (ok_dyn_ins) then +! Ehouarn: Gather fields and make master write to output + call Gather_Field(vcov,ip1jm,llm,0) + call Gather_Field(ucov,ip1jmp1,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(phi,ip1jmp1,llm,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + call Gather_Field(masse,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + call Gather_Field(phis,ip1jmp1,1,0) + if (mpi_rank==0) then + CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) + endif +! CALL writehist_p(histid,histvid, itau,vcov, +! & ucov,teta,phi,q,masse,ps,phis) +! or use writefield_p +! call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +! call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/))) +! call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/))) +! call WriteField_p('ps',reshape(ps,(/iip1,jmp1/))) + endif ! of if (ok_dyn_ins) +#endif +! For some Grads outputs of fields + if (output_grads_dyn) then +! Ehouarn: hope this works the way I think it does: + call Gather_Field(unat,ip1jmp1,llm,0) + call Gather_Field(vnat,ip1jm,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + if (mpi_rank==0) then +#include "write_grads_dyn.h" + endif + endif ! of if (output_grads_dyn) +c$OMP END MASTER + endif ! of if (leapf.or.(.not.leapf.and.(.not.forward))) + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + IF(itau.EQ.itaufin) THEN + +c$OMP BARRIER +c$OMP MASTER + +! if (planet_type.eq."earth") then +! Write an Earth-format restart file + CALL dynredem1_p("restart.nc",0.0, + & vcov,ucov,teta,q,masse,ps) +! endif ! of if (planet_type.eq."earth") + +! CLOSE(99) +c$OMP END MASTER + ENDIF ! of IF (itau.EQ.itaufin) + +c----------------------------------------------------------------------- +c gestion de l'integration temporelle: +c ------------------------------------ + + IF( MOD(itau,iperiod).EQ.0 ) THEN + GO TO 1 + ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN + + IF( forward ) THEN +c fin du pas forward et debut du pas backward + + forward = .FALSE. + leapf = .FALSE. + GO TO 2 + + ELSE +c fin du pas backward et debut du premier pas leapfrog + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF + ELSE + +c ...... pas leapfrog ..... + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (MOD(itau,iperiod).EQ.0) + ! ELSEIF (MOD(itau-1,iperiod).EQ.0) + + + ELSE ! of IF (.not.purmats) + +c ........................................................ +c .............. schema matsuno ............... +c ........................................................ + IF( forward ) THEN + + itau = itau + 1 +! iday = day_ini+itau/day_step +! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +! +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + + forward = .FALSE. + IF( itau. EQ. itaufinp1 ) then +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + RETURN + ENDIF + GO TO 2 + + ELSE ! of IF(forward) i.e. backward step + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF +#ifdef CPP_IOIPSL + IF (ok_dynzon) THEN +c$OMP BARRIER + call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest) + call SendRequest(TestRequest) +c$OMP BARRIER + call WaitRequest(TestRequest) +c$OMP BARRIER +c$OMP MASTER +! CALL writedynav_p(histaveid, itau,vcov , +! , ucov,teta,pk,phi,q,masse,ps,phis) + CALL bilan_dyn_p(2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) +c$OMP END MASTER + END IF !ok_dynzon +#endif + IF (ok_dyn_ave) THEN +!$OMP MASTER +#ifdef CPP_IOIPSL +! Ehouarn: Gather fields and make master send to output + call Gather_Field(vcov,ip1jm,llm,0) + call Gather_Field(ucov,ip1jmp1,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(pk,ip1jmp1,llm,0) + call Gather_Field(phi,ip1jmp1,llm,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + call Gather_Field(masse,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + call Gather_Field(phis,ip1jmp1,1,0) + if (mpi_rank==0) then + CALL writedynav(itau,vcov, + & ucov,teta,pk,phi,q,masse,ps,phis) + endif +#endif +!$OMP END MASTER + ENDIF ! of IF (ok_dyn_ave) + + ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) + + + IF(MOD(itau,iecri ).EQ.0) THEN +c IF(MOD(itau,iecri*day_step).EQ.0) THEN +c$OMP BARRIER +c$OMP MASTER + nbetat = nbetatdem + CALL geopot_p(ip1jmp1,teta,pk,pks,phis,phi) + +cym unat=0. + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + ijb=ij_begin+iip1 + unat(1:iip1,:)=0. + endif + + if (pole_sud) then + ije=ij_end-iip1 + unat(ij_end-iip1+1:ij_end,:)=0. + endif + + do l=1,llm + unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije) + enddo + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + do l=1,llm + vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije) + enddo + +#ifdef CPP_IOIPSL + if (ok_dyn_ins) then +! Ehouarn: Gather fields and make master send to output + call Gather_Field(vcov,ip1jm,llm,0) + call Gather_Field(ucov,ip1jmp1,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(phi,ip1jmp1,llm,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + call Gather_Field(masse,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + call Gather_Field(phis,ip1jmp1,1,0) + if (mpi_rank==0) then + CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) + endif +! CALL writehist_p(histid, histvid, itau,vcov , +! & ucov,teta,phi,q,masse,ps,phis) + endif ! of if (ok_dyn_ins) +#endif +! For some Grads output (but does it work?) + if (output_grads_dyn) then + call Gather_Field(unat,ip1jmp1,llm,0) + call Gather_Field(vnat,ip1jm,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo +c + if (mpi_rank==0) then +#include "write_grads_dyn.h" + endif + endif ! of if (output_grads_dyn) + +c$OMP END MASTER + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + IF(itau.EQ.itaufin) THEN +! if (planet_type.eq."earth") then +c$OMP MASTER + CALL dynredem1_p("restart.nc",0.0, + . vcov,ucov,teta,q,masse,ps) +c$OMP END MASTER +! endif ! of if (planet_type.eq."earth") + ENDIF ! of IF(itau.EQ.itaufin) + + forward = .TRUE. + GO TO 1 + + ENDIF ! of IF (forward) + + END IF ! of IF(.not.purmats) +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limit_netcdf.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limit_netcdf.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limit_netcdf.F90 (revision 1634) @@ -0,0 +1,642 @@ +! +! $Id$ +!------------------------------------------------------------------------------- +! +SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque) +! +!------------------------------------------------------------------------------- +! Author : L. Fairhead, 27/01/94 +!------------------------------------------------------------------------------- +! Purpose: Boundary conditions files building for new model using climatologies. +! Both grids have to be regular. +!------------------------------------------------------------------------------- +! Note: This routine is designed to work for Earth +!------------------------------------------------------------------------------- +! Modification history: +! * 23/03/1994: Z. X. Li +! * 09/1999: L. Fairhead (netcdf reading in LMDZ.3.3) +! * 07/2001: P. Le Van +! * 11/2009: L. Guez (ozone day & night climatos, see etat0_netcdf.F90) +! * 12/2009: D. Cugnet (f77->f90, calendars, files from coupled runs) +!------------------------------------------------------------------------------- + USE control_mod +#ifdef CPP_EARTH + USE dimphy + USE ioipsl, ONLY : ioget_year_len + USE phys_state_var_mod, ONLY : pctsrf + USE netcdf, ONLY : NF90_OPEN, NF90_CREATE, NF90_CLOSE, & + NF90_DEF_DIM, NF90_DEF_VAR, NF90_PUT_VAR, NF90_PUT_ATT, & + NF90_NOERR, NF90_NOWRITE, NF90_DOUBLE, NF90_GLOBAL, & + NF90_CLOBBER, NF90_ENDDEF, NF90_UNLIMITED, NF90_FLOAT + USE inter_barxy_m, only: inter_barxy +#endif + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" + LOGICAL, INTENT(IN) :: interbar ! barycentric interpolation + LOGICAL, INTENT(IN) :: extrap ! SST extrapolation flag + LOGICAL, INTENT(IN) :: oldice ! old way ice computation + REAL, DIMENSION(iip1,jjp1), INTENT(IN) :: masque ! land mask +#ifndef CPP_EARTH + CALL abort_gcm('limit_netcdf','Earth-specific routine, needs Earth physics',1) +#else +!------------------------------------------------------------------------------- +! Local variables: +#include "logic.h" +#include "comvert.h" +#include "comgeom2.h" +#include "comconst.h" +#include "indicesol.h" + +!--- INPUT NETCDF FILES NAMES -------------------------------------------------- + CHARACTER(LEN=25) :: icefile, sstfile, dumstr + CHARACTER(LEN=25), PARAMETER :: famipsst='amipbc_sst_1x1.nc ', & + famipsic='amipbc_sic_1x1.nc ', & + fcpldsst='cpl_atm_sst.nc ', & + fcpldsic='cpl_atm_sic.nc ', & + fhistsst='histmth_sst.nc ', & + fhistsic='histmth_sic.nc ', & + frugo ='Rugos.nc ', & + falbe ='Albedo.nc ' + CHARACTER(LEN=10) :: varname +!--- OUTPUT VARIABLES FOR NETCDF FILE ------------------------------------------ + REAL, DIMENSION(klon) :: fi_ice, verif + REAL, DIMENSION(:,:), POINTER :: phy_rug=>NULL(), phy_ice=>NULL() + REAL, DIMENSION(:,:), POINTER :: phy_sst=>NULL(), phy_alb=>NULL() + REAL, DIMENSION(:,:), ALLOCATABLE :: phy_bil + REAL, DIMENSION(:,:,:), ALLOCATABLE :: pctsrf_t + INTEGER :: nbad + +!--- VARIABLES FOR OUTPUT FILE WRITING ----------------------------------------- + INTEGER :: ierr, nid, ndim, ntim, k + INTEGER, DIMENSION(2) :: dims + INTEGER :: id_tim, id_SST, id_BILS, id_RUG, id_ALB + INTEGER :: id_FOCE, id_FSIC, id_FTER, id_FLIC + INTEGER :: NF90_FORMAT + INTEGER :: ndays !--- Depending on the output calendar + +!--- INITIALIZATIONS ----------------------------------------------------------- +#ifdef NC_DOUBLE + NF90_FORMAT=NF90_DOUBLE +#else + NF90_FORMAT=NF90_FLOAT +#endif + + pi = 4.*ATAN(1.) + rad = 6371229. + daysec= 86400. + omeg = 2.*pi/daysec + g = 9.8 + kappa = 0.2857143 + cpp = 1004.70885 + dtvr = daysec/REAL(day_step) + CALL inigeom + +!--- Beware: anneeref (from gcm.def) is used to determine output time sampling + ndays=ioget_year_len(anneeref) + +!--- RUGOSITY TREATMENT -------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de la rugosite' + varname='RUGOS' + CALL get_2Dfield(frugo,varname,'RUG',interbar,ndays,phy_rug,mask=masque(1:iim,:)) + +!--- OCEAN TREATMENT ----------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de la glace oceanique' + +! Input SIC file selection +! Open file only to test if available + IF ( NF90_OPEN(TRIM(famipsic),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + icefile=TRIM(famipsic) + varname='sicbcs' + ELSE IF( NF90_OPEN(TRIM(fcpldsic),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + icefile=TRIM(fcpldsic) + varname='SIICECOV' + ELSE IF ( NF90_OPEN(TRIM(fhistsic),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + icefile=TRIM(fhistsic) + varname='pourc_sic' + ELSE + WRITE(lunout,*) 'ERROR! No sea-ice input file was found.' + WRITE(lunout,*) 'One of following files must be availible : ',trim(famipsic),', ',trim(fcpldsic),', ',trim(fhistsic) + CALL abort_gcm('limit_netcdf','No sea-ice file was found',1) + END IF + ierr=NF90_CLOSE(nid) + IF (prt_level>=0) WRITE(lunout,*)'Pour la glace de mer a ete choisi le fichier '//TRIM(icefile) + + CALL get_2Dfield(icefile,varname, 'SIC',interbar,ndays,phy_ice,flag=oldice) + + ALLOCATE(pctsrf_t(klon,nbsrf,ndays)) + DO k=1,ndays + fi_ice=phy_ice(:,k) + WHERE(fi_ice>=1.0 ) fi_ice=1.0 + WHERE(fi_ice=1.0-zmasq) + pctsrf_t(:,is_sic,k)=1.0-zmasq + pctsrf_t(:,is_oce,k)=0.0 + ELSEWHERE + pctsrf_t(:,is_oce,k)=1.0-zmasq-pctsrf_t(:,is_sic,k) + WHERE(pctsrf_t(:,is_oce,k)0) WRITE(lunout,*) 'pb sous maille pour nb point = ',nbad + nbad=COUNT(abs(sum(pctsrf_t(:,:,k),dim=2)-1.0)>EPSFRA) + IF(nbad>0) WRITE(lunout,*) 'pb sous surface pour nb points = ',nbad + END DO + DEALLOCATE(phy_ice) + +!--- SST TREATMENT ------------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de la sst' + +! Input SST file selection +! Open file only to test if available + IF ( NF90_OPEN(TRIM(famipsst),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + sstfile=TRIM(famipsst) + varname='tosbcs' + ELSE IF ( NF90_OPEN(TRIM(fcpldsst),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + sstfile=TRIM(fcpldsst) + varname='SISUTESW' + ELSE IF ( NF90_OPEN(TRIM(fhistsst),NF90_NOWRITE,nid)==NF90_NOERR ) THEN + sstfile=TRIM(fhistsst) + varname='tsol_oce' + ELSE + WRITE(lunout,*) 'ERROR! No sst input file was found.' + WRITE(lunout,*) 'One of following files must be availible : ',trim(famipsst),trim(fcpldsst),trim(fhistsst) + CALL abort_gcm('limit_netcdf','No sst file was found',1) + END IF + ierr=NF90_CLOSE(nid) + IF (prt_level>=0) WRITE(lunout,*)'Pour la temperature de mer a ete choisi un fichier '//TRIM(sstfile) + + CALL get_2Dfield(sstfile,varname,'SST',interbar,ndays,phy_sst,flag=extrap) + +!--- ALBEDO TREATMENT ---------------------------------------------------------- + IF (prt_level>1) WRITE(lunout,*) 'Traitement de l albedo' + varname='ALBEDO' + CALL get_2Dfield(falbe,varname,'ALB',interbar,ndays,phy_alb) + +!--- REFERENCE GROUND HEAT FLUX TREATMENT -------------------------------------- + ALLOCATE(phy_bil(klon,ndays)); phy_bil=0.0 + +!--- OUTPUT FILE WRITING ------------------------------------------------------- + IF (prt_level>5) WRITE(lunout,*) 'Ecriture du fichier limit : debut' + + !--- File creation + ierr=NF90_CREATE("limit.nc",NF90_CLOBBER,nid) + ierr=NF90_PUT_ATT(nid,NF90_GLOBAL,"title","Fichier conditions aux limites") + + !--- Dimensions creation + ierr=NF90_DEF_DIM(nid,"points_physiques",klon,ndim) + ierr=NF90_DEF_DIM(nid,"time",NF90_UNLIMITED,ntim) + + dims=(/ndim,ntim/) + + !--- Variables creation + ierr=NF90_DEF_VAR(nid,"TEMPS",NF90_FORMAT,(/ntim/),id_tim) + ierr=NF90_DEF_VAR(nid,"FOCE", NF90_FORMAT,dims,id_FOCE) + ierr=NF90_DEF_VAR(nid,"FSIC", NF90_FORMAT,dims,id_FSIC) + ierr=NF90_DEF_VAR(nid,"FTER", NF90_FORMAT,dims,id_FTER) + ierr=NF90_DEF_VAR(nid,"FLIC", NF90_FORMAT,dims,id_FLIC) + ierr=NF90_DEF_VAR(nid,"SST", NF90_FORMAT,dims,id_SST) + ierr=NF90_DEF_VAR(nid,"BILS", NF90_FORMAT,dims,id_BILS) + ierr=NF90_DEF_VAR(nid,"ALB", NF90_FORMAT,dims,id_ALB) + ierr=NF90_DEF_VAR(nid,"RUG", NF90_FORMAT,dims,id_RUG) + + !--- Attributes creation + ierr=NF90_PUT_ATT(nid,id_tim, "title","Jour dans l annee") + ierr=NF90_PUT_ATT(nid,id_FOCE,"title","Fraction ocean") + ierr=NF90_PUT_ATT(nid,id_FSIC,"title","Fraction glace de mer") + ierr=NF90_PUT_ATT(nid,id_FTER,"title","Fraction terre") + ierr=NF90_PUT_ATT(nid,id_FLIC,"title","Fraction land ice") + ierr=NF90_PUT_ATT(nid,id_SST ,"title","Temperature superficielle de la mer") + ierr=NF90_PUT_ATT(nid,id_BILS,"title","Reference flux de chaleur au sol") + ierr=NF90_PUT_ATT(nid,id_ALB, "title","Albedo a la surface") + ierr=NF90_PUT_ATT(nid,id_RUG, "title","Rugosite") + + ierr=NF90_ENDDEF(nid) + + !--- Variables saving + ierr=NF90_PUT_VAR(nid,id_tim,(/(REAL(k),k=1,ndays)/)) + ierr=NF90_PUT_VAR(nid,id_FOCE,pctsrf_t(:,is_oce,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_FSIC,pctsrf_t(:,is_sic,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_FTER,pctsrf_t(:,is_ter,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_FLIC,pctsrf_t(:,is_lic,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_SST ,phy_sst(:,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_BILS,phy_bil(:,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_ALB ,phy_alb(:,:),(/1,1/),(/klon,ndays/)) + ierr=NF90_PUT_VAR(nid,id_RUG ,phy_rug(:,:),(/1,1/),(/klon,ndays/)) + + ierr=NF90_CLOSE(nid) + + IF (prt_level>5) WRITE(lunout,*) 'Ecriture du fichier limit : fin' + + DEALLOCATE(pctsrf_t,phy_sst,phy_bil,phy_alb,phy_rug) + + +!=============================================================================== +! + CONTAINS +! +!=============================================================================== + + +!------------------------------------------------------------------------------- +! +SUBROUTINE get_2Dfield(fnam, varname, mode, ibar, ndays, champo, flag, mask) +! +!----------------------------------------------------------------------------- +! Comments: +! There are two assumptions concerning the NetCDF files, that are satisfied +! with files that are conforming NC convention: +! 1) The last dimension of the variables used is the time record. +! 2) Dimensional variables have the same names as corresponding dimensions. +!----------------------------------------------------------------------------- + USE netcdf, ONLY: NF90_OPEN, NF90_INQ_VARID, NF90_INQUIRE_VARIABLE, & + NF90_CLOSE, NF90_INQ_DIMID, NF90_INQUIRE_DIMENSION, NF90_GET_VAR, & + NF90_GET_ATT + USE dimphy, ONLY : klon + USE phys_state_var_mod, ONLY : pctsrf + USE control_mod + use pchsp_95_m, only: pchsp_95 + use pchfe_95_m, only: pchfe_95 + use arth_m, only: arth + + IMPLICIT NONE +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "indicesol.h" +#include "iniprint.h" +!----------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: fnam ! NetCDF file name + CHARACTER(LEN=10), INTENT(IN) :: varname ! NetCDF variable name + CHARACTER(LEN=3), INTENT(IN) :: mode ! RUG, SIC, SST or ALB + LOGICAL, INTENT(IN) :: ibar ! interp on pressure levels + INTEGER, INTENT(IN) :: ndays ! current year number of days + REAL, POINTER, DIMENSION(:, :) :: champo ! output field = f(t) + LOGICAL, OPTIONAL, INTENT(IN) :: flag ! extrapol. (SST) old ice (SIC) + REAL, OPTIONAL, DIMENSION(iim, jjp1), INTENT(IN) :: mask +!------------------------------------------------------------------------------ +! Local variables: +!--- NetCDF + INTEGER :: ncid, varid ! NetCDF identifiers + CHARACTER(LEN=30) :: dnam ! dimension name +!--- dimensions + INTEGER, DIMENSION(4) :: dids ! NetCDF dimensions identifiers + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_ini ! initial longitudes vector + REAL, ALLOCATABLE, DIMENSION(:) :: dlat_ini ! initial latitudes vector + REAL, POINTER, DIMENSION(:) :: dlon, dlat ! reordered lon/lat vectors +!--- fields + INTEGER :: imdep, jmdep, lmdep ! dimensions of 'champ' + REAL, ALLOCATABLE, DIMENSION(:, :) :: champ ! wanted field on initial grid + REAL, ALLOCATABLE, DIMENSION(:) :: yder, timeyear + REAL, DIMENSION(iim, jjp1) :: champint ! interpolated field + REAL, ALLOCATABLE, DIMENSION(:, :, :) :: champtime + REAL, ALLOCATABLE, DIMENSION(:, :, :) :: champan +!--- input files + CHARACTER(LEN=20) :: cal_in ! calendar + CHARACTER(LEN=20) :: unit_sic ! attribute unit in sea-ice file + INTEGER :: ndays_in ! number of days +!--- misc + INTEGER :: i, j, k, l ! loop counters + REAL, ALLOCATABLE, DIMENSION(:, :) :: work ! used for extrapolation + CHARACTER(LEN=25) :: title ! for messages + LOGICAL :: extrp ! flag for extrapolation + LOGICAL :: oldice ! flag for old way ice computation + REAL :: chmin, chmax + INTEGER ierr + integer n_extrap ! number of extrapolated points + logical skip + +!------------------------------------------------------------------------------ +!---Variables depending on keyword 'mode' ------------------------------------- + NULLIFY(champo) + + SELECT CASE(mode) + CASE('RUG'); title='Rugosite' + CASE('SIC'); title='Sea-ice' + CASE('SST'); title='SST' + CASE('ALB'); title='Albedo' + END SELECT + + + extrp=.FALSE. + oldice=.FALSE. + IF ( PRESENT(flag) ) THEN + IF ( flag .AND. mode=='SST' ) extrp=.TRUE. + IF ( flag .AND. mode=='SIC' ) oldice=.TRUE. + END IF + +!--- GETTING SOME DIMENSIONAL VARIABLES FROM FILE ----------------------------- + IF (prt_level>5) WRITE(lunout,*) ' Now reading file : ',fnam + ierr=NF90_OPEN(fnam, NF90_NOWRITE, ncid); CALL ncerr(ierr, fnam) + ierr=NF90_INQ_VARID(ncid, trim(varname), varid); CALL ncerr(ierr, fnam) + ierr=NF90_INQUIRE_VARIABLE(ncid, varid, dimids=dids); CALL ncerr(ierr, fnam) + +!--- Read unit for sea-ice variable only + IF (mode=='SIC') THEN + ierr=NF90_GET_ATT(ncid, varid, 'units', unit_sic) + IF(ierr/=NF90_NOERR) THEN + IF (prt_level>5) WRITE(lunout,*) 'No unit was given in sea-ice file. Take percentage as default value' + unit_sic='X' + ELSE + IF (prt_level>5) WRITE(lunout,*) ' Sea-ice cover has unit=',unit_sic + END IF + END IF + +!--- Longitude + ierr=NF90_INQUIRE_DIMENSION(ncid, dids(1), name=dnam, len=imdep) + CALL ncerr(ierr, fnam); ALLOCATE(dlon_ini(imdep), dlon(imdep)) + ierr=NF90_INQ_VARID(ncid, dnam, varid); CALL ncerr(ierr, fnam) + ierr=NF90_GET_VAR(ncid, varid, dlon_ini); CALL ncerr(ierr, fnam) + IF (prt_level>5) WRITE(lunout, *) 'variable ', dnam, 'dimension ', imdep + +!--- Latitude + ierr=NF90_INQUIRE_DIMENSION(ncid, dids(2), name=dnam, len=jmdep) + CALL ncerr(ierr, fnam); ALLOCATE(dlat_ini(jmdep), dlat(jmdep)) + ierr=NF90_INQ_VARID(ncid, dnam, varid); CALL ncerr(ierr, fnam) + ierr=NF90_GET_VAR(ncid, varid, dlat_ini); CALL ncerr(ierr, fnam) + IF (prt_level>5) WRITE(lunout, *) 'variable ', dnam, 'dimension ', jmdep + +!--- Time (variable is not needed - it is rebuilt - but calendar is) + ierr=NF90_INQUIRE_DIMENSION(ncid, dids(3), name=dnam, len=lmdep) + CALL ncerr(ierr, fnam); ALLOCATE(timeyear(lmdep)) + ierr=NF90_INQ_VARID(ncid, dnam, varid); CALL ncerr(ierr, fnam) + cal_in=' ' + ierr=NF90_GET_ATT(ncid, varid, 'calendar', cal_in) + IF(ierr/=NF90_NOERR) THEN + SELECT CASE(mode) + CASE('RUG', 'ALB'); cal_in='360d' + CASE('SIC', 'SST'); cal_in='gregorian' + END SELECT + IF (prt_level>5) WRITE(lunout, *)'ATTENTION: variable "time" sans attribut "calendrier" ' & + // 'dans '//TRIM(fnam)//'. On choisit la valeur par defaut.' + END IF + IF (prt_level>5) WRITE(lunout, *) 'variable ', dnam, 'dimension ', lmdep, 'calendrier ', & + cal_in + + +!--- CONSTRUCTING THE INPUT TIME VECTOR FOR INTERPOLATION -------------------- + !--- Determining input file number of days, depending on calendar + ndays_in=year_len(anneeref, cal_in) + +!--- Time vector reconstruction (time vector from file is not trusted) +!--- If input records are not monthly, time sampling has to be constant ! + timeyear=mid_months(anneeref, cal_in, lmdep) + IF (lmdep /= 12) WRITE(lunout,*) 'Note : les fichiers de ', TRIM(mode), & + ' ne comportent pas 12, mais ', lmdep, ' enregistrements.' + +!--- GETTING THE FIELD AND INTERPOLATING IT ---------------------------------- + ALLOCATE(champ(imdep, jmdep), champtime(iim, jjp1, lmdep)) + IF(extrp) ALLOCATE(work(imdep, jmdep)) + + IF (prt_level>5) WRITE(lunout, *) + IF (prt_level>5) WRITE(lunout,*)'LECTURE ET INTERPOLATION HORIZ. DE ', lmdep, ' CHAMPS.' + ierr=NF90_INQ_VARID(ncid, varname, varid); CALL ncerr(ierr, fnam) + DO l=1, lmdep + ierr=NF90_GET_VAR(ncid, varid, champ, (/1, 1, l/), (/imdep, jmdep, 1/)) + CALL ncerr(ierr, fnam) + CALL conf_dat2d(title, imdep, jmdep, dlon_ini, dlat_ini, dlon, dlat, & + champ, ibar) + + IF (extrp) CALL extrapol(champ, imdep, jmdep, 999999., .TRUE., .TRUE., 2, & + work) + + IF(ibar .AND. .NOT.oldice) THEN + IF(l==1 .AND. prt_level>5) THEN + WRITE(lunout, *) '-------------------------------------------------------------------------' + WRITE(lunout, *) 'Utilisation de l''interpolation barycentrique pour ',TRIM(title),' $$$' + WRITE(lunout, *) '-------------------------------------------------------------------------' + END IF + IF(mode=='RUG') champ=LOG(champ) + CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim), & + rlatv, champint) + IF(mode=='RUG') THEN + champint=EXP(champint) + WHERE(NINT(mask)/=1) champint=0.001 + END IF + ELSE + SELECT CASE(mode) + CASE('RUG'); CALL rugosite(imdep, jmdep, dlon, dlat, champ, & + iim, jjp1, rlonv, rlatu, champint, mask) + CASE('SIC'); CALL sea_ice (imdep, jmdep, dlon, dlat, champ, & + iim, jjp1, rlonv, rlatu, champint) + CASE('SST', 'ALB'); CALL grille_m(imdep, jmdep, dlon, dlat, champ, & + iim, jjp1, rlonv, rlatu, champint) + END SELECT + END IF + champtime(:, :, l)=champint + END DO + ierr=NF90_CLOSE(ncid); CALL ncerr(ierr, fnam) + + DEALLOCATE(dlon_ini, dlat_ini, dlon, dlat, champ) + IF(extrp) DEALLOCATE(work) + +!--- TIME INTERPOLATION ------------------------------------------------------ + IF (prt_level>5) THEN + WRITE(lunout, *) + WRITE(lunout, *)'INTERPOLATION TEMPORELLE.' + WRITE(lunout, *)' Vecteur temps en entree: ', timeyear + WRITE(lunout, *)' Vecteur temps en sortie de 0 a ', ndays + END IF + + ALLOCATE(yder(lmdep), champan(iip1, jjp1, ndays)) + skip = .false. + n_extrap = 0 + DO j=1, jjp1 + DO i=1, iim + yder = pchsp_95(timeyear, champtime(i, j, :), ibeg=2, iend=2, & + vc_beg=0., vc_end=0.) + CALL pchfe_95(timeyear, champtime(i, j, :), yder, skip, & + arth(0., real(ndays_in) / ndays, ndays), champan(i, j, :), ierr) + if (ierr < 0) stop 1 + n_extrap = n_extrap + ierr + END DO + END DO + if (n_extrap /= 0) then + WRITE(lunout,*) "get_2Dfield pchfe_95: n_extrap = ", n_extrap + end if + champan(iip1, :, :)=champan(1, :, :) + DEALLOCATE(yder, champtime, timeyear) + +!--- Checking the result + DO j=1, jjp1 + CALL minmax(iip1, champan(1, j, 10), chmin, chmax) + IF (prt_level>5) WRITE(lunout, *)' ',TRIM(title),' au temps 10 ', chmin, chmax, j + END DO + +!--- SPECIAL FILTER FOR SST: SST>271.38 -------------------------------------- + IF(mode=='SST') THEN + IF (prt_level>5) WRITE(lunout, *) 'Filtrage de la SST: SST >= 271.38' + WHERE(champan<271.38) champan=271.38 + END IF + +!--- SPECIAL FILTER FOR SIC: 0.05) WRITE(lunout, *) 'Filtrage de la SIC: 0.0 < Sea-ice < 1.0' + + IF (unit_sic=='1') THEN + ! Nothing to be done for sea-ice field is already in fraction of 1 + ! This is the case for sea-ice in file cpl_atm_sic.nc + IF (prt_level>5) WRITE(lunout,*) 'Sea-ice field already in fraction of 1' + ELSE + ! Convert sea ice from percentage to fraction of 1 + IF (prt_level>5) WRITE(lunout,*) 'Transformt sea-ice field from percentage to fraction of 1.' + champan(:, :, :)=champan(:, :, :)/100. + END IF + + champan(iip1, :, :)=champan(1, :, :) + WHERE(champan>1.0) champan=1.0 + WHERE(champan<0.0) champan=0.0 + END IF + +!--- DYNAMICAL TO PHYSICAL GRID ---------------------------------------------- + ALLOCATE(champo(klon, ndays)) + DO k=1, ndays + CALL gr_dyn_fi(1, iip1, jjp1, klon, champan(1, 1, k), champo(1, k)) + END DO + DEALLOCATE(champan) + +END SUBROUTINE get_2Dfield +! +!------------------------------------------------------------------------------- + + + +!------------------------------------------------------------------------------- +! +FUNCTION year_len(y,cal_in) +! +!------------------------------------------------------------------------------- + USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_year_len + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + INTEGER :: year_len + INTEGER, INTENT(IN) :: y + CHARACTER(LEN=*), INTENT(IN) :: cal_in +!------------------------------------------------------------------------------- +! Local variables: + CHARACTER(LEN=20) :: cal_out ! calendar (for outputs) +!------------------------------------------------------------------------------- +!--- Getting the input calendar to reset at the end of the function + CALL ioget_calendar(cal_out) + +!--- Unlocking calendar and setting it to wanted one + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in)) + +!--- Getting the number of days in this year + year_len=ioget_year_len(y) + +!--- Back to original calendar + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out)) + +END FUNCTION year_len +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +FUNCTION mid_months(y,cal_in,nm) +! +!------------------------------------------------------------------------------- + USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_mon_len + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: y ! year + CHARACTER(LEN=*), INTENT(IN) :: cal_in ! calendar + INTEGER, INTENT(IN) :: nm ! months/year number + REAL, DIMENSION(nm) :: mid_months ! mid-month times +!------------------------------------------------------------------------------- +! Local variables: + CHARACTER(LEN=99) :: mess ! error message + CHARACTER(LEN=20) :: cal_out ! calendar (for outputs) + INTEGER, DIMENSION(nm) :: mnth ! months lengths (days) + INTEGER :: m ! months counter + INTEGER :: nd ! number of days +!------------------------------------------------------------------------------- + nd=year_len(y,cal_in) + + IF(nm==12) THEN + + !--- Getting the input calendar to reset at the end of the function + CALL ioget_calendar(cal_out) + + !--- Unlocking calendar and setting it to wanted one + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in)) + + !--- Getting the length of each month + DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO + + !--- Back to original calendar + CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out)) + + ELSE IF(MODULO(nd,nm)/=0) THEN + WRITE(mess,'(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',& + nm,' months/year. Months number should divide days number.' + CALL abort_gcm('mid_months',TRIM(mess),1) + + ELSE + mnth=(/(m,m=1,nm,nd/nm)/) + END IF + +!--- Mid-months times + mid_months(1)=0.5*REAL(mnth(1)) + DO k=2,nm + mid_months(k)=mid_months(k-1)+0.5*REAL(mnth(k-1)+mnth(k)) + END DO + +END FUNCTION mid_months +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE ncerr(ncres,fnam) +! +!------------------------------------------------------------------------------- +! Purpose: NetCDF errors handling. +!------------------------------------------------------------------------------- + USE netcdf, ONLY : NF90_NOERR, NF90_STRERROR + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: ncres + CHARACTER(LEN=*), INTENT(IN) :: fnam +!------------------------------------------------------------------------------- +#include "iniprint.h" + IF(ncres/=NF90_NOERR) THEN + WRITE(lunout,*)'Problem with file '//TRIM(fnam)//' in routine limit_netcdf.' + CALL abort_gcm('limit_netcdf',NF90_STRERROR(ncres),1) + END IF + +END SUBROUTINE ncerr +! +!------------------------------------------------------------------------------- + +#endif +! of #ifdef CPP_EARTH + +END SUBROUTINE limit_netcdf Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limx.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limx.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limx.F (revision 1634) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE limx(s0,sx,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sx(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dxq(ip1jmp1,llm) + + + REAL new_m,zm + real dxqu(ip1jmp1) + real adxqu(ip1jmp1),dxqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dxq(ij,l) = sx(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente a droite et a gauche de la maille + + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + enddo + + do ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=iip2+1,ip1jm + dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij)) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim)=dxqmax(ij) + enddo + +c calcul de la pente avec limitation + + do ij=iip2+1,ip1jm + if( dxqu(ij-1)*dxqu(ij).gt.0. + & .and. dxq(ij,l)*dxqu(ij).gt.0.) then + dxq(ij,l)= + & sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l)) + else +c extremum local + dxq(ij,l)=0. + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + enddo + + DO ij=1,ip1jmp1 + sx(ij,l) = dxq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limy.F (revision 1634) @@ -0,0 +1,194 @@ +c +c $Id$ +c + SUBROUTINE limy(s0,sy,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL q(ip1jmp1,llm) + REAL airej2,airejjm,airescb(iim),airesch(iim) + real sigv,dyq(ip1jmp1),dyqv(ip1jm) + real adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2 + Logical extremum,first + save first + + real convpn,convps,convmpn,convmps + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon +c +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + endif + +c + + do l = 1, llm +c + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dyq(ij) = sy(ij,l) / sm ( ij,l ) + ENDDO +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + do ij=iip2,ip1jm + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + enddo + +c calcul des pentes aux poles + +c calcul des pentes limites aux poles + +c print*,dyqv(iip1+1) +c appn=abs(dyq(1)/dyqv(iip1+1)) +c print*,dyq(ip1jm+1) +c print*,dyqv(ip1jm-iip1+1) +c apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +c do ij=2,iim +c appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) +c apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) +c enddo +c appn=min(pente_max/appn,1.) +c apps=min(pente_max/apps,1.) + + +c cas ou on a un extremum au pole + +c if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +c & appn=0. +c if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +c & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +c & apps=0. + +c limitation des pentes aux poles +c do ij=1,iip1 +c dyq(ij)=appn*dyq(ij) +c dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) +c enddo + +c test +c do ij=1,iip1 +c dyq(iip1+ij)=0. +c dyq(ip1jm+ij-iip1)=0. +c enddo +c do ij=1,ip1jmp1 +c dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +c enddo + + if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) + & then + do ij=1,iip1 + dyqmax(ij)=0. + enddo + else + do ij=1,iip1 + dyqmax(ij)=pente_max*abs(dyqv(ij)) + enddo + endif + + if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* + & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) + &then + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=0. + enddo + else + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) + enddo + endif + +c calcul des pentes limitees + + do ij=1,ip1jmp1 + if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then + dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij)) + else + dyq(ij)=0. + endif + enddo + + DO ij=1,ip1jmp1 + sy(ij,l) = dyq(ij) * sm ( ij,l ) + ENDDO + + enddo ! fin de la boucle sur les couches verticales + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limz.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limz.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/limz.F (revision 1634) @@ -0,0 +1,99 @@ +! +! $Header$ +! + SUBROUTINE limz(s0,sz,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sz(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dzq(ip1jmp1,llm) + + + REAL new_m,zm + real dzqw(ip1jmp1) + real adzqw(ip1jmp1),dzqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dzq(ij,l) = sz(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente en haut et en bas de la maille + do ij=1,ip1jmp1 + do l = 1, llm-1 + dzqw(l)=q(ij,l+1)-q(ij,l) + enddo + dzqw(llm)=0. + + do l=1,llm + adzqw(l)=abs(dzqw(l)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=2,llm-1 + dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l)) + enddo + +c calcul de la pente avec limitation + + do l=2,llm-1 + if( dzqw(l-1)*dzqw(l).gt.0. + & .and. dzq(ij,l)*dzqw(l).gt.0.) then + dzq(ij,l)= + & sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l)) + else +c extremum local + dzq(ij,l)=0. + endif + enddo + + DO l=1,llm + sz(ij,l) = dzq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/logic.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/logic.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/logic.h (revision 1634) @@ -0,0 +1,27 @@ +! +! $Id$ +! +! +! NB: keep items of different kinds in seperate common blocs to avoid +! "misaligned commons" issues +!----------------------------------------------------------------------- +! INCLUDE 'logic.h' + + COMMON/logicl/ purmats,forward,leapf,apphys, & + & statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile & + & ,ok_limit,ok_etat0,grilles_gcm_netcdf,hybrid + + COMMON/logici/ iflag_phys,iflag_trac + + LOGICAL purmats,forward,leapf,apphys,statcl,conser, & + & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile & + & ,ok_limit,ok_etat0,grilles_gcm_netcdf + logical hybrid ! vertical coordinate is hybrid if true (sigma otherwise) + ! (only used if disvert_type==2) + + integer iflag_phys,iflag_trac +!$OMP THREADPRIVATE(/logicl/) +!$OMP THREADPRIVATE(/logici/) +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbar.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbar.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbar.F (revision 1634) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE massbar( masse, massebx, masseby ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , + * masseby( ip1jm,llm ) +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + DO ij = iip1, ip1jmp1, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + DO ij = 1,ip1jm + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbar_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbar_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbar_p.F (revision 1634) @@ -0,0 +1,117 @@ + SUBROUTINE massbar_p( masse, massebx, masseby ) + +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , + * masseby( ip1jm,llm ) + INTEGER ij,l,ijb,ije +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij = ijb, ije - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + + + + DO ij = ijb+iim, ije+iim, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij = ijb,ije + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbarxy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbarxy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbarxy.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE massbarxy( masse, massebxy ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebxy( ip1jm,llm ) +c + + DO 100 l = 1 , llm +c + DO 5 ij = 1, ip1jm - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbarxy_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbarxy_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massbarxy_p.F (revision 1634) @@ -0,0 +1,55 @@ + SUBROUTINE massbarxy_p( masse, massebxy ) + USE parallel + implicit none +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebxy( ip1jm,llm ) +c + INTEGER ij,l,ijb,ije + + + ijb=ij_begin-iip1 + ije=ij_end + + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + DO 5 ij = ijb, ije - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = ijb+iip1-1, ije+iip1-1, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massdair.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massdair.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massdair.F (revision 1634) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE massdair( p, masse ) +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) + +c .... Variables locales ..... + + INTEGER l,ij + REAL massemoyn, massemoys + + REAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = 1, ip1jmp1,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massdair_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massdair_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/massdair_p.F (revision 1634) @@ -0,0 +1,120 @@ + SUBROUTINE massdair_p( p, masse ) + USE parallel +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) + +c .... Variables locales ..... + + INTEGER l,ij + INTEGER ijb,ije + REAL massemoyn, massemoys + + REAL SSUM + EXTERNAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + + + + ijb=ij_begin-iip1 + ije=ij_end+2*iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + DO ij = ijb, ije + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = ijb, ije,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/minmax.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/minmax.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/minmax.F (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! + SUBROUTINE minmax(imax, xi, zmin, zmax ) +c +c P. Le Van + + INTEGER imax + REAL xi(imax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/minmax2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/minmax2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/minmax2.F (revision 1634) @@ -0,0 +1,20 @@ +! +! $Header$ +! + SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax ) +c + INTEGER lmax,jmax,imax + REAL xi(imax*jmax*lmax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax*jmax*lmax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_const_para.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_const_para.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_const_para.F90 (revision 1634) @@ -0,0 +1,77 @@ +! +! $Id$ +! +MODULE mod_const_mpi + + INTEGER,SAVE :: COMM_LMDZ + INTEGER,SAVE :: MPI_REAL_LMDZ + + +CONTAINS + + SUBROUTINE Init_const_mpi +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + INTEGER :: comp_id + INTEGER :: thread_required + INTEGER :: thread_provided + CHARACTER(len = 6) :: type_ocean + +!$OMP MASTER + type_ocean = 'force ' + CALL getin('type_ocean', type_ocean) +!$OMP END MASTER +!$OMP BARRIER + + IF (type_ocean=='couple') THEN +#ifdef CPP_COUPLE +!$OMP MASTER + CALL prism_init_comp_proto (comp_id, 'lmdz.x', ierr) + CALL prism_get_localcomm_proto(COMM_LMDZ,ierr) +!$OMP END MASTER +#endif +#ifdef CPP_MPI + MPI_REAL_LMDZ=MPI_REAL8 +#endif + ELSE + CALL init_mpi + ENDIF + + END SUBROUTINE Init_const_mpi + + SUBROUTINE Init_mpi + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + INTEGER :: thread_required + INTEGER :: thread_provided + +#ifdef CPP_MPI +!$OMP MASTER + thread_required=MPI_THREAD_SERIALIZED + + CALL MPI_INIT_THREAD(thread_required,thread_provided,ierr) + IF (thread_provided < thread_required) THEN + PRINT *,'Warning : The multithreaded level of MPI librairy do not provide the requiered level', & + ' in mod_const_mpi::Init_const_mpi' + ENDIF + COMM_LMDZ=MPI_COMM_WORLD + MPI_REAL_LMDZ=MPI_REAL8 +!$OMP END MASTER +#endif + + END SUBROUTINE Init_mpi + +END MODULE mod_const_mpi Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_hallo.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_hallo.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_hallo.F90 (revision 1634) @@ -0,0 +1,814 @@ +module mod_Hallo +USE parallel +implicit none + logical,save :: use_mpi_alloc + integer, parameter :: MaxRequest=200 + integer, parameter :: MaxProc=80 + integer, parameter :: MaxBufferSize=1024*1024*16 + integer, parameter :: ListSize=1000 + + integer,save :: MaxBufferSize_Used +!$OMP THREADPRIVATE( MaxBufferSize_Used) + + real,save,pointer,dimension(:) :: Buffer +!$OMP THREADPRIVATE(Buffer) + + integer,save,dimension(Listsize) :: Buffer_Pos + integer,save :: Index_Pos +!$OMP THREADPRIVATE(Buffer_Pos,Index_pos) + + type Hallo + real, dimension(:,:),pointer :: Field + integer :: offset + integer :: size + integer :: NbLevel + integer :: Stride + end type Hallo + + type request_SR + integer :: NbRequest=0 + integer :: Pos + integer :: Index + type(Hallo),dimension(MaxRequest) :: Hallo + integer :: MSG_Request + end type request_SR + + type request + type(request_SR),dimension(0:MaxProc-1) :: RequestSend + type(request_SR),dimension(0:MaxProc-1) :: RequestRecv + integer :: tag=1 + end type request + + + contains + + subroutine Init_mod_hallo + implicit none + + Index_Pos=1 + Buffer_Pos(Index_Pos)=1 + MaxBufferSize_Used=0 + + IF (use_mpi_alloc .AND. using_mpi) THEN + CALL create_global_mpi_buffer + ELSE + CALL create_standard_mpi_buffer + ENDIF + + end subroutine init_mod_hallo + + SUBROUTINE create_standard_mpi_buffer + IMPLICIT NONE + + ALLOCATE(Buffer(MaxBufferSize)) + + END SUBROUTINE create_standard_mpi_buffer + + SUBROUTINE create_global_mpi_buffer + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + POINTER (Pbuffer,MPI_Buffer(MaxBufferSize)) + REAL :: MPI_Buffer +#ifdef CPP_MPI + INTEGER(KIND=MPI_ADDRESS_KIND) :: BS +#else + INTEGER(KIND=8) :: BS +#endif + INTEGER :: i,ierr + +! Allocation du buffer MPI + Bs=8*MaxBufferSize +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr) +#endif +!$OMP END CRITICAL (MPI) + DO i=1,MaxBufferSize + MPI_Buffer(i)=i + ENDDO + + CALL Associate_buffer(MPI_Buffer) + + CONTAINS + + SUBROUTINE Associate_buffer(MPI_Buffer) + IMPLICIT NONE + REAL,DIMENSION(:),target :: MPI_Buffer + + Buffer=>MPI_Buffer + + END SUBROUTINE Associate_buffer + + END SUBROUTINE create_global_mpi_buffer + + + subroutine allocate_buffer(Size,Index,Pos) + implicit none + integer :: Size + integer :: Index + integer :: Pos + + if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size + if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then + print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + if (Index_pos>=ListSize) then + print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + Pos=Buffer_Pos(Index_Pos) + Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size + Index_Pos=Index_Pos+1 + Index=Index_Pos + + end subroutine allocate_buffer + + subroutine deallocate_buffer(Index) + implicit none + integer :: Index + + Buffer_Pos(Index)=-1 + + do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1) + Index_Pos=Index_Pos-1 + end do + + end subroutine deallocate_buffer + + subroutine SetTag(a_request,tag) + implicit none + type(request):: a_request + integer :: tag + + a_request%tag=tag + end subroutine SetTag + + + subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo) + integer :: Stride + integer :: NbLevel + integer :: size + integer :: offset + real, dimension(Stride,NbLevel),target :: Field + type(Hallo) :: NewHallo + + NewHallo%Field=>Field + NewHallo%Stride=Stride + NewHallo%NbLevel=NbLevel + NewHallo%size=size + NewHallo%offset=offset + + + end subroutine Init_Hallo + + subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,offset,size,target + REAL, dimension(ij,ll) :: Field + type(request),target :: a_request + type(request_SR),pointer :: Ptr_request + + Ptr_Request=>a_request%RequestSend(target) + Ptr_Request%NbRequest=Ptr_Request%NbRequest+1 + if (Ptr_Request%NbRequest>=MaxRequest) then + print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!' + stop + endif + call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest)) + + end subroutine Register_SendField + + subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,offset,size,target + REAL, dimension(ij,ll) :: Field + type(request),target :: a_request + type(request_SR),pointer :: Ptr_request + + Ptr_Request=>a_request%RequestRecv(target) + Ptr_Request%NbRequest=Ptr_Request%NbRequest+1 + + if (Ptr_Request%NbRequest>=MaxRequest) then + print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest)) + + + end subroutine Register_RecvField + + subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + type(request) :: a_request + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + do i=0,MPI_Size-1 + if (i /= MPI_Rank) then + jjb=max(jj_begin_new(i),jj_begin) + jje=min(jj_end_new(i),jj_end) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),jj_end_Para(i)) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + endif + enddo + + end subroutine Register_SwapField + + + subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,Up,Down + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + type(request) :: a_request + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + do i=0,MPI_Size-1 + jj_begin_New(i)=max(1,jj_begin_New(i)-Up) + jj_end_New(i)=min(jjp1,jj_end_new(i)+Down) + enddo + + do i=0,MPI_Size-1 + if (i /= MPI_Rank) then + jjb=max(jj_begin_new(i),jj_begin) + jje=min(jj_end_new(i),jj_end) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),jj_end_Para(i)) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + endif + enddo + + end subroutine Register_SwapFieldHallo + + subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request) + + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: Sup,Sdown,rup,rdown + type(request) :: a_request + type(Hallo),pointer :: PtrHallo + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (Sup.eq.0) then + SendUp=.FALSE. + endif + + if (Sdown.eq.0) then + SendDown=.FALSE. + endif + + if (Rup.eq.0) then + RecvUp=.FALSE. + endif + + if (Rdown.eq.0) then + RecvDown=.FALSE. + endif + + IF (SendUp) THEN + call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request) + ENDIF + + IF (SendDown) THEN + call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request) + ENDIF + + + IF (RecvUp) THEN + call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request) + ENDIF + + IF (RecvDown) THEN + call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request) + ENDIF + + end subroutine Register_Hallo + + subroutine SendRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer :: SizeBuffer + integer :: i,rank,l,ij,Pos,ierr + integer :: offset + real,dimension(:,:),pointer :: Field + integer :: Nb + + do rank=0,MPI_SIZE-1 + + Req=>a_Request%RequestSend(rank) + + SizeBuffer=0 + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,PtrHallo%NbLevel + SizeBuffer=SizeBuffer+PtrHallo%size*iip1 + ENDDO +!$OMP ENDDO NOWAIT + enddo + + if (SizeBuffer>0) then + + call allocate_buffer(SizeBuffer,Req%Index,Req%pos) + + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 + Field=>PtrHallo%Field + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + Buffer(Pos+ij)=Field(Offset+ij,l) + enddo + + Pos=Pos+Nb+1 + enddo +!$OMP END DO NOWAIT + enddo + +!$OMP CRITICAL (MPI) + +#ifdef CPP_MPI + call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, & + COMM_LMDZ,Req%MSG_Request,ierr) +#endif + IF (.NOT.using_mpi) THEN + PRINT *,'Erreur, echange MPI en mode sequentiel !!!' + STOP + ENDIF +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->" +! PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank +! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + + enddo + + + do rank=0,MPI_SIZE-1 + + Req=>a_Request%RequestRecv(rank) + SizeBuffer=0 + + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,PtrHallo%NbLevel + SizeBuffer=SizeBuffer+PtrHallo%size*iip1 + ENDDO +!$OMP ENDDO NOWAIT + enddo + + if (SizeBuffer>0) then + + call allocate_buffer(SizeBuffer,Req%Index,Req%Pos) +!$OMP CRITICAL (MPI) + +#ifdef CPP_MPI + call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, & + COMM_LMDZ,Req%MSG_Request,ierr) +#endif + IF (.NOT.using_mpi) THEN + PRINT *,'Erreur, echange MPI en mode sequentiel !!!' + STOP + ENDIF + +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->" +! PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank +! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request +! PRINT *,"-------------------------------------------------------------------" + +!$OMP END CRITICAL (MPI) + endif + + enddo + + end subroutine SendRequest + + subroutine WaitRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(2*mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus +#else + integer, dimension(1,2*mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset + integer :: Nb + + + NbRequest=0 + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + if (NbRequest>0) then +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + do rank=0,MPI_Size-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij) + enddo + + Pos=Pos+Nb+1 + enddo +!$OMP ENDDO NOWAIT + enddo + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitRequest + + subroutine WaitSendRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus +#else + integer, dimension(1,mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset + + + NbRequest=0 + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + + if (NbRequest>0) THEN +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" + +!$OMP END CRITICAL (MPI) + endif + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitSendRequest + + subroutine WaitRecvRequest(a_Request) + implicit none + +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus +#else + integer, dimension(1,mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset,Nb + + + NbRequest=0 + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + + if (NbRequest>0) then +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + + do rank=0,MPI_Size-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij) + enddo + Pos=Pos+Nb+1 + enddo +!$OMP END DO NOWAIT + enddo + endif + enddo + + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitRecvRequest + + + + subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,l + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb,ijb,ije + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + jjb=max(jj_begin,jj_begin_new(MPI_Rank)) + jje=min(jj_end,jj_end_new(MPI_Rank)) + if (ij==ip1jm) jje=min(jje,jjm) + + if (jje >= jjb) then + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,ll + FieldR(ijb:ije,l)=FieldS(ijb:ije,l) + enddo +!$OMP ENDDO NOWAIT + endif + + + end subroutine CopyField + + subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down) + + implicit none +#include "dimensions.h" +#include "paramet.h" + + INTEGER :: ij,ll,Up,Down + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb,ijb,ije,l + + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + + jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up) + jje=min(jj_end,jj_end_new(MPI_Rank)+Down) + if (ij==ip1jm) jje=min(jje,jjm) + + + if (jje >= jjb) then + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,ll + FieldR(ijb:ije,l)=FieldS(ijb:ije,l) + enddo +!$OMP ENDDO NOWAIT + + endif + end subroutine CopyFieldHallo + +end module mod_Hallo + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_interface_dyn_phys.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_interface_dyn_phys.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/mod_interface_dyn_phys.F90 (revision 1634) @@ -0,0 +1,59 @@ +! +! $Id$ +! +MODULE mod_interface_dyn_phys + INTEGER,SAVE,dimension(:),allocatable :: index_i + INTEGER,SAVE,dimension(:),allocatable :: index_j + + +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics +CONTAINS + + SUBROUTINE Init_interface_dyn_phys + USE mod_phys_lmdz_mpi_data + IMPLICIT NONE + include 'dimensions.h' + + INTEGER :: i,j,k + + ALLOCATE(index_i(klon_mpi)) + ALLOCATE(index_j(klon_mpi)) + + k=1 + IF (is_north_pole) THEN + index_i(k)=1 + index_j(k)=1 + k=2 + ELSE + DO i=ii_begin,iim + index_i(k)=i + index_j(k)=jj_begin + k=k+1 + ENDDO + ENDIF + + DO j=jj_begin+1,jj_end-1 + DO i=1,iim + index_i(k)=i + index_j(k)=j + k=k+1 + ENDDO + ENDDO + + IF (is_south_pole) THEN + index_i(k)=1 + index_j(k)=jj_end + ELSE + DO i=1,ii_end + index_i(k)=i + index_j(k)=jj_end + k=k+1 + ENDDO + ENDIF + + END SUBROUTINE Init_interface_dyn_phys +#endif +! of #ifdef CPP_EARTH +END MODULE mod_interface_dyn_phys Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad.F (revision 1634) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE nxgrad (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_gam.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_gam.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_gam.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgrad_gam( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_gam_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_gam_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_gam_p.F (revision 1634) @@ -0,0 +1,67 @@ + SUBROUTINE nxgrad_gam_p( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij + integer ismin,ismax + external ismin,ismax + INTEGER :: ijb,ije +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + if(pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrad_p.F (revision 1634) @@ -0,0 +1,67 @@ + SUBROUTINE nxgrad_p (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgradst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgradst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgradst.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgradst (klevel,rot, x, y ) +c + IMPLICIT NONE +c Auteur : P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y(ij,l)=( rot(ij,l) - rot(ij-1,l)) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... + + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x(ij,l)= rot(ij,l)-rot(ij-iip1,l) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgraro2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgraro2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgraro2.F (revision 1634) @@ -0,0 +1,68 @@ +! +! $Header$ +! + SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL rot(ip1jm,llm) , signe, nugradrs + INTEGER l,ij,iter,lr +c ........................................................ +c +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c + CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) +c + CALL rotatf ( klevel, grx, gry, rot ) +c + CALL laplacien_rot ( klevel, rot, rot,grx,gry ) + +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 + CALL laplacien_rotgam ( klevel, rot, rot ) + ENDDO +c +c + CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1) + CALL nxgrad ( klevel, rot, grx, gry ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + gry( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + DO ij = 1, ip1jmp1 + grx( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgraro2_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgraro2_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgraro2_p.F (revision 1634) @@ -0,0 +1,141 @@ + SUBROUTINE nxgraro2_p (klevel,xcov, ycov, lr, grx_out, gry_out ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + USE write_Field_p + USE parallel + USE times + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: grx( ip1jmp1,llm ), gry( ip1jm,llm ) + REAL grx_out( ip1jmp1,klevel ), gry_out( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL,SAVE :: rot(ip1jm,llm) + REAL signe, nugradrs + INTEGER l,ij,iter,lr + Type(Request) :: Request_dissip +c ........................................................ +c + INTEGER :: ijb,ije,jjb,jje + +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c +c CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) +c CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + grx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo(grx,ip1jmp1,llm,0,1,1,0,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gry(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL rotatf_p ( klevel, grx, gry, rot ) +c call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/))) + +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rot_p ( klevel, rot, rot,grx,gry ) +c call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/))) +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rotgam_p ( klevel, rot, rot ) + ENDDO + +c call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/))) + +c +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2,1, .FALSE.,1) +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL nxgrad_p ( klevel, rot, grx, gry ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if(pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gry_out( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + + if(pole_sud) ije=ij_end + DO ij = ijb, ije + grx_out( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrarot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrarot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrarot.F (revision 1634) @@ -0,0 +1,55 @@ +! +! $Header$ +! + SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c + REAL rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c +c +c + CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + DO 10 iter = 1,lr + CALL rotat (klevel,grx, gry, rot ) + CALL filtreg( rot, jjm, klevel, 2,1, .false.,2) + CALL nxgrad (klevel,rot, grx, gry ) +c + DO 5 l = 1, klevel + DO 2 ij = 1, ip1jm + gry( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + DO 3 ij = 1, ip1jmp1 + grx( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrarot_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrarot_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/nxgrarot_p.F (revision 1634) @@ -0,0 +1,101 @@ + SUBROUTINE nxgrarot_p (klevel,xcov, ycov, lr, grx_out, gry_out ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + USE write_field_p + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx_out( ip1jmp1,klevel ), gry_out( ip1jm,klevel ) + REAL,SAVE :: grx( ip1jmp1,llm ), gry( ip1jm,llm ) + +c + REAL,SAVE :: rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) +c CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + grx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gry(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + DO 10 iter = 1,lr +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(grx,ip1jmp1,llm,0,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL rotat_p (klevel,grx, gry, rot ) +c call write_field3d_p('rot',reshape(rot,(/iip1,jjm,llm/))) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + CALL filtreg_p( rot,jjb,jje, jjm, klevel, 2,1, .false.,2) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(rot,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL nxgrad_p (klevel,rot, grx, gry ) +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1, klevel + if(pole_sud) ije=ij_end-iip1 + DO 2 ij = ijb, ije + gry_out( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + if(pole_sud) ije=ij_end + DO 3 ij = ijb, ije + grx_out( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c$OMP END DO NOWAIT +c call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/))) +c call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/))) +c stop + 10 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/omp_chunk.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/omp_chunk.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/omp_chunk.h (revision 1634) @@ -0,0 +1,1 @@ +#define OMP_CHUNK 5 Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/parallel.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/parallel.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/parallel.F90 (revision 1634) @@ -0,0 +1,571 @@ +! +! $Id$ +! + module parallel + USE mod_const_mpi + + LOGICAL,SAVE :: using_mpi=.TRUE. + LOGICAL,SAVE :: using_omp + + integer, save :: mpi_size + integer, save :: mpi_rank + integer, save :: jj_begin + integer, save :: jj_end + integer, save :: jj_nb + integer, save :: ij_begin + integer, save :: ij_end + logical, save :: pole_nord + logical, save :: pole_sud + + integer, allocatable, save, dimension(:) :: jj_begin_para + integer, allocatable, save, dimension(:) :: jj_end_para + integer, allocatable, save, dimension(:) :: jj_nb_para + integer, save :: OMP_CHUNK + integer, save :: omp_rank + integer, save :: omp_size +!$OMP THREADPRIVATE(omp_rank) + + contains + + subroutine init_parallel + USE vampir + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" + + integer :: ierr + integer :: i,j + integer :: type_size + integer, dimension(3) :: blocklen,type + integer :: comp_id + +#ifdef CPP_OMP + INTEGER :: OMP_GET_NUM_THREADS + EXTERNAL OMP_GET_NUM_THREADS + INTEGER :: OMP_GET_THREAD_NUM + EXTERNAL OMP_GET_THREAD_NUM +#endif + +#ifdef CPP_MPI + using_mpi=.TRUE. +#else + using_mpi=.FALSE. +#endif + + +#ifdef CPP_OMP + using_OMP=.TRUE. +#else + using_OMP=.FALSE. +#endif + + call InitVampir + + IF (using_mpi) THEN +#ifdef CPP_MPI + call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr) + call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr) +#endif + ELSE + mpi_size=1 + mpi_rank=0 + ENDIF + + + allocate(jj_begin_para(0:mpi_size-1)) + allocate(jj_end_para(0:mpi_size-1)) + allocate(jj_nb_para(0:mpi_size-1)) + + do i=0,mpi_size-1 + jj_nb_para(i)=(jjm+1)/mpi_size + if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1 + + if (jj_nb_para(i) <= 2 ) then + + write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)." + write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude" + +#ifdef CPP_MPI + IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr) +#endif + endif + + enddo + +! jj_nb_para(0)=11 +! jj_nb_para(1)=25 +! jj_nb_para(2)=25 +! jj_nb_para(3)=12 + + j=1 + + do i=0,mpi_size-1 + + jj_begin_para(i)=j + jj_end_para(i)=j+jj_Nb_para(i)-1 + j=j+jj_Nb_para(i) + + enddo + + jj_begin = jj_begin_para(mpi_rank) + jj_end = jj_end_para(mpi_rank) + jj_nb = jj_nb_para(mpi_rank) + + ij_begin=(jj_begin-1)*iip1+1 + ij_end=jj_end*iip1 + + if (mpi_rank.eq.0) then + pole_nord=.TRUE. + else + pole_nord=.FALSE. + endif + + if (mpi_rank.eq.mpi_size-1) then + pole_sud=.TRUE. + else + pole_sud=.FALSE. + endif + + write(lunout,*)"init_parallel: jj_begin",jj_begin + write(lunout,*)"init_parallel: jj_end",jj_end + write(lunout,*)"init_parallel: ij_begin",ij_begin + write(lunout,*)"init_parallel: ij_end",ij_end + +!$OMP PARALLEL + +#ifdef CPP_OMP +!$OMP MASTER + omp_size=OMP_GET_NUM_THREADS() +!$OMP END MASTER + omp_rank=OMP_GET_THREAD_NUM() +#else + omp_size=1 + omp_rank=0 +#endif +!$OMP END PARALLEL + + end subroutine init_parallel + + + subroutine SetDistrib(jj_Nb_New) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + INTEGER,dimension(0:MPI_Size-1) :: jj_Nb_New + INTEGER :: i + + jj_Nb_Para=jj_Nb_New + + jj_begin_para(0)=1 + jj_end_para(0)=jj_Nb_Para(0) + + do i=1,mpi_size-1 + + jj_begin_para(i)=jj_end_para(i-1)+1 + jj_end_para(i)=jj_begin_para(i)+jj_Nb_para(i)-1 + + enddo + + jj_begin = jj_begin_para(mpi_rank) + jj_end = jj_end_para(mpi_rank) + jj_nb = jj_nb_para(mpi_rank) + + ij_begin=(jj_begin-1)*iip1+1 + ij_end=jj_end*iip1 + + end subroutine SetDistrib + + + + + subroutine Finalize_parallel +#ifdef CPP_COUPLE + use mod_prism_proto +#endif +#ifdef CPP_EARTH +! Ehouarn: surface_data module is in 'phylmd' ... + use surface_data, only : type_ocean + implicit none +#else + implicit none +! without the surface_data module, we declare (and set) a dummy 'type_ocean' + character(len=6),parameter :: type_ocean="dummy" +#endif +! #endif of #ifdef CPP_EARTH + + include "dimensions.h" + include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + integer :: ierr + integer :: i + + if (allocated(jj_begin_para)) deallocate(jj_begin_para) + if (allocated(jj_end_para)) deallocate(jj_end_para) + if (allocated(jj_nb_para)) deallocate(jj_nb_para) + + if (type_ocean == 'couple') then +#ifdef CPP_COUPLE + call prism_terminate_proto(ierr) + IF (ierr .ne. PRISM_Ok) THEN + call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1) + endif +#endif + else +#ifdef CPP_MPI + IF (using_mpi) call MPI_FINALIZE(ierr) +#endif + end if + + end subroutine Finalize_parallel + + subroutine Pack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(in) ::Field + real,dimension(ll*iip1*row), intent(out) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Buffer(Pos)=Field(i,l) + enddo + enddo + + end subroutine Pack_data + + subroutine Unpack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(out) ::Field + real,dimension(ll*iip1*row), intent(in) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Field(i,l)=Buffer(Pos) + enddo + enddo + + end subroutine UnPack_data + + + SUBROUTINE barrier + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + END SUBROUTINE barrier + + + subroutine exchange_hallo(Field,ij,ll,up,down) + USE Vampir + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: up,down + + INTEGER :: ierr + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + INTEGER, DIMENSION(4) :: Request +#ifdef CPP_MPI + INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status +#else + INTEGER, DIMENSION(1,4) :: Status +#endif + INTEGER :: NbRequest + REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down + REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down + INTEGER :: Buffer_size + + IF (using_mpi) THEN + + CALL barrier + + call VTb(VThallo) + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (up.eq.0) then + SendDown=.FALSE. + RecvUp=.FALSE. + endif + + if (down.eq.0) then + SendUp=.FALSE. + RecvDown=.FALSE. + endif + + NbRequest=0 + + IF (SendUp) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_Send_up(Buffer_size)) + call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up) +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + IF (SendDown) THEN + NbRequest=NbRequest+1 + + buffer_size=up*iip1*ll + allocate(Buffer_Send_down(Buffer_size)) + call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + + IF (RecvUp) THEN + NbRequest=NbRequest+1 + buffer_size=up*iip1*ll + allocate(Buffer_recv_up(Buffer_size)) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + + + ENDIF + + IF (RecvDown) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_recv_down(Buffer_size)) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + + ENDIF + +#ifdef CPP_MPI + if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr) +#endif + IF (RecvUp) call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up) + IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) + + call VTe(VThallo) + call barrier + + ENDIF ! using_mpi + + RETURN + + end subroutine exchange_Hallo + + + subroutine Gather_Field(Field,ij,ll,rank) + implicit none +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll,rank + REAL, dimension(ij,ll) :: Field + REAL, dimension(:),allocatable :: Buffer_send + REAL, dimension(:),allocatable :: Buffer_Recv + INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ + INTEGER :: ierr + INTEGER ::i + + IF (using_mpi) THEN + + if (ij==ip1jmp1) then + allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send) + else if (ij==ip1jm) then + allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send) + else + write(lunout,*)ij + stop 'erreur dans Gather_Field' + endif + + if (MPI_Rank==rank) then + allocate(Buffer_Recv(ij*ll)) + +!CDIR NOVECTOR + do i=0,MPI_Size-1 + + if (ij==ip1jmp1) then + Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1 + else if (ij==ip1jm) then + Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1 + else + stop 'erreur dans Gather_Field' + endif + + if (i==0) then + displ(i)=0 + else + displ(i)=displ(i-1)+Recv_count(i-1) + endif + + enddo + + endif + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, & + Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + if (MPI_Rank==rank) then + + if (ij==ip1jmp1) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + else if (ij==ip1jm) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + endif + endif + ENDIF ! using_mpi + + end subroutine Gather_Field + + + subroutine AllGather_Field(Field,ij,ll) + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: ierr + + IF (using_mpi) THEN + call Gather_Field(Field,ij,ll,0) +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + end subroutine AllGather_Field + + subroutine Broadcast_Field(Field,ij,ll,rank) + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: rank + INTEGER :: ierr + + IF (using_mpi) THEN + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + ENDIF + end subroutine Broadcast_Field + + +! Subroutine verif_hallo(Field,ij,ll,up,down) +! implicit none +!#include "dimensions.h" +!#include "paramet.h" +! include 'mpif.h' +! +! INTEGER :: ij,ll +! REAL, dimension(ij,ll) :: Field +! INTEGER :: up,down +! +! REAL,dimension(ij,ll): NewField +! +! NewField=0 +! +! ijb=ij_begin +! ije=ij_end +! if (pole_nord) +! NewField(ij_be + + end module parallel Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/paramet.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/paramet.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/paramet.h (revision 1634) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +!----------------------------------------------------------------------- +! INCLUDE 'paramet.h' + + INTEGER iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1 + INTEGER kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm + INTEGER ijmllm,mvar + INTEGER jcfil,jcfllm + + PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3 & + & ,jjp1=jjm+1-1/jjm) + PARAMETER( llmp1 = llm+1, llmp2 = llm+2, llmm1 = llm-1 ) + PARAMETER( kftd = iim/2 -ndm ) + PARAMETER( ip1jm = iip1*jjm, ip1jmp1= iip1*jjp1 ) + PARAMETER( ip1jmi1= ip1jm - iip1 ) + PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm ) + PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm ) + PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm ) + +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pbar.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pbar.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pbar.F (revision 1634) @@ -0,0 +1,124 @@ +! +! $Header$ +! + SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************* +c +c pext est un argum. d'entree pour le s-pg .. +c pbarx,pbary et pbarxy sont des argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" + +#include "comgeom.h" + + REAL pext( ip1jmp1 ), pbarx ( ip1jmp1 ) + REAL pbary( ip1jm ), pbarxy( ip1jm ) + + INTEGER ij + + + + DO 1 ij = 1, ip1jmp1 - 1 + pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1) + 1 CONTINUE + +c .... correction pour pbarx( iip1,j) ..... + +c ... pbarx(iip1,j)= pbarx(1,j) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jmp1, iip1 + pbarx( ij ) = pbarx( ij - iim ) + 2 CONTINUE + + + DO 3 ij = 1,ip1jm + pbary( ij ) = pext( ij ) * alpha2p3( ij ) + + * pext( ij+iip1 ) * alpha1p4( ij+iip1 ) + 3 CONTINUE + + + DO 5 ij = 1, ip1jm - 1 + pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour pbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + pbarxy( ij ) = pbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pentes_ini.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pentes_ini.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pentes_ini.F (revision 1634) @@ -0,0 +1,474 @@ +! +! $Header$ +! + SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ******************************************************************** +c Transport des traceurs par la methode des pentes +c ******************************************************************** +c Reference possible : Russel. G.L., Lerner J.A.: +c A new Finite-Differencing Scheme for Traceur Transport +c Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 +c ******************************************************************** +c q,w,masse,pbaru et pbarv +c sont des arguments d'entree pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + integer mode + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL q( iip1,jjp1,llm,0:3) + REAL w( ip1jmp1,llm ) + REAL masse( iip1,jjp1,llm) +c Local: +c ------ + LOGICAL limit + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + real masn,mass,zz + INTEGER i,j,l,iq + +c modif Fred 24 03 96 + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2 + real qpn,qps,dqzpn,dqzps + real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1) + real qmin,zq,pente_max +c + REAL SSUM + integer ismax,ismin,lati,latf + EXTERNAL SSUM, ismin,ismax + logical first + save first +c fin modif + + +c modif Fred 24 03 96 + data first/.true./ + + limit = .TRUE. + pente_max=2 +c if (mode.eq.1.or.mode.eq.3) then +c if (mode.eq.1) then + if (mode.ge.1) then + lati=2 + latf=jjm + else + lati=1 + latf=jjp1 + endif + + qmin=0.4995 + qmin=0. + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + print*,coslondlon(i),sinlondlon(i) + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1) + print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1) + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q ( i,j,l,1 )=0. + q ( i,j,l,2 )=0. + q ( i,j,l,3 )=0. + ENDDO + ENDDO + ENDDO + + endif +c Fin modif Fred + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q +c *** Rem : utilisation de SCOPY ulterieurement + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,llm+1-l ) = q ( i,j,l,0 ) + sx( i,j,llm+1-l ) = q ( i,j,l,1 ) + sy( i,j,llm+1-l ) = q ( i,j,l,2 ) + sz( i,j,llm+1-l ) = q ( i,j,l,3 ) + ENDDO + ENDDO + ENDDO + +c PRINT*,'----- S0 just before conversion -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) +c PRINT*,'Q(16,12,1,4)=',q(16,12,1,4) + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm ( i,j,llm+1-l)=masse( i,j,l ) + ENDDO + ENDDO + ENDDO + +c *** On converti les champs S en atome (resp. kg) +c *** Les routines d'advection traitent les champs +c *** a advecter si ces derniers sont en atome (resp. kg) +c *** A optimiser !!! + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0(i,j,l) = s0(i,j,l) * sm ( i,j,l ) + sx(i,j,l) = sx(i,j,l) * sm ( i,j,l ) + sy(i,j,l) = sy(i,j,l) * sm ( i,j,l ) + sz(i,j,l) = sz(i,j,l) * sm ( i,j,l ) + ENDDO + ENDDO + ENDDO + +c ss0 = 0. +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iim +c ss0 = ss0 + s0 ( i,j,l ) +c ENDDO +c ENDDO +c ENDDO +c PRINT*, 'valeur tot s0 avant advection=',ss0 + +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- +c PRINT*,'----- S0 just before ADVX -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) + +c----------------------------------------------------------- +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'avant advx1, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +CCC + if(mode.eq.2) then + do l=1,llm + s0s=0. + s0n=0. + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + smn=0. + sms=0. + do i=1,iim + smn=smn+sm(i,1,l) + sms=sms+sm(i,jjp1,l) + s0n=s0n+s0(i,1,l) + s0s=s0s+s0(i,jjp1,l) + zz=sy(i,1,l)/sm(i,1,l) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=sy(i,jjp1,l)/sm(i,jjp1,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i) + sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i) + enddo + do i=1,iim + s0(i,1,l)=s0n/smn+sy(i,1,l) + s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l) + enddo + + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + + do i=1,iim + sxn(i)=s0(i+1,1,l)-s0(i,1,l) + sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l) +c on rerentre les masses + enddo + do i=1,iim + sy(i,1,l)=sy(i,1,l)*sm(i,1,l) + sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l) + s0(i,1,l)=s0(i,1,l)*sm(i,1,l) + s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l) + sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l) + enddo + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + sy(iip1,1,l)=sy(1,1,l) + sy(iip1,jjp1,l)=sy(1,jjp1,l) + sx(1,1,l)=sx(iip1,1,l) + sx(1,jjp1,l)=sx(iip1,jjp1,l) + enddo + endif + + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'avant advy ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) +c call minmaxq(zq,1.e33,-1.e33,'avant advz ') + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + enddo + enddo + call limz(s0,sz,sm,pente_max) + call advz( limit,dtvr,w,sm,s0,sx,sy,sz ) + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) + do l=1,llm + do j=1,jjp1 + sm(iip1,j,l)=sm(1,j,l) + s0(iip1,j,l)=s0(1,j,l) + sx(iip1,j,l)=sx(1,j,l) + sy(iip1,j,l)=sy(1,j,l) + sz(iip1,j,l)=sz(1,j,l) + enddo + enddo + + +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'apres advx ') +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'apres advx2, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +c *** On repasse les S dans la variable q directement 14/10/94 +c On revient a des rapports de melange en divisant par la masse + +c En dehors des poles: + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c Traitements specifiques au pole + + if(mode.ge.1) then + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo + if(mode.eq.3) then + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l) + dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l) + dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2) + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2) + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + endif + if(mode.eq.1) then +c on filtre les valeurs au bord de la "grande maille pole" + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + enddo + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1) + + endif + + ENDDO + endif + +c bouclage en longitude + do iq=0,3 + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,iq)=q(1,j,l,iq) + enddo + enddo + enddo + +c PRINT*, ' SORTIE DE PENTES --- ca peut glisser ....' + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN +c PRINT*,'------------ BIP-----------' +c PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0) +c PRINT*,'QX(',i,j,l,')=',q(i,j,l,1) +c PRINT*,'QY(',i,j,l,')=',q(i,j,l,2) +c PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE DE PENTES' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + ENDDO + +c PRINT*, '-------------------------------------------' + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + if(q(i,j,l,0).lt.qmin) + , print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0) + enddo + enddo + enddo + RETURN + END + + + + + + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ppm3d.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ppm3d.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ppm3d.F (revision 1634) @@ -0,0 +1,2001 @@ +! +! $Id$ +! + +cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998 +cDate: Wed, 15 Apr 1998 11:37:03 -0400 +cFrom: lin@explorer.gsfc.nasa.gov +cTo: Frederic.Hourdin@lmd.jussieu.fr +cSubject: 3D transport module of the GSFC CTM and GEOS GCM + + +cThis code is sent to you by S-J Lin, DAO, NASA-GSFC + +cNote: this version is intended for machines like CRAY +C-90. No multitasking directives implemented. + + +C ******************************************************************** +C +C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard +C Earth Observing System General Circulation Model (GEOS-GCM), and Data +C Assimilation System (GEOS-DAS). +C +C ******************************************************************** +C +C Purpose: given horizontal winds on a hybrid sigma-p surfaces, +C one call to tpcore updates the 3-D mixing ratio +C fields one time step (NDT). [vertical mass flux is computed +C internally consistent with the discretized hydrostatic mass +C continuity equation of the C-Grid GEOS-GCM (for IGD=1)]. +C +C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based +C on the van Leer or PPM. +C (see Lin and Rood 1996). +C Version 4.5 +C Last modified: Dec. 5, 1996 +C Major changes from version 4.0: a more general vertical hybrid sigma- +C pressure coordinate. +C Subroutines modified: xtp, ytp, fzppm, qckxyz +C Subroutines deleted: vanz +C +C Author: Shian-Jiann Lin +C mail address: +C Shian-Jiann Lin* +C Code 910.3, NASA/GSFC, Greenbelt, MD 20771 +C Phone: 301-286-9540 +C E-mail: lin@dao.gsfc.nasa.gov +C +C *affiliation: +C Joint Center for Earth Systems Technology +C The University of Maryland Baltimore County +C NASA - Goddard Space Flight Center +C References: +C +C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- +C Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. +C +C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of +C the van Leer-type transport schemes and its applications to the moist- +C ure transport in a General Circulation Model. Mon. Wea. Rev., 122, +C 1575-1593. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C + subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR, + & JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax) + +c implicit none + +c rajout de déclarations +c integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd +c integer iu,iiu,j2,jmr,js0,jt +c real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp +c real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru +C +C ******************************************************************** +C +C ============= +C INPUT: +C ============= +C +C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t) +C NC: total # of constituents +C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR +C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1 +C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at +C the model top to NLAY near the surface (see fig. below). +C It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation) +C +C PS1(IMR,JNP): surface pressure at current time (t) +C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2) +C PS2 is replaced by the predicted PS (at t+NDT) on output. +C Note: surface pressure can have any unit or can be multiplied by any +C const. +C +C The pressure at layer edges are defined as follows: +C +C p(i,j,k) = AP(k)*PT + BP(k)*PS(i,j) (1) +C +C Where PT is a constant having the same unit as PS. +C AP and BP are unitless constants given at layer edges +C defining the vertical coordinate. +C BP(1) = 0., BP(NLAY+1) = 1. +C The pressure at the model top is PTOP = AP(1)*PT +C +C For pure sigma system set AP(k) = 1 for all k, PT = PTOP, +C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP. +C +C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn +C is a subset of the following even more general sigma-P-thelta coord. +C currently under development. +C p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa)) +C +C ///////////////////////////////// +C / \ ------------- PTOP -------------- AP(1), BP(1) +C | +C delp(1) | ........... Q(i,j,1) ............ +C | +C W(1) \ / --------------------------------- AP(2), BP(2) +C +C +C +C W(k-1) / \ --------------------------------- AP(k), BP(k) +C | +C delp(K) | ........... Q(i,j,k) ............ +C | +C W(k) \ / --------------------------------- AP(k+1), BP(k+1) +C +C +C +C / \ --------------------------------- AP(NLAY), BP(NLAY) +C | +C delp(NLAY) | ........... Q(i,j,NLAY) ......... +C | +C W(NLAY)=0 \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1) +C ////////////////////////////////// +C +C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2) +C U and V may need to be polar filtered in advance in some cases. +C +C IGD: grid type on which winds are defined. +C IGD = 0: A-Grid [all variables defined at the same point from south +C pole (j=1) to north pole (j=JNP) ] +C +C IGD = 1 GEOS-GCM C-Grid +C [North] +C +C V(i,j) +C | +C | +C | +C U(i-1,j)---Q(i,j)---U(i,j) [EAST] +C | +C | +C | +C V(i,j-1) +C +C U(i, 1) is defined at South Pole. +C V(i, 1) is half grid north of the South Pole. +C V(i,JMR) is half grid south of the North Pole. +C +C V must be defined at j=1 and j=JMR if IGD=1 +C V at JNP need not be given. +C +C NDT: time step in seconds (need not be constant during the course of +C the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5 +C (Lat-Lon) resolution. Smaller values are recommanded if the model +C has a well-resolved stratosphere. +C +C J1 defines the size of the polar cap: +C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg. +C North polar cap edge is located at 90 - (j1-1.5)*180/(JNP-1) deg. +C There are currently only two choices (j1=2 or 3). +C IMR must be an even integer if j1 = 2. Recommended value: J1=3. +C +C IORD, JORD, and KORD are integers controlling various options in E-W, N-S, +C and vertical transport, respectively. Recommended values for positive +C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non- +C positive definite scalars or when linear correlation between constituents +C is to be maintained. +C +C _ORD= +C 1: 1st order upstream scheme (too diffusive, not a useful option; it +C can be used for debugging purposes; this is THE only known "linear" +C monotonic advection scheme.). +C 2: 2nd order van Leer (full monotonicity constraint; +C see Lin et al 1994, MWR) +C 3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984) +C 4: semi-monotonic PPM (same as 3, but overshoots are allowed) +C 5: positive-definite PPM (constraint on the subgrid distribution is +C only strong enough to prevent generation of negative values; +C both overshoots & undershoots are possible). +C 6: un-constrained PPM (nearly diffusion free; slightly faster but +C positivity not quaranteed. Use this option only when the fields +C and winds are very smooth). +C +C *PPM: Piece-wise Parabolic Method +C +C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5. +C for non-positive definite scalars (such as Ertel Potential Vorticity). +C +C The implicit numerical diffusion decreases as _ORD increases. +C The last two options (ORDER=5, 6) should only be used when there is +C significant explicit diffusion (such as a turbulence parameterization). You +C might get dispersive results otherwise. +C No filter of any kind is applied to the constituent fields here. +C +C AE: Radius of the sphere (meters). +C Recommended value for the planet earth: 6.371E6 +C +C fill(logical): flag to do filling for negatives (see note below). +C +C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s). +C (220 m/s is a good value for troposphere model; 280 m/s otherwise) +C +C ============= +C Output +C ============= +C +C Q: mixing ratios at future time (t+NDT) (original values are over-written) +C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic +C relationship. W will have the same unit as PS1 and PS2 (eg, mb). +C W must be divided by NDT to get the correct mass-flux unit. +C The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND +C is the pressure thickness in the "upwind" direction. For example, +C C(k) = W(k)/delp(k) if W(k) > 0; +C C(k) = W(k)/delp(k+1) if W(k) < 0. +C ( W > 0 is downward, ie, toward surface) +C PS2: predicted PS at t+NDT (original values are over-written) +C +C ******************************************************************** +C NOTES: +C This forward-in-time upstream-biased transport scheme reduces to +C the 2nd order center-in-time center-in-space mass continuity eqn. +C if Q = 1 (constant fields will remain constant). This also ensures +C that the computed vertical velocity to be identical to GEOS-1 GCM +C for on-line transport. +C +C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when +C winds are noisy near poles). +C +C Flux-Form Semi-Lagrangian transport in the East-West direction is used +C when and where Courant # is greater than one. +C +C The user needs to change the parameter Jmax or Kmax if the resolution +C is greater than 0.5 deg in N-S or 150 layers in the vertical direction. +C (this TransPort Core is otherwise resolution independent and can be used +C as a library routine). +C +C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd +C order accurate for non-uniform grid (vertical sigma coord.). +C +C Time step is limitted only by transport in the meridional direction. +C (the FFSL scheme is not implemented in the meridional direction). +C +C Since only 1-D limiters are applied, negative values could +C potentially be generated when large time step is used and when the +C initial fields contain discontinuities. +C This does not necessarily imply the integration is unstable. +C These negatives are typically very small. A filling algorithm is +C activated if the user set "fill" to be true. +C +C The van Leer scheme used here is nearly as accurate as the original PPM +C due to the use of a 4th order accurate reference slope. The PPM imple- +C mented here is an improvement over the original and is also based on +C the 4th order reference slope. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C User modifiable parameters +C + parameter (Jmax = 361, kmax = 150) +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C Input-Output arrays +C + + real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP), + & U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1), + & BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax + integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE + integer IMRD2 + real PT + logical cross, fill, dum +C +C Local dynamic arrays +C + real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP), + & fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY), + & WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP), + & delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP), + & UA(IMR,JNP),qtmp(-IMR:2*IMR) +C +C Local static arrays +C + real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax), + & cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax) + data NDT0, NSTEP /0, 0/ + data cross /.true./ + SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML, + & DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK +C + + JMR = JNP -1 + IMJM = IMR*JNP + j2 = JNP - j1 + 1 + NSTEP = NSTEP + 1 +C +C *********** Initialization ********************** + if(NSTEP.eq.1) then +c + write(6,*) '------------------------------------ ' + write(6,*) 'NASA/GSFC Transport Core Version 4.5' + write(6,*) '------------------------------------ ' +c + WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1 + WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT +C +C controles sur les parametres + if(NLAY.LT.6) then + write(6,*) 'NLAY must be >= 6' + stop + endif + if (JNP.LT.NLAY) then + write(6,*) 'JNP must be >= NLAY' + stop + endif + IMRD2=mod(IMR,2) + if (j1.eq.2.and.IMRD2.NE.0) then + write(6,*) 'if j1=2 IMR must be an even integer' + stop + endif + +C + if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then + write(6,*) 'Jmax or Kmax is too small' + stop + endif +C + DO k=1,NLAY + DAP(k) = (AP(k+1) - AP(k))*PT + DBK(k) = BP(k+1) - BP(k) + ENDDO +C + PI = 4. * ATAN(1.) + DL = 2.*PI / REAL(IMR) + DP = PI / REAL(JMR) +C + if(IGD.eq.0) then +C Compute analytic cosine at cell edges + call cosa(cosp,cose,JNP,PI,DP) + else +C Define cosine consistent with GEOS-GCM (using dycore2.0 or later) + call cosc(cosp,cose,JNP,PI,DP) + endif +C + do 15 J=2,JMR +15 acosp(j) = 1. / cosp(j) +C +C Inverse of the Scaled polar cap area. +C + RCAP = DP / (IMR*(1.-COS((j1-1.5)*DP))) + acosp(1) = RCAP + acosp(JNP) = RCAP + endif +C + if(NDT0 .ne. NDT) then + DT = NDT + NDT0 = NDT + + if(Umax .lt. 180.) then + write(6,*) 'Umax may be too small!' + endif + CR1 = abs(Umax*DT)/(DL*AE) + MaxDT = DP*AE / abs(Umax) + 0.5 + write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT + if(MaxDT .lt. abs(NDT)) then + write(6,*) 'Warning!!! NDT maybe too large!' + endif +C + if(CR1.ge.0.95) then + JS0 = 0 + JN0 = 0 + IML = IMR-2 + ZTC = 0. + else + ZTC = acos(CR1) * (180./PI) +C + JS0 = REAL(JMR)*(90.-ZTC)/180. + 2 + JS0 = max(JS0, J1+1) + IML = min(6*JS0/(J1-1)+2, 4*IMR/5) + JN0 = JNP-JS0+1 + endif +C +C + do J=2,JMR + DTDX(j) = DT / ( DL*AE*COSP(J) ) + +c print*,'dtdx=',dtdx(j) + DTDX5(j) = 0.5*DTDX(j) + enddo +C + + DTDY = DT /(AE*DP) +c print*,'dtdy=',dtdy + DTDY5 = 0.5*DTDY +C +c write(6,*) 'J1=',J1,' J2=', J2 + endif +C +C *********** End Initialization ********************** +C +C delp = pressure thickness: the psudo-density in a hydrostatic system. + do k=1,NLAY + do j=1,JNP + do i=1,IMR + delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j) + delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j) + enddo + enddo + enddo + +C + if(j1.ne.2) then + DO 40 IC=1,NC + DO 40 L=1,NLAY + DO 40 I=1,IMR + Q(I, 2,L,IC) = Q(I, 1,L,IC) +40 Q(I,JMR,L,IC) = Q(I,JNP,L,IC) + endif +C +C Compute "tracer density" + DO 550 IC=1,NC + DO 44 k=1,NLAY + DO 44 j=1,JNP + DO 44 i=1,IMR +44 DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k) +550 continue +C + do 1500 k=1,NLAY +C + if(IGD.eq.0) then +C Convert winds on A-Grid to Courant # on C-Grid. + call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + else +C Convert winds on C-grid to Courant # + do 45 j=j1,j2 + do 45 i=2,IMR +45 CRX(i,J) = dtdx(j)*U(i-1,j,k) + +C + do 50 j=j1,j2 +50 CRX(1,J) = dtdx(j)*U(IMR,j,k) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY*V(i,1,k) + endif +C +C Determine JS and JN + JS = j1 + JN = j2 +C + do j=JS0,j1+1,-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JS = j + go to 2222 + endif + enddo + enddo +C +2222 continue + do j=JN0,j2-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JN = j + go to 2233 + endif + enddo + enddo +2233 continue +C + if(j1.ne.2) then ! Enlarged polar cap. + do i=1,IMR + DPI(i, 2,k) = 0. + DPI(i,JMR,k) = 0. + enddo + endif +C +C ******* Compute horizontal mass fluxes ************ +C +C N-S component + do j=j1,j2+1 + D5 = 0.5 * COSE(j) + do i=1,IMR + ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k)) + enddo + enddo +C + do 95 j=j1,j2 + DO 95 i=1,IMR +95 DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j) +C +C Poles + sum1 = ymass(IMR,j1 ) + sum2 = ymass(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + ymass(i,j1 ) + sum2 = sum2 + ymass(i,J2+1) + enddo +C + sum1 = - sum1 * RCAP + sum2 = sum2 * RCAP + do i=1,IMR + DPI(i, 1,k) = sum1 + DPI(i,JNP,k) = sum2 + enddo +C +C E-W component +C + do j=j1,j2 + do i=2,IMR + PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k)) + enddo + enddo +C + do j=j1,j2 + PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k)) + enddo +C + do 110 j=j1,j2 + DO 110 i=1,IMR +110 xmass(i,j) = PU(i,j)*CRX(i,j) +C + DO 120 j=j1,j2 + DO 120 i=1,IMR-1 +120 DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j) +C + DO 130 j=j1,j2 +130 DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j) +C + DO j=j1,j2 + do i=1,IMR-1 + UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j)) + enddo + enddo +C + DO j=j1,j2 + UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j)) + enddo +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajouts pour LMDZ.3.3 +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc + do i=1,IMR + do j=1,JNP + VA(i,j)=0. + enddo + enddo + + do i=1,imr*(JMR-1) + VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3)) + enddo +C + if(j1.eq.2) then + IMH = IMR/2 + do i=1,IMH + VA(i, 1) = 0.5*(CRY(i,2)-CRY(i+IMH,2)) + VA(i+IMH, 1) = -VA(i,1) + VA(i, JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR)) + VA(i+IMH,JNP) = -VA(i,JNP) + enddo + VA(IMR,1)=VA(1,1) + VA(IMR,JNP)=VA(1,JNP) + endif +C +C ****6***0*********0*********0*********0*********0*********0**********72 + do 1000 IC=1,NC +C + do i=1,IMJM + wk1(i,1,1) = 0. + wk1(i,1,2) = 0. + enddo +C +C E-W advective cross term + do 250 j=J1,J2 + if(J.GT.JS .and. J.LT.JN) GO TO 250 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j,k,IC) + qtmp(IMR+1-i) = q(1-i,j,k,IC) + enddo +C + DO 230 i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + wk1(i,j,1) = wk1(i,j,1) - qtmp(i) +230 continue +250 continue +C + if(JN.ne.0) then + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + qtmp(0) = q(IMR,J,k,IC) + qtmp(IMR+1) = q( 1,J,k,IC) +C + do i=1,imr + iu = i - UA(i,j) + wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1)) + enddo + enddo + endif +C ****6***0*********0*********0*********0*********0*********0**********72 +C Contribution from the N-S advection + do i=1,imr*(j2-j1+1) + JT = REAL(J1) - VA(i,j1) + wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC)) + enddo +C + do i=1,IMJM + wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1) + wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2) + enddo +C + if(cross) then +C Add cross terms in the vertical direction. + if(IORD .GE. 2) then + iad = 2 + else + iad = 1 + endif +C + if(JORD .GE. 2) then + jad = 2 + else + jad = 1 + endif + call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad) + call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad) + do j=1,JNP + do i=1,IMR + q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j) + enddo + enddo + endif +C + call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2) + & ,CRX,fx1,xmass,IORD) + + call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY, + & DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD) +C +1000 continue +1500 continue +C +C ******* Compute vertical mass flux (same unit as PS) *********** +C +C 1st step: compute total column mass CONVERGENCE. +C + do 320 j=1,JNP + do 320 i=1,IMR +320 CRY(i,j) = DPI(i,j,1) +C + do 330 k=2,NLAY + do 330 j=1,JNP + do 330 i=1,IMR + CRY(i,j) = CRY(i,j) + DPI(i,j,k) +330 continue +C + do 360 j=1,JNP + do 360 i=1,IMR +C +C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption. +C Changes (increases) to surface pressure = total column mass convergence +C + PS2(i,j) = PS1(i,j) + CRY(i,j) +C +C 3rd step: compute vertical mass flux from mass conservation principle. +C + W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j) + W(i,j,NLAY) = 0. +360 continue +C + do 370 k=2,NLAY-1 + do 370 j=1,JNP + do 370 i=1,IMR + W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j) +370 continue +C + DO 380 k=1,NLAY + DO 380 j=1,JNP + DO 380 i=1,IMR + delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j) +380 continue +C + KRD = max(3, KORD) + do 4000 IC=1,NC +C +C****6***0*********0*********0*********0*********0*********0**********72 + + call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI, + & DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD) +C + + if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2, + & cosp,acosp,.false.,IC,NSTEP) +C +C Recover tracer mixing ratio from "density" using predicted +C "air density" (pressure thickness) at time-level n+1 +C + DO k=1,NLAY + DO j=1,JNP + DO i=1,IMR + Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k) +c print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC) + enddo + enddo + enddo +C + if(j1.ne.2) then + DO 400 k=1,NLAY + DO 400 I=1,IMR +c j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord + Q(I, 2,k,IC) = Q(I, 1,k,IC) + Q(I,JMR,k,IC) = Q(I,JNP,k,IC) +400 CONTINUE + endif +4000 continue +C + if(j1.ne.2) then + DO 5000 k=1,NLAY + DO 5000 i=1,IMR + W(i, 2,k) = W(i, 1,k) + W(i,JMR,k) = W(i,JNP,k) +5000 continue + endif +C + RETURN + END +C +C****6***0*********0*********0*********0*********0*********0**********72 + subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6, + & flux,wk1,wk2,wz2,delp,KORD) + parameter ( kmax = 150 ) + parameter ( R23 = 2./3., R3 = 1./3.) + real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY), + & wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY), + & DQDT(IMR,JNP,NLAY) +C Assuming JNP >= NLAY + real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*), + & wz2(IMR,*) +C + JMR = JNP - 1 + IMJM = IMR*JNP + NLAYM1 = NLAY - 1 +C + LMT = KORD - 3 +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Compute DC for PPM +C ****6***0*********0*********0*********0*********0*********0**********72 +C + do 1000 k=1,NLAYM1 + do 1000 i=1,IMJM + DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k) +1000 continue +C + DO 1220 k=2,NLAYM1 + DO 1220 I=1,IMJM + c0 = delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1)) + c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k)) + c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k)) + tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1)) + Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k) + Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) + DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp) +1220 CONTINUE + +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Loop over latitudes (to save memory) +C ****6***0*********0*********0*********0*********0*********0**********72 +C + DO 2000 j=1,JNP + if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000 +C + DO k=1,NLAY + DO i=1,IMR + wz2(i,k) = WZ(i,j,k) + wk1(i,k) = P(i,j,k) + wk2(i,k) = delp(i,j,k) + flux(i,k) = DC(i,j,k) !this flux is actually the monotone slope + enddo + enddo +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute first guesses at cell interfaces +C First guesses are required to be continuous. +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C three-cell parabolic subgrid distribution at model top +C two-cell parabolic with zero gradient subgrid distribution +C at the surface. +C +C First guess top edge value + DO 10 i=1,IMR +C three-cell PPM +C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp + a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/ + & (wk2(i,1)+wk2(i,2)) ) / + & ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) ) + b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - + & R23*a*(2.*wk2(i,1)+wk2(i,2)) + AL(i,1) = wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b) + AL(i,2) = wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1) +C +C Check if change sign + if(wk1(i,1)*AL(i,1).le.0.) then + AL(i,1) = 0. + flux(i,1) = 0. + else + flux(i,1) = wk1(i,1) - AL(i,1) + endif +10 continue +C +C Bottom + DO 15 i=1,IMR +C 2-cell PPM with zero gradient right at the surface +C + fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 / + & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1))) + AR(i,NLAY) = wk1(i,NLAY) + fct + AL(i,NLAY) = wk1(i,NLAY) - (fct+fct) + if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0. + flux(i,NLAY) = AR(i,NLAY) - wk1(i,NLAY) +15 continue + +C +C****6***0*********0*********0*********0*********0*********0**********72 +C 4th order interpolation in the interior. +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 14 k=3,NLAYM1 + DO 12 i=1,IMR + c1 = DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k)) + c2 = 2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1)) + A1 = (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k)) + A2 = (wk2(i,k )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1)) + AL(i,k) = wk1(i,k-1) + c1 + c2 * + & ( wk2(i,k )*(c1*(A1 - A2)+A2*flux(i,k-1)) - + & wk2(i,k-1)*A1*flux(i,k) ) +C print *,'AL1',i,k, AL(i,k) +12 CONTINUE +14 continue +C + do 20 i=1,IMR*NLAYM1 + AR(i,1) = AL(i,2) +C print *,'AR1',i,AR(i,1) +20 continue +C + do 30 i=1,IMR*NLAY + A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1))) +C print *,'A61',i,A6(i,1) +30 continue +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Top & Bot always monotonic + call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0) + call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY), + & wk1(1,NLAY),IMR,0) +C +C Interior depending on KORD + if(LMT.LE.2) + & call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2), + & IMR*(NLAY-2),LMT) +C +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 140 i=1,IMR*NLAYM1 + IF(wz2(i,1).GT.0.) then + CM = wz2(i,1) / wk2(i,1) + flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM)) + else +C print *,'test2-0',i,j,wz2(i,1),wk2(i,2) + CP= wz2(i,1) / wk2(i,2) +C print *,'testCP',CP + flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP)) +C print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23 + endif +140 continue +C + DO 250 i=1,IMR*NLAYM1 + flux(i,2) = wz2(i,1) * flux(i,2) +250 continue +C + do 350 i=1,IMR + DQ(i,j, 1) = DQ(i,j, 1) - flux(i, 2) + DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY) +350 continue +C + do 360 k=2,NLAYM1 + do 360 i=1,IMR +360 DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1) +2000 continue + return + end +C + subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC, + & fx1,xmass,IORD) + dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP) + & ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML) + dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR) +C + IMP = IMR + 1 +C +C van Leer at high latitudes + jvan = max(1,JNP/18) + j1vl = j1+jvan + j2vl = j2-jvan +C + do 1310 j=j1,j2 +C + do i=1,IMR + qtmp(i) = q(i,j) + enddo +C + if(j.ge.JN .or. j.le.JS) goto 2222 +C ************* Eulerian ********** +C + qtmp(0) = q(IMR,J) + qtmp(-1) = q(IMR-1,J) + qtmp(IMP) = q(1,J) + qtmp(IMP+1) = q(2,J) +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1406 i=1,IMR + iu = REAL(i) - uc(i,j) +1406 fx1(i) = qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) + DC(0) = DC(IMR) +C + if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then + DO 1408 i=1,IMR + iu = REAL(i) - uc(i,j) +1408 fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j)) + else + call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD) + endif +C + ENDIF +C + DO 1506 i=1,IMR +1506 fx1(i) = fx1(i)*xmass(i,j) +C + goto 1309 +C +C ***** Conservative (flux-form) Semi-Lagrangian transport ***** +C +2222 continue +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j) + qtmp(IMP-i) = q(1-i,j) + enddo +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1306 i=1,IMR + itmp = INT(uc(i,j)) + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1306 fx1(i) = (uc(i,j) - itmp)*qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) +C + do i=-IML,0 + DC(i) = DC(IMR+i) + DC(IMP-i) = DC(1-i) + enddo +C + DO 1307 i=1,IMR + itmp = INT(uc(i,j)) + rut = uc(i,j) - itmp + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1307 fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut)) + ENDIF +C + do 1308 i=1,IMR + IF(uc(i,j).GT.1.) then +CDIR$ NOVECTOR + do ist = ISAVE(i),i-1 + fx1(i) = fx1(i) + qtmp(ist) + enddo + elseIF(uc(i,j).LT.-1.) then + do ist = i,ISAVE(i)-1 + fx1(i) = fx1(i) - qtmp(ist) + enddo +CDIR$ VECTOR + endif +1308 continue + do i=1,IMR + fx1(i) = PU(i,j)*fx1(i) + enddo +C +C *************************************** +C +1309 fx1(IMP) = fx1(1) + DO 1215 i=1,IMR +1215 DQ(i,j) = DQ(i,j) + fx1(i)-fx1(i+1) +C +C *************************************** +C +1310 continue + return + end +C + subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1) + DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR) + integer LMT +c logical first +c data first /.true./ +c SAVE LMT +c if(first) then +C +C correction calcul de LMT a chaque passage pour pouvoir choisir +c plusieurs schemas PPM pour differents traceurs +c IF (IORD.LE.0) then +c if(IMR.GE.144) then +c LMT = 0 +c elseif(IMR.GE.72) then +c LMT = 1 +c else +c LMT = 2 +c endif +c else +c LMT = IORD - 3 +c endif +C + LMT = IORD - 3 +c write(6,*) 'PPM option in E-W direction = ', LMT +c first = .false. +C endif +C + DO 10 i=1,IMR +10 AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3 +C + do 20 i=1,IMR-1 +20 AR(i) = AL(i+1) + AR(IMR) = AL(1) +C + do 30 i=1,IMR +30 A6(i) = 3.*(p(i)+p(i) - (AL(i)+AR(i))) +C + if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT) +C + AL(0) = AL(IMR) + AR(0) = AR(IMR) + A6(0) = A6(IMR) +C + DO i=1,IMR + IF(UT(i).GT.0.) then + flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) + + & A6(i-1)*(1.-R23*UT(i)) ) + else + flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + + & A6(i)*(1.+R23*UT(i))) + endif + enddo + return + end +C + subroutine xmist(IMR,IML,P,DC) + parameter( R24 = 1./24.) + dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML) +C + do 10 i=1,IMR + tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2)) + Pmax = max(P(i-1), p(i), p(i+1)) - p(i) + Pmin = p(i) - min(P(i-1), p(i), p(i+1)) +10 DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp) + return + end +C + subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2 + & ,ymass,fx,A6,AR,AL,JORD) + dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP) + & ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP) +C Work array + DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) +C + JMR = JNP - 1 + len = IMR*(J2-J1+2) +C + if(JORD.eq.1) then + DO 1000 i=1,len + JT = REAL(J1) - VC(i,J1) +1000 fx(i,j1) = p(i,JT) + else + + call ymist(IMR,JNP,j1,P,DC2,4) +C + if(JORD.LE.0 .or. JORD.GE.3) then + + call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD) + + else + DO 1200 i=1,len + JT = REAL(J1) - VC(i,J1) +1200 fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT) + endif + endif +C + DO 1300 i=1,len +1300 fx(i,j1) = fx(i,j1)*ymass(i,j1) +C + DO 1400 j=j1,j2 + DO 1400 i=1,IMR +1400 DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j) +C +C Poles + sum1 = fx(IMR,j1 ) + sum2 = fx(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + fx(i,j1 ) + sum2 = sum2 + fx(i,J2+1) + enddo +C + sum1 = DQ(1, 1) - sum1 * RCAP + sum2 = DQ(1,JNP) + sum2 * RCAP + do i=1,IMR + DQ(i, 1) = sum1 + DQ(i,JNP) = sum2 + enddo +C + if(j1.ne.2) then + do i=1,IMR + DQ(i, 2) = sum1 + DQ(i,JMR) = sum2 + enddo + endif +C + return + end +C + subroutine ymist(IMR,JNP,j1,P,DC,ID) + parameter ( R24 = 1./24. ) + dimension P(IMR,JNP),DC(IMR,JNP) +C + IMH = IMR / 2 + JMR = JNP - 1 + IJM3 = IMR*(JMR-3) +C + IF(ID.EQ.2) THEN + do 10 i=1,IMR*(JMR-1) + tmp = 0.25*(p(i,3) - p(i,1)) + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +10 CONTINUE + ELSE + do 12 i=1,IMH +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +12 CONTINUE + do 14 i=IMH+1,IMR +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +14 CONTINUE +C + do 15 i=1,IJM3 + tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24 + Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3) + Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4)) + DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp) +15 CONTINUE + ENDIF +C + if(j1.ne.2) then + do i=1,IMR + DC(i,1) = 0. + DC(i,JNP) = 0. + enddo + else +C Determine slopes in polar caps for scalars! +C + do 13 i=1,IMH +C South + tmp = 0.25*(p(i,2) - p(i+imh,2)) + Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1) + Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2)) + DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp) +C North. + tmp = 0.25*(p(i+imh,JMR) - p(i,JMR)) + Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP) + Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR)) + DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp) +13 continue +C + do 25 i=imh+1,IMR + DC(i, 1) = - DC(i-imh, 1) + DC(i,JNP) = - DC(i-imh,JNP) +25 continue + endif + return + end +C + subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*) +C Local work arrays. + real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) + integer LMT +c logical first +C data first /.true./ +C SAVE LMT +C + IMH = IMR / 2 + JMR = JNP - 1 + j11 = j1-1 + IMJM1 = IMR*(J2-J1+2) + len = IMR*(J2-J1+3) +C if(first) then +C IF(JORD.LE.0) then +C if(JMR.GE.90) then +C LMT = 0 +C elseif(JMR.GE.45) then +C LMT = 1 +C else +C LMT = 2 +C endif +C else +C LMT = JORD - 3 +C endif +C +C first = .false. +C endif +C +c modifs pour pouvoir choisir plusieurs schemas PPM + LMT = JORD - 3 +C + DO 10 i=1,IMR*JMR + AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3 + AR(i,1) = AL(i,2) +10 CONTINUE +C +CPoles: +C + DO i=1,IMH + AL(i,1) = AL(i+IMH,2) + AL(i+IMH,1) = AL(i,2) +C + AR(i,JNP) = AR(i+IMH,JMR) + AR(i+IMH,JNP) = AR(i,JMR) + ENDDO + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajout pour LMDZ.3.3 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + AR(IMR,1)=AL(1,1) + AR(IMR,JNP)=AL(1,JNP) +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + do 30 i=1,len +30 A6(i,j11) = 3.*(p(i,j11)+p(i,j11) - (AL(i,j11)+AR(i,j11))) +C + if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11) + & ,AL(1,j11),P(1,j11),len,LMT) +C + + DO 140 i=1,IMJM1 + IF(VC(i,j1).GT.0.) then + flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) + + & A6(i,j11)*(1.-R23*VC(i,j1)) ) + else + flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) + + & A6(i,j1)*(1.+R23*VC(i,j1))) + endif +140 continue + return + end +C + subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD) + REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP) + REAL WK(IMR,-1:JNP+2) +C + JMR = JNP-1 + IMH = IMR/2 + do j=1,JNP + do i=1,IMR + wk(i,j) = p(i,j) + enddo + enddo +C Poles: + do i=1,IMH + wk(i, -1) = p(i+IMH,3) + wk(i+IMH,-1) = p(i,3) + wk(i, 0) = p(i+IMH,2) + wk(i+IMH,0) = p(i,2) + wk(i,JNP+1) = p(i+IMH,JMR) + wk(i+IMH,JNP+1) = p(i,JMR) + wk(i,JNP+2) = p(i+IMH,JNP-2) + wk(i+IMH,JNP+2) = p(i,JNP-2) + enddo +c write(*,*) 'toto 1' +C -------------------------------- + IF(IAD.eq.2) then + do j=j1-1,j2+1 + do i=1,IMR +c write(*,*) 'avt NINT','i=',i,'j=',j + JP = NINT(VA(i,j)) + rv = JP - VA(i,j) +c write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv + JP = j - JP +c write(*,*) 'JP2=',JP + a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp) + b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1)) +c write(*,*) 'a1=',a1,'b1=',b1 + ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j) + enddo + enddo +c write(*,*) 'toto 2' +C + ELSEIF(IAD.eq.1) then + do j=j1-1,j2+1 + do i=1,imr + JP = REAL(j)-VA(i,j) + ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1)) + enddo + enddo + ENDIF +C + if(j1.ne.2) then + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,2) + sum2 = sum2 + ady(i,JMR) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 2) = sum1 + ady(i,JMR) = sum2 + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + else +C Poles: + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,1) + sum2 = sum2 + ady(i,JNP) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + endif +C + return + end +C + subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD) + REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP) +C + JMR = JNP-1 + do 1309 j=j1,j2 + if(J.GT.JS .and. J.LT.JN) GO TO 1309 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + do i=-IML,0 + qtmp(i) = p(IMR+i,j) + qtmp(IMR+1-i) = p(1-i,j) + enddo +C + IF(IAD.eq.2) THEN + DO i=1,IMR + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then + DO i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + enddo + ENDIF +C + do i=1,IMR + adx(i,j) = adx(i,j) - p(i,j) + enddo +1309 continue +C +C Eulerian upwind +C + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + qtmp(0) = p(IMR,J) + qtmp(IMR+1) = p(1,J) +C + IF(IAD.eq.2) THEN + qtmp(-1) = p(IMR-1,J) + qtmp(IMR+2) = p(2,J) + do i=1,imr + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then +C 1st order + DO i=1,IMR + IP = i - UA(i,j) + adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1)) + enddo + ENDIF + enddo +C + if(j1.ne.2) then + do i=1,IMR + adx(i, 2) = 0. + adx(i,JMR) = 0. + enddo + endif +C set cross term due to x-adv at the poles to zero. + do i=1,IMR + adx(i, 1) = 0. + adx(i,JNP) = 0. + enddo + return + end +C + subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT) +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + parameter ( R12 = 1./12. ) + dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM) +C + if(LMT.eq.0) then +C Full constraint + do 100 i=1,IM + if(DC(i).eq.0.) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + else + da1 = AR(i) - AL(i) + da2 = da1**2 + A6DA = A6(i)*da1 + if(A6DA .lt. -da2) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + elseif(A6DA .gt. da2) then + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif + endif +100 continue + elseif(LMT.eq.1) then +C Semi-monotonic constraint + do 150 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +150 continue + elseif(LMT.eq.2) then + do 250 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250 + fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12 + if(fmin.ge.0.) go to 250 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +250 continue + endif + return + end +C + subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*) +C + do 35 j=j1,j2 + do 35 i=2,IMR +35 CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j)) +C + do 45 j=j1,j2 +45 CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j)) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY5*(V(i,2)+V(i,1)) + return + end +C + subroutine cosa(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) + JMR = JNP-1 + do 55 j=2,JNP + ph5 = -0.5*PI + (REAL(J-1)-0.5)*DP +55 cose(j) = cos(ph5) +C + JEQ = (JNP+1) / 2 + if(JMR .eq. 2*(JMR/2) ) then + do j=JNP, JEQ+1, -1 + cose(j) = cose(JNP+2-j) + enddo + else +C cell edge at equator. + cose(JEQ+1) = 1. + do j=JNP, JEQ+2, -1 + cose(j) = cose(JNP+2-j) + enddo + endif +C + do 66 j=2,JMR +66 cosp(j) = 0.5*(cose(j)+cose(j+1)) + cosp(1) = 0. + cosp(JNP) = 0. + return + end +C + subroutine cosc(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) +C + phi = -0.5*PI + do 55 j=2,JNP-1 + phi = phi + DP +55 cosp(j) = cos(phi) + cosp( 1) = 0. + cosp(JNP) = 0. +C + do 66 j=2,JNP + cose(j) = 0.5*(cosp(j)+cosp(j-1)) +66 CONTINUE +C + do 77 j=2,JNP-1 + cosp(j) = 0.5*(cose(j)+cose(j+1)) +77 CONTINUE + return + end +C + SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, + & cross,IC,NSTEP) +C + parameter( tiny = 1.E-60 ) + DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*) + logical cross +C + NLAYM1 = NLAY-1 + len = IMR*(j2-j1+1) + ip = 0 +C +C Top layer + L = 1 + icr = 1 + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 50 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 50 +C + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 50 +C +C Vertical filling... + do i=1,len + IF( Q(i,j1,1).LT.0.) THEN + ip = ip + 1 + Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1) + Q(i,j1,1) = 0. + endif + enddo +C +50 continue + DO 225 L = 2,NLAYM1 + icr = 1 +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 225 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) go to 225 + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 225 +C + do i=1,len + IF( Q(I,j1,L).LT.0.) THEN +C + ip = ip + 1 +C From above + qup = Q(I,j1,L-1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,L-1) = qup - dup + Q(I,j1,L ) = dup-qly +C Below + Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L) + Q(I,j1,L) = 0. + ENDIF + ENDDO +225 CONTINUE +C +C BOTTOM LAYER + sum = 0. + L = NLAY +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 911 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 911 +C + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + if(icr.eq.0) goto 911 +C + DO I=1,len + IF( Q(I,j1,L).LT.0.) THEN + ip = ip + 1 +c +C From above +C + qup = Q(I,j1,NLAYM1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,NLAYM1) = qup - dup +C From "below" the surface. + sum = sum + qly-dup + Q(I,j1,L) = 0. + ENDIF + ENDDO +C +911 continue +C + if(ip.gt.IMR) then + write(6,*) 'IC=',IC,' STEP=',NSTEP, + & ' Vertical filling pts=',ip + endif +C + if(sum.gt.1.e-25) then + write(6,*) IC,NSTEP,' Mass source from the ground=',sum + endif + RETURN + END +C + subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + dimension q(IMR,*),cosp(*),acosp(*) + icr = 0 + do 65 j=j1+1,j2-1 + DO 50 i=1,IMR-1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(i+1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i+1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(i+1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i+1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +50 continue + if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65 + DO 55 i=2,IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(i-1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i-1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(i-1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i-1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C ***************************************** +C i=1 + i=1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(IMR,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(IMR,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(IMR,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(IMR,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +C i=IMR + i=IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +65 continue +C + do i=1,IMR + if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then + icr = 1 + goto 80 + endif + enddo +C +80 continue +C + if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then + icr = 1 + endif +C + return + end +C + subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + dimension q(IMR,*),cosp(*),acosp(*) +c logical first +c data first /.true./ +c save cap1 +C +c if(first) then + DP = 4.*ATAN(1.)/REAL(JNP-1) + CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP +c first = .false. +c endif +C + ipy = 0 + do 55 j=j1+1,j2-1 + DO 55 i=1,IMR + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C North + dn = q(i,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C + do i=1,imr + IF(q(i,j1).LT.0.) THEN + ipy = 1 + dq = - q(i,j1)*cosp(j1) +C North + dn = q(i,j1+1)*cosp(j1+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j1+1) = (dn - d1)*acosp(j1+1) + q(i,j1) = (d1 - dq)*acosp(j1) + tiny + endif + enddo +C + j = j2 + do i=1,imr + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif + enddo +C +C Check Poles. + if(q(1,1).lt.0.) then + dq = q(1,1)*cap1/REAL(IMR)*acosp(j1) + do i=1,imr + q(i,1) = 0. + q(i,j1) = q(i,j1) + dq + if(q(i,j1).lt.0.) ipy = 1 + enddo + endif +C + if(q(1,JNP).lt.0.) then + dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2) + do i=1,imr + q(i,JNP) = 0. + q(i,j2) = q(i,j2) + dq + if(q(i,j2).lt.0.) ipy = 1 + enddo + endif +C + return + end +C + subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny) + dimension q(IMR,*),qtmp(JNP,IMR) +C + ipx = 0 +C Copy & swap direction for vectorization. + do 25 i=1,imr + do 25 j=j1,j2 +25 qtmp(j,i) = q(i,j) +C + do 55 i=2,imr-1 + do 55 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +55 continue +c + i=1 + do 65 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,imr)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,imr) = qtmp(j,imr) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +65 continue + i=IMR + do 75 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,1) = qtmp(j,1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +75 continue +C + if(ipx.ne.0) then + do 85 j=j1,j2 + do 85 i=1,imr +85 q(i,j) = qtmp(j,i) + else +C +C Poles. + if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1 + endif + return + end +C + subroutine zflip(q,im,km,nc) +C This routine flip the array q (in the vertical). + real q(im,km,nc) +C local dynamic array + real qtmp(im,km) +C + do 4000 IC = 1, nc +C + do 1000 k=1,km + do 1000 i=1,im + qtmp(i,k) = q(i,km+1-k,IC) +1000 continue +C + do 2000 i=1,im*km +2000 q(i,1,IC) = qtmp(i,1) +4000 continue + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/prather.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/prather.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/prather.F (revision 1634) @@ -0,0 +1,359 @@ +! +! $Header$ +! + SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ************************************************ +c Transport des traceurs par la methode de prather +c Ref : +c +c ************************************************ +c q,w,pext,pbaru et pbarv : arguments d'entree pour le s-pg +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + INTEGER iq,nt + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL masse(iip1,jjp1,llm) + REAL q( iip1,jjp1,llm,0:9) + REAL w( ip1jmp1,llm ) + integer ordre,ilim + +c Local: +c ------ + LOGICAL limit + real zq(iip1,jjp1,llm) + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + REAL sxx( iip1,jjp1,llm) + REAL sxy( iip1,jjp1,llm) + REAL sxz( iip1,jjp1,llm) + REAL syy( iip1,jjp1,llm ) + REAL syz( iip1,jjp1,llm ) + REAL szz( iip1,jjp1,llm ),zz + INTEGER i,j,l,indice + real sxn(iip1),sxs(iip1) + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + real qmin,qmax + save qmin,qmax + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps + real masn,mass +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + logical first + save first + + data first/.true./ + data qmin,qmax/-1.e33,1.e33/ + + +c========================================================================== +c========================================================================== +c MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt +c========================================================================== +c========================================================================== + REAL dt +c========================================================================== + limit = .TRUE. + + if(first) then + print*,'SCHEMA PRATHER' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,l,1 )=0. + q( i,j,l,2)=0. + q( i,j,l,3)=0. + q( i,j,l,4)=0. + q( i,j,l,5)=0. + q( i,j,l,6)=0. + q( i,j,l,7)=0. + q( i,j,l,8)=0. + q( i,j,l,9)=0. + ENDDO + ENDDO + ENDDO + endif +c Fin modif Fred + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm( i,j,llm+1-l ) =masse(i,j,l) + ENDDO + ENDDO + ENDDO + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l) + sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l) + sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l) + sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l) + sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l) + sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l) + sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l) + syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l) + syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l) + szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l) + ENDDO + ENDDO + ENDDO +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- + do indice =1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + +c--------------------------------------------------------- + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + sxz(i,j,1)=0. + sxz(i,j,llm)=0. + syz(i,j,1)=0. + syz(i,j,llm)=0. + szz(i,j,1)=0. + szz(i,j,llm)=0. + enddo + enddo + call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + +c--------------------------------------------------------- + +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + DO l = 1,llm + DO j = 1,jjp1 + s0( iip1,j,l)=s0( 1,j,l ) + sx( iip1,j,l)=sx( 1,j,l ) + sy( iip1,j,l)=sy( 1,j,l ) + sz( iip1,j,l)=sz( 1,j,l ) + sxx( iip1,j,l)=sxx( 1,j,l ) + sxy( iip1,j,l)=sxy( 1,j,l) + sxz( iip1,j,l)=sxz( 1,j,l ) + syy( iip1,j,l)=syy( 1,j,l ) + syz( iip1,j,l)=syz( 1,j,l) + szz( iip1,j,l)=szz( 1,j,l ) + ENDDO + ENDDO + do indice=1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do +c--------------------------------------------------------- +c--------------------------------------------------------- +c *** On repasse les S dans la variable qpr +c *** On repasse les S dans la variable q directement 14/10/94 + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c--------------------------------------------------------- +c go to 777 +c filtrages aux poles + +c Traitements specifiques au pole + +c filtrages aux poles + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo +c enddo +c print*,'qpn',qpn,'qps',qps +c print*,'dqzpn',dqzpn,'dqzps',dqzps +c enddo + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + $ (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0) + $ +q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + $ (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + $ -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + END DO + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)= + $ q(iip1,jjp1,llm+1-l,1) + enddo + do l=1,llm + do i=1,iim + q( i,1,llm+1-l,4)=0. + q( i,jjp1,llm+1-l,4)=0. + q( i,1,llm+1-l,5)=0. + q( i,jjp1,llm+1-l,5)=0. + q( i,1,llm+1-l,6)=0. + q( i,jjp1,llm+1-l,6)=0. + q( i,1,llm+1-l,7)=0. + q( i,jjp1,llm+1-l,7)=0. + q( i,1,llm+1-l,8)=0. + q( i,jjp1,llm+1-l,8)=0. + q( i,1,llm+1-l,9)=0. + q( i,jjp1,llm+1-l,9)=0. + enddo + ENDDO + +777 continue +c +c bouclage en longitude + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,0)=q(1,j,l,0) + q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0) + q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1) + q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2) + q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3) + q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4) + q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5) + q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6) + q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7) + q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8) + q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9) + enddo + enddo + DO l = 1,llm + DO j = 2,jjm + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0), + $ q(i,j-1,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2), + $ q(i,j-1,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE D'' ADVZP' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + do j=1,jjp1,jjm + do i=1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP 2-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) + + q(i,j,l,0)=0. +c STOP + ENDIF + enddo + enddo + ENDDO + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pres2lev.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pres2lev.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pres2lev.F90 (revision 1634) @@ -0,0 +1,74 @@ +! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $ +! +!****************************************************** +SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp) +! +! interpolation lineaire pour passer +! a une nouvelle discretisation verticale pour +! les variables de GCM +! Francois Forget (01/1995) +! MOdif remy roca 12/97 pour passer de pres2sig +! Modif F.Codron 07/08 po en 3D +!********************************************************** + + IMPLICIT NONE + +! Declarations: +! ============== +! +! ARGUMENTS +! """"""""" + LOGICAL, INTENT(IN) :: ok_invertp + INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches + INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches + + REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille + REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille + + INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal + + REAL, INTENT(IN) :: varo(ni*nj,lmo) ! var dans l'ancienne grille + REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille + + REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo) + +! Autres variables +! """""""""""""""" + INTEGER :: ln ,lo, k + REAL :: coef + + +! Inversion de l'ordre des niveaux verticaux + IF (ok_invertp) THEN + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lmo+1-lo) + zvaro(k,lo)=varo(k,lmo+1-lo) + ENDDO + ENDDO + ELSE + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lo) + zvaro(k,lo)=varo(k,lo) + ENDDO + ENDDO + ENDIF + + DO ln=1,lmn + DO lo=1,lmo-1 + DO k=1,ni*nj + IF (pn(k,ln) >= zpo(k,1) ) THEN + varn(k,ln) = zvaro(k,1) + ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN + varn(k,ln) = zvaro(k,lmo) + ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN + coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo)) + varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo)) + ENDIF + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE pres2lev Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pression.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pression.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pression.F (revision 1634) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE pression( ngrid, ap, bp, ps, p ) +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + DO l = 1, llmp1 + DO ij = 1, ngrid + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pression_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pression_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/pression_p.F (revision 1634) @@ -0,0 +1,40 @@ + SUBROUTINE pression_p( ngrid, ap, bp, ps, p ) + USE parallel +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + INTEGER ijb,ije + + + ijb=ij_begin-iip1 + ije=ij_end+2*iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 + DO ij = ijb, ije + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/profvert.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/profvert.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/profvert.def (revision 1634) @@ -0,0 +1,23 @@ +! +! $Header$ +! +nom_courbes=F +titre=/home/hourdin/LMDZ4/libf/dyn3d +xinf=0. +xsup=669. +yinf=6.5 +ysup=10.5 +axtxtx=sols +axtxty=pressure (mb) +pathcham=. +lstyles=1 9999 +linewidth=.2 +lcolors=1 9999 +frwidth=.5 +repery0=T +txtheight=2.5 +freecoord=/d2/hourdin/Ames/saison.def + +determination du champ physique +xlength=195. +ylength=105. Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/psextbar.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/psextbar.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/psextbar.F (revision 1634) @@ -0,0 +1,107 @@ +! +! $Header$ +! + SUBROUTINE psextbar ( ps, psexbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************** +c +c ps est un argum. d'entree pour le s-pg .. +c psexbarxy est un argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 ) + + INTEGER l, ij +c + + DO ij = 1, ip1jmp1 + pext(ij) = ps(ij) * aire(ij) + ENDDO + + + DO 5 ij = 1, ip1jm - 1 + psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour psexbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + psexbarxy( ij ) = psexbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/q_sat.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/q_sat.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/q_sat.F (revision 1634) @@ -0,0 +1,72 @@ +! +! $Header$ +! +c +c + + subroutine q_sat(np,temp,pres,qsat) +c + IMPLICIT none +c====================================================================== +c Autheur(s): Z.X. Li (LMD/CNRS) +c reecriture vectorisee par F. Hourdin. +c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.) +c====================================================================== +c Arguments: +c kelvin---input-R: temperature en Kelvin +c millibar--input-R: pression en mb +c +c q_sat----output-R: vapeur d'eau saturante en kg/kg +c====================================================================== +c + integer np + REAL temp(np),pres(np),qsat(np) +c + REAL r2es + PARAMETER (r2es=611.14 *18.0153/28.9644) +c + REAL r3les, r3ies, r3es + PARAMETER (R3LES=17.269) + PARAMETER (R3IES=21.875) +c + REAL r4les, r4ies, r4es + PARAMETER (R4LES=35.86) + PARAMETER (R4IES=7.66) +c + REAL rtt + PARAMETER (rtt=273.16) +c + REAL retv + PARAMETER (retv=28.9644/18.0153 - 1.0) + + real zqsat + integer ip +c +C ------------------------------------------------------------------ +c +c + + do ip=1,np + +c write(*,*)'kelvin,millibar=',kelvin,millibar +c write(*,*)'temp,pres=',temp(ip),pres(ip) +c + IF (temp(ip) .LE. rtt) THEN + r3es = r3ies + r4es = r4ies + ELSE + r3es = r3les + r4es = r4les + ENDIF +c + zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es)) + zqsat=MIN(0.5,ZQSAT) + zqsat=zqsat/(1.-retv *zqsat) +c + qsat(ip)= zqsat +c write(*,*)'qsat=',qsat(ip) + + enddo +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/qminimum_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/qminimum_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/qminimum_p.F (revision 1634) @@ -0,0 +1,107 @@ + SUBROUTINE qminimum_p( q,nq,deltap ) + USE parallel + IMPLICIT none +c +c -- Objet : Traiter les valeurs trop petites (meme negatives) +c pour l'eau vapeur et l'eau liquide +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +c + INTEGER nq + REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm) +c + INTEGER iq_vap, iq_liq + PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur + PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide + REAL seuil_vap, seuil_liq + PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur + PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide +c +c NB. ....( Il est souhaitable mais non obligatoire que les valeurs des +c parametres seuil_vap, seuil_liq soient pareilles a celles +c qui sont utilisees dans la routine ADDFI ) +c ................................................................. +c + INTEGER i, k, iq + REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe +c + REAL SSUM + EXTERNAL SSUM +c + INTEGER imprim + SAVE imprim + DATA imprim /0/ +c$OMP THREADPRIVATE(imprim) + INTEGER ijb,ije + INTEGER Index_pump(ip1jmp1) + INTEGER nb_pump +c +c Quand l'eau liquide est trop petite (ou negative), on prend +c l'eau vapeur de la meme couche et la convertit en eau liquide +c (sans changer la temperature !) +c + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 1000 k = 1, llm + DO 1040 i = ijb, ije + if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then + q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq + q(i,k,iq_liq) = seuil_liq + endif + 1040 CONTINUE + 1000 CONTINUE +c$OMP END DO NOWAIT +c$OMP BARRIER +c ---> SYNCHRO OPENMP ICI + +c +c Quand l'eau vapeur est trop faible (ou negative), on complete +c le defaut en prennant de l'eau vapeur de la couche au-dessous. +c + iq = iq_vap +c + DO k = llm, 2, -1 +ccc zx_abc = dpres(k) / dpres(k-1) +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then + q(i,k-1,iq) = q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) * + & deltap(i,k) / deltap(i,k-1) + q(i,k,iq) = seuil_vap + endif + ENDDO +c$OMP END DO NOWAIT + ENDDO +c$OMP BARRIER +c +c Quand il s'agit de la premiere couche au-dessus du sol, on +c doit imprimer un message d'avertissement (saturation possible). +c + nb_pump=0 +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) ) + q(i,1,iq) = AMAX1( q(i,1,iq), seuil_vap ) + IF (zx_pump(i) > 0.0) THEN + nb_pump = nb_pump+1 + Index_pump(nb_pump)=i + ENDIF + ENDDO +c$OMP END DO +! pompe = SSUM(ije-ijb+1,zx_pump(ijb),1) + + IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN + PRINT *, 'ATT!:on pompe de l eau au sol' + DO i = 1, nb_pump + imprim = imprim + 1 + PRINT*,' en ',index_pump(i),zx_pump(index_pump(i)) + ENDDO + ENDIF +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ran1.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ran1.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ran1.F (revision 1634) @@ -0,0 +1,34 @@ +! +! $Id$ +! + FUNCTION RAN1(IDUM) + DIMENSION R(97) + save r + save iff,ix1,ix2,ix3 + PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6) + PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6) + PARAMETER (M3=243000,IA3=4561,IC3=51349) + DATA IFF /0/ + IF (IDUM.LT.0.OR.IFF.EQ.0) THEN + IFF=1 + IX1=MOD(IC1-IDUM,M1) + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IX1,M2) + IX1=MOD(IA1*IX1+IC1,M1) + IX3=MOD(IX1,M3) + DO 11 J=1,97 + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 +11 CONTINUE + IDUM=1 + ENDIF + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + IX3=MOD(IA3*IX3+IC3,M3) + J=1+(97*IX3)/M3 + IF(J.GT.97.OR.J.LT.1)PAUSE + RAN1=R(J) + R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat.F (revision 1634) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotat (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_nfil.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_nfil.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_nfil.F (revision 1634) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE rotat_nfil (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_nfil_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_nfil_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_nfil_p.F (revision 1634) @@ -0,0 +1,52 @@ + SUBROUTINE rotat_nfil_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotat_p.F (revision 1634) @@ -0,0 +1,63 @@ + SUBROUTINE rotat_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatf.F (revision 1634) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotatf (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatf_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatf_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatf_p.F (revision 1634) @@ -0,0 +1,67 @@ + SUBROUTINE rotatf_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2, 2, .FALSE., 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatst.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatst.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/rotatst.F (revision 1634) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE rotatst (klevel,x, y, rot ) +c +c P. Le Van +c +c ***************************************************************** +c .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ..... +c ***************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c + INTEGER klevel +#include "dimensions.h" +#include "paramet.h" + + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) + INTEGER l, ij +c +c + DO 5 l = 1,klevel +c + DO 1 ij = 1, ip1jm - 1 + rot( ij,l ) = ( y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) ) + 1 CONTINUE +c +c .... correction pour rot( iip1,j,l) .... +c +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + 2 CONTINUE +c + 5 CONTINUE + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/serre.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/serre.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/serre.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! +!c +!c +!c..include serre.h +!c + REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo, & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy + COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sort.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sort.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sort.F (revision 1634) @@ -0,0 +1,37 @@ +! +! $Header$ +! +C +C + SUBROUTINE sort(n,d) +c +c P.Le Van +c +c... cette routine met le tableau d dans l'ordre croissant .... +cc ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc +c tion situee + bas IF(d(j).LE.p) THEN par +c IF(d(j).GE.p) THEN +c + + INTEGER n + REAL d(n) , p + INTEGER i,j,k + + DO i=1,n-1 + k=i + p=d(i) + DO j=i+1,n + IF(d(j).LE.p) THEN + k=j + p=d(j) + ENDIF + ENDDO + + IF(k.ne.i) THEN + d(k)=d(i) + d(i)=p + ENDIF + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sortvarc.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sortvarc.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sortvarc.F (revision 1634) @@ -0,0 +1,166 @@ +! +! $Id$ +! + SUBROUTINE sortvarc + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = REAL( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge(:)=dp(:)*dp(:) + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot = SSUM( llm, etotl, 1 ) + ztot = SSUM( llm, ztotl, 1 ) + stot = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang = SSUM( llm, angl, 1 ) + +c rday = REAL(INT ( day_ini + time )) +c + rday = REAL(INT(time-jD_ref-jH_ref)) + IF(ptot0.eq.0.) THEN + PRINT 3500, itau, rday, heure,time + PRINT*,'WARNING!!! On recalcule les valeurs initiales de :' + PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang' + PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + etot0 = etot + ptot0 = ptot + ztot0 = ztot + stot0 = stot + ang0 = ang + END IF + + etot= etot/etot0 + rmsv= SQRT(rmsv/ptot) + ptot= ptot/ptot0 + ztot= ztot/ztot0 + stot= stot/stot0 + ang = ang /ang0 + + + PRINT 3500, itau, rday, heure, time + PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + + RETURN + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x + * ,'date',f14.4,4x,10("*")) +4000 FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie' + * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB ' + . ,f10.6,e13.6,5f10.3/ + * ) + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sortvarc0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sortvarc0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sortvarc0.F (revision 1634) @@ -0,0 +1,141 @@ +! +! $Id$ +! + SUBROUTINE sortvarc0 + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + integer ismin,ismax + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = REAL( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge=dp*dp + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot0 = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot0 = SSUM( llm, etotl, 1 ) + ztot0 = SSUM( llm, ztotl, 1 ) + stot0 = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang0 = SSUM( llm, angl, 1 ) + + rday = REAL(INT (time )) +c + PRINT 3500, itau, rday, heure, time + PRINT *, ptot0,etot0,ztot0,stot0,ang0 + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x + * ,'date',f10.5,4x,10("*")) + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/startvar.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/startvar.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/startvar.F90 (revision 1634) @@ -0,0 +1,783 @@ +! +! $Id$ +! +!******************************************************************************* +! +MODULE startvar +! +!******************************************************************************* +! +!------------------------------------------------------------------------------- +! Purpose: Access data from the database of atmospheric to initialize the model. +!------------------------------------------------------------------------------- +! Comments: +! +! * This module is designed to work for Earth (and with ioipsl) +! +! * There are three ways to acces data, depending on the type of field +! which needs to be extracted. In any case the call should come after a restget +! and should be of the type : CALL startget(...) +! +! - A 1D variable on the physical grid : +! CALL startget_phys1d((varname, iml, jml, lon_in, lat_in, nbindex, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 2D variable on the dynamical grid : +! CALL startget_phys2d(varname, iml, jml, lon_in, lat_in, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 3D variable on the dynamical grid : +! CALL startget_dyn((varname, iml, jml, lon_in, lat_in, lml, pls, workvar, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! * Data needs to be in NetCDF format +! +! * Variables should have the following names in the files: +! 'RELIEF' : High resolution orography +! 'ST' : Surface temperature +! 'CDSW' : Soil moisture +! 'Z' : Surface geopotential +! 'SP' : Surface pressure +! 'U' : East ward wind +! 'V' : Northward wind +! 'TEMP' : Temperature +! 'R' : Relative humidity +! +! * There is a big mess with the longitude size. Should it be iml or iml+1 ? +! I have chosen to use the iml+1 as an argument to this routine and we declare +! internaly smaller fields when needed. This needs to be cleared once and for +! all in LMDZ. A convention is required. +!------------------------------------------------------------------------------- +#ifdef CPP_EARTH + USE ioipsl + IMPLICIT NONE + + PRIVATE + PUBLIC startget_phys2d, startget_phys1d, startget_dyn +! INTERFACE startget +! MODULE PROCEDURE startget_phys1d, startget_phys2d, startget_dyn +! END INTERFACE + + REAL, SAVE :: deg2rad, pi + INTEGER, SAVE :: iml_rel, jml_rel + INTEGER, SAVE :: fid_phys, iml_phys, jml_phys + INTEGER, SAVE :: fid_dyn, iml_dyn, jml_dyn, llm_dyn, ttm_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_phys, lon_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_phys, lat_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_rug, lon_alb, lon_rel + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_rug, lat_alb, lat_rel + REAL, DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: levdyn_ini + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: relief, zstd, zsig, zgam + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: masque, zthe, zpic, zval + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: rugo, phis, tsol, qsol + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: psol_dyn + REAL, DIMENSION(:,:,:), ALLOCATABLE, TARGET, SAVE :: var_ana3d + + CONTAINS + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, lat_in, nbindex, champ, & + val_exp ,jml2, lon_in2, lat_in2, ibar) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: nbindex + REAL, DIMENSION(nbindex), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d +!------------------------------------------------------------------------------- + v2d=>NULL() + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('qsol') + IF(.NOT.ALLOCATED(qsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('zmea','zstd','zsig','zgam','zthe','zpic','zval') + IF(.NOT.ALLOCATED(relief)) & + CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rads','snow','tslab','seaice','rugmer','agsno') + CASE DEFAULT + WRITE(lunout,*)'startget_phys1d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('rads','snow','tslab','seaice'); champ=0.0 + CASE('rugmer'); champ(:)=0.001 + CASE('agsno'); champ(:)=50.0 + CASE DEFAULT + SELECT CASE(varname) + CASE('tsol'); v2d=>tsol + CASE('qsol'); v2d=>qsol + CASE('psol'); v2d=>psol_dyn + CASE('zmea'); v2d=>relief + CASE('zstd'); v2d=>zstd + CASE('zsig'); v2d=>zsig + CASE('zgam'); v2d=>zgam + CASE('zthe'); v2d=>zthe + CASE('zpic'); v2d=>zpic + CASE('zval'); v2d=>zval + END SELECT + IF(SIZE(v2d)/=SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + CALL gr_dyn_fi(1,iml,jml,nbindex,v2d,champ) + END SELECT + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) ALLOCATE(tsol(iml,jml)) + CALL gr_fi_dyn(1,iml,jml,nbindex,champ,tsol) + END SELECT + + END IF + +END SUBROUTINE startget_phys1d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, champ, val_exp, & + jml2, lon_in2, lat_in2 , ibar, msk) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar + REAL, DIMENSION(iml,jml), INTENT(IN), OPTIONAL :: msk +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d=>NULL() + LOGICAL :: lrelief1, lrelief2 +!------------------------------------------------------------------------------- + v2d=>NULL() + lrelief1=(.NOT.ALLOCATED(relief).AND. PRESENT(msk)) + lrelief2=(.NOT.ALLOCATED(relief).AND..NOT.PRESENT(msk)) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('relief') + IF(lrelief1) CALL start_init_orog(iml,jml,lon_in,lat_in,msk) + IF(lrelief2) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('surfgeo') + IF(.NOT.ALLOCATED(phis)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rugosite','masque') + IF(.NOT.ALLOCATED(rugo)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE DEFAULT + WRITE(lunout,*)'startget_phys2d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('psol'); v2d=>psol_dyn + CASE('relief'); v2d=>relief + CASE('rugosite'); v2d=>rugo + CASE('masque'); v2d=>masque + CASE('surfgeo'); v2d=>phis + END SELECT + IF(SIZE(champ)/=SIZE(v2d)) THEN + WRITE(lunout,*) 'STARTVAR module has been initialized to the wrong size' + STOP + END IF + + champ(:,:)=v2d(:,:) + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE ('surfgeo') + IF(.NOT.ALLOCATED(phis)) ALLOCATE(phis(iml,jml)) + IF(SIZE(phis)/=SIZE(champ)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + phis(:,:)=champ(:,:) + END SELECT + + END IF + +END SUBROUTINE startget_phys2d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_dyn(varname, lon_in, lat_in, pls,workvar,& + champ, val_exp, lon_in2, lat_in2, ibar) + + use assert_eq_m, only: assert_eq + + +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + REAL, INTENT(IN) :: lon_in(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in(:) ! dim(jml) + REAL, INTENT(IN) :: pls(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: workvar(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(INOUT) :: champ(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: val_exp + REAL, INTENT(IN) :: lon_in2(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in2(:) ! dim(jml2) + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "comconst.h" +#include "paramet.h" +#include "comgeom2.h" + INTEGER :: iml, jml + INTEGER :: lml + INTEGER :: jml2 + REAL, DIMENSION(:,:,:), POINTER :: v3d=>NULL() + CHARACTER(LEN=10) :: vname + INTEGER :: il + REAL :: xppn, xpps +!------------------------------------------------------------------------------- + NULLIFY(v3d) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + + iml = assert_eq((/size(lon_in), size(pls, 1), size(workvar, 1), & + & size(champ, 1), size(lon_in2)/), "startget_dyn iml") + jml = assert_eq(size(lat_in), size(pls, 2), size(workvar, 2), & + & size(champ, 2), "startget_dyn jml") + lml = assert_eq(size(pls, 3), size(workvar, 3), size(champ, 3), & + & "startget_dyn lml") + jml2 = size(lat_in2) + +!--- READING UNALLOCATED FILES + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + +!--- CHECKING IF THE FIELD IS KNOWN AND INTERPOLATING 3D FIELDS + SELECT CASE(varname) + CASE('u'); vname='U' + CASE('v'); vname='V' + CASE('t','tpot'); vname='TEMP' + CASE('q'); vname='R' + CASE DEFAULT + WRITE(lunout,*)'startget_dyn' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + CALL start_inter_3d(TRIM(vname), iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls, champ,ibar ) + +!--- COMPUTING THE REQUIRED FILED + SELECT CASE(varname) + CASE('u') !--- Eastward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cu(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('v') !--- Northward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cv(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('tpot') !--- Temperature + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=champ*cpp/workvar + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute potential temperature as the' + WRITE(lunout,*)'Exner function is missing or constant.'; STOP + END IF + + CASE('q') !--- Relat. humidity + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=0.01*champ*workvar + WHERE(champ<0.) champ=1.0E-10 + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute specific humidity as the' + WRITE(lunout,*)'saturated humidity is missing or constant.'; STOP + END IF + + END SELECT + + END IF + +END SUBROUTINE startget_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_orog(iml,jml,lon_in,lat_in,masque_lu) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(IN), OPTIONAL :: masque_lu +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: orofname + LOGICAL :: check=.TRUE. + REAL, DIMENSION(1) :: lev + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: fid, llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: relief_hi, tmp_var + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini +!------------------------------------------------------------------------------- + pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + + orofname = 'Relief.nc'; title='RELIEF' + IF(check) WRITE(lunout,*)'Reading the high resolution orography' + CALL flininfo(orofname, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + + ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel)) + CALL flinopen(orofname, .FALSE., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,& + lev, ttm_tmp, itau, date, dt, fid) + ALLOCATE(relief_hi(iml_rel,jml_rel)) + CALL flinget(fid, title, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1, 1, relief_hi) + CALL flinclo(fid) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel)) + lon_ini(:)=lon_rel(:,1); IF(MAXVAL(lon_rel)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_rel(1,:); IF(MAXVAL(lat_rel)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel)) + CALL conf_dat2d(title, iml_rel, jml_rel, lon_ini, lat_ini, lon_rad, lat_rad, & + relief_hi, .FALSE.) + DEALLOCATE(lon_ini,lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + IF(check) WRITE(lunout,*)'Computes all parameters needed for gravity wave dra& + &g code' + + ALLOCATE(phis(iml,jml)) ! Geopotentiel au sol + ALLOCATE(zstd(iml,jml)) ! Deviation standard de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) ! Pente de l'orographie sous-maille + ALLOCATE(zgam(iml,jml)) ! Anisotropie de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) ! Orientation axe +grande pente d'oro sous maille + ALLOCATE(zpic(iml,jml)) ! Hauteur pics de la SSO + ALLOCATE(zval(iml,jml)) ! Hauteur vallees de la SSO + ALLOCATE(relief(iml,jml)) ! Orographie moyenne + ALLOCATE(masque(iml,jml)) ! Masque terre ocean + masque = -99999. + IF(PRESENT(masque_lu)) masque=masque_lu + + CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque) + phis = phis * 9.81 + +!--- SURFACE ROUGHNESS COMPUTATION (UNUSED FOR THE MOMENT !!! ) + IF(check) WRITE(lunout,*)'Compute surface roughness induced by the orography' + ALLOCATE(rugo (iml ,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, tmp_var) + rugo(1:iml-1,:)=tmp_var; rugo(iml,:)=tmp_var(1,:) + DEALLOCATE(relief_hi,tmp_var,lon_rad,lat_rad) + RETURN + +END SUBROUTINE start_init_orog +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!------------------------------------------------------------------------------- + physfname = 'ECPHY.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*)'Opening the surface analysis' + CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, ttm_tmp, fid_phys) + + ALLOCATE(lat_phys(iml_phys,jml_phys)) + ALLOCATE(lon_phys(iml_phys,jml_phys)) + ALLOCATE(levphys_ini(llm_tmp)) + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, llm_tmp, lon_phys, & + lat_phys, levphys_ini, ttm_tmp, itau, date, dt, fid_phys) + DEALLOCATE(levphys_ini) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_phys),lat_ini(jml_phys)) + lon_ini(:)=lon_phys(:,1); IF(MAXVAL(lon_phys)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_phys(1,:); IF(MAXVAL(lat_phys)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_phys,jml_phys),lon_rad(iml_phys),lat_rad(jml_phys)) + +!--- SURFACE TEMPERATURE + title='ST' + ALLOCATE(tsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana , ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, tsol) + +!--- SOIL MOISTURE + title='CDSW' + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana, ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, qsol) + + CALL flinclo(fid_phys) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +END SUBROUTINE start_init_phys +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: i, j + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana, z + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: xppn, xpps +!------------------------------------------------------------------------------- + +!--- KINETIC ENERGY + physfname = 'ECDYN.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*) 'Opening the surface analysis' + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, fid_dyn) + IF(check) WRITE(lunout,*) 'Values read: ', iml_dyn, jml_dyn, llm_dyn, ttm_dyn + + ALLOCATE(lat_dyn(iml_dyn,jml_dyn)) + ALLOCATE(lon_dyn(iml_dyn,jml_dyn)) + ALLOCATE(levdyn_ini(llm_dyn)) + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, lon_dyn,lat_dyn,& + levdyn_ini, ttm_dyn, itau, date, dt, fid_dyn) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn),lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:,1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1,:); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_dyn,jml_dyn),lon_rad(iml_dyn),lat_rad(jml_dyn)) + +!--- SURFACE GEOPOTENTIAL + title='Z' + ALLOCATE(z(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, z) + +!--- SURFACE PRESSURE + title='SP' + ALLOCATE(psol_dyn(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, psol_dyn) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +!--- ALLOCATION OF VARIABLES CREATED IN OR COMING FROM RESTART FILE + IF(.NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + ELSE + IF(SIZE(tsol)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The temperature field we have does not have the right size' + STOP + END IF + END IF + + IF(.NOT.ALLOCATED(phis)) THEN + CALL start_init_orog(iml,jml,lon_in,lat_in) + ELSE + IF(SIZE(phis)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The orography field we have does not have the right size' + STOP + END IF + END IF + +!--- PSOL IS COMPUTED IN PASCALS + DO j = 1, jml + DO i = 1, iml-1 + psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j))/287.0/tsol(i,j)) + END DO + psol_dyn(iml,j) = psol_dyn(1,j) + END DO + DEALLOCATE(z) + + ALLOCATE(xppn(iml-1),xpps(iml-1)) + DO i = 1, iml-1 + xppn(i) = aire( i,1) * psol_dyn( i,1) + xpps(i) = aire( i,jml) * psol_dyn( i,jml) + END DO + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + END DO + DEALLOCATE(xppn,xpps) + + RETURN + +END SUBROUTINE start_init_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls_in, var3d, ibar) + + use pchsp_95_m, only: pchsp_95 + use pchfe_95_m, only: pchfe_95 + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml, lml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + REAL, DIMENSION(iml, jml, lml), INTENT(IN) :: pls_in + REAL, DIMENSION(iml, jml, lml), INTENT(OUT) :: var3d + LOGICAL, INTENT(IN) :: ibar +!---------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + LOGICAL:: check=.TRUE., skip + REAL chmin, chmax + INTEGER ii, ij, il, ierr + integer n_extrap ! number of extrapolated points + REAL, DIMENSION(iml, jml, llm_dyn):: var_tmp3d + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(llm_dyn):: lev_dyn, ax, ay, yder + +!--------------------------------------------------------------------------- + IF(check) WRITE(lunout, *)'Going into flinget to extract the 3D field.' + IF(check) WRITE(lunout, *) fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, & + ttm_dyn + IF(check) WRITE(lunout, *) 'Allocating space for interpolation', iml, jml, & + llm_dyn + + IF(.NOT.ALLOCATED(var_ana3d)) ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, 1, 1, & + var_ana3d) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn), lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:, 1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1, :); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_dyn), lat_rad(jml_dyn)) + CALL conf_dat3d (varname, iml_dyn, jml_dyn, llm_dyn, lon_ini, lat_ini, & + levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d, ibar) + DEALLOCATE(lon_ini, lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + DO il=1, llm_dyn + CALL interp_startvar(varname, ibar, il==1, iml_dyn, jml_dyn, lon_rad, & + lat_rad, var_ana3d(:, :, il), iml, jml, jml2, lon_in, lat_in, & + lon_in2, lat_in2, var_tmp3d(:, :, il)) + END DO + DEALLOCATE(lon_rad, lat_rad) + +!--- VERTICAL INTERPOLATION IS PERFORMED FROM TOP OF ATMOSPHERE TO GROUND + ax = lev_dyn(llm_dyn:1:-1) + skip = .false. + n_extrap = 0 + DO ij=1, jml + DO ii=1, iml-1 + ay = var_tmp3d(ii, ij, llm_dyn:1:-1) + yder = pchsp_95(ax, ay, ibeg=2, iend=2, vc_beg=0., vc_end=0.) + CALL pchfe_95(ax, ay, yder, skip, pls_in(ii, ij, lml:1:-1), & + var3d(ii, ij, lml:1:-1), ierr) + if (ierr < 0) stop 1 + n_extrap = n_extrap + ierr + END DO + END DO + if (n_extrap /= 0) then + print *, "start_inter_3d pchfe_95: n_extrap = ", n_extrap + end if + var3d(iml, :, :) = var3d(1, :, :) + + DO il=1, lml + CALL minmax(iml*jml, var3d(1, 1, il), chmin, chmax) + WRITE(lunout, *)' '//TRIM(varname)//' min max l ', il, chmin, chmax + END DO + +END SUBROUTINE start_inter_3d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE interp_startvar(vname, ibar, ibeg, ii, jj, lon, lat, vari, & + i1, j1, j2, lon1, lat1, lon2, lat2, varo) +! +!------------------------------------------------------------------------------- + + USE inter_barxy_m, only: inter_barxy + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: vname + LOGICAL, INTENT(IN) :: ibar, ibeg + INTEGER, INTENT(IN) :: ii, jj + REAL, DIMENSION(ii), INTENT(IN) :: lon + REAL, DIMENSION(jj), INTENT(IN) :: lat + REAL, DIMENSION(ii,jj), INTENT(IN) :: vari + INTEGER, INTENT(IN) :: i1, j1, j2 + REAL, DIMENSION(i1), INTENT(IN) :: lon1 + REAL, DIMENSION(j1), INTENT(IN) :: lat1 + REAL, DIMENSION(i1), INTENT(IN) :: lon2 + REAL, DIMENSION(j2), INTENT(IN) :: lat2 + REAL, DIMENSION(i1,j1), INTENT(OUT) :: varo +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(i1-1,j1) :: vtmp +!------------------------------------------------------------------------------- + IF(ibar) THEN + IF(ibeg) THEN + WRITE(lunout,*) & + '---------------------------------------------------------------' + WRITE(lunout,*) & + '$$$ Utilisation de l interpolation barycentrique pour '//TRIM(vname)//' $$$' + WRITE(lunout,*) & + '---------------------------------------------------------------' + END IF + CALL inter_barxy(lon, lat(:jj-1), vari, lon2(:i1-1), lat2(:j2), vtmp) + ELSE + CALL grille_m (ii, jj, lon, lat, vari, i1-1, j1, lon1, lat1, vtmp) + END IF + CALL gr_int_dyn(vtmp, varo, i1-1, j1) + +END SUBROUTINE interp_startvar +! +!------------------------------------------------------------------------------- + +#endif +! of #ifdef CPP_EARTH + +END MODULE startvar +! +!******************************************************************************* Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sw_case_williamson91_6.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sw_case_williamson91_6.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/sw_case_williamson91_6.F (revision 1634) @@ -0,0 +1,140 @@ +! +! $Id $ +! + SUBROUTINE sw_case_williamson91_6(vcov,ucov,teta,masse,ps) + +c======================================================================= +c +c Author: Thomas Dubos original: 26/01/2010 +c ------- +c +c Subject: +c ------ +c Realise le cas-test 6 de Williamson et al. (1991) : onde de Rossby-Haurwitz +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "iniprint.h" + +c Arguments: +c ---------- + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + +c Local: +c ------ + + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) + + REAL :: sinth,costh,costh2, Ath,Bth,Cth, lon,dps + INTEGER i,j,ij + + REAL, PARAMETER :: rho=1 ! masse volumique de l'air (arbitraire) + REAL, PARAMETER :: K = 7.848e-6 ! K = \omega + REAL, PARAMETER :: gh0 = 9.80616 * 8e3 + INTEGER, PARAMETER :: R0=4, R1=R0+1, R2=R0+2 ! mode 4 +c NB : rad = 6371220 dans W91 (6371229 dans LMDZ) +c omeg = 7.292e-5 dans W91 (7.2722e-5 dans LMDZ) + + IF(0==0) THEN +c Williamson et al. (1991) : onde de Rossby-Haurwitz + teta = preff/rho/cpp +c geopotentiel (pression de surface) + do j=1,jjp1 + costh2 = cos(rlatu(j))**2 + Ath = (R0+1)*(costh2**2) + (2*R0*R0-R0-2)*costh2 - 2*R0*R0 + Ath = .25*(K**2)*(costh2**(R0-1))*Ath + Ath = .5*K*(2*omeg+K)*costh2 + Ath + Bth = (R1*R1+1)-R1*R1*costh2 + Bth = 2*(omeg+K)*K/(R1*R2) * (costh2**(R0/2))*Bth + Cth = R1*costh2 - R2 + Cth = .25*K*K*(costh2**R0)*Cth + do i=1,iip1 + ij=(j-1)*iip1+i + lon = rlonv(i) + dps = Ath + Bth*cos(R0*lon) + Cth*cos(2*R0*lon) + ps(ij) = rho*(gh0 + (rad**2)*dps) + enddo + enddo + write(lunout,*) 'W91 ps', MAXVAL(ps), MINVAL(ps) +c vitesse zonale ucov + do j=1,jjp1 + costh = cos(rlatu(j)) + costh2 = costh**2 + Ath = rad*K*costh + Bth = R0*(1-costh2)-costh2 + Bth = rad*K*Bth*(costh**(R0-1)) + do i=1,iip1 + ij=(j-1)*iip1+i + lon = rlonu(i) + ucov(ij,1) = (Ath + Bth*cos(R0*lon)) + enddo + enddo + write(lunout,*) 'W91 u', MAXVAL(ucov(:,1)), MINVAL(ucov(:,1)) + ucov(:,1)=ucov(:,1)*cu +c vitesse meridienne vcov + do j=1,jjm + sinth = sin(rlatv(j)) + costh = cos(rlatv(j)) + Ath = -rad*K*R0*sinth*(costh**(R0-1)) + do i=1,iip1 + ij=(j-1)*iip1+i + lon = rlonv(i) + vcov(ij,1) = Ath*sin(R0*lon) + enddo + enddo + write(lunout,*) 'W91 v', MAXVAL(vcov(:,1)), MINVAL(vcov(:,1)) + vcov(:,1)=vcov(:,1)*cv + +c ucov=0 +c vcov=0 + ELSE +c test non-tournant, onde se propageant en latitude + do j=1,jjp1 + do i=1,iip1 + ij=(j-1)*iip1+i + ps(ij) = 1e5*(1 + .1*exp(-100*(1+sin(rlatu(j)))**2) ) + enddo + enddo + +c rho = preff/(cpp*teta) + teta = .01*preff/cpp ! rho = 100 ; phi = ps/rho = 1e3 ; c=30 m/s = 2600 km/j = 23 degres / j + ucov=0. + vcov=0. + END IF + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL massdair(p,masse) + + END +c----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/temps.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/temps.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/temps.h (revision 1634) @@ -0,0 +1,25 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +! jD_ref = jour julien de la date de reference (lancement de l'experience) +! hD_ref = "heure" julienne de la date de reference +!----------------------------------------------------------------------- +! INCLUDE 'temps.h' + + COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref, & + & itau_dyn, itau_phy, jD_ref, jH_ref, calend + + INTEGER itaufin + INTEGER itau_dyn, itau_phy + INTEGER day_ini, day_end, annee_ref, day_ref + REAL dt, jD_ref, jH_ref + CHARACTER (len=10) :: calend + +!$OMP THREADPRIVATE(/temps/) +!----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/test_period.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/test_period.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/test_period.F (revision 1634) @@ -0,0 +1,115 @@ +! +! $Header$ +! + SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis ) + USE infotrac, ONLY : nqtot +c +c Auteur : P. Le Van +c --------- +c .... Cette routine teste la periodicite en longitude des champs ucov, +c teta, q , p et phis .......... +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c +c ...... Arguments ...... +c + REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) , + , q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1) +c +c ..... Variables locales ..... +c + INTEGER ij,l,nq +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( ucov(ij,l).NE.ucov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- UCOV --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + STOP + ENDIF + IF( teta(ij,l).NE.teta(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + , , teta(ij,l), teta(ij+iim,l) + STOP + ENDIF + ENDDO + + do ij=1,iim + if (teta(ij,l).ne.teta(1,l) + s .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' constant aux poles ! ' + print*,'teta(',1 ,',',l,')=',teta(1 ,l) + print*,'teta(',ij,',',l,')=',teta(ij,l) + print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l) + print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l) + stop + endif + enddo + ENDDO + +c + DO l = 1, llm + DO ij = 1, ip1jm, iip1 + IF( vcov(ij,l).NE.vcov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- VCOV --- n est pas', + , ' periodique en longitude !' + PRINT *,' l, ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l) + vcov(ij+iim,l)=vcov(ij,l) +c STOP + ENDIF + ENDDO + ENDDO + +c + DO nq =1, nqtot + DO l =1, llm + DO ij = 1, ip1jmp1, iip1 + IF( q(ij,l,nq).NE.q(ij+iim,l,nq) ) THEN + PRINT *,'STOP dans test_period car --- Q --- n est pas ', + , 'periodique en longitude !' + PRINT *,' nq , l, ij = ', nq, l, ij, ij+iim + STOP + ENDIF + ENDDO + ENDDO + ENDDO +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( p(ij,l).NE.p(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' periodique en longitude !' + PRINT *,' l ij = ',l, ij, ij+iim + STOP + ENDIF + IF( phis(ij).NE.phis(ij+iim) ) THEN + PRINT *,'STOP dans test_period car --- PHIS --- n est pas', + , ' periodique en longitude ! l, IJ = ', l, ij,ij+iim + PRINT *,' ij = ', ij, ij+iim + STOP + ENDIF + ENDDO + do ij=1,iim + if (p(ij,l).ne.p(1,l) + s .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' constant aux poles ! ' + print*,'p(',1 ,',',l,')=',p(1 ,l) + print*,'p(',ij,',',l,')=',p(ij,l) + print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l) + print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l) + stop + endif + enddo + ENDDO +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/times.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/times.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/times.F90 (revision 1634) @@ -0,0 +1,248 @@ +module times + integer,private,save :: Last_Count=0 + real, private,save :: Last_cpuCount=0 + logical, private,save :: AllTimer_IsActive=.false. + + integer, parameter :: nb_timer = 4 + integer, parameter :: timer_caldyn = 1 + integer, parameter :: timer_vanleer = 2 + integer, parameter :: timer_dissip = 3 + integer, parameter :: timer_physic = 4 + integer, parameter :: stopped = 1 + integer, parameter :: running = 2 + integer, parameter :: suspended = 3 + + integer :: max_size + real, allocatable, dimension(:,:,:) :: timer_table + real, allocatable, dimension(:,:,:) :: timer_table_sqr + integer, allocatable, dimension(:,:,:) :: timer_iteration + real, allocatable, dimension(:,:,:) :: timer_average + real, allocatable, dimension(:,:,:) :: timer_delta + real, allocatable,dimension(:) :: timer_running, last_time + integer, allocatable,dimension(:) :: timer_state + + contains + + subroutine init_timer + use parallel + implicit none +#include "dimensions.h" +#include "paramet.h" + + max_size=jjm+1 + allocate(timer_table(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_average(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_delta(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_running(nb_timer)) + allocate(timer_state(nb_timer)) + allocate(last_time(nb_timer)) + + timer_table(:,:,:)=0 + timer_table_sqr(:,:,:)=0 + timer_iteration(:,:,:)=0 + timer_average(:,:,:)=0 + timer_delta(:,:,:)=0 + timer_state(:)=stopped + end subroutine init_timer + + subroutine start_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + + if (timer_state(no_timer)/=stopped) then + stop 'start_timer :: timer is already running or suspended' + else + timer_state(no_timer)=running + endif + + timer_running(no_timer)=0 + call cpu_time(last_time(no_timer)) + + endif + + end subroutine start_timer + + subroutine suspend_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + if (timer_state(no_timer)/=running) then + stop 'suspend_timer :: timer is not running' + else + timer_state(no_timer)=suspended + endif + + timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer) + call cpu_time(last_time(no_timer)) + timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer) + endif + end subroutine suspend_timer + + subroutine resume_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + if (timer_state(no_timer)/=suspended) then + stop 'resume_timer :: timer is not suspended' + else + timer_state(no_timer)=running + endif + + call cpu_time(last_time(no_timer)) + endif + + end subroutine resume_timer + + subroutine stop_timer(no_timer) + use parallel + implicit none + integer :: no_timer + integer :: N + real :: V,V2 + + if (AllTimer_IsActive) then + + if (timer_state(no_timer)/=running) then + stop 'stop_timer :: timer is not running' + else + timer_state(no_timer)=stopped + endif + + timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer) + call cpu_time(last_time(no_timer)) + timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer) + + timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer) + timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2 + timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1 + timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank) + if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then + N=timer_iteration(jj_nb,no_timer,mpi_rank) + V2=timer_table_sqr(jj_nb,no_timer,mpi_rank) + V=timer_table(jj_nb,no_timer,mpi_rank) + timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) + else + timer_delta(jj_nb,no_timer,mpi_rank)=0 + endif + endif + + end subroutine stop_timer + + subroutine allgather_timer + use parallel + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + integer :: ierr + integer :: data_size + real, allocatable,dimension(:,:) :: tmp_table + + IF (using_mpi) THEN + + if (AllTimer_IsActive) then + + + allocate(tmp_table(max_size,nb_timer)) + + data_size=max_size*nb_timer + + tmp_table(:,:)=timer_table(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table_sqr(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + deallocate(tmp_table) + + endif + + ENDIF ! using_mpi + + end subroutine allgather_timer + + subroutine allgather_timer_average + use parallel + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + integer :: ierr + integer :: data_size + real, allocatable,dimension(:,:),target :: tmp_table + integer, allocatable,dimension(:,:),target :: tmp_iter + integer :: istats + + IF (using_mpi) THEN + + if (AllTimer_IsActive) then + + allocate(tmp_table(max_size,nb_timer)) + allocate(tmp_iter(max_size,nb_timer)) + + data_size=max_size*nb_timer + + tmp_table(:,:)=timer_average(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_average(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_table(:,:)=timer_delta(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_delta(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_iter(:,:)=timer_iteration(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr) +#endif + deallocate(tmp_table) + + endif + + ENDIF ! using_mp� + end subroutine allgather_timer_average + + subroutine InitTime + implicit none + integer :: count,count_rate,count_max + + AllTimer_IsActive=.TRUE. + if (AllTimer_IsActive) then + call system_clock(count,count_rate,count_max) + call cpu_time(Last_cpuCount) + Last_Count=count + endif + end subroutine InitTime + + function DiffTime() + implicit none + double precision :: DiffTime + integer :: count,count_rate,count_max + + call system_clock(count,count_rate,count_max) + if (Count>=Last_Count) then + DiffTime=(1.*(Count-last_Count))/count_rate + else + DiffTime=(1.*(Count-last_Count+Count_max))/count_rate + endif + Last_Count=Count + end function DiffTime + + function DiffCpuTime() + implicit none + real :: DiffCpuTime + real :: Count + + call cpu_time(Count) + DiffCpuTime=Count-Last_cpuCount + Last_cpuCount=Count + end function DiffCpuTime + +end module times Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/top_bound_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/top_bound_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/top_bound_p.F (revision 1634) @@ -0,0 +1,161 @@ + SUBROUTINE top_bound_p( vcov,ucov,teta,masse, du,dv,dh ) + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + + +c .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, +C F. LOTT DEC. 2006 +c ( 10/12/06 ) + +c======================================================================= +c +c Auteur: F. LOTT +c ------- +c +c Objet: +c ------ +c +c Dissipation linéaire (ex top_bound de la physique) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),teta(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) + REAL dv(iip1,jjm,llm),du(iip1,jjp1,llm),dh(iip1,jjp1,llm) + +c Local: +c ------ + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm + REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm) + + INTEGER NDAMP + PARAMETER (NDAMP=4) + integer i + REAL,SAVE :: rdamp(llm) +! & (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) + LOGICAL,SAVE :: first=.true. + INTEGER j,l,jjb,jje + + + if (iflag_top_bound == 0) return + if (first) then +c$OMP BARRIER +c$OMP MASTER + if (iflag_top_bound == 1) then +! couche eponge dans les 4 dernieres couches du modele + rdamp(:)=0. + rdamp(llm)=tau_top_bound + rdamp(llm-1)=tau_top_bound/2. + rdamp(llm-2)=tau_top_bound/4. + rdamp(llm-3)=tau_top_bound/8. + else if (iflag_top_bound == 2) then +! couce eponge dans toutes les couches de pression plus faible que +! 100 fois la pression de la derniere couche + rdamp(:)=tau_top_bound + s *max(presnivs(llm)/presnivs(:)-0.01,0.) + endif + first=.false. + print*,'TOP_BOUND rdamp=',rdamp +c$OMP END MASTER +c$OMP BARRIER + endif + + + CALL massbar_p(masse,massebx,masseby) +C CALCUL DES CHAMPS EN MOYENNE ZONALE: + + jjb=jj_begin + jje=jj_end + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + vzon(j,l)=0 + do i=1,iim +! Rm: on peut travailler directement avec la moyenne zonale de vcov +! plutot qu'avec celle de v car le coefficient cv qui relie les deux +! ne varie qu'en latitude + vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) + zm=zm+masseby(i,j,l) + enddo + vzon(j,l)=vzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + IF (pole_nord) jjb=jj_begin+1 + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + uzon(j,l)=0. + zm=0. + do i=1,iim + uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) + zm=zm+massebx(i,j,l) + enddo + uzon(j,l)=uzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + tzon(j,l)=0. + do i=1,iim + tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) + zm=zm+masse(i,j,l) + enddo + tzon(j,l)=tzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +C AMORTISSEMENTS LINEAIRES: + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + du(i,j,l)=du(i,j,l) + s -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) + dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourabs.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourabs.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourabs.F (revision 1634) @@ -0,0 +1,98 @@ + SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs ) + IMPLICIT NONE + +c======================================================================= +c +c Modif: I. Musat (28/10/04) +c ------- +c adaptation du code tourpot.F pour le calcul de la vorticite absolue +c cf. P. Le Van +c +c Objet: +c ------ +c +c ******************************************************************* +c ............. calcul de la vorticite absolue ................. +c ******************************************************************* +c +c ntetaSTD, vcov,ucov sont des argum. d'entree pour le s-pg . +c vorabs est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" +#include "comconst.h" +c + INTEGER ntetaSTD + REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD ) + REAL vorabs( ip1jm,ntetaSTD ) +c +c variables locales + INTEGER l, ij, i, j + REAL rot( ip1jm,ntetaSTD ) + + + +c ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,ntetaSTD + + DO 2 i = 1, iip1 + DO 2 j = 1, jjm +c + ij=i+(j-1)*iip1 + IF(ij.LE.ip1jm - 1) THEN +c + IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR. + $ cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN + rot( ij,l ) = 0. + continue + ELSE + rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/ + $ (2.*pi*RAD*cos(rlatv(j)))*REAL(iim) + $ +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/ + $ (pi*RAD)*(REAL(jjm)-1.) +c + ENDIF + ENDIF !(ij.LE.ip1jm - 1) THEN + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, ntetaSTD + + DO 6 ij = 1, ip1jm - 1 + vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) ) + 6 CONTINUE + +c ..... correction pour vorabs( iip1,j,l) ..... +c .... vorabs(iip1,j,l)= vorabs(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorabs( ij,l ) = vorabs( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourpot.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourpot.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourpot.F (revision 1634) @@ -0,0 +1,81 @@ +! +! $Header$ +! + SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ip1jm,llm ) + REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) + REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) + + INTEGER l, ij + + + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,llm + + DO 2 ij = 1, ip1jm - 1 + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, llm + + DO 6 ij = 1, ip1jm - 1 + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourpot_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourpot_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tourpot_p.F (revision 1634) @@ -0,0 +1,93 @@ + SUBROUTINE tourpot_p ( vcov, ucov, massebxy, vorpot ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ip1jm,llm ) + REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) + REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) + + INTEGER l, ij ,ije,ijb,jje,jjb + + + ijb=ij_begin-iip1 + ije=ij_end + + if (pole_nord) ijb=ij_begin + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + if (pole_sud) ije=ij_end-iip1-1 + DO 2 ij = ijb, ije + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + if (pole_sud) ije=ij_end-iip1 + + DO 3 ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT + jjb=jj_begin-1 + jje=jj_end + + if (pole_nord) jjb=jjb+1 + if (pole_sud) jje=jje-1 + CALL filtreg_p( rot, jjb,jje,jjm, llm, 2, 1, .FALSE., 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1, llm + + if (pole_sud) ije=ij_end-iip1-1 + + DO 6 ij = ijb, ije + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + if (pole_sud) ije=ij_end-iip1 + DO 8 ij = ijb+iip1-1, ije, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/traceurpole.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/traceurpole.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/traceurpole.F (revision 1634) @@ -0,0 +1,70 @@ +! +! $Id$ +! + subroutine traceurpole(q,masse) + + USE control_mod + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + + +c Arguments + integer iq + real masse(iip1,jjp1,llm) + real q(iip1,jjp1,llm) + + +c Locals + integer i,j,l + real sommemassen(llm) + real sommemqn(llm) + real sommemasses(llm) + real sommemqs(llm) + real qpolen(llm),qpoles(llm) + + +c On impose une seule valeur au pôle Sud j=jjm+1=jjp1 + sommemasses=0 + sommemqs=0 + do l=1,llm + do i=1,iip1 + sommemasses(l)=sommemasses(l)+masse(i,jjp1,l) + sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l) + enddo + qpoles(l)=sommemqs(l)/sommemasses(l) + enddo + +c On impose une seule valeur du traceur au pôle Nord j=1 + sommemassen=0 + sommemqn=0 + do l=1,llm + do i=1,iip1 + sommemassen(l)=sommemassen(l)+masse(i,1,l) + sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l) + enddo + qpolen(l)=sommemqn(l)/sommemassen(l) + enddo + +c On force le traceur à prendre cette valeur aux pôles + do l=1,llm + do i=1,iip1 + q(i,1,l)=qpolen(l) + q(i,jjp1,l)=qpoles(l) + enddo + enddo + + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tracstoke.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tracstoke.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/tracstoke.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + common /tracstoke/istdyn,istphy,unittrac + integer istdyn,istphy,unittrac Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ugeostr.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ugeostr.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/ugeostr.F90 (revision 1634) @@ -0,0 +1,68 @@ +! +! $Id$ +! +subroutine ugeostr(phi,ucov) + + ! Calcul du vent covariant geostrophique a partir du champ de + ! geopotentiel. + ! We actually compute: (1 - cos^8 \phi) u_g + ! to have a wind going smoothly to 0 at the equator. + ! We assume that the surface pressure is uniform so that model + ! levels are pressure levels. + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + + real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm) + real um(jjm,llm),fact,u(iip1,jjm,llm) + integer i,j,l + + real zlat + + um(:,:)=0 ! initialize um() + + DO j=1,jjm + + if (abs(sin(rlatv(j))).lt.1.e-4) then + zlat=1.e-4 + else + zlat=rlatv(j) + endif + fact=cos(zlat) + fact=fact*fact + fact=fact*fact + fact=fact*fact + fact=(1.-fact)/ & + (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j))) + fact=-fact/rad + DO l=1,llm + DO i=1,iim + u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l)) + um(j,l)=um(j,l)+u(i,j,l)/REAL(iim) + ENDDO + ENDDO + ENDDO + call dump2d(jjm,llm,um,'Vent-u geostrophique') + + ! calcul des champ de vent: + + DO l=1,llm + DO i=1,iip1 + ucov(i,1,l)=0. + ucov(i,jjp1,l)=0. + end DO + DO j=2,jjm + DO i=1,iim + ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j) + end DO + ucov(iip1,j,l)=ucov(1,j,l) + end DO + end DO + + print *, 301 + +end subroutine ugeostr Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vitvert.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vitvert.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vitvert.F (revision 1634) @@ -0,0 +1,52 @@ +! +! $Header$ +! + SUBROUTINE vitvert ( convm , w ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) + INTEGER l, ij + + + + DO 2 l = 1,llmm1 + + DO 1 ij = 1,ip1jmp1 + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE + + DO 5 ij = 1,ip1jmp1 + w(ij,1) = 0. +5 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vitvert_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vitvert_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vitvert_p.F (revision 1634) @@ -0,0 +1,56 @@ + SUBROUTINE vitvert_p ( convm , w ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) + INTEGER l, ij,ijb,ije + + + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_sud) ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 2 l = 1,llmm1 + + DO 1 ij = ijb,ije + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE +c$OMP END DO +c$OMP MASTER + DO 5 ij = ijb,ije + w(ij,1) = 0. +5 CONTINUE +c$OMP END MASTER +c$OMP BARRIER + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlsplt_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlsplt_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlsplt_p.F (revision 1634) @@ -0,0 +1,1142 @@ +c +c $Id$ +c + + SUBROUTINE vlsplt_p(q,pente_max,masse,w,pbaru,pbarv,pdt) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + USE parallel + USE mod_hallo + USE Vampir + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max +c REAL masse(iip1,jjp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) +c REAL q(iip1,jjp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + INTEGER ijlqmin,iqmin,jqmin,lqmin +c + REAL zm(ip1jmp1,llm),newmasse + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm),zz + REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm) + REAL second,temps0,temps1,temps2,temps3 + REAL ztemps1,ztemps2,ztemps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + INTEGER iminn,imaxx + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + INTEGER ijb,ije + type(request) :: MyRequest1 + type(request) :: MyRequest2 + + call SetTag(MyRequest1,100) + call SetTag(MyRequest2,101) + + zzpbar = 0.5 * pdt + zzw = pdt + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO l=1,llm + DO ij = ijb,ije + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij=ijb,ije + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=ijb,ije + mw(ij,llm+1)=0. + ENDDO + +c CALL SCOPY(ijp1llm,q,1,zq,1) +c CALL SCOPY(ijp1llm,masse,1,zm,1) + + ijb=ij_begin + ije=ij_end + zq(ijb:ije,:)=q(ijb:ije,:) + zm(ijb:ije,:)=masse(ijb:ije,:) + + +c print*,'Entree vlx1' +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_begin+2*iip1-1) + call vlx_p(zq,pente_max,zm,mu,ij_end-2*iip1+1,ij_end) + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1) + call SendRequest(MyRequest1) + call VTe(VTHallo) + call vlx_p(zq,pente_max,zm,mu,ij_begin+2*iip1,ij_end-2*iip1) +c call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end) + call VTb(VTHallo) + call WaitRecvRequest(MyRequest1) + call VTe(VTHallo) + + +c print*,'Sortie vlx1' +c call minmaxq(zq,qmin,qmax,'apres vlx1 ') + +c print*,'Entree vly1' +c call exchange_hallo(zq,ip1jmp1,llm,2,2) +c call exchange_hallo(zm,ip1jmp1,llm,1,1) + + call vly_p(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly1 ') +c print*,'Sortie vly1' + call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1) + call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end) + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2) + call SendRequest(MyRequest2) + call VTe(VTHallo) + call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1) + call VTb(VTHallo) + call WaitRecvRequest(MyRequest2) + + call VTe(VTHallo) + +c call minmaxq(zq,qmin,qmax,'apres vlz ') + + + + + call vly_p(zq,pente_max,zm,mv) +c call minmaxq(zq,qmin,qmax,'apres vly ') + + + call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end) +c call minmaxq(zq,qmin,qmax,'apres vlx2 ') + + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + q(ij,l)=zq(ij,l) + ENDDO + ENDDO + + + DO l=1,llm + DO ij=ijb,ije-iip1+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + call WaitSendRequest(MyRequest1) + call WaitSendRequest(MyRequest2) + + RETURN + END + + + SUBROUTINE vlx_p(q,pente_max,masse,u_m,ijb_x,ije_x) + +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE Parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + Logical extremum + + REAL SSUM + EXTERNAL SSUM + + REAL z1,z2,z3 + + INTEGER ijb,ije,ijb_x,ije_x + +c calcul de la pente a droite et a gauche de la maille + + ijb=ijb_x + ije=ije_x + + if (pole_nord.and.ijb==1) ijb=ijb+iip1 + if (pole_sud.and.ije==ip1jmp1) ije=ije-iip1 + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=ijb,ije + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=ijb+1,ije + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=ijb+iip1-1,ije,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=ijb+1,ije +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +c$OMP END DO NOWAIT +c print*,'Ok calcul des pentes' + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=ijb+1,ije + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + DO ij=ijb,ije + iadvplus(ij,l)=0 + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c print*,'Bouclage en iip1' + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c print*,'Cumule ....' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 +c print*,'masse(',ij,')=',masse(ij,l) + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +#endif +c stop + +c go to 9999 +c detection des points ou on advecte plus que la masse de la +c maille +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +c print*,'Ok test 1' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c print*,'Ok test 2' + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + nl(l)=0 + DO ij=ijb,ije + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO +c$OMP END DO NOWAIT +cym IF(n0.gt.1) THEN +cym IF(n0.gt.0) THEN + +c PRINT*,'Nombre de points pour lesquels on advect plus que le' +c & ,'contenu de la maille : ',n0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=ijb,ije + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO +c$OMP END DO NOWAIT +cym ENDIF ! n0.gt.0 +9999 continue + + +c bouclage en latitude +c print*,'Avant bouclage en latitude' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c calcul des tENDances +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+1,ije + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=ijb+iip1-1,ije,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + + + SUBROUTINE vly_p(q,pente_max,masse,masse_adv_v) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm), dq( ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical extremum,first,testcpu + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 +c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) + SAVE first,testcpu +c$OMP THREADPRIVATE(first,testcpu) + + REAL convpn,convps,convmpn,convmps + real massepn,masseps,qpn,qps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon +c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) + SAVE airej2,airejjm +c$OMP THREADPRIVATE(airej2,airejjm) +c +c + REAL SSUM + EXTERNAL SSUM + + DATA first,testcpu/.true.,.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + INTEGER ijb,ije + + IF(first) THEN +c PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c +c PRINT*,'CALCUL EN LATITUDE' + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + if (pole_nord) then + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + endif + + if (pole_sud) then + DO i = 1, iim + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpsn = SSUM( iim, airesch ,1 ) / airejjm + endif + + + +c calcul des pentes aux points v + + ijb=ij_begin-2*iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + +c calcul des pentes aux poles + IF (pole_nord) THEN + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + ENDDO + + dyn1=0. + dyn2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + ENDDO + + DO ij=1,iip1 + dyq(ij,l)=0. + ENDDO +c ym tout cela ne sert pas a grand chose + ENDIF + + IF (pole_sud) THEN + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + + dys1=0. + dys2=0. + + DO ij=1,iim + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=0. + ENDDO +c ym tout cela ne sert pas a grand chose + ENDIF + +c filtrage de la derivee + +c calcul des pentes limites aux poles +c ym partie inutile +c goto 8888 +c fn=1. +c fs=1. +c DO ij=1,iim +c IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN +c fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) +c ENDIF +c IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN +c fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) +c ENDIF +c ENDDO +c DO ij=1,iip1 +c dyq(ij,l)=fn*dyq(ij,l) +c dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) +c ENDDO +c 8888 continue + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C appn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) +C apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) +C ENDDO +C appn=min(pente_max/appn,1.) +C apps=min(pente_max/apps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & appn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & apps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=appn*dyq(ij) +C dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + IF(masse_adv_v(ij,l).gt.0) THEN + qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)* + , 0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)) + ELSE + qbyv(ij,l)=q(ij,l)-dyq(ij,l)* + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) + ENDIF + qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version +c convpn=SSUM(iim,qbyv(1,l),1)/apoln +c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + if (pole_nord) then + convpn=SSUM(iim,qbyv(1,l),1) + convmpn=ssum(iim,masse_adv_v(1,l),1) + massepn=ssum(iim,masse(1,l),1) + qpn=0. + do ij=1,iim + qpn=qpn+masse(ij,l)*q(ij,l) + enddo + qpn=(qpn+convpn)/(massepn+convmpn) + do ij=1,iip1 + q(ij,l)=qpn + enddo + endif + +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols + + if (pole_sud) then + + convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) + convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) + masseps=ssum(iim, masse(ip1jm+1,l),1) + qps=0. + do ij = ip1jm+1,ip1jmp1-1 + qps=qps+masse(ij,l)*q(ij,l) + enddo + qps=(qps+convps)/(masseps+convmps) + do ij=ip1jm+1,ip1jmp1 + q(ij,l)=qps + enddo + endif +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO +c$OMP END DO NOWAIT + + RETURN + END + + + + SUBROUTINE vlz_p(q,pente_max,masse,w,ijb_x,ije_x) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE Parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm+1) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL,SAVE :: wq(ip1jmp1,llm+1) + REAL newmasse + + REAL,SAVE :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm) + REAL dzqmax + REAL sigw + + LOGICAL testcpu + SAVE testcpu +c$OMP THREADPRIVATE(testcpu) + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 +c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) + + REAL SSUM + EXTERNAL SSUM + + DATA testcpu/.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + INTEGER ijb,ije,ijb_x,ije_x +c On oriente tout dans le sens de la pression c'est a dire dans le +c sens de W + +#ifdef BIDON + IF(testcpu) THEN + temps0=second(0.) + ENDIF +#endif + + ijb=ijb_x + ije=ije_x + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=2,llm + DO ij=ijb,ije + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + adzqw(ij,l)=abs(dzqw(ij,l)) + ENDDO + ENDDO +c$OMP END DO + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=2,llm-1 + DO ij=ijb,ije +#ifdef CRAY + dzq(ij,l)=0.5* + , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) +#else + IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN + dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) + ELSE + dzq(ij,l)=0. + ENDIF +#endif + dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) + dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + dzq(ij,1)=0. + dzq(ij,llm)=0. + ENDDO +c$OMP END MASTER +c$OMP BARRIER +#ifdef BIDON + IF(testcpu) THEN + temps1=temps1+second(0.)-temps0 + ENDIF +#endif +c --------------------------------------------------------------- +c .... calcul des termes d'advection verticale ....... +c --------------------------------------------------------------- + +c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm-1 + do ij = ijb,ije + IF(w(ij,l+1).gt.0.) THEN + sigw=w(ij,l+1)/masse(ij,l+1) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1)) + ELSE + sigw=w(ij,l+1)/masse(ij,l) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + wq(ij,llm+1)=0. + wq(ij,1)=0. + ENDDO +c$OMP END MASTER +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO + ENDDO +c$OMP END DO NOWAIT + + + RETURN + END +c SUBROUTINE minmaxq(zq,qmin,qmax,comment) +c +c#include "dimensions.h" +c#include "paramet.h" + +c CHARACTER*(*) comment +c real qmin,qmax +c real zq(ip1jmp1,llm) + +c INTEGER jadrs(ip1jmp1), jbad, k, i + + +c DO k = 1, llm +c jbad = 0 +c DO i = 1, ip1jmp1 +c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN +c jbad = jbad + 1 +c jadrs(jbad) = i +c ENDIF +c ENDDO +c IF (jbad.GT.0) THEN +c PRINT*, comment +c DO i = 1, jbad +cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) +c ENDDO +c ENDIF +c ENDDO + +c return +c end + + + subroutine minmaxq_p(zq,qmin,qmax,comment) + +#include "dimensions.h" +#include "paramet.h" + + character*20 comment + real qmin,qmax + real zq(ip1jmp1,llm) + real zzq(iip1,jjp1,llm) + + integer imin,jmin,lmin,ijlmin + integer imax,jmax,lmax,ijlmax + + integer ismin,ismax + +#ifdef isminismax + call scopy (ip1jmp1*llm,zq,1,zzq,1) + + ijlmin=ismin(ijp1llm,zq,1) + lmin=(ijlmin-1)/ip1jmp1+1 + ijlmin=ijlmin-(lmin-1.)*ip1jmp1 + jmin=(ijlmin-1)/iip1+1 + imin=ijlmin-(jmin-1.)*iip1 + zqmin=zq(ijlmin,lmin) + + ijlmax=ismax(ijp1llm,zq,1) + lmax=(ijlmax-1)/ip1jmp1+1 + ijlmax=ijlmax-(lmax-1.)*ip1jmp1 + jmax=(ijlmax-1)/iip1+1 + imax=ijlmax-(jmax-1.)*iip1 + zqmax=zq(ijlmax,lmax) + + if(zqmin.lt.qmin) +c s write(*,9999) comment, + s write(*,*) comment, + s imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin) + if(zqmax.gt.qmax) +c s write(*,9999) comment, + s write(*,*) comment, + s imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax) +#endif + return +9999 format(a20,' q(',i3,',',i2,',',i2,')=',e12.5,e12.5) + end + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlspltgen_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlspltgen_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlspltgen_p.F (revision 1634) @@ -0,0 +1,497 @@ +! +! $Header$ +! + SUBROUTINE vlspltgen_p( q,iadv,pente_max,masse,w,pbaru,pbarv,pdt, + , p,pk,teta ) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c + test sur humidite specifique: Q advecte< Qsat aval +c (F. Codron, 10/99) +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c teta temperature potentielle, p pression aux interfaces, +c pk exner au milieu des couches necessaire pour calculer Qsat +c -------------------------------------------------------------------- + USE parallel + USE mod_hallo + USE Write_Field_p + USE VAMPIR + USE infotrac, ONLY : nqtot + IMPLICIT NONE + +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + INTEGER iadv(nqtot) + REAL masse(ip1jmp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm,nqtot) + REAL w(ip1jmp1,llm),pdt + REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + REAL,SAVE :: qsat(ip1jmp1,llm) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: zm + REAL,SAVE :: mu(ip1jmp1,llm) + REAL,SAVE :: mv(ip1jm,llm) + REAL,SAVE :: mw(ip1jmp1,llm+1) + REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: zq + REAL zzpbar, zzw + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + +c--pour rapport de melange saturant-- + + REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play + REAL ptarg,pdelarg,foeew,zdelta + REAL tempe(ip1jmp1) + INTEGER ijb,ije,iq + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + type(request) :: MyRequest1 + type(request) :: MyRequest2 + +c fonction psat(T) + + FOEEW ( PTARG,PDELARG ) = EXP ( + * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) + + r2es = 380.11733 + r3les = 17.269 + r3ies = 21.875 + r4les = 35.86 + r4ies = 7.66 + retv = 0.6077667 + rtt = 273.16 + +c Allocate variables depending on dynamic variable nqtot + + IF (firstcall) THEN + firstcall=.FALSE. +!$OMP MASTER + ALLOCATE(zm(ip1jmp1,llm,nqtot)) + ALLOCATE(zq(ip1jmp1,llm,nqtot)) +!$OMP END MASTER +!$OMP BARRIER + END IF +c-- Calcul de Qsat en chaque point +c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 +c pour eviter une exponentielle. + + call SetTag(MyRequest1,100) + call SetTag(MyRequest2,101) + + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + tempe(ij) = teta(ij,l) * pk(ij,l) /cpp + ENDDO + DO ij = ijb, ije + zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) + play = 0.5*(p(ij,l)+p(ij,l+1)) + qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) + qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c PRINT*,'Debut vlsplt version debug sans vlyqs' + + zzpbar = 0.5 * pdt + zzw = pdt + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij = ijb,ije + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + mw(ij,llm+1)=0. + ENDDO +c$OMP END MASTER + +c CALL SCOPY(ijp1llm,q,1,zq,1) +c CALL SCOPY(ijp1llm,masse,1,zm,1) + + ijb=ij_begin + ije=ij_end + + DO iq=1,nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + zq(ijb:ije,l,iq)=q(ijb:ije,l,iq) + zm(ijb:ije,l,iq)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + ENDDO + + +c$OMP BARRIER + DO iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + +#ifdef _ADV_HALO + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin,ij_begin+2*iip1-1) + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_end-2*iip1+1,ij_end) +#else + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin,ij_end) +#endif + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + else if (iadv(iq)==14) then + +#ifdef _ADV_HALO + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin,ij_begin+2*iip1-1) + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_end-2*iip1+1,ij_end) +#else + + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin,ij_end) +#endif + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call SendRequest(MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + +#ifdef _ADV_HALLO + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + else if (iadv(iq)==14) then +#ifdef _ADV_HALLO + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + +! call WaitRecvRequest(MyRequest1) +! call WaitSendRequest(MyRequest1) +c$OMP BARRIER + call WaitRequest(MyRequest1) + + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv) + + else if (iadv(iq)==14) then + + call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10 .or. iadv(iq)==14 ) then + +c$OMP BARRIER +#ifdef _ADV_HALLO + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_begin,ij_begin+2*iip1-1) + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_end-2*iip1+1,ij_end) +#else + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_begin,ij_end) +#endif +c$OMP BARRIER + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest2) + call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo +c$OMP BARRIER + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call SendRequest(MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + +c$OMP BARRIER + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10 .or. iadv(iq)==14 ) then +c$OMP BARRIER + +#ifdef _ADV_HALLO + call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + +c$OMP BARRIER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + +! call WaitRecvRequest(MyRequest2) +! call WaitSendRequest(MyRequest2) +c$OMP BARRIER + CALL WaitRequest(MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv) + + else if (iadv(iq)==14) then + + call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu, + & ij_begin,ij_end) + + else if (iadv(iq)==14) then + + call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat, + & ij_begin,ij_end) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + + ijb=ij_begin + ije=ij_end +c$OMP BARRIER + + + DO iq=1,nqtot + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije +c print *,'zq-->',ij,l,iq,zq(ij,l,iq) +c print *,'q-->',ij,l,iq,q(ij,l,iq) + q(ij,l,iq)=zq(ij,l,iq) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-iip1+1,iip1 + q(ij+iim,l,iq)=q(ij,l,iq) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + +c$OMP BARRIER + +cc$OMP MASTER +c call WaitSendRequest(MyRequest1) +c call WaitSendRequest(MyRequest2) +cc$OMP END MASTER +cc$OMP BARRIER + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlspltqs_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlspltqs_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/vlspltqs_p.F (revision 1634) @@ -0,0 +1,940 @@ +c +c $Id$ +c + SUBROUTINE vlspltqs_p ( q,pente_max,masse,w,pbaru,pbarv,pdt, + , p,pk,teta ) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c + test sur humidite specifique: Q advecte< Qsat aval +c (F. Codron, 10/99) +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c teta temperature potentielle, p pression aux interfaces, +c pk exner au milieu des couches necessaire pour calculer Qsat +c -------------------------------------------------------------------- + USE parallel + USE mod_hallo + USE VAMPIR + IMPLICIT NONE + +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt + REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL qsat(ip1jmp1,llm) + REAL zm(ip1jmp1,llm) + REAL mu(ip1jmp1,llm) + REAL mv(ip1jm,llm) + REAL mw(ip1jmp1,llm+1) + REAL zq(ip1jmp1,llm) + REAL temps1,temps2,temps3 + REAL zzpbar, zzw + LOGICAL testcpu + SAVE testcpu + SAVE temps1,temps2,temps3 + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + DATA testcpu/.false./ + DATA temps1,temps2,temps3/0.,0.,0./ + +c--pour rapport de melange saturant-- + + REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play + REAL ptarg,pdelarg,foeew,zdelta + REAL tempe(ip1jmp1) + INTEGER ijb,ije + type(request) :: MyRequest1 + type(request) :: MyRequest2 + +c fonction psat(T) + + FOEEW ( PTARG,PDELARG ) = EXP ( + * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) + + r2es = 380.11733 + r3les = 17.269 + r3ies = 21.875 + r4les = 35.86 + r4ies = 7.66 + retv = 0.6077667 + rtt = 273.16 + +c-- Calcul de Qsat en chaque point +c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 +c pour eviter une exponentielle. + + call SetTag(MyRequest1,100) + call SetTag(MyRequest2,101) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + + + DO l = 1, llm + DO ij = ijb, ije + tempe(ij) = teta(ij,l) * pk(ij,l) /cpp + ENDDO + DO ij = ijb, ije + zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) + play = 0.5*(p(ij,l)+p(ij,l+1)) + qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) + qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) + ENDDO + ENDDO + +c PRINT*,'Debut vlsplt version debug sans vlyqs' + + zzpbar = 0.5 * pdt + zzw = pdt + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + + DO l=1,llm + DO ij = ijb,ije + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + DO ij=ijb,ije + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + ENDDO + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=ijb,ije + mw(ij,llm+1)=0. + ENDDO + +c CALL SCOPY(ijp1llm,q,1,zq,1) +c CALL SCOPY(ijp1llm,masse,1,zm,1) + + ijb=ij_begin + ije=ij_end + zq(ijb:ije,1:llm)=q(ijb:ije,1:llm) + zm(ijb:ije,1:llm)=masse(ijb:ije,1:llm) + + + call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_begin+2*iip1-1) + call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_end-2*iip1+1,ij_end) + + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1) + call SendRequest(MyRequest1) + call VTe(VTHallo) + + call vlxqs_p(zq,pente_max,zm,mu,qsat, + . ij_begin+2*iip1,ij_end-2*iip1) + + call VTb(VTHallo) + call WaitRecvRequest(MyRequest1) + call VTe(VTHallo) + + call vlyqs_p(zq,pente_max,zm,mv,qsat) + + call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1) + call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end) + + call VTb(VTHallo) + call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2) + call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2) + call SendRequest(MyRequest2) + call VTe(VTHallo) + + call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1) + + call VTb(VTHallo) + call WaitRecvRequest(MyRequest2) + call VTe(VTHallo) + + call vlyqs_p(zq,pente_max,zm,mv,qsat) + + + call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_end) + + + ijb=ij_begin + ije=ij_end + + DO l=1,llm + DO ij=ijb,ije + q(ij,l)=zq(ij,l) + ENDDO + ENDDO + + DO l=1,llm + DO ij=ijb,ije-iip1+1,iip1 + q(ij+iim,l)=q(ij,l) + ENDDO + ENDDO + + call WaitSendRequest(MyRequest1) + call WaitSendRequest(MyRequest2) + + RETURN + END + SUBROUTINE vlxqs_p(q,pente_max,masse,u_m,qsat,ijb_x,ije_x) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL u_m( ip1jmp1,llm ) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ip1jmp1,llm) + REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1) + REAL zz(ip1jmp1) + REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) + REAL u_mq(ip1jmp1,llm) + + REAL SSUM + + + INTEGER ijb,ije,ijb_x,ije_x + + +c calcul de la pente a droite et a gauche de la maille + +c ijb=ij_begin +c ije=ij_end + + ijb=ijb_x + ije=ije_x + + if (pole_nord.and.ijb==1) ijb=ijb+iip1 + if (pole_sud.and.ije==ip1jmp1) ije=ije-iip1 + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=ijb,ije + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=ijb+1,ije + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=ijb+iip1-1,ije,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=ijb+1,ije +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +c$OMP END DO NOWAIT + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=ijb+1,ije + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + + DO ij=ijb,ije + iadvplus(ij,l)=0 + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + iadvplus(1:iip1,l)=0 + ENDDO +c$OMP END DO NOWAIT + endif + + if (pole_sud) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + iadvplus(ip1jm+1:ip1jmp1,l)=0 + ENDDO +c$OMP END DO NOWAIT + endif + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c--pas encore modification sur Qsat +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +#endif + + +c detection des points ou on advecte plus que la masse de la +c maille +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c pas d'influence de la pression saturante (pour l'instant) + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + nl(l)=0 + DO ij=ijb,ije + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO +c$OMP END DO NOWAIT + +cym ATTENTION ICI en OpenMP reduction pas forcement nécessaire +cym IF(n0.gt.1) THEN +cym IF(n0.gt.0) THEN +ccc PRINT*,'Nombre de points pour lesquels on advect plus que le' +ccc & ,'contenu de la maille : ',n0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=ijb,ije + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO +c$OMP END DO NOWAIT +cym ENDIF ! n0.gt.0 + + + +c bouclage en latitude +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c calcul des tendances +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+1,ije + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=ijb+iip1-1,ije,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + SUBROUTINE vlyqs_p(q,pente_max,masse,masse_adv_v,qsat) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c qsat est un argument de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ip1jmp1,llm),pente_max + REAL masse_adv_v( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL qsat(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ip1jmp1,llm),dyqv(ip1jm) + REAL adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical first + SAVE first +c$OMP THREADPRIVATE(first) + REAL convpn,convps,convmpn,convmps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon + SAVE airej2,airejjm +c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) +c$OMP THREADPRIVATE(airej2,airejjm) +c +c + REAL SSUM + + DATA first/.true./ + INTEGER ijb,ije + + IF(first) THEN + PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + if (pole_nord) then + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + endif + + if (pole_sud) then + DO i = 1, iim + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpsn = SSUM( iim, airesch ,1 ) / airejjm + endif + + +c calcul des pentes aux points v + + ijb=ij_begin-2*iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + + +c calcul des pentes aux points scalaires + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + + IF (pole_nord) THEN + +c calcul des pentes aux poles + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + ENDDO + +c filtrage de la derivee + dyn1=0. + dyn2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + fn=1. + DO ij=1,iim + IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN + fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) + ENDIF + ENDDO + + DO ij=1,iip1 + dyq(ij,l)=fn*dyq(ij,l) + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + + dys1=0. + dys2=0. + + DO ij=1,iim + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + fs=1. + DO ij=1,iim + IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN + fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) + ENDIF + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) + ENDDO + + ENDIF + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C appn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) +C apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) +C ENDDO +C appn=min(pente_max/appn,1.) +C apps=min(pente_max/apps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & appn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & apps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=appn*dyq(ij) +C dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + IF( masse_adv_v(ij,l).GT.0. ) THEN + qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l ) + + , dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))) + ELSE + qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) * + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) ) + ENDIF + qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version + + IF (pole_nord) THEN + + convpn=SSUM(iim,qbyv(1,l),1)/apoln + convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + DO ij = 1,iip1 + newmasse=masse(ij,l)+convmpn*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + + ENDIF + + IF (pole_sud) THEN + + convps = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols + convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols + DO ij = ip1jm+1,ip1jmp1 + newmasse=masse(ij,l)+convmps*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + + ENDIF +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/wrgrads.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/wrgrads.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/wrgrads.F (revision 1634) @@ -0,0 +1,128 @@ +! +! $Header$ +! + subroutine wrgrads(if,nl,field,name,titlevar) + implicit none + +c Declarations +c if indice du fichier +c nl nombre de couches +c field champ +c name petit nom +c titlevar Titre + +#include "gradsdef.h" + +c arguments + integer if,nl + real field(imx*jmx*lmx) + character*10 name,file + character*10 titlevar + +c local + + integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf + + logical writectl + + + writectl=.false. + + print*,if,iid(if),jid(if),ifd(if),jfd(if) + iii=iid(if) + iji=jid(if) + iif=ifd(if) + ijf=jfd(if) + im=iif-iii+1 + jm=ijf-iji+1 + lm=lmd(if) + + print*,'im,jm,lm,name,firsttime(if)' + print*,im,jm,lm,name,firsttime(if) + + if(firsttime(if)) then + if(name.eq.var(1,if)) then + firsttime(if)=.false. + ivar(if)=1 + print*,'fin de l initialiation de l ecriture du fichier' + print*,file + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + else + ivar(if)=ivar(if)+1 + nvar(if)=ivar(if) + var(ivar(if),if)=name + tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar)) + nld(ivar(if),if)=nl + print*,'initialisation ecriture de ',var(ivar(if),if) + print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) + endif + writectl=.true. + itime(if)=1 + else + ivar(if)=mod(ivar(if),nvar(if))+1 + if (ivar(if).eq.nvar(if)) then + writectl=.true. + itime(if)=itime(if)+1 + endif + + if(var(ivar(if),if).ne.name) then + print*,'Il faut stoker la meme succession de champs a chaque' + print*,'pas de temps' + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + + stop + endif + endif + + print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' + print*,ivar(if),nvar(if),var(ivar(if),if),writectl + do l=1,nl + irec(if)=irec(if)+1 +c print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, +c s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii +c s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif + write(unit(if)+1,rec=irec(if)) + s ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) + s ,i=iii,iif),j=iji,ijf) + enddo + if (writectl) then + + file=fichier(if) +c WARNING! on reecrase le fichier .ctl a chaque ecriture + open(unit(if),file=file(1:lnblnk(file))//'.ctl' + & ,form='formatted',status='unknown') + write(unit(if),'(a5,1x,a40)') + & 'DSET ','^'//file(1:lnblnk(file))//'.dat' + + write(unit(if),'(a12)') 'UNDEF 1.0E30' + write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) + call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') + call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') + call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') + write(unit(if),'(a4,i10,a30)') + & 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' + write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) + do iv=1,nvar(if) +c print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' +c print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) + write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) + & ,99,tvar(iv,if) + enddo + write(unit(if),'(a7)') 'ENDVARS' +c +1000 format(a5,3x,i4,i3,1x,a39) + + close(unit(if)) + + endif ! writectl + + return + + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/write_field_p.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/write_field_p.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/write_field_p.F90 (revision 1634) @@ -0,0 +1,73 @@ +module write_field_p +implicit none + + interface WriteField_p + module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p + end interface WriteField_p + + contains + + subroutine write_field1D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=1 + character(len=*) :: name + real, dimension(:) :: Field + real, dimension(:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + + Dim=shape(Field) + allocate(New_Field(Dim(1))) + New_Field(:)=Field(:) + call Gather_Field(New_Field,dim(1),1,0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + end subroutine write_field1D_p + + subroutine write_field2D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=2 + character(len=*) :: name + real, dimension(:,:) :: Field + real, dimension(:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + Dim=shape(Field) + allocate(New_Field(Dim(1),Dim(2))) + New_Field(:,:)=Field(:,:) + call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + + end subroutine write_field2D_p + + subroutine write_field3D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=3 + character(len=*) :: name + real, dimension(:,:,:) :: Field + real, dimension(:,:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + Dim=shape(Field) + allocate(New_Field(Dim(1),Dim(2),Dim(3))) + New_Field(:,:,:)=Field(:,:,:) + call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + end subroutine write_field3D_p + +end module write_field_p + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/write_grads_dyn.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/write_grads_dyn.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/write_grads_dyn.h (revision 1634) @@ -0,0 +1,31 @@ +! +! $Header$ +! + if (callinigrads) then + + string10='dyn' + call inigrads(1,iip1 + s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dtvr*iperiod,string10,'dyn_zon ') + + callinigrads=.false. + + + endif + + string10='ps' + CALL wrgrads(1,1,ps,string10,string10) + + string10='u' + CALL wrgrads(1,llm,unat,string10,string10) + string10='v' + CALL wrgrads(1,llm,vnat,string10,string10) + string10='teta' + CALL wrgrads(1,llm,teta,string10,string10) + do iq=1,nqtot + string10='q' + write(string10(2:2),'(i1)') iq + CALL wrgrads(1,llm,q(:,:,iq),string10,string10) + enddo + Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/writedynav_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/writedynav_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/writedynav_p.F (revision 1634) @@ -0,0 +1,169 @@ +! +! $Id$ +! + subroutine writedynav_p( histid, time, vcov, + , ucov,teta,ppk,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm),ppk(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll + real us(ip1jmp1,llm), vs(ip1jmp1,llm) + real tm(ip1jmp1,llm) + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn +C +C Initialisations +C + if (adjust) return + + ndex3d = 0 + ndex2d = 0 + ok_sync = .TRUE. + us = 999.999 + vs = 999.999 + tm = 999.999 + vnat = 999.999 + unat = 999.999 + itau_w = itau_dyn + time + +C Passage aux composantes naturelles du vent + call covnat_p(llm, ucov, vcov, unat, vnat) + +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U scalaire +C + call gr_u_scal_p(llm, unat, us) + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'u', itau_w, us(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Vents V scalaire +C + + call gr_v_scal_p(llm, vnat, vs) + call histwrite(histid, 'v', itau_w, vs(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Temperature potentielle moyennee +C + + call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Temperature moyennee +C + do ll=1,llm + do ii = ijb, ije + tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp + enddo + enddo + + call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), + . iip1*jjn*llm, ndex3d) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1), + . iip1*jjn, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndex2d) +C +C Fin +C + if (ok_sync) call histsync(histid) +#else + write(lunout,*)'writedynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/writehist_p.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/writehist_p.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/dyn3dpar/writehist_p.F (revision 1634) @@ -0,0 +1,156 @@ +! +! $Id$ +! + subroutine writehist_p( histid, histvid, time, vcov, + , ucov,teta,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C histvid:ID du fichier histoire pour les vents V (appele a disparaitre) +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid, histvid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer iq, ii, ll + integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn +C +C Initialisations +C + if (adjust) return + + + ndexu = 0 + ndexv = 0 + ndex2d = 0 + ok_sync =.TRUE. + itau_w = itau_dyn + time +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'ucov', itau_w, ucov(ijb:ije,:), + . iip1*jjn*llm, ndexu) + +C +C Vents V +C + if (pole_sud) ije=ij_end-iip1 + if (pole_sud) jjn=jj_nb-1 + + call histwrite(histvid, 'vcov', itau_w, vcov(ijb:ije,:), + . iip1*jjn*llm, ndexv) + +C +C Temperature potentielle +C + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'teta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndexu) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndexu) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), + . iip1*jjn*llm, ndexu) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1), + . iip1*jjn, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndex2d) +C +C Fin +C + if (ok_sync) then + call histsync(histid) + call histsync(histvid) + endif +#else + write(lunout,*)'writehist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/acc.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/acc.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/acc.F (revision 1634) @@ -0,0 +1,17 @@ +! +! $Header$ +! + subroutine acc(vec,d,im) + dimension vec(im,im),d(im) + do j=1,im + do i=1,im + d(i)=vec(i,j)*vec(i,j) + enddo + sum=ssum(im,d,1) + sum=sqrt(sum) + do i=1,im + vec(i,j)=vec(i,j)/sum + enddo + enddo + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/coefils.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/coefils.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/coefils.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! + COMMON/coefils/jfiltnu,jfiltsu,jfiltnv,jfiltsv,sddu(iim),sddv(iim)& + & ,unsddu(iim),unsddv(iim),coefilu(iim,jjm),coefilv(iim,jjm), & + & modfrstu(jjm),modfrstv(jjm),eignfnu(iim,iim),eignfnv(iim,iim) & + & ,coefilu2(iim,jjm),coefilv2(iim,jjm) +!c + INTEGER jfiltnu,jfiltsu,jfiltnv,jfiltsv,modfrstu,modfrstv + REAL sddu,sddv,unsddu,unsddv,coefilu,coefilv,eignfnu,eignfnv + REAL coefilu2,coefilv2 Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/eigen.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/eigen.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/eigen.F (revision 1634) @@ -0,0 +1,31 @@ +! +! $Header$ +! + SUBROUTINE eigen( e,d) +#include "dimensions.h" + dimension e( iim,iim ), d( iim ) + dimension asm( iim ) + im=iim +c + DO 48 i = 1,im + asm( i ) = d( im-i+1 ) + 48 CONTINUE + DO 49 i = 1,iim + d( i ) = asm( i ) + 49 CONTINUE +c +c PRINT 70,d + 70 FORMAT(5x,'Valeurs propres',/,8(1x,8f10.4,/),/) + print * +c + DO 51 i = 1,im + DO 52 j = 1,im + asm( j ) = e( i , im-j+1 ) + 52 CONTINUE + DO 50 j = 1,im + e( i,j ) = asm( j ) + 50 CONTINUE + 51 CONTINUE + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/eigen_sort.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/eigen_sort.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/eigen_sort.F (revision 1634) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE eigen_sort(d,v,n,np) + INTEGER n,np + REAL d(np),v(np,np) + INTEGER i,j,k + REAL p + + DO i=1,n-1 + k=i + p=d(i) + DO j=i+1,n + IF(d(j).ge.p) THEN + k=j + p=d(j) + ENDIF + ENDDO + + IF(k.ne.i) THEN + d(k)=d(i) + d(i)=p + DO j=1,n + p=v(j,i) + v(j,i)=v(j,k) + v(j,k)=p + ENDDO + ENDIF + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/filtreg.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/filtreg.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/filtreg.F (revision 1634) @@ -0,0 +1,319 @@ +! +! $Header$ +! + SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire, + & griscal ,iter) + + USE filtreg_mod + + IMPLICIT NONE +c======================================================================= +c +c Auteur: P. Le Van 07/10/97 +c ------ +c +c Objet: filtre matriciel longitudinal ,avec les matrices precalculees +c pour l'operateur Filtre . +c ------ +c +c Arguments: +c ---------- +c +c nblat nombre de latitudes a filtrer +c nbniv nombre de niveaux verticaux a filtrer +c champ(iip1,nblat,nbniv) en entree : champ a filtrer +c en sortie : champ filtre +c ifiltre +1 Transformee directe +c -1 Transformee inverse +c +2 Filtre directe +c -2 Filtre inverse +c +c iaire 1 si champ intensif +c 2 si champ extensif (pondere par les aires) +c +c iter 1 filtre simple +c +c======================================================================= +c +c +c Variable Intensive +c ifiltre = 1 filtre directe +c ifiltre =-1 filtre inverse +c +c Variable Extensive +c ifiltre = 2 filtre directe +c ifiltre =-2 filtre inverse +c +c +#include "dimensions.h" +#include "paramet.h" +#include "coefils.h" + + INTEGER nlat,nbniv,ifiltre,iter + INTEGER i,j,l,k + INTEGER iim2,immjm + INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil + + REAL champ( iip1,nlat,nbniv) + + REAL eignq(iim,nlat,nbniv), sdd1(iim),sdd2(iim) + LOGICAL griscal + INTEGER hemisph, iaire + + LOGICAL,SAVE :: first=.TRUE. + + REAL, SAVE :: sdd12(iim,4) + + INTEGER, PARAMETER :: type_sddu=1 + INTEGER, PARAMETER :: type_sddv=2 + INTEGER, PARAMETER :: type_unsddu=3 + INTEGER, PARAMETER :: type_unsddv=4 + + INTEGER :: sdd1_type, sdd2_type + + IF (first) THEN + sdd12(1:iim,type_sddu) = sddu(1:iim) + sdd12(1:iim,type_sddv) = sddv(1:iim) + sdd12(1:iim,type_unsddu) = unsddu(1:iim) + sdd12(1:iim,type_unsddv) = unsddv(1:iim) + + first=.FALSE. + ENDIF + + IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) + & STOP'Pas de transformee simple dans cette version' + + IF( iter.EQ. 2 ) THEN + PRINT *,' Pas d iteration du filtre dans cette version !' + & , ' Utiliser old_filtreg et repasser !' + STOP + ENDIF + + IF( ifiltre.EQ. -2 .AND..NOT.griscal ) THEN + PRINT *,' Cette routine ne calcule le filtre inverse que ' + & , ' sur la grille des scalaires !' + STOP + ENDIF + + IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 ) THEN + PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' + & , ' corriger et repasser !' + STOP + ENDIF + + iim2 = iim * iim + immjm = iim * jjm + + IF( griscal ) THEN + IF( nlat. NE. jjp1 ) THEN + PRINT 1111 + STOP + ELSE + + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddv + sdd2_type = type_unsddv + ELSE + sdd1_type = type_unsddv + sdd2_type = type_sddv + ENDIF + +c IF( iaire.EQ.1 ) THEN +c CALL SCOPY( iim, sddv, 1, sdd1, 1 ) +c CALL SCOPY( iim, unsddv, 1, sdd2, 1 ) +c ELSE +c CALL SCOPY( iim, unsddv, 1, sdd1, 1 ) +c CALL SCOPY( iim, sddv, 1, sdd2, 1 ) +c END IF + + jdfil1 = 2 + jffil1 = jfiltnu + jdfil2 = jfiltsu + jffil2 = jjm + END IF + ELSE + IF( nlat.NE.jjm ) THEN + PRINT 2222 + STOP + ELSE + + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddu + sdd2_type = type_unsddu + ELSE + sdd1_type = type_unsddu + sdd2_type = type_sddu + ENDIF + +c IF( iaire.EQ.1 ) THEN +c CALL SCOPY( iim, sddu, 1, sdd1, 1 ) +c CALL SCOPY( iim, unsddu, 1, sdd2, 1 ) +c ELSE +c CALL SCOPY( iim, unsddu, 1, sdd1, 1 ) +c CALL SCOPY( iim, sddu, 1, sdd2, 1 ) +c END IF + + jdfil1 = 1 + jffil1 = jfiltnv + jdfil2 = jfiltsv + jffil2 = jjm + END IF + END IF + + DO hemisph = 1, 2 + + IF ( hemisph.EQ.1 ) THEN + jdfil = jdfil1 + jffil = jffil1 + ELSE + jdfil = jdfil2 + jffil = jffil2 + END IF + + DO l = 1, nbniv + DO j = jdfil,jffil + DO i = 1, iim + champ(i,j,l) = champ(i,j,l) * sdd12(i,sdd1_type) ! sdd1(i) + END DO + END DO + END DO + + IF( hemisph. EQ. 1 ) THEN + + IF( ifiltre. EQ. -2 ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matrinvn(1,1,j), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matrinvn(:,:,j), champ(:iim,j,:)) +#endif + END DO + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matriceun(1,1,j), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matriceun(:,:,j), champ(:iim,j,:)) +#endif + END DO + + ELSE + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matricevn(1,1,j), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matricevn(:,:,j), champ(:iim,j,:)) +#endif + END DO + + ENDIF + + ELSE + + IF( ifiltre. EQ. -2 ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matrinvs(1,1,j-jfiltsu+1), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matrinvs(:,:,j-jfiltsu+1), + $ champ(:iim,j,:)) +#endif + END DO + + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matriceus(1,1,j-jfiltsu+1), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matriceus(:,:,j-jfiltsu+1), + $ champ(:iim,j,:)) +#endif + END DO + + ELSE + + DO j = jdfil,jffil +#ifdef BLAS + CALL DGEMM("N", "N", iim, nbniv, iim, 1.0, + & matricevs(1,1,j-jfiltsv+1), + & iim, champ(1,j,1), iip1*nlat, 0.0, + & eignq(1,j-jdfil+1,1), iim*nlat) +#else + eignq(:,j-jdfil+1,:) + $ = matmul(matricevs(:,:,j-jfiltsv+1), + $ champ(:iim,j,:)) +#endif + END DO + + ENDIF + + ENDIF + + IF( ifiltre.EQ. 2 ) THEN + + DO l = 1, nbniv + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = + & (champ(i,j,l) + eignq(i,j-jdfil+1,l)) + & * sdd12(i,sdd2_type) ! sdd2(i) + END DO + END DO + END DO + + ELSE + + DO l = 1, nbniv + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = + & (champ(i,j,l) - eignq(i,j-jdfil+1,l)) + & * sdd12(i,sdd2_type) ! sdd2(i) + END DO + END DO + END DO + + ENDIF + + DO l = 1, nbniv + DO j = jdfil,jffil + champ( iip1,j,l ) = champ( 1,j,l ) + END DO + END DO + + + ENDDO + +1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a + & filtrer, sur la grille des scalaires'/) +2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi + & ltrer, sur la grille de V ou de Z'/) + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/filtreg_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/filtreg_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/filtreg_mod.F90 (revision 1634) @@ -0,0 +1,536 @@ +MODULE filtreg_mod + + REAL, DIMENSION(:,:,:), ALLOCATABLE :: matriceun,matriceus,matricevn + REAL, DIMENSION(:,:,:), ALLOCATABLE :: matricevs,matrinvn,matrinvs + +CONTAINS + + SUBROUTINE inifilr + USE mod_filtre_fft + ! + ! ... H. Upadhyaya, O.Sharma ... + ! + IMPLICIT NONE + ! + ! version 3 ..... + + ! Correction le 28/10/97 P. Le Van . + ! ------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" + ! ------------------------------------------------------------------- +#include "comgeom.h" +#include "coefils.h" +#include "logic.h" +#include "serre.h" + + REAL dlonu(iim),dlatu(jjm) + REAL rlamda( iim ), eignvl( iim ) + ! + + REAL lamdamax,pi,cof + INTEGER i,j,modemax,imx,k,kf,ii + REAL dymin,dxmin,colat0 + REAL eignft(iim,iim), coff + + LOGICAL, SAVE :: first_call_inifilr = .TRUE. + +#ifdef CRAY + INTEGER ISMIN + EXTERNAL ISMIN + INTEGER iymin + INTEGER ixmineq +#endif + EXTERNAL inifgn + ! + ! ------------------------------------------------------------ + ! This routine computes the eigenfunctions of the laplacien + ! on the stretched grid, and the filtering coefficients + ! + ! We designate: + ! eignfn eigenfunctions of the discrete laplacien + ! eigenvl eigenvalues + ! jfiltn indexof the last scalar line filtered in NH + ! jfilts index of the first line filtered in SH + ! modfrst index of the mode from WHERE modes are filtered + ! modemax maximum number of modes ( im ) + ! coefil filtering coefficients ( lamda_max*COS(rlat)/lamda ) + ! sdd SQRT( dx ) + ! + ! the modes are filtered from modfrst to modemax + ! + !----------------------------------------------------------- + ! + + pi = 2. * ASIN( 1. ) + + DO i = 1,iim + dlonu(i) = xprimu( i ) + ENDDO + ! + CALL inifgn(eignvl) + ! + PRINT *,' EIGNVL ' + PRINT 250,eignvl +250 FORMAT( 1x,5e13.6) + ! + ! compute eigenvalues and eigenfunctions + ! + ! + !................................................................. + ! + ! compute the filtering coefficients for scalar lines and + ! meridional wind v-lines + ! + ! we filter all those latitude lines WHERE coefil < 1 + ! NO FILTERING AT POLES + ! + ! colat0 is to be used when alpha (stretching coefficient) + ! is set equal to zero for the regular grid CASE + ! + ! ....... Calcul de colat0 ......... + ! ..... colat0 = minimum de ( 0.5, min dy/ min dx ) ... + ! + ! + DO j = 1,jjm + dlatu( j ) = rlatu( j ) - rlatu( j+1 ) + ENDDO + ! +#ifdef CRAY + iymin = ISMIN( jjm, dlatu, 1 ) + ixmineq = ISMIN( iim, dlonu, 1 ) + dymin = dlatu( iymin ) + dxmin = dlonu( ixmineq ) +#else + dxmin = dlonu(1) + DO i = 2, iim + dxmin = MIN( dxmin,dlonu(i) ) + ENDDO + dymin = dlatu(1) + DO j = 2, jjm + dymin = MIN( dymin,dlatu(j) ) + ENDDO +#endif + ! + ! + colat0 = MIN( 0.5, dymin/dxmin ) + ! + IF( .NOT.fxyhypb.AND.ysinus ) THEN + colat0 = 0.6 + ! ...... a revoir pour ysinus ! ....... + alphax = 0. + ENDIF + ! + PRINT 50, colat0,alphax +50 FORMAT(/15x,' Inifilr colat0 alphax ',2e16.7) + ! + IF(alphax.EQ.1. ) THEN + PRINT *,' Inifilr alphax doit etre < a 1. Corriger ' + STOP + ENDIF + ! + lamdamax = iim / ( pi * colat0 * ( 1. - alphax ) ) + + ! ... Correction le 28/10/97 ( P.Le Van ) .. + ! + DO i = 2,iim + rlamda( i ) = lamdamax/ SQRT( ABS( eignvl(i) ) ) + ENDDO + ! + + DO j = 1,jjm + DO i = 1,iim + coefilu( i,j ) = 0.0 + coefilv( i,j ) = 0.0 + coefilu2( i,j ) = 0.0 + coefilv2( i,j ) = 0.0 + ENDDO + ENDDO + + ! + ! ... Determination de jfiltnu,jfiltnv,jfiltsu,jfiltsv .... + ! ......................................................... + ! + modemax = iim + +!!!! imx = modemax - 4 * (modemax/iim) + + imx = iim + ! + PRINT *,' TRUNCATION AT ',imx + ! + DO j = 2, jjm/2+1 + cof = COS( rlatu(j) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatu(j) ).LT.1. ) jfiltnu= j + ENDIF + + cof = COS( rlatu(jjp1-j+1) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatu(jjp1-j+1) ).LT.1. ) & + jfiltsu= jjp1-j+1 + ENDIF + ENDDO + ! + DO j = 1, jjm/2 + cof = COS( rlatv(j) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatv(j) ).LT.1. ) jfiltnv= j + ENDIF + + cof = COS( rlatv(jjm-j+1) )/ colat0 + IF ( cof .LT. 1. ) THEN + IF( rlamda(imx) * COS(rlatv(jjm-j+1) ).LT.1. ) & + jfiltsv= jjm-j+1 + ENDIF + ENDDO + ! + + IF ( jfiltnu.LE.0 ) jfiltnu=1 + IF( jfiltnu.GT. jjm/2 +1 ) THEN + PRINT *,' jfiltnu en dehors des valeurs acceptables ' ,jfiltnu + STOP + ENDIF + + IF( jfiltsu.LE.0) jfiltsu=1 + IF( jfiltsu.GT. jjm +1 ) THEN + PRINT *,' jfiltsu en dehors des valeurs acceptables ' ,jfiltsu + STOP + ENDIF + + IF( jfiltnv.LE.0) jfiltnv=1 + IF( jfiltnv.GT. jjm/2 ) THEN + PRINT *,' jfiltnv en dehors des valeurs acceptables ' ,jfiltnv + STOP + ENDIF + + IF( jfiltsv.LE.0) jfiltsv=1 + IF( jfiltsv.GT. jjm ) THEN + PRINT *,' jfiltsv en dehors des valeurs acceptables ' ,jfiltsv + STOP + ENDIF + + PRINT *,' jfiltnv jfiltsv jfiltnu jfiltsu ' , & + jfiltnv,jfiltsv,jfiltnu,jfiltsu + + IF(first_call_inifilr) THEN + ALLOCATE(matriceun(iim,iim,jfiltnu)) + ALLOCATE(matriceus(iim,iim,jfiltsu)) + ALLOCATE(matricevn(iim,iim,jfiltnv)) + ALLOCATE(matricevs(iim,iim,jfiltsv)) + ALLOCATE( matrinvn(iim,iim,jfiltnu)) + ALLOCATE( matrinvs(iim,iim,jfiltsu)) + first_call_inifilr = .FALSE. + ENDIF + + ! + ! ... Determination de coefilu,coefilv,n=modfrstu,modfrstv .... + !................................................................ + ! + ! + DO j = 1,jjm + modfrstu( j ) = iim + modfrstv( j ) = iim + ENDDO + ! + DO j = 2,jfiltnu + DO k = 2,modemax + cof = rlamda(k) * COS( rlatu(j) ) + IF ( cof .LT. 1. ) GOTO 82 + ENDDO + GOTO 84 +82 modfrstu( j ) = k + ! + kf = modfrstu( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatu(j) ) + coefilu(k,j) = cof - 1. + coefilu2(k,j) = cof*cof - 1. + ENDDO +84 CONTINUE + ENDDO + ! + ! + DO j = 1,jfiltnv + ! + DO k = 2,modemax + cof = rlamda(k) * COS( rlatv(j) ) + IF ( cof .LT. 1. ) GOTO 87 + ENDDO + GOTO 89 +87 modfrstv( j ) = k + ! + kf = modfrstv( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatv(j) ) + coefilv(k,j) = cof - 1. + coefilv2(k,j) = cof*cof - 1. + ENDDO +89 CONTINUE + ENDDO + ! + DO j = jfiltsu,jjm + DO k = 2,modemax + cof = rlamda(k) * COS( rlatu(j) ) + IF ( cof .LT. 1. ) GOTO 92 + ENDDO + GOTO 94 +92 modfrstu( j ) = k + ! + kf = modfrstu( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatu(j) ) + coefilu(k,j) = cof - 1. + coefilu2(k,j) = cof*cof - 1. + ENDDO +94 CONTINUE + ENDDO + ! + DO j = jfiltsv,jjm + DO k = 2,modemax + cof = rlamda(k) * COS( rlatv(j) ) + IF ( cof .LT. 1. ) GOTO 97 + ENDDO + GOTO 99 +97 modfrstv( j ) = k + ! + kf = modfrstv( j ) + DO k = kf , modemax + cof = rlamda(k) * COS( rlatv(j) ) + coefilv(k,j) = cof - 1. + coefilv2(k,j) = cof*cof - 1. + ENDDO +99 CONTINUE + ENDDO + ! + + IF(jfiltnv.GE.jjm/2 .OR. jfiltnu.GE.jjm/2)THEN + + IF(jfiltnv.EQ.jfiltsv)jfiltsv=1+jfiltnv + IF(jfiltnu.EQ.jfiltsu)jfiltsu=1+jfiltnu + + PRINT *,'jfiltnv jfiltsv jfiltnu jfiltsu' , & + jfiltnv,jfiltsv,jfiltnu,jfiltsu + ENDIF + + PRINT *,' Modes premiers v ' + PRINT 334,modfrstv + PRINT *,' Modes premiers u ' + PRINT 334,modfrstu + + ! + ! ................................................................... + ! + ! ... Calcul de la matrice filtre 'matriceu' pour les champs situes + ! sur la grille scalaire ........ + ! ................................................................... + ! + DO j = 2, jfiltnu + + DO i=1,iim + coff = coefilu(i,j) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM( eignfnv,iim,eignft,iim,matriceun(1,1,j),iim ) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, matriceun(1,1,j), iim) +#else + DO k = 1, iim + DO i = 1, iim + matriceun(i,k,j) = 0.0 + DO ii = 1, iim + matriceun(i,k,j) = matriceun(i,k,j) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + DO j = jfiltsu, jjm + + DO i=1,iim + coff = coefilu(i,j) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM(eignfnv,iim,eignft,iim,matriceus(1,1,j-jfiltsu+1),iim) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, & + matriceus(1,1,j-jfiltsu+1), iim) +#else + DO k = 1, iim + DO i = 1, iim + matriceus(i,k,j-jfiltsu+1) = 0.0 + DO ii = 1, iim + matriceus(i,k,j-jfiltsu+1) = matriceus(i,k,j-jfiltsu+1) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + ! ................................................................... + ! + ! ... Calcul de la matrice filtre 'matricev' pour les champs situes + ! sur la grille de V ou de Z ........ + ! ................................................................... + ! + DO j = 1, jfiltnv + + DO i = 1, iim + coff = coefilv(i,j) + IF( i.LT.modfrstv(j) ) coff = 0. + DO k = 1, iim + eignft(i,k) = eignfnu(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM( eignfnu,iim,eignft,iim,matricevn(1,1,j),iim ) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnu, iim, eignft, iim, 0.0, matricevn(1,1,j), iim) +#else + DO k = 1, iim + DO i = 1, iim + matricevn(i,k,j) = 0.0 + DO ii = 1, iim + matricevn(i,k,j) = matricevn(i,k,j) & + + eignfnu(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + DO j = jfiltsv, jjm + + DO i = 1, iim + coff = coefilv(i,j) + IF( i.LT.modfrstv(j) ) coff = 0. + DO k = 1, iim + eignft(i,k) = eignfnu(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM(eignfnu,iim,eignft,iim,matricevs(1,1,j-jfiltsv+1),iim) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnu, iim, eignft, iim, 0.0, & + matricevs(1,1,j-jfiltsv+1), iim) +#else + DO k = 1, iim + DO i = 1, iim + matricevs(i,k,j-jfiltsv+1) = 0.0 + DO ii = 1, iim + matricevs(i,k,j-jfiltsv+1) = matricevs(i,k,j-jfiltsv+1) & + + eignfnu(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + ! ................................................................... + ! + ! ... Calcul de la matrice filtre 'matrinv' pour les champs situes + ! sur la grille scalaire , pour le filtre inverse ........ + ! ................................................................... + ! + DO j = 2, jfiltnu + + DO i = 1,iim + coff = coefilu(i,j)/ ( 1. + coefilu(i,j) ) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM( eignfnv,iim,eignft,iim,matrinvn(1,1,j),iim ) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, matrinvn(1,1,j), iim) +#else + DO k = 1, iim + DO i = 1, iim + matrinvn(i,k,j) = 0.0 + DO ii = 1, iim + matrinvn(i,k,j) = matrinvn(i,k,j) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + DO j = jfiltsu, jjm + + DO i = 1,iim + coff = coefilu(i,j) / ( 1. + coefilu(i,j) ) + IF( i.LT.modfrstu(j) ) coff = 0. + DO k=1,iim + eignft(i,k) = eignfnv(k,i) * coff + ENDDO + ENDDO +#ifdef CRAY + CALL MXM(eignfnv,iim,eignft,iim,matrinvs(1,1,j-jfiltsu+1),iim) +#else +#ifdef BLAS + CALL SGEMM ('N', 'N', iim, iim, iim, 1.0, & + eignfnv, iim, eignft, iim, 0.0, matrinvs(1,1,j-jfiltsu+1), iim) +#else + DO k = 1, iim + DO i = 1, iim + matrinvs(i,k,j-jfiltsu+1) = 0.0 + DO ii = 1, iim + matrinvs(i,k,j-jfiltsu+1) = matrinvs(i,k,j-jfiltsu+1) & + + eignfnv(i,ii)*eignft(ii,k) + ENDDO + ENDDO + ENDDO +#endif +#endif + + ENDDO + + IF (use_filtre_fft) THEN + CALL Init_filtre_fft(coefilu,modfrstu,jfiltnu,jfiltsu, & + coefilv,modfrstv,jfiltnv,jfiltsv) + ENDIF + + ! ................................................................... + + ! +334 FORMAT(1x,24i3) +755 FORMAT(1x,6f10.3,i3) + + RETURN + END SUBROUTINE inifilr + +END MODULE filtreg_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/inifgn.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/inifgn.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/inifgn.F (revision 1634) @@ -0,0 +1,106 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/filtrez/inifgn.F,v 1.1.1.1 2004-05-19 12:53:09 lmdzadmin Exp $ +! + SUBROUTINE inifgn(dv) +c +c ... H.Upadyaya , O.Sharma ... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "serre.h" + +c + REAL vec(iim,iim),vec1(iim,iim) + REAL dlonu(iim),dlonv(iim) + REAL du(iim),dv(iim),d(iim) + REAL pi + INTEGER i,j,k,imm1,nrot +C +#include "coefils.h" +c + EXTERNAL SSUM, acc,eigen,jacobi + REAL SSUM +c + + imm1 = iim -1 + pi = 2.* ASIN(1.) +C + DO 5 i=1,iim + dlonu(i)= xprimu( i ) + dlonv(i)= xprimv( i ) + 5 CONTINUE + + DO 12 i=1,iim + sddv(i) = SQRT(dlonv(i)) + sddu(i) = SQRT(dlonu(i)) + unsddu(i) = 1./sddu(i) + unsddv(i) = 1./sddv(i) + 12 CONTINUE +C + DO 17 j=1,iim + DO 17 i=1,iim + vec(i,j) = 0. + vec1(i,j) = 0. + eignfnv(i,j) = 0. + eignfnu(i,j) = 0. + 17 CONTINUE +c +c + eignfnv(1,1) = -1. + eignfnv(iim,1) = 1. + DO 20 i=1,imm1 + eignfnv(i+1,i+1)= -1. + eignfnv(i,i+1) = 1. + 20 CONTINUE + DO 25 j=1,iim + DO 25 i=1,iim + eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j)) + 25 CONTINUE + DO 30 j=1,iim + DO 30 i=1,iim + eignfnu(i,j) = -eignfnv(j,i) + 30 CONTINUE +c +#ifdef CRAY + CALL MXM(eignfnu,iim,eignfnv,iim,vec ,iim) + CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim) +#else + DO j = 1, iim + DO i = 1, iim + vec (i,j) = 0.0 + vec1(i,j) = 0.0 + DO k = 1, iim + vec (i,j) = vec(i,j) + eignfnu(i,k) * eignfnv(k,j) + vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j) + ENDDO + ENDDO + ENDDO +#endif + +c + CALL jacobi(vec,iim,iim,dv,eignfnv,nrot) + CALL acc(eignfnv,d,iim) + CALL eigen_sort(dv,eignfnv,iim,iim) +c + CALL jacobi(vec1,iim,iim,du,eignfnu,nrot) + CALL acc(eignfnu,d,iim) + CALL eigen_sort(du,eignfnu,iim,iim) + +cc ancienne version avec appels IMSL +c +c CALL MXM(eignfnu,iim,eignfnv,iim,vec,iim) +c CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim) +c CALL EVCSF(iim,vec,iim,dv,eignfnv,iim) +c CALL acc(eignfnv,d,iim) +c CALL eigen(eignfnv,dv) +c +c CALL EVCSF(iim,vec1,iim,du,eignfnu,iim) +c CALL acc(eignfnu,d,iim) +c CALL eigen(eignfnu,du) + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/jacobi.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/jacobi.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/jacobi.F90 (revision 1634) @@ -0,0 +1,106 @@ +! +! $Id$ +! + SUBROUTINE JACOBI(A,N,NP,D,V,NROT) + implicit none +! Arguments: + integer,intent(in) :: N + integer,intent(in) :: NP + integer,intent(out) :: NROT + real,intent(inout) :: A(NP,NP) + real,intent(out) :: D(NP) + real,intent(out) :: V(NP,NP) + +! local variables: + integer :: IP,IQ,I,J + real :: SM,TRESH,G,H,T,THETA,C,S,TAU + real :: B(N) + real :: Z(N) + + DO IP=1,N + DO IQ=1,N + V(IP,IQ)=0. + ENDDO + V(IP,IP)=1. + ENDDO + DO IP=1,N + B(IP)=A(IP,IP) + D(IP)=B(IP) + Z(IP)=0. + ENDDO + NROT=0 + DO I=1,50 ! 50? I suspect this should be NP + ! but convergence is fast enough anyway + SM=0. + DO IP=1,N-1 + DO IQ=IP+1,N + SM=SM+ABS(A(IP,IQ)) + ENDDO + ENDDO + IF(SM.EQ.0.)RETURN + IF(I.LT.4)THEN + TRESH=0.2*SM/N**2 + ELSE + TRESH=0. + ENDIF + DO IP=1,N-1 + DO IQ=IP+1,N + G=100.*ABS(A(IP,IQ)) + IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP))) & + .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN + A(IP,IQ)=0. + ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN + H=D(IQ)-D(IP) + IF(ABS(H)+G.EQ.ABS(H))THEN + T=A(IP,IQ)/H + ELSE + THETA=0.5*H/A(IP,IQ) + T=1./(ABS(THETA)+SQRT(1.+THETA**2)) + IF(THETA.LT.0.)T=-T + ENDIF + C=1./SQRT(1+T**2) + S=T*C + TAU=S/(1.+C) + H=T*A(IP,IQ) + Z(IP)=Z(IP)-H + Z(IQ)=Z(IQ)+H + D(IP)=D(IP)-H + D(IQ)=D(IQ)+H + A(IP,IQ)=0. + DO J=1,IP-1 + G=A(J,IP) + H=A(J,IQ) + A(J,IP)=G-S*(H+G*TAU) + A(J,IQ)=H+S*(G-H*TAU) + ENDDO + DO J=IP+1,IQ-1 + G=A(IP,J) + H=A(J,IQ) + A(IP,J)=G-S*(H+G*TAU) + A(J,IQ)=H+S*(G-H*TAU) + ENDDO + DO J=IQ+1,N + G=A(IP,J) + H=A(IQ,J) + A(IP,J)=G-S*(H+G*TAU) + A(IQ,J)=H+S*(G-H*TAU) + ENDDO + DO J=1,N + G=V(J,IP) + H=V(J,IQ) + V(J,IP)=G-S*(H+G*TAU) + V(J,IQ)=H+S*(G-H*TAU) + ENDDO + NROT=NROT+1 + ENDIF + ENDDO + ENDDO + DO IP=1,N + B(IP)=B(IP)+Z(IP) + D(IP)=B(IP) + Z(IP)=0. + ENDDO + ENDDO ! of DO I=1,50 + STOP 'Jacobi: 50 iterations should never happen' + RETURN + END SUBROUTINE JACOBI Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft.F90 (revision 1634) @@ -0,0 +1,13 @@ +MODULE mod_fft + +#ifdef FFT_MATHKEISAN + USE mod_fft_mathkeisan +#elif FFT_FFTW + USE mod_fft_fftw +#elif FFT_MKL + USE mod_fft_mkl +#else + USE mod_fft_wrapper +#endif + +END MODULE mod_fft Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_fftw.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_fftw.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_fftw.F90 (revision 1634) @@ -0,0 +1,114 @@ +! +! $Id$ +! + +MODULE mod_fft_fftw + +#ifdef FFT_FFTW + + REAL, SAVE :: scale_factor + INTEGER, SAVE :: vsize + INTEGER, PARAMETER :: inc=1 + + INTEGER*8, ALLOCATABLE, DIMENSION(:), SAVE :: plan_forward + INTEGER*8, ALLOCATABLE, DIMENSION(:), SAVE :: plan_backward + +CONTAINS + + SUBROUTINE Init_fft(iim,nvectmax) + IMPLICIT NONE +#include + INTEGER :: iim + INTEGER :: nvectmax + + INTEGER :: itmp + + INTEGER :: rank + INTEGER :: howmany + INTEGER :: istride, idist + INTEGER :: ostride, odist + INTEGER, DIMENSION(1) :: n_array, inembed, onembed + + REAL, DIMENSION(iim+1,nvectmax) :: dbidon + COMPLEX, DIMENSION(iim/2+1,nvectmax) :: cbidon + + vsize = iim + scale_factor = 1./SQRT(1.*vsize) + + dbidon = 0 + cbidon = 0 + + ALLOCATE(plan_forward(nvectmax)) + ALLOCATE(plan_backward(nvectmax)) + + WRITE(*,*)"!---------------------!" + WRITE(*,*)"! !" + WRITE(*,*)"! INITIALISATION FFTW !" + WRITE(*,*)"! !" + WRITE(*,*)"!---------------------!" + +! On initialise tous les plans + DO itmp = 1, nvectmax + rank = 1 + n_array(1) = iim + howmany = itmp + inembed(1) = iim + 1 ; onembed(1) = iim/2 + 1 + istride = 1 ; ostride = 1 + idist = iim + 1 ; odist = iim/2 + 1 + + CALL dfftw_plan_many_dft_r2c(plan_forward(itmp), rank, n_array, howmany, & + & dbidon, inembed, istride, idist, & + & cbidon, onembed, ostride, odist, & + & FFTW_ESTIMATE) + + rank = 1 + n_array(1) = iim + howmany = itmp + inembed(1) = iim/2 + 1 ; onembed(1) = iim + 1 + istride = 1 ; ostride = 1 + idist = iim/2 + 1 ; odist = iim + 1 + CALL dfftw_plan_many_dft_c2r(plan_backward(itmp), rank, n_array, howmany, & + & cbidon, inembed, istride, idist, & + & dbidon, onembed, ostride, odist, & + & FFTW_ESTIMATE) + + ENDDO + + WRITE(*,*)"!-------------------------!" + WRITE(*,*)"! !" + WRITE(*,*)"! FIN INITIALISATION FFTW !" + WRITE(*,*)"! !" + WRITE(*,*)"!-------------------------!" + + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE +#include + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect(vsize+inc,nb_vect) + COMPLEX,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect) + + CALL dfftw_execute_dft_r2c(plan_forward(nb_vect),vect,TF_vect) + + TF_vect = scale_factor * TF_vect + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE +#include + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(OUT) :: vect(vsize+inc,nb_vect) + COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect) + + CALL dfftw_execute_dft_c2r(plan_backward(nb_vect),TF_vect,vect) + + vect = scale_factor * vect + + END SUBROUTINE fft_backward + +#endif + +END MODULE mod_fft_fftw Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_mathkeisan.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_mathkeisan.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_mathkeisan.F90 (revision 1634) @@ -0,0 +1,67 @@ +MODULE mod_fft_mathkeisan +#ifdef FFT_MATHKEISAN + + REAL,SAVE,ALLOCATABLE :: Table_forward(:) + REAL,SAVE,ALLOCATABLE :: Table_backward(:) + REAL,SAVE :: scale_factor + INTEGER,SAVE :: vsize + INTEGER,PARAMETER :: inc=2 + +CONTAINS + + SUBROUTINE Init_fft(iim,nb_vect_max) + IMPLICIT NONE + INTEGER :: iim + INTEGER :: nb_vect_max + REAL :: rtmp=1. + COMPLEX :: ctmp + INTEGER :: itmp=1 + INTEGER :: isign=0 + INTEGER :: ierr + + vsize=iim + scale_factor=1./SQRT(1.*vsize) + ALLOCATE(Table_forward(2*vsize+64)) + ALLOCATE(Table_backward(2*vsize+64)) + + CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr) + + CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr) + + + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect(vsize+inc,nb_vect) + COMPLEX,INTENT(OUT) :: TF_vect(vsize/2+1,nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=-1 + + work=0 + CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr) + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(OUT) :: vect(vsize+inc,nb_vect) + COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=1 + + work(:)=0 + CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr) + + END SUBROUTINE fft_backward + +#endif + +END MODULE mod_fft_mathkeisan + + Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_mkl.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_mkl.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_mkl.F90 (revision 1634) @@ -0,0 +1,128 @@ +MODULE mod_fft_mkl +#ifdef FFT_MKL + + USE MKL_DFTI + + REAL,SAVE :: scale_factor + INTEGER,SAVE :: vsize + INTEGER,PARAMETER :: inc=1 + +! TYPE FFT_HANDLE +! TYPE(DFTI_DESCRIPTOR), POINTER :: Pt +! LOGICAL :: IsAllocated +! END TYPE FFT_HANDLE + +! TYPE(FFT_HANDLE),SAVE,ALLOCATABLE :: Forward_Handle(:) +! TYPE(FFT_HANDLE),SAVE,ALLOCATABLE :: Backward_Handle(:) +!!$OMP THREADPRIVATE(Forward_Handle,Backward_Handle) + +CONTAINS + + SUBROUTINE Init_fft(iim,nb_vect_max) + IMPLICIT NONE + INTEGER :: iim + INTEGER :: nb_vect_max + REAL :: rtmp=1. + COMPLEX :: ctmp + INTEGER :: itmp=1 + INTEGER :: isign=0 + INTEGER :: ierr + + vsize=iim + scale_factor=1./SQRT(1.*vsize) +! ALLOCATE(Forward_Handle(nb_vect_max)) +! ALLOCATE(Backward_Handle(nb_vect_max)) + +! Forward_Handle(:)%IsAllocated=.FALSE. +! Backward_Handle(:)%IsAllocated=.FALSE. + +! ALLOCATE(Table_forward(2*vsize+64)) +! ALLOCATE(Table_backward(2*vsize+64)) +! +! CALL DZFFTM(isign,vsize,itmp,scale_factor,rtmp,vsize+inc,ctmp,vsize/2+1,table_forward,rtmp,ierr) +! +! CALL ZDFFTM(isign,vsize,itmp,scale_factor,ctmp,vsize/2+1,rtmp,vsize+inc,table_backward,rtmp,ierr) + +! ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) +! ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) +! ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) +! ierr = DftiSetValue(Desc_Handle, DFTI_INPUT_DISTANCE, vsize+inc) +! ierr = DftiSetValue(Desc_Handle, DFTI_OUTPUT_DISTANCE, vsize) +! ierr = DftiCommitDescriptor( FFT_HANDLE ) + + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect((vsize+inc)*nb_vect) + COMPLEX,INTENT(OUT) :: TF_vect((vsize/2+1)*nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=-1 + REAL :: vect_out((vsize+inc)*nb_vect) + TYPE(DFTI_DESCRIPTOR), POINTER :: FFT_Handle + +! IF ( .NOT. Forward_handle(nb_vect)%IsAllocated) THEN + ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) + ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) + ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) + ierr = DftiSetValue(FFT_Handle, DFTI_INPUT_DISTANCE, vsize+inc) + ierr = DftiSetValue(FFT_Handle, DFTI_OUTPUT_DISTANCE, (vsize/2+1)*2) + ierr = DftiCommitDescriptor( FFT_Handle ) +! Forward_handle(nb_vect)%IsAllocated=.TRUE. +! ENDIF + + ierr = DftiComputeForward( FFT_Handle, vect, TF_vect ) + + ierr = DftiFreeDescriptor( FFT_Handle ) + +! ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) +! ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) +! ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) +! ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) +! ierr = DftiSetValue(FFT_HANDLE, DFTI_INPUT_DISTANCE, vsize/2+1) +! ierr = DftiSetValue(FFT_HANDLE, DFTI_OUTPUT_DISTANCE, vsize+inc) +! ierr = DftiCommitDescriptor( FFT_HANDLE ) +! ierr = DftiComputeBackward( FFT_HANDLE, TF_vect, vect_out ) +! ierr = DftiFreeDescriptor( FFT_HANDLE ) + +! CALL DZFFTM(isign,vsize,nb_vect,scale_factor,vect,vsize+inc,TF_vect,vsize/2+1,table_forward,work,ierr) + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(OUT) :: vect((vsize+inc)*nb_vect) + COMPLEX,INTENT(IN ) :: TF_vect((vsize/2+1)*nb_vect) + REAL :: work(4*vsize*nb_vect) + INTEGER :: ierr + INTEGER, PARAMETER :: isign=1 + TYPE(DFTI_DESCRIPTOR),POINTER :: FFT_Handle +! CALL ZDFFTM(isign,vsize,nb_vect,scale_factor,TF_vect,vsize/2+1,vect,vsize+inc,table_backward,work,ierr) +! IF ( .NOT. Backward_handle(nb_vect)%IsAllocated) THEN + ierr = DftiCreateDescriptor( FFT_Handle, DFTI_DOUBLE, DFTI_REAL, 1, vsize ) + ierr = DftiSetValue(FFT_Handle,DFTI_NUMBER_OF_TRANSFORMS,nb_vect) + ierr = DftiSetValue(FFT_Handle,DFTI_FORWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_BACKWARD_SCALE,scale_factor) + ierr = DftiSetValue(FFT_Handle,DFTI_PLACEMENT,DFTI_NOT_INPLACE) + ierr = DftiSetValue(FFT_Handle, DFTI_INPUT_DISTANCE, (vsize/2+1)*2) + ierr = DftiSetValue(FFT_Handle, DFTI_OUTPUT_DISTANCE, vsize+inc) + ierr = DftiCommitDescriptor( FFT_Handle ) +! Backward_handle(nb_vect)%IsAllocated=.TRUE. +! ENDIF + ierr = DftiComputeBackward( FFT_Handle, TF_vect, vect ) + ierr = DftiFreeDescriptor( FFT_Handle) + + END SUBROUTINE fft_backward + +#endif + +END MODULE mod_fft_mkl Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_wrapper.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_wrapper.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_fft_wrapper.F90 (revision 1634) @@ -0,0 +1,37 @@ +MODULE mod_fft_wrapper + + INTEGER,SAVE :: vsize + INTEGER,PARAMETER :: inc=1 + +CONTAINS + + SUBROUTINE Init_fft(iim,nb) + IMPLICIT NONE + INTEGER :: iim + INTEGER :: nb + + STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique" + END SUBROUTINE Init_fft + + + SUBROUTINE fft_forward(vect,TF_vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(IN) :: vect(vsize+inc,nb_vect) + COMPLEX,INTENT(INOUT) :: TF_vect(vsize/2+1,nb_vect) + + STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique" + + END SUBROUTINE fft_forward + + SUBROUTINE fft_backward(TF_vect,vect,nb_vect) + IMPLICIT NONE + INTEGER,INTENT(IN) :: nb_vect + REAL,INTENT(INOUT) :: vect(vsize+inc,nb_vect) + COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect) + + STOP "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique" + + END SUBROUTINE fft_backward + +END MODULE mod_fft_wrapper Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_filtre_fft.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_filtre_fft.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/mod_filtre_fft.F90 (revision 1634) @@ -0,0 +1,300 @@ +! +! $Id$ +! + +MODULE mod_filtre_fft + + LOGICAL,SAVE :: use_filtre_fft + REAL,SAVE,ALLOCATABLE :: Filtre_u(:,:) + REAL,SAVE,ALLOCATABLE :: Filtre_v(:,:) + REAL,SAVE,ALLOCATABLE :: Filtre_inv(:,:) + +CONTAINS + + SUBROUTINE Init_filtre_fft(coeffu,modfrstu,jfiltnu,jfiltsu,coeffv,modfrstv,jfiltnv,jfiltsv) + USE mod_fft + IMPLICIT NONE + include 'dimensions.h' + REAL, INTENT(IN) :: coeffu(iim,jjm) + INTEGER,INTENT(IN) :: modfrstu(jjm) + INTEGER,INTENT(IN) :: jfiltnu + INTEGER,INTENT(IN) :: jfiltsu + REAL, INTENT(IN) :: coeffv(iim,jjm) + INTEGER,INTENT(IN) :: modfrstv(jjm) + INTEGER,INTENT(IN) :: jfiltnv + INTEGER,INTENT(IN) :: jfiltsv + + INTEGER :: index_vp(iim) + INTEGER :: i,j + INTEGER :: l,ll_nb + + index_vp(1)=1 + DO i=1,iim/2 + index_vp(i+1)=i*2 + ENDDO + + DO i=1,iim/2-1 + index_vp(iim/2+i+1)=iim-2*i+1 + ENDDO + + ALLOCATE(Filtre_u(iim,jjm)) + ALLOCATE(Filtre_v(iim,jjm)) + ALLOCATE(Filtre_inv(iim,jjm)) + + + DO j=2,jfiltnu + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_u(i,j)=0 + ELSE + Filtre_u(i,j)=coeffu(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=jfiltsu,jjm + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_u(i,j)=0 + ELSE + Filtre_u(i,j)=coeffu(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=1,jfiltnv + DO i=1,iim + IF (index_vp(i) < modfrstv(j)) THEN + Filtre_v(i,j)=0 + ELSE + Filtre_v(i,j)=coeffv(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=jfiltsv,jjm + DO i=1,iim + IF (index_vp(i) < modfrstv(j)) THEN + Filtre_v(i,j)=0 + ELSE + Filtre_v(i,j)=coeffv(index_vp(i),j) + ENDIF + ENDDO + ENDDO + + DO j=2,jfiltnu + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_inv(i,j)=0 + ELSE + Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j)) + ENDIF + ENDDO + ENDDO + + DO j=jfiltsu,jjm + DO i=1,iim + IF (index_vp(i) < modfrstu(j)) THEN + Filtre_inv(i,j)=0 + ELSE + Filtre_inv(i,j)=coeffu(index_vp(i),j)/(1.+coeffu(index_vp(i),j)) + ENDIF + ENDDO + ENDDO + +#ifdef FFT_FFTW + + WRITE (*,*)"COTH jfiltnu,jfiltsu,jfiltnv,jjm-jfiltsv" + WRITE (*,*)jfiltnu,jfiltsu,jfiltnv,jjm-jfiltsv + WRITE (*,*)MAX(jfiltnu-2,jjm-jfiltsu,jfiltnv-2,jjm-jfiltsv)+1 + CALL Init_FFT(iim,(llm+1)*(MAX(jfiltnu-2,jjm-jfiltsu,jfiltnv-2,jjm-jfiltsv)+1)) +#else + CALL Init_FFT(iim,(jjm+1)*(llm+1)) +#endif + + END SUBROUTINE Init_filtre_fft + + SUBROUTINE Filtre_u_fft(vect_inout,nlat,jj_begin,jj_end,nbniv) + USE mod_fft +#ifdef CPP_PARA + USE parallel,ONLY : OMP_CHUNK +#endif + IMPLICIT NONE + include 'dimensions.h' + INTEGER,INTENT(IN) :: nlat + INTEGER,INTENT(IN) :: jj_begin + INTEGER,INTENT(IN) :: jj_end + INTEGER,INTENT(IN) :: nbniv + REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv) + + REAL :: vect(iim+inc,jj_end-jj_begin+1,nbniv) + COMPLEX :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv) + INTEGER :: nb_vect + INTEGER :: i,j,l + INTEGER :: ll_nb + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + nb_vect=(jj_end-jj_begin+1)*ll_nb + + CALL FFT_forward(vect,TF_vect,nb_vect) + + DO l=1,ll_nb + DO j=1,jj_end-jj_begin+1 + DO i=1,iim/2+1 + TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_u(i,jj_begin+j-1) + ENDDO + ENDDO + ENDDO + + CALL FFT_backward(TF_vect,vect,nb_vect) + + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + END SUBROUTINE Filtre_u_fft + + + SUBROUTINE Filtre_v_fft(vect_inout,nlat,jj_begin,jj_end,nbniv) + USE mod_fft +#ifdef CPP_PARA + USE parallel,ONLY : OMP_CHUNK +#endif + IMPLICIT NONE + INCLUDE 'dimensions.h' + INTEGER,INTENT(IN) :: nlat + INTEGER,INTENT(IN) :: jj_begin + INTEGER,INTENT(IN) :: jj_end + INTEGER,INTENT(IN) :: nbniv + REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv) + + REAL :: vect(iim+inc,jj_end-jj_begin+1,nbniv) + COMPLEX :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv) + INTEGER :: nb_vect + INTEGER :: i,j,l + INTEGER :: ll_nb + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + + nb_vect=(jj_end-jj_begin+1)*ll_nb + + CALL FFT_forward(vect,TF_vect,nb_vect) + + DO l=1,ll_nb + DO j=1,jj_end-jj_begin+1 + DO i=1,iim/2+1 + TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_v(i,jj_begin+j-1) + ENDDO + ENDDO + ENDDO + + CALL FFT_backward(TF_vect,vect,nb_vect) + + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + END SUBROUTINE Filtre_v_fft + + + SUBROUTINE Filtre_inv_fft(vect_inout,nlat,jj_begin,jj_end,nbniv) + USE mod_fft +#ifdef CPP_PARA + USE parallel,ONLY : OMP_CHUNK +#endif + IMPLICIT NONE + INCLUDE 'dimensions.h' + INTEGER,INTENT(IN) :: nlat + INTEGER,INTENT(IN) :: jj_begin + INTEGER,INTENT(IN) :: jj_end + INTEGER,INTENT(IN) :: nbniv + REAL,INTENT(INOUT) :: vect_inout(iim+1,nlat,nbniv) + + REAL :: vect(iim+inc,jj_end-jj_begin+1,nbniv) + COMPLEX :: TF_vect(iim/2+1,jj_end-jj_begin+1,nbniv) + INTEGER :: nb_vect + INTEGER :: i,j,l + INTEGER :: ll_nb + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect(i,j,ll_nb)=vect_inout(i,j+jj_begin-1,l) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + nb_vect=(jj_end-jj_begin+1)*ll_nb + + CALL FFT_forward(vect,TF_vect,nb_vect) + + DO l=1,ll_nb + DO j=1,jj_end-jj_begin+1 + DO i=1,iim/2+1 + TF_vect(i,j,l)=TF_vect(i,j,l)*Filtre_inv(i,jj_begin+j-1) + ENDDO + ENDDO + ENDDO + + CALL FFT_backward(TF_vect,vect,nb_vect) + + ll_nb=0 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + ll_nb=ll_nb+1 + DO j=1,jj_end-jj_begin+1 + DO i=1,iim+1 + vect_inout(i,j+jj_begin-1,l)=vect(i,j,ll_nb) + ENDDO + ENDDO + ENDDO +!$OMP END DO NOWAIT + + END SUBROUTINE Filtre_inv_fft + +END MODULE mod_filtre_fft + Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h (revision 1634) @@ -0,0 +1,4 @@ +! +! $Header$ +! + INTEGER nfilun, nfilus, nfilvn, nfilvs Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h_192x142x29 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h_192x142x29 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h_192x142x29 (revision 1634) @@ -0,0 +1,45 @@ +! +! $Header$ +! + INTEGER nfilun, nfilus, nfilvn, nfilvs +c +c 48 32 19 non-zoom: +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) +c PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5) +c PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8) +c PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +cmaf -debug PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2) +c +c +c 96 49 11 non-zoom: +ccc PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8) +c +c +c 144 73 11 non-zoom: +ccc PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12) +c +c 192 143 19 non-zoom: +c PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13) +c PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper +c PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) + +c 96 72 19 non-zoom: +c PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12) +c 192 142 29 non-zoom: + PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +c +c PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 ) +c PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 ) +c +c +c Ici , on a exagere les nombres de lignes de latitudes a filtrer . +c +c La premiere fois que le Gcm rentrera dans le Filtre , +c +c il indiquera les bonnes valeurs de nfilun , nflius, nfilvn et +c +c nfilvs a mettre . Il suffira alors de changer ces valeurs dans +c +c Parameter ci-dessus et de relancer le run . + Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h_96x71x19 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h_96x71x19 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/parafilt.h_96x71x19 (revision 1634) @@ -0,0 +1,46 @@ +! +! $Header$ +! + INTEGER nfilun, nfilus, nfilvn, nfilvs +c +c 48 32 19 non-zoom: +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) +c PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5) +c PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8) +c PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +cmaf -debug PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2) +c +c +c 96 49 11 non-zoom: +ccc PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8) +c +c +c 144 73 11 non-zoom: +ccc PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12) +c +c 192 143 19 non-zoom: +c PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13) +c PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper +c PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper +c PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30) + +cIM 96 72 19 non-zoom: +c 96 71 19 non-zoom: + PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12) +c 192 142 29 non-zoom: +c PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24) +c +c PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 ) +c PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 ) +c +c +c Ici , on a exagere les nombres de lignes de latitudes a filtrer . +c +c La premiere fois que le Gcm rentrera dans le Filtre , +c +c il indiquera les bonnes valeurs de nfilun , nflius, nfilvn et +c +c nfilvs a mettre . Il suffira alors de changer ces valeurs dans +c +c Parameter ci-dessus et de relancer le run . + Index: LMDZ5/branches/LMDZ5_AR5/libf/filtrez/timer_filtre.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/filtrez/timer_filtre.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/filtrez/timer_filtre.F90 (revision 1634) @@ -0,0 +1,33 @@ +MODULE timer_filtre +IMPLICIT NONE + PRIVATE + REAL :: time + REAL :: Last_time + PUBLIC :: Init_timer, start_timer, stop_timer, Print_filtre_timer +CONTAINS + + SUBROUTINE Init_timer + time=0 + Last_time=0 + END SUBROUTINE Init_timer + + SUBROUTINE Start_timer + + CALL cpu_time(last_time) + + END SUBROUTINE start_timer + + + SUBROUTINE stop_timer + REAL :: T + + CALL cpu_time(t) + Time=Time+t-last_time + + END SUBROUTINE stop_timer + + SUBROUTINE Print_filtre_timer + PRINT *,"Temps CPU passe dans le filtre :",Time + END SUBROUTINE Print_filtre_timer + +END MODULE timer_filtre Index: LMDZ5/branches/LMDZ5_AR5/libf/grid/dimension/makdim =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/grid/dimension/makdim (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/grid/dimension/makdim (revision 1634) @@ -0,0 +1,65 @@ +for i in $* ; do + list=$list.$i +done +fichdim=dimensions${list} + +if [ ! -f $fichdim ] ; then +# si le fichier de dimensions n'existe pas, on le cree + + if [ $# -ge 3 ] ; then + im=$1 + jm=$2 + lm=$3 + n2=$1 + ndm=1 + +# Le test suivant est commente car il est inutile avec le nouveau +# filtre filtrez. Attention avec le "vieux" filtre (F. Forget,11/1994) +# +# while [ "$n2" -gt 2 ]; do +# n2=`expr $n2 / 2` +# ndm=`expr $ndm + 1` +# echo $n2 +# done +# if [ "$n2" != 2 ] ; then +# echo le nombre de longitude doit etre une puissance de 2 +# exit +# fi + + + else if [ $# -ge 2 ] ; then + im=1 + jm=$1 + lm=$2 + ndm=1 + else if [ $# -ge 1 ] ; then + im=1 + jm=1 + lm=$1 + ndm=1 + else + echo il faut au moins une dimension + exit + fi +fi +fi + +cat << EOF > $fichdim +!----------------------------------------------------------------------- +! INCLUDE 'dimensions.h' +! +! dimensions.h contient les dimensions du modele +! ndm est tel que iim=2**ndm +!----------------------------------------------------------------------- + + INTEGER iim,jjm,llm,ndm + + PARAMETER (iim= $im,jjm=$jm,llm=$lm,ndm=$ndm) + +!----------------------------------------------------------------------- +EOF + +fi + +\rm ../dimensions.h +tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimensions.h ) Index: LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_new.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_new.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_new.h (revision 1634) @@ -0,0 +1,27 @@ +! +! $Header$ +! +c-------------------------------------------------------------- + REAL ripx + REAL fx,fxprim,fy,fyprim,ri,rj,bigy +c +c....stretching in x... +c + ripx( ri )= (ri-1.0) *2.*pi/REAL(iim) + fx ( ri )= ripx(ri) + transx + + * alphax * SIN( ripx(ri)+transx-pxo ) - pi + fxprim(ri) = 2.*pi/REAL(iim) * + * ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) ) + +c....stretching in y... +c + bigy(rj) = 2.* (REAL(jjp1)-rj ) *pi/jjm + fy(rj) = ( bigy(rj) + transy + + * alphay * SIN( bigy(rj)+transy-pyo ) ) /2. - pi/2. + fyprim(rj) = ( pi/jjm ) * ( 1.+ + * alphay * COS( bigy(rj)+transy-pyo ) ) + +c fy(rj)= pyo-pisjjm*(rj-transy)+coefalpha*SIN(depisjm*(rj- +c * transy )) +c fyprim(rj)= pisjjm-pisjjm*coefy2* COS(depisjm*(rj-transy)) +c-------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_reg.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_reg.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_reg.h (revision 1634) @@ -0,0 +1,45 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'fxyprim.h' +c +c ................................................................ +c ................ Fonctions in line ........................... +c ................................................................ +c + REAL fy, fx, fxprim, fyprim + REAL ri, rj +c +c + fy ( rj ) = pi/REAL(jjm) * ( 0.5 * REAL(jjm) + 1. - rj ) + fyprim( rj ) = pi/REAL(jjm) + +c fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm))) +c fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj)) + + fx ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* REAL(iim) - 1. ) +c fx ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) ) + fxprim( ri ) = 2.*pi/REAL(iim) +c +c +c La valeur de pi est passee par le common/const/ou /const2/ . +c Sinon, il faut la calculer avant d'appeler ces fonctions . +c +c ---------------------------------------------------------------- +c Fonctions a changer eventuellement, selon x(x) et y(y) choisis . +c ----------------------------------------------------------------- +c +c ..... ici, on a l'application particuliere suivante ........ +c +c ************************************** +c ** x = 2. * pi/iim * X ** +c ** y = pi/jjm * Y ** +c ************************************** +c +c .................................................................. +c .................................................................. +c +c +c +c----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_sin.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_sin.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/grid/fxy_sin.h (revision 1634) @@ -0,0 +1,42 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'fxyprim.h' +c +c ................................................................ +c ................ Fonctions in line ........................... +c ................................................................ +c + REAL fy, fx, fxprim, fyprim + REAL ri, rj +c +c + fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm))) + fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj)) + + fx ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* REAL(iim) - 1. ) +c fx ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) ) + fxprim( ri ) = 2.*pi/REAL(iim) +c +c +c La valeur de pi est passee par le common/const/ou /const2/ . +c Sinon, il faut la calculer avant d'appeler ces fonctions . +c +c ---------------------------------------------------------------- +c Fonctions a changer eventuellement, selon x(x) et y(y) choisis . +c ----------------------------------------------------------------- +c +c ..... ici, on a l'application particuliere suivante ........ +c +c ************************************** +c ** x = 2. * pi/iim * X ** +c ** y = pi/jjm * Y ** +c ************************************** +c +c .................................................................. +c .................................................................. +c +c +c +c----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/grid/fxyprim.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/grid/fxyprim.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/grid/fxyprim.h (revision 1634) @@ -0,0 +1,45 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE 'fxyprim.h' +c +c ................................................................ +c ................ Fonctions in line ........................... +c ................................................................ +c + REAL fy, fx, fxprim, fyprim + REAL ri, rj +c +c + fy ( rj ) = pi/REAL(jjm) * ( 0.5 * REAL(jjm) + 1. - rj ) + fyprim( rj ) = pi/REAL(jjm) + +c fy(rj)=ASIN(1.+2.*((1.-rj)/REAL(jjm))) +c fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj)) + + fx ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* REAL(iim) - 1. ) +c fx ( ri ) = 2.*pi/REAL(iim) * ( ri - 0.5* ( REAL(iim) + 1.) ) + fxprim( ri ) = 2.*pi/REAL(iim) +c +c +c La valeur de pi est passee par le common/const/ou /const2/ . +c Sinon, il faut la calculer avant d'appeler ces fonctions . +c +c ---------------------------------------------------------------- +c Fonctions a changer eventuellement, selon x(x) et y(y) choisis . +c ----------------------------------------------------------------- +c +c ..... ici, on a l'application particuliere suivante ........ +c +c ************************************** +c ** x = 2. * pi/iim * X ** +c ** y = pi/jjm * Y ** +c ************************************** +c +c .................................................................. +c .................................................................. +c +c +c +c----------------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/CFMIP_point_locations_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/CFMIP_point_locations_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/CFMIP_point_locations_mod.F90 (revision 1634) @@ -0,0 +1,121 @@ +MODULE CFMIP_point_locations + IMPLICIT NONE + +CONTAINS + + SUBROUTINE read_CFMIP_point_locations(npCFMIP, tab, lonCFMIP, latCFMIP) + IMPLICIT none + INTEGER :: npCFMIP + REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP + INTEGER :: tab(npCFMIP), np + + WRITE(*,*) 'npCFMIP=',npCFMIP +! OPEN(20, file="pointlocations.txt",status='old') + OPEN(20, file="pointlocations.txt",status='old',err=999) + OPEN(21, file="pointlocations_lon180.txt") + np=1 +10 READ(20,*) tab(np), lonCFMIP(np), latCFMIP(np) +!!! passage de 0-360 a -180/180 + IF (lonCFMIP(np).GT.180.) THEN + lonCFMIP(np)=lonCFMIP(np)-360. + ENDIF + WRITE(21,*) np, lonCFMIP(np), latCFMIP(np) + np=np+1 + IF(np.LE.npCFMIP) THEN + GOTO 10 + ENDIF + CLOSE(20) + CLOSE(21) +999 RETURN + END SUBROUTINE read_CFMIP_point_locations + + SUBROUTINE LMDZ_CFMIP_point_locations(npCFMIP, lonCFMIP, latCFMIP, & + tabijGCM, lonGCM, latGCM, ipt, jpt) + USE dimphy + USE iophy + USE mod_grid_phy_lmdz + + IMPLICIT none +#include "dimensions.h" + INTEGER :: npCFMIP + REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP + INTEGER :: i, j, np, ip + INTEGER, DIMENSION(npCFMIP) :: ipt, jpt + REAL :: dlon1, dlon2 + REAL :: dlat1, dlat2 + REAL, DIMENSION(iim+1) :: lon + INTEGER, DIMENSION(npCFMIP) :: tabijGCM + REAL, DIMENSION(npCFMIP) :: lonGCM, latGCM + + lon(1:iim)=io_lon(:) + lon(iim+1)=-1*lon(1) + OPEN(22, file="LMDZ_pointsCFMIP.txt") + DO np=1, npCFMIP + DO i=1, iim +! +! PRINT*,'IM np i lonCF lonGCM lonGCM+1',np,i,lonCFMIP(np),lon(i), & +! lon(i+1) +! + IF(lonCFMIP(np).GE.lon(i).AND.lonCFMIP(np).LT.lon(i+1)) THEN + dlon1 = abs (lonCFMIP(np) - lon(i)) + dlon2 = abs (lonCFMIP(np) - lon(i+1)) + IF (dlon1.LE.dlon2) THEN + ipt(np)=i + ELSE + ipt(np)=i+1 + ENDIF + ENDIF + END DO + END DO +! + np=1 +30 j=1 +40 IF(latCFMIP(np).LE.io_lat(j).AND.latCFMIP(np).GE.io_lat(j+1)) THEN + dlat1 = abs (latCFMIP(np) - io_lat(j)) + dlat2 = abs (latCFMIP(np) - io_lat(j+1)) + IF (dlat1.LE.dlat2) THEN + jpt(np)=j + ELSE + jpt(np)=j+1 + ENDIF + np=np+1 + IF(np.LE.npCFMIP) THEN + GOTO 30 + ENDIF + ELSE + j=j+1 + IF(j.LE.jjm) THEN + GOTO 40 + ENDIF + ENDIF + + DO np=1, npCFMIP + WRITE(22,*) lon(ipt(np)), io_lat(jpt(np)) + ENDDO + CLOSE(22) + + OPEN(23, file="pointsCFMIPvsLMDZ.txt") + DO ip=1, npCFMIP + lonGCM(ip)=lon(ipt(ip)) + latGCM(ip)=io_lat(jpt(ip)) + if(jpt(ip).GE.2.AND.jpt(ip).LE.jjm) THEN + tabijGCM(ip)=1+(jpt(ip)-2)*iim+ipt(ip) + else if(jpt(ip).EQ.1) THEN + tabijGCM(ip)=1 + else if(jpt(ip).EQ.jjm+1) THEN + tabijGCM(ip)=klon_glo + else + print*,'ip jpt tabijGCM',ip,jpt(ip),tabijGCM(ip) + endif +! PRINT*,'CFMIP ip lon lat tabijGCM',ip,lonGCM(ip),latGCM(ip),tabijGCM(ip) + ENDDO + DO ip=1, npCFMIP + if(lonGCM(ip).EQ.io_lon(1)) lonGCM(ip)=360.+lonGCM(ip) + ENDDO + DO i=1, npCFMIP + WRITE(23,*) i, lonCFMIP(i), latCFMIP(i), lonGCM(i), latGCM(i), tabijGCM(i) + ENDDO + CLOSE(23) + END SUBROUTINE LMDZ_CFMIP_point_locations + +END MODULE CFMIP_point_locations Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/FCTTRE.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/FCTTRE.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/FCTTRE.h (revision 1634) @@ -0,0 +1,45 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! ------------------------------------------------------------------ +! This COMDECK includes the Thermodynamical functions for the cy39 +! ECMWF Physics package. +! Consistent with YOMCST Basic physics constants, assuming the +! partial pressure of water vapour is given by a first order +! Taylor expansion of Qs(T) w.r.t. to Temperature, using constants +! in YOETHF +! ------------------------------------------------------------------ + REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG + REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl + LOGICAL thermcep + PARAMETER (thermcep=.TRUE.) +! + FOEEW ( PTARG,PDELARG ) = EXP ( & + & (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) & + & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) +! + FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG & + & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2 +! + qsats(ptarg) = 100.0 * 0.622 * 10.0 & + & ** (2.07023 - 0.00320991 * ptarg & + & - 2484.896 / ptarg + 3.56654 * LOG10(ptarg)) + qsatl(ptarg) = 100.0 * 0.622 * 10.0 & + & ** (23.8319 - 2948.964 / ptarg & + & - 5.028 * LOG10(ptarg) & + & - 29810.16 * EXP( - 0.0699382 * ptarg) & + & + 25.21935 * EXP( - 2999.924 / ptarg)) +! + dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg & + & +2484.896*LOG(10.)/ptarg**2 & + & -0.00320991*LOG(10.)) + dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)* & + & (2948.964/ptarg**2-5.028/LOG(10.)/ptarg & + & +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg) & + & +29810.16*0.0699382*EXP(-0.0699382*ptarg)) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOECUMF.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOECUMF.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOECUMF.h (revision 1634) @@ -0,0 +1,48 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! ---------------------------------------------------------------- +!* *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME +! ---------------------------------------------------------------- +! + COMMON /YOECUMF/ & + & LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV, & + & ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP, & + & CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON + + LOGICAL LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV + REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD + REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON +!$OMP THREADPRIVATE(/YOECUMF/) +! +!*if (DOC,declared) <> 'UNKNOWN' +!* *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME +! +! M.TIEDTKE E. C. M. W. F. 18/1/89 +! +! NAME TYPE PURPOSE +! ---- ---- ------- +! +! LMFPEN LOGICAL TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON +! LMFSCV LOGICAL TRUE IF SHALLOW CONVECTION IS SWITCHED ON +! LMFMID LOGICAL TRUE IF MIDLEVEL CONVECTION IS SWITCHED ON +! LMFDD LOGICAL TRUE IF CUMULUS DOWNDRAFT IS SWITCHED ON +! LMFDUDV LOGICAL TRUE IF CUMULUS FRICTION IS SWITCHED ON +! ENTRPEN REAL ENTRAINMENT RATE FOR PENETRATIVE CONVECTION +! ENTRSCV REAL ENTRAINMENT RATE FOR SHALLOW CONVECTION +! ENTRMID REAL ENTRAINMENT RATE FOR MIDLEVEL CONVECTION +! ENTRDD REAL ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS +! CMFCTOP REAL RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC +! CMFCMAX REAL MAXIMUM MASSFLUX VALUE ALLOWED FOR +! CMFCMIN REAL MINIMUM MASSFLUX VALUE (FOR SAFETY) +! CMFDEPS REAL FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS +! RHCDD REAL RELATIVE SATURATION IN DOWNDRAFTS +! CPRCON REAL COEFFICIENTS FOR DETERMINING CONVERSION +! FROM CLOUD WATER TO RAIN +!*ifend +! ---------------------------------------------------------------- Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOEGWD.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOEGWD.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOEGWD.h (revision 1634) @@ -0,0 +1,16 @@ +! +! $Header$ +! +C ----------------------------------------------------------------- +C* *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS +C ----------------------------------------------------------------- +C + integer NKTOPG,NSTRA + real GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT + real GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC + COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT + * ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC +c$OMP THREADPRIVATE(/YOEGWD/) +C + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOETHF.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOETHF.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOETHF.h (revision 1634) @@ -0,0 +1,21 @@ +! +! $Header$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!* COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS +! +! *R__ES* *CONSTANTS USED FOR COMPUTATION OF SATURATION +! MIXING RATIO OVER LIQUID WATER(*R_LES*) OR +! ICE(*R_IES*). +! *RVTMP2* *RVTMP2=RCPV/RCPD-1. +! *RHOH2O* *DENSITY OF LIQUID WATER. (RATM/100.) +! + REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES + REAL RVTMP2, RHOH2O + COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES, & + & RVTMP2, RHOH2O +!$OMP THREADPRIVATE(/YOETHF/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOMCST.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOMCST.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOMCST.h (revision 1634) @@ -0,0 +1,44 @@ +! +! $Header$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! +! A1.0 Fundamental constants + REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO +! A1.1 Astronomical constants + REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA +! A1.1.bis Constantes concernant l'orbite de la Terre: + REAL R_ecc, R_peri, R_incl +! A1.2 Geoide + REAL RA,RG,R1SA +! A1.3 Radiation +! REAL RSIGMA,RI0 + REAL RSIGMA +! A1.4 Thermodynamic gas phase + REAL R,RMD,RMO3,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV + REAL RKAPPA,RETV +! A1.5,6 Thermodynamic liquid,solid phases + REAL RCW,RCS +! A1.7 Thermodynamic transition of phase + REAL RLVTT,RLSTT,RLMLT,RTT,RATM +! A1.8 Curve of saturation + REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS + REAL RALPD,RBETD,RGAMD +! + COMMON/YOMCST/RPI ,RCLUM ,RHPLA ,RKBOL ,RNAVO & + & ,RDAY ,REA ,REPSM ,RSIYEA,RSIDAY,ROMEGA & + & ,R_ecc, R_peri, R_incl & + & ,RA ,RG ,R1SA & + & ,RSIGMA & + & ,R ,RMD ,RMO3 ,RMV ,RD ,RV ,RCPD & + & ,RCPV ,RCVD ,RCVV ,RKAPPA,RETV & + & ,RCW ,RCS & + & ,RLVTT ,RLSTT ,RLMLT ,RTT ,RATM & + & ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS & + & ,RALPD ,RBETD ,RGAMD +! ------------------------------------------------------------------ +!$OMP THREADPRIVATE(/YOMCST/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOMCST2.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOMCST2.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/YOMCST2.h (revision 1634) @@ -0,0 +1,13 @@ + + INTEGER choice, iflag_mix + REAL gammas, alphas, betas, Fmax, qqa1, qqa2, qqa3, scut + REAL Qcoef1max,Qcoef2max,Supcrit1,Supcrit2 +! + COMMON/YOMCST2/gammas, alphas, betas, Fmax, scut, & + & qqa1, qqa2, qqa3, & + & Qcoef1max,Qcoef2max, & + & Supcrit1, Supcrit2, & + & choice,iflag_mix +!$OMP THREADPRIVATE(/YOMCST2/) +! -------------------------------------------------------------------- + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aaam_bud.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aaam_bud.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aaam_bud.F (revision 1634) @@ -0,0 +1,372 @@ +! +! $Id$ +! + subroutine aaam_bud (iam,nlon,nlev,rjour,rsec, + i rea,rg,ome, + i plat,plon,phis, + i dragu,liftu,phyu, + i dragv,liftv,phyv, + i p, u, v, + o aam, torsfc) +c + use dimphy + implicit none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 20031020 +c Object: Compute different terms of the axial AAAM Budget. +C No outputs, every AAM quantities are written on the IAM +C File. +c +c Modif : I.Musat (LMD/CNRS) date : 20041020 +c Outputs : axial components of wind AAM "aam" and total surface torque "torsfc", +c but no write in the iam file. +c +C WARNING: Only valid for regular rectangular grids. +C REMARK: CALL DANS PHYSIQ AFTER lift_noro: +C CALL aaam_bud (27,klon,klev,rjourvrai,gmtime, +C C ra,rg,romega, +C C rlat,rlon,pphis, +C C zustrdr,zustrli,zustrph, +C C zvstrdr,zvstrli,zvstrph, +C C paprs,u,v) +C +C====================================================================== +c Explicit Arguments: +c ================== +c iam-----input-I-File number where AAMs and torques are written +c It is a formatted file that has been opened +c in physiq.F +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c rjour -R-Jour compte depuis le debut de la simu (run.def) +c rsec -R-Seconde de la journee +c rea -R-Earth radius +c rg -R-gravity constant +c ome -R-Earth rotation rate +c plat ---input-R-Latitude en degres +c plon ---input-R-Longitude en degres +c phis ---input-R-Geopotential at the ground +c dragu---input-R-orodrag stress (zonal) +c liftu---input-R-orolift stress (zonal) +c phyu----input-R-Stress total de la physique (zonal) +c dragv---input-R-orodrag stress (Meridional) +c liftv---input-R-orolift stress (Meridional) +c phyv----input-R-Stress total de la physique (Meridional) +c p-------input-R-Pressure (Pa) at model half levels +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c aam-----output-R-Axial Wind AAM (=raam(3)) +c torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3)) +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c iim*(jjm-1)+2 for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c dlat-----R: Latitude increment (Radians) +c dlon-----R: Longitude increment (Radians) +c raam ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale) +c oaam ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale) +c tmou-----R: Resolved Mountain torque (3 components) +c tsso-----R: Parameterised Moutain drag torque (3 components) +c tbls-----R: Parameterised Boundary layer torque (3 components) +c +c LOCAL ARRAY: +c =========== +c zs ---R: Topographic height +c ps ---R: Surface Pressure +c ub ---R: Barotropic wind zonal +c vb ---R: Barotropic wind meridional +c zlat ---R: Latitude in radians +c zlon ---R: Longitude in radians +c====================================================================== + +#include "dimensions.h" +ccc#include "dimphy.h" +c +c ARGUMENTS +c + INTEGER iam,nlon,nlev + REAL, intent(in):: rjour,rsec,rea,rg,ome + REAL plat(nlon),plon(nlon),phis(nlon) + REAL dragu(nlon),liftu(nlon),phyu(nlon) + REAL dragv(nlon),liftv(nlon),phyv(nlon) + REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev) +c +c Variables locales: +c + INTEGER i,j,k,l + REAL xpi,hadley,hadday + REAL dlat,dlon + REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3) + integer iax +cIM ajout aam, torsfc +c aam = composante axiale du Wind AAM raam +c torsfc = composante axiale de (tmou+tsso+tbls) + REAL aam, torsfc + + REAL ZS(801,401),PS(801,401) + REAL UB(801,401),VB(801,401) + REAL SSOU(801,401),SSOV(801,401) + REAL BLSU(801,401),BLSV(801,401) + REAL ZLON(801),ZLAT(401) + + CHARACTER (LEN=20) :: modname='aaam_bud' + CHARACTER (LEN=80) :: abort_message + + +C +C PUT AAM QUANTITIES AT ZERO: +C + if(iim+1.gt.801.or.jjm+1.gt.401)then + abort_message = 'Pb de dimension dans aaam_bud' + CALL abort_gcm (modname,abort_message,1) + endif + + xpi=acos(-1.) + hadley=1.e18 + hadday=1.e18*24.*3600. + dlat=xpi/REAL(jjm) + dlon=2.*xpi/REAL(iim) + + do iax=1,3 + oaam(iax)=0. + raam(iax)=0. + tmou(iax)=0. + tsso(iax)=0. + tbls(iax)=0. + enddo + +C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND: + +C North pole values (j=1): + + l=1 + + ub(1,1)=0. + vb(1,1)=0. + do k=1,nlev + ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + + zlat(1)=plat(l)*xpi/180. + + do i=1,iim+1 + + zs(i,1)=phis(l)/rg + ps(i,1)=p(l,1) + ub(i,1)=ub(1,1) + vb(i,1)=vb(1,1) + ssou(i,1)=dragu(l)+liftu(l) + ssov(i,1)=dragv(l)+liftv(l) + blsu(i,1)=phyu(l)-dragu(l)-liftu(l) + blsv(i,1)=phyv(l)-dragv(l)-liftv(l) + + enddo + + + do j = 2,jjm + +C Values at Greenwich (Periodicity) + + zs(iim+1,j)=phis(l+1)/rg + ps(iim+1,j)=p(l+1,1) + ssou(iim+1,j)=dragu(l+1)+liftu(l+1) + ssov(iim+1,j)=dragv(l+1)+liftv(l+1) + blsu(iim+1,j)=phyu(l+1)-dragu(l+1)-liftu(l+1) + blsv(iim+1,j)=phyv(l+1)-dragv(l+1)-liftv(l+1) + zlon(iim+1)=-plon(l+1)*xpi/180. + zlat(j)=plat(l+1)*xpi/180. + + ub(iim+1,j)=0. + vb(iim+1,j)=0. + do k=1,nlev + ub(iim+1,j)=ub(iim+1,j)+u(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg + vb(iim+1,j)=vb(iim+1,j)+v(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg + enddo + + + do i=1,iim + + l=l+1 + zs(i,j)=phis(l)/rg + ps(i,j)=p(l,1) + ssou(i,j)=dragu(l)+liftu(l) + ssov(i,j)=dragv(l)+liftv(l) + blsu(i,j)=phyu(l)-dragu(l)-liftu(l) + blsv(i,j)=phyv(l)-dragv(l)-liftv(l) + zlon(i)=plon(l)*xpi/180. + + ub(i,j)=0. + vb(i,j)=0. + do k=1,nlev + ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + + enddo + + enddo + + +C South Pole + + if (jjm.GT.1) then + l=l+1 + ub(1,jjm+1)=0. + vb(1,jjm+1)=0. + do k=1,nlev + ub(1,jjm+1)=ub(1,jjm+1)+u(l,k)*(p(l,k)-p(l,k+1))/rg + vb(1,jjm+1)=vb(1,jjm+1)+v(l,k)*(p(l,k)-p(l,k+1))/rg + enddo + zlat(jjm+1)=plat(l)*xpi/180. + + do i=1,iim+1 + zs(i,jjm+1)=phis(l)/rg + ps(i,jjm+1)=p(l,1) + ssou(i,jjm+1)=dragu(l)+liftu(l) + ssov(i,jjm+1)=dragv(l)+liftv(l) + blsu(i,jjm+1)=phyu(l)-dragu(l)-liftu(l) + blsv(i,jjm+1)=phyv(l)-dragv(l)-liftv(l) + ub(i,jjm+1)=ub(1,jjm+1) + vb(i,jjm+1)=vb(1,jjm+1) + enddo + endif + +C +C MOMENT ANGULAIRE +C + DO j=1,jjm + DO i=1,iim + + raam(1)=raam(1)-rea**3*dlon*dlat*0.5* + c (cos(zlon(i ))*sin(zlat(j ))*cos(zlat(j ))*ub(i ,j ) + c +cos(zlon(i ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i ,j+1)) + c +rea**3*dlon*dlat*0.5* + c (sin(zlon(i ))*cos(zlat(j ))*vb(i ,j ) + c +sin(zlon(i ))*cos(zlat(j+1))*vb(i ,j+1)) + + oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5* + c (cos(zlon(i ))*cos(zlat(j ))**2*sin(zlat(j ))*ps(i ,j ) + c +cos(zlon(i ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i ,j+1)) + + raam(2)=raam(2)-rea**3*dlon*dlat*0.5* + c (sin(zlon(i ))*sin(zlat(j ))*cos(zlat(j ))*ub(i ,j ) + c +sin(zlon(i ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i ,j+1)) + c -rea**3*dlon*dlat*0.5* + c (cos(zlon(i ))*cos(zlat(j ))*vb(i ,j ) + c +cos(zlon(i ))*cos(zlat(j+1))*vb(i ,j+1)) + + oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5* + c (sin(zlon(i ))*cos(zlat(j ))**2*sin(zlat(j ))*ps(i ,j ) + c +sin(zlon(i ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i ,j+1)) + + raam(3)=raam(3)+rea**3*dlon*dlat*0.5* + c (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1)) + + oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5* + c (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1)) + + ENDDO + ENDDO + +C +C COUPLE DES MONTAGNES: +C + + DO j=1,jjm + DO i=1,iim + tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i)) + c *(zs(i,j)-zs(i,j+1)) + c *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) + tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i)) + c *(zs(i,j)-zs(i,j+1)) + c *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) + ENDDO + ENDDO + + DO j=2,jjm + DO i=1,iim + tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j)) + c *(zs(i+1,j)-zs(i,j)) + c *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j)) + tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j)) + c *(zs(i+1,j)-zs(i,j)) + c *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j)) + tmou(3)=tmou(3)-rea**2*dlat*0.5* + c cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j)) + ENDDO + ENDDO + +C +C COUPLES DES DIFFERENTES FRICTION AU SOL: +C + l=1 + DO j=2,jjm + DO i=1,iim + l=l+1 + tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *sin(zlat(j))*cos(zlon(i)) + c +rea**3*cos(zlat(j))*dlon*dlat* + c ssov(i,j) *sin(zlon(i)) + + tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *sin(zlat(j))*sin(zlon(i)) + c -rea**3*cos(zlat(j))*dlon*dlat* + c ssov(i,j) *cos(zlon(i)) + + tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat* + c ssou(i,j) *cos(zlat(j)) + + tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *sin(zlat(j))*cos(zlon(i)) + c +rea**3*cos(zlat(j))*dlon*dlat* + c blsv(i,j) *sin(zlon(i)) + + tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *sin(zlat(j))*sin(zlon(i)) + c -rea**3*cos(zlat(j))*dlon*dlat* + c blsv(i,j) *cos(zlon(i)) + + tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat* + c blsu(i,j) *cos(zlat(j)) + + ENDDO + ENDDO + + +c write(*,*) 'AAM',rsec, +c write(*,*) 'AAM',rjour+rsec/86400., +c c raam(3)/hadday,oaam(3)/hadday, +c c tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley + +c write(iam,100)rjour+rsec/86400., +c c raam(1)/hadday,oaam(1)/hadday, +c c tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley, +c c raam(2)/hadday,oaam(2)/hadday, +c c tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley, +c c raam(3)/hadday,oaam(3)/hadday, +c c tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley +100 format(F12.5,15(1x,F12.5)) + +c write(iam+1,*)((zs(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ps(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ub(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((vb(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ssou(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((ssov(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((blsu(i,j),i=1,iim),j=1,jjm+1) +c write(iam+1,*)((blsv(i,j),i=1,iim),j=1,jjm+1) +c + aam=raam(3) + torsfc= tmou(3)+tsso(3)+tbls(3) +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/add_phys_tend.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/add_phys_tend.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/add_phys_tend.F90 (revision 1634) @@ -0,0 +1,193 @@ +! +! $Id$ +! +SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,text) +!====================================================================== +! Ajoute les tendances des variables physiques aux variables +! d'etat de la dynamique t_seri, q_seri ... +! On en profite pour faire des tests sur les tendances en question. +!====================================================================== + + +!====================================================================== +! Declarations +!====================================================================== + +use dimphy +use phys_local_var_mod +use phys_state_var_mod +IMPLICIT none +#include "iniprint.h" + +! Arguments : +!------------ +REAL zdu(klon,klev),zdv(klon,klev) +REAL zdt(klon,klev),zdq(klon,klev),zdql(klon,klev) +CHARACTER*(*) text + +! Local : +!-------- +REAL zt,zq + +INTEGER i, k,j +INTEGER jadrs(klon*klev), jbad +INTEGER jqadrs(klon*klev), jqbad +INTEGER kadrs(klon*klev) +INTEGER kqadrs(klon*klev) + +integer debug_level +logical, save :: first=.true. +!$OMP THREADPRIVATE(first) +INTEGER, SAVE :: itap +!$OMP THREADPRIVATE(itap) +!====================================================================== +! Initialisations + +debug_level=10 + if (first) then + itap=0 + first=.false. + endif +! Incrementer le compteur de la physique + itap = itap + 1 +!====================================================================== +! Ajout des tendances sur le vent et l'eau liquide +!====================================================================== + + u_seri(:,:)=u_seri(:,:)+zdu(:,:) + v_seri(:,:)=v_seri(:,:)+zdv(:,:) + ql_seri(:,:)=ql_seri(:,:)+zdql(:,:) + +!====================================================================== +! On ajoute les tendances de la temperature et de la vapeur d'eau +! en verifiant que ca ne part pas dans les choux +!====================================================================== + + jbad=0 + jqbad=0 + DO k = 1, klev + DO i = 1, klon + zt=t_seri(i,k)+zdt(i,k) + zq=q_seri(i,k)+zdq(i,k) + IF ( zt>370. .or. zt<130. .or. abs(zdt(i,k))>50. ) then + jbad = jbad + 1 + jadrs(jbad) = i + kadrs(jbad) = k + ENDIF + IF ( zq<0. .or. zq>0.1 .or. abs(zdq(i,k))>1.e-2 ) then + jqbad = jqbad + 1 + jqadrs(jqbad) = i + kqadrs(jqbad) = k + ENDIF + t_seri(i,k)=zt + q_seri(i,k)=zq + ENDDO + ENDDO + +!===================================================================================== +! Impression et stop en cas de probleme important +!===================================================================================== + +IF (jbad .GT. 0) THEN + DO j = 1, jbad + i=jadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'PLANTAGE POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text + print*,'l T dT Q dQ ' + DO k = 1, klev + write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k) + ENDDO + call print_debug_phys(i,debug_level,text) + endif + ENDDO +ENDIF +! +!===================================================================================== +! Impression, warning et correction en cas de probleme moins important +!===================================================================================== +IF (jqbad .GT. 0) THEN + DO j = 1, jqbad + i=jqadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'WARNING : EAU POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text + print*,'l T dT Q dQ ' + endif + DO k = 1, klev + zq=q_seri(i,k)+zdq(i,k) + if (zq.lt.1.e-15) then + if (q_seri(i,k).lt.1.e-15) then + if(prt_level.ge.debug_level) THEN + print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k) + endif + q_seri(i,k)=1.e-15 + zdq(i,k)=(1.e-15-q_seri(i,k)) + endif + endif +! zq=q_seri(i,k)+zdq(i,k) +! if (zq.lt.1.e-15) then +! zdq(i,k)=(1.e-15-q_seri(i,k)) +! endif + ENDDO + ENDDO +ENDIF +! + +!IM ajout memes tests pour reverifier les jbad, jqbad beg + jbad=0 + jqbad=0 + DO k = 1, klev + DO i = 1, klon + IF ( t_seri(i,k)>370. .or. t_seri(i,k)<130. .or. abs(zdt(i,k))>50. ) then + jbad = jbad + 1 + jadrs(jbad) = i +! if(prt_level.ge.debug_level) THEN +! print*,'cas2 i k t_seri zdt',i,k,t_seri(i,k),zdt(i,k) +! endif + ENDIF + IF ( q_seri(i,k)<0. .or. q_seri(i,k)>0.1 .or. abs(zdq(i,k))>1.e-2 ) then + jqbad = jqbad + 1 + jqadrs(jqbad) = i + kqadrs(jqbad) = k +! if(prt_level.ge.debug_level) THEN +! print*,'cas2 i k q_seri zdq',i,k,q_seri(i,k),zdq(i,k) +! endif + ENDIF + ENDDO + ENDDO +IF (jbad .GT. 0) THEN + DO j = 1, jbad + i=jadrs(j) + k=kadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'PLANTAGE2 POUR LE POINT i itap rlon rlat txt jbad zdt t',i,itap,rlon(i),rlat(i),text,jbad, & + & zdt(i,k),t_seri(i,k)-zdt(i,k) +!!! if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN + print*,'l T dT Q dQ ' + DO k = 1, klev + write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k) + ENDDO + call print_debug_phys(i,debug_level,text) + endif + ENDDO +ENDIF +! +IF (jqbad .GT. 0) THEN + DO j = 1, jqbad + i=jqadrs(j) + k=kqadrs(j) + if(prt_level.ge.debug_level) THEN + print*,'WARNING : EAU2 POUR LE POINT i itap rlon rlat txt jqbad zdq q zdql ql',i,itap,rlon(i),rlat(i),text,jqbad,& + & zdq(i,k), q_seri(i,k)-zdq(i,k), zdql(i,k), ql_seri(i,k)-zdql(i,k) +!!! if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN + print*,'l T dT Q dQ ' + DO k = 1, klev + write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k) + ENDDO + call print_debug_phys(i,debug_level,text) + endif + ENDDO +ENDIF + + CALL hgardfou(t_seri,ftsol,text) + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aero_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aero_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aero_mod.F90 (revision 1634) @@ -0,0 +1,68 @@ +! $Id$ +! +MODULE aero_mod + ! Declaration des indices pour les aerosols + + ! Total number of aerosols + INTEGER, PARAMETER :: naero_tot = 10 + + ! Identification number used in aeropt_2bands and aeropt_5wv + ! corresponding to naero_tot + INTEGER, PARAMETER :: id_ASBCM = 1 + INTEGER, PARAMETER :: id_ASPOMM = 2 + INTEGER, PARAMETER :: id_ASSO4M = 3 + INTEGER, PARAMETER :: id_CSSO4M = 4 + INTEGER, PARAMETER :: id_SSSSM = 5 + INTEGER, PARAMETER :: id_CSSSM = 6 + INTEGER, PARAMETER :: id_ASSSM = 7 + INTEGER, PARAMETER :: id_CIDUSTM = 8 + INTEGER, PARAMETER :: id_AIBCM = 9 + INTEGER, PARAMETER :: id_AIPOMM = 10 + + ! Total number of aerosols actually used in LMDZ + ! 1 = ASBCM + ! 2 = ASPOMM + ! 3 = ASSO4M ( = SO4) + ! 4 = CSSO4M + ! 5 = SSSSM + ! 6 = CSSSM + ! 7 = ASSSM + ! 8 = CIDUSTM + ! 9 = AIBCM + !10 = AIPOMM + INTEGER, PARAMETER :: naero_spc = 10 + + ! Corresponding names for the aerosols + CHARACTER(len=7),DIMENSION(naero_spc) :: name_aero=(/& + "ASBCM ", & + "ASPOMM ", & + "SO4 ", & + "CSSO4M ", & + "SSSSM ", & + "CSSSM ", & + "ASSSM ", & + "CIDUSTM", & + "AIBCM ", & + "AIPOMM " /) + + + ! Number of aerosol groups + ! 1 = ZERO + ! 2 = AER total + ! 3 = NAT + ! 4 = BC + ! 5 = SO4 + ! 6 = POM + ! 7 = DUST + ! 8 = SS + ! 9 = NO3 + INTEGER, PARAMETER :: naero_grp = 9 + + ! Number of wavelengths + INTEGER, PARAMETER :: nwave = 5 + + ! Number of modes spectral bands + INTEGER, parameter :: nbands = 2 + + +END MODULE aero_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt.F (revision 1634) @@ -0,0 +1,141 @@ +! +! $Id$ +! + SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl, + . tau_ae, piz_ae, cg_ae, ai ) +c + USE dimphy + IMPLICIT none +c +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL, INTENT(in) :: paprs(klon,klev+1) + REAL, INTENT(in) :: pplay(klon,klev), t_seri(klon,klev) + REAL, INTENT(in) :: msulfate(klon,klev) ! masse sulfate ug SO4/m3 [ug/m^3] + REAL, INTENT(in) :: RHcl(klon,klev) ! humidite relative ciel clair + REAL, INTENT(out) :: tau_ae(klon,klev,2) ! epaisseur optique aerosol + REAL, INTENT(out) :: piz_ae(klon,klev,2) ! single scattering albedo aerosol + REAL, INTENT(out) :: cg_ae(klon,klev,2) ! asymmetry parameter aerosol + REAL, INTENT(out) :: ai(klon) ! POLDER aerosol index +c +c Local +c + INTEGER i, k, inu + INTEGER RH_num, nbre_RH + PARAMETER (nbre_RH=12) + REAL RH_tab(nbre_RH) + REAL RH_MAX, DELTA, rh + PARAMETER (RH_MAX=95.) + DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./ + REAL zrho, zdz + REAL taue670(klon) ! epaisseur optique aerosol absorption 550 nm + REAL taue865(klon) ! epaisseur optique aerosol extinction 865 nm + REAL alpha_aer_sulfate(nbre_RH,5) !--unit m2/g SO4 + REAL alphasulfate + + CHARACTER (LEN=20) :: modname='aeropt' + CHARACTER (LEN=80) :: abort_message + +c +c Proprietes optiques +c + REAL alpha_aer(nbre_RH,2) !--unit m2/g SO4 + REAL cg_aer(nbre_RH,2) + DATA alpha_aer/.500130E+01, .500130E+01, .500130E+01, + . .500130E+01, .500130E+01, .616710E+01, + . .826850E+01, .107687E+02, .136976E+02, + . .162972E+02, .211690E+02, .354833E+02, + . .139460E+01, .139460E+01, .139460E+01, + . .139460E+01, .139460E+01, .173910E+01, + . .244380E+01, .332320E+01, .440120E+01, + . .539570E+01, .734580E+01, .136038E+02 / + DATA cg_aer/.619800E+00, .619800E+00, .619800E+00, + . .619800E+00, .619800E+00, .662700E+00, + . .682100E+00, .698500E+00, .712500E+00, + . .721800E+00, .734600E+00, .755800E+00, + . .545600E+00, .545600E+00, .545600E+00, + . .545600E+00, .545600E+00, .583700E+00, + . .607100E+00, .627700E+00, .645800E+00, + . .658400E+00, .676500E+00, .708500E+00 / + DATA alpha_aer_sulfate/ + . 4.910,4.910,4.910,4.910,6.547,7.373, + . 8.373,9.788,12.167,14.256,17.924,28.433, + . 1.453,1.453,1.453,1.453,2.003,2.321, + . 2.711,3.282,4.287,5.210,6.914,12.305, + . 4.308,4.308,4.308,4.308,5.753,6.521, + . 7.449,8.772,11.014,12.999,16.518,26.772, + . 3.265,3.265,3.265,3.265,4.388,5.016, + . 5.775,6.868,8.745,10.429,13.457,22.538, + . 2.116,2.116,2.116,2.116,2.882,3.330, + . 3.876,4.670,6.059,7.327,9.650,16.883/ +c + DO i=1, klon + taue670(i)=0.0 + taue865(i)=0.0 + ENDDO +c + DO k=1, klev + DO i=1, klon + if (t_seri(i,k).eq.0) write (*,*) 'aeropt T ',i,k,t_seri(i,k) + if (pplay(i,k).eq.0) write (*,*) 'aeropt p ',i,k,pplay(i,k) + zrho=pplay(i,k)/t_seri(i,k)/RD ! kg/m3 + zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG ! m + rh=MIN(RHcl(i,k)*100.,RH_MAX) + RH_num = INT( rh/10. + 1.) + IF (rh.LT.0.) THEN + abort_message = 'aeropt: RH < 0 not possible' + CALL abort_gcm (modname,abort_message,1) + ENDIF + IF (rh.gt.85.) RH_num=10 + IF (rh.gt.90.) RH_num=11 + DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num)) +c + inu=1 + tau_ae(i,k,inu)=alpha_aer(RH_num,inu) + + . DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu)) + tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6 + piz_ae(i,k,inu)=1.0 + cg_ae(i,k,inu)=cg_aer(RH_num,inu) + + . DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu)) +c + inu=2 + tau_ae(i,k,inu)=alpha_aer(RH_num,inu) + + . DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu)) + tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6 + piz_ae(i,k,inu)=1.0 + cg_ae(i,k,inu)=cg_aer(RH_num,inu) + + . DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu)) +cjq +cjq for aerosol index +c + alphasulfate=alpha_aer_sulfate(RH_num,4) + + . DELTA*(alpha_aer_sulfate(RH_num+1,4)- + . alpha_aer_sulfate(RH_num,4)) !--m2/g +c + taue670(i)=taue670(i)+ + . alphasulfate*msulfate(i,k)*zdz*1.e-6 +c + alphasulfate=alpha_aer_sulfate(RH_num,5) + + . DELTA*(alpha_aer_sulfate(RH_num+1,5)- + . alpha_aer_sulfate(RH_num,5)) !--m2/g +c + taue865(i)=taue865(i)+ + . alphasulfate*msulfate(i,k)*zdz*1.e-6 + + ENDDO + ENDDO +c + DO i=1, klon + ai(i)=(-log(MAX(taue670(i),0.0001)/ + . MAX(taue865(i),0.0001))/log(670./865.)) * + . taue865(i) + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt_2bands.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt_2bands.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt_2bands.F90 (revision 1634) @@ -0,0 +1,1131 @@ +! +! $Id$ +! +SUBROUTINE AEROPT_2BANDS( & + pdel, m_allaer, delt, RHcl, & + tau_allaer, piz_allaer, & + cg_allaer, m_allaer_pi, & + flag_aerosol, pplay, t_seri, presnivs) + + USE dimphy + USE aero_mod + USE phys_local_var_mod, only: absvisaer + + ! Yves Balkanski le 12 avril 2006 + ! Celine Deandreis + ! Anne Cozic Avril 2009 + ! a partir d'une sous-routine de Johannes Quaas pour les sulfates + ! + IMPLICIT NONE + + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + + ! + ! Input arguments: + ! + REAL, DIMENSION(klon,klev), INTENT(in) :: pdel + REAL, INTENT(in) :: delt + REAL, DIMENSION(klon,klev,naero_spc), INTENT(in) :: m_allaer +!RAF + REAL, DIMENSION(klon,klev,naero_spc), INTENT(in) :: m_allaer_pi + REAL, DIMENSION(klon,klev), INTENT(in) :: RHcl ! humidite relative ciel clair +!RAF REAL, DIMENSION(klon,naero_tot),INTENT(in) :: fractnat_allaer + INTEGER, INTENT(in) :: flag_aerosol + REAL, DIMENSION(klon,klev), INTENT(in) :: pplay + REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri + REAL, DIMENSION(klev), INTENT(in) :: presnivs + ! + ! Output arguments: + ! + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: tau_allaer ! epaisseur optique aerosol + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: piz_allaer ! single scattering albedo aerosol + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: cg_allaer ! asymmetry parameter aerosol + + ! + ! Local + ! + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: tau_ae +!RAF + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: tau_ae_pi + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: piz_ae + REAL, DIMENSION(klon,klev,naero_tot,nbands) :: cg_ae + LOGICAL :: soluble + INTEGER :: i, k,n, ierr, inu, m, mrfspecies + INTEGER :: spsol, spinsol, spss + INTEGER :: RH_num(klon,klev) + INTEGER, PARAMETER :: nb_level=19 ! number of vertical levels in DATA + + INTEGER, PARAMETER :: nbre_RH=12 + INTEGER, PARAMETER :: naero_soluble=7 ! 1- BC soluble; 2- POM soluble; 3- SO4. acc. 4- SO4 coarse + ! 5- seasalt super coarse 6- seasalt coarse 7- seasalt acc. + INTEGER, PARAMETER :: naero_insoluble=3 ! 1- Dust; 2- BC insoluble; 3- POM insoluble + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + +! Coefficient optiques sur 19 niveaux + REAL, SAVE, DIMENSION(nb_level) :: presnivs_19 ! Pression milieux couche pour 19 niveaux (nb_level) +!$OMP THREADPRIVATE(presnivs_19) + + REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19,& + B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19,& + A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19,& + B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19,& + A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19,& + B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19,& + A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19,& + B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19,& + A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19,& + B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19,& + A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19,& + B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19 +!$OMP THREADPRIVATE(A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19) +!$OMP THREADPRIVATE(B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19) +!$OMP THREADPRIVATE(A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19) +!$OMP THREADPRIVATE(B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19) +!$OMP THREADPRIVATE(A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19) +!$OMP THREADPRIVATE(B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19) +!$OMP THREADPRIVATE(A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19) +!$OMP THREADPRIVATE(B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19) +!$OMP THREADPRIVATE(A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19) +!$OMP THREADPRIVATE(B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19) +!$OMP THREADPRIVATE(A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19) +!$OMP THREADPRIVATE(B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19) + + +! Coefficient optiques interpole sur le nombre de niveau du modele + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: & + A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1,& + B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1,& + A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1,& + B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1,& + A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1,& + B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1,& + A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2,& + B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2,& + A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2,& + B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2,& + A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2,& + B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2 +!$OMP THREADPRIVATE(A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1) +!$OMP THREADPRIVATE(B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1) +!$OMP THREADPRIVATE(A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1) +!$OMP THREADPRIVATE(B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1) +!$OMP THREADPRIVATE(A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1) +!$OMP THREADPRIVATE(B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1) +!$OMP THREADPRIVATE(A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2) +!$OMP THREADPRIVATE(B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2) +!$OMP THREADPRIVATE(A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2) +!$OMP THREADPRIVATE(B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2) +!$OMP THREADPRIVATE(A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2) +!$OMP THREADPRIVATE(B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2) + + REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./) + REAL, PARAMETER :: RH_MAX=95. + REAL:: DELTA(klon,klev), rh(klon,klev), H + REAL:: tau_ae2b_int ! Intermediate computation of epaisseur optique aerosol + REAL:: piz_ae2b_int ! Intermediate computation of Single scattering albedo + REAL:: cg_ae2b_int ! Intermediate computation of Assymetry parameter + REAL :: Fact_RH(nbre_RH) + REAL :: zrho + REAL :: fac + REAL :: zdp1(klon,klev) + REAL, PARAMETER :: gravit = 9.80616 ! m2/s + INTEGER, ALLOCATABLE, DIMENSION(:) :: aerosol_name + INTEGER :: nb_aer + REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp +!RAF + REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp_pi + + ! + ! Proprietes optiques + ! + REAL:: alpha_aers_2bands(nbre_RH,nbands,naero_soluble) !--unit m2/g SO4 + REAL:: alpha_aeri_2bands(nbands,naero_insoluble) + REAL:: cg_aers_2bands(nbre_RH,nbands,naero_soluble) !--unit + REAL:: cg_aeri_2bands(nbands,naero_insoluble) + REAL:: piz_aers_2bands(nbre_RH,nbands,naero_soluble) !-- unit + REAL:: piz_aeri_2bands(nbands,naero_insoluble) !-- unit + + INTEGER :: id + LOGICAL :: used_aer(naero_tot) + REAL :: tmp_var, tmp_var_pi + + DATA presnivs_19/& + 100426.5, 98327.6, 95346.5, 90966.8, 84776.9, & + 76536.5, 66292.2, 54559.3, 42501.8, 31806, & + 23787.5, 18252.7, 13996, 10320.8, 7191.1, & + 4661.7, 2732.9, 1345.6, 388.2/ + + +!***********************BAND 1*********************************** +!ACCUMULATION MODE + DATA A1_ASSSM_b1_19/ 4.373E+00, 4.361E+00, 4.331E+00, & + 4.278E+00, 4.223E+00, 4.162E+00, & + 4.103E+00, 4.035E+00, 3.962E+00, & + 3.904E+00, 3.871E+00, 3.847E+00, & + 3.824E+00, 3.780E+00, 3.646E+00, & + 3.448E+00, 3.179E+00, 2.855E+00, 2.630E+00/ + DATA A2_ASSSM_b1_19/ 2.496E+00, 2.489E+00, 2.472E+00, & + 2.442E+00, 2.411E+00, 2.376E+00, & + 2.342E+00, 2.303E+00, 2.261E+00, & + 2.228E+00, 2.210E+00, 2.196E+00, & + 2.183E+00, 2.158E+00, 2.081E+00, & + 1.968E+00, 1.814E+00, 1.630E+00, 1.501E+00/ + DATA A3_ASSSM_b1_19/-4.688E-02, -4.676E-02, -4.644E-02, & + -4.587E-02, -4.528E-02, -4.463E-02, & + -4.399E-02, -4.326E-02, -4.248E-02, & + -4.186E-02, -4.151E-02, -4.125E-02, & + -4.100E-02, -4.053E-02, -3.910E-02, & + -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/ + DATA B1_ASSSM_b1_19/ 1.165E-08, 1.145E-08, 1.097E-08, & + 1.012E-08, 9.233E-09, 8.261E-09, & + 7.297E-09, 6.201E-09, 5.026E-09, & + 4.098E-09, 3.567E-09, 3.187E-09, & + 2.807E-09, 2.291E-09, 2.075E-09, & + 1.756E-09, 1.322E-09, 8.011E-10, 4.379E-10/ + DATA B2_ASSSM_b1_19/ 2.193E-08, 2.192E-08, 2.187E-08, & + 2.179E-08, 2.171E-08, 2.162E-08, & + 2.153E-08, 2.143E-08, 2.132E-08, & + 2.124E-08, 2.119E-08, 2.115E-08, & + 2.112E-08, 2.106E-08, 2.100E-08, & + 2.090E-08, 2.077E-08, 2.061E-08, 2.049E-08/ + DATA C1_ASSSM_b1_19/ 7.365E-01, 7.365E-01, 7.365E-01, & + 7.364E-01, 7.363E-01, 7.362E-01, & + 7.361E-01, 7.359E-01, 7.358E-01, & + 7.357E-01, 7.356E-01, 7.356E-01, & + 7.356E-01, 7.355E-01, 7.354E-01, & + 7.352E-01, 7.350E-01, 7.347E-01, 7.345E-01/ + DATA C2_ASSSM_b1_19/ 5.833E-02, 5.835E-02, 5.841E-02, & + 5.850E-02, 5.859E-02, 5.870E-02, & + 5.880E-02, 5.891E-02, 5.904E-02, & + 5.914E-02, 5.920E-02, 5.924E-02, & + 5.928E-02, 5.934E-02, 5.944E-02, & + 5.959E-02, 5.979E-02, 6.003E-02, 6.020E-02/ +!COARSE MODE + DATA A1_CSSSM_b1_19/ 7.403E-01, 7.422E-01, 7.626E-01, & + 8.019E-01, 8.270E-01, 8.527E-01, & + 8.702E-01, 8.806E-01, 8.937E-01, & + 9.489E-01, 1.030E+00, 1.105E+00, & + 1.199E+00, 1.357E+00, 1.660E+00, & + 2.540E+00, 4.421E+00, 2.151E+00, 9.518E-01/ + DATA A2_CSSSM_b1_19/ 4.522E-01, 4.532E-01, 4.644E-01, & + 4.859E-01, 4.996E-01, 5.137E-01, & + 5.233E-01, 5.290E-01, 5.361E-01, & + 5.655E-01, 6.085E-01, 6.483E-01, & + 6.979E-01, 7.819E-01, 9.488E-01, & + 1.450E+00, 2.523E+00, 1.228E+00, 5.433E-01/ + DATA A3_CSSSM_b1_19/-8.516E-03, -8.535E-03, -8.744E-03, & + -9.148E-03, -9.406E-03, -9.668E-03, & + -9.848E-03, -9.955E-03, -1.009E-02, & + -1.064E-02, -1.145E-02, -1.219E-02, & + -1.312E-02, -1.470E-02, -1.783E-02, & + -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/ + DATA B1_CSSSM_b1_19/ 2.535E-07, 2.530E-07, 2.479E-07, & + 2.380E-07, 2.317E-07, 2.252E-07, & + 2.208E-07, 2.182E-07, 2.149E-07, & + 2.051E-07, 1.912E-07, 1.784E-07, & + 1.624E-07, 1.353E-07, 1.012E-07, & + 6.016E-08, 2.102E-08, 0.000E+00, 0.000E+00/ + DATA B2_CSSSM_b1_19/ 1.221E-07, 1.217E-07, 1.179E-07, & + 1.104E-07, 1.056E-07, 1.008E-07, & + 9.744E-08, 9.546E-08, 9.299E-08, & + 8.807E-08, 8.150E-08, 7.544E-08, & + 6.786E-08, 5.504E-08, 4.080E-08, & + 2.960E-08, 2.300E-08, 2.030E-08, 1.997E-08/ + DATA C1_CSSSM_b1_19/ 7.659E-01, 7.658E-01, 7.652E-01, & + 7.639E-01, 7.631E-01, 7.623E-01, & + 7.618E-01, 7.614E-01, 7.610E-01, & + 7.598E-01, 7.581E-01, 7.566E-01, & + 7.546E-01, 7.513E-01, 7.472E-01, & + 7.423E-01, 7.376E-01, 7.342E-01, 7.334E-01/ + DATA C2_CSSSM_b1_19/ 3.691E-02, 3.694E-02, 3.729E-02, & + 3.796E-02, 3.839E-02, 3.883E-02, & + 3.913E-02, 3.931E-02, 3.953E-02, & + 4.035E-02, 4.153E-02, 4.263E-02, & + 4.400E-02, 4.631E-02, 4.933E-02, & + 5.331E-02, 5.734E-02, 6.053E-02, 6.128E-02/ +!SUPER COARSE MODE + DATA A1_SSSSM_b1_19/ 2.836E-01, 2.876E-01, 2.563E-01, & + 2.414E-01, 2.541E-01, 2.546E-01, & + 2.572E-01, 2.638E-01, 2.781E-01, & + 3.167E-01, 4.209E-01, 5.286E-01, & + 6.959E-01, 9.233E-01, 1.282E+00, & + 1.836E+00, 2.981E+00, 4.355E+00, 4.059E+00/ + DATA A2_SSSSM_b1_19/ 1.608E-01, 1.651E-01, 1.577E-01, & + 1.587E-01, 1.686E-01, 1.690E-01, & + 1.711E-01, 1.762E-01, 1.874E-01, & + 2.138E-01, 2.751E-01, 3.363E-01, & + 4.279E-01, 5.519E-01, 7.421E-01, & + 1.048E+00, 1.702E+00, 2.485E+00, 2.317E+00/ + DATA A3_SSSSM_b1_19/-3.025E-03, -3.111E-03, -2.981E-03, & + -3.005E-03, -3.193E-03, -3.200E-03, & + -3.239E-03, -3.336E-03, -3.548E-03, & + -4.047E-03, -5.196E-03, -6.345E-03, & + -8.061E-03, -1.038E-02, -1.395E-02, & + -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/ + DATA B1_SSSSM_b1_19/ 6.759E-07, 6.246E-07, 5.542E-07, & + 4.953E-07, 4.746E-07, 4.738E-07, & + 4.695E-07, 4.588E-07, 4.354E-07, & + 3.947E-07, 3.461E-07, 3.067E-07, & + 2.646E-07, 2.095E-07, 1.481E-07, & + 9.024E-08, 5.747E-08, 2.384E-08, 6.599E-09/ + DATA B2_SSSSM_b1_19/ 5.977E-07, 5.390E-07, 4.468E-07, & + 3.696E-07, 3.443E-07, 3.433E-07, & + 3.380E-07, 3.249E-07, 2.962E-07, & + 2.483E-07, 1.989E-07, 1.623E-07, & + 1.305E-07, 9.015E-08, 6.111E-08, & + 3.761E-08, 2.903E-08, 2.337E-08, 2.147E-08/ + DATA C1_SSSSM_b1_19/ 8.120E-01, 8.084E-01, 8.016E-01, & + 7.953E-01, 7.929E-01, 7.928E-01, & + 7.923E-01, 7.910E-01, 7.882E-01, & + 7.834E-01, 7.774E-01, 7.725E-01, & + 7.673E-01, 7.604E-01, 7.529E-01, & + 7.458E-01, 7.419E-01, 7.379E-01, 7.360E-01/ + DATA C2_SSSSM_b1_19/ 2.388E-02, 2.392E-02, 2.457E-02, 2.552E-02, & + 2.615E-02, 2.618E-02, 2.631E-02, 2.663E-02, & + 2.735E-02, 2.875E-02, 3.113E-02, 3.330E-02, & + 3.615E-02, 3.997E-02, 4.521E-02, 5.038E-02, & + 5.358E-02, 5.705E-02, 5.887E-02/ +!*********************BAND 2************************************************ +!ACCUMULATION MODE + DATA A1_ASSSM_b2_19/1.256E+00, 1.246E+00, 1.226E+00, 1.187E+00, 1.148E+00, & + 1.105E+00, 1.062E+00, 1.014E+00, 9.616E-01, 9.205E-01, & + 8.970E-01, 8.800E-01, 8.632E-01, 8.371E-01, 7.943E-01, & + 7.308E-01, 6.448E-01, 5.414E-01, 4.693E-01/ + DATA A2_ASSSM_b2_19/5.321E-01, 5.284E-01, 5.196E-01, 5.036E-01, 4.872E-01, & + 4.691E-01, 4.512E-01, 4.308E-01, 4.089E-01, 3.917E-01, & + 3.818E-01, 3.747E-01, 3.676E-01, 3.567E-01, 3.385E-01, & + 3.116E-01, 2.751E-01, 2.312E-01, 2.006E-01/ + DATA A3_ASSSM_b2_19/-1.053E-02, -1.046E-02, -1.028E-02, -9.964E-03, -9.637E-03, & + -9.279E-03, -8.923E-03, -8.518E-03, -8.084E-03, -7.741E-03, & + -7.545E-03, -7.405E-03, -7.265E-03, -7.048E-03, -6.687E-03, & + -6.156E-03, -5.433E-03, -4.565E-03, -3.961E-03/ + DATA B1_ASSSM_b2_19/1.560E-02, 1.560E-02, 1.561E-02, 1.565E-02, 1.568E-02, & + 1.572E-02, 1.576E-02, 1.580E-02, 1.584E-02, 1.588E-02, & + 1.590E-02, 1.592E-02, 1.593E-02, 1.595E-02, 1.599E-02, & + 1.605E-02, 1.612E-02, 1.621E-02, 1.627E-02/ + DATA B2_ASSSM_b2_19/1.073E-02, 1.074E-02, 1.076E-02, 1.079E-02, 1.082E-02, & + 1.085E-02, 1.089E-02, 1.093E-02, 1.097E-02, 1.100E-02, & + 1.102E-02, 1.103E-02, 1.105E-02, 1.107E-02, 1.110E-02, & + 1.115E-02, 1.122E-02, 1.130E-02, 1.136E-02/ + DATA C1_ASSSM_b2_19/7.429E-01, 7.429E-01, 7.429E-01, 7.427E-01, 7.427E-01, & + 7.424E-01, 7.423E-01, 7.422E-01, 7.421E-01, 7.420E-01, & + 7.419E-01, 7.419E-01, 7.418E-01, 7.417E-01, 7.416E-01, & + 7.415E-01, 7.413E-01, 7.409E-01, 7.408E-01/ + DATA C2_ASSSM_b2_19/3.031E-02, 3.028E-02, 3.022E-02, 3.011E-02, 2.999E-02, & + 2.986E-02, 2.973E-02, 2.959E-02, 2.943E-02, 2.931E-02, & + 2.924E-02, 2.919E-02, 2.913E-02, 2.905E-02, 2.893E-02, & + 2.874E-02, 2.847E-02, 2.817E-02, 2.795E-02/ +!COARSE MODE + DATA A1_CSSSM_b2_19/7.061E-01, 7.074E-01, 7.211E-01, 7.476E-01, 7.647E-01, & + 7.817E-01, 7.937E-01, 8.007E-01, 8.095E-01, 8.436E-01, & + 8.932E-01, 9.390E-01, 9.963E-01, 1.093E+00, 1.256E+00, & + 1.668E+00, 1.581E+00, 3.457E-01, 1.331E-01/ + DATA A2_CSSSM_b2_19/3.617E-01, 3.621E-01, 3.662E-01, 3.739E-01, 3.789E-01, & + 3.840E-01, 3.874E-01, 3.895E-01, 3.921E-01, 4.001E-01, & + 4.117E-01, 4.223E-01, 4.356E-01, 4.581E-01, 5.099E-01, & + 6.831E-01, 6.663E-01, 1.481E-01, 5.703E-02/ + DATA A3_CSSSM_b2_19/-6.953E-03, -6.961E-03, -7.048E-03, -7.216E-03, -7.322E-03, & + -7.431E-03, -7.506E-03, -7.551E-03, -7.606E-03, -7.791E-03, & + -8.059E-03, -8.305E-03, -8.613E-03, -9.134E-03, -1.023E-02, & + -1.365E-02, -1.320E-02, -2.922E-03, -1.125E-03/ + DATA B1_CSSSM_b2_19/1.007E-02, 1.008E-02, 1.012E-02, 1.019E-02, 1.024E-02, & + 1.029E-02, 1.033E-02, 1.035E-02, 1.038E-02, 1.056E-02, & + 1.083E-02, 1.109E-02, 1.140E-02, 1.194E-02, 1.270E-02, & + 1.390E-02, 1.524E-02, 1.639E-02, 1.667E-02/ + DATA B2_CSSSM_b2_19/4.675E-03, 4.682E-03, 4.760E-03, 4.908E-03, 5.004E-03, & + 5.102E-03, 5.168E-03, 5.207E-03, 5.256E-03, 5.474E-03, & + 5.793E-03, 6.089E-03, 6.457E-03, 7.081E-03, 7.923E-03, & + 9.127E-03, 1.041E-02, 1.147E-02, 1.173E-02/ + DATA C1_CSSSM_b2_19/7.571E-01, 7.571E-01, 7.570E-01, 7.568E-01, 7.565E-01, & + 7.564E-01, 7.563E-01, 7.562E-01, 7.562E-01, 7.557E-01, & + 7.552E-01, 7.545E-01, 7.539E-01, 7.527E-01, 7.509E-01, & + 7.478E-01, 7.440E-01, 7.404E-01, 7.394E-01/ + DATA C2_CSSSM_b2_19/4.464E-02, 4.465E-02, 4.468E-02, 4.474E-02, 4.477E-02, & + 4.480E-02, 4.482E-02, 4.484E-02, 4.486E-02, 4.448E-02, & + 4.389E-02, 4.334E-02, 4.264E-02, 4.148E-02, 3.957E-02, & + 3.588E-02, 3.149E-02, 2.751E-02, 2.650E-02/ +!SUPER COARSE MODE + DATA A1_SSSSM_b2_19/2.357E-01, 2.490E-01, 2.666E-01, 2.920E-01, 3.120E-01, & + 3.128E-01, 3.169E-01, 3.272E-01, 3.498E-01, 3.960E-01, & + 4.822E-01, 5.634E-01, 6.763E-01, 8.278E-01, 1.047E+00, & + 1.340E+00, 1.927E+00, 1.648E+00, 1.031E+00/ + DATA A2_SSSSM_b2_19/1.219E-01, 1.337E-01, 1.633E-01, 1.929E-01, 2.057E-01, & + 2.062E-01, 2.089E-01, 2.155E-01, 2.300E-01, 2.560E-01, & + 2.908E-01, 3.199E-01, 3.530E-01, 3.965E-01, 4.475E-01, & + 5.443E-01, 7.943E-01, 6.928E-01, 4.381E-01/ + DATA A3_SSSSM_b2_19/-2.387E-03, -2.599E-03, -3.092E-03, -3.599E-03, -3.832E-03, & + -3.842E-03, -3.890E-03, -4.012E-03, -4.276E-03, -4.763E-03, & + -5.455E-03, -6.051E-03, -6.763E-03, -7.708E-03, -8.887E-03, & + -1.091E-02, -1.585E-02, -1.373E-02, -8.665E-03/ + DATA B1_SSSSM_b2_19/1.260E-02, 1.211E-02, 1.126E-02, 1.056E-02, 1.038E-02, & + 1.037E-02, 1.033E-02, 1.023E-02, 1.002E-02, 9.717E-03, & + 9.613E-03, 9.652E-03, 9.983E-03, 1.047E-02, 1.168E-02, & + 1.301E-02, 1.399E-02, 1.514E-02, 1.578E-02/ + DATA B2_SSSSM_b2_19/2.336E-03, 2.419E-03, 2.506E-03, 2.610E-03, 2.690E-03, & + 2.694E-03, 2.711E-03, 2.752E-03, 2.844E-03, 3.043E-03, & + 3.455E-03, 3.871E-03, 4.507E-03, 5.373E-03, 6.786E-03, & + 8.238E-03, 9.208E-03, 1.032E-02, 1.091E-02/ + DATA C1_SSSSM_b2_19/7.832E-01, 7.787E-01, 7.721E-01, 7.670E-01, 7.657E-01, & + 7.657E-01, 7.654E-01, 7.648E-01, 7.634E-01, 7.613E-01, & + 7.596E-01, 7.585E-01, 7.574E-01, 7.560E-01, 7.533E-01, & + 7.502E-01, 7.476E-01, 7.443E-01, 7.423E-01/ + DATA C2_SSSSM_b2_19/3.144E-02, 3.268E-02, 3.515E-02, 3.748E-02, 3.837E-02, & + 3.840E-02, 3.860E-02, 3.906E-02, 4.006E-02, 4.173E-02, & + 4.338E-02, 4.435E-02, 4.459E-02, 4.467E-02, 4.202E-02, & + 3.864E-02, 3.559E-02, 3.183E-02, 2.964E-02/ +!*************************************************************************** + + spsol = 0 + spinsol = 0 + spss = 0 + + DATA alpha_aers_2bands/ & + ! bc soluble + 7.675,7.675,7.675,7.675,7.675,7.675, & + 7.675,7.675,10.433,11.984,13.767,15.567,& + 4.720,4.720,4.720,4.720,4.720,4.720, & + 4.720,4.720,6.081,6.793,7.567,9.344, & + ! pom soluble + 5.503,5.503,5.503,5.503,5.588,5.957, & + 6.404,7.340,8.545,10.319,13.595,20.398, & + 1.402,1.402,1.402,1.402,1.431,1.562, & + 1.715,2.032,2.425,2.991,4.193,7.133, & + ! sulfate + 4.681,5.062,5.460,5.798,6.224,6.733, & + 7.556,8.613,10.687,12.265,16.32,21.692, & + 1.107,1.239,1.381,1.490,1.635,1.8030, & + 2.071,2.407,3.126,3.940,5.539,7.921, & + ! sulfate coarse + 4.681,5.062,5.460,5.798,6.224,6.733, & + 7.556,8.613,10.687,12.265,16.32,21.692, & + 1.107,1.239,1.381,1.490,1.635,1.8030, & + 2.071,2.407,3.126,3.940,5.539,7.921, & + ! seasalt Super Coarse Soluble (SS) + 0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, & + 1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, & + 0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, & + 1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, & + ! seasalt Coarse Soluble (CS) + 0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, & + 1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, & + 0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, & + 1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, & + ! seasalt Accumulation Soluble (AS) + 4.125, 4.674, 5.005, 5.434, 5.985, 10.006, & + 11.175,13.376,17.264,20.540,26.604, 42.349,& + 4.187, 3.939, 3.919, 3.937, 3.995, 5.078, & + 5.511, 6.434, 8.317,10.152,14.024, 26.537/ + + DATA alpha_aeri_2bands/ & + ! dust insoluble + 0.7661,0.7123,& + ! bc insoluble + 10.360,4.437, & + ! pom insoluble + 3.741,0.606/ + + DATA cg_aers_2bands/ & + ! bc soluble + .612, .612, .612, .612, .612, .612, & + .612, .612, .702, .734, .760, .796, & + .433, .433, .433, .433, .433, .433, & + .433, .433, .534, .575, .613, .669, & + ! pom soluble + .663, .663, .663, .663, .666, .674, & + .685, .702, .718, .737, .757, .777, & + .544, .544, .544, .544, .547, .554, & + .565, .583, .604, .631, .661, .698, & + ! sulfate + .658, .669, .680, .688, .698, .707, & + .719, .733, .752, .760, .773, .786, & + .544, .555, .565, .573, .583, .593, & + .610, .628, .655, .666, .692, .719, & + ! sulfate coarse + .658, .669, .680, .688, .698, .707, & + .719, .733, .752, .760, .773, .786, & + .544, .555, .565, .573, .583, .593, & + .610, .628, .655, .666, .692, .719, & + ! seasalt Super Coarse soluble (SS) + .727, .747, .755, .761, .770, .788, & + .792, .799, .805, .809, .815, .826, & + .717, .738, .745, .752, .761, .779, & + .781, .786, .793, .797, .803, .813, & + ! seasalt Coarse soluble (CS) + .727, .747, .755, .761, .770, .788, & + .792, .799, .805, .809, .815, .826, & + .717, .738, .745, .752, .761, .779, & + .781, .786, .793, .797, .803, .813, & + ! Sesalt Accumulation Soluble (AS) + .727, .741, .748, .754, .761, .782, & + .787, .792, .797, .799, .801, .799, & + .606, .645, .658, .669, .681, .726, & + .734, .746, .761, .770, .782, .798/ + + DATA cg_aeri_2bands/ & + ! dust insoluble + .701, .670, & + ! bc insoluble + .471, .297, & + ! pom insoluble + .568, .365/ + + DATA piz_aers_2bands/& + ! bc soluble + .445, .445, .445, .445, .445, .445, & + .445, .445, .461, .480, .505, .528, & + .362, .362, .362, .362, .362, .362, & + .362, .362, .381, .405, .437, .483, & + ! pom soluble + .972, .972, .972, .972, .972, .974, & + .976, .979, .982, .986, .989, .992, & + .924, .924, .924, .924, .925, .927, & + .932, .938, .945, .952, .961, .970, & + ! sulfate + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + .992, .988, .988, .987, .986, .985, & + .985, .985, .984, .984, .984, .984, & + ! sulfate coarse + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + .992, .988, .988, .987, .986, .985, & + .985, .985, .984, .984, .984, .984, & + ! seasalt Super Coarse Soluble (SS) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 0.992,0.989,0.987,0.986,0.986,0.980, & + 0.980,0.978,0.976,0.976,0.974,0.971, & + ! seasalt Coarse soluble (CS) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 0.992,0.989,0.987,0.986,0.986,0.980, & + 0.980,0.978,0.976,0.976,0.974,0.971, & + ! seasalt Accumulation Soluble (AS) + 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, & + 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, & + 0.970, 0.975, 0.976, 0.977, 0.978, 0.982, & + 0.982, 0.983, 0.984, 0.984, 0.985, 0.985/ + + DATA piz_aeri_2bands/ & + ! dust insoluble + .963, .987, & + ! bc insoluble + .395, .264, & + ! pom insoluble + .966, .859/ + +! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model + IF (firstcall) THEN + firstcall=.FALSE. + + IF (.NOT. ALLOCATED(A1_ASSSM_b1)) THEN + ALLOCATE(A1_ASSSM_b1(klev),A2_ASSSM_b1(klev), A3_ASSSM_b1(klev),& + B1_ASSSM_b1(klev), B2_ASSSM_b1(klev), C1_ASSSM_b1(klev), C2_ASSSM_b1(klev),& + A1_CSSSM_b1(klev), A2_CSSSM_b1(klev), A3_CSSSM_b1(klev),& + B1_CSSSM_b1(klev), B2_CSSSM_b1(klev), C1_CSSSM_b1(klev), C2_CSSSM_b1(klev),& + A1_SSSSM_b1(klev), A2_SSSSM_b1(klev), A3_SSSSM_b1(klev),& + B1_SSSSM_b1(klev), B2_SSSSM_b1(klev), C1_SSSSM_b1(klev), C2_SSSSM_b1(klev),& + A1_ASSSM_b2(klev), A2_ASSSM_b2(klev), A3_ASSSM_b2(klev),& + B1_ASSSM_b2(klev), B2_ASSSM_b2(klev), C1_ASSSM_b2(klev), C2_ASSSM_b2(klev),& + A1_CSSSM_b2(klev), A2_CSSSM_b2(klev), A3_CSSSM_b2(klev),& + B1_CSSSM_b2(klev), B2_CSSSM_b2(klev), C1_CSSSM_b2(klev), C2_CSSSM_b2(klev),& + A1_SSSSM_b2(klev), A2_SSSSM_b2(klev), A3_SSSSM_b2(klev),& + B1_SSSSM_b2(klev), B2_SSSSM_b2(klev), C1_SSSSM_b2(klev), C2_SSSSM_b2(klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('aeropt_2bands', 'pb in allocation 1',1) + END IF + +! bande 1 + CALL pres2lev(A1_ASSSM_b1_19, A1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_ASSSM_b1_19, A2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_ASSSM_b1_19, A3_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_ASSSM_b1_19, B1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_ASSSM_b1_19, B2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_ASSSM_b1_19, C1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_ASSSM_b1_19, C2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_CSSSM_b1_19, A1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_CSSSM_b1_19, A2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_CSSSM_b1_19, A3_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_CSSSM_b1_19, B1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_CSSSM_b1_19, B2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_CSSSM_b1_19, C1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_CSSSM_b1_19, C2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_SSSSM_b1_19, A1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_SSSSM_b1_19, A2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_SSSSM_b1_19, A3_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_SSSSM_b1_19, B1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_SSSSM_b1_19, B2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_SSSSM_b1_19, C1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_SSSSM_b1_19, C2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + +! bande 2 + CALL pres2lev(A1_ASSSM_b2_19, A1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_ASSSM_b2_19, A2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_ASSSM_b2_19, A3_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_ASSSM_b2_19, B1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_ASSSM_b2_19, B2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_ASSSM_b2_19, C1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_ASSSM_b2_19, C2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_CSSSM_b2_19, A1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_CSSSM_b2_19, A2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_CSSSM_b2_19, A3_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_CSSSM_b2_19, B1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_CSSSM_b2_19, B2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_CSSSM_b2_19, C1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_CSSSM_b2_19, C2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + CALL pres2lev(A1_SSSSM_b2_19, A1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_SSSSM_b2_19, A2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_SSSSM_b2_19, A3_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_SSSSM_b2_19, B1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_SSSSM_b2_19, B2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_SSSSM_b2_19, C1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_SSSSM_b2_19, C2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + END IF ! firstcall + + + DO k=1, klev + DO i=1, klon + zrho=pplay(i,k)/t_seri(i,k)/RD ! kg/m3 +!CDIR UNROLL=naero_spc + mass_temp(i,k,:) = m_allaer(i,k,:) / zrho / 1.e+9 +!RAF zrho +!CDIR UNROLL=naero_spc + mass_temp_pi(i,k,:) = m_allaer_pi(i,k,:) / zrho / 1.e+9 + zdp1(i,k)=pdel(i,k)/(gravit*delt) ! air mass auxiliary variable --> zdp1 [kg/(m^2 *s)] + ENDDO + ENDDO + + IF (flag_aerosol .EQ. 1) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_CSSO4M + ELSEIF (flag_aerosol .EQ. 2) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASBCM + aerosol_name(2) = id_AIBCM + ELSEIF (flag_aerosol .EQ. 3) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASPOMM + aerosol_name(2) = id_AIPOMM + ELSEIF (flag_aerosol .EQ. 4) THEN + nb_aer = 3 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CSSSM + aerosol_name(2) = id_SSSSM + aerosol_name(3) = id_ASSSM + ELSEIF (flag_aerosol .EQ. 5) THEN + nb_aer = 1 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CIDUSTM + ELSEIF (flag_aerosol .EQ. 6) THEN + nb_aer = 10 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_ASBCM + aerosol_name(3) = id_AIBCM + aerosol_name(4) = id_ASPOMM + aerosol_name(5) = id_AIPOMM + aerosol_name(6) = id_CSSSM + aerosol_name(7) = id_SSSSM + aerosol_name(8) = id_ASSSM + aerosol_name(9) = id_CIDUSTM + aerosol_name(10)= id_CSSO4M + ENDIF + + + ! + ! loop over modes, use of precalculated nmd and corresponding sigma + ! loop over wavelengths + ! for each mass species in mode + ! interpolate from Sext to retrieve Sext_at_gridpoint_per_species + ! compute optical_thickness_at_gridpoint_per_species + + + +!!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) +!CDIR SHORTLOOP + DO n=1,nbre_RH-1 + fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n)) + ENDDO + + DO k=1, KLEV +!!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) + DO i=1, KLON + rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX) + RH_num(i,k) = INT( rh(i,k)/10. + 1.) + IF (rh(i,k).GT.85.) RH_num(i,k)=10 + IF (rh(i,k).GT.90.) RH_num(i,k)=11 + + DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k)) + ENDDO + ENDDO + + used_aer(:)=.FALSE. + + DO m=1,nb_aer ! tau is only computed for each mass + fac=1.0 + IF (aerosol_name(m).EQ.id_ASBCM) THEN + soluble=.TRUE. + spsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASPOMM) THEN + soluble=.TRUE. + spsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASSO4M) THEN + soluble=.TRUE. + spsol=3 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_CSSO4M) THEN + soluble=.TRUE. + spsol=4 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_SSSSM) THEN + soluble=.TRUE. + spsol=5 + spss=3 + ELSEIF (aerosol_name(m).EQ.id_CSSSM) THEN + soluble=.TRUE. + spsol=6 + spss=2 + ELSEIF (aerosol_name(m).EQ.id_ASSSM) THEN + soluble=.TRUE. + spsol=7 + spss=1 + ELSEIF (aerosol_name(m).EQ.id_CIDUSTM) THEN + soluble=.FALSE. + spinsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIBCM) THEN + soluble=.FALSE. + spinsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIPOMM) THEN + soluble=.FALSE. + spinsol=3 + spss=0 + ELSE + CYCLE + ENDIF + + id=aerosol_name(m) + used_aer(id)=.TRUE. + + + IF (soluble) THEN + + IF (spss.NE.0) THEN + + IF (spss.EQ.1) THEN !accumulation mode + DO k=1, KLEV +!CDIR ON_ADB(A1_ASSSM_b1) +!CDIR ON_ADB(A2_ASSSM_b1) +!CDIR ON_ADB(A3_ASSSM_b1) +!CDIR ON_ADB(B1_ASSSM_b1) +!CDIR ON_ADB(B2_ASSSM_b1) +!CDIR ON_ADB(C1_ASSSM_b1) +!CDIR ON_ADB(C2_ASSSM_b2) +!CDIR ON_ADB(A1_ASSSM_b2) +!CDIR ON_ADB(A2_ASSSM_b2) +!CDIR ON_ADB(A3_ASSSM_b2) +!CDIR ON_ADB(B1_ASSSM_b2) +!CDIR ON_ADB(B2_ASSSM_b2) +!CDIR ON_ADB(C1_ASSSM_b2) +!CDIR ON_ADB(C2_ASSSM_b2) + DO i=1, KLON + H=rh(i,k)/100 + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + + ! band 1 + tau_ae2b_int=A1_ASSSM_b1(k)+A2_ASSSM_b1(k)*H+A3_ASSSM_b1(k)/(H-1.05) + piz_ae2b_int=1-B1_ASSSM_b1(k)-B2_ASSSM_b1(k)*H + cg_ae2b_int=C1_ASSSM_b1(k)+C2_ASSSM_b1(k)*H + + tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,1) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,1) = piz_ae2b_int + cg_ae(i,k,id,1)= cg_ae2b_int + + !band 2 + tau_ae2b_int=A1_ASSSM_b2(k)+A2_ASSSM_b2(k)*H+A3_ASSSM_b2(k)/(H-1.05) + piz_ae2b_int=1-B1_ASSSM_b2(k)-B2_ASSSM_b2(k)*H + cg_ae2b_int=C1_ASSSM_b2(k)+C2_ASSSM_b2(k)*H + + tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,2) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,2) = piz_ae2b_int + cg_ae(i,k,id,2)= cg_ae2b_int + + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.2) THEN !coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_CSSSM_b1) +!CDIR ON_ADB(A2_CSSSM_b1) +!CDIR ON_ADB(A3_CSSSM_b1) +!CDIR ON_ADB(B1_CSSSM_b1) +!CDIR ON_ADB(B2_CSSSM_b1) +!CDIR ON_ADB(C1_CSSSM_b1) +!CDIR ON_ADB(C2_CSSSM_b2) +!CDIR ON_ADB(A1_CSSSM_b2) +!CDIR ON_ADB(A2_CSSSM_b2) +!CDIR ON_ADB(A3_CSSSM_b2) +!CDIR ON_ADB(B1_CSSSM_b2) +!CDIR ON_ADB(B2_CSSSM_b2) +!CDIR ON_ADB(C1_CSSSM_b2) +!CDIR ON_ADB(C2_CSSSM_b2) + DO i=1, KLON + H=rh(i,k)/100 + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + ! band 1 + tau_ae2b_int=A1_CSSSM_b1(k)+A2_CSSSM_b1(k)*H+A3_CSSSM_b1(k)/(H-1.05) + piz_ae2b_int=1-B1_CSSSM_b1(k)-B2_CSSSM_b1(k)*H + cg_ae2b_int=C1_CSSSM_b1(k)+C2_CSSSM_b1(k)*H + + tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,1) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,1) = piz_ae2b_int + cg_ae(i,k,id,1)= cg_ae2b_int + + ! band 2 + tau_ae2b_int=A1_CSSSM_b2(k)+A2_CSSSM_b2(k)*H+A3_CSSSM_b2(k)/(H-1.05) + piz_ae2b_int=1-B1_CSSSM_b2(k)-B2_CSSSM_b2(k)*H + cg_ae2b_int=C1_CSSSM_b2(k)+C2_CSSSM_b2(k)*H + + tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,2) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,2) = piz_ae2b_int + cg_ae(i,k,id,2)= cg_ae2b_int + + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.3) THEN !super coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_SSSSM_b1) +!CDIR ON_ADB(A2_SSSSM_b1) +!CDIR ON_ADB(A3_SSSSM_b1) +!CDIR ON_ADB(B1_SSSSM_b1) +!CDIR ON_ADB(B2_SSSSM_b1) +!CDIR ON_ADB(C1_SSSSM_b1) +!CDIR ON_ADB(C2_SSSSM_b2) +!CDIR ON_ADB(A1_SSSSM_b2) +!CDIR ON_ADB(A2_SSSSM_b2) +!CDIR ON_ADB(A3_SSSSM_b2) +!CDIR ON_ADB(B1_SSSSM_b2) +!CDIR ON_ADB(B2_SSSSM_b2) +!CDIR ON_ADB(C1_SSSSM_b2) +!CDIR ON_ADB(C2_SSSSM_b2) + DO i=1, KLON + H=rh(i,k)/100 + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + + ! band 1 + tau_ae2b_int=A1_SSSSM_b1(k)+A2_SSSSM_b1(k)*H+A3_SSSSM_b1(k)/(H-1.05) + piz_ae2b_int=1-B1_SSSSM_b1(k)-B2_SSSSM_b1(k)*H + cg_ae2b_int=C1_SSSSM_b1(k)+C2_SSSSM_b1(k)*H + + tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,1) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,1) = piz_ae2b_int + cg_ae(i,k,id,1)= cg_ae2b_int + + ! band 2 + tau_ae2b_int=A1_SSSSM_b2(k)+A2_SSSSM_b2(k)*H+A3_SSSSM_b2(k)/(H-1.05) + piz_ae2b_int=1-B1_SSSSM_b2(k)-B2_SSSSM_b2(k)*H + cg_ae2b_int=C1_SSSSM_b2(k)+C2_SSSSM_b2(k)*H + + tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,2) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,2) = piz_ae2b_int + cg_ae(i,k,id,2)= cg_ae2b_int + + ENDDO + ENDDO + ENDIF + + ELSE + +!CDIR ON_ADB(alpha_aers_2bands) +!CDIR ON_ADB(piz_aers_2bands) +!CDIR ON_ADB(cg_aers_2bands) + DO k=1, KLEV + DO i=1, KLON + tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac +!CDIR UNROLL=nbands + DO inu=1,nbands + + tau_ae2b_int= alpha_aers_2bands(RH_num(i,k),inu,spsol)+ & + DELTA(i,k)* (alpha_aers_2bands(RH_num(i,k)+1,inu,spsol) - & + alpha_aers_2bands(RH_num(i,k),inu,spsol)) + + piz_ae2b_int = piz_aers_2bands(RH_num(i,k),inu,spsol) + & + DELTA(i,k)* (piz_aers_2bands(RH_num(i,k)+1,inu,spsol) - & + piz_aers_2bands(RH_num(i,k),inu,spsol)) + + cg_ae2b_int = cg_aers_2bands(RH_num(i,k),inu,spsol) + & + DELTA(i,k)* (cg_aers_2bands(RH_num(i,k)+1,inu,spsol) - & + cg_aers_2bands(RH_num(i,k),inu,spsol)) + + tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,inu) = tmp_var_pi* tau_ae2b_int + piz_ae(i,k,id,inu) = piz_ae2b_int + cg_ae(i,k,id,inu)= cg_ae2b_int + + ENDDO + ENDDO + ENDDO + + ENDIF + + ELSE ! For all aerosol insoluble components + +!CDIR ON_ADB(alpha_aers_2bands) +!CDIR ON_ADB(piz_aers_2bands) +!CDIR ON_ADB(cg_aers_2bands) + DO k=1, KLEV + DO i=1, KLON + tmp_var=mass_temp(i,k,naero_soluble+ spinsol)*1000.*zdp1(i,k)*delt*fac + tmp_var_pi=mass_temp_pi(i,k,naero_soluble+spinsol)*1000.*zdp1(i,k)*delt*fac +!CDIR UNROLL=nbands + DO inu=1,nbands + tau_ae2b_int = alpha_aeri_2bands(inu,spinsol) + piz_ae2b_int = piz_aeri_2bands(inu,spinsol) + cg_ae2b_int = cg_aeri_2bands(inu,spinsol) + + tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int + tau_ae_pi(i,k,id,inu) = tmp_var_pi*tau_ae2b_int + piz_ae(i,k,id,inu) = piz_ae2b_int + cg_ae(i,k,id,inu)= cg_ae2b_int + ENDDO + ENDDO + ENDDO + + ENDIF ! soluble + + ENDDO ! nb_aer + + DO m=1,nb_aer + IF (.NOT. used_aer(m)) THEN + tau_ae(:,:,:,:)=0. + tau_ae_pi(:,:,:,:)=0. + piz_ae(:,:,:,:)=0. + cg_ae(:,:,:,:)=0. + ENDIF + ENDDO + + DO inu=1, nbands + DO mrfspecies=1,naero_grp + IF (mrfspecies .EQ. 2) THEN ! = total aerosol AER + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M,inu)+tau_ae(i,k,id_CSSO4M,inu)+ & + tau_ae(i,k,id_ASBCM,inu)+tau_ae(i,k,id_AIBCM,inu)+ & + tau_ae(i,k,id_ASPOMM,inu)+tau_ae(i,k,id_AIPOMM,inu)+ & + tau_ae(i,k,id_ASSSM,inu)+tau_ae(i,k,id_CSSSM,inu)+ & + tau_ae(i,k,id_SSSSM,inu)+ tau_ae(i,k,id_CIDUSTM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)+ & + tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)+ & + tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)+ & + tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)+ & + tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)+ & + tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)+ & + tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)+ & + tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)+ & + tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)+ & + tau_ae(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)) & + /tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu)+ & + tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)*cg_ae(i,k,id_CSSO4M,inu)+ & + tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)*cg_ae(i,k,id_ASBCM,inu)+ & + tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu)+ & + tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)*cg_ae(i,k,id_ASPOMM,inu)+ & + tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu)+ & + tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)*cg_ae(i,k,id_ASSSM,inu)+ & + tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu)+ & + tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu)+ & + tau_ae(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)*cg_ae(i,k,id_CIDUSTM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 3) THEN ! = natural aerosol NAT + + DO k=1, KLEV + DO i=1, KLON +!RAF + tau_allaer(i,k,mrfspecies,inu)=tau_ae_pi(i,k,id_ASSO4M,inu)+ & + tau_ae_pi(i,k,id_CSSO4M,inu)+ & + tau_ae_pi(i,k,id_ASBCM,inu)+ & + tau_ae_pi(i,k,id_AIBCM,inu)+ & + tau_ae_pi(i,k,id_ASPOMM,inu)+ & + tau_ae_pi(i,k,id_AIPOMM,inu)+ & + tau_ae_pi(i,k,id_ASSSM,inu)+ & + tau_ae_pi(i,k,id_CSSSM,inu)+ & + tau_ae_pi(i,k,id_SSSSM,inu)+ & + tau_ae_pi(i,k,id_CIDUSTM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + + piz_allaer(i,k,mrfspecies,inu)=(tau_ae_pi(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)+ & + tau_ae_pi(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)+ & + tau_ae_pi(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)+ & + tau_ae_pi(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)+ & + tau_ae_pi(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)+ & + tau_ae_pi(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)+ & + tau_ae_pi(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)+ & + tau_ae_pi(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)+ & + tau_ae_pi(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)+ & + tau_ae_pi(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)) & + /tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + + cg_allaer(i,k,mrfspecies,inu)=(& + tau_ae_pi(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu)+ & + tau_ae_pi(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)*cg_ae(i,k,id_CSSO4M,inu)+ & + tau_ae_pi(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)*cg_ae(i,k,id_ASBCM,inu)+ & + tau_ae_pi(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu)+ & + tau_ae_pi(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)*cg_ae(i,k,id_ASPOMM,inu)+ & + tau_ae_pi(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu)+ & + tau_ae_pi(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)*cg_ae(i,k,id_ASSSM,inu)+ & + tau_ae_pi(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu)+ & + tau_ae_pi(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu)+ & + tau_ae_pi(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)*& + cg_ae(i,k,id_CIDUSTM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 4) THEN ! = BC + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASBCM,inu)+tau_ae(i,k,id_AIBCM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu) & + +tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu) *cg_ae(i,k,id_ASBCM,inu)& + +tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 5) THEN ! = SO4 + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M,inu)+tau_ae(i,k,id_CSSO4M,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu) & + +tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu) *cg_ae(i,k,id_CSSO4M,inu)& + +tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 6) THEN ! = POM + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASPOMM,inu)+tau_ae(i,k,id_AIPOMM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu) & + +tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu) *cg_ae(i,k,id_ASPOMM,inu)& + +tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 7) THEN ! = DUST + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_CIDUSTM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=piz_ae(i,k,id_CIDUSTM,inu) + cg_allaer(i,k,mrfspecies,inu)=cg_ae(i,k,id_CIDUSTM,inu) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 8) THEN ! = SS + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSSM,inu)+tau_ae(i,k,id_CSSSM,inu)+tau_ae(i,k,id_SSSSM,inu) + tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5) + piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu) & + +tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu) & + +tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu))/ & + tau_allaer(i,k,mrfspecies,inu) + piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1) + cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu) *cg_ae(i,k,id_ASSSM,inu)& + +tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu) & + +tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu))/ & + (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu)) + ENDDO + ENDDO + + ELSEIF (mrfspecies .EQ. 9) THEN ! = NO3 + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=0. ! preliminary + piz_allaer(i,k,mrfspecies,inu)=0. + cg_allaer(i,k,mrfspecies,inu)=0. + ENDDO + ENDDO + + ELSE + + DO k=1, KLEV + DO i=1, KLON + tau_allaer(i,k,mrfspecies,inu)=0. + piz_allaer(i,k,mrfspecies,inu)=0. + cg_allaer(i,k,mrfspecies,inu)=0. + ENDDO + ENDDO + + ENDIF + + ENDDO + ENDDO + + + inu=1 + DO i=1, KLON + absvisaer(i)=SUM((1-piz_allaer(i,:,:,inu))*tau_allaer(i,:,:,inu)) + END DO + + DEALLOCATE(aerosol_name) + +END SUBROUTINE AEROPT_2BANDS Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt_5wv.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt_5wv.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/aeropt_5wv.F90 (revision 1634) @@ -0,0 +1,888 @@ +! +! $Id$ +! + +SUBROUTINE AEROPT_5WV(& + pdel, m_allaer, delt, & + RHcl, ai, flag_aerosol, & + pplay, t_seri, & + tausum, tau, presnivs) + + USE DIMPHY + USE aero_mod + USE phys_local_var_mod, only: od550aer,od865aer,ec550aer,od550lt1aer + + ! + ! Yves Balkanski le 12 avril 2006 + ! Celine Deandreis + ! Anne Cozic Avril 2009 + ! a partir d'une sous-routine de Johannes Quaas pour les sulfates + ! + ! + ! Refractive indices for seasalt come from Shettle and Fenn (1979) + ! + ! Refractive indices from water come from Hale and Querry (1973) + ! + ! Refractive indices from Ammonium Sulfate Toon and Pollack (1976) + ! + ! Refractive indices for Dust, internal mixture of minerals coated with 1.5% hematite + ! by Volume (Balkanski et al., 2006) + ! + ! Refractive indices for POM: Kinne (pers. Communication + ! + ! Refractive index for BC from Shettle and Fenn (1979) + ! + ! Shettle, E. P., & Fenn, R. W. (1979), Models for the aerosols of the lower atmosphere and + ! the effects of humidity variations on their optical properties, U.S. Air Force Geophysics + ! Laboratory Rept. AFGL-TR-79-0214, Hanscomb Air Force Base, MA. + ! + ! Hale, G. M. and M. R. Querry, Optical constants of water in the 200-nm to 200-m + ! wavelength region, Appl. Opt., 12, 555-563, 1973. + ! + ! Toon, O. B. and J. B. Pollack, The optical constants of several atmospheric aerosol species: + ! Ammonium sulfate, aluminum oxide, and sodium chloride, J. Geohys. Res., 81, 5733-5748, + ! 1976. + ! + ! Balkanski, Y., M. Schulz, T. Claquin And O. Boucher, Reevaluation of mineral aerosol + ! radiative forcings suggests a better agreement with satellite and AERONET data, Atmospheric + ! Chemistry and Physics Discussions., 6, pp 8383-8419, 2006. + ! + IMPLICIT NONE + INCLUDE "YOMCST.h" + ! + ! Input arguments: + ! + REAL, DIMENSION(klon,klev), INTENT(in) :: pdel + REAL, INTENT(in) :: delt + REAL, DIMENSION(klon,klev,naero_spc), INTENT(in) :: m_allaer + REAL, DIMENSION(klon,klev), INTENT(in) :: RHcl ! humidite relative ciel clair + INTEGER,INTENT(in) :: flag_aerosol + REAL, DIMENSION(klon,klev), INTENT(in) :: pplay + REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri + REAL, DIMENSION(klev), INTENT(in) :: presnivs + ! + ! Output arguments: + ! + REAL, DIMENSION(klon), INTENT(out) :: ai ! POLDER aerosol index + REAL, DIMENSION(klon,nwave,naero_spc), INTENT(out) :: tausum + REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(out) :: tau + + + ! + ! Local + ! + INTEGER, PARAMETER :: las = nwave + LOGICAL :: soluble + + INTEGER :: i, k, ierr, m + INTEGER :: spsol, spinsol, spss, la + INTEGER :: RH_num(klon,klev) + INTEGER, PARAMETER :: la443 = 1 + INTEGER, PARAMETER :: la550 = 2 + INTEGER, PARAMETER :: la670 = 3 + INTEGER, PARAMETER :: la765 = 4 + INTEGER, PARAMETER :: la865 = 5 + INTEGER, PARAMETER :: nbre_RH=12 + INTEGER, PARAMETER :: naero_soluble=7 ! 1- BC soluble; 2- POM soluble; 3- SO4 acc. + ! 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + INTEGER, PARAMETER :: naero_insoluble=3 ! 1- Dust; 2- BC insoluble; 3- POM insoluble + INTEGER, PARAMETER :: nb_level = 19 ! number of vertical levels + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + + REAL :: zrho + + ! Coefficient optiques sur 19 niveaux + REAL, SAVE, DIMENSION(nb_level) :: presnivs_19 ! Pression milieux couche pour 19 niveaux (nb_level) +!$OMP THREADPRIVATE(presnivs_19) + + REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19,& + B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19,& + A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19,& + B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19, & + A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19,& + B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19 +!$OMP THREADPRIVATE(A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19) +!$OMP THREADPRIVATE(B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19) +!$OMP THREADPRIVATE(A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19) +!$OMP THREADPRIVATE(B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19) +!$OMP THREADPRIVATE(A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19) +!$OMP THREADPRIVATE(B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19) + + ! Coefficient optiques interpole sur le nombre de niveau du modele + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: & + A1_ASSSM, A2_ASSSM, A3_ASSSM,& + B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM,& + A1_CSSSM, A2_CSSSM, A3_CSSSM,& + B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM, & + A1_SSSSM, A2_SSSSM, A3_SSSSM,& + B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM +!$OMP THREADPRIVATE(A1_ASSSM, A2_ASSSM, A3_ASSSM) +!$OMP THREADPRIVATE(B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM) +!$OMP THREADPRIVATE(A1_CSSSM, A2_CSSSM, A3_CSSSM) +!$OMP THREADPRIVATE(B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM) +!$OMP THREADPRIVATE(A1_SSSSM, A2_SSSSM, A3_SSSSM) +!$OMP THREADPRIVATE(B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM) + + + REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./) + REAL :: DELTA(klon,klev), rh(klon,klev), H + REAL :: tau_ae5wv_int ! Intermediate computation of epaisseur optique aerosol + REAL :: piz_ae5wv_int ! Intermediate single scattering albedo aerosol + REAL :: cg_ae5wv_int ! Intermediate asymmetry parameter aerosol + REAL, PARAMETER :: RH_MAX=95. + REAL :: taue670(KLON) ! epaisseur optique aerosol absorption 550 nm + REAL :: taue865(KLON) ! epaisseur optique aerosol extinction 865 nm + REAL :: fac + REAL :: zdp1(klon,klev) + REAL, PARAMETER :: gravit = 9.80616 ! m2/s + INTEGER, ALLOCATABLE, DIMENSION(:) :: aerosol_name + INTEGER :: nb_aer + + REAL :: tau3d(KLON,KLEV), piz3d(KLON,KLEV), cg3d(KLON,KLEV) + REAL :: abs3d(KLON,KLEV) ! epaisseur optique d'absorption + REAL :: dh(KLON,KLEV) + + REAL :: alpha_aers_5wv(nbre_RH,las,naero_soluble) ! ext. coeff. Soluble comp. units *** m2/g + ! 1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + REAL :: alpha_aeri_5wv(las,naero_insoluble) ! ext. coeff. Insoluble comp. 1- Dust: 2- BC; 3- POM + REAL :: cg_aers_5wv(nbre_RH,las,naero_soluble) ! Asym. param. soluble comp. + ! 1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + REAL :: cg_aeri_5wv(las,naero_insoluble) ! Asym. param. insoluble comp. 1- Dust: 2- BC; 3- POM + REAL :: piz_aers_5wv(nbre_RH,las,naero_soluble) + ! 1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc. + REAL :: piz_aeri_5wv(las,naero_insoluble) ! Insoluble comp. 1- Dust: 2- BC; 3- POM + + REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp + + ! + ! Proprietes optiques + ! + REAL :: radry = 287.054 + REAL :: tau_tmp ! dry air mass constant + REAL :: fact_RH(nbre_RH) + LOGICAL :: used_tau(naero_spc) + INTEGER :: n + + DATA presnivs_19/& + 100426.5, 98327.6, 95346.5, 90966.8, 84776.9, & + 76536.5, 66292.2, 54559.3, 42501.8, 31806, & + 23787.5, 18252.7, 13996, 10320.8, 7191.1, & + 4661.7, 2732.9, 1345.6, 388.2/ + +!!ACCUMULATION MODE + DATA A1_ASSSM_19/ 4.373E+00, 4.361E+00, 4.331E+00, & + 4.278E+00, 4.223E+00, 4.162E+00, & + 4.103E+00, 4.035E+00, 3.962E+00, & + 3.904E+00, 3.871E+00, 3.847E+00, & + 3.824E+00, 3.780E+00, 3.646E+00, & + 3.448E+00, 3.179E+00, 2.855E+00, 2.630E+00/ + DATA A2_ASSSM_19/ 2.496E+00, 2.489E+00, 2.472E+00, & + 2.442E+00, 2.411E+00, 2.376E+00, & + 2.342E+00, 2.303E+00, 2.261E+00, & + 2.228E+00, 2.210E+00, 2.196E+00, & + 2.183E+00, 2.158E+00, 2.081E+00, & + 1.968E+00, 1.814E+00, 1.630E+00, 1.501E+00/ + DATA A3_ASSSM_19/-4.688E-02, -4.676E-02, -4.644E-02, & + -4.587E-02, -4.528E-02, -4.463E-02, & + -4.399E-02, -4.326E-02, -4.248E-02, & + -4.186E-02, -4.151E-02, -4.125E-02, & + -4.100E-02, -4.053E-02, -3.910E-02, & + -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/ + DATA B1_ASSSM_19/ 1.165E-08, 1.145E-08, 1.097E-08, & + 1.012E-08, 9.233E-09, 8.261E-09, & + 7.297E-09, 6.201E-09, 5.026E-09, & + 4.098E-09, 3.567E-09, 3.187E-09, & + 2.807E-09, 2.291E-09, 2.075E-09, & + 1.756E-09, 1.322E-09, 8.011E-10, 4.379E-10/ + DATA B2_ASSSM_19/ 2.193E-08, 2.192E-08, 2.187E-08, & + 2.179E-08, 2.171E-08, 2.162E-08, & + 2.153E-08, 2.143E-08, 2.132E-08, & + 2.124E-08, 2.119E-08, 2.115E-08, & + 2.112E-08, 2.106E-08, 2.100E-08, & + 2.090E-08, 2.077E-08, 2.061E-08, 2.049E-08/ + DATA C1_ASSSM_19/ 7.365E-01, 7.365E-01, 7.365E-01, & + 7.364E-01, 7.363E-01, 7.362E-01, & + 7.361E-01, 7.359E-01, 7.358E-01, & + 7.357E-01, 7.356E-01, 7.356E-01, & + 7.356E-01, 7.355E-01, 7.354E-01, & + 7.352E-01, 7.350E-01, 7.347E-01, 7.345E-01/ + DATA C2_ASSSM_19/ 5.833E-02, 5.835E-02, 5.841E-02, & + 5.850E-02, 5.859E-02, 5.870E-02, & + 5.880E-02, 5.891E-02, 5.904E-02, & + 5.914E-02, 5.920E-02, 5.924E-02, & + 5.928E-02, 5.934E-02, 5.944E-02, & + 5.959E-02, 5.979E-02, 6.003E-02, 6.020E-02/ +!COARSE MODE + DATA A1_CSSSM_19/ 7.403E-01, 7.422E-01, 7.626E-01, & + 8.019E-01, 8.270E-01, 8.527E-01, & + 8.702E-01, 8.806E-01, 8.937E-01, & + 9.489E-01, 1.030E+00, 1.105E+00, & + 1.199E+00, 1.357E+00, 1.660E+00, & + 2.540E+00, 4.421E+00, 2.151E+00, 9.518E-01/ + DATA A2_CSSSM_19/ 4.522E-01, 4.532E-01, 4.644E-01, & + 4.859E-01, 4.996E-01, 5.137E-01, & + 5.233E-01, 5.290E-01, 5.361E-01, & + 5.655E-01, 6.085E-01, 6.483E-01, & + 6.979E-01, 7.819E-01, 9.488E-01, & + 1.450E+00, 2.523E+00, 1.228E+00, 5.433E-01/ + DATA A3_CSSSM_19/-8.516E-03, -8.535E-03, -8.744E-03, & + -9.148E-03, -9.406E-03, -9.668E-03, & + -9.848E-03, -9.955E-03, -1.009E-02, & + -1.064E-02, -1.145E-02, -1.219E-02, & + -1.312E-02, -1.470E-02, -1.783E-02, & + -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/ + DATA B1_CSSSM_19/ 2.535E-07, 2.530E-07, 2.479E-07, & + 2.380E-07, 2.317E-07, 2.252E-07, & + 2.208E-07, 2.182E-07, 2.149E-07, & + 2.051E-07, 1.912E-07, 1.784E-07, & + 1.624E-07, 1.353E-07, 1.012E-07, & + 6.016E-08, 2.102E-08, 0.000E+00, 0.000E+00/ + DATA B2_CSSSM_19/ 1.221E-07, 1.217E-07, 1.179E-07, & + 1.104E-07, 1.056E-07, 1.008E-07, & + 9.744E-08, 9.546E-08, 9.299E-08, & + 8.807E-08, 8.150E-08, 7.544E-08, & + 6.786E-08, 5.504E-08, 4.080E-08, & + 2.960E-08, 2.300E-08, 2.030E-08, 1.997E-08/ + DATA C1_CSSSM_19/ 7.659E-01, 7.658E-01, 7.652E-01, & + 7.639E-01, 7.631E-01, 7.623E-01, & + 7.618E-01, 7.614E-01, 7.610E-01, & + 7.598E-01, 7.581E-01, 7.566E-01, & + 7.546E-01, 7.513E-01, 7.472E-01, & + 7.423E-01, 7.376E-01, 7.342E-01, 7.334E-01/ + DATA C2_CSSSM_19/ 3.691E-02, 3.694E-02, 3.729E-02, & + 3.796E-02, 3.839E-02, 3.883E-02, & + 3.913E-02, 3.931E-02, 3.953E-02, & + 4.035E-02, 4.153E-02, 4.263E-02, & + 4.400E-02, 4.631E-02, 4.933E-02, & + 5.331E-02, 5.734E-02, 6.053E-02, 6.128E-02/ +!SUPER COARSE MODE + DATA A1_SSSSM_19/ 2.836E-01, 2.876E-01, 2.563E-01, & + 2.414E-01, 2.541E-01, 2.546E-01, & + 2.572E-01, 2.638E-01, 2.781E-01, & + 3.167E-01, 4.209E-01, 5.286E-01, & + 6.959E-01, 9.233E-01, 1.282E+00, & + 1.836E+00, 2.981E+00, 4.355E+00, 4.059E+00/ + DATA A2_SSSSM_19/ 1.608E-01, 1.651E-01, 1.577E-01, & + 1.587E-01, 1.686E-01, 1.690E-01, & + 1.711E-01, 1.762E-01, 1.874E-01, & + 2.138E-01, 2.751E-01, 3.363E-01, & + 4.279E-01, 5.519E-01, 7.421E-01, & + 1.048E+00, 1.702E+00, 2.485E+00, 2.317E+00/ + DATA A3_SSSSM_19/-3.025E-03, -3.111E-03, -2.981E-03, & + -3.005E-03, -3.193E-03, -3.200E-03, & + -3.239E-03, -3.336E-03, -3.548E-03, & + -4.047E-03, -5.196E-03, -6.345E-03, & + -8.061E-03, -1.038E-02, -1.395E-02, & + -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/ + DATA B1_SSSSM_19/ 6.759E-07, 6.246E-07, 5.542E-07, & + 4.953E-07, 4.746E-07, 4.738E-07, & + 4.695E-07, 4.588E-07, 4.354E-07, & + 3.947E-07, 3.461E-07, 3.067E-07, & + 2.646E-07, 2.095E-07, 1.481E-07, & + 9.024E-08, 5.747E-08, 2.384E-08, 6.599E-09/ + DATA B2_SSSSM_19/ 5.977E-07, 5.390E-07, 4.468E-07, & + 3.696E-07, 3.443E-07, 3.433E-07, & + 3.380E-07, 3.249E-07, 2.962E-07, & + 2.483E-07, 1.989E-07, 1.623E-07, & + 1.305E-07, 9.015E-08, 6.111E-08, & + 3.761E-08, 2.903E-08, 2.337E-08, 2.147E-08/ + DATA C1_SSSSM_19/ 8.120E-01, 8.084E-01, 8.016E-01, & + 7.953E-01, 7.929E-01, 7.928E-01, & + 7.923E-01, 7.910E-01, 7.882E-01, & + 7.834E-01, 7.774E-01, 7.725E-01, & + 7.673E-01, 7.604E-01, 7.529E-01, & + 7.458E-01, 7.419E-01, 7.379E-01, 7.360E-01/ + DATA C2_SSSSM_19/ 2.388E-02, 2.392E-02, 2.457E-02, 2.552E-02, & + 2.615E-02, 2.618E-02, 2.631E-02, 2.663E-02, & + 2.735E-02, 2.875E-02, 3.113E-02, 3.330E-02, & + 3.615E-02, 3.997E-02, 4.521E-02, 5.038E-02, & + 5.358E-02, 5.705E-02, 5.887E-02/ +!********************************************************************* +! +! +! +! +! +! +! From here on we look at the optical parameters at 5 wavelengths: +! 443nm, 550, 670, 765 and 865 nm +! le 12 AVRIL 2006 +! + DATA alpha_aers_5wv/ & + ! bc soluble + 7.930,7.930,7.930,7.930,7.930,7.930, & + 7.930,7.930,10.893,12.618,14.550,16.613, & + 7.658,7.658,7.658,7.658,7.658,7.658, & + 7.658,7.658,10.351,11.879,13.642,15.510, & + 7.195,7.195,7.195,7.195,7.195,7.195, & + 7.195,7.195,9.551,10.847,12.381,13.994, & + 6.736,6.736,6.736,6.736,6.736,6.736, & + 6.736,6.736,8.818,9.938,11.283,12.687, & + 6.277,6.277,6.277,6.277,6.277,6.277, & + 6.277,6.277,8.123,9.094,10.275,11.501, & + ! pom soluble + 6.676,6.676,6.676,6.676,6.710,6.934, & + 7.141,7.569,8.034,8.529,9.456,10.511, & + 5.109,5.109,5.109,5.109,5.189,5.535, & + 5.960,6.852,8.008,9.712,12.897,19.676, & + 3.718,3.718,3.718,3.718,3.779,4.042, & + 4.364,5.052,5.956,7.314,9.896,15.688, & + 2.849,2.849,2.849,2.849,2.897,3.107, & + 3.365,3.916,4.649,5.760,7.900,12.863, & + 2.229,2.229,2.229,2.229,2.268,2.437, & + 2.645,3.095,3.692,4.608,6.391,10.633, & + ! Sulfate (Accumulation) + 5.751,6.215,6.690,7.024,7.599,8.195, & + 9.156,10.355,12.660,14.823,18.908,24.508, & + 4.320,4.675,5.052,5.375,5.787,6.274, & + 7.066,8.083,10.088,12.003,15.697,21.133, & + 3.079,3.351,3.639,3.886,4.205,4.584, & + 5.206,6.019,7.648,9.234,12.391,17.220, & + 2.336,2.552,2.781,2.979,3.236,3.540, & + 4.046,4.711,6.056,7.388,10.093,14.313, & + 1.777,1.949,2.134,2.292,2.503,2.751, & + 3.166,3.712,4.828,5.949,8.264,11.922, & + ! Sulfate (Coarse) + 5.751,6.215,6.690,7.024,7.599,8.195, & + 9.156,10.355,12.660,14.823,18.908,24.508, & + 4.320,4.675,5.052,5.375,5.787,6.274, & + 7.066,8.083,10.088,12.003,15.697,21.133, & + 3.079,3.351,3.639,3.886,4.205,4.584, & + 5.206,6.019,7.648,9.234,12.391,17.220, & + 2.336,2.552,2.781,2.979,3.236,3.540, & + 4.046,4.711,6.056,7.388,10.093,14.313, & + 1.777,1.949,2.134,2.292,2.503,2.751, & + 3.166,3.712,4.828,5.949,8.264,11.922, & + ! Seasalt soluble super_coarse (computed below for 550nm) + 0.50,0.90,1.05,1.21,1.40,2.41, & + 2.66,3.11,3.88,4.52,5.69,8.84, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.52,0.93,1.08,1.24,1.43,2.47, & + 2.73,3.20,3.99,4.64,5.84,9.04, & + 0.52,0.93,1.09,1.25,1.44,2.50, & + 2.76,3.23,4.03,4.68,5.89,9.14, & + 0.52,0.94,1.09,1.26,1.45,2.51, & + 2.78,3.25,4.06,4.72,5.94,9.22, & + ! seasalt soluble coarse (computed below for 550nm) + 0.50,0.90,1.05,1.21,1.40,2.41, & + 2.66,3.11,3.88,4.52,5.69,8.84, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.52,0.93,1.08,1.24,1.43,2.47, & + 2.73,3.20,3.99,4.64,5.84,9.04, & + 0.52,0.93,1.09,1.25,1.44,2.50, & + 2.76,3.23,4.03,4.68,5.89,9.14, & + 0.52,0.94,1.09,1.26,1.45,2.51, & + 2.78,3.25,4.06,4.72,5.94,9.22, & + ! seasalt soluble accumulation (computed below for 550nm) + 4.28, 7.17, 8.44, 9.85,11.60,22.44, & + 25.34,30.54,39.38,46.52,59.33,91.77, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 2.48, 4.22, 5.02, 5.94, 7.11,15.29, & + 17.70,22.31,30.73,38.06,52.15,90.59, & + 1.90, 3.29, 3.94, 4.69, 5.65, 12.58, & + 14.68,18.77,26.41,33.25,46.77,85.50, & + 1.47, 2.59, 3.12, 3.74, 4.54, 10.42, & + 12.24,15.82,22.66,28.91,41.54,79.33/ + + DATA alpha_aeri_5wv/ & + ! dust insoluble + 0.759, 0.770, 0.775, 0.775, 0.772, & + !!jb bc insoluble + 11.536,10.033, 8.422, 7.234, 6.270, & + ! pom insoluble + 5.042, 3.101, 1.890, 1.294, 0.934/ + ! + DATA cg_aers_5wv/ & + ! bc soluble + .651, .651, .651, .651, .651, .651, & + .651, .651, .738, .764, .785, .800, & + .597, .597, .597, .597, .597, .597, & + .597, .597, .695, .725, .751, .770, & + .543, .543, .543, .543, .543, .543, & + .543, .543, .650, .684, .714, .736, & + .504, .504, .504, .504, .504, .504, & + .504, .504, .614, .651, .683, .708, & + .469, .469, .469, .469, .469, .469, & + .469, .469, .582, .620, .655, .681, & + ! pom soluble + .679, .679, .679, .679, .683, .691, & + .703, .720, .736, .751, .766, .784, & + .656, .656, .656, .656, .659, .669, & + .681, .699, .717, .735, .750, .779, & + .623, .623, .623, .623, .627, .637, & + .649, .668, .688, .709, .734, .762, & + .592, .592, .592, .592, .595, .605, & + .618, .639, .660, .682, .711, .743, & + .561, .561, .561, .561, .565, .575, & + .588, .609, .632, .656, .688, .724, & + ! Accumulation sulfate + .671, .684, .697, .704, .714, .723, & + .734, .746, .762, .771, .781, .789, & + .653, .666, .678, .687, .697, .707, & + .719, .732, .751, .762, .775, .789, & + .622, .635, .648, .657, .667, .678, & + .691, .705, .728, .741, .758, .777, & + .591, .604, .617, .627, .638, .650, & + .664, .679, .704, .719, .739, .761, & + .560, .574, .587, .597, .609, .621, & + .637, .653, .680, .697, .719, .745, & + ! Coarse sulfate + .671, .684, .697, .704, .714, .723, & + .734, .746, .762, .771, .781, .789, & + .653, .666, .678, .687, .697, .707, & + .719, .732, .751, .762, .775, .789, & + .622, .635, .648, .657, .667, .678, & + .691, .705, .728, .741, .758, .777, & + .591, .604, .617, .627, .638, .650, & + .664, .679, .704, .719, .739, .761, & + .560, .574, .587, .597, .609, .621, & + .637, .653, .680, .697, .719, .745, & + ! For super coarse seasalt (computed below for 550nm!) + 0.730,0.753,0.760,0.766,0.772,0.793, & + 0.797,0.802,0.809,0.813,0.820,0.830, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.721,0.744,0.750,0.756,0.762,0.784, & + 0.787,0.793,0.800,0.804,0.811,0.822, & + 0.717,0.741,0.747,0.753,0.759,0.780, & + 0.784,0.789,0.795,0.800,0.806,0.817, & + 0.715,0.739,0.745,0.751,0.757,0.777, & + 0.781,0.786,0.793,0.797,0.803,0.814, & + ! For coarse-soluble seasalt (computed below for 550nm!) + 0.730,0.753,0.760,0.766,0.772,0.793, & + 0.797,0.802,0.809,0.813,0.820,0.830, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.721,0.744,0.750,0.756,0.762,0.784, & + 0.787,0.793,0.800,0.804,0.811,0.822, & + 0.717,0.741,0.747,0.753,0.759,0.780, & + 0.784,0.789,0.795,0.800,0.806,0.817, & + 0.715,0.739,0.745,0.751,0.757,0.777, & + 0.781,0.786,0.793,0.797,0.803,0.814, & + ! accumulation-seasalt soluble (computed below for 550nm!) + 0.698,0.722,0.729,0.736,0.743,0.765, & + 0.768,0.773,0.777,0.779,0.781,0.779, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.000,0.000,0.000,0.000,0.000,0.000, & + 0.658,0.691,0.701,0.710,0.720,0.756, & + 0.763,0.771,0.782,0.788,0.795,0.801, & + 0.632,0.668,0.679,0.690,0.701,0.743, & + 0.750,0.762,0.775,0.783,0.792,0.804, & + 0.605,0.644,0.656,0.669,0.681,0.729, & + 0.737,0.750,0.765,0.775,0.787,0.803/ + ! + + DATA cg_aeri_5wv/& + ! dust insoluble + 0.714, 0.697, 0.688, 0.683, 0.679, & + ! bc insoluble + 0.511, 0.445, 0.384, 0.342, 0.307, & + !c pom insoluble + 0.596, 0.536, 0.466, 0.409, 0.359/ + ! + DATA piz_aers_5wv/& + ! bc soluble + .445, .445, .445, .445, .445, .445, & + .445, .445, .470, .487, .508, .531, & + .442, .442, .442, .442, .442, .442, & + .442, .442, .462, .481, .506, .533, & + .427, .427, .427, .427, .427, .427, & + .427, .427, .449, .470, .497, .526, & + .413, .413, .413, .413, .413, .413, & + .413, .413, .437, .458, .486, .516, & + .399, .399, .399, .399, .399, .399, & + .399, .399, .423, .445, .473, .506, & + ! pom soluble + .975, .975, .975, .975, .975, .977, & + .979, .982, .984, .987, .990, .994, & + .972, .972, .972, .972, .973, .974, & + .977, .980, .983, .986, .989, .993, & + .963, .963, .963, .963, .964, .966, & + .969, .974, .977, .982, .986, .991, & + .955, .955, .955, .955, .955, .958, & + .962, .967, .972, .977, .983, .989, & + .944, .944, .944, .944, .944, .948, & + .952, .959, .962, .972, .979, .987, & + ! sulfate soluble accumulation + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! sulfate soluble coarse + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! seasalt super coarse (computed below for 550nm) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! seasalt coarse (computed below for 550nm) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + ! seasalt soluble accumulation (computed below for 550nm) + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000, & + 1.000,1.000,1.000,1.000,1.000,1.000/ + + ! + DATA piz_aeri_5wv/& + ! dust insoluble + 0.944, 0.970, 0.977, 0.982, 0.987, & + ! bc insoluble + 0.415, 0.387, 0.355, 0.328, 0.301, & + ! pom insoluble + 0.972, 0.963, 0.943, 0.923, 0.897/ + +! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model + IF (firstcall) THEN + firstcall=.FALSE. +! Allocation + IF (.NOT. ALLOCATED(A1_ASSSM)) THEN + ALLOCATE(A1_ASSSM(klev),A2_ASSSM(klev), A3_ASSSM(klev),& + B1_ASSSM(klev), B2_ASSSM(klev), C1_ASSSM(klev), C2_ASSSM(klev),& + A1_CSSSM(klev), A2_CSSSM(klev), A3_CSSSM(klev),& + B1_CSSSM(klev), B2_CSSSM(klev), C1_CSSSM(klev), C2_CSSSM(klev),& + A1_SSSSM(klev), A2_SSSSM(klev), A3_SSSSM(klev),& + B1_SSSSM(klev), B2_SSSSM(klev), C1_SSSSM(klev), C2_SSSSM(klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('aeropt_5mw', 'pb in allocation 1',1) + END IF + +!Accumulation mode + CALL pres2lev(A1_ASSSM_19, A1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_ASSSM_19, A2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_ASSSM_19, A3_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_ASSSM_19, B1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_ASSSM_19, B2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_ASSSM_19, C1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_ASSSM_19, C2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) +!Coarse mode + CALL pres2lev(A1_CSSSM_19, A1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_CSSSM_19, A2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_CSSSM_19, A3_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_CSSSM_19, B1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_CSSSM_19, B2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_CSSSM_19, C1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_CSSSM_19, C2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) +!Super coarse mode + CALL pres2lev(A1_SSSSM_19, A1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A2_SSSSM_19, A2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(A3_SSSSM_19, A3_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B1_SSSSM_19, B1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(B2_SSSSM_19, B2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C1_SSSSM_19, C1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + CALL pres2lev(C2_SSSSM_19, C2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.) + + END IF ! firstcall + + + ! Initialisations + ai(:) = 0. + tausum(:,:,:) = 0. + + + DO k=1, klev + DO i=1, klon +! IF (t_seri(i,k).EQ.0) stop 'stop aeropt_5wv T ' +! IF (pplay(i,k).EQ.0) stop 'stop aeropt_5wv p ' + zrho=pplay(i,k)/t_seri(i,k)/RD ! kg/m3 + dh(i,k)=pdel(i,k)/(gravit*zrho) +!CDIR UNROLL=naero_spc + mass_temp(i,k,:) = m_allaer(i,k,:) / zrho / 1.e+9 + zdp1(i,k)=pdel(i,k)/(gravit*delt) ! air mass auxiliary variable --> zdp1 [kg/(m^2 *s)] + + ENDDO + ENDDO + + + IF (flag_aerosol .EQ. 1) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_CSSO4M + ELSEIF (flag_aerosol .EQ. 2) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASBCM + aerosol_name(2) = id_AIBCM + ELSEIF (flag_aerosol .EQ. 3) THEN + nb_aer = 2 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASPOMM + aerosol_name(2) = id_AIPOMM + ELSEIF (flag_aerosol .EQ. 4) THEN + nb_aer = 3 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CSSSM + aerosol_name(2) = id_SSSSM + aerosol_name(3) = id_ASSSM + ELSEIF (flag_aerosol .EQ. 5) THEN + nb_aer = 1 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_CIDUSTM + ELSEIF (flag_aerosol .EQ. 6) THEN + nb_aer = 10 + ALLOCATE (aerosol_name(nb_aer)) + aerosol_name(1) = id_ASSO4M + aerosol_name(2) = id_ASBCM + aerosol_name(3) = id_AIBCM + aerosol_name(4) = id_ASPOMM + aerosol_name(5) = id_AIPOMM + aerosol_name(6) = id_CSSSM + aerosol_name(7) = id_SSSSM + aerosol_name(8) = id_ASSSM + aerosol_name(9) = id_CIDUSTM + aerosol_name(10) = id_CSSO4M + ENDIF + + ! + ! loop over modes, use of precalculated nmd and corresponding sigma + ! loop over wavelengths + ! for each mass species in mode + ! interpolate from Sext to retrieve Sext_at_gridpoint_per_species + ! compute optical_thickness_at_gridpoint_per_species + + + ! + ! Calculations that need to be done since we are not in the subroutines INCA + ! + +!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) +!CDIR NOVECTOR + DO n=1,nbre_RH-1 + fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n)) + ENDDO + + DO k=1, KLEV +!CDIR ON_ADB(RH_tab) +!CDIR ON_ADB(fact_RH) + DO i=1, KLON + rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX) + RH_num(i,k) = INT( rh(i,k)/10. + 1.) + IF (rh(i,k).GT.85.) RH_num(i,k)=10 + IF (rh(i,k).GT.90.) RH_num(i,k)=11 + DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k)) + ENDDO + ENDDO + +!CDIR SHORTLOOP + used_tau(:)=.FALSE. + + DO m=1,nb_aer ! tau is only computed for each mass + fac=1.0 + IF (aerosol_name(m).EQ.id_ASBCM) THEN + soluble=.TRUE. + spsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASPOMM) THEN + soluble=.TRUE. + spsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_ASSO4M) THEN + soluble=.TRUE. + spsol=3 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_CSSO4M) THEN + soluble=.TRUE. + spsol=4 + spss=0 + fac=1.375 ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD + ELSEIF (aerosol_name(m).EQ.id_SSSSM) THEN + soluble=.TRUE. + spsol=5 + spss=3 + ELSEIF (aerosol_name(m).EQ.id_CSSSM) THEN + soluble=.TRUE. + spsol=6 + spss=2 + ELSEIF (aerosol_name(m).EQ.id_ASSSM) THEN + soluble=.TRUE. + spsol=7 + spss=1 + ELSEIF (aerosol_name(m).EQ.id_CIDUSTM) THEN + soluble=.FALSE. + spinsol=1 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIBCM) THEN + soluble=.FALSE. + spinsol=2 + spss=0 + ELSEIF (aerosol_name(m).EQ.id_AIPOMM) THEN + soluble=.FALSE. + spinsol=3 + spss=0 + ELSE + CYCLE + ENDIF + +!Bug 21 12 10 AI +! used_tau(spsol)=.TRUE. + IF (soluble) then + used_tau(spsol)=.TRUE. + ELSE + used_tau(naero_soluble+spinsol)=.TRUE. + ENDIF + + DO la=1,las + + IF (soluble) THEN + + IF((la.EQ.2).AND.(spss.NE.0)) THEN !la=2 corresponds to 550 nm + IF (spss.EQ.1) THEN !accumulation mode + DO k=1, KLEV +!CDIR ON_ADB(A1_ASSSM) +!CDIR ON_ADB(A2_ASSSM) +!CDIR ON_ADB(A3_ASSSM) + DO i=1, KLON + H=rh(i,k)/100 + tau_ae5wv_int=A1_ASSSM(k)+A2_ASSSM(k)*H+A3_ASSSM(k)/(H-1.05) + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.2) THEN !coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_CSSSM) +!CDIR ON_ADB(A2_CSSSM) +!CDIR ON_ADB(A3_CSSSM) + DO i=1, KLON + H=rh(i,k)/100 + tau_ae5wv_int=A1_CSSSM(k)+A2_CSSSM(k)*H+A3_CSSSM(k)/(H-1.05) + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol) = tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + IF (spss.EQ.3) THEN !super coarse mode + DO k=1, KLEV +!CDIR ON_ADB(A1_SSSSM) +!CDIR ON_ADB(A2_SSSSM) +!CDIR ON_ADB(A3_SSSSM) + DO i=1, KLON + H=rh(i,k)/100 + tau_ae5wv_int=A1_SSSSM(k)+A2_SSSSM(k)*H+A3_SSSSM(k)/(H-1.05) + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + ELSE + DO k=1, KLEV +!CDIR ON_ADB(alpha_aers_5wv) + DO i=1, KLON + tau_ae5wv_int = alpha_aers_5wv(RH_num(i,k),la,spsol)+DELTA(i,k)* & + (alpha_aers_5wv(RH_num(i,k)+1,la,spsol) - & + alpha_aers_5wv(RH_num(i,k),la,spsol)) + + tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k) & + *tau_ae5wv_int*delt*fac + tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol) + ENDDO + ENDDO + ENDIF + + ELSE ! For insoluble aerosol + DO k=1, KLEV +!CDIR ON_ADB(alpha_aeri_5wv) + DO i=1, KLON + tau_ae5wv_int = alpha_aeri_5wv(la,spinsol) + tau(i,k,la,naero_soluble+spinsol) = mass_temp(i,k,naero_soluble+spinsol)*1000.*zdp1(i,k)* & + tau_ae5wv_int*delt*fac + tausum(i,la,naero_soluble+spinsol)= tausum(i,la,naero_soluble+spinsol) & + +tau(i,k,la,naero_soluble+spinsol) + ENDDO + ENDDO + ENDIF + ENDDO ! boucle sur les longueurs d'onde + ENDDO ! Boucle sur les masses de traceurs + + DO m=1,naero_spc + IF (.NOT.used_tau(m)) tau(:,:,:,m)=0. + ENDDO +! +! +! taue670(:) = SUM(tausum(:,la670,:),dim=2) +! taue865(:) = SUM(tausum(:,la865,:),dim=2) +! +! DO i=1, klon +! ai(i)=-LOG(MAX(taue670(i),0.0001)/ & +! MAX(taue865(i),0.0001))/LOG(670./865.) +! ENDDO + + DO i=1, klon + od550aer(i)=0. + DO m=1,naero_spc + od550aer(i)=od550aer(i)+tausum(i,2,m) + END DO + END DO + DO i=1, klon + od865aer(i)=0. + DO m=1,naero_spc + od865aer(i)=od865aer(i)+tausum(i,5,m) + END DO + END DO + DO i=1, klon + DO k=1, KLEV + ec550aer(i,k)=0. + DO m=1,naero_spc + ec550aer(i,k)=ec550aer(i,k)+tau(i,k,2,m)/dh(i,k) + END DO + END DO + END DO + + od550lt1aer(:)=tausum(:,2,id_ASSO4M)+tausum(:,2,id_ASBCM)+tausum(:,2,id_AIBCM)+ & + tausum(:,2,id_ASPOMM)+tausum(:,2,id_AIPOMM)+tausum(:,2,id_ASSSM)+ & + 0.03*tausum(:,2,id_CSSSM)+0.4*tausum(:,2,id_CIDUSTM) + + + + DEALLOCATE(aerosol_name) + +END SUBROUTINE AEROPT_5WV Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ajsec.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ajsec.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ajsec.F (revision 1634) @@ -0,0 +1,403 @@ +! +! $Header$ +! + SUBROUTINE ajsec(paprs, pplay, t,q,limbas,d_t,d_q) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement sec (adaptation du GCM du LMD) +c====================================================================== +c Arguments: +c t-------input-R- Temperature +c +c d_t-----output-R-Incrementation de la temperature +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev), q(klon,klev) + REAL d_t(klon,klev), d_q(klon,klev) +c + INTEGER limbas(klon), limhau ! les couches a ajuster +c + LOGICAL mixq +ccc PARAMETER (mixq=.TRUE.) + PARAMETER (mixq=.FALSE.) +c + REAL zh(klon,klev) + REAL zho(klon,klev) + REAL zq(klon,klev) + REAL zpk(klon,klev) + REAL zpkdp(klon,klev) + REAL hm, sm, qm + LOGICAL modif(klon), down + INTEGER i, k, k1, k2 +c +c Initialisation: +c +cym + limhau=klev + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO +c------------------------------------- detection des profils a modifier + DO k = 1, limhau + DO i = 1, klon + zpk(i,k) = pplay(i,k)**RKAPPA + zh(i,k) = RCPD * t(i,k)/ zpk(i,k) + zho(i,k) = zh(i,k) + zq(i,k) = q(i,k) + ENDDO + ENDDO +c + DO k = 1, limhau + DO i = 1, klon + zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1)) + ENDDO + ENDDO +c + DO i = 1, klon + modif(i) = .FALSE. + ENDDO + DO k = 2, limhau + DO i = 1, klon + IF (.NOT.modif(i).and.k-1>limbas(i)) THEN + IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE. + ENDIF + ENDDO + ENDDO +c------------------------------------- correction des profils instables + DO 1080 i = 1, klon + IF (modif(i)) THEN + k2 = limbas(i) + 8000 CONTINUE + k2 = k2 + 1 + IF (k2 .GT. limhau) goto 8001 + IF (zh(i,k2) .LT. zh(i,k2-1)) THEN + k1 = k2 - 1 + k = k1 + sm = zpkdp(i,k2) + hm = zh(i,k2) + qm = zq(i,k2) + 8020 CONTINUE + sm = sm +zpkdp(i,k) + hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm + qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm + down = .FALSE. + IF (k1 .ne. limbas(i)) THEN + IF (hm .LT. zh(i,k1-1)) down = .TRUE. + ENDIF + IF (down) THEN + k1 = k1 - 1 + k = k1 + ELSE + IF ((k2 .EQ. limhau)) GOTO 8021 + IF ((zh(i,k2+1).GE.hm)) GOTO 8021 + k2 = k2 + 1 + k = k2 + ENDIF + GOTO 8020 + 8021 CONTINUE +c------------ nouveau profil : constant (valeur moyenne) + DO k = k1, k2 + zh(i,k) = hm + zq(i,k) = qm + ENDDO + k2 = k2 + 1 + ENDIF + GOTO 8000 + 8001 CONTINUE + ENDIF + 1080 CONTINUE +c + DO k = 1, limhau + DO i = 1, klon + d_t(i,k) = (zh(i,k)-zho(i,k))*zpk(i,k)/RCPD + d_q(i,k) = zq(i,k) - q(i,k) + ENDDO + ENDDO +c +! FH : les d_q et d_t sont maintenant calcules de facon a valoir +! effectivement 0. si on ne fait rien. +! +! IF (limbas.GT.1) THEN +! DO k = 1, limbas-1 +! DO i = 1, klon +! d_t(i,k) = 0.0 +! d_q(i,k) = 0.0 +! ENDDO +! ENDDO +! ENDIF +c +! IF (limhau.LT.klev) THEN +! DO k = limhau+1, klev +! DO i = 1, klon +! d_t(i,k) = 0.0 +! d_q(i,k) = 0.0 +! ENDDO +! ENDDO +! ENDIF +c + IF (.NOT.mixq) THEN + DO k = 1, klev + DO i = 1, klon + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + RETURN + END + + SUBROUTINE ajsec_convV2(paprs, pplay, t,q, d_t,d_q) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement sec (adaptation du GCM du LMD) +c====================================================================== +c Arguments: +c t-------input-R- Temperature +c +c d_t-----output-R-Incrementation de la temperature +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev), q(klon,klev) + REAL d_t(klon,klev), d_q(klon,klev) +c + INTEGER limbas, limhau ! les couches a ajuster +ccc PARAMETER (limbas=klev-3, limhau=klev) +cym PARAMETER (limbas=1, limhau=klev) +c + LOGICAL mixq +ccc PARAMETER (mixq=.TRUE.) + PARAMETER (mixq=.FALSE.) +c + REAL zh(klon,klev) + REAL zq(klon,klev) + REAL zpk(klon,klev) + REAL zpkdp(klon,klev) + REAL hm, sm, qm + LOGICAL modif(klon), down + INTEGER i, k, k1, k2 +c +c Initialisation: +c +cym + limbas=1 + limhau=klev + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO +c------------------------------------- detection des profils a modifier + DO k = limbas, limhau + DO i = 1, klon + zpk(i,k) = pplay(i,k)**RKAPPA + zh(i,k) = RCPD * t(i,k)/ zpk(i,k) + zq(i,k) = q(i,k) + ENDDO + ENDDO +c + DO k = limbas, limhau + DO i = 1, klon + zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1)) + ENDDO + ENDDO +c + DO i = 1, klon + modif(i) = .FALSE. + ENDDO + DO k = limbas+1, limhau + DO i = 1, klon + IF (.NOT.modif(i)) THEN + IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE. + ENDIF + ENDDO + ENDDO +c------------------------------------- correction des profils instables + DO 1080 i = 1, klon + IF (modif(i)) THEN + k2 = limbas + 8000 CONTINUE + k2 = k2 + 1 + IF (k2 .GT. limhau) goto 8001 + IF (zh(i,k2) .LT. zh(i,k2-1)) THEN + k1 = k2 - 1 + k = k1 + sm = zpkdp(i,k2) + hm = zh(i,k2) + qm = zq(i,k2) + 8020 CONTINUE + sm = sm +zpkdp(i,k) + hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm + qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm + down = .FALSE. + IF (k1 .ne. limbas) THEN + IF (hm .LT. zh(i,k1-1)) down = .TRUE. + ENDIF + IF (down) THEN + k1 = k1 - 1 + k = k1 + ELSE + IF ((k2 .EQ. limhau)) GOTO 8021 + IF ((zh(i,k2+1).GE.hm)) GOTO 8021 + k2 = k2 + 1 + k = k2 + ENDIF + GOTO 8020 + 8021 CONTINUE +c------------ nouveau profil : constant (valeur moyenne) + DO k = k1, k2 + zh(i,k) = hm + zq(i,k) = qm + ENDDO + k2 = k2 + 1 + ENDIF + GOTO 8000 + 8001 CONTINUE + ENDIF + 1080 CONTINUE +c + DO k = limbas, limhau + DO i = 1, klon + d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k) + d_q(i,k) = zq(i,k) - q(i,k) + ENDDO + ENDDO +c + IF (limbas.GT.1) THEN + DO k = 1, limbas-1 + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + IF (limhau.LT.klev) THEN + DO k = limhau+1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + IF (.NOT.mixq) THEN + DO k = 1, klev + DO i = 1, klon + d_q(i,k) = 0.0 + ENDDO + ENDDO + ENDIF +c + RETURN + END + SUBROUTINE ajsec_old(paprs, pplay, t, d_t) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement sec (adaptation du GCM du LMD) +c====================================================================== +c Arguments: +c t-------input-R- Temperature +c +c d_t-----output-R-Incrementation de la temperature +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) + REAL d_t(klon,klev) +c + REAL local_h(klon,klev) + REAL hm, sm + LOGICAL modif(klon), down + INTEGER i, l, l1, l2 +c------------------------------------- detection des profils a modifier + DO i = 1, klon + modif(i) = .false. + ENDDO +c + DO l = 1, klev + DO i = 1, klon + local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA) + ENDDO + ENDDO +c + DO l = 2, klev + DO i = 1, klon + IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN + modif(i) = .true. + ELSE + modif(i) = modif(i) + ENDIF + ENDDO + ENDDO +c------------------------------------- correction des profils instables + do 1080 i = 1, klon + if (modif(i)) then + l2 = 1 + 8000 continue + l2 = l2 + 1 + if (l2 .gt. klev) goto 8001 + if (local_h(i, l2) .lt. local_h(i, l2-1)) then + l1 = l2 - 1 + l = l1 + sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1)) + hm = local_h(i, l2) + 8020 continue + sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1)) + hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1)) + . * (local_h(i, l) - hm) / sm + down = .false. + if (l1 .ne. 1) then + if (hm .lt. local_h(i, l1-1)) then + down = .true. + end if + end if + if (down) then + l1 = l1 - 1 + l = l1 + else + if ((l2 .eq. klev)) GOTO 8021 + IF ((local_h(i, l2+1).ge.hm)) goto 8021 + l2 = l2 + 1 + l = l2 + end if + go to 8020 + 8021 continue +c------------ nouveau profil : constant (valeur moyenne) + do 1100 l = l1, l2 + local_h(i, l) = hm + 1100 continue + l2 = l2 + 1 + end if + go to 8000 + 8001 continue + end if + 1080 continue +c + DO l = 1, klev + DO i = 1, klon + d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/albedo.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/albedo.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/albedo.F (revision 1634) @@ -0,0 +1,191 @@ +! +! $Id$ +! +c +c + SUBROUTINE alboc(rjour,rlat,albedo) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD) +c Date: le 16 mars 1995 +c Objet: Calculer l'albedo sur l'ocean +c Methode: Integrer numeriquement l'albedo pendant une journee +c +c Arguments; +c rjour (in,R) : jour dans l'annee (a compter du 1 janvier) +c rlat (in,R) : latitude en degre +c albedo (out,R): albedo obtenu (de 0 a 1) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "clesphys.h" +c +c fmagic -> clesphys.h/.inc +c REAL fmagic ! un facteur magique pour regler l'albedo +ccc PARAMETER (fmagic=0.7) +cccIM => a remplacer +c PARAMETER (fmagic=1.32) +c PARAMETER (fmagic=1.0) +c PARAMETER (fmagic=0.7) + INTEGER npts ! il controle la precision de l'integration + PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes +c + REAL rlat(klon), rjour, albedo(klon) + REAL zdist, zlonsun, zpi, zdeclin + REAL rmu,alb, srmu, salb, fauxo, aa, bb + INTEGER i, k +cccIM + LOGICAL ancien_albedo + PARAMETER(ancien_albedo=.FALSE.) +c SAVE albedo +c + IF ( ancien_albedo ) THEN +c + zpi = 4. * ATAN(1.) +c +c Calculer la longitude vraie de l'orbite terrestre: + CALL orbite(rjour,zlonsun,zdist) +c +c Calculer la declinaison du soleil (qui varie entre + et - R_incl): + zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0)) +c + DO 999 i=1,klon + aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin) + bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin) +c +c Midi local (angle du temps = 0.0): + rmu = aa + bb * COS(0.0) + rmu = MAX(0.0, rmu) + fauxo = (1.47-ACOS(rmu))/.15 + alb = 0.03+0.630/(1.+fauxo*fauxo) + srmu = rmu + salb = alb * rmu +c +c Faire l'integration numerique de midi a minuit (le facteur 2 +c prend en compte l'autre moitie de la journee): + DO k = 1, npts + rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi) + rmu = MAX(0.0, rmu) + fauxo = (1.47-ACOS(rmu))/.15 + alb = 0.03+0.630/(1.+fauxo*fauxo) + srmu = srmu + rmu * 2.0 + salb = salb + alb*rmu * 2.0 + ENDDO + IF (srmu .NE. 0.0) THEN + albedo(i) = salb / srmu * fmagic+pmagic + ELSE ! nuit polaire (on peut prendre une valeur quelconque) + albedo(i) = fmagic + ENDIF + 999 CONTINUE +c +c nouvel albedo +c + ELSE +c + zpi = 4. * ATAN(1.) +c +c Calculer la longitude vraie de l'orbite terrestre: + CALL orbite(rjour,zlonsun,zdist) +c +c Calculer la declinaison du soleil (qui varie entre + et - R_incl): + zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0)) +c + DO 1999 i=1,klon + aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin) + bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin) +c +c Midi local (angle du temps = 0.0): + rmu = aa + bb * COS(0.0) + rmu = MAX(0.0, rmu) +cIM cf. PB alb = 0.058/(rmu + 0.30) +c alb = 0.058/(rmu + 0.30) * 1.5 + alb = 0.058/(rmu + 0.30) * 1.2 +c alb = 0.058/(rmu + 0.30) * 1.3 + srmu = rmu + salb = alb * rmu +c +c Faire l'integration numerique de midi a minuit (le facteur 2 +c prend en compte l'autre moitie de la journee): + DO k = 1, npts + rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi) + rmu = MAX(0.0, rmu) +cIM cf. PB alb = 0.058/(rmu + 0.30) +c alb = 0.058/(rmu + 0.30) * 1.5 + alb = 0.058/(rmu + 0.30) * 1.2 +c alb = 0.058/(rmu + 0.30) * 1.3 + srmu = srmu + rmu * 2.0 + salb = salb + alb*rmu * 2.0 + ENDDO + IF (srmu .NE. 0.0) THEN + albedo(i) = salb / srmu * fmagic+pmagic + ELSE ! nuit polaire (on peut prendre une valeur quelconque) + albedo(i) = fmagic + ENDIF +1999 CONTINUE + ENDIF + RETURN + END +c===================================================================== + SUBROUTINE alboc_cd(rmu0,albedo) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c date: 19940624 +c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen +c Formule due a Larson and Barkstrom (1977) Proc. of the symposium +C on radiation in the atmosphere, 19-28 August 1976, science Press, +C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume. +c +c Arguments +c rmu0 (in): cosinus de l'angle solaire zenithal +c albedo (out): albedo de surface de l'ocean +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "clesphys.h" + REAL rmu0(klon), albedo(klon) +c +c REAL fmagic ! un facteur magique pour regler l'albedo +ccc PARAMETER (fmagic=0.7) +cccIM => a remplacer +c PARAMETER (fmagic=1.32) +c PARAMETER (fmagic=1.0) +c PARAMETER (fmagic=0.7) +c + REAL fauxo + INTEGER i +cccIM + LOGICAL ancien_albedo + PARAMETER(ancien_albedo=.FALSE.) +c SAVE albedo +c + IF ( ancien_albedo ) THEN +c + DO i = 1, klon +c + rmu0(i) = MAX(rmu0(i),0.0) +c + fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15 + albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))+pmagic + albedo(i) = MAX(MIN(albedo(i),0.60),0.04) + ENDDO +c +c nouvel albedo +c + ELSE +c + DO i = 1, klon + rmu0(i) = MAX(rmu0(i),0.0) +cIM:orig albedo(i) = 0.058/(rmu0(i) + 0.30) + albedo(i) = fmagic * 0.058/(rmu0(i) + 0.30)+pmagic + albedo(i) = MAX(MIN(albedo(i),0.60),0.04) + ENDDO +c + ENDIF +c + RETURN + END +c======================================================================== Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/albsno.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/albsno.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/albsno.F90 (revision 1634) @@ -0,0 +1,55 @@ +! +! $Header$ +! +SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow) + + IMPLICIT NONE + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: klon, knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: precip_snow + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: alb_neig_grid + +! Local variables +!**************************************************************************************** + INTEGER :: i, nv + INTEGER, PARAMETER :: nvm = 8 + REAL :: as + REAL, DIMENSION(klon,nvm) :: veget + REAL, DIMENSION(nvm),SAVE :: init, decay + !$OMP THREADPRIVATE(init, decay) + + DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./ + DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./ +!**************************************************************************************** + + veget = 0. + veget(:,1) = 1. ! desert partout + DO i = 1, knon + alb_neig_grid(i) = 0.0 + ENDDO + DO nv = 1, nvm + DO i = 1, knon + as = init(nv)+decay(nv)*EXP(-agesno(i)/5.) + alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as + ENDDO + ENDDO + + +! modilation en fonction de l'age de la neige + DO i = 1, knon + agesno(i) = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)& + & * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3) + agesno(i) = MAX(agesno(i),0.0) + ENDDO + +END SUBROUTINE albsno Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/atm2geo.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/atm2geo.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/atm2geo.F90 (revision 1634) @@ -0,0 +1,48 @@ +! +! $Header$ +! +SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz ) + USE dimphy + USE mod_phys_lmdz_para + IMPLICIT NONE + INCLUDE 'dimensions.h' + INCLUDE 'YOMCST.h' +! +! Change wind local atmospheric coordinates to geocentric +! + INTEGER, INTENT (in) :: im, jm + REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn + REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat + REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz + + REAL :: rad + + + rad = rpi / 180.0E0 + + pxx(:,:) = & + - pte(:,:) * SIN(rad * plon(:,:)) & + - ptn(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:)) + + pyy(:,:) = & + + pte(:,:) * COS(rad * plon(:,:)) & + - ptn(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:)) + + pzz(:,:) = & + + ptn(:,:) * COS(rad * plat (:,:)) + +! Value at North Pole + IF (is_north_pole) THEN + pxx(:, 1) = - pte (1, 1) + pyy(:, 1) = - ptn (1, 1) + pzz(:, 1) = pzz(1,1) + ENDIF + +! Value at South Pole + IF (is_south_pole) THEN + pxx(:,jm) = pxx(1,jm) + pyy(:,jm) = pyy(1,jm) + pzz(:,jm) = pzz(1,jm) + ENDIF + +END SUBROUTINE atm2geo Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/buffer_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/buffer_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/buffer_mod.F90 (revision 1634) @@ -0,0 +1,86 @@ +MODULE buffer_mod + +PRIVATE + REAL,PARAMETER :: grow_factor=1.5 + + INTEGER, POINTER, SAVE :: buffer_i(:) + INTEGER,SAVE :: size_buffer_i = 0 +!$OMP THREADPRIVATE(buffer_i,size_buffer_i) + + REAL,POINTER,SAVE :: buffer_r(:) + INTEGER,SAVE :: size_buffer_r = 0 +!$OMP THREADPRIVATE(buffer_r,size_buffer_r) + + LOGICAL,POINTER,SAVE :: buffer_l(:) + INTEGER,SAVE :: size_buffer_l = 0 +!$OMP THREADPRIVATE(buffer_l,size_buffer_l) + + CHARACTER,POINTER,SAVE :: buffer_c(:) + INTEGER,SAVE :: size_buffer_c = 0 +!$OMP THREADPRIVATE(buffer_c,size_buffer_c) + +INTERFACE get_buffer + MODULE PROCEDURE get_buffer_i, get_buffer_r, get_buffer_l, get_buffer_c +END INTERFACE + +PUBLIC :: get_buffer + +CONTAINS + + SUBROUTINE get_buffer_i(buff,buff_size) + IMPLICIT NONE + INTEGER,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_i) THEN + DEALLOCATE(buffer_i) + size_buffer_i=MAX(2,INT(size_buffer_i*grow_factor)) + ALLOCATE(buffer_i(size_buffer_i)) + ENDIF + + buff=>buffer_i + END SUBROUTINE get_buffer_i + + SUBROUTINE get_buffer_r(buff,buff_size) + IMPLICIT NONE + REAL,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_r) THEN + DEALLOCATE(buffer_r) + size_buffer_r=MAX(2,INT(size_buffer_r*grow_factor)) + ALLOCATE(buffer_r(size_buffer_r)) + ENDIF + + buff=>buffer_r + END SUBROUTINE get_buffer_r + + SUBROUTINE get_buffer_l(buff,buff_size) + IMPLICIT NONE + LOGICAL,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_l) THEN + DEALLOCATE(buffer_l) + size_buffer_l=MAX(2,INT(size_buffer_l*grow_factor)) + ALLOCATE(buffer_l(size_buffer_l)) + ENDIF + + buff=>buffer_l + END SUBROUTINE get_buffer_l + + SUBROUTINE get_buffer_c(buff,buff_size) + IMPLICIT NONE + CHARACTER,POINTER :: buff(:) + INTEGER,INTENT(IN) :: buff_size + + IF (buff_size>size_buffer_c) THEN + DEALLOCATE(buffer_c) + size_buffer_c=MAX(2,INT(size_buffer_c*grow_factor)) + ALLOCATE(buffer_c(size_buffer_c)) + ENDIF + + buff=>buffer_c + END SUBROUTINE get_buffer_c + +END MODULE buffer_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calbeta.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calbeta.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calbeta.F90 (revision 1634) @@ -0,0 +1,103 @@ +! +! $Header$ +! +SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, & + vbeta,vcal,vdif) + + USE dimphy + IMPLICIT none +!====================================================================== +! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD) +! date: 19940414 +!====================================================================== +! +! Calculer quelques parametres pour appliquer la couche limite +! ------------------------------------------------------------ + INCLUDE "indicesol.h" + +! Variables d'entrees +!**************************************************************************************** + REAL, INTENT(IN) :: dtime + INTEGER, INTENT(IN) :: indice + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon), INTENT(IN) :: snow + REAL, DIMENSION(klon), INTENT(IN) :: qsol + + +! Variables de sorties +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: vbeta + REAL, DIMENSION(klon), INTENT(OUT) :: vcal + REAL, DIMENSION(klon), INTENT(OUT) :: vdif + +! Variables locales +!**************************************************************************************** + REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer +!cc PARAMETER (tau_gl=86400.0*30.0) + REAL, PARAMETER :: mx_eau_sol=150.0 + REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15) + REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15) + REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15) + + INTEGER :: i + +!**************************************************************************************** + + vbeta(:) = 0.0 + vcal(:) = 0.0 + vdif(:) = 0.0 + + IF (indice.EQ.is_oce) THEN + DO i = 1, knon + vcal(i) = 0.0 + vbeta(i) = 1.0 + vdif(i) = 0.0 + ENDDO + ENDIF + + IF (indice.EQ.is_sic) THEN + DO i = 1, knon + vcal(i) = calice + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = 1.0 + vdif(i) = 1.0/tau_gl +! vdif(i) = calice/tau_gl ! c'etait une erreur + ENDDO + ENDIF + + IF (indice.EQ.is_ter) THEN + DO i = 1, knon + vcal(i) = calsol + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = MIN(2.0*qsol(i)/mx_eau_sol, 1.0) + vdif(i) = 0.0 + ENDDO + ENDIF + + IF (indice.EQ.is_lic) THEN + DO i = 1, knon + vcal(i) = calice + IF (snow(i) .GT. 0.0) vcal(i) = calsno + vbeta(i) = 1.0 + vdif(i) = 0.0 + ENDDO + ENDIF + +END SUBROUTINE calbeta + + + + + + + + + + + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcratqs.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcratqs.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcratqs.F (revision 1634) @@ -0,0 +1,166 @@ +! +! $Header$ +! + SUBROUTINE calcratqs ( flag_ratqs, + I paprs,pplay,q_seri,d_t_con,d_t_ajs + O ,ratqs,zpt_conv) + USE dimphy + IMPLICIT none +c====================================================================== +c +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c +c Objet: Moniteur general de la physique du modele +cAA Modifications quant aux traceurs : +cAA - uniformisation des parametrisations ds phytrac +cAA - stockage des moyennes des champs necessaires +cAA en mode traceur off-line +c====================================================================== +c modif ( P. Le Van , 12/10/98 ) +c +c Arguments: +c +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c presnivs-input_R_pressions approximat. des milieux couches ( en PA) +cym#include "dimensions.h" +cym#include "dimphy.h" + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL d_t_con(klon,klev) + REAL d_t_ajs(klon,klev) + REAL ratqs(klon,klev) + LOGICAL pt_conv(klon,klev) + REAL q_seri(klon,klev) + + logical firstcall + save firstcall + data firstcall/.true./ +c$OMP THREADPRIVATE(firstcall) + + REAL ratqsmin,ratqsmax,zx,epmax + REAL ratqs1,ratqs2,ratqs3,ratqs4 + REAL ratqsc1,ratqsc2,ratqsc3,ratqsc4 + INTEGER i,k + INTEGER flag_ratqs + save ratqsmin,ratqsmax,epmax + save ratqs1,ratqs2,ratqs3,ratqs4 + save ratqsc1,ratqsc2,ratqsc3,ratqsc4 +c$OMP THREADPRIVATE(ratqsmin,ratqsmax,epmax) +c$OMP THREADPRIVATE(ratqs1,ratqs2,ratqs3,ratqs4) +c$OMP THREADPRIVATE(ratqsc1,ratqsc2,ratqsc3,ratqsc4) + real zpt_conv(klon,klev) + + REAL zx_min + PARAMETER (zx_min=1.0) + REAL zx_max + PARAMETER (zx_max=0.1) + + zpt_conv=0. +c +c Appeler le processus de condensation a grande echelle +c et le processus de precipitation +c + if (flag_ratqs.eq.0) then + + ratqsmax=0.01 + ratqsmin=0.3 + + if (firstcall) print*,'RATQS ANCIEN ' + do k=1,klev + do i=1,klon + zx = pplay(i,k)/paprs(i,1) + zx = (zx_max-zx)/(zx_max-zx_min) + zx = MIN(MAX(zx,0.0),1.0) + zx = zx * zx * zx + ratqs(i,k)= zx * (ratqsmax-ratqsmin) + ratqsmin + enddo + enddo + + else + +c On aplique un ratqs "interactif" a toutes les mailles affectees +c par la convection ou se trouvant "sous" une maille affectee. + do i=1,klon + pt_conv(i,klev)=.false. + enddo + do k=klev-1,1,-1 + do i=1,klon + pt_conv(i,k)=pt_conv(i,k+1).or. + s (abs(d_t_con(i,k))+abs(d_t_ajs(i,k))).gt.1.e-8 + if(pt_conv(i,k)) then + zpt_conv(i,k)=1. + else + zpt_conv(i,k)=0. + endif + enddo + enddo + + if (flag_ratqs.eq.1) then + + ratqsmin=0.4 + ratqsmax=0.99 + if (firstcall) print*,'RATQS INTERACTIF ' + do k=1,klev + do i=1,klon + if (pt_conv(i,k)) then + ratqs(i,k)=0.01 + s +1.5*0.25*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k) + ratqs(i,k)=min(ratqs(i,k),ratqsmax) + ratqs(i,k)=max(ratqs(i,k),0.1) + else + ratqs(i,k)=0.01+(ratqsmin-0.01)* + s min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) + endif + enddo + enddo + else if (flag_ratqs.eq.2) then + do k=1,klev + do i=1,klon + ratqs(i,k)=0.001+ + s (q_seri(i,1)-q_seri(i,k))/q_seri(i,k) + if (pt_conv(i,k)) then + ratqs(i,k)=min(ratqs(i,k),ratqsmax) + else + ratqs(i,k)=min(ratqs(i,k),ratqsmin) + endif + enddo + enddo + else + do k=1,klev + do i=1,klon + if (pplay(i,k).ge.95000.) then + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc1 + else + ratqs(i,k)=ratqs1 + endif + else if (pplay(i,k).ge.75000.) then + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc2 + else + ratqs(i,k)=ratqs2 + endif + else if (pplay(i,k).ge.50000.) then + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc3 + else + ratqs(i,k)=ratqs3 + endif + else + if (pt_conv(i,k)) then + ratqs(i,k)=ratqsc4 + else + ratqs(i,k)=ratqs4 + endif + endif + enddo + enddo + endif + + endif + + firstcall=.false. + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_REGDYN.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_REGDYN.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_REGDYN.h (revision 1634) @@ -0,0 +1,22 @@ +c +c $Header$ +c +c calculs statistiques distribution nuage ftion du regime dynamique +c +c Ce calcul doit etre fait a partir de valeurs mensuelles ?? + CALL histo_o500_pctau(nbregdyn,pct_ocean,o500,fq_isccp, + &histoW,nhistoW) +c +c nhistoWt = somme de toutes les nhistoW + DO nreg=1, nbregdyn + DO k = 1, kmaxm1 + DO l = 1, lmaxm1 + DO iw = 1, iwmax + nhistoWt(k,l,iw,nreg)=nhistoWt(k,l,iw,nreg)+ + & nhistoW(k,l,iw,nreg) + ENDDO + ENDDO + ENDDO + ENDDO +c +cIM 190504 END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_STDlev.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_STDlev.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_STDlev.h (revision 1634) @@ -0,0 +1,158 @@ +c +c $Header$ +c +c +cIM on initialise les variables +c + CALL ini_undefSTD(itap,freq_outNMC) +c +cIM on interpole les champs sur les niveaux STD de pression +cIM a chaque pas de temps de la physique +c +c-------------------------------------------------------c +c positionnement de l'argument logique a .false. c +c pour ne pas recalculer deux fois la meme chose ! c +c a cet effet un appel a plevel_new a ete deplace c +c a la fin de la serie d'appels c +c la boucle 'DO k=1, nlevSTD' a ete internalisee c +c dans plevel_new, d'ou la creation de cette routine... c +c-------------------------------------------------------c +c + CALL plevel_new(klon,klev,nlevSTD,.true.,pplay,rlevSTD, + & t_seri,tlevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & u_seri,ulevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & v_seri,vlevSTD) +c + +c + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zphi/RG,philevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & qx(:,:,ivap),qlevSTD) + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_rh*100.,rhlevSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=u_seri(i,l)*v_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,uvSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*q_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,vqSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*t_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,vTSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=omega(i,l)*qx(i,l,ivap) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,wqSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*zphi(i,l)/RG + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,vphiSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=omega(i,l)*t_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,wTSTD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=u_seri(i,l)*u_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,u2STD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=v_seri(i,l)*v_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,v2STD) +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=t_seri(i,l)*t_seri(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,T2STD) + +c + zx_tmp_fi3d(:,:)=wo(:,:,1) * dobson_u * 1e3 / zmasse / rmo3 * rmd + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,O3STD) +c + if (read_climoz == 2) THEN + zx_tmp_fi3d(:,:)=wo(:,:,2) * dobson_u * 1e3 / zmasse / rmo3 * rmd + CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD, + & zx_tmp_fi3d,O3daySTD) + endif +c + DO l=1, klev + DO i=1, klon + zx_tmp_fi3d(i,l)=paprs(i,l) + ENDDO !i + ENDDO !l + CALL plevel_new(klon,klev,nlevSTD,.true.,zx_tmp_fi3d,rlevSTD, + & omega,wlevSTD) +c +cIM on somme les valeurs toutes les freq_calNMC secondes +c + CALL undefSTD(itap,freq_calNMC, read_climoz) +c +cIM on moyenne a la fin du mois ou du jour (toutes les freq_outNMC secondes) +c + CALL moy_undefSTD(itap,freq_outNMC,freq_moyNMC) +c + CALL plevel(klon,klev,.true.,pplay,50000., + & zphi/RG,geo500) + +cIM on interpole a chaque pas de temps le SWup(clr) et SWdn(clr) a 200 hPa +c + CALL plevel(klon,klevp1,.true.,paprs,20000., + $ swdn0,SWdn200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ swdn,SWdn200) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ swup0,SWup200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ swup,SWup200) +c + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwdn0,LWdn200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwdn,LWdn200) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwup0,LWup200clr) + CALL plevel(klon,klevp1,.false.,paprs,20000., + $ lwup,LWup200) +c Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_divers.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_divers.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_divers.h (revision 1634) @@ -0,0 +1,24 @@ +c +c $Header$ +c + +c Initialisations diverses au "debut" du mois + IF(debut) THEN + nday_rain(:)=0. + +c surface terre + paire_ter(:)=0. + DO i=1, klon + IF(pctsrf(i,is_ter).GT.0.) THEN + paire_ter(i)=airephy(i)*pctsrf(i,is_ter) + ENDIF + ENDDO + ENDIF + +cIM Calcul une fois par jour : total_rain, nday_rain + IF(MOD(itap,INT(un_jour/dtime)).EQ.0) THEN + DO i = 1, klon + total_rain(i)=rain_fall(i)+snow_fall(i) + IF(total_rain(i).GT.0.) nday_rain(i)=nday_rain(i)+1. + ENDDO + ENDIF Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_fluxs_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_fluxs_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_fluxs_mod.F90 (revision 1634) @@ -0,0 +1,289 @@ +! +MODULE calcul_fluxs_mod + + +CONTAINS + SUBROUTINE calcul_fluxs( knon, nisurf, dtime, & + tsurf, p1lay, cal, beta, coef1lay, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, & + petAcoef, peqAcoef, petBcoef, peqBcoef, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + + USE dimphy, ONLY : klon + +! Cette routine calcule les fluxs en h et q a l'interface et eventuellement +! une temperature de surface (au cas ou ok_veget = false) +! +! L. Fairhead 4/2000 +! +! input: +! knon nombre de points a traiter +! nisurf surface a traiter +! tsurf temperature de surface +! p1lay pression 1er niveau (milieu de couche) +! cal capacite calorifique du sol +! beta evap reelle +! coef1lay coefficient d'echange +! ps pression au sol +! precip_rain precipitations liquides +! precip_snow precipitations solides +! snow champs hauteur de neige +! runoff runoff en cas de trop plein +! petAcoef coeff. A de la resolution de la CL pour t +! peqAcoef coeff. A de la resolution de la CL pour q +! petBcoef coeff. B de la resolution de la CL pour t +! peqBcoef coeff. B de la resolution de la CL pour q +! radsol rayonnement net aus sol (LW + SW) +! dif_grnd coeff. diffusion vers le sol profond +! +! output: +! tsurf_new temperature au sol +! qsurf humidite de l'air au dessus du sol +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! dflux_s derivee du flux de chaleur sensible / Ts +! dflux_l derivee du flux de chaleur latente / Ts +! + + INCLUDE "YOETHF.h" + INCLUDE "FCTTRE.h" + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon, nisurf + REAL , INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: ps, q1lay + REAL, DIMENSION(klon), INTENT(IN) :: tsurf, p1lay, cal, beta, coef1lay + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow ! pas utiles + REAL, DIMENSION(klon), INTENT(IN) :: radsol, dif_grnd + REAL, DIMENSION(klon), INTENT(IN) :: t1lay, u1lay, v1lay + +! Parametres entree-sorties +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow ! snow pas utile + +! Parametres sorties +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new, evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Variables locales +!**************************************************************************************** + INTEGER :: i + REAL, DIMENSION(klon) :: zx_mh, zx_nh, zx_oh + REAL, DIMENSION(klon) :: zx_mq, zx_nq, zx_oq + REAL, DIMENSION(klon) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef + REAL, DIMENSION(klon) :: zx_sl, zx_k1 + REAL, DIMENSION(klon) :: d_ts + REAL :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh + REAL :: qsat_new, q1_new + REAL, PARAMETER :: t_grnd = 271.35, t_coup = 273.15 + REAL, PARAMETER :: max_eau_sol = 150.0 + CHARACTER (len = 20) :: modname = 'calcul_fluxs' + LOGICAL :: fonte_neige + LOGICAL, SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + +! End definition +!**************************************************************************************** + + IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf + + IF (check) THEN + WRITE(*,*)' radsol (min, max)', & + MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon)) + ENDIF + +! Traitement neige et humidite du sol +!**************************************************************************************** +! +!!$ WRITE(*,*)'test calcul_flux, surface ', nisurf +!!PB test +!!$ if (nisurf == is_oce) then +!!$ snow = 0. +!!$ qsol = max_eau_sol +!!$ else +!!$ where (precip_snow > 0.) snow = snow + (precip_snow * dtime) +!!$ where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime)) +!!$! snow = max(0.0, snow + (precip_snow - evap) * dtime) +!!$ where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime +!!$ endif +!!$ IF (nisurf /= is_ter) qsol = max_eau_sol + + +! +! Initialisation +!**************************************************************************************** + evap = 0. + fluxsens=0. + fluxlat=0. + dflux_s = 0. + dflux_l = 0. +! +! zx_qs = qsat en kg/kg +!**************************************************************************************** + DO i = 1, knon + zx_pkh(i) = (ps(i)/ps(i))**RKAPPA + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i)) + zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i) + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) & + /RLVTT / zx_pkh(i) + ELSE + IF (tsurf(i).LT.t_coup) THEN + zx_qs = qsats(tsurf(i)) / ps(i) + zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT & + / zx_pkh(i) + ELSE + zx_qs = qsatl(tsurf(i)) / ps(i) + zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT & + / zx_pkh(i) + ENDIF + ENDIF + zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh + zx_qsat(i) = zx_qs + zx_coef(i) = coef1lay(i) * & + (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * & + p1lay(i)/(RD*t1lay(i)) + + ENDDO + + +! === Calcul de la temperature de surface === +! zx_sl = chaleur latente d'evaporation ou de sublimation +!**************************************************************************************** + + DO i = 1, knon + zx_sl(i) = RLVTT + IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT + zx_k1(i) = zx_coef(i) + ENDDO + + + DO i = 1, knon +! Q + zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime) + zx_mq(i) = beta(i) * zx_k1(i) * & + (peqAcoef(i) - zx_qsat(i) + & + zx_dq_s_dt(i) * tsurf(i)) & + / zx_oq(i) + zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) & + / zx_oq(i) + +! H + zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime) + zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i) + zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i) + +! Tsurface + tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * & + (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & + + dif_grnd(i) * t_grnd * dtime)/ & + ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( & + zx_nh(i) + zx_sl(i) * zx_nq(i)) & + + dtime * dif_grnd(i)) + +! +! Y'a-t-il fonte de neige? +! +! fonte_neige = (nisurf /= is_oce) .AND. & +! & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) & +! & .AND. (tsurf_new(i) >= RTT) +! if (fonte_neige) tsurf_new(i) = RTT + d_ts(i) = tsurf_new(i) - tsurf(i) +! zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i) +! zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i) + +!== flux_q est le flux de vapeur d'eau: kg/(m**2 s) positive vers bas +!== flux_t est le flux de cpt (energie sensible): j/(m**2 s) + evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) + fluxlat(i) = - evap(i) * zx_sl(i) + fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i) + +! Derives des flux dF/dTs (W m-2 K-1): + dflux_s(i) = zx_nh(i) + dflux_l(i) = (zx_sl(i) * zx_nq(i)) + +! Nouvelle valeure de l'humidite au dessus du sol + qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i) + q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime + qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new +! +! en cas de fonte de neige +! +! if (fonte_neige) then +! bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - & +! & dif_grnd(i) * (tsurf_new(i) - t_grnd) - & +! & RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i)) +! bilan_f = max(0., bilan_f) +! fq_fonte = bilan_f / zx_sl(i) +! snow(i) = max(0., snow(i) - fq_fonte * dtime) +! qsol(i) = qsol(i) + (fq_fonte * dtime) +! endif +!!$ if (nisurf == is_ter) & +!!$ & run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0) +!!$ qsol(i) = min(qsol(i), max_eau_sol) + ENDDO +! +!**************************************************************************************** +! + END SUBROUTINE calcul_fluxs +! +!**************************************************************************************** +! + SUBROUTINE calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdrag_m, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, t1lay, & + flux_u1, flux_v1) + + USE dimphy + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: u0, v0 ! u and v at niveau 0 + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 ! u and v at niveau 1 + REAL, DIMENSION(klon), INTENT(IN) :: cdrag_m ! cdrag pour momentum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: p1lay ! pression 1er niveau (milieu de couche) + REAL, DIMENSION(klon), INTENT(IN) :: t1lay ! temperature +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1 + REAL, DIMENSION(klon), INTENT(OUT) :: flux_v1 + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL :: mod_wind, buf + +!**************************************************************************************** +! Calculate the surface flux +! +!**************************************************************************************** + DO i=1,knon + mod_wind = 1.0 + SQRT((u1(i) - u0(i))**2 + (v1(i)-v0(i))**2) + buf = cdrag_m(i) * mod_wind * p1lay(i)/(RD*t1lay(i)) + flux_u1(i) = (AcoefU(i) - u0(i)) / (1/buf - BcoefU(i)*dtime ) + flux_v1(i) = (AcoefV(i) - v0(i)) / (1/buf - BcoefV(i)*dtime ) + END DO + + END SUBROUTINE calcul_flux_wind +! +!**************************************************************************************** +! +END MODULE calcul_fluxs_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_simulISCCP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_simulISCCP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calcul_simulISCCP.h (revision 1634) @@ -0,0 +1,148 @@ +c +c $Id$ +c +c on appelle le simulateur ISCCP toutes les 3h +c et on fait des sorties 1 fois par jour +c +c ATTENTION : le temps de calcul peut augmenter considerablement ! +c =============================================================== c + DO n=1, napisccp +c + nbapp_isccp=30 !appel toutes les 15h +cIM 170107 isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique + freqin_pdt(n)=ifreq_isccp(n) +c +cIM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee +c + DO i=1, klon + sunlit(i)=1 + IF(rmu0(i).EQ.0.) sunlit(i)=0 + nbsunlit(1,i,n)=REAL(sunlit(i)) + ENDDO +c +cIM calcul tau, emissivite nuages convectifs +c + convfra(:,:)=rnebcon(:,:) + convliq(:,:)=rnebcon(:,:)*clwcon(:,:) +c + CALL newmicro (paprs, pplay,ok_newmicro, + . t_seri, convliq, convfra, dtau_c, dem_c, + . cldh_c, cldl_c, cldm_c, cldt_c, cldq_c, + . flwp_c, fiwp_c, flwc_c, fiwc_c, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) +c +cIM calcul tau, emissivite nuages startiformes +c + CALL newmicro (paprs, pplay,ok_newmicro, + . t_seri, cldliq, cldfra, dtau_s, dem_s, + . cldh_s, cldl_s, cldm_s, cldt_s, cldq_s, + . flwp_s, fiwp_s, flwc_s, fiwc_s, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) +c + cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) +c +cIM inversion des niveaux de pression ==> de haut en bas +c + CALL haut2bas(klon, klev, pplay, pfull) + CALL haut2bas(klon, klev, q_seri, qv) + CALL haut2bas(klon, klev, cldtot, cc) + CALL haut2bas(klon, klev, rnebcon, conv) + CALL haut2bas(klon, klev, dtau_s, dtau_sH2B) + CALL haut2bas(klon, klev, dtau_c, dtau_cH2B) + CALL haut2bas(klon, klev, t_seri, at) + CALL haut2bas(klon, klev, dem_s, dem_sH2B) + CALL haut2bas(klon, klev, dem_c, dem_cH2B) + CALL haut2bas(klon, klevp1, paprs, phalf) +c +cIM: initialisation de seed +c + DO i=1, klon +c + aa=ABS(paprs(i,2)-NINT(paprs(i,2))) + seed_re(i,n)=1000.*aa+1. + seed(i,n)=NINT(seed_re(i,n)) +c + IF(seed(i,n).LT.50) THEN +c print*,'seed<50 avant i seed itap paprs',i, +c . seed(i,n),itap,paprs(i,2) + seed(i,n)=50+seed(i,n)+i+itap + seed_old(i,n)=seed(i,n) +c + IF(itap.GT.1) then + IF(seed(i,n).EQ.seed_old(i,n)) THEN + seed(i,n)=seed(i,n)+10 + seed_old(i,n)=seed(i,n) + ENDIF + ENDIF +c +c print*,'seed<50 apres i seed itap paprs',i, +c . seed(i,n),itap,paprs(i,2) +c + ELSE IF(seed(i,n).EQ.0) THEN + print*,'seed=0 i paprs aa seed_re', + . i,paprs(i,2),aa,seed_re(i,n) + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + ELSE IF(seed(i,n).LT.0) THEN + print*,'seed < 0, i seed itap paprs',i, + . seed(i,n),itap,paprs(i,2) + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + ENDIF +c + ENDDO +c +cIM: pas de debug, debugcol + debug=0 + debugcol=0 +c +cIM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa) +c + DO k=1, klevm1 + kp1=k+1 +c PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1) + if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN + DO i=1, klon + o500(i)=omega(i,k)*RDAY/100. +c if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1) + ENDDO + GOTO 1000 + endif +1000 continue + ENDDO +c +cIM recalcule les nuages vus par satellite, via le simulateur ISCCP +c + CALL ISCCP_CLOUD_TYPES( + & debug, + & debugcol, + & klon, + & sunlit, + & klev, + & ncol(n), + & seed(:,n), + & pfull, + & phalf, + & qv, cc, conv, dtau_sH2B, dtau_cH2B, + & top_height, + & overlap, + & tautab, + & invtau, + & ztsol, + & emsfc_lw, + & at, dem_sH2B, dem_cH2B, + & fq_isccp(:,:,:,n), + & totalcldarea(:,n), + & meanptop(:,n), + & meantaucld(:,n), + & boxtau(:,:,n), + & boxptop(:,:,n)) +c + ENDDO !n=1, napisccp + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calltherm.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calltherm.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/calltherm.F90 (revision 1634) @@ -0,0 +1,386 @@ +! +! $Id$ +! + subroutine calltherm(dtime & + & ,pplay,paprs,pphi,weak_inversion & + & ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & + & ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs & + & ,fm_therm,entr_therm,detr_therm,zqasc,clwcon0,lmax,ratqscth, & + & ratqsdiff,zqsatth,Ale_bl,Alp_bl,lalim_conv,wght_th, & + & zmax0,f0,zw2,fraca,ztv,zpspsk,ztla,zthl) + + USE dimphy + implicit none +#include "dimensions.h" +!#include "dimphy.h" +#include "thermcell.h" +#include "iniprint.h" + +!IM 140508 + INTEGER itap + REAL dtime + LOGICAL debut + LOGICAL logexpr0, logexpr2(klon,klev), logexpr1(klon) + REAL fact(klon) + INTEGER nbptspb + + REAL u_seri(klon,klev),v_seri(klon,klev) + REAL t_seri(klon,klev),q_seri(klon,klev),qmemoire(klon,klev) + REAL weak_inversion(klon) + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pphi(klon,klev) + real zlev(klon,klev+1) +!test: on sort lentr et a* pour alimenter KE + REAL wght_th(klon,klev) + INTEGER lalim_conv(klon) + REAL zw2(klon,klev+1),fraca(klon,klev+1) + +!FH Update Thermiques + REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev) + REAL d_u_ajs(klon,klev),d_v_ajs(klon,klev) + real fm_therm(klon,klev+1) + real entr_therm(klon,klev),detr_therm(klon,klev) + +!******************************************************** +! declarations + LOGICAL flag_bidouille_stratocu + real fmc_therm(klon,klev+1),zqasc(klon,klev) + real zqla(klon,klev) + real zqta(klon,klev) + real ztv(klon,klev) + real zpspsk(klon,klev) + real ztla(klon,klev) + real zthl(klon,klev) + real wmax_sec(klon) + real zmax_sec(klon) + real f_sec(klon) + real detrc_therm(klon,klev) +! FH WARNING : il semble que ces save ne servent a rien +! save fmc_therm, detrc_therm + real clwcon0(klon,klev) + real zqsat(klon,klev) + real zw_sec(klon,klev+1) + integer lmix_sec(klon) + integer lmax(klon) + real ratqscth(klon,klev) + real ratqsdiff(klon,klev) + real zqsatth(klon,klev) +!nouvelles variables pour la convection + real Ale_bl(klon) + real Alp_bl(klon) + real Ale(klon) + real Alp(klon) +!RC + !on garde le zmax du pas de temps precedent + real zmax0(klon), f0(klon) +!******************************************************** + + +! variables locales + REAL d_t_the(klon,klev), d_q_the(klon,klev) + REAL d_u_the(klon,klev),d_v_the(klon,klev) +! + real zfm_therm(klon,klev+1),zdt + real zentr_therm(klon,klev),zdetr_therm(klon,klev) +! FH A VERIFIER : SAVE INUTILES +! save zentr_therm,zfm_therm + + character (len=20) :: modname='calltherm' + character (len=80) :: abort_message + + integer i,k + logical, save :: first=.true. +!$OMP THREADPRIVATE(first) +!******************************************************** + if (first) then + itap=0 + first=.false. + endif + +! Incrementer le compteur de la physique + itap = itap + 1 + +! Modele du thermique +! =================== +! print*,'thermiques: WARNING on passe t au lieu de t_seri' + + +! On prend comme valeur initiale des thermiques la valeur du pas +! de temps precedent + zfm_therm(:,:)=fm_therm(:,:) + zdetr_therm(:,:)=detr_therm(:,:) + zentr_therm(:,:)=entr_therm(:,:) + +! On reinitialise les flux de masse a zero pour le cumul en +! cas de splitting + fm_therm(:,:)=0. + entr_therm(:,:)=0. + detr_therm(:,:)=0. + + Ale_bl(:)=0. + Alp_bl(:)=0. + if (prt_level.ge.10) then + print*,'thermV4 nsplit: ',nsplit_thermals,' weak_inversion' + endif + +! tests sur les valeurs negatives de l'eau + logexpr0=prt_level.ge.10 + nbptspb=0 + do k=1,klev + do i=1,klon +! Attention teste abderr 19-03-09 +! logexpr2(i,k)=.not.q_seri(i,k).ge.0. + logexpr2(i,k)=.not.q_seri(i,k).ge.1.e-15 + if (logexpr2(i,k)) then + q_seri(i,k)=1.e-15 + nbptspb=nbptspb+1 + endif +! if (logexpr0) & +! & print*,'WARN eau<0 avant therm i=',i,' k=',k & +! & ,' dq,q',d_q_the(i,k),q_seri(i,k) + enddo + enddo + if(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb + + zdt=dtime/REAL(nsplit_thermals) + do isplit=1,nsplit_thermals + + if (iflag_thermals.eq.1) then + CALL thermcell_2002(klon,klev,zdt & + & ,pplay,paprs,pphi & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,30.,w2di_thermals & + & ,tau_thermals) + else if (iflag_thermals.eq.2) then + CALL thermcell_sec(klon,klev,zdt & + & ,pplay,paprs,pphi,zlev & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,30.,w2di_thermals & + & ,tau_thermals) + else if (iflag_thermals.eq.3) then + CALL thermcell(klon,klev,zdt & + & ,pplay,paprs,pphi & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & + & ,tau_thermals) + else if (iflag_thermals.eq.10) then + CALL thermcell_eau(klon,klev,zdt & + & ,pplay,paprs,pphi & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm & + & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & + & ,tau_thermals) + else if (iflag_thermals.eq.11) then + abort_message = 'cas non prevu dans calltherm' + CALL abort_gcm (modname,abort_message,1) + +! CALL thermcell_pluie(klon,klev,zdt & +! & ,pplay,paprs,pphi,zlev & +! & ,u_seri,v_seri,t_seri,q_seri & +! & ,d_u_the,d_v_the,d_t_the,d_q_the & +! & ,zfm_therm,zentr_therm,zqla & +! & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & +! & ,tau_thermals,3) + else if (iflag_thermals.eq.12) then + CALL calcul_sec(klon,klev,zdt & + & ,pplay,paprs,pphi,zlev & + & ,u_seri,v_seri,t_seri,q_seri & + & ,zmax_sec,wmax_sec,zw_sec,lmix_sec & + & ,r_aspect_thermals,l_mix_thermals,w2di_thermals & + & ,tau_thermals) + else if (iflag_thermals==13.or.iflag_thermals==14) then + CALL thermcellV0_main(itap,klon,klev,zdt & + & ,pplay,paprs,pphi,debut & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm,zdetr_therm,zqasc,zqla,lmax & + & ,ratqscth,ratqsdiff,zqsatth & + & ,r_aspect_thermals,l_mix_thermals & + & ,tau_thermals,Ale,Alp,lalim_conv,wght_th & + & ,zmax0,f0,zw2,fraca) + else if (iflag_thermals==15.or.iflag_thermals==16) then + +! print*,'THERM iflag_thermas_ed=',iflag_thermals_ed + CALL thermcell_main(itap,klon,klev,zdt & + & ,pplay,paprs,pphi,debut & + & ,u_seri,v_seri,t_seri,q_seri & + & ,d_u_the,d_v_the,d_t_the,d_q_the & + & ,zfm_therm,zentr_therm,zdetr_therm,zqasc,zqla,lmax & + & ,ratqscth,ratqsdiff,zqsatth & +! & ,r_aspect_thermals,l_mix_thermals & +! & ,tau_thermals,iflag_thermals_ed,iflag_coupl & + & ,Ale,Alp,lalim_conv,wght_th & + & ,zmax0,f0,zw2,fraca,ztv,zpspsk & + & ,ztla,zthl) + if (prt_level.gt.10) write(lunout,*)'Apres thermcell_main OK' + else + abort_message = 'Cas des thermiques non prevu' + CALL abort_gcm (modname,abort_message,1) + endif + + flag_bidouille_stratocu=iflag_thermals.eq.14.or.iflag_thermals.eq.16 + + fact(:)=0. + DO i=1,klon + logexpr1(i)=flag_bidouille_stratocu.or.weak_inversion(i).gt.0.5 + IF(logexpr1(i)) fact(i)=1./REAL(nsplit_thermals) + ENDDO + + DO k=1,klev +! transformation de la derivee en tendance + d_t_the(:,k)=d_t_the(:,k)*dtime*fact(:) + d_u_the(:,k)=d_u_the(:,k)*dtime*fact(:) + d_v_the(:,k)=d_v_the(:,k)*dtime*fact(:) + d_q_the(:,k)=d_q_the(:,k)*dtime*fact(:) + fm_therm(:,k)=fm_therm(:,k) & + & +zfm_therm(:,k)*fact(:) + entr_therm(:,k)=entr_therm(:,k) & + & +zentr_therm(:,k)*fact(:) + detr_therm(:,k)=detr_therm(:,k) & + & +zdetr_therm(:,k)*fact(:) + ENDDO + fm_therm(:,klev+1)=0. + + + +! accumulation de la tendance + d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_the(:,:) + d_u_ajs(:,:)=d_u_ajs(:,:)+d_u_the(:,:) + d_v_ajs(:,:)=d_v_ajs(:,:)+d_v_the(:,:) + d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_the(:,:) + +! incrementation des variables meteo + t_seri(:,:) = t_seri(:,:) + d_t_the(:,:) + u_seri(:,:) = u_seri(:,:) + d_u_the(:,:) + v_seri(:,:) = v_seri(:,:) + d_v_the(:,:) + qmemoire(:,:)=q_seri(:,:) + q_seri(:,:) = q_seri(:,:) + d_q_the(:,:) + if (prt_level.gt.10) write(lunout,*)'Apres apres thermcell_main OK' + + DO i=1,klon + if(prt_level.GE.10) print*,'calltherm i Alp_bl Alp Ale_bl Ale',i,Alp_bl(i),Alp(i),Ale_bl(i),Ale(i) + fm_therm(i,klev+1)=0. + Ale_bl(i)=Ale_bl(i)+Ale(i)/REAL(nsplit_thermals) +! write(22,*)'ALE CALLTHERM',Ale_bl(i),Ale(i) + Alp_bl(i)=Alp_bl(i)+Alp(i)/REAL(nsplit_thermals) +! write(23,*)'ALP CALLTHERM',Alp_bl(i),Alp(i) + ENDDO + +!IM 060508 marche pas comme cela !!! enddo ! isplit + +! tests sur les valeurs negatives de l'eau + nbptspb=0 + DO k = 1, klev + DO i = 1, klon + logexpr2(i,k)=.not.q_seri(i,k).ge.0. + if (logexpr2(i,k)) then + q_seri(i,k)=1.e-15 + nbptspb=nbptspb+1 +! if (prt_level.ge.10) then +! print*,'WARN eau<0 apres therm i=',i,' k=',k & +! & ,' dq,q',d_q_the(i,k),q_seri(i,k), & +! & 'fm=',zfm_therm(i,k),'entr=',entr_therm(i,k) + endif + ENDDO + ENDDO + IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb +! tests sur les valeurs de la temperature + nbptspb=0 + DO k = 1, klev + DO i = 1, klon + logexpr2(i,k)=t_seri(i,k).lt.50..or.t_seri(i,k).gt.370. + if (logexpr2(i,k)) nbptspb=nbptspb+1 +! if ((t_seri(i,k).lt.50.) .or. & +! & (t_seri(i,k).gt.370.)) then +! print*,'WARN temp apres therm i=',i,' k=',k & +! & ,' t_seri',t_seri(i,k) +! CALL abort +! endif + ENDDO + ENDDO + IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb + enddo ! isplit + +! +!*************************************************************** +! calcul du flux ascencant conservatif +! print*,'<<< calwake, wake_s ', wake_s(1) + + RDCP=1./3.5 + + +c----------------------------------------------------------- +cIM 290108 DO 999 i=1,klon ! a vectoriser +c---------------------------------------------------------- + + + DO l=1,klev + DO i=1,klon + p(i,l)= pplay(i,l) + ph(i,l)= paprs(i,l) + pi(i,l) = (pplay(i,l)/100000.)**RDCP + + te(i,l) = t(i,l) + qe(i,l) = q(i,l) + omgbe(i,l) = omgb(i,l) + + dtdwn(i,l)= dt_dwn(i,l) + dqdwn(i,l)= dq_dwn(i,l) + dta(i,l)= dt_a(i,l) + dqa(i,l)= dq_a(i,l) + wdtPBL(i,l)= wdt_PBL(i,l) + wdqPBL(i,l)= wdq_PBL(i,l) + udtPBL(i,l)= udt_PBL(i,l) + udqPBL(i,l)= udq_PBL(i,l) + ENDDO + ENDDO + + omgbe(:,klev+1) = 0. + + DO i=1,klon + sigd0(i)=sigd(i) + ENDDO +c print*, 'sigd0,sigd', sigd0, sigd(i) + DO i=1,klon + ph(i,klev+1)=0. + ENDDO + + DO i=1,klon + ktopw(i) = wake_k(i) + ENDDO + + DO l=1,klev + DO i=1,klon + dtw(i,l) = wake_deltat(i,l) + dqw(i,l) = wake_deltaq(i,l) + ENDDO + ENDDO + + DO l=1,klev + DO i=1,klon + dtls(i,l)=dt_wake(i,l) + dqls(i,l)=dq_wake(i,l) + ENDDO + ENDDO + + DO i=1,klon + hw(i) = wake_h(i) + sigmaw(i)= wake_s(i) + ENDDO + +cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface +cfkc on veut le flux de masse au milieu des couches + + DO l=1,klev-1 + DO i=1,klon + amdwn(i,l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1)) + amdwn(i,l)= (M_dwn(i,l+1)) + ENDDO + ENDDO + +c au sommet le flux de masse est nul + + DO i=1,klon + amdwn(i,klev)=0.5*M_dwn(i,klev) + ENDDO +c + DO l = 1,klev + DO i=1,klon + amup(i,l)=M_up(i,l) + ENDDO + ENDDO + + call WAKE(p,ph,pi,dtime,sigd0 + $ ,te,qe,omgbe + $ ,dtdwn,dqdwn,amdwn,amup,dta,dqa + $ ,wdtPBL,wdqPBL,udtPBL,udqPBL + $ ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl + $ ,dtls,dqls,ktopw + $ ,omgbdth,dp_omgb,wdens + $ ,tu,qu + $ ,dtKE,dqKE + $ ,dtPBL,dqPBL + $ ,omg,dp_deltomg,spread + $ ,Cstar,d_deltat_gw + $ ,d_deltatw,d_deltaqw) +c + DO l=1,klev + DO i=1,klon + IF (ktopw(i) .GT. 0) THEN + wake_deltat(i,l)= dtw(i,l) + wake_deltaq(i,l)= dqw(i,l) + wake_d_deltat_gw(i,l)= d_deltat_gw(i,l) + wake_omgbdth(i,l) = omgbdth(i,l) + wake_dp_omgb(i,l) = dp_omgb(i,l) + wake_dtKE(i,l) = dtKE(i,l) + wake_dqKE(i,l) = dqKE(i,l) + wake_dtPBL(i,l) = dtPBL(i,l) + wake_dqPBL(i,l) = dqPBL(i,l) + wake_omg(i,l) = omg(i,l) + wake_dp_deltomg(i,l) = dp_deltomg(i,l) + wake_spread(i,l) = spread(i,l) + wake_dth(i,l) = dth(i,l) + dt_wake(i,l) = dtls(i,l) + dq_wake(i,l) = dqls(i,l) + undi_t(i,l) = tu(i,l) + undi_q(i,l) = qu(i,l) + wake_ddeltat(i,l) = d_deltatw(i,l) + wake_ddeltaq(i,l) = d_deltaqw(i,l) + ELSE + wake_deltat(i,l)= 0. + wake_deltaq(i,l)= 0. + wake_d_deltat_gw(i,l)= 0. + wake_omgbdth(i,l) = 0. + wake_dp_omgb(i,l) = 0. + wake_dtKE(i,l) = 0. + wake_dqKE(i,l) = 0. + wake_dtPBL(i,l) = 0. + wake_dqPBL(i,l) = 0. + wake_omg(i,l) = 0. + wake_dp_deltomg(i,l) = 0. + wake_spread(i,l) = 0. + wake_dth(i,l)=0. + dt_wake(i,l)=0. + dq_wake(i,l)=0. + undi_t(i,l)=te(i,l) + undi_q(i,l)=qe(i,l) + wake_ddeltat(i,l) = 0. + wake_ddeltaq(i,l) = 0. + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + wake_h(i)= hw(i) + wake_s(i)= sigmaw(i) + wake_pe(i)= wape(i) + wake_fip(i)= fip(i) + wake_gfl(i) = gfl(i) + wake_k(i) =ktopw(i) + wake_Cstar(i) = Cstar(i) + wake_dens(i) = wdens(i) + ENDDO +c + RETURN + END + + SUBROUTINE CALWAKE_scal(paprs,pplay,dtime + : ,t,q,omgb + : ,dt_dwn,dq_dwn,M_dwn,M_up + : ,dt_a,dq_a,sigd + : ,wdt_PBL,wdq_PBL + : ,udt_PBL,udq_PBL + o ,wake_deltat,wake_deltaq,wake_dth + o ,wake_h,wake_s,wake_dens + o ,wake_pe,wake_fip,wake_gfl + o ,dt_wake,dq_wake + o ,wake_k + o ,undi_t,undi_q + o ,wake_omgbdth,wake_dp_omgb + o ,wake_dtKE,wake_dqKE + o ,wake_dtPBL,wake_dqPBL + o ,wake_omg,wake_dp_deltomg + o ,wake_spread,wake_Cstar,wake_d_deltat_gw + o ,wake_ddeltat,wake_ddeltaq) +*************************************************************** +* * +* CALWAKE * +* interface avec le schema de calcul de la poche * +* froide * +* * +* written by : CHERUY Frederique, 13/03/2000, 10.31.05 * +* modified by : ROEHRIG Romain, 01/30/2007 * +*************************************************************** +* + USE dimphy + IMPLICIT none +c====================================================================== + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c Arguments +c---------- + + INTEGER i,l,ktopw + REAL dtime + + REAL paprs(klon,klev+1),pplay(klon,klev) + REAL t(klon,klev), q(klon,klev), omgb(klon,klev) + REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev) + REAL M_up(klon,klev) + REAL dt_a(klon,klev), dq_a(klon,klev) + REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev) + REAL udt_PBL(klon,klev), udq_PBL(klon,klev) + REAL wake_deltat(klon,klev),wake_deltaq(klon,klev) + REAL dt_wake(klon,klev),dq_wake(klon,klev) + REAL wake_d_deltat_gw(klon,klev) + REAL wake_h(klon),wake_s(klon) + REAL wake_dth(klon,klev) + REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon) + REAL undi_t(klon,klev),undi_q(klon,klev) + REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev) + REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev) + REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev) + REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev) + REAL wake_spread(klon,klev),wake_Cstar(klon) + REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) + REAL d_deltatw(klev), d_deltaqw(klev) + INTEGER wake_k(klon) + REAL sigd(klon) + REAL wake_dens(klon) + +C Variable internes +C ----------------- + + REAL aire + REAL p(klev),ph(klev+1),pi(klev) + REAL te(klev),qe(klev),omgbe(klev),dtdwn(klev),dqdwn(klev) + REAL dta(klev),dqa(klev) + REAL wdtPBL(klev),wdqPBL(klev) + REAL udtPBL(klev),udqPBL(klev) + REAL amdwn(klev),amup(klev) + REAL dtw(klev),dqw(klev),dth(klev),d_deltat_gw(klev) + REAL dtls(klev),dqls(klev) + REAL tu(klev),qu(klev) + REAL hw,sigmaw,wape,fip,gfl + REAL omgbdth(klev),dp_omgb(klev) + REAL dtKE(klev),dqKE(klev) + REAL dtPBL(klev),dqPBL(klev) + REAL omg(klev+1),dp_deltomg(klev),spread(klev),Cstar + REAL sigd0,wdens + + REAL RDCP + +c print *, '-> calwake, wake_s ', wake_s(1) + + RDCP=1./3.5 + +c----------------------------------------------------------- + DO 999 i=1,klon ! a vectoriser +c---------------------------------------------------------- + + + DO l=1,klev + p(l)= pplay(i,l) + ph(l)= paprs(i,l) + pi(l) = (pplay(i,l)/100000.)**RDCP + + te(l) = t(i,l) + qe(l) = q(i,l) + omgbe(l) = omgb(i,l) + + dtdwn(l)= dt_dwn(i,l) + dqdwn(l)= dq_dwn(i,l) + dta(l)= dt_a(i,l) + dqa(l)= dq_a(i,l) + wdtPBL(l)= wdt_PBL(i,l) + wdqPBL(l)= wdq_PBL(i,l) + udtPBL(l)= udt_PBL(i,l) + udqPBL(l)= udq_PBL(i,l) + ENDDO + + sigd0=sigd(i) +c print*, 'sigd0,sigd', sigd0, sigd(i) + ph(klev+1)=0. + + ktopw = wake_k(i) + + DO l=1,klev + dtw(l) = wake_deltat(i,l) + dqw(l) = wake_deltaq(i,l) + ENDDO + + DO l=1,klev + dtls(l)=dt_wake(i,l) + dqls(l)=dq_wake(i,l) + ENDDO + + hw = wake_h(i) + sigmaw = wake_s(i) + +cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface +cfkc on veut le flux de masse au milieu des couches + + DO l=1,klev-1 + amdwn(l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1)) + amdwn(l)= (M_dwn(i,l+1)) + ENDDO + +c au sommet le flux de masse est nul + + amdwn(klev)=0.5*M_dwn(i,klev) +c + DO l = 1,klev + amup(l)=M_up(i,l) + ENDDO + + call WAKE_scal(p,ph,pi,dtime,sigd0 + $ ,te,qe,omgbe + $ ,dtdwn,dqdwn,amdwn,amup,dta,dqa + $ ,wdtPBL,wdqPBL,udtPBL,udqPBL + $ ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl + $ ,dtls,dqls,ktopw + $ ,omgbdth,dp_omgb,wdens + $ ,tu,qu + $ ,dtKE,dqKE + $ ,dtPBL,dqPBL + $ ,omg,dp_deltomg,spread + $ ,Cstar,d_deltat_gw + $ ,d_deltatw,d_deltaqw) + + IF (ktopw .GT. 0) THEN + DO l=1,klev + wake_deltat(i,l)= dtw(l) + wake_deltaq(i,l)= dqw(l) + wake_d_deltat_gw(i,l)= d_deltat_gw(l) + wake_omgbdth(i,l) = omgbdth(l) + wake_dp_omgb(i,l) = dp_omgb(l) + wake_dtKE(i,l) = dtKE(l) + wake_dqKE(i,l) = dqKE(l) + wake_dtPBL(i,l) = dtPBL(l) + wake_dqPBL(i,l) = dqPBL(l) + wake_omg(i,l) = omg(l) + wake_dp_deltomg(i,l) = dp_deltomg(l) + wake_spread(i,l) = spread(l) + wake_dth(i,l) = dth(l) + dt_wake(i,l) = dtls(l) + dq_wake(i,l) = dqls(l) + undi_t(i,l) = tu(l) + undi_q(i,l) = qu(l) + wake_ddeltat(i,l) = d_deltatw(l) + wake_ddeltaq(i,l) = d_deltaqw(l) + ENDDO + ELSE + DO l = 1,klev + wake_deltat(i,l)= 0. + wake_deltaq(i,l)= 0. + wake_d_deltat_gw(i,l)= 0. + wake_omgbdth(i,l) = 0. + wake_dp_omgb(i,l) = 0. + wake_dtKE(i,l) = 0. + wake_dqKE(i,l) = 0. + wake_omg(i,l) = 0. + wake_dp_deltomg(i,l) = 0. + wake_spread(i,l) = 0. + wake_dth(i,l)=0. + dt_wake(i,l)=0. + dq_wake(i,l)=0. + undi_t(i,l)=te(l) + undi_q(i,l)=qe(l) + ENDDO + ENDIF + + wake_h(i)= hw + wake_s(i)= sigmaw + wake_pe(i)= wape + wake_fip(i)= fip + wake_gfl(i) = gfl + wake_k(i) =ktopw + wake_Cstar(i) = Cstar + wake_dens(i) = wdens +c + 999 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/carbon_cycle_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/carbon_cycle_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/carbon_cycle_mod.F90 (revision 1634) @@ -0,0 +1,467 @@ +MODULE carbon_cycle_mod +! Controle module for the carbon CO2 tracers : +! - Identification +! - Get concentrations comming from coupled model or read from file to tracers +! - Calculate new RCO2 for radiation scheme +! - Calculate new carbon flux for sending to coupled models (PISCES and ORCHIDEE) +! +! Author : Josefine GHATTAS, Patricia CADULE + + IMPLICIT NONE + SAVE + PRIVATE + PUBLIC :: carbon_cycle_init, carbon_cycle + +! Variables read from parmeter file physiq.def + LOGICAL, PUBLIC :: carbon_cycle_tr ! 3D transport of CO2 in the atmosphere, parameter read in conf_phys +!$OMP THREADPRIVATE(carbon_cycle_tr) + LOGICAL, PUBLIC :: carbon_cycle_cpl ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) +!$OMP THREADPRIVATE(carbon_cycle_cpl) + + LOGICAL :: carbon_cycle_emis_comp=.FALSE. ! Calculation of emission compatible +!$OMP THREADPRIVATE(carbon_cycle_emis_comp) + + LOGICAL :: RCO2_inter ! RCO2 interactive : if true calculate new value RCO2 for the radiation scheme +!$OMP THREADPRIVATE(RCO2_inter) + +! Scalare values when no transport, from physiq.def + REAL :: fos_fuel_s ! carbon_cycle_fos_fuel dans physiq.def +!$OMP THREADPRIVATE(fos_fuel_s) + REAL :: emis_land_s ! not yet implemented +!$OMP THREADPRIVATE(emis_land_s) + + REAL :: airetot ! Total area of the earth surface +!$OMP THREADPRIVATE(airetot) + + INTEGER :: ntr_co2 ! Number of tracers concerning the carbon cycle +!$OMP THREADPRIVATE(ntr_co2) + +! fco2_ocn_day : flux CO2 from ocean for 1 day (cumulated) [gC/m2/d]. Allocation and initalization done in cpl_mod + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocn_day +!$OMP THREADPRIVATE(fco2_ocn_day) + + REAL, DIMENSION(:), ALLOCATABLE :: fco2_land_day ! flux CO2 from land for 1 day (cumulated) [gC/m2/d] +!$OMP THREADPRIVATE(fco2_land_day) + REAL, DIMENSION(:), ALLOCATABLE :: fco2_lu_day ! Emission from land use change for 1 day (cumulated) [gC/m2/d] +!$OMP THREADPRIVATE(fco2_lu_day) + + REAL, DIMENSION(:,:), ALLOCATABLE :: dtr_add ! Tracer concentration to be injected +!$OMP THREADPRIVATE(dtr_add) + +! Following 2 fields will be allocated and initialized in surf_land_orchidee + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_inst ! flux CO2 from land at one time step +!$OMP THREADPRIVATE(fco2_land_inst) + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_lu_inst ! Emission from land use change at one time step +!$OMP THREADPRIVATE(fco2_lu_inst) + +! Calculated co2 field to be send to the ocean via the coupler and to ORCHIDEE + REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: co2_send ! Field allocated in phyetat0 +!$OMP THREADPRIVATE(co2_send) + + + TYPE, PUBLIC :: co2_trac_type + CHARACTER(len = 8) :: name ! Tracer name in tracer.def + INTEGER :: id ! Index in total tracer list, tr_seri + CHARACTER(len=30) :: file ! File name + LOGICAL :: cpl ! True if this tracers is coupled from ORCHIDEE or PISCES. + ! False if read from file. + INTEGER :: updatefreq ! Frequence to inject in second + INTEGER :: readstep ! Actual time step to read in file + LOGICAL :: updatenow ! True if this tracer should be updated this time step + END TYPE co2_trac_type + INTEGER,PARAMETER :: maxco2trac=5 ! Maximum number of different CO2 fluxes + TYPE(co2_trac_type), DIMENSION(maxco2trac) :: co2trac + +CONTAINS + + SUBROUTINE carbon_cycle_init(tr_seri, pdtphys, aerosol, radio) +! This subroutine is called from traclmdz_init, only at first timestep. +! - Read controle parameters from .def input file +! - Search for carbon tracers and set default values +! - Allocate variables +! - Test for compatibility + + USE dimphy + USE comgeomphy + USE mod_phys_lmdz_transfert_para + USE infotrac + USE IOIPSL + USE surface_data, ONLY : ok_veget, type_ocean + USE phys_cal_mod, ONLY : mth_len + + IMPLICIT NONE + INCLUDE "clesphys.h" + INCLUDE "iniprint.h" + +! Input argument + REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri ! Concentration Traceur [U/KgA] + REAL,INTENT(IN) :: pdtphys ! length of time step in physiq (sec) + +! InOutput arguments + LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: aerosol + LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: radio + +! Local variables + INTEGER :: ierr, it, iiq, itc + INTEGER :: teststop + + + +! 1) Read controle parameters from .def input file +! ------------------------------------------------ + ! Read fosil fuel value if no transport + IF (.NOT. carbon_cycle_tr) THEN + fos_fuel_s = 0. + CALL getin ('carbon_cycle_fos_fuel',fos_fuel_s) + WRITE(lunout,*) 'carbon_cycle_fos_fuel = ', fos_fuel_s + END IF + + + ! Read parmeter for calculation compatible emission + IF (.NOT. carbon_cycle_tr) THEN + carbon_cycle_emis_comp=.FALSE. + CALL getin('carbon_cycle_emis_comp',carbon_cycle_emis_comp) + WRITE(lunout,*) 'carbon_cycle_emis_comp = ',carbon_cycle_emis_comp + IF (carbon_cycle_emis_comp) THEN + CALL abort_gcm('carbon_cycle_init', 'carbon_cycle_emis_comp option not yet implemented!!',1) + END IF + END IF + + ! Read parameter for interactive calculation of the CO2 value for the radiation scheme + RCO2_inter=.FALSE. + CALL getin('RCO2_inter',RCO2_inter) + WRITE(lunout,*) 'RCO2_inter = ', RCO2_inter + IF (RCO2_inter) THEN + WRITE(lunout,*) 'RCO2 will be recalculated once a day' + WRITE(lunout,*) 'RCO2 initial = ', RCO2 + END IF + + +! 2) Search for carbon tracers and set default values +! --------------------------------------------------- + itc=0 + DO it=1,nbtr + iiq=niadv(it+2) + + SELECT CASE(tname(iiq)) + CASE("fCO2_ocn") + itc = itc + 1 + co2trac(itc)%name='fCO2_ocn' + co2trac(itc)%id=it + co2trac(itc)%file='fl_co2_ocean.nc' + IF (carbon_cycle_cpl .AND. type_ocean=='couple') THEN + co2trac(itc)%cpl=.TRUE. + co2trac(itc)%updatefreq = 86400 ! Once a day as the coupling with OASIS/PISCES + ELSE + co2trac(itc)%cpl=.FALSE. + co2trac(itc)%updatefreq = 86400*mth_len ! Once a month + END IF + CASE("fCO2_land") + itc = itc + 1 + co2trac(itc)%name='fCO2_land' + co2trac(itc)%id=it + co2trac(itc)%file='fl_co2_land.nc' + IF (carbon_cycle_cpl .AND. ok_veget) THEN + co2trac(itc)%cpl=.TRUE. + co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE + ELSE + co2trac(itc)%cpl=.FALSE. +! co2trac(itc)%updatefreq = 10800 ! 10800sec = 3H + co2trac(itc)%updatefreq = 86400*mth_len ! Once a month + END IF + CASE("fCO2_land_use") + itc = itc + 1 + co2trac(itc)%name='fCO2_land_use' + co2trac(itc)%id=it + co2trac(itc)%file='fl_co2_land_use.nc' + IF (carbon_cycle_cpl .AND. ok_veget) THEN + co2trac(it)%cpl=.TRUE. + co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE + ELSE + co2trac(itc)%cpl=.FALSE. + co2trac(itc)%updatefreq = 10800 ! 10800sec = 3H + END IF + CASE("fCO2_fos_fuel") + itc = itc + 1 + co2trac(itc)%name='fCO2_fos_fuel' + co2trac(itc)%id=it + co2trac(itc)%file='fossil_fuel.nc' + co2trac(itc)%cpl=.FALSE. ! This tracer always read from file +! co2trac(itc)%updatefreq = 86400 ! 86400sec = 24H Cadule case + co2trac(itc)%updatefreq = 86400*mth_len ! Once a month + CASE("fCO2_bbg") + itc = itc + 1 + co2trac(itc)%name='fCO2_bbg' + co2trac(itc)%id=it + co2trac(itc)%file='fl_co2_bbg.nc' + co2trac(itc)%cpl=.FALSE. ! This tracer always read from file + co2trac(itc)%updatefreq = 86400*mth_len ! Once a month + CASE("fCO2") + ! fCO2 : One tracer transporting the total CO2 flux + itc = itc + 1 + co2trac(itc)%name='fCO2' + co2trac(itc)%id=it + co2trac(itc)%file='fl_co2.nc' + IF (carbon_cycle_cpl) THEN + co2trac(itc)%cpl=.TRUE. + ELSE + co2trac(itc)%cpl=.FALSE. + END IF + co2trac(itc)%updatefreq = 86400 + ! DOES THIS WORK ???? Problematic due to implementation of the coupled fluxes... + CALL abort_gcm('carbon_cycle_init','transport of total CO2 has to be implemented and tested',1) + END SELECT + END DO + + ! Total number of carbon CO2 tracers + ntr_co2 = itc + + ! Definition of control varaiables for the tracers + DO it=1,ntr_co2 + aerosol(co2trac(it)%id) = .FALSE. + radio(co2trac(it)%id) = .FALSE. + END DO + + ! Vector indicating which timestep to read for each tracer + ! Always start read in the beginning of the file + co2trac(:)%readstep = 0 + + +! 3) Allocate variables +! --------------------- + ! Allocate vector for storing fluxes to inject + ALLOCATE(dtr_add(klon,maxco2trac), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 11',1) + + ! Allocate variables for cumulating fluxes from ORCHIDEE + IF (RCO2_inter) THEN + IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN + ALLOCATE(fco2_land_day(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 2',1) + fco2_land_day(1:klon) = 0. + + ALLOCATE(fco2_lu_day(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 3',1) + fco2_lu_day(1:klon) = 0. + END IF + END IF + + +! 4) Test for compatibility +! ------------------------- +! IF (carbon_cycle_cpl .AND. type_ocean/='couple') THEN +! WRITE(lunout,*) 'Coupling with ocean model is needed for carbon_cycle_cpl' +! CALL abort_gcm('carbon_cycle_init', 'coupled ocean is needed for carbon_cycle_cpl',1) +! END IF +! +! IF (carbon_cycle_cpl .AND..NOT. ok_veget) THEN +! WRITE(lunout,*) 'Coupling with surface land model ORCHDIEE is needed for carbon_cycle_cpl' +! CALL abort_gcm('carbon_cycle_init', 'ok_veget is needed for carbon_cycle_cpl',1) +! END IF + + ! Compiler test : following should never happen + teststop=0 + DO it=1,teststop + CALL abort_gcm('carbon_cycle_init', 'Entering loop from 1 to 0',1) + END DO + + IF (ntr_co2==0) THEN + ! No carbon tracers found in tracer.def. It is not possible to do carbon cycle + WRITE(lunout,*) 'No carbon tracers found in tracer.def. Not ok with carbon_cycle_tr and/or carbon_cycle_cp' + CALL abort_gcm('carbon_cycle_init', 'No carbon tracers found in tracer.def',1) + END IF + +! 5) Calculate total area of the earth surface +! -------------------------------------------- + CALL reduce_sum(SUM(airephy),airetot) + CALL bcast(airetot) + + END SUBROUTINE carbon_cycle_init + + + SUBROUTINE carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source) +! Subroutine for injection of co2 in the tracers +! +! - Find out if it is time to update +! - Get tracer from coupled model or from file +! - Calculate new RCO2 value for the radiation scheme +! - Calculate CO2 flux to send to ocean and land models (PISCES and ORCHIDEE) + + USE infotrac + USE dimphy + USE mod_phys_lmdz_transfert_para + USE phys_cal_mod, ONLY : mth_cur, mth_len + USE phys_cal_mod, ONLY : day_cur + USE comgeomphy + + IMPLICIT NONE + + INCLUDE "clesphys.h" + INCLUDE "indicesol.h" + INCLUDE "iniprint.h" + INCLUDE "YOMCST.h" + +! In/Output arguments + INTEGER,INTENT(IN) :: nstep ! time step in physiq + REAL,INTENT(IN) :: pdtphys ! length of time step in physiq (sec) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Surface fraction + REAL, DIMENSION(klon,klev,nbtr), INTENT(INOUT) :: tr_seri ! All tracers + REAL, DIMENSION(klon,nbtr), INTENT(INOUT) :: source ! Source for all tracers + +! Local variables + INTEGER :: it + LOGICAL :: newmonth ! indicates if a new month just started + LOGICAL :: newday ! indicates if a new day just started + LOGICAL :: endday ! indicated if last time step in a day + + REAL, PARAMETER :: fact=1.E-15/2.12 ! transformation factor from gC/m2/day => ppm/m2/day + REAL, DIMENSION(klon) :: fco2_tmp + REAL :: sumtmp + REAL :: delta_co2_ppm + + +! 1) Calculate logicals indicating if it is a new month, new day or the last time step in a day (end day) +! ------------------------------------------------------------------------------------------------------- + + newday = .FALSE.; endday = .FALSE.; newmonth = .FALSE. + + IF (MOD(nstep,INT(86400./pdtphys))==1) newday=.TRUE. + IF (MOD(nstep,INT(86400./pdtphys))==0) endday=.TRUE. + IF (newday .AND. day_cur==1) newmonth=.TRUE. + +! 2) For each carbon tracer find out if it is time to inject (update) +! -------------------------------------------------------------------- + DO it = 1, ntr_co2 + IF ( MOD(nstep,INT(co2trac(it)%updatefreq/pdtphys)) == 1 ) THEN + co2trac(it)%updatenow = .TRUE. + ELSE + co2trac(it)%updatenow = .FALSE. + END IF + END DO + +! 3) Get tracer update +! -------------------------------------- + DO it = 1, ntr_co2 + IF ( co2trac(it)%updatenow ) THEN + IF ( co2trac(it)%cpl ) THEN + ! Get tracer from coupled model + SELECT CASE(co2trac(it)%name) + CASE('fCO2_land') ! from ORCHIDEE + dtr_add(:,it) = fco2_land_inst(:)*pctsrf(:,is_ter)*fact ! [ppm/m2/day] + CASE('fCO2_land_use') ! from ORCHIDEE + dtr_add(:,it) = fco2_lu_inst(:) *pctsrf(:,is_ter)*fact ! [ppm/m2/day] + CASE('fCO2_ocn') ! from PISCES + dtr_add(:,it) = fco2_ocn_day(:) *pctsrf(:,is_oce)*fact ! [ppm/m2/day] + CASE DEFAULT + WRITE(lunout,*) 'Error with tracer ',co2trac(it)%name + CALL abort_gcm('carbon_cycle', 'No coupling implemented for this tracer',1) + END SELECT + ELSE + ! Read tracer from file + co2trac(it)%readstep = co2trac(it)%readstep + 1 ! increment time step in file +! Patricia CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.FALSE.,dtr_add(:,it)) + CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.TRUE.,dtr_add(:,it)) + + ! Converte from kgC/m2/h to kgC/m2/s + dtr_add(:,it) = dtr_add(:,it)/3600 + ! Add individual treatment of values read from file + SELECT CASE(co2trac(it)%name) + CASE('fCO2_land') + dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter) + CASE('fCO2_land_use') + dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter) + CASE('fCO2_ocn') + dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_oce) +! Patricia : +! CASE('fCO2_fos_fuel') +! dtr_add(:,it) = dtr_add(:,it)/mth_len +! co2trac(it)%readstep = 0 ! Always read same value for fossil fuel(Cadule case) + END SELECT + END IF + END IF + END DO + +! 4) Update co2 tracers : +! Loop over all carbon tracers and add source +! ------------------------------------------------------------------ + IF (carbon_cycle_tr) THEN + DO it = 1, ntr_co2 + IF (.FALSE.) THEN + tr_seri(1:klon,1,co2trac(it)%id) = tr_seri(1:klon,1,co2trac(it)%id) + dtr_add(1:klon,it) + source(1:klon,co2trac(it)%id) = 0. + ELSE + source(1:klon,co2trac(it)%id) = dtr_add(1:klon,it) + END IF + END DO + END IF + + +! 5) Calculations for new CO2 value for the radiation scheme(instead of reading value from .def) +! ---------------------------------------------------------------------------------------------- + IF (RCO2_inter) THEN + ! Cumulate fluxes from ORCHIDEE at each timestep + IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN + IF (newday) THEN ! Reset cumulative variables once a day + fco2_land_day(1:klon) = 0. + fco2_lu_day(1:klon) = 0. + END IF + fco2_land_day(1:klon) = fco2_land_day(1:klon) + fco2_land_inst(1:klon) ![gC/m2/day] + fco2_lu_day(1:klon) = fco2_lu_day(1:klon) + fco2_lu_inst(1:klon) ![gC/m2/day] + END IF + + ! At the end of a new day, calculate a mean scalare value of CO2 + ! JG : Ici on utilise uniquement le traceur du premier couche du modele. Est-ce que c'est correcte ? + IF (endday) THEN + + IF (carbon_cycle_tr) THEN + ! Sum all co2 tracers to get the total delta CO2 flux + fco2_tmp(:) = 0. + DO it = 1, ntr_co2 + fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id) + END DO + + ELSE IF (carbon_cycle_cpl) THEN ! no carbon_cycle_tr + ! Sum co2 fluxes comming from coupled models and parameter for fossil fuel + fco2_tmp(1:klon) = fos_fuel_s + ((fco2_lu_day(1:klon) + fco2_land_day(1:klon))*pctsrf(1:klon,is_ter) & + + fco2_ocn_day(:)*pctsrf(:,is_oce)) * fact + END IF + + ! Calculate a global mean value of delta CO2 flux + fco2_tmp(1:klon) = fco2_tmp(1:klon) * airephy(1:klon) + CALL reduce_sum(SUM(fco2_tmp),sumtmp) + CALL bcast(sumtmp) + delta_co2_ppm = sumtmp/airetot + + ! Add initial value for co2_ppm and delta value + co2_ppm = co2_ppm0 + delta_co2_ppm + + ! Transformation of atmospheric CO2 concentration for the radiation code + RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97 + + WRITE(lunout,*) 'RCO2 is now updated! RCO2 = ', RCO2 + END IF ! endday + + END IF ! RCO2_inter + + +! 6) Calculate CO2 flux to send to ocean and land models : PISCES and ORCHIDEE +! ---------------------------------------------------------------------------- + IF (carbon_cycle_cpl) THEN + + IF (carbon_cycle_tr) THEN + ! Sum all co2 tracers to get the total delta CO2 flux at first model layer + fco2_tmp(:) = 0. + DO it = 1, ntr_co2 + fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id) + END DO + co2_send(1:klon) = fco2_tmp(1:klon) + co2_ppm0 + ELSE + ! Send a scalare value in 2D variable to ocean and land model (PISCES and ORCHIDEE) + co2_send(1:klon) = co2_ppm + END IF + + END IF + + END SUBROUTINE carbon_cycle + +END MODULE carbon_cycle_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/change_srf_frac_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/change_srf_frac_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/change_srf_frac_mod.F90 (revision 1634) @@ -0,0 +1,163 @@ +! +! $Header$ +! +MODULE change_srf_frac_mod + + IMPLICIT NONE + +CONTAINS +! +! Change Surface Fractions +! Author J Ghattas 2008 + + SUBROUTINE change_srf_frac(itime, dtime, jour, & + pctsrf, alb1, alb2, tsurf, u10m, v10m, pbl_tke) +! +! This subroutine is called from physiq.F at each timestep. +! 1- For each type of ocean (force, slab, couple) receive new fractions only if +! it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false). +! If received new fraction : +! 2- Tests and ajustements are done on the fractions +! 3- Initialize variables where a new fraction(new or melted ice) has appered, +! + + USE dimphy + USE surface_data, ONLY : type_ocean + USE limit_read_mod + USE pbl_surface_mod, ONLY : pbl_surface_newfrac + USE cpl_mod, ONLY : cpl_receive_frac + USE ocean_slab_mod, ONLY : ocean_slab_frac + + INCLUDE "iniprint.h" + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! current time step + INTEGER, INTENT(IN) :: jour ! day of the year + REAL, INTENT(IN) :: dtime ! length of time step (s) + +! In-Output arguments +!**************************************************************************************** + + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb1 ! albedo first interval in SW spektrum + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb2 ! albedo second interval in SW spektrum + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m + REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke + +! Loccal variables +!**************************************************************************************** + INTEGER :: i, nsrf + LOGICAL :: is_modified ! true if pctsrf is modified at this time step + LOGICAL :: test_sum=.FALSE. + LOGICAL, DIMENSION(klon,nbsrf) :: new_surf + REAL, DIMENSION(klon,nbsrf) :: pctsrf_old ! fraction from previous time-step + REAL :: tmpsum + + pctsrf_old(:,:) = pctsrf(:,:) +!**************************************************************************************** +! 1) +! For each type of ocean (force, slab, couple) receive new fractions only if it's time +! to modify (is_modified=true). Otherwise nothing is done (is_modified=false). +!**************************************************************************************** + SELECT CASE (type_ocean) + CASE ('force') + ! Read fraction from limit.nc + CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified) + CASE ('slab') + ! Get fraction from slab module + CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified) + CASE ('couple') + ! Get fraction from the coupler + CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified) + END SELECT + + +!**************************************************************************************** +! 2) +! Tests and ajustements on the new fractions : +! - Put to zero fractions that are too small +! - Test total fraction sum is one for each grid point +! +!**************************************************************************************** + IF (is_modified) THEN + +! Test and exit if a fraction is negative + IF (MINVAL(pctsrf(:,:)) < 0.) THEN + WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime + WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:)) + WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:)) + CALL abort_gcm('change_srf_frac','Negative fraction',1) + END IF + +! Optional test on the incoming fraction + IF (test_sum) THEN + DO i= 1, klon + tmpsum = SUM(pctsrf(i,:)) + IF (ABS(1. - tmpsum) > 0.05) CALL abort_gcm('change_srf_frac','Total fraction not equal 1.',1) + END DO + END IF + +! Test for too small fractions of the sum land+landice and ocean+sea-ice + WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA) + pctsrf(:,is_ter) = 0. + pctsrf(:,is_lic) = 0. + END WHERE + + WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA) + pctsrf(:,is_oce) = 0. + pctsrf(:,is_sic) = 0. + END WHERE + +! Normalize to force total fraction to be equal one + DO i= 1, klon + tmpsum = SUM(pctsrf(i,:)) + DO nsrf = 1, nbsrf + pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum + END DO + END DO + +! Test for too small fractions at each sub-surface + WHERE (pctsrf(:,is_ter) < EPSFRA) + pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic) + pctsrf(:,is_ter) = 0. + END WHERE + + WHERE (pctsrf(:,is_lic) < EPSFRA) + pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic) + pctsrf(:,is_lic) = 0. + END WHERE + + WHERE (pctsrf(:,is_oce) < EPSFRA) + pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic) + pctsrf(:,is_oce) = 0. + END WHERE + + WHERE (pctsrf(:,is_sic) < EPSFRA) + pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic) + pctsrf(:,is_sic) = 0. + END WHERE + +!**************************************************************************************** +! 3) +! Initialize variables where a new fraction has appered, +! i.e. where new sea ice has been formed +! or where ice free ocean has appread in a grid cell +! +!**************************************************************************************** + CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb1, alb2, u10m, v10m, pbl_tke) + + ELSE + ! No modifcation should be done + pctsrf(:,:) = pctsrf_old(:,:) + + END IF ! is_modified + + END SUBROUTINE change_srf_frac + + +END MODULE change_srf_frac_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/chem.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/chem.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/chem.h (revision 1634) @@ -0,0 +1,14 @@ +! +! $Header$ +! + INTEGER idms, iso2, iso4, ih2s, idmso, imsa, ih2o2 + PARAMETER (idms=1, iso2=2, iso4=3) + PARAMETER (ih2s=4, idmso=5, imsa=6, ih2o2=7) + + REAL n_avogadro, masse_s, masse_so4, rho_water, rho_ice + PARAMETER (n_avogadro=6.02E23) !--molec mol-1 + PARAMETER (masse_s=32.0) !--g mol-1 + PARAMETER (masse_so4=96.0) !--g mol-1 + PARAMETER (rho_water=1000.0) !--kg m-3 + PARAMETER (rho_ice=500.0) !--kg m-3 + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clcdrag.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clcdrag.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clcdrag.F90 (revision 1634) @@ -0,0 +1,135 @@ +! +!$Id$ +! +SUBROUTINE clcdrag(knon, nsrf, paprs, pplay,& + u1, v1, t1, q1, & + tsurf, qsurf, rugos, & + pcfm, pcfh) + + USE dimphy + IMPLICIT NONE +! ================================================================= c +! +! Objet : calcul des cdrags pour le moment (pcfm) et +! les flux de chaleur sensible et latente (pcfh). +! +! ================================================================= c +! +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! u1-------input-R- vent zonal au 1er niveau du modele +! v1-------input-R- vent meridien au 1er niveau du modele +! t1-------input-R- temperature de l'air au 1er niveau du modele +! q1-------input-R- humidite de l'air au 1er niveau du modele +! tsurf------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite de l'air a la surface +! rugos---input-R- rugosite +! +! pcfm---output-R- cdrag pour le moment +! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible +! + INTEGER, INTENT(IN) :: knon, nsrf + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, t1, q1 + REAL, DIMENSION(klon), INTENT(IN) :: tsurf, qsurf + REAL, DIMENSION(klon), INTENT(IN) :: rugos + REAL, DIMENSION(klon), INTENT(OUT) :: pcfm, pcfh +! +! ================================================================= c +! + INCLUDE "YOMCST.h" + INCLUDE "YOETHF.h" + INCLUDE "indicesol.h" + INCLUDE "clesphys.h" +! +! Quelques constantes et options: +!!$PB REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2 + REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2 +! +! Variables locales : + INTEGER :: i + REAL :: zdu2, ztsolv + REAL :: ztvd, zscf + REAL :: zucf, zcr + REAL :: friv, frih + REAL, DIMENSION(klon) :: zcfm1, zcfm2 + REAL, DIMENSION(klon) :: zcfh1, zcfh2 + REAL, DIMENSION(klon) :: zcdn + REAL, DIMENSION(klon) :: zri + REAL, DIMENSION(klon) :: zgeop1 ! geopotentiel au 1er niveau du modele + LOGICAL, PARAMETER :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li +! +! Fonctions thermodynamiques et fonctions d'instabilite + REAL :: fsta, fins, x + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) + +! ================================================================= c +! +! Calculer le geopotentiel du premier couche de modele +! + DO i = 1, knon + zgeop1(i) = RD * t1(i) / (0.5*(paprs(i,1)+pplay(i,1))) & + * (paprs(i,1)-pplay(i,1)) + END DO +! ================================================================= c +! +! Calculer le frottement au sol (Cdrag) +! + DO i = 1, knon + zdu2 = MAX(cepdu2,u1(i)**2+v1(i)**2) + ztsolv = tsurf(i) * (1.0+RETV*qsurf(i)) + ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) & + *(1.+RETV*q1(i)) + zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd) + zcdn(i) = (ckap/LOG(1.+zgeop1(i)/(RG*rugos(i))))**2 + +!!$ IF (zri(i) .ge. 0.) THEN ! situation stable + IF (zri(i) .GT. 0.) THEN ! situation stable + zri(i) = MIN(20.,zri(i)) + IF (.NOT.zxli) THEN + zscf = SQRT(1.+cd*ABS(zri(i))) + FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1) + zcfm1(i) = zcdn(i) * FRIV + FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 ) +!!$ PB zcfh1(i) = zcdn(i) * FRIH +!!$ PB zcfh1(i) = f_cdrag_stable * zcdn(i) * FRIH + zcfh1(i) = f_cdrag_ter * zcdn(i) * FRIH + IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn(i) * FRIH +!!$ PB + pcfm(i) = zcfm1(i) + pcfh(i) = zcfh1(i) + ELSE + pcfm(i) = zcdn(i)* fsta(zri(i)) + pcfh(i) = zcdn(i)* fsta(zri(i)) + ENDIF + ELSE ! situation instable + IF (.NOT.zxli) THEN + zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) & + *(1.0+zgeop1(i)/(RG*rugos(i))))) + zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1) +!!$PB zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1) + zcfh2(i) = f_cdrag_ter*zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1) + pcfm(i) = zcfm2(i) + pcfh(i) = zcfh2(i) + ELSE + pcfm(i) = zcdn(i)* fins(zri(i)) + pcfh(i) = zcdn(i)* fins(zri(i)) + ENDIF + zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.) + IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25) + ENDIF + END DO + +! ================================================================= c + + ! IM cf JLD : on seuille cdrag_m et cdrag_h + IF (nsrf == is_oce) THEN + DO i=1,knon + pcfm(i)=MIN(pcfm(i),cdmmax) + pcfh(i)=MIN(pcfh(i),cdhmax) + END DO + END IF + +END SUBROUTINE clcdrag Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clesphys.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clesphys.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clesphys.h (revision 1634) @@ -0,0 +1,103 @@ + +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!..include cles_phys.h +! + LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf + LOGICAL ok_limitvrai + INTEGER nbapp_rad, iflag_con + REAL co2_ppm, co2_ppm0, solaire + REAL(kind=8) RCO2, RCH4, RN2O, RCFC11, RCFC12 + REAL(kind=8) RCO2_act, RCH4_act, RN2O_act, RCFC11_act, RCFC12_act + REAL(kind=8) CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt +!IM ajout CFMIP2/CMIP5 + REAL co2_ppm_per + REAL(kind=8) RCO2_per,RCH4_per,RN2O_per,RCFC11_per,RCFC12_per + REAL(kind=8) CH4_ppb_per,N2O_ppb_per,CFC11_ppt_per,CFC12_ppt_per + +!OM ---> correction du bilan d'eau global +!OM Correction sur precip KE + REAL cvl_corr +!OM Fonte calotte dans bilan eau + LOGICAL ok_lic_melt + +!IM simulateur ISCCP + INTEGER top_height, overlap +!IM seuils cdrm, cdrh + REAL cdmmax, cdhmax +!IM param. stabilite s/ terres et en dehors + REAL ksta, ksta_ter +!IM ok_kzmin : clef calcul Kzmin dans la CL de surface cf FH + LOGICAL ok_kzmin +!IM, MAFo fmagic, pmagic : parametres - additionnel et multiplicatif - +! pour regler l albedo sur ocean + REAL fmagic, pmagic +! Hauteur (imposee) du contenu en eau du sol + REAL qsol0 +! Frottement au sol (Cdrag) + Real f_cdrag_ter,f_cdrag_oce +! Rugoro + Real f_rugoro + +!IM lev_histhf : niveau sorties 6h +!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 +!IM pasphys : pas de temps de physique (secondes) + REAL pasphys + LOGICAL ok_histNMC(3) + REAL freq_outNMC(3) , freq_calNMC(3) + CHARACTER(len=4) type_run +! aer_type: pour utiliser un fichier constant dans readaerosol + CHARACTER*8 :: aer_type + LOGICAL ok_isccp, ok_regdyn + REAL lonmin_ins, lonmax_ins, latmin_ins, latmax_ins + REAL ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day + REAL ecrit_mth, ecrit_tra, ecrit_reg + REAL ecrit_LES + REAL freq_ISCCP, ecrit_ISCCP + REAL freq_COSP + LOGICAL :: ok_cosp,ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP + INTEGER :: ip_ebil_phy, iflag_rrtm + LOGICAL :: ok_strato + LOGICAL :: ok_hines + + COMMON/clesphys/cycle_diurne, soil_model, new_oliq, & + & ok_orodr, ok_orolf, ok_limitvrai, nbapp_rad, iflag_con & + & , co2_ppm, solaire & + & , RCO2, RCH4, RN2O, RCFC11, RCFC12 & + & , RCO2_act, RCH4_act, RN2O_act, RCFC11_act, RCFC12_act & + & , RCO2_per, RCH4_per, RN2O_per, RCFC11_per, RCFC12_per & + & , CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt & + & , CH4_ppb_per, N2O_ppb_per, CFC11_ppt_per, CFC12_ppt_per & + & , top_height, overlap, cdmmax, cdhmax, ksta, ksta_ter & + & , ok_kzmin, fmagic, pmagic & + & , f_cdrag_ter,f_cdrag_oce,f_rugoro & + & , lev_histhf, lev_histday, lev_histmth & + & , lev_histins, lev_histLES, lev_histdayNMC & + & , pasphys, ok_histNMC, freq_outNMC, freq_calNMC & + & , type_run, ok_isccp, ok_regdyn, ok_cosp & + & , ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP & + & , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins & + & , ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day & + & , ecrit_mth, ecrit_tra, ecrit_reg & + & , freq_ISCCP, ecrit_ISCCP, freq_COSP, ip_ebil_phy & + & , ok_lic_melt, cvl_corr, aer_type & + & , qsol0, iflag_rrtm, ok_strato,ok_hines,ecrit_LES & + & , co2_ppm0 + +!$OMP THREADPRIVATE(/clesphys/) + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clift.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clift.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clift.F (revision 1634) @@ -0,0 +1,72 @@ +! +! $Header$ +! + SUBROUTINE CLIFT (P,T,RR,RS,PLCL,DPLCLDT,DPLCLDQ) +C*************************************************************** +C* * +C* CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS * +C* DERIVATIVES RELATIVE TO T AND R * +C* (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) * +C* * +C* written by : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01 * +C* modified by : * +C*************************************************************** +C* +C*Arguments : +C* +C* Input : P = pressure of level from wich lifting is performed +C* T = temperature of level P +C* RR = vapour mixing ratio at level P +C* RS = vapour saturation mixing ratio at level P +C* +C* Output : PLCL = lifting condensation level +C* DPLCLDT = derivative of PLCL relative to T +C* DPLCLDQ = derivative of PLCL relative to R +C* +ccccccccccccccccccccccc +c constantes coherentes avec le modele du Centre Europeen +c RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644 +c RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153 +c CPD = 3.5 * RD +c CPV = 4.0 * RV +c CL = 4218.0 +c CI=2090.0 +c CPVMCL=CL-CPV +c CLMCI=CL-CI +c EPS=RD/RV +c ALV0=2.5008E+06 +c ALF0=3.34E+05 +c +c on utilise les constantes thermo du Centre Europeen: (sb) +c +#include "YOMCST.h" +c + CPD = RCPD + CPV = RCPV + CL = RCW + CPVMCL = CL-CPV + EPS = RD/RV + ALV0 = RLVTT +c +c +c Bolton formula coefficients : + A = 1669.0 + B = 122.0 +c + RH=RR/RS + CHI=T/(A-B*RH-T) + PLCL=P*(RH**CHI) +c + ALV = ALV0 - CPVMCL*(T-273.15) +c +c -- sb: correction: +c DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) ) + DPLCLDQ = PLCL*CHI*( 1./RR + B*CHI/T/RS*ALOG(RH) ) +c sb -- +c + DPLCLDT = PLCL*CHI*((A-B*RH*(1.+ALV/RV/T))/T**2*CHI*ALOG(RH) + $ - ALV/RV/T**2 ) +c +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/climb_hq_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/climb_hq_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/climb_hq_mod.F90 (revision 1634) @@ -0,0 +1,377 @@ +MODULE climb_hq_mod +! +! Module to solve the verctical diffusion of "q" and "H"; +! specific humidity and potential energi. +! + USE dimphy + + IMPLICIT NONE + SAVE + PRIVATE + PUBLIC :: climb_hq_down, climb_hq_up + + REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah + !$OMP THREADPRIVATE(gamaq,gamah) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q + !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H + !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_Q, Bcoef_Q + !$OMP THREADPRIVATE(Acoef_Q, Bcoef_Q) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_H, Bcoef_H + !$OMP THREADPRIVATE(Acoef_H, Bcoef_H) + REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq + !$OMP THREADPRIVATE(Kcoefhq) + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, & + delp, temp, q, dtime, & + Acoef_H_out, Acoef_Q_out, Bcoef_H_out, Bcoef_Q_out) + + INCLUDE "YOMCST.h" +! This routine calculates recursivly the coefficients C and D +! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is +! the index of the vertical layer. +! +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon,klev), INTENT(IN) :: coefhq + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: temp, delp ! temperature + REAL, DIMENSION(klon,klev), INTENT(IN) :: q + REAL, INTENT(IN) :: dtime + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_H_out + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_Q_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_H_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_Q_out + +! Local variables +!**************************************************************************************** + LOGICAL, SAVE :: first=.TRUE. + !$OMP THREADPRIVATE(first) + REAL, DIMENSION(klon,klev) :: local_H + REAL, DIMENSION(klon) :: psref + REAL :: delz, pkh + INTEGER :: k, i, ierr + +! Include +!**************************************************************************************** + INCLUDE "compbl.h" + + +!**************************************************************************************** +! 1) +! Allocation at first time step only +! +!**************************************************************************************** + + IF (first) THEN + first=.FALSE. + ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr + + ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr + + ALLOCATE(Ccoef_H(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Ccoef_H, ierr=', ierr + + ALLOCATE(Dcoef_H(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Dcoef_H, ierr=', ierr + + ALLOCATE(Acoef_Q(klon), Bcoef_Q(klon), Acoef_H(klon), Bcoef_H(klon), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Acoef_X and Bcoef_X, ierr=', ierr + + ALLOCATE(Kcoefhq(klon,klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Kcoefhq, ierr=', ierr + + ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr + + ALLOCATE(gamah(1:klon,2:klev), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr + END IF + +!**************************************************************************************** +! 2) +! Definition of the coeficient K +! +!**************************************************************************************** + Kcoefhq(:,:) = 0.0 + DO k = 2, klev + DO i = 1, knon + Kcoefhq(i,k) = & + coefhq(i,k)*RG*RG*dtime /(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2 + ENDDO + ENDDO + +!**************************************************************************************** +! 3) +! Calculation of gama for "Q" and "H" +! +!**************************************************************************************** +! surface pressure is used as reference + psref(:) = paprs(:,1) + +! definition of gama + IF (iflag_pbl == 1) THEN + gamaq(:,:) = 0.0 + gamah(:,:) = -1.0e-03 + gamah(:,2) = -2.5e-03 + +! conversion de gama + DO k = 2, klev + DO i = 1, knon + delz = RD * (temp(i,k-1)+temp(i,k)) / & + 2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k)) + pkh = (psref(i)/paprs(i,k))**RKAPPA + +! convertie gradient verticale d'humidite specifique en difference d'humidite specifique entre centre de couches + gamaq(i,k) = gamaq(i,k) * delz +! convertie gradient verticale de temperature en difference de temperature potentielle entre centre de couches + gamah(i,k) = gamah(i,k) * delz * RCPD * pkh + ENDDO + ENDDO + + ELSE + gamaq(:,:) = 0.0 + gamah(:,:) = 0.0 + ENDIF + + +!**************************************************************************************** +! 4) +! Calculte the coefficients C and D for specific humidity, q +! +!**************************************************************************************** + + CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), delp(:,:), q(:,:), & + Ccoef_Q(:,:), Dcoef_Q(:,:), Acoef_Q, Bcoef_Q) + +!**************************************************************************************** +! 5) +! Calculte the coefficients C and D for potentiel entalpie, H +! +!**************************************************************************************** + local_H(:,:) = 0.0 + + DO k=1,klev + DO i = 1, knon + ! convertie la temperature en entalpie potentielle + local_H(i,k) = RCPD * temp(i,k) * & + (psref(i)/pplay(i,k))**RKAPPA + ENDDO + ENDDO + + CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), delp(:,:), local_H(:,:), & + Ccoef_H(:,:), Dcoef_H(:,:), Acoef_H, Bcoef_H) + +!**************************************************************************************** +! 6) +! Return the first layer in output variables +! +!**************************************************************************************** + Acoef_H_out = Acoef_H + Bcoef_H_out = Bcoef_H + Acoef_Q_out = Acoef_Q + Bcoef_Q_out = Bcoef_Q + + END SUBROUTINE climb_hq_down +! +!**************************************************************************************** +! + SUBROUTINE calc_coef(knon, Kcoef, gama, delp, X, Ccoef, Dcoef, Acoef, Bcoef) +! +! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1) +! where X is H or Q, and k the vertical level k=1,klev +! + INCLUDE "YOMCST.h" +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon,klev), INTENT(IN) :: Kcoef, delp + REAL, DIMENSION(klon,klev), INTENT(IN) :: X + REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef, Bcoef + REAL, DIMENSION(klon,klev), INTENT(OUT) :: Ccoef, Dcoef + +! Local variables +!**************************************************************************************** + INTEGER :: k, i + REAL :: buf + +!**************************************************************************************** +! Niveau au sommet, k=klev +! +!**************************************************************************************** + Ccoef(:,:) = 0.0 + Dcoef(:,:) = 0.0 + + DO i = 1, knon + buf = delp(i,klev) + Kcoef(i,klev) + + Ccoef(i,klev) = (X(i,klev)*delp(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf + Dcoef(i,klev) = Kcoef(i,klev)/buf + END DO + + +!**************************************************************************************** +! Niveau (klev-1) <= k <= 2 +! +!**************************************************************************************** + + DO k=(klev-1),2,-1 + DO i = 1, knon + buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1)) + Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + & + Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf + Dcoef(i,k) = Kcoef(i,k)/buf + END DO + END DO + +!**************************************************************************************** +! Niveau k=1 +! +!**************************************************************************************** + + DO i = 1, knon + buf = delp(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2)) + Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf + Bcoef(i) = -1. * RG / buf + END DO + + END SUBROUTINE calc_coef +! +!**************************************************************************************** +! + SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, & + flx_q1, flx_h1, paprs, pplay, & + flux_q, flux_h, d_q, d_t) +! +! This routine calculates the flux and tendency of the specific humidity q and +! the potential engergi H. +! The quantities q and H are calculated according to +! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients +! C and D are known from before and k is index of the vertical layer. +! + INCLUDE "YOMCST.h" +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_old, q_old + REAL, DIMENSION(klon), INTENT(IN) :: flx_q1, flx_h1 + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: flux_q, flux_h, d_q, d_t + +! Local variables +!**************************************************************************************** + LOGICAL, SAVE :: last=.FALSE. + REAL, DIMENSION(klon,klev) :: h_new, q_new + REAL, DIMENSION(klon) :: psref + INTEGER :: k, i, ierr + +!**************************************************************************************** +! 1) +! Definition of some variables +! +!**************************************************************************************** + flux_q(:,:) = 0.0 + flux_h(:,:) = 0.0 + d_q(:,:) = 0.0 + d_t(:,:) = 0.0 + + psref(1:knon) = paprs(1:knon,1) + +!**************************************************************************************** +! 2) +! Calculation of Q and H +! +!**************************************************************************************** + +!- First layer + q_new(1:knon,1) = Acoef_Q(1:knon) + Bcoef_Q(1:knon)*flx_q1(1:knon)*dtime + h_new(1:knon,1) = Acoef_H(1:knon) + Bcoef_H(1:knon)*flx_h1(1:knon)*dtime + +!- All the other layers + DO k = 2, klev + DO i = 1, knon + q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1) + h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1) + END DO + END DO +!**************************************************************************************** +! 3) +! Calculation of the flux for Q and H +! +!**************************************************************************************** + +!- The flux at first layer, k=1 + flux_q(1:knon,1)=flx_q1(1:knon) + flux_h(1:knon,1)=flx_h1(1:knon) + +!- The flux at all layers above surface + DO k = 2, klev + DO i = 1, knon + flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * & + (q_new(i,k)-q_new(i,k-1)+gamaq(i,k)) + + flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * & + (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) + END DO + END DO + +!**************************************************************************************** +! 4) +! Calculation of tendency for Q and H +! +!**************************************************************************************** + + DO k = 1, klev + DO i = 1, knon + d_t(i,k) = h_new(i,k)/(psref(i)/pplay(i,k))**RKAPPA/RCPD - t_old(i,k) + d_q(i,k) = q_new(i,k) - q_old(i,k) + END DO + END DO + +!**************************************************************************************** +! Some deallocations +! +!**************************************************************************************** + IF (last) THEN + DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H, ierr=', ierr + DEALLOCATE(Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H, ierr=', ierr + DEALLOCATE(gamaq, gamah,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate gamaq, gamah, ierr=', ierr + DEALLOCATE(Kcoefhq,stat=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in dealllocate Kcoefhq, ierr=', ierr + END IF + END SUBROUTINE climb_hq_up +! +!**************************************************************************************** +! +END MODULE climb_hq_mod + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/climb_wind_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/climb_wind_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/climb_wind_mod.F90 (revision 1634) @@ -0,0 +1,307 @@ +! +MODULE climb_wind_mod +! +! Module to solve the verctical diffusion of the wind components "u" and "v". +! + USE dimphy + + IMPLICIT NONE + + SAVE + PRIVATE + + REAL, DIMENSION(:), ALLOCATABLE :: alf1, alf2 + !$OMP THREADPRIVATE(alf1,alf2) + REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefm + !$OMP THREADPRIVATE(Kcoefm) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_U, Dcoef_U + !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U) + REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_V, Dcoef_V + !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_U, Bcoef_U + !$OMP THREADPRIVATE(Acoef_U, Bcoef_U) + REAL, DIMENSION(:), ALLOCATABLE :: Acoef_V, Bcoef_V + !$OMP THREADPRIVATE(Acoef_V, Bcoef_V) + LOGICAL :: firstcall=.TRUE. + !$OMP THREADPRIVATE(firstcall) + + + PUBLIC :: climb_wind_down, climb_wind_up + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE climb_wind_init + + INTEGER :: ierr + CHARACTER(len = 20) :: modname = 'climb_wind_init' + +!**************************************************************************************** +! Allocation of global module variables +! +!**************************************************************************************** + + ALLOCATE(alf1(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1) + + ALLOCATE(alf2(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1) + + ALLOCATE(Kcoefm(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Kcoefm',1) + + ALLOCATE(Ccoef_U(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Ccoef_U',1) + + ALLOCATE(Dcoef_U(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_U',1) + + ALLOCATE(Ccoef_V(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Ccoef_V',1) + + ALLOCATE(Dcoef_V(klon,klev), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_V',1) + + ALLOCATE(Acoef_U(klon), Bcoef_U(klon), Acoef_V(klon), Bcoef_V(klon), STAT=ierr) + IF ( ierr /= 0 ) PRINT*,' pb in allloc Acoef_U and Bcoef_U, ierr=', ierr + + firstcall=.FALSE. + + END SUBROUTINE climb_wind_init +! +!**************************************************************************************** +! + SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old, & + Acoef_U_out, Acoef_V_out, Bcoef_U_out, Bcoef_V_out) +! +! This routine calculates for the wind components u and v, +! recursivly the coefficients C and D in equation +! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer. +! +! + INCLUDE "YOMCST.h" +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon,klev), INTENT(IN) :: coef_in + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! pres au milieu de couche (Pa) + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa) + REAL, DIMENSION(klon,klev), INTENT(IN) :: temp ! temperature + REAL, DIMENSION(klon,klev), INTENT(IN) :: delp + REAL, DIMENSION(klon,klev), INTENT(IN) :: u_old + REAL, DIMENSION(klon,klev), INTENT(IN) :: v_old + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_U_out + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef_V_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_U_out + REAL, DIMENSION(klon), INTENT(OUT) :: Bcoef_V_out + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: u1lay, v1lay + INTEGER :: k, i + + +!**************************************************************************************** +! Initialize module + IF (firstcall) CALL climb_wind_init + +!**************************************************************************************** +! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1) +! +!**************************************************************************************** +! - Define alpha (alf1 and alf2) + alf1(:) = 1.0 + alf2(:) = 1.0 - alf1(:) + +! - Calculate the coefficients K + Kcoefm(:,:) = 0.0 + DO k = 2, klev + DO i=1,knon + Kcoefm(i,k) = coef_in(i,k)*RG*RG*dtime/(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2 + END DO + END DO + +! - Calculate the coefficients C and D, component "u" + CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), & + u_old(:,:), alf1(:), alf2(:), & + Ccoef_U(:,:), Dcoef_U(:,:), Acoef_U(:), Bcoef_U(:)) + +! - Calculate the coefficients C and D, component "v" + CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), & + v_old(:,:), alf1(:), alf2(:), & + Ccoef_V(:,:), Dcoef_V(:,:), Acoef_V(:), Bcoef_V(:)) + +!**************************************************************************************** +! 6) +! Return the first layer in output variables +! +!**************************************************************************************** + Acoef_U_out = Acoef_U + Bcoef_U_out = Bcoef_U + Acoef_V_out = Acoef_V + Bcoef_V_out = Bcoef_V + + END SUBROUTINE climb_wind_down +! +!**************************************************************************************** +! + SUBROUTINE calc_coef(knon, Kcoef, delp, X, alfa1, alfa2, Ccoef, Dcoef, Acoef, Bcoef) +! +! Find the coefficients C and D in fonction of alfa, K and delp +! +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon,klev), INTENT(IN) :: Kcoef, delp + REAL, DIMENSION(klon,klev), INTENT(IN) :: X + REAL, DIMENSION(klon), INTENT(IN) :: alfa1, alfa2 + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: Acoef, Bcoef + REAL, DIMENSION(klon,klev), INTENT(OUT) :: Ccoef, Dcoef + +! local variables +!**************************************************************************************** + INTEGER :: k, i + REAL :: buf + + INCLUDE "YOMCST.h" +!**************************************************************************************** +! + +! Calculate coefficients C and D at top level, k=klev +! + Ccoef(:,:) = 0.0 + Dcoef(:,:) = 0.0 + + DO i = 1, knon + buf = delp(i,klev) + Kcoef(i,klev) + + Ccoef(i,klev) = X(i,klev)*delp(i,klev)/buf + Dcoef(i,klev) = Kcoef(i,klev)/buf + END DO + +! +! Calculate coefficients C and D at top level (klev-1) <= k <= 2 +! + DO k=(klev-1),2,-1 + DO i = 1, knon + buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1)) + + Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1))/buf + Dcoef(i,k) = Kcoef(i,k)/buf + END DO + END DO + +! +! Calculate coeffiecent A and B at surface +! + DO i = 1, knon + buf = delp(i,1) + Kcoef(i,2)*(1-Dcoef(i,2)) + Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*Ccoef(i,2))/buf + Bcoef(i) = -RG/buf + END DO + + END SUBROUTINE calc_coef +! +!**************************************************************************************** +! + + SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, flx_u1, flx_v1, & + flx_u_new, flx_v_new, d_u_new, d_v_new) +! +! Diffuse the wind components from the surface layer and up to the top layer. +! Coefficents A, B, C and D are known from before. Start values for the diffusion are the +! momentum fluxes at surface. +! +! u(k=1) = A + B*flx*dtime +! u(k) = C(k) + D(k)*u(k-1) [2 <= k <= klev] +! +!**************************************************************************************** + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon,klev), INTENT(IN) :: u_old + REAL, DIMENSION(klon,klev), INTENT(IN) :: v_old + REAL, DIMENSION(klon), INTENT(IN) :: flx_u1, flx_v1 ! momentum flux + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new + REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon,klev) :: u_new, v_new + INTEGER :: k, i + +! +!**************************************************************************************** + +! Niveau 1 + DO i = 1, knon + u_new(i,1) = Acoef_U(i) + Bcoef_U(i)*flx_u1(i)*dtime + v_new(i,1) = Acoef_V(i) + Bcoef_V(i)*flx_v1(i)*dtime + END DO + +! Niveau 2 jusqu'au sommet klev + DO k = 2, klev + DO i=1, knon + u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1) + v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1) + END DO + END DO + +!**************************************************************************************** +! Calcul flux +! +!== flux_u/v est le flux de moment angulaire (positif vers bas) +!== dont l'unite est: (kg m/s)/(m**2 s) +! +!**************************************************************************************** +! + flx_u_new(:,:) = 0.0 + flx_v_new(:,:) = 0.0 + + flx_u_new(1:knon,1)=flx_u1(1:knon) + flx_v_new(1:knon,1)=flx_v1(1:knon) + +! Niveau 2->klev + DO k = 2, klev + DO i = 1, knon + flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * & + (u_new(i,k)-u_new(i,k-1)) + + flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * & + (v_new(i,k)-v_new(i,k-1)) + END DO + END DO + +!**************************************************************************************** +! Calcul tendances +! +!**************************************************************************************** + d_u_new(:,:) = 0.0 + d_v_new(:,:) = 0.0 + DO k = 1, klev + DO i = 1, knon + d_u_new(i,k) = u_new(i,k) - u_old(i,k) + d_v_new(i,k) = v_new(i,k) - v_old(i,k) + END DO + END DO + + END SUBROUTINE climb_wind_up +! +!**************************************************************************************** +! +END MODULE climb_wind_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clouds_gno.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clouds_gno.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/clouds_gno.F (revision 1634) @@ -0,0 +1,263 @@ +! +! $Header$ +! +C +C================================================================================ +C + SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF) + IMPLICIT NONE +C +C-------------------------------------------------------------------------------- +C +C Inputs: +C +C ND----------: Number of vertical levels +C R--------ND-: Domain-averaged mixing ratio of total water +C RS-------ND-: Mean saturation humidity mixing ratio within the gridbox +C QSUB-----ND-: Mixing ratio of condensed water within clouds associated +C with SUBGRID-SCALE condensation processes (here, it is +C predicted by the convection scheme) +C Outputs: +C +C PTCONV-----ND-: Point convectif = TRUE +C RATQSC-----ND-: Largeur normalisee de la distribution +C CLDF-----ND-: Fraction nuageuse +C +C-------------------------------------------------------------------------------- + + + INTEGER klon,ND + REAL R(klon,ND), RS(klon,ND), QSUB(klon,ND) + LOGICAL PTCONV(klon,ND) + REAL RATQSC(klon,ND) + REAL CLDF(klon,ND) + +c -- parameters controlling the iteration: +c -- nmax : maximum nb of iterations (hopefully never reached) +c -- epsilon : accuracy of the numerical resolution +c -- vmax : v-value above which we use an asymptotic expression for ERF(v) + + INTEGER nmax + PARAMETER ( nmax = 10) + REAL epsilon, vmax0, vmax(klon) + PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) + + REAL min_mu, min_Q + PARAMETER ( min_mu = 1.e-12, min_Q=1.e-12 ) + + INTEGER i,K, n, m + REAL mu(klon), qsat, delta(klon), beta(klon) + real zu2,zv2 + REAL xx(klon), aux(klon), coeff, block + REAL dist, fprime, det + REAL pi, u, v, erfcu, erfcv + REAL xx1, xx2 + real erf,hsqrtlog_2,v2 + real sqrtpi,sqrt2,zx1,zx2,exdel +c lconv = true si le calcul a converge (entre autre si qsub < min_q) + LOGICAL lconv(klon) + +!cdir arraycomb + cldf (1:klon,1:ND)=0.0 ! cym + ratqsc(1:klon,1:ND)=0.0 + ptconv(1:klon,1:ND)=.false. +!cdir end arraycomb + + pi = ACOS(-1.) + sqrtpi=sqrt(pi) + sqrt2=sqrt(2.) + hsqrtlog_2=0.5*SQRT(log(2.)) + + DO 500 K = 1, ND + + do i=1,klon ! vector + mu(i) = R(i,K) + mu(i) = MAX(mu(i),min_mu) + qsat = RS(i,K) + qsat = MAX(qsat,min_mu) + delta(i) = log(mu(i)/qsat) +c enddo ! vector + +C +C *** There is no subgrid-scale condensation; *** +C *** the scheme becomes equivalent to an "all-or-nothing" *** +C *** large-scale condensation scheme. *** +C + +C +C *** Some condensation is produced at the subgrid-scale *** +C *** *** +C *** PDF = generalized log-normal distribution (GNO) *** +C *** (k<0 because a lower bound is considered for the PDF) *** +C *** *** +C *** -> Determine x (the parameter k of the GNO PDF) such *** +C *** that the contribution of subgrid-scale processes to *** +C *** the in-cloud water content is equal to QSUB(K) *** +C *** (equations (13), (14), (15) + Appendix B of the paper) *** +C *** *** +C *** Here, an iterative method is used for this purpose *** +C *** (other numerical methods might be more efficient) *** +C *** *** +C *** NB: the "error function" is called ERF *** +C *** (ERF in double precision) *** +C + +c On commence par eliminer les cas pour lesquels on n'a pas +c suffisamment d'eau nuageuse. + +c do i=1,klon ! vector + + IF ( QSUB(i,K) .lt. min_Q ) THEN + ptconv(i,k)=.false. + ratqsc(i,k)=0. + lconv(i) = .true. + +c Rien on a deja initialise + + ELSE + + lconv(i) = .FALSE. + vmax(i) = vmax0 + + beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) ) + +c -- roots of equation v > vmax: + + det = delta(i) + vmax(i)*vmax(i) + if (det.LE.0.0) vmax(i) = vmax0 + 1.0 + det = delta(i) + vmax(i)*vmax(i) + + if (det.LE.0.) then + xx(i) = -0.0001 + else + zx1=-sqrt2*vmax(i) + zx2=SQRT(1.0+delta(i)/(vmax(i)*vmax(i))) + xx1=zx1*(1.0-zx2) + xx2=zx1*(1.0+zx2) + xx(i) = 1.01 * xx1 + if ( xx1 .GE. 0.0 ) xx(i) = 0.5*xx2 + endif + if (delta(i).LT.0.) xx(i) = -hsqrtlog_2 + + ENDIF + + enddo ! vector + +c---------------------------------------------------------------------- +c Debut des nmax iterations pour trouver la solution. +c---------------------------------------------------------------------- + + DO n = 1, nmax + + do i=1,klon ! vector + if (.not.lconv(i)) then + + u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2) + v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2) + v2 = v*v + + IF ( v .GT. vmax(i) ) THEN + + IF ( ABS(u) .GT. vmax(i) + : .AND. delta(i) .LT. 0. ) THEN + +c -- use asymptotic expression of erf for u and v large: +c ( -> analytic solution for xx ) + exdel=beta(i)*EXP(delta(i)) + aux(i) = 2.0*delta(i)*(1.-exdel) + : /(1.+exdel) + if (aux(i).lt.0.) then +c print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i) + aux(i)=0. + endif + xx(i) = -SQRT(aux(i)) + block = EXP(-v*v) / v / sqrtpi + dist = 0.0 + fprime = 1.0 + + ELSE + +c -- erfv -> 1.0, use an asymptotic expression of erfv for v large: + + erfcu = 1.0-ERF(u) +c !!! ATTENTION : rajout d'un seuil pour l'exponentiel + aux(i) = sqrtpi*erfcu*EXP(min(v2,100.)) + coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2) + block = coeff * EXP(-v2) / v / sqrtpi + dist = v * aux(i) / coeff - beta(i) + fprime = 2.0 / xx(i) * (v2) + : * ( EXP(-delta(i)) - u * aux(i) / coeff ) + : / coeff + + ENDIF ! ABS(u) + + ELSE + +c -- general case: + + erfcu = 1.0-ERF(u) + erfcv = 1.0-ERF(v) + block = erfcv + dist = erfcu / erfcv - beta(i) + zu2=u*u + zv2=v2 + if(zu2.gt.20..or. zv2.gt.20.) then +c print*,'ATTENTION !!! xx(',i,') =', xx(i) +c print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF', +c .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k), +c .CLDF(i,k) +c print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i) + zu2=20. + zv2=20. + fprime = 0. + else + fprime = 2. /sqrtpi /xx(i) /(erfcv*erfcv) + : * ( erfcv*v*EXP(-zu2) + : - erfcu*u*EXP(-zv2) ) + endif + ENDIF ! x + +c -- test numerical convergence: + +! if (beta(i).lt.1.e-10) then +! print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i) +! stop +! endif + if (abs(fprime).lt.1.e-11) then +! print*,'avant test fprime<.e-11 ' +! s ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i) +! print*,'klon,ND,R,RS,QSUB', +! s klon,ND,R(i,k),rs(i,k),qsub(i,k) + fprime=sign(1.e-11,fprime) + endif + + + if ( ABS(dist/beta(i)) .LT. epsilon ) then +c print*,'v-u **2',(v(i)-u(i))**2 +c print*,'exp v-u **2',exp((v(i)-u(i))**2) + ptconv(i,K) = .TRUE. + lconv(i)=.true. +c borne pour l'exponentielle + ratqsc(i,k)=min(2.*(v-u)*(v-u),20.) + ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.) + CLDF(i,K) = 0.5 * block + else + xx(i) = xx(i) - dist/fprime + endif +c print*,'apres test ',i,k,lconv(i) + + endif ! lconv + enddo ! vector + +c---------------------------------------------------------------------- +c Fin des nmax iterations pour trouver la solution. + ENDDO ! n +c---------------------------------------------------------------------- + +500 CONTINUE ! K + + RETURN + END + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cloudth.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cloudth.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cloudth.F90 (revision 1634) @@ -0,0 +1,243 @@ + SUBROUTINE cloudth(ngrid,klev,ind2, & + & ztv,po,zqta,fraca, & + & qcloud,ctot,zpspsk,paprs,ztla,zthl, & + & ratqs,zqs,t) + + + IMPLICIT NONE + + +!=========================================================================== +! Auteur : Arnaud Octavio Jam (LMD/CNRS) +! Date : 25 Mai 2010 +! Objet : calcule les valeurs de qc et rneb dans les thermiques +!=========================================================================== + + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +#include "thermcell.h" + + INTEGER itap,ind1,ind2 + INTEGER ngrid,klev,klon,l,ig + + REAL ztv(ngrid,klev) + REAL po(ngrid) + REAL zqenv(ngrid) + REAL zqta(ngrid,klev) + + REAL fraca(ngrid,klev+1) + REAL zpspsk(ngrid,klev) + REAL paprs(ngrid,klev+1) + REAL ztla(ngrid,klev) + REAL zthl(ngrid,klev) + + REAL zqsatth(ngrid,klev) + REAL zqsatenv(ngrid,klev) + + + REAL sigma1(ngrid,klev) + REAL sigma2(ngrid,klev) + REAL qlth(ngrid,klev) + REAL qlenv(ngrid,klev) + REAL qltot(ngrid,klev) + REAL cth(ngrid,klev) + REAL cenv(ngrid,klev) + REAL ctot(ngrid,klev) + REAL rneb(ngrid,klev) + REAL t(ngrid,klev) + REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi + REAL rdd,cppd,Lv + REAL alth,alenv,ath,aenv + REAL sth,senv,sigma1s,sigma2s,xth,xenv + REAL Tbef,zdelta,qsatbef,zcor + REAL alpha,qlbef + REAL ratqs(ngrid,klev) ! determine la largeur de distribution de vapeur + + REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid) + REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) + REAL zqs(ngrid), qcloud(ngrid) + REAL erf + + + + + +! print*,ngrid,klev,ind1,ind2,ztv(ind1,ind2),po(ind1),zqta(ind1,ind2), & +! & fraca(ind1,ind2),zpspsk(ind1,ind2),paprs(ind1,ind2),ztla(ind1,ind2),zthl(ind1,ind2), & +! & 'verif' + + +! LOGICAL active(ngrid) + +!----------------------------------------------------------------------------------------------------------------- +! Initialisation des variables réelles +!----------------------------------------------------------------------------------------------------------------- + sigma1(:,:)=0. + sigma2(:,:)=0. + qlth(:,:)=0. + qlenv(:,:)=0. + qltot(:,:)=0. + rneb(:,:)=0. + qcloud(:)=0. + cth(:,:)=0. + cenv(:,:)=0. + ctot(:,:)=0. + qsatmmussig1=0. + qsatmmussig2=0. + rdd=287.04 + cppd=1005.7 + pi=3.14159 + Lv=2.5e6 + sqrt2pi=sqrt(2.*pi) + + + +!------------------------------------------------------------------------------------------------------------------ +! Calcul de la fraction du thermique et des écart-types des distributions +!------------------------------------------------------------------------------------------------------------------ + do ind1=1,ngrid + + if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then + + zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2)) + + +! zqenv(ind1)=po(ind1) + Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + zqsatenv(ind1,ind2)=qsatbef + + + + + alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) + aenv=1./(1.+(alenv*Lv/cppd)) + senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) + + + + + Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + zqsatth(ind1,ind2)=qsatbef + + alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2) + ath=1./(1.+(alth*Lv/cppd)) + sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2)) + + + +!----------------------------------------------------------------------------------------------------------------- +! Calcul des écart-types pour s +!----------------------------------------------------------------------------------------------------------------- + + sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1) + sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.002*zqta(ind1,ind2) + + +!----------------------------------------------------------------------------------------------------------------- +! Calcul de l'eau condensée et de la couverture nuageuse +!----------------------------------------------------------------------------------------------------------------- + sqrt2pi=sqrt(2.*pi) + xth=sth/(sqrt(2.)*sigma2s) + xenv=senv/(sqrt(2.)*sigma1s) + cth(ind1,ind2)=0.5*(1.+1.*erf(xth)) + cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv)) + ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2) +! ctot(ind1,ind2)=alpha*cth(ind1,ind2)+(1.-1.*alpha)*cenv(ind1,ind2) + + + + qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth(ind1,ind2)) + qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2)) + qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2) +! qltot(ind1,ind2)=alpha*qlth(ind1,ind2)+(1.-1.*alpha)*qlenv(ind1,ind2) + + +! print*,senv,sth,sigma1s,sigma2s,fraca(ind1,ind2),'senv et sth et sig1 et sig2 et alpha' + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (ctot(ind1,ind2).lt.1.e-10) then + ctot(ind1,ind2)=0. + qcloud(ind1)=zqsatenv(ind1,ind2) + + else + + ctot(ind1,ind2)=ctot(ind1,ind2) + qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1) + + endif + + +! print*,sth,sigma2s,qlth(ind1,ind2),ctot(ind1,ind2),qltot(ind1,ind2),'verif' + + + else ! gaussienne environnement seule + + zqenv(ind1)=po(ind1) + Tbef=t(ind1,ind2) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + zqsatenv(ind1,ind2)=qsatbef + + +! qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.) + zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd) + alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) + aenv=1./(1.+(alenv*Lv/cppd)) + senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) + + + sigma1s=ratqs(ind1,ind2)*zqenv(ind1) + + sqrt2pi=sqrt(2.*pi) + xenv=senv/(sqrt(2.)*sigma1s) + ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv)) + qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2)) + + if (ctot(ind1,ind2).lt.1.e-3) then + ctot(ind1,ind2)=0. + qcloud(ind1)=zqsatenv(ind1,ind2) + + else + + ctot(ind1,ind2)=ctot(ind1,ind2) + qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2) + + endif + + + + + + + endif + enddo + + return + end + + + + + + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cltrac.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cltrac.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cltrac.F90 (revision 1634) @@ -0,0 +1,140 @@ +! +! $Id $ +! +SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp,d_tr) + USE dimphy + IMPLICIT NONE +!====================================================================== +! Auteur(s): O. Boucher (LOA/LMD) date: 19961127 +! inspire de clvent +! Objet: diffusion verticale de traceurs avec flux fixe a la surface +! ou/et flux du type c-drag +! +! Arguments: +!----------- +! dtime....input-R- intervalle du temps (en secondes) +! coef.....input-R- le coefficient d'echange (m**2/s) l>1 +! t........input-R- temperature (K) +! tr.......input-R- la q. de traceurs +! flux.....input-R- le flux de traceurs a la surface +! paprs....input-R- pression a inter-couche (Pa) +! pplay....input-R- pression au milieu de couche (Pa) +! delp.....input-R- epaisseur de couche (Pa) +! cdrag....input-R- cdrag pour le flux de surface (non active) +! tr0......input-R- traceurs a la surface ou dans l'ocean (non active) +! d_tr.....output-R- le changement de tr +! flux_tr..output-R- flux de tr +!====================================================================== + include "YOMCST.h" +! +! Entree +! + REAL,INTENT(IN) :: dtime + REAL,DIMENSION(klon,klev),INTENT(IN) :: coef + REAL,DIMENSION(klon,klev),INTENT(IN) :: t, tr + REAL,DIMENSION(klon),INTENT(IN) :: flux !(at/s/m2) + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay, delp +! +! Sorties +! + REAL ,DIMENSION(klon,klev),INTENT(OUT) :: d_tr +! REAL ,DIMENSION(klon,klev),INTENT(OUT) :: flux_tr +! +! Local +! + INTEGER :: i, k + REAL,DIMENSION(klon) :: cdrag, tr0 + REAL,DIMENSION(klon,klev) :: zx_ctr + REAL,DIMENSION(klon,klev) :: zx_dtr + REAL,DIMENSION(klon) :: zx_buf + REAL,DIMENSION(klon,klev) :: zx_coef + REAL,DIMENSION(klon,klev) :: local_tr + REAL,DIMENSION(klon) :: zx_alf1,zx_alf2,zx_flux + +!====================================================================== + + DO k = 1, klev + DO i = 1, klon + local_tr(i,k) = tr(i,k) + ENDDO + ENDDO + +!====================================================================== + + DO i = 1, klon + zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alf2(i) = 1.0 - zx_alf1(i) + zx_flux(i) = -flux(i)*dtime*RG +! Pour le moment le flux est prescrit cdrag et zx_coef(1) vaut 0 + cdrag(i) = 0.0 + tr0(i) = 0.0 + zx_coef(i,1) = cdrag(i)*dtime*RG + zx_ctr(i,1)=0. + zx_dtr(i,1)=0. + ENDDO + +!====================================================================== + + DO k = 2, klev + DO i = 1, klon + zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2 + zx_coef(i,k) = zx_coef(i,k)*dtime*RG + ENDDO + ENDDO + +!====================================================================== + + DO i = 1, klon + zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2) + ! + zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+ & + zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i) + ! + zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / & + zx_buf(i) + ENDDO + + DO k = 3, klev + DO i = 1, klon + zx_buf(i) = delp(i,k-1) + zx_coef(i,k) & + + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1)) + zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1) & + +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i) + zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i) + ENDDO + ENDDO + + DO i = 1, klon + local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev) & + +zx_coef(i,klev)*zx_ctr(i,klev) ) & + / ( delp(i,klev) + zx_coef(i,klev) & + -zx_coef(i,klev)*zx_dtr(i,klev) ) + ENDDO + + DO k = klev-1, 1, -1 + DO i = 1, klon + local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1) + ENDDO + ENDDO + +!====================================================================== +!== flux_tr est le flux de traceur (positif vers bas) +! DO i = 1, klon +! flux_tr(i,1) = zx_coef(i,1)/(RG*dtime) +! ENDDO +! DO k = 2, klev +! DO i = 1, klon +! flux_tr(i,k) = zx_coef(i,k)/(RG*dtime) +! . * (local_tr(i,k)-local_tr(i,k-1)) +! ENDDO +! ENDDO +!====================================================================== + DO k = 1, klev + DO i = 1, klon + d_tr(i,k) = local_tr(i,k) - tr(i,k) + ENDDO + ENDDO + +END SUBROUTINE cltrac Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cltracrn.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cltracrn.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cltracrn.F90 (revision 1634) @@ -0,0 +1,287 @@ +!$Id $ + +SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay, & + cdrag,coef,t,ftsol,pctsrf, & + tr,trs,paprs,pplay,delp, & + masktr,fshtr,hsoltr,tautr,vdeptr, & + lat,d_tr,d_trs ) + + USE dimphy + USE traclmdz_mod, ONLY : id_rn, id_pb + IMPLICIT NONE +!====================================================================== +! Auteur(s): Alex/LMD) date: fev 99 +! inspire de clqh + clvent +! Objet: diffusion verticale de traceurs avec quantite de traceur ds +! le sol ( reservoir de sol de radon ) +! +! note : pour l'instant le traceur dans le sol et le flux sont +! calcules mais ils ne servent que de diagnostiques +! seule la tendance sur le traceur est sortie (d_tr) +!--------------------------------------------------------------------- +! Arguments: +! itr......input-R- le type de traceur : id_rn(radon), id_pb(plomb) +! dtime....input-R- intervalle du temps (en secondes) ~ pdtphys +! u1lay....input-R- vent u de la premiere couche (m/s) +! v1lay....input-R- vent v de la premiere couche (m/s) +! cdrag....input-R- cdrag +! coef.....input-R- le coefficient d'echange (m**2/s) l>1, valable uniquement pour k entre 2 et klev +! t........input-R- temperature (K) +! paprs....input-R- pression a inter-couche (Pa) +! pplay....input-R- pression au milieu de couche (Pa) +! delp.....input-R- epaisseur de couche (Pa) +! ftsol....input-R- temperature du sol (en Kelvin) +! tr.......input-R- traceurs +! trs......input-R- traceurs dans le sol +! masktr...input-R- Masque reservoir de sol traceur (1 = reservoir) +! fshtr....input-R- Flux surfacique de production dans le sol +! tautr....input-R- Constante de decroissance du traceur +! vdeptr...input-R- Vitesse de depot sec dans la couche brownienne +! hsoltr...input-R- Epaisseur equivalente du reservoir de sol +! lat......input-R- latitude en degree +! d_tr.....output-R- le changement de "tr" +! d_trs....output-R- le changement de "trs" +!====================================================================== + include "YOMCST.h" + include "indicesol.h" +! +!Entrees + INTEGER,INTENT(IN) :: itr + REAL,INTENT(IN) :: dtime + REAL,DIMENSION(klon),INTENT(IN) :: u1lay, v1lay + REAL,DIMENSION(klon),INTENT(IN) :: cdrag + REAL,DIMENSION(klon,klev),INTENT(IN) :: coef, t + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol, pctsrf + REAL,DIMENSION(klon,klev),INTENT(IN) :: tr + REAL,DIMENSION(klon),INTENT(IN) :: trs + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay, delp + REAL,DIMENSION(klon),INTENT(IN) :: masktr + REAL,DIMENSION(klon),INTENT(IN) :: fshtr + REAL,INTENT(IN) :: hsoltr + REAL,INTENT(IN) :: tautr + REAL,INTENT(IN) :: vdeptr + REAL,DIMENSION(klon),INTENT(IN) :: lat + +!Sorties + REAL,DIMENSION(klon,klev),INTENT(OUT) :: d_tr + REAL,DIMENSION(klon),INTENT(OUT) :: d_trs ! (diagnostic) traceur ds le sol + +!Locales + REAL,DIMENSION(klon,klev) :: flux_tr ! (diagnostic) flux de traceur + INTEGER :: i, k, n, l + REAL,DIMENSION(klon) :: rotrhi + REAL,DIMENSION(klon,klev) :: zx_coef + REAL,DIMENSION(klon) :: zx_buf + REAL,DIMENSION(klon,klev) :: zx_ctr + REAL,DIMENSION(klon,klev) :: zx_dtr + REAL,DIMENSION(klon) :: zx_trs + REAL :: zx_a, zx_b + + REAL,DIMENSION(klon,klev) :: local_tr + REAL,DIMENSION(klon) :: local_trs + REAL,DIMENSION(klon) :: zts ! champ de temperature du sol + REAL,DIMENSION(klon) :: zx_alpha1, zx_alpha2 +!====================================================================== +!AA Pour l'instant les 4 types de surface ne sont pas pris en compte +!AA On fabrique avec zts un champ de temperature de sol +!AA que le pondere par la fraction de nature de sol. + + DO i = 1,klon + zts(i) = 0. + ENDDO + + DO n=1,nbsrf + DO i = 1,klon + zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n) + ENDDO + ENDDO + + DO i = 1,klon + rotrhi(i) = RD * zts(i) / hsoltr + ENDDO + + DO k = 1, klev + DO i = 1, klon + local_tr(i,k) = tr(i,k) + ENDDO + ENDDO + + DO i = 1, klon + local_trs(i) = trs(i) + ENDDO +!====================================================================== +!AA Attention si dans clmain zx_alf1(i) = 1.0 +!AA Il doit y avoir coherence (dc la meme chose ici) + + DO i = 1, klon +!AA zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2)) + zx_alpha1(i) = 1.0 + zx_alpha2(i) = 1.0 - zx_alpha1(i) + ENDDO +!====================================================================== + DO i = 1, klon + zx_coef(i,1) = cdrag(i)*(1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) & + *pplay(i,1)/(RD*t(i,1)) + zx_coef(i,1) = zx_coef(i,1) * dtime*RG + ENDDO + + DO k = 2, klev + DO i = 1, klon + zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) & + *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2 + zx_coef(i,k) = zx_coef(i,k) * dtime*RG + ENDDO + ENDDO +!====================================================================== + DO i = 1, klon + zx_buf(i) = delp(i,klev) + zx_coef(i,klev) + zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i) + zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i) + ENDDO + + DO l = klev-1, 2 , -1 + DO i = 1, klon + zx_buf(i) = delp(i,l)+zx_coef(i,l) & + +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1)) + + zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l) & + + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i) + zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i) + ENDDO + ENDDO + + DO i = 1, klon + zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2)) & + + masktr(i) * zx_coef(i,1) & + *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) ) + + zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1) & + + zx_ctr(i,2) & + *(zx_coef(i,2) & + - masktr(i) * zx_coef(i,1) & + *zx_alpha2(i) ) ) / zx_buf(i) + zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i) + ENDDO +!====================================================================== +! Calculer d'abord local_trs nouvelle quantite dans le reservoir +! de sol +!===================================================================== + + DO i = 1, klon +!------------------------- +! Au dessus des continents +!-- +! Le pb peut se deposer partout : vdeptr = 10-3 m/s +! Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0. +!------------------------------------------------------------------- + IF ( NINT(masktr(i)) .EQ. 1 ) THEN + zx_trs(i) = local_trs(i) + zx_a = zx_trs(i) & + +fshtr(i)*dtime*rotrhi(i) & + +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) & + +zx_alpha2(i)*zx_ctr(i,2)) +! Pour l'instant, pour aller vite, le depot sec est traite comme une decroissance + zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + * (1.-zx_dtr(i,1) & + *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))) & + + dtime / tautr & + + dtime * vdeptr / hsoltr + zx_trs(i) = zx_a / zx_b + local_trs(i) = zx_trs(i) + ENDIF +!-------------------------------------------------------- +! Si on est entre 60N et 70N on divise par 2 l'emanation +!-------------------------------------------------------- + + IF ( (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.).OR. & + (itr.eq.id_pb.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.) ) THEN + zx_trs(i) = local_trs(i) + zx_a = zx_trs(i) & + +(fshtr(i)/2.)*dtime*rotrhi(i) & + +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) & + +zx_alpha2(i)*zx_ctr(i,2)) + ! + zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG & + * (1.-zx_dtr(i,1) & + *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))) & + + dtime / tautr & + + dtime * vdeptr / hsoltr + ! + zx_trs(i) = zx_a / zx_b + local_trs(i) = zx_trs(i) + ENDIF + +!---------------------------------------------- +! Au dessus des oceans et aux hautes latitudes +!-- +! au dessous de -60S pas d'emission de radon au dessus +! des oceans et des continents +!--------------------------------------------------------------- + + IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR. & + (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.)) THEN + zx_trs(i) = 0. + local_trs(i) = 0. + END IF +!-- +! au dessus de 70 N pas d'emission de radon au dessus +! des oceans et des continents +!-------------------------------------------------------------- + IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR. & + (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.)) THEN + zx_trs(i) = 0. + local_trs(i) = 0. + END IF +!--------------------------------------------- +! Au dessus des oceans la source est nulle +!-------------------------------------------- + + IF (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.0) THEN + zx_trs(i) = 0. + local_trs(i) = 0. + END IF + + ENDDO ! sur le i=1,klon +! +!====================================================================== +! Une fois on a zx_trs, on peut faire l'iteration +!====================================================================== + + DO i = 1, klon + local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i) + ENDDO + DO l = 2, klev + DO i = 1, klon + local_tr(i,l) = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1) + ENDDO + ENDDO +!====================================================================== +! Calcul du flux de traceur (flux_tr): UA/(m**2 s) +!====================================================================== + DO i = 1, klon + flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG & + * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2) & + -zx_trs(i)) / dtime + ENDDO + DO l = 2, klev + DO i = 1, klon + flux_tr(i,l) = zx_coef(i,l)/RG & + * (local_tr(i,l)-local_tr(i,l-1)) / dtime + ENDDO + ENDDO +!====================================================================== +! Calcul des tendances du traceur ds le sol et dans l'atmosphere +!====================================================================== + DO l = 1, klev + DO i = 1, klon + d_tr(i,l) = local_tr(i,l) - tr(i,l) + ENDDO + ENDDO + DO i = 1, klon + d_trs(i) = local_trs(i) - trs(i) + ENDDO + +END SUBROUTINE cltracrn Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coef_diff_turb_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coef_diff_turb_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coef_diff_turb_mod.F90 (revision 1634) @@ -0,0 +1,582 @@ +! +MODULE coef_diff_turb_mod +! +! This module contains some procedures for calculation of the coefficients of the +! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion +! at surface(cdrag) +! + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, & + ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, & + ycoefm, ycoefh ,yq2) + + USE dimphy +! +! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the +! atmosphere +! NB! No values are calculated between surface and the first model layer. +! ycoefm(:,1) and ycoefh(:,1) are not valid !!! +! +! +! Input arguments +!**************************************************************************************** + REAL, INTENT(IN) :: dtime + INTEGER, INTENT(IN) :: nsrf, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: ni + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: ypaprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: ypplay + REAL, DIMENSION(klon,klev), INTENT(IN) :: yu, yv + REAL, DIMENSION(klon,klev), INTENT(IN) :: yq, yt + REAL, DIMENSION(klon), INTENT(IN) :: yts, yrugos, yqsurf + REAL, DIMENSION(klon), INTENT(IN) :: ycdragm + +! InOutput arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev+1), INTENT(INOUT):: yq2 + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: ycoefh + REAL, DIMENSION(klon,klev), INTENT(OUT) :: ycoefm + +! Other local variables +!**************************************************************************************** + INTEGER :: k, i, j + REAL, DIMENSION(klon,klev) :: ycoefm0, ycoefh0, yzlay, yteta + REAL, DIMENSION(klon,klev+1) :: yzlev, q2diag, ykmm, ykmn, ykmq + REAL, DIMENSION(klon) :: yustar + +! Include +!**************************************************************************************** + INCLUDE "clesphys.h" + INCLUDE "indicesol.h" + INCLUDE "iniprint.h" + INCLUDE "compbl.h" + INCLUDE "YOETHF.h" + INCLUDE "YOMCST.h" + + +!**************************************************************************************** +! Calcul de coefficients de diffusion turbulent de l'atmosphere : +! ycoefm(:,2:klev), ycoefh(:,2:klev) +! +!**************************************************************************************** + + CALL coefkz(nsrf, knon, ypaprs, ypplay, & + ksta, ksta_ter, & + yts, yrugos, yu, yv, yt, yq, & + yqsurf, & + ycoefm, ycoefh) + +!**************************************************************************************** +! Eventuelle recalcule des coeffeicients de diffusion turbulent de l'atmosphere : +! ycoefm(:,2:klev), ycoefh(:,2:klev) +! +!**************************************************************************************** + + IF (iflag_pbl.EQ.1) THEN + CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, & + ycoefm0, ycoefh0) + + DO k = 2, klev + DO i = 1, knon + ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k)) + ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k)) + ENDDO + ENDDO + ENDIF + + +!**************************************************************************************** +! Calcul d'une diffusion minimale pour les conditions tres stables +! +!**************************************************************************************** + IF (ok_kzmin) THEN + CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm, & + ycoefm0,ycoefh0) + + DO k = 2, klev + DO i = 1, knon + ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k)) + ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k)) + ENDDO + ENDDO + + ENDIF + + +!**************************************************************************************** +! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin +! +!**************************************************************************************** + + IF (iflag_pbl.GE.3) THEN + + yzlay(1:knon,1)= & + RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) & + *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG + DO k=2,klev + DO i = 1, knon + yzlay(i,k)= & + yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) & + /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG + END DO + END DO + + DO k=1,klev + DO i = 1, knon + yteta(i,k)= & + yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA & + *(1.+0.61*yq(i,k)) + END DO + END DO + + yzlev(1:knon,1)=0. + yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1) + DO k=2,klev + DO i = 1, knon + yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1)) + END DO + END DO + +!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!$! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un +!!$! bug sur les coefficients de surface : +!!$! ycdragh(1:knon) = ycoefm(1:knon,1) +!!$! ycdragm(1:knon) = ycoefh(1:knon,1) +!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CALL ustarhb(knon,yu,yv,ycdragm, yustar) + + IF (prt_level > 9) THEN + WRITE(lunout,*) 'USTAR = ',yustar + ENDIF + +! iflag_pbl peut etre utilise comme longuer de melange + IF (iflag_pbl.GE.11) THEN + CALL vdif_kcay(knon,dtime,RG,RD,ypaprs,yt, & + yzlev,yzlay,yu,yv,yteta, & + ycdragm,yq2,q2diag,ykmm,ykmn,yustar, & + iflag_pbl) + ELSE + CALL yamada4(knon,dtime,RG,RD,ypaprs,yt, & + yzlev,yzlay,yu,yv,yteta, & + ycdragm,yq2,ykmm,ykmn,ykmq,yustar, & + iflag_pbl) + ENDIF + + ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev) + ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev) + + ENDIF !(iflag_pbl.ge.3) + + END SUBROUTINE coef_diff_turb +! +!**************************************************************************************** +! + SUBROUTINE coefkz(nsrf, knon, paprs, pplay, & + ksta, ksta_ter, & + ts, rugos, & + u,v,t,q, & + qsurf, & + pcfm, pcfh) + + USE dimphy + +!====================================================================== +! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922 +! (une version strictement identique a l'ancien modele) +! Objet: calculer le coefficient du frottement du sol (Cdrag) et les +! coefficients d'echange turbulent dans l'atmosphere. +! Arguments: +! nsrf-----input-I- indicateur de la nature du sol +! knon-----input-I- nombre de points a traiter +! paprs----input-R- pregssion a chaque intercouche (en Pa) +! pplay----input-R- pression au milieu de chaque couche (en Pa) +! ts-------input-R- temperature du sol (en Kelvin) +! rugos----input-R- longeur de rugosite (en m) +! u--------input-R- vitesse u +! v--------input-R- vitesse v +! t--------input-R- temperature (K) +! q--------input-R- vapeur d'eau (kg/kg) +! +! pcfm-----output-R- coefficients a calculer (vitesse) +! pcfh-----output-R- coefficients a calculer (chaleur et humidite) +!====================================================================== + INCLUDE "YOETHF.h" + INCLUDE "FCTTRE.h" + INCLUDE "iniprint.h" + INCLUDE "indicesol.h" + INCLUDE "compbl.h" + INCLUDE "YOMCST.h" +! +! Arguments: +! + INTEGER, INTENT(IN) :: knon, nsrf + REAL, INTENT(IN) :: ksta, ksta_ter + REAL, DIMENSION(klon), INTENT(IN) :: ts + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev), INTENT(IN) :: u, v, t, q + REAL, DIMENSION(klon), INTENT(IN) :: rugos + REAL, DIMENSION(klon), INTENT(IN) :: qsurf + + REAL, DIMENSION(klon,klev), INTENT(OUT) :: pcfm, pcfh + +! +! Local variables: +! + INTEGER, DIMENSION(klon) :: itop ! numero de couche du sommet de la couche limite +! +! Quelques constantes et options: +! + REAL, PARAMETER :: cepdu2=0.1**2 + REAL, PARAMETER :: CKAP=0.4 + REAL, PARAMETER :: cb=5.0 + REAL, PARAMETER :: cc=5.0 + REAL, PARAMETER :: cd=5.0 + REAL, PARAMETER :: clam=160.0 + REAL, PARAMETER :: ratqs=0.05 ! largeur de distribution de vapeur d'eau + LOGICAL, PARAMETER :: richum=.TRUE. ! utilise le nombre de Richardson humide + REAL, PARAMETER :: ric=0.4 ! nombre de Richardson critique + REAL, PARAMETER :: prandtl=0.4 + REAL kstable ! diffusion minimale (situation stable) + ! GKtest + ! PARAMETER (kstable=1.0e-10) +!IM: 261103 REAL kstable_ter, kstable_sinon +!IM: 211003 cf GK PARAMETER (kstable_ter = 1.0e-6) +!IM: 261103 PARAMETER (kstable_ter = 1.0e-8) +!IM: 261103 PARAMETER (kstable_ter = 1.0e-10) +!IM: 261103 PARAMETER (kstable_sinon = 1.0e-10) + ! fin GKtest + REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange + INTEGER isommet ! le sommet de la couche limite + LOGICAL, PARAMETER :: tvirtu=.TRUE. ! calculer Ri d'une maniere plus performante + LOGICAL, PARAMETER :: opt_ec=.FALSE.! formule du Centre Europeen dans l'atmosphere + +! +! Variables locales: + INTEGER i, k !IM 120704 + REAL zgeop(klon,klev) + REAL zmgeom(klon) + REAL zri(klon) + REAL zl2(klon) + REAL zdphi, zdu2, ztvd, ztvu, zcdn + REAL zscf + REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs + REAL z2geomf, zalh2, zalm2, zscfh, zscfm + REAL, PARAMETER :: t_coup=273.15 + LOGICAL, PARAMETER :: check=.FALSE. +! +! contre-gradient pour la chaleur sensible: Kelvin/metre + REAL gamt(2:klev) + + LOGICAL, SAVE :: appel1er=.TRUE. + !$OMP THREADPRIVATE(appel1er) +! +! Fonctions thermodynamiques et fonctions d'instabilite + REAL fsta, fins, x + + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) + + isommet=klev + + IF (appel1er) THEN + IF (prt_level > 9) THEN + WRITE(lunout,*)'coefkz, opt_ec:', opt_ec + WRITE(lunout,*)'coefkz, richum:', richum + IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs + WRITE(lunout,*)'coefkz, isommet:', isommet + WRITE(lunout,*)'coefkz, tvirtu:', tvirtu + appel1er = .FALSE. + ENDIF + ENDIF +! +! Initialiser les sorties +! + DO k = 1, klev + DO i = 1, knon + pcfm(i,k) = 0.0 + pcfh(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, knon + itop(i) = 0 + ENDDO + +! +! Prescrire la valeur de contre-gradient +! + IF (iflag_pbl.EQ.1) THEN + DO k = 3, klev + gamt(k) = -1.0E-03 + ENDDO + gamt(2) = -2.5E-03 + ELSE + DO k = 2, klev + gamt(k) = 0.0 + ENDDO + ENDIF +!IM cf JLD/ GKtest + IF ( nsrf .NE. is_oce ) THEN +!IM 261103 kstable = kstable_ter + kstable = ksta_ter + ELSE +!IM 261103 kstable = kstable_sinon + kstable = ksta + ENDIF +!IM cf JLD/ GKtest fin + +! +! Calculer les geopotentiels de chaque couche +! + DO i = 1, knon + zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) & + * (paprs(i,1)-pplay(i,1)) + ENDDO + DO k = 2, klev + DO i = 1, knon + zgeop(i,k) = zgeop(i,k-1) & + + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) & + * (pplay(i,k-1)-pplay(i,k)) + ENDDO + ENDDO + +! +! Calculer les coefficients turbulents dans l'atmosphere +! + DO i = 1, knon + itop(i) = isommet + ENDDO + + + DO k = 2, isommet + DO i = 1, knon + zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 & + +(v(i,k)-v(i,k-1))**2) + zmgeom(i)=zgeop(i,k)-zgeop(i,k-1) + zdphi =zmgeom(i) / 2.0 + zt = (t(i,k)+t(i,k-1)) * 0.5 + zq = (q(i,k)+q(i,k-1)) * 0.5 + +! +! Calculer Qs et dQs/dT: +! + IF (thermcep) THEN + zdelta = MAX(0.,SIGN(1.,RTT-zt)) + zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) & + + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta + zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k) + zqs = MIN(0.5,zqs) + zcor = 1./(1.-RETV*zqs) + zqs = zqs*zcor + zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor) + ELSE + IF (zt .LT. t_coup) THEN + zqs = qsats(zt) / pplay(i,k) + zdqs = dqsats(zt,zqs) + ELSE + zqs = qsatl(zt) / pplay(i,k) + zdqs = dqsatl(zt,zqs) + ENDIF + ENDIF +! +! calculer la fraction nuageuse (processus humide): +! + zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq) + zfr = MAX(0.0,MIN(1.0,zfr)) + IF (.NOT.richum) zfr = 0.0 +! +! calculer le nombre de Richardson: +! + IF (tvirtu) THEN + ztvd =( t(i,k) & + + zdphi/RCPD/(1.+RVTMP2*zq) & + *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) & + )*(1.+RETV*q(i,k)) + ztvu =( t(i,k-1) & + - zdphi/RCPD/(1.+RVTMP2*zq) & + *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) & + )*(1.+RETV*q(i,k-1)) + zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu)) + zri(i) = zri(i) & + + zmgeom(i)*zmgeom(i)/RG*gamt(k) & + *(paprs(i,k)/101325.0)**RKAPPA & + /(zdu2*0.5*(ztvd+ztvu)) + + ELSE ! calcul de Ridchardson compatible LMD5 + + zri(i) =(RCPD*(t(i,k)-t(i,k-1)) & + -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) & + *(pplay(i,k)-pplay(i,k-1)) & + )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k))) + zri(i) = zri(i) + & + zmgeom(i)*zmgeom(i)*gamt(k)/RG & + *(paprs(i,k)/101325.0)**RKAPPA & + /(zdu2*0.5*(t(i,k-1)+t(i,k))) + ENDIF +! +! finalement, les coefficients d'echange sont obtenus: +! + zcdn=SQRT(zdu2) / zmgeom(i) * RG + + IF (opt_ec) THEN + z2geomf=zgeop(i,k-1)+zgeop(i,k) + zalm2=(0.5*ckap/RG*z2geomf & + /(1.+0.5*ckap/rg/clam*z2geomf))**2 + zalh2=(0.5*ckap/rg*z2geomf & + /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2 + IF (zri(i).LT.0.0) THEN ! situation instable + zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 & + / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG) + zscf = SQRT(-zri(i)*zscf) + zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf) + zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf) + pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm) + pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh) + ELSE ! situation stable + zscf=SQRT(1.+cd*zri(i)) + pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf) + pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf) + ENDIF + ELSE + zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) & + /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2 + pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable)) + pcfm(i,k)= zl2(i)* pcfm(i,k) + pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different + ENDIF + ENDDO + ENDDO + +! +! Au-dela du sommet, pas de diffusion turbulente: +! + DO i = 1, knon + IF (itop(i)+1 .LE. klev) THEN + DO k = itop(i)+1, klev + pcfh(i,k) = 0.0 + pcfm(i,k) = 0.0 + ENDDO + ENDIF + ENDDO + + END SUBROUTINE coefkz +! +!**************************************************************************************** +! + SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, & + pcfm, pcfh) + + USE dimphy + +!====================================================================== +! J'introduit un peu de diffusion sauf dans les endroits +! ou une forte inversion est presente +! On peut dire qu'il represente la convection peu profonde +! +! Arguments: +! nsrf-----input-I- indicateur de la nature du sol +! knon-----input-I- nombre de points a traiter +! paprs----input-R- pression a chaque intercouche (en Pa) +! pplay----input-R- pression au milieu de chaque couche (en Pa) +! t--------input-R- temperature (K) +! +! pcfm-----output-R- coefficients a calculer (vitesse) +! pcfh-----output-R- coefficients a calculer (chaleur et humidite) +!====================================================================== +! +! Arguments: +! + INTEGER, INTENT(IN) :: knon, nsrf + REAL, DIMENSION(klon, klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon, klev), INTENT(IN) :: t(klon,klev) + + REAL, DIMENSION(klon, klev), INTENT(OUT) :: pcfm, pcfh +! +! Quelques constantes et options: +! + REAL, PARAMETER :: prandtl=0.4 + REAL, PARAMETER :: kstable=0.002 +! REAL, PARAMETER :: kstable=0.001 + REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange + REAL, PARAMETER :: seuil=-0.02 ! au-dela l'inversion est consideree trop faible +! PARAMETER (seuil=-0.04) +! PARAMETER (seuil=-0.06) +! PARAMETER (seuil=-0.09) + +! +! Variables locales: +! + INTEGER i, k, invb(knon) + REAL zl2(knon) + REAL zdthmin(knon), zdthdp + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" +! +! Initialiser les sorties +! + DO k = 1, klev + DO i = 1, knon + pcfm(i,k) = 0.0 + pcfh(i,k) = 0.0 + ENDDO + ENDDO + +! +! Chercher la zone d'inversion forte +! + DO i = 1, knon + invb(i) = klev + zdthmin(i)=0.0 + ENDDO + DO k = 2, klev/2-1 + DO i = 1, knon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) & + - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) + zdthdp = zdthdp * 100.0 + IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. & + zdthdp.LT.zdthmin(i) ) THEN + zdthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO + +! +! Introduire une diffusion: +! + IF ( nsrf.EQ.is_oce ) THEN + DO k = 2, klev + DO i = 1, knon +!IM cf FH/GK IF ( (nsrf.NE.is_oce) .OR. ! si ce n'est pas sur l'ocean +!IM cf FH/GK . (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion + !IM cf JLD/ GKtest TERkz2 + ! IF ( (nsrf.EQ.is_ter) .OR. ! si on est sur la terre + ! fin GKtest + + +! s'il n'y a pas d'inversion ou si l'inversion est trop faible +! IF ( (nsrf.EQ.is_oce) .AND. & + IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN + zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) & + /(paprs(i,2)-paprs(i,klev+1)) ))**2 + pcfm(i,k)= zl2(i)* kstable + pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different + ENDIF + ENDDO + ENDDO + ENDIF + + END SUBROUTINE coefkz2 +! +!**************************************************************************************** +! +END MODULE coef_diff_turb_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coefcdrag.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coefcdrag.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coefcdrag.F90 (revision 1634) @@ -0,0 +1,144 @@ +! +! +! + SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, & + speed, t, q, zgeop, psol, & + ts, qsurf, rugos, okri, ri1, & + cdram, cdrah, cdran, zri1, pref) + IMPLICIT none +!------------------------------------------------------------------------- +! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur +! sensible et latente (cdrah), du cdrag neutre (cdran), +! du nombre de Richardson entre la surface et le niveau de reference +! (zri1) et de la pression au niveau de reference (pref). +! +! I. Musat, 01.07.2002 +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! speed---input-R- module du vent au 1er niveau du modele +! t-------input-R- temperature de l'air au 1er niveau du modele +! q-------input-R- humidite de l'air au 1er niveau du modele +! zgeop---input-R- geopotentiel au 1er niveau du modele +! psol----input-R- pression au sol +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite de l'air a la surface +! rugos---input-R- rugosite +! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce +! et zref par rapport au Ri entre la sfce et la 1ere couche +! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche +! +! cdram--output-R- cdrag pour le moment +! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible +! cdran--output-R- cdrag neutre +! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG +! pref---output-R- pression au niveau zgeop/RG +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 + LOGICAL, intent(in) :: okri +! + REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref +!------------------------------------------------------------------------- +! + include "YOMCST.h" + include "YOETHF.h" + include "indicesol.h" +! Quelques constantes : + REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0, cepdu2=(0.1)**2 +! +! Variables locales : + INTEGER :: i + REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd + REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr + REAL, dimension(klon) :: zcfm1, zcfh1 + REAL, dimension(klon) :: zcfm2, zcfh2 + REAL, dimension(klon) :: trm0, trm1 +!------------------------------------------------------------------------- + REAL :: fsta, fins, x + fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x)) + fins(x) = SQRT(1.0-18.0*x) +!------------------------------------------------------------------------- +! + DO i = 1, knon +! + zdphi(i) = zgeop(i) + zdu2(i) = max(cepdu2,speed(i)**2) + pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* & + (1.+ RETV * max(q(i),0.0)))) + ztsolv(i) = ts(i) + ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA + trm0(i) = 1. + RETV * max(qsurf(i),0.0) + trm1(i) = 1. + RETV * max(q(i),0.0) + ztsolv(i) = ztsolv(i) * trm0(i) + ztvd(i) = ztvd(i) * trm1(i) + zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i)) +! +! on teste zri1 par rapport au Richardson de la 1ere couche ri1 +! +!IM +++ + IF(1.EQ.0) THEN + IF (okri) THEN + IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN + zri1(i) = ri1(i) + ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN + zri1(i) = ri1(i) + ENDIF + ENDIF + ENDIF +!IM --- +! + cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2 + + IF (zri1(i) .ge. 0.) THEN +! +! situation stable : pour eviter les inconsistances dans les cas +! tres stables on limite zri1 a 20. cf Hess et al. (1995) +! + zri1(i) = min(20.,zri1(i)) +! + IF (.NOT.zxli) THEN + zscf(i) = SQRT(1.+CD*ABS(zri1(i))) + friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1) + zcfm1(i) = cdran(i) * friv(i) + frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 ) + zcfh1(i) = cdran(i) * frih(i) + cdram(i) = zcfm1(i) + cdrah(i) = zcfh1(i) + ELSE + cdram(i) = cdran(i)* fsta(zri1(i)) + cdrah(i) = cdran(i)* fsta(zri1(i)) + ENDIF +! + ELSE +! +! situation instable +! + IF (.NOT.zxli) THEN + zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) & + *(1.0+zdphi(i)/(RG*rugos(i))))) + zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1) + zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1) + cdram(i) = zcfm2(i) + cdrah(i) = zcfh2(i) + ELSE + cdram(i) = cdran(i)* fins(zri1(i)) + cdrah(i) = cdran(i)* fins(zri1(i)) + ENDIF +! +! cdrah sur l'ocean cf. Miller et al. (1992) +! + zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) & + **(1./3.) + IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) & + **(1./1.25) + ENDIF +! + END DO + RETURN + END SUBROUTINE coefcdrag Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coefkzmin.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coefkzmin.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/coefkzmin.F (revision 1634) @@ -0,0 +1,132 @@ +! + SUBROUTINE coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm + . ,km,kn) + + USE dimphy + IMPLICIT NONE + + include "YOMCST.h" + +c....................................................................... +c Entrees modifies en attendant une version ou les zlev, et zlay soient +c disponibles. + + REAL ycdragm(klon) + + REAL yu(klon,klev), yv(klon,klev) + REAL yt(klon,klev), yq(klon,klev) + REAL ypaprs(klon,klev+1), ypplay(klon,klev) + REAL yustar(klon) + real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev) + + integer i + +c....................................................................... +c +c En entree : +c ----------- +c +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c ustar : u* +c +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c +c en sortier : +c ------------ +c +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL teta(klon,klev) + + REAL km(klon,klev) + REAL kn(klon,klev) + integer knon + + + integer nlay,nlev + integer ig,k + + real,parameter :: kap=0.4 + + nlay=klev + nlev=klev+1 +c....................................................................... +c en attendant une version ou les zlev, et zlay soient +c disponibles. +c Debut de la partie qui doit etre unclue a terme dans clmain. +c + do i=1,knon + yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1))) + . *(ypaprs(i,1)-ypplay(i,1))/RG + enddo + do k=2,klev + do i=1,knon + yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) + s /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG + enddo + enddo + do k=1,klev + do i=1,knon +cATTENTION:on passe la temperature potentielle virt. pour le calcul de K + yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa + s *(1.+0.61*yq(i,k)) + enddo + enddo + do i=1,knon + yzlev(i,1)=0. + yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1) + enddo + do k=2,klev + do i=1,knon + yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1)) + enddo + enddo + + yustar(1:knon) =SQRT(ycdragm(1:knon)* + $ (yu(1:knon,1)*yu(1:knon,1)+yv(1:knon,1)*yv(1:knon,1))) + +c Fin de la partie qui doit etre unclue a terme dans clmain. + +Cette routine est ecrite pour avoir en entree ustar, teta et zlev +c Ici, on a inclut le calcul de ces trois variables dans la routine +c coefkzmin en attendant une nouvelle version de la couche limite +c ou ces variables seront disponibles. + +c Debut de la routine coefkzmin proprement dite. + + ustar=yustar + teta=yteta + zlev=yzlev + + do ig=1,knon + coriol(ig)=1.e-4 + pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5) + enddo + + do k=2,klev + do ig=1,knon + if (teta(ig,2).gt.teta(ig,1)) then + qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin=kap*zlev(ig,k)*qmin + else + kmin=0. ! kmin n'est utilise que pour les SL stables. + endif + kn(ig,k)=kmin + km(ig,k)=kmin + enddo + enddo + + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comgeomphy.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comgeomphy.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comgeomphy.F90 (revision 1634) @@ -0,0 +1,23 @@ +module comgeomphy + real,save,allocatable :: airephy(:) + real,save,allocatable :: cuphy(:) + real,save,allocatable :: cvphy(:) + real,save,allocatable :: rlatd(:) + real,save,allocatable :: rlond(:) +!$OMP THREADPRIVATE(airephy,cuphy,cvphy,rlatd,rlond) +contains + + subroutine InitComgeomphy + USE mod_phys_lmdz_para + implicit none + + + allocate(airephy(klon_omp)) + allocate(cuphy(klon_omp)) + allocate(cvphy(klon_omp)) + allocate(rlatd(klon_omp)) + allocate(rlond(klon_omp)) + + end subroutine InitComgeomphy + +end module comgeomphy Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comgeomphy.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comgeomphy.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comgeomphy.h (revision 1634) @@ -0,0 +1,9 @@ +! +! $Header$ +! +c +c +c Common de passage de la geometrie de la dynamique a la physique + real airephy(klon),cuphy(klon),cvphy(klon) + REAL rlatd(klon), rlond(klon) + common/comgeomphy/airephy,cuphy,cvphy,rlatd, rlond Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/compbl.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/compbl.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/compbl.h (revision 1634) @@ -0,0 +1,6 @@ + ! + ! $Header$ + ! + integer iflag_pbl + common/compbl/iflag_pbl +!$OMP THREADPRIVATE(/compbl/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comsoil.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comsoil.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/comsoil.h (revision 1634) @@ -0,0 +1,7 @@ +! +! $Header$ +! + + common /comsoil/inertie_sol,inertie_sno,inertie_ice + real inertie_sol,inertie_sno,inertie_ice +!$OMP THREADPRIVATE(/comsoil/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conccm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conccm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conccm.F (revision 1634) @@ -0,0 +1,835 @@ +! +! $Header$ +! + SUBROUTINE conccm (dtime,paprs,pplay,t,q,conv_q, + s d_t, d_q, rain, snow, kbascm, ktopcm) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996 +c Objet: Schema simple (avec flux de masse) pour la convection +c (schema standard du modele NCAR CCM2) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +c +c Entree: + REAL dtime ! pas d'integration + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (g/g) + REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s) +c Sortie: + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation vapeur + REAL rain(klon) ! pluie (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER kbascm(klon) ! niveau du bas de convection + INTEGER ktopcm(klon) ! niveau du haut de convection +c + REAL pt(klon,klev) + REAL pq(klon,klev) + REAL pres(klon,klev) + REAL dp(klon,klev) + REAL zgeom(klon,klev) + REAL cmfprs(klon) + REAL cmfprt(klon) + INTEGER ntop(klon) + INTEGER nbas(klon) + INTEGER i, k + REAL zlvdcp, zlsdcp, zdelta, zz, za, zb +c + LOGICAL usekuo ! utiliser convection profonde (schema Kuo) + PARAMETER (usekuo=.TRUE.) +c + REAL d_t_bis(klon,klev) + REAL d_q_bis(klon,klev) + REAL rain_bis(klon) + REAL snow_bis(klon) + INTEGER ibas_bis(klon) + INTEGER itop_bis(klon) + REAL d_ql_bis(klon,klev) + REAL rneb_bis(klon,klev) +c +c initialiser les variables de sortie (pour securite) + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + kbascm(i) = 0 + ktopcm(i) = 0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pq(i,k) = q(i,klev-k+1) + pres(i,k) = pplay(i,klev-k+1) + dp(i,k) = paprs(i,klev+1-k)-paprs(i,klev+1-k+1) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) + ENDDO + DO k = 2, klev + DO i = 1, klon + zgeom(i,klev+1-k) = zgeom(i,klev+1-k+1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) + ENDDO + ENDDO +c + CALL cmfmca(dtime, pres, dp, zgeom, pt, pq, + $ cmfprt, cmfprs, ntop, nbas) +C + DO k = 1, klev + DO i = 1, klon + d_q(i,klev+1-k) = pq(i,k) - q(i,klev+1-k) + d_t(i,klev+1-k) = pt(i,k) - t(i,klev+1-k) + ENDDO + ENDDO +c + DO i = 1, klon + rain(i) = cmfprt(i) * rhoh2o + snow(i) = cmfprs(i) * rhoh2o + kbascm(i) = klev+1 - nbas(i) + ktopcm(i) = klev+1 - ntop(i) + ENDDO +c + IF (usekuo) THEN + CALL conkuo(dtime, paprs, pplay, t, q, conv_q, + s d_t_bis, d_q_bis, d_ql_bis, rneb_bis, + s rain_bis, snow_bis, ibas_bis, itop_bis) + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = d_t(i,k) + d_t_bis(i,k) + d_q(i,k) = d_q(i,k) + d_q_bis(i,k) + ENDDO + ENDDO + DO i = 1, klon + rain(i) = rain(i) + rain_bis(i) + snow(i) = snow(i) + snow_bis(i) + kbascm(i) = MIN(kbascm(i),ibas_bis(i)) + ktopcm(i) = MAX(ktopcm(i),itop_bis(i)) + ENDDO + DO k = 1, klev ! eau liquide convective est + DO i = 1, klon ! dispersee dans l'air + zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k)) + zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k)) + zdelta = MAX(0.,SIGN(1.,RTT-t(i,k))) + zz = d_ql_bis(i,k) ! re-evap. de l'eau liquide + zb = MAX(0.0,zz) + za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + d_t(i,k) = d_t(i,k) + za + d_q(i,k) = d_q(i,k) + zb + ENDDO + ENDDO + ENDIF +c + RETURN + END + SUBROUTINE cmfmca(deltat, p, dp, gz, + $ tb, shb, + $ cmfprt, cmfprs, cnt, cnb) + USE dimphy + IMPLICIT none +C----------------------------------------------------------------------- +C Moist convective mass flux procedure: +C If stratification is unstable to nonentraining parcel ascent, +C complete an adjustment making use of a simple cloud model +C +C Code generalized to allow specification of parcel ("updraft") +C properties, as well as convective transport of an arbitrary +C number of passive constituents (see cmrb array). +C----------------------------Code History------------------------------- +C Original version: J. J. Hack, March 22, 1990 +C Standardized: J. Rosinski, June 1992 +C Reviewed: J. Hack, G. Taylor, August 1992 +c Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994, +c J. Geophys. Res. vol 99, D3, 5551-5568). J'ai +c introduit les constantes et les fonctions thermo- +c dynamiques du Centre Europeen. J'ai elimine le +c re-indicage du code en esperant que cela pourra +c simplifier la lecture et la comprehension. +C----------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" + INTEGER pcnst ! nombre de traceurs passifs + PARAMETER (pcnst=1) +C------------------------------Arguments-------------------------------- +C Input arguments +C + REAL deltat ! time step (seconds) + REAL p(klon,klev) ! pressure + REAL dp(klon,klev) ! delta-p + REAL gz(klon,klev) ! geopotential (a partir du sol) +c + REAL thtap(klon) ! PBL perturbation theta + REAL shp(klon) ! PBL perturbation specific humidity + REAL pblh(klon) ! PBL height (provided by PBL routine) + REAL cmrp(klon,pcnst) ! constituent perturbations in PBL +c +c Updated arguments: +c + REAL tb(klon,klev) ! temperature (t bar) + REAL shb(klon,klev) ! specific humidity (sh bar) + REAL cmrb(klon,klev,pcnst) ! constituent mixing ratios (cmr bar) +C +C Output arguments +C + REAL cmfdt(klon,klev) ! dT/dt due to moist convection + REAL cmfdq(klon,klev) ! dq/dt due to moist convection + REAL cmfmc(klon,klev ) ! moist convection cloud mass flux + REAL cmfdqr(klon,klev) ! dq/dt due to convective rainout + REAL cmfsl(klon,klev ) ! convective lw static energy flux + REAL cmflq(klon,klev ) ! convective total water flux + REAL cmfprt(klon) ! convective precipitation rate + REAL cmfprs(klon) ! convective snowfall rate + REAL qc(klon,klev) ! dq/dt due to rainout terms + INTEGER cnt(klon) ! top level of convective activity + INTEGER cnb(klon) ! bottom level of convective activity +C------------------------------Parameters------------------------------- + REAL c0 ! rain water autoconversion coefficient + PARAMETER (c0=1.0e-4) + REAL dzmin ! minimum convective depth for precipitation + PARAMETER (dzmin=0.0) + REAL betamn ! minimum overshoot parameter + PARAMETER (betamn=0.10) + REAL cmftau ! characteristic adjustment time scale + PARAMETER (cmftau=3600.) + INTEGER limcnv ! top interface level limit for convection + PARAMETER (limcnv=1) + REAL tpmax ! maximum acceptable t perturbation (degrees C) + PARAMETER (tpmax=1.50) + REAL shpmax ! maximum acceptable q perturbation (g/g) + PARAMETER (shpmax=1.50e-3) + REAL tiny ! arbitrary small num used in transport estimates + PARAMETER (tiny=1.0e-36) + REAL eps ! convergence criteria (machine dependent) + PARAMETER (eps=1.0e-13) + REAL tmelt ! freezing point of water(req'd for rain vs snow) + PARAMETER (tmelt=273.15) + REAL ssfac ! supersaturation bound (detrained air) + PARAMETER (ssfac=1.001) +C +C---------------------------Local workspace----------------------------- + REAL gam(klon,klev) ! L/cp (d(qsat)/dT) + REAL sb(klon,klev) ! dry static energy (s bar) + REAL hb(klon,klev) ! moist static energy (h bar) + REAL shbs(klon,klev) ! sat. specific humidity (sh bar star) + REAL hbs(klon,klev) ! sat. moist static energy (h bar star) + REAL shbh(klon,klev+1) ! specific humidity on interfaces + REAL sbh(klon,klev+1) ! s bar on interfaces + REAL hbh(klon,klev+1) ! h bar on interfaces + REAL cmrh(klon,klev+1) ! interface constituent mixing ratio + REAL prec(klon) ! instantaneous total precipitation + REAL dzcld(klon) ! depth of convective layer (m) + REAL beta(klon) ! overshoot parameter (fraction) + REAL betamx ! local maximum on overshoot + REAL eta(klon) ! convective mass flux (kg/m^2 s) + REAL etagdt ! eta*grav*deltat + REAL cldwtr(klon) ! cloud water (mass) + REAL rnwtr(klon) ! rain water (mass) + REAL sc (klon) ! dry static energy ("in-cloud") + REAL shc (klon) ! specific humidity ("in-cloud") + REAL hc (klon) ! moist static energy ("in-cloud") + REAL cmrc(klon) ! constituent mix rat ("in-cloud") + REAL dq1(klon) ! shb convective change (lower lvl) + REAL dq2(klon) ! shb convective change (mid level) + REAL dq3(klon) ! shb convective change (upper lvl) + REAL ds1(klon) ! sb convective change (lower lvl) + REAL ds2(klon) ! sb convective change (mid level) + REAL ds3(klon) ! sb convective change (upper lvl) + REAL dcmr1(klon) ! cmrb convective change (lower lvl) + REAL dcmr2(klon) ! cmrb convective change (mid level) + REAL dcmr3(klon) ! cmrb convective change (upper lvl) + REAL flotab(klon) ! hc - hbs (mesure d'instabilite) + LOGICAL ldcum(klon) ! .true. si la convection existe + LOGICAL etagt0 ! true if eta > 0.0 + REAL dt ! current 2 delta-t (model time step) + REAL cats ! modified characteristic adj. time + REAL rdt ! 1./dt + REAL qprime ! modified specific humidity pert. + REAL tprime ! modified thermal perturbation + REAL pblhgt ! bounded pbl height (max[pblh,1m]) + REAL fac1 ! intermediate scratch variable + REAL shprme ! intermediate specific humidity pert. + REAL qsattp ! saturation mixing ratio for +C ! thermally perturbed PBL parcels + REAL dz ! local layer depth + REAL b1 ! bouyancy measure in detrainment lvl + REAL b2 ! bouyancy measure in condensation lvl + REAL g ! bounded vertical gradient of hb + REAL tmass ! total mass available for convective exchange + REAL denom ! intermediate scratch variable + REAL qtest1! used in negative q test (middle lvl) + REAL qtest2! used in negative q test (lower lvl) + REAL fslkp ! flux lw static energy (bot interface) + REAL fslkm ! flux lw static energy (top interface) + REAL fqlkp ! flux total water (bottom interface) + REAL fqlkm ! flux total water (top interface) + REAL botflx! bottom constituent mixing ratio flux + REAL topflx! top constituent mixing ratio flux + REAL efac1 ! ratio cmrb to convectively induced change (bot lvl) + REAL efac2 ! ratio cmrb to convectively induced change (mid lvl) + REAL efac3 ! ratio cmrb to convectively induced change (top lvl) +c + INTEGER i,k ! indices horizontal et vertical + INTEGER km1 ! k-1 (index offset) + INTEGER kp1 ! k+1 (index offset) + INTEGER m ! constituent index + INTEGER ktp ! temporary index used to track top + INTEGER is ! nombre de points a ajuster +C + REAL tmp1, tmp2, tmp3, tmp4 + REAL zx_t, zx_p, zx_q, zx_qs, zx_gam + REAL zcor, zdelta, zcvm5 +C + REAL qhalf, sh1, sh2, shbs1, shbs2 +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + qhalf(sh1,sh2,shbs1,shbs2) = MIN(MAX(sh1,sh2), + $ (shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2)) +C +C----------------------------------------------------------------------- +c pas de traceur pour l'instant + DO m = 1, pcnst + DO k = 1, klev + DO i = 1, klon + cmrb(i,k,m) = 0.0 + ENDDO + ENDDO + ENDDO +c +c Les perturbations de la couche limite sont zero pour l'instant +c + DO m = 1, pcnst + DO i = 1, klon + cmrp(i,m) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + thtap(i) = 0.0 + shp(i) = 0.0 + pblh(i) = 1.0 + ENDDO +C +C Ensure that characteristic adjustment time scale (cmftau) assumed +C in estimate of eta isn't smaller than model time scale (deltat) +C + dt = deltat + cats = MAX(dt,cmftau) + rdt = 1.0/dt +C +C Compute sb,hb,shbs,hbs +C + DO k = 1, klev + DO i = 1, klon + zx_t = tb(i,k) + zx_p = p(i,k) + zx_q = shb(i,k) + zdelta=MAX(0.,SIGN(1.,RTT-zx_t)) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q) + zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor) + shbs(i,k) = zx_qs + gam(i,k) = zx_gam + ENDDO + ENDDO +C + DO k=limcnv,klev + DO i=1,klon + sb (i,k) = RCPD*tb(i,k) + gz(i,k) + hb (i,k) = sb(i,k) + RLVTT*shb(i,k) + hbs(i,k) = sb(i,k) + RLVTT*shbs(i,k) + ENDDO + ENDDO +C +C Compute sbh, shbh +C + DO k=limcnv+1,klev + km1 = k - 1 + DO i=1,klon + sbh (i,k) =0.5*(sb(i,km1) + sb(i,k)) + shbh(i,k) =qhalf(shb(i,km1),shb(i,k),shbs(i,km1),shbs(i,k)) + hbh (i,k) =sbh(i,k) + RLVTT*shbh(i,k) + ENDDO + ENDDO +C +C Specify properties at top of model (not used, but filling anyway) +C + DO i=1,klon + sbh (i,limcnv) = sb(i,limcnv) + shbh(i,limcnv) = shb(i,limcnv) + hbh (i,limcnv) = hb(i,limcnv) + ENDDO +C +C Zero vertically independent control, tendency & diagnostic arrays +C + DO i=1,klon + prec(i) = 0.0 + dzcld(i) = 0.0 + cnb(i) = 0 + cnt(i) = klev+1 + ENDDO + + DO k = 1, klev + DO i = 1,klon + cmfdt(i,k) = 0. + cmfdq(i,k) = 0. + cmfdqr(i,k) = 0. + cmfmc(i,k) = 0. + cmfsl(i,k) = 0. + cmflq(i,k) = 0. + ENDDO + ENDDO +C +C Begin moist convective mass flux adjustment procedure. +C Formalism ensures that negative cloud liquid water can never occur +C + DO 70 k=klev-1,limcnv+1,-1 + km1 = k - 1 + kp1 = k + 1 + DO 10 i=1,klon + eta (i) = 0.0 + beta (i) = 0.0 + ds1 (i) = 0.0 + ds2 (i) = 0.0 + ds3 (i) = 0.0 + dq1 (i) = 0.0 + dq2 (i) = 0.0 + dq3 (i) = 0.0 +C +C Specification of "cloud base" conditions +C + qprime = 0.0 + tprime = 0.0 +C +C Assign tprime within the PBL to be proportional to the quantity +C thtap (which will be bounded by tpmax), passed to this routine by +C the PBL routine. Don't allow perturbation to produce a dry +C adiabatically unstable parcel. Assign qprime within the PBL to be +C an appropriately modified value of the quantity shp (which will be +C bounded by shpmax) passed to this routine by the PBL routine. The +C quantity qprime should be less than the local saturation value +C (qsattp=qsat[t+tprime,p]). In both cases, thtap and shp are +C linearly reduced toward zero as the PBL top is approached. +C + pblhgt = MAX(pblh(i),1.0) + IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.0) THEN + fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt) + tprime = MIN(thtap(i),tpmax)*fac1 + qsattp = shbs(i,kp1) + RCPD/RLVTT*gam(i,kp1)*tprime + shprme = MIN(MIN(shp(i),shpmax)*fac1, + $ MAX(qsattp-shb(i,kp1),0.0)) + qprime = MAX(qprime,shprme) + ELSE + tprime = 0.0 + qprime = 0.0 + ENDIF +C +C Specify "updraft" (in-cloud) thermodynamic properties +C + sc (i) = sb (i,kp1) + RCPD*tprime + shc(i) = shb(i,kp1) + qprime + hc (i) = sc (i ) + RLVTT*shc(i) + flotab(i) = hc(i) - hbs(i,k) + dz = dp(i,k)*RD*tb(i,k)/RG/p(i,k) + IF (flotab(i).gt.0.0) THEN + dzcld(i) = dzcld(i) + dz + ELSE + dzcld(i) = 0.0 + ENDIF + 10 CONTINUE +C +C Check on moist convective instability +C + is = 0 + DO i = 1, klon + IF (flotab(i).GT.0.0) THEN + ldcum(i) = .TRUE. + is = is + 1 + ELSE + ldcum(i) = .FALSE. + ENDIF + ENDDO +C + IF (is.EQ.0) THEN + DO i=1,klon + dzcld(i) = 0.0 + ENDDO + GOTO 70 + ENDIF +C +C Current level just below top level => no overshoot +C + IF (k.le.limcnv+1) THEN + DO i=1,klon + IF (ldcum(i)) THEN + cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k)) + cldwtr(i) = MAX(0.0,cldwtr(i)) + beta(i) = 0.0 + ENDIF + ENDDO + GOTO 20 + ENDIF +C +C First guess at overshoot parameter using crude buoyancy closure +C 10% overshoot assumed as a minimum and 1-c0*dz maximum to start +C If pre-existing supersaturation in detrainment layer, beta=0 +C cldwtr is temporarily equal to RLVTT*l (l=> liquid water) +C + DO i=1,klon + IF (ldcum(i)) THEN + cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k)) + cldwtr(i) = MAX(0.0,cldwtr(i)) + betamx = 1.0 - c0*MAX(0.0,(dzcld(i)-dzmin)) + b1 = (hc(i) - hbs(i,km1))*dp(i,km1) + b2 = (hc(i) - hbs(i,k ))*dp(i,k ) + beta(i) = MAX(betamn,MIN(betamx, 1.0+b1/b2)) + IF (hbs(i,km1).le.hb(i,km1)) beta(i) = 0.0 + ENDIF + ENDDO +C +C Bound maximum beta to ensure physically realistic solutions +C +C First check constrains beta so that eta remains positive +C (assuming that eta is already positive for beta equal zero) +c La premiere contrainte de beta est que le flux eta doit etre positif. +C + DO i=1,klon + IF (ldcum(i)) THEN + tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i)) + $ - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1) + tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k)) + IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN + betamx = 0.99*(tmp1/tmp2) + beta(i) = MAX(0.0,MIN(betamx,beta(i))) + ENDIF +C +C Second check involves supersaturation of "detrainment layer" +C small amount of supersaturation acceptable (by ssfac factor) +c La 2e contrainte est que la convection ne doit pas sursaturer +c la "detrainment layer", Neanmoins, une petite sursaturation +c est acceptee (facteur ssfac). +C + IF (hb(i,km1).lt.hbs(i,km1)) THEN + tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i)) + $ - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1) + tmp1 = tmp1/dp(i,k) + tmp2 = gam(i,km1)*(sbh(i,k)-sc(i) + cldwtr(i)) - + $ hbh(i,k) + hc(i) - sc(i) + sbh(i,k) + tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k) + tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2 + $ / (dp(i,km1)*(hbs(i,km1)-hb(i,km1))) + tmp3 + IF ((beta(i)*tmp4-tmp1).GT.0.0) THEN + betamx = ssfac*(tmp1/tmp4) + beta(i) = MAX(0.0,MIN(betamx,beta(i))) + ENDIF + ELSE + beta(i) = 0.0 + ENDIF +C +C Third check to avoid introducing 2 delta x thermodynamic +C noise in the vertical ... constrain adjusted h (or theta e) +C so that the adjustment doesn't contribute to "kinks" in h +C + g = MIN(0.0,hb(i,k)-hb(i,km1)) + tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt) / (hc(i)-hbs(i,k)) + tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i)) + $ - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1) + tmp1 = tmp1/dp(i,k) + tmp1 = tmp3*tmp1 + (hc(i) - hbh(i,kp1))/dp(i,k) + tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k) + $ + (hc(i)-hbh(i,k)-cldwtr(i)) + $ *(1.0/dp(i,k)+1.0/dp(i,kp1)) + IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN + betamx = 0.0 + IF (tmp2.NE.0.0) betamx = tmp1/tmp2 + beta(i) = MAX(0.0,MIN(betamx,beta(i))) + ENDIF + ENDIF + ENDDO +C +C Calculate mass flux required for stabilization. +C +C Ensure that the convective mass flux, eta, is positive by +C setting negative values of eta to zero.. +C Ensure that estimated mass flux cannot move more than the +C minimum of total mass contained in either layer k or layer k+1. +C Also test for other pathological cases that result in non- +C physical states and adjust eta accordingly. +C + 20 CONTINUE + DO i=1,klon + IF (ldcum(i)) THEN + beta(i) = MAX(0.0,beta(i)) + tmp1 = hc(i) - hbs(i,k) + tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - + $ beta(i)*(1.0+gam(i,k))*(sc(i)-sbh(i,k)))/dp(i,k) - + $ (hbh(i,kp1)-hc(i))/dp(i,kp1) + eta(i) = tmp1/(tmp2*RG*cats) + tmass = MIN(dp(i,k),dp(i,kp1))/RG + IF (eta(i).GT.tmass*rdt .OR. eta(i).LE.0.0) eta(i) = 0.0 +C +C Check on negative q in top layer (bound beta) +C + IF(shc(i)-shbh(i,k).LT.0.0 .AND. beta(i)*eta(i).NE.0.0)THEN + denom = eta(i)*RG*dt*(shc(i) - shbh(i,k))/dp(i,km1) + beta(i) = MAX(0.0,MIN(-0.999*shb(i,km1)/denom,beta(i))) + ENDIF +C +C Check on negative q in middle layer (zero eta) +C + qtest1 = shb(i,k) + eta(i)*RG*dt*((shc(i) - shbh(i,kp1)) - + $ (1.0 - beta(i))*cldwtr(i)/RLVTT - + $ beta(i)*(shc(i) - shbh(i,k)))/dp(i,k) + IF (qtest1.le.0.0) eta(i) = 0.0 +C +C Check on negative q in lower layer (bound eta) +C + fac1 = -(shbh(i,kp1) - shc(i))/dp(i,kp1) + qtest2 = shb(i,kp1) - eta(i)*RG*dt*fac1 + IF (qtest2 .lt. 0.0) THEN + eta(i) = 0.99*shb(i,kp1)/(RG*dt*fac1) + ENDIF + ENDIF + ENDDO +C +C +C Calculate cloud water, rain water, and thermodynamic changes +C + DO 30 i=1,klon + IF (ldcum(i)) THEN + etagdt = eta(i)*RG*dt + cldwtr(i) = etagdt*cldwtr(i)/RLVTT/RG + rnwtr(i) = (1.0 - beta(i))*cldwtr(i) + ds1(i) = etagdt*(sbh(i,kp1) - sc(i))/dp(i,kp1) + dq1(i) = etagdt*(shbh(i,kp1) - shc(i))/dp(i,kp1) + ds2(i) = (etagdt*(sc(i) - sbh(i,kp1)) + + $ RLVTT*RG*cldwtr(i) - beta(i)*etagdt* + $ (sc(i) - sbh(i,k)))/dp(i,k) + dq2(i) = (etagdt*(shc(i) - shbh(i,kp1)) - + $ RG*rnwtr(i) - beta(i)*etagdt* + $ (shc(i) - shbh(i,k)))/dp(i,k) + ds3(i) = beta(i)*(etagdt*(sc(i) - sbh(i,k)) - + $ RLVTT*RG*cldwtr(i))/dp(i,km1) + dq3(i) = beta(i)*etagdt*(shc(i) - shbh(i,k))/dp(i,km1) +C +C Isolate convective fluxes for later diagnostics +C + fslkp = eta(i)*(sc(i) - sbh(i,kp1)) + fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) - + $ RLVTT*cldwtr(i)*rdt) + fqlkp = eta(i)*(shc(i) - shbh(i,kp1)) + fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k)) +C +C +C Update thermodynamic profile (update sb, hb, & hbs later) +C + tb (i,kp1) = tb(i,kp1) + ds1(i) / RCPD + tb (i,k ) = tb(i,k ) + ds2(i) / RCPD + tb (i,km1) = tb(i,km1) + ds3(i) / RCPD + shb(i,kp1) = shb(i,kp1) + dq1(i) + shb(i,k ) = shb(i,k ) + dq2(i) + shb(i,km1) = shb(i,km1) + dq3(i) + prec(i) = prec(i) + rnwtr(i)/rhoh2o +C +C Update diagnostic information for final budget +C Tracking temperature & specific humidity tendencies, +C rainout term, convective mass flux, convective liquid +C water static energy flux, and convective total water flux +C + cmfdt (i,kp1) = cmfdt (i,kp1) + ds1(i)/RCPD*rdt + cmfdt (i,k ) = cmfdt (i,k ) + ds2(i)/RCPD*rdt + cmfdt (i,km1) = cmfdt (i,km1) + ds3(i)/RCPD*rdt + cmfdq (i,kp1) = cmfdq (i,kp1) + dq1(i)*rdt + cmfdq (i,k ) = cmfdq (i,k ) + dq2(i)*rdt + cmfdq (i,km1) = cmfdq (i,km1) + dq3(i)*rdt + cmfdqr(i,k ) = cmfdqr(i,k ) + (RG*rnwtr(i)/dp(i,k))*rdt + cmfmc (i,kp1) = cmfmc (i,kp1) + eta(i) + cmfmc (i,k ) = cmfmc (i,k ) + beta(i)*eta(i) + cmfsl (i,kp1) = cmfsl (i,kp1) + fslkp + cmfsl (i,k ) = cmfsl (i,k ) + fslkm + cmflq (i,kp1) = cmflq (i,kp1) + RLVTT*fqlkp + cmflq (i,k ) = cmflq (i,k ) + RLVTT*fqlkm + qc (i,k ) = (RG*rnwtr(i)/dp(i,k))*rdt + ENDIF + 30 CONTINUE +C +C Next, convectively modify passive constituents +C + DO 50 m=1,pcnst + DO 40 i=1,klon + IF (ldcum(i)) THEN +C +C If any of the reported values of the constituent is negative in +C the three adjacent levels, nothing will be done to the profile +C + IF ((cmrb(i,kp1,m).LT.0.0) .OR. + $ (cmrb(i,k,m).LT.0.0) .OR. + $ (cmrb(i,km1,m).LT.0.0)) GOTO 40 +C +C Specify constituent interface values (linear interpolation) +C + cmrh(i,k ) = 0.5*(cmrb(i,km1,m) + cmrb(i,k ,m)) + cmrh(i,kp1) = 0.5*(cmrb(i,k ,m) + cmrb(i,kp1,m)) +C +C Specify perturbation properties of constituents in PBL +C + pblhgt = MAX(pblh(i),1.0) + IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.) THEN + fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt) + cmrc(i) = cmrb(i,kp1,m) + cmrp(i,m)*fac1 + ELSE + cmrc(i) = cmrb(i,kp1,m) + ENDIF +C +C Determine fluxes, flux divergence => changes due to convection +C Logic must be included to avoid producing negative values. A bit +C messy since there are no a priori assumptions about profiles. +C Tendency is modified (reduced) when pending disaster detected. +C + etagdt = eta(i)*RG*dt + botflx = etagdt*(cmrc(i) - cmrh(i,kp1)) + topflx = beta(i)*etagdt*(cmrc(i)-cmrh(i,k)) + dcmr1(i) = -botflx/dp(i,kp1) + efac1 = 1.0 + efac2 = 1.0 + efac3 = 1.0 +C + IF (cmrb(i,kp1,m)+dcmr1(i) .LT. 0.0) THEN + efac1 = MAX(tiny,ABS(cmrb(i,kp1,m)/dcmr1(i)) - eps) + ENDIF +C + IF (efac1.EQ.tiny .OR. efac1.GT.1.0) efac1 = 0.0 + dcmr1(i) = -efac1*botflx/dp(i,kp1) + dcmr2(i) = (efac1*botflx - topflx)/dp(i,k) +C + IF (cmrb(i,k,m)+dcmr2(i) .LT. 0.0) THEN + efac2 = MAX(tiny,ABS(cmrb(i,k ,m)/dcmr2(i)) - eps) + ENDIF +C + IF (efac2.EQ.tiny .OR. efac2.GT.1.0) efac2 = 0.0 + dcmr2(i) = (efac1*botflx - efac2*topflx)/dp(i,k) + dcmr3(i) = efac2*topflx/dp(i,km1) +C + IF (cmrb(i,km1,m)+dcmr3(i) .LT. 0.0) THEN + efac3 = MAX(tiny,ABS(cmrb(i,km1,m)/dcmr3(i)) - eps) + ENDIF +C + IF (efac3.EQ.tiny .OR. efac3.GT.1.0) efac3 = 0.0 + efac3 = MIN(efac2,efac3) + dcmr2(i) = (efac1*botflx - efac3*topflx)/dp(i,k) + dcmr3(i) = efac3*topflx/dp(i,km1) +C + cmrb(i,kp1,m) = cmrb(i,kp1,m) + dcmr1(i) + cmrb(i,k ,m) = cmrb(i,k ,m) + dcmr2(i) + cmrb(i,km1,m) = cmrb(i,km1,m) + dcmr3(i) + ENDIF + 40 CONTINUE + 50 CONTINUE ! end of m=1,pcnst loop +C + IF (k.EQ.limcnv+1) GOTO 60 ! on ne pourra plus glisser +c +c Dans la procedure de glissage ascendant, les variables thermo- +c dynamiques des couches k et km1 servent au calcul des couches +c superieures. Elles ont donc besoin d'une mise-a-jour. +C + DO i = 1, klon + IF (ldcum(i)) THEN + zx_t = tb(i,k) + zx_p = p(i,k) + zx_q = shb(i,k) + zdelta=MAX(0.,SIGN(1.,RTT-zx_t)) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q) + zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor) + shbs(i,k) = zx_qs + gam(i,k) = zx_gam +c + zx_t = tb(i,km1) + zx_p = p(i,km1) + zx_q = shb(i,km1) + zdelta=MAX(0.,SIGN(1.,RTT-zx_t)) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q) + zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p + zx_qs=MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor) + shbs(i,km1) = zx_qs + gam(i,km1) = zx_gam +C + sb (i,k ) = sb(i,k ) + ds2(i) + sb (i,km1) = sb(i,km1) + ds3(i) + hb (i,k ) = sb(i,k ) + RLVTT*shb(i,k) + hb (i,km1) = sb(i,km1) + RLVTT*shb(i,km1) + hbs(i,k ) = sb(i,k ) + RLVTT*shbs(i,k ) + hbs(i,km1) = sb(i,km1) + RLVTT*shbs(i,km1) +C + sbh (i,k) = 0.5*(sb(i,k) + sb(i,km1)) + shbh(i,k) = qhalf(shb(i,km1),shb(i,k) + $ ,shbs(i,km1),shbs(i,k)) + hbh (i,k) = sbh(i,k) + RLVTT*shbh(i,k) + sbh (i,km1) = 0.5*(sb(i,km1) + sb(i,k-2)) + shbh(i,km1) = qhalf(shb(i,k-2),shb(i,km1), + $ shbs(i,k-2),shbs(i,km1)) + hbh (i,km1) = sbh(i,km1) + RLVTT*shbh(i,km1) + ENDIF + ENDDO +C +C Ensure that dzcld is reset if convective mass flux zero +C specify the current vertical extent of the convective activity +C top of convective layer determined by size of overshoot param. +C + 60 CONTINUE + DO i=1,klon + etagt0 = eta(i).gt.0.0 + IF (.not.etagt0) dzcld(i) = 0.0 + IF (etagt0 .and. beta(i).gt.betamn) THEN + ktp = km1 + ELSE + ktp = k + ENDIF + IF (etagt0) THEN + cnt(i) = MIN(cnt(i),ktp) + cnb(i) = MAX(cnb(i),k) + ENDIF + ENDDO + 70 CONTINUE ! end of k loop +C +C determine whether precipitation, prec, is frozen (snow) or not +C + DO i=1,klon + IF (tb(i,klev).LT.tmelt .AND. tb(i,klev-1).lt.tmelt) THEN + cmfprs(i) = prec(i)*rdt + ELSE + cmfprt(i) = prec(i)*rdt + ENDIF + ENDDO +C + RETURN ! we're all done ... return to calling procedure + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/concvl.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/concvl.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/concvl.F (revision 1634) @@ -0,0 +1,479 @@ + SUBROUTINE concvl (iflag_con,iflag_clos, + . dtime,paprs,pplay, + . t,q,t_wake,q_wake,s_wake,u,v,tra,ntra, + . ALE,ALP,work1,work2, + . d_t,d_q,d_u,d_v,d_tra, + . rain, snow, kbas, ktop, sigd, + . cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwdbis, + . Ma,mip,Vprecip, + . cape,cin,tvp,Tconv,iflag, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr, + . qcondc,wd,pmflxr,pmflxs, + . da,phi,mp,dd_t,dd_q,lalim_conv,wght_th) +*************************************************************** +* * +* CONCVL * +* * +* * +* written by : Sandrine Bony-Lena, 17/05/2003, 11.16.04 * +* modified by : * +*************************************************************** +* +c + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT none +c====================================================================== +c Auteur(s): S. Bony-Lena (LMD/CNRS) date: ??? +c Objet: schema de convection de Emanuel (1991) interface +c====================================================================== +c Arguments: +c dtime--input-R-pas d'integration (s) +c s-------input-R-la valeur "s" pour chaque couche +c sigs----input-R-la valeur "sigma" de chaque couche +c sig-----input-R-la valeur de "sigma" pour chaque niveau +c psolpa--input-R-la pression au sol (en Pa) +C pskapa--input-R-exponentiel kappa de psolpa +c h-------input-R-enthalpie potentielle (Cp*T/P**kappa) +c q-------input-R-vapeur d'eau (en kg/kg) +c +c work*: input et output: deux variables de travail, +c on peut les mettre a 0 au debut +c ALE-----input-R-energie disponible pour soulevement +c ALP-----input-R-puissance disponible pour soulevement +c +C d_h-----output-R-increment de l'enthalpie potentielle (h) +c d_q-----output-R-increment de la vapeur d'eau +c rain----output-R-la pluie (mm/s) +c snow----output-R-la neige (mm/s) +c upwd----output-R-saturated updraft mass flux (kg/m**2/s) +c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s) +c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s) +c Ma------output-R-adiabatic ascent mass flux (kg/m2/s) +c mip-----output-R-mass flux shed by adiabatic ascent (kg/m2/s) +c Vprecip-output-R-vertical profile of precipitations (kg/m2/s) +c Tconv---output-R-environment temperature seen by convective scheme (K) +c Cape----output-R-CAPE (J/kg) +c Cin ----output-R-CIN (J/kg) +c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee +c adiabatiquement a partir du niveau 1 (K) +c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa) +c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace +c dd_t-----output-R-increment de la temperature du aux descentes precipitantes +c dd_q-----output-R-increment de la vapeur d'eau du aux desc precip +c====================================================================== +c +#include "dimensions.h" +c + INTEGER iflag_con,iflag_clos +c + REAL dtime, paprs(klon,klev+1),pplay(klon,klev) + REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev) + REAL t_wake(klon,klev),q_wake(klon,klev) + Real s_wake(klon) + REAL tra(klon,klev,nbtr) + INTEGER ntra + REAL work1(klon,klev),work2(klon,klev),ptop2(klon) + REAL pmflxr(klon,klev+1),pmflxs(klon,klev+1) + REAL ALE(klon),ALP(klon) +c + REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev) + REAL dd_t(klon,klev),dd_q(klon,klev) + REAL d_tra(klon,klev,nbtr) + REAL rain(klon),snow(klon) +c + INTEGER kbas(klon),ktop(klon) + REAL em_ph(klon,klev+1),em_p(klon,klev) + REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev) + +!! REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev) !jyg + REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev+1) !jyg + + real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) + REAL cape(klon),cin(klon),tvp(klon,klev) + REAL Tconv(klon,klev) +c +cCR:test: on passe lentr et alim_star des thermiques + INTEGER lalim_conv(klon) + REAL wght_th(klon,klev) + REAL em_sig1feed ! sigma at lower bound of feeding layer + REAL em_sig2feed ! sigma at upper bound of feeding layer + REAL em_wght(klev) ! weight density determining the feeding mixture +con enleve le save +c SAVE em_sig1feed,em_sig2feed,em_wght +c + INTEGER iflag(klon) + REAL rflag(klon) + REAL pbase(klon),bbase(klon) + REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev) + REAL dplcldt(klon),dplcldr(klon) + REAL qcondc(klon,klev) + REAL wd(klon) + REAL Plim1(klon),Plim2(klon),asupmax(klon,klev) + REAL supmax0(klon),asupmaxmin(klon) +c + REAL sigd(klon) + REAL zx_t,zdelta,zx_qs,zcor +c +! INTEGER iflag_mix +! SAVE iflag_mix + INTEGER noff, minorig + INTEGER i,k,itra + REAL qs(klon,klev),qs_wake(klon,klev) + REAL cbmf(klon),plcl(klon),plfc(klon),wbeff(klon) +cLF SAVE cbmf +cIM/JYG REAL, SAVE, ALLOCATABLE :: cbmf(:) +ccc$OMP THREADPRIVATE(cbmf)! + REAL cbmflast(klon) + INTEGER ifrst + SAVE ifrst + DATA ifrst /0/ +c$OMP THREADPRIVATE(ifrst) + +c +C Variables supplementaires liees au bilan d'energie +c Real paire(klon) +cLF Real ql(klon,klev) +c Save paire +cLF Save ql +cLF Real t1(klon,klev),q1(klon,klev) +cLF Save t1,q1 +c Data paire /1./ + REAL, SAVE, ALLOCATABLE :: ql(:,:), q1(:,:), t1(:,:) +c$OMP THREADPRIVATE(ql, q1, t1) +c +C Variables liees au bilan d'energie et d'enthalpi + REAL ztsol(klon) + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot + SAVE h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot) +c$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot) + REAL d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec + REAL d_h_vcol_phy + REAL fs_bound, fq_bound + SAVE d_h_vcol_phy +c$OMP THREADPRIVATE(d_h_vcol_phy) + REAL zero_v(klon) + CHARACTER*15 ztit + INTEGER ip_ebil ! PRINT level for energy conserv. diag. + SAVE ip_ebil + DATA ip_ebil/2/ +c$OMP THREADPRIVATE(ip_ebil) + INTEGER if_ebil ! level for energy conserv. dignostics + SAVE if_ebil + DATA if_ebil/2/ +c$OMP THREADPRIVATE(if_ebil) +c+jld ec_conser + REAL d_t_ec(klon,klev) ! tendance du a la conersion Ec -> E thermique + REAL ZRCPD +c-jld ec_conser +cLF + INTEGER nloc + logical, save :: first=.true. +c$OMP THREADPRIVATE(first) + INTEGER, SAVE :: itap, igout +c$OMP THREADPRIVATE(itap, igout) +c +#include "YOMCST.h" +#include "YOMCST2.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +c + if (first) then +c Allocate some variables LF 04/2008 +c +cIM/JYG allocate(cbmf(klon)) + allocate(ql(klon,klev)) + allocate(t1(klon,klev)) + allocate(q1(klon,klev)) + itap=0 + igout=klon/2+1/klon + endif +c Incrementer le compteur de la physique + itap = itap + 1 + +c Copy T into Tconv + DO k = 1,klev + DO i = 1,klon + Tconv(i,k) = T(i,k) + ENDDO + ENDDO +c + IF (if_ebil.ge.1) THEN + DO i=1,klon + ztsol(i) = t(i,1) + zero_v(i)=0. + Do k = 1,klev + ql(i,k) = 0. + ENDDO + END DO + END IF +c +cym + snow(:)=0 + +c IF (ifrst .EQ. 0) THEN +c ifrst = 1 + if (first) then + first=.false. +c +C=========================================================================== +C READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION +C=========================================================================== +C + if (iflag_con.eq.3) then +c CALL cv3_inicp() + CALL cv3_inip() + endif +c +C=========================================================================== +C READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS +C=========================================================================== +C +cc$$$ open (56,file='supcrit.data') +cc$$$ read (56,*) Supcrit1, Supcrit2 +cc$$$ close (56) +c + print*, 'supcrit1, supcrit2' ,supcrit1, supcrit2 +C +C=========================================================================== +C Initialisation pour les bilans d'eau et d'energie +C=========================================================================== + IF (if_ebil.ge.1) d_h_vcol_phy=0. +c + DO i = 1, klon + cbmf(i) = 0. + plcl(i) = 0. + plfc(i) = 0. + wbeff(i) = 0. + sigd(i) = 0. + ENDDO + ENDIF !(ifrst .EQ. 0) + + DO k = 1, klev+1 + DO i=1,klon + em_ph(i,k) = paprs(i,k) / 100.0 + pmflxr(i,k)=0. + pmflxs(i,k)=0. + ENDDO + ENDDO +c + DO k = 1, klev + DO i=1,klon + em_p(i,k) = pplay(i,k) / 100.0 + ENDDO + ENDDO +c +! +! Feeding layer +! + em_sig1feed = 1. + em_sig2feed = 0.97 +c em_sig2feed = 0.8 +! Relative Weight densities + do k=1,klev + em_wght(k)=1. + end do +cCRtest: couche alim des tehrmiques ponderee par a* +c DO i = 1, klon +c do k=1,lalim_conv(i) +c em_wght(k)=wght_th(i,k) +c print*,'em_wght=',em_wght(k),wght_th(i,k) +c end do +c END DO + + if (iflag_con .eq. 4) then + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0) + zcor=1./(1.-retv*zx_qs) + qs(i,k)=zx_qs*zcor + ENDDO + DO i = 1, klon + zx_t = t_wake(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0) + zcor=1./(1.-retv*zx_qs) + qs_wake(i,k)=zx_qs*zcor + ENDDO + ENDDO + else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique) + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0 + zx_qs= MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + qs(i,k)=zx_qs + ENDDO + DO i = 1, klon + zx_t = t_wake(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0 + zx_qs= MIN(0.5,zx_qs) + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + qs_wake(i,k)=zx_qs + ENDDO + ENDDO + endif ! iflag_con +c +C------------------------------------------------------------------ + +C Main driver for convection: +C iflag_con=3 -> nvlle version de KE (JYG) +C iflag_con = 30 -> equivalent to convect3 +C iflag_con = 4 -> equivalent to convect1/2 +c +c + if (iflag_con.eq.30) then + + CALL cv_driver(klon,klev,klev+1,ntra,iflag_con, + : t,q,qs,u,v,tra, + $ em_p,em_ph,iflag, + $ d_t,d_q,d_u,d_v,d_tra,rain, +!! $ pmflxr,cbmf,work1,work2, !jyg + $ Vprecip,cbmf,work1,work2, !jyg + $ kbas,ktop, + $ dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape, + $ da,phi,mp) +c + DO i = 1,klon + cbmf(i) = Ma(i,kbas(i)) + ENDDO +c + else + +cLF necessary for gathered fields + nloc=klon + CALL cva_driver(klon,klev,klev+1,ntra,nloc, + $ iflag_con,iflag_mix,iflag_clos,dtime, + : t,q,qs,t_wake,q_wake,qs_wake,s_wake,u,v,tra, + $ em_p,em_ph, + . ALE,ALP, + . em_sig1feed,em_sig2feed,em_wght, + . iflag,d_t,d_q,d_u,d_v,d_tra,rain,kbas,ktop, + $ cbmf,plcl,plfc,wbeff,work1,work2,ptop2,sigd, + $ Ma,mip,Vprecip,upwd,dnwd,dnwdbis,qcondc,wd, + $ cape,cin,tvp, + $ dd_t,dd_q,Plim1,Plim2,asupmax,supmax0, + $ asupmaxmin,lalim_conv) + endif +C------------------------------------------------------------------ + print *,' cva_driver -> cbmf,plcl,plfc,wbeff ', + . cbmf(1),plcl(1),plfc(1),wbeff(1) + + DO i = 1,klon + rain(i) = rain(i)/86400. + rflag(i)=iflag(i) + ENDDO + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = dtime*d_t(i,k) + d_q(i,k) = dtime*d_q(i,k) + d_u(i,k) = dtime*d_u(i,k) + d_v(i,k) = dtime*d_v(i,k) + ENDDO + ENDDO +c + if (iflag_con.eq.30) then + DO itra = 1,ntra + DO k = 1, klev + DO i = 1, klon + d_tra(i,k,itra) =dtime*d_tra(i,k,itra) + ENDDO + ENDDO + ENDDO + endif + + DO k = 1, klev + DO i = 1, klon + t1(i,k) = t(i,k)+ d_t(i,k) + q1(i,k) = q(i,k)+ d_q(i,k) + ENDDO + ENDDO +c !jyg +c--Separation neige/pluie (pour diagnostics) !jyg + DO k = 1, klev !jyg + DO i = 1, klon !jyg + IF (t1(i,k).LT.RTT) THEN !jyg + pmflxs(i,k)=Vprecip(i,k) !jyg + ELSE !jyg + pmflxr(i,k)=Vprecip(i,k) !jyg + ENDIF !jyg + ENDDO !jyg + ENDDO !jyg +c +cc IF (if_ebil.ge.2) THEN +cc ztit='after convect' +cc CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime +cc e , t1,q1,ql,qs,u,v,paprs,pplay +cc s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +cc call diagphy(paire,ztit,ip_ebil +cc e , zero_v, zero_v, zero_v, zero_v, zero_v +cc e , zero_v, rain, zero_v, ztsol +cc e , d_h_vcol, d_qt, d_ec +cc s , fs_bound, fq_bound ) +cc END IF +C +c +c les traceurs ne sont pas mis dans cette version de convect4: + if (iflag_con.eq.4) then + DO itra = 1,ntra + DO k = 1, klev + DO i = 1, klon + d_tra(i,k,itra) = 0. + ENDDO + ENDDO + ENDDO + endif +c print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1) + + DO k = 1, klev + DO i = 1, klon + dtvpdt1(i,k) = 0. + dtvpdq1(i,k) = 0. + ENDDO + ENDDO + DO i = 1, klon + dplcldt(i) = 0. + dplcldr(i) = 0. + ENDDO +c + if(prt_level.GE.20) THEN + DO k=1,klev +! print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout +! .,k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k), +! .d_q_con(igout,k),dql0(igout,k) +! print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q' +! .,itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout), +! . t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k) +! print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip' +! .,itap,rain_con(igout),snow_con(igout),ema_work1(igout,k), +! .ema_work2(igout,k),Vprecip(igout,k), mip(igout,k) +! print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv ' +! .,itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout), +! .tvp(igout,k),Tconv(igout,k) +! print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc' +! .,itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout), +! .dplcldr(igout),qcondc(igout,k) +! print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1' +! .,itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k) +! .,pmflxs(igout,k+1) +! print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth', +! .itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k), +! . fqd(igout,k),lalim_conv(igout),wght_th(igout,k) + ENDDO + endif !(prt_level.EQ.20) THEN +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/condsurf.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/condsurf.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/condsurf.F (revision 1634) @@ -0,0 +1,139 @@ +c $Header$ +c + SUBROUTINE condsurf( jour, jourvrai, lmt_bils ) + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT none +c +c I. Musat 05.2005 +c +c Lire chaque jour le bilan de chaleur au sol issu +c d'un run atmospherique afin de l'utiliser dans +c dans un run "slab" ocean +c ----------------------------------------- +c jour : input , numero du jour a lire +c jourvrai : input , vrai jour de la simulation +c +c lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean") +c +#include "netcdf.inc" + INTEGER nid, nvarid + INTEGER debut(2) + INTEGER epais(2) +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "indicesol.h" +#include "temps.h" +#include "clesphys.h" +c + INTEGER nannemax + PARAMETER ( nannemax = 60 ) +c + INTEGER jour, jourvrai + REAL lmt_bils(klon) !bilan chaleur au sol +c +c Variables locales: + INTEGER ig, i, kt, ierr + LOGICAL ok + INTEGER anneelim,anneemax + CHARACTER*20 fich + + REAL :: lmt_bils_glo(klon_glo) + +cc +cc ..................................................................... +cc +cc Pour lire le fichier limit correspondant vraiment a l'annee de la +cc simulation en cours , il suffit de mettre ok_limitvrai = .TRUE. +cc +cc ...................................................................... +c +c + + IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN + PRINT*,'Le jour demande n est pas correct: ', jour + CALL ABORT + ENDIF +c + anneelim = annee_ref + anneemax = annee_ref + nannemax +c +c + IF( ok_limitvrai ) THEN + DO kt = 1, nannemax + IF(jourvrai.LE. (kt-1)*360 + 359 ) THEN + WRITE(fich,'("limit",i4,".nc")') anneelim +c PRINT *,' Fichier Limite ',fich + GO TO 100 + ENDIF + anneelim = anneelim + 1 + ENDDO + + PRINT *,' PBS ! Le jour a lire sur le fichier limit ne se ' + PRINT *,' trouve pas sur les ',nannemax,' annees a partir de ' + PRINT *,' l annee de debut', annee_ref + CALL EXIT(1) +c +100 CONTINUE +c + ELSE + + WRITE(fich,'("limitNEW.nc")') +c PRINT *,' Fichier Limite ',fich + ENDIF +c +c Ouvrir le fichier en format NetCDF: +c +c$OMP MASTER + IF (is_mpi_root) THEN + ierr = NF_OPEN (fich, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)' Pb d''ouverture du fichier ', fich + WRITE(6,*)' Le fichier limit ',fich,' (avec 4 chiffres , pour' + WRITE(6,*)' l an 2000 ) , n existe pas ! ' + WRITE(6,*)' ierr = ', ierr + CALL EXIT(1) + ENDIF +c DO k = 1, jour +c La tranche de donnees a lire: +c + debut(1) = 1 + debut(2) = jourvrai + epais(1) = klon_glo + epais(2) = 1 +c Bilan flux de chaleur au sol: +c + ierr = NF_INQ_VARID (nid, "BILS", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "condsurf: Le champ est absent" + CALL abort + ENDIF + PRINT*,'debut,epais',debut,epais,'jour,jourvrai',jour,jourvrai +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_bils_glo) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_bils_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "condsurf: Lecture echouee pour " + CALL abort + ENDIF +c ENDDO !k = 1, jour +c +c Fermer le fichier: +c + ierr = NF_CLOSE(nid) + + ENDIF ! is_mpi_root==0 + +c$OMP END MASTER + CALL scatter(lmt_bils_glo,lmt_bils) + +c +c +c PRINT*, 'lmt_bils est lu pour jour: ', jour +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conema3.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conema3.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conema3.F (revision 1634) @@ -0,0 +1,420 @@ +! +! $Id$ +! + SUBROUTINE conema3 (dtime,paprs,pplay,t,q,u,v,tra,ntra, + . work1,work2,d_t,d_q,d_u,d_v,d_tra, + . rain, snow, kbas, ktop, + . upwd,dnwd,dnwdbis,bas,top,Ma,cape,tvp,rflag, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr, + . qcond_incld) + + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: schema de convection de Emanuel (1991) interface +c Mai 1998: Interface modifiee pour implementation dans LMDZ +c====================================================================== +c Arguments: +c dtime---input-R-pas d'integration (s) +c paprs---input-R-pression inter-couches (Pa) +c pplay---input-R-pression au milieu des couches (Pa) +c t-------input-R-temperature (K) +c q-------input-R-humidite specifique (kg/kg) +c u-------input-R-vitesse du vent zonal (m/s) +c v-------input-R-vitesse duvent meridien (m/s) +c tra-----input-R-tableau de rapport de melange des traceurs +c work*: input et output: deux variables de travail, +c on peut les mettre a 0 au debut +c +C d_t-----output-R-increment de la temperature +c d_q-----output-R-increment de la vapeur d'eau +c d_u-----output-R-increment de la vitesse zonale +c d_v-----output-R-increment de la vitesse meridienne +c d_tra---output-R-increment du contenu en traceurs +c rain----output-R-la pluie (mm/s) +c snow----output-R-la neige (mm/s) +c kbas----output-R-bas du nuage (integer) +c ktop----output-R-haut du nuage (integer) +c upwd----output-R-saturated updraft mass flux (kg/m**2/s) +c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s) +c dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s) +c bas-----output-R-bas du nuage (real) +c top-----output-R-haut du nuage (real) +c Ma------output-R-flux ascendant non dilue (kg/m**2/s) +c cape----output-R-CAPE +c tvp-----output-R-virtual temperature of the lifted parcel +c rflag---output-R-flag sur le fonctionnement de convect +c pbase---output-R-pression a la base du nuage (Pa) +c bbase---output-R-buoyancy a la base du nuage (K) +c dtvpdt1-output-R-derivative of parcel virtual temp wrt T1 +c dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1 +c dplcldt-output-R-derivative of the PCP pressure wrt T1 +c dplcldr-output-R-derivative of the PCP pressure wrt Q1 +c====================================================================== +c +#include "dimensions.h" +#include "conema3.h" + INTEGER i, l,m,itra + INTEGER ntra ! if no tracer transport + ! is needed, set ntra = 1 (or 0) + REAL dtime +c + REAL d_t2(klon,klev), d_q2(klon,klev) ! sbl + REAL d_u2(klon,klev), d_v2(klon,klev) ! sbl + REAL em_d_t2(klev), em_d_q2(klev) ! sbl + REAL em_d_u2(klev), em_d_v2(klev) ! sbl +c + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev), q(klon,klev), d_t(klon,klev), d_q(klon,klev) + REAL u(klon,klev), v(klon,klev), tra(klon,klev,ntra) + REAL d_u(klon,klev), d_v(klon,klev), d_tra(klon,klev,ntra) + REAL work1(klon,klev), work2(klon,klev) + REAL upwd(klon,klev), dnwd(klon,klev), dnwdbis(klon,klev) + REAL rain(klon) + REAL snow(klon) + REAL cape(klon), tvp(klon,klev), rflag(klon) + REAL pbase(klon), bbase(klon) + REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) + REAL dplcldt(klon), dplcldr(klon) + INTEGER kbas(klon), ktop(klon) + + REAL wd(klon) + REAL qcond_incld(klon,klev) +c + LOGICAL,SAVE :: first=.true. +c$OMP THREADPRIVATE(first) + +cym REAL em_t(klev) + REAL,ALLOCATABLE,SAVE :: em_t(:) +c$OMP THREADPRIVATE(em_t) +cym REAL em_q(klev) + REAL,ALLOCATABLE,SAVE :: em_q(:) +c$OMP THREADPRIVATE(em_q) +cym REAL em_qs(klev) + REAL,ALLOCATABLE,SAVE :: em_qs(:) +c$OMP THREADPRIVATE(em_qs) +cym REAL em_u(klev), em_v(klev), em_tra(klev,nbtr) + REAL,ALLOCATABLE,SAVE :: em_u(:),em_v(:),em_tra(:,:) +c$OMP THREADPRIVATE(em_u,em_v,em_tra) +cym REAL em_ph(klev+1), em_p(klev) + REAL,ALLOCATABLE,SAVE ::em_ph(:),em_p(:) +c$OMP THREADPRIVATE(em_ph,em_p) +cym REAL em_work1(klev), em_work2(klev) + REAL,ALLOCATABLE,SAVE ::em_work1(:),em_work2(:) +c$OMP THREADPRIVATE(em_work1,em_work2) +cym REAL em_precip, em_d_t(klev), em_d_q(klev) + REAL,SAVE :: em_precip +c$OMP THREADPRIVATE(em_precip) + REAL,ALLOCATABLE,SAVE :: em_d_t(:),em_d_q(:) +c$OMP THREADPRIVATE(em_d_t,em_d_q) +cym REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr) + REAL,ALLOCATABLE,SAVE ::em_d_u(:),em_d_v(:),em_d_tra(:,:) +c$OMP THREADPRIVATE(em_d_u,em_d_v,em_d_tra) +cym REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev) + REAL,ALLOCATABLE,SAVE :: em_upwd(:),em_dnwd(:),em_dnwdbis(:) +c$OMP THREADPRIVATE(em_upwd,em_dnwd,em_dnwdbis) + REAL em_dtvpdt1(klev), em_dtvpdq1(klev) + REAL em_dplcldt, em_dplcldr +cym SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2 +cym SAVE em_u,em_v, em_tra +cym SAVE em_d_u,em_d_v, em_d_tra +cym SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis + + INTEGER em_bas, em_top + SAVE em_bas, em_top +c$OMP THREADPRIVATE(em_bas,em_top) + REAL em_wd + REAL em_qcond(klev) + REAL em_qcondc(klev) +c + REAL zx_t, zx_qs, zdelta, zcor + INTEGER iflag + REAL sigsum +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c VARIABLES A SORTIR +cccccccccccccccccccccccccccccccccccccccccccccccccc + +cym REAL emmip(klev) !variation de flux ascnon dilue i et i+1 + REAL,ALLOCATABLE,SAVE ::emmip(:) +c$OMP THREADPRIVATE(emmip) +cym SAVE emmip +cym real emMke(klev) + REAL,ALLOCATABLE,SAVE ::emMke(:) +c$OMP THREADPRIVATE(emMke) +cym save emMke + real top + real bas +cym real emMa(klev) + REAL,ALLOCATABLE,SAVE ::emMa(:) +c$OMP THREADPRIVATE(emMa) +cym save emMa + real Ma(klon,klev) + real Ment(klev,klev) + real Qent(klev,klev) + real TPS(klev),TLS(klev) + real SIJ(klev,klev) + real em_CAPE, em_TVP(klev) + real em_pbase, em_bbase + integer iw,j,k,ix,iy + +c -- sb: pour schema nuages: + + integer iflagcon + integer em_ifc(klev) + + real em_pradj + real em_cldf(klev), em_cldq(klev) + real em_ftadj(klev), em_fradj(klev) + + integer ifc(klon,klev) + real pradj(klon) + real cldf(klon,klev), cldq(klon,klev) + real ftadj(klon,klev), fqadj(klon,klev) + +c sb -- + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + + if (first) then + + allocate(em_t(klev)) + allocate(em_q(klev)) + allocate(em_qs(klev)) + allocate(em_u(klev), em_v(klev), em_tra(klev,nbtr)) + allocate(em_ph(klev+1), em_p(klev)) + allocate(em_work1(klev), em_work2(klev)) + allocate(em_d_t(klev), em_d_q(klev)) + allocate(em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr)) + allocate(em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)) + allocate(emmip(klev)) + allocate(emMke(klev)) + allocate(emMa(klev)) + + first=.false. + endif + + qcond_incld(:,:) = 0. +c +c@$$ print*,'debut conema' + + DO 999 i = 1, klon + DO l = 1, klev+1 + em_ph(l) = paprs(i,l) / 100.0 + ENDDO +c + DO l = 1, klev + em_p(l) = pplay(i,l) / 100.0 + em_t(l) = t(i,l) + em_q(l) = q(i,l) + em_u(l) = u(i,l) + em_v(l) = v(i,l) + do itra = 1, ntra + em_tra(l,itra) = tra(i,l,itra) + enddo +c@$$ print*,'em_t',em_t +c@$$ print*,'em_q',em_q +c@$$ print*,'em_qs',em_qs +c@$$ print*,'em_u',em_u +c@$$ print*,'em_v',em_v +c@$$ print*,'em_tra',em_tra +c@$$ print*,'em_p',em_p + + +c + zx_t = em_t(l) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(l)/100.0 + zx_qs=MIN(0.5,zx_qs) +c@$$ print*,'zx_qs',zx_qs + zcor=1./(1.-retv*zx_qs) + zx_qs=zx_qs*zcor + em_qs(l) = zx_qs +c@$$ print*,'em_qs',em_qs +c + em_work1(l) = work1(i,l) + em_work2(l) = work2(i,l) + emMke(l)=0 +c emMa(l)=0 +c Ma(i,l)=0 + + em_dtvpdt1(l) = 0. + em_dtvpdq1(l) = 0. + dtvpdt1(i,l) = 0. + dtvpdq1(i,l) = 0. + ENDDO +c + em_dplcldt = 0. + em_dplcldr = 0. + rain(i) = 0.0 + snow(i) = 0.0 + kbas(i) = 1 + ktop(i) = 1 +c ajout SB: + bas = 1 + top = 1 + + +c sb3d write(*,1792) (em_work1(m),m=1,klev) +1792 format('sig avant convect ',/,10(1X,E13.5)) +c +c sb d write(*,1793) (em_work2(m),m=1,klev) +1793 format('w avant convect ',/,10(1X,E13.5)) + +c@$$ print*,'avant convect' +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + +c print*,'avant convect i=',i + CALL convect3(dtime,epmax,ok_adj_ema, + . em_t, em_q, em_qs,em_u ,em_v , + . em_tra, em_p, em_ph, + . klev, klev+1, klev-1,ntra, dtime, iflag, + . em_d_t, em_d_q,em_d_u,em_d_v, + . em_d_tra, em_precip, + . em_bas, em_top,em_upwd, em_dnwd, em_dnwdbis, + . em_work1, em_work2,emmip,emMke,emMa,Ment, + . Qent,TPS,TLS,SIJ,em_CAPE,em_TVP,em_pbase,em_bbase, + . em_dtvpdt1,em_dtvpdq1,em_dplcldt,em_dplcldr, ! sbl + . em_d_t2,em_d_q2,em_d_u2,em_d_v2,em_wd,em_qcond,em_qcondc)!sbl +c print*,'apres convect ' +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c -- sb: Appel schema statistique de nuages couple a la convection +c (Bony et Emanuel 2001): + +c -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ: + + iflagcon = 3 +c CALL cv_thermo(iflagcon) + +c -- appel schema de nuages: + +c CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t +c i ,em_p,em_ph,dtime,em_qcondc +c o ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc) + + do k = 1, klev + cldf(i,k) = em_cldf(k) ! cloud fraction (0-1) + cldq(i,k) = em_cldq(k) ! in-cloud water content (kg/kg) + ftadj(i,k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s) + fqadj(i,k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s) + ifc(i,k) = em_ifc(k) ! flag convergence clouds_gno (1 ou 2) + enddo + pradj(i) = em_pradj ! precip from LS supersat adj (mm/day) + +c sb -- +c +c SB: + if (iflag.ne.1 .and. iflag.ne.4) then + em_CAPE = 0. + do l = 1, klev + em_upwd(l) = 0. + em_dnwd(l) = 0. + em_dnwdbis(l) = 0. + emMa(l) = 0. + em_TVP(l) = 0. + enddo + endif +c fin SB +c +c If sig has been set to zero, then set Ma to zero +c + sigsum = 0. + do k = 1,klev + sigsum = sigsum + em_work1(k) + enddo + if (sigsum .eq. 0.0) then + do k = 1,klev + emMa(k) = 0. + enddo + endif +c +c sb3d print*,'i, iflag=',i,iflag +c +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c SORTIE DES ICB ET INB +c en fait inb et icb correspondent au niveau ou se trouve +c le nuage,le numero d'interface +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c modif SB: + if (iflag.EQ.1 .or. iflag.EQ.4) then + top=em_top + bas=em_bas + kbas(i) = em_bas + ktop(i) = em_top + endif + + pbase(i) = em_pbase + bbase(i) = em_bbase + rain(i) = em_precip/ 86400.0 + snow(i) = 0.0 + cape(i) = em_CAPE + wd(i) = em_wd + rflag(i) = REAL(iflag) +c SB kbas(i) = em_bas +c SB ktop(i) = em_top + dplcldt(i) = em_dplcldt + dplcldr(i) = em_dplcldr + DO l = 1, klev + d_t2(i,l) = dtime * em_d_t2(l) + d_q2(i,l) = dtime * em_d_q2(l) + d_u2(i,l) = dtime * em_d_u2(l) + d_v2(i,l) = dtime * em_d_v2(l) + + d_t(i,l) = dtime * em_d_t(l) + d_q(i,l) = dtime * em_d_q(l) + d_u(i,l) = dtime * em_d_u(l) + d_v(i,l) = dtime * em_d_v(l) + do itra = 1, ntra + d_tra(i,l,itra) = dtime * em_d_tra(l,itra) + enddo + upwd(i,l) = em_upwd(l) + dnwd(i,l) = em_dnwd(l) + dnwdbis(i,l) = em_dnwdbis(l) + work1(i,l) = em_work1(l) + work2(i,l) = em_work2(l) + Ma(i,l)=emMa(l) + tvp(i,l)=em_TVP(l) + dtvpdt1(i,l) = em_dtvpdt1(l) + dtvpdq1(i,l) = em_dtvpdq1(l) + + if (iflag_clw.eq.0) then + qcond_incld(i,l) = em_qcondc(l) + else if (iflag_clw.eq.1) then + qcond_incld(i,l) = em_qcond(l) + endif + ENDDO + 999 CONTINUE + +c On calcule une eau liquide diagnostique en fonction de la +c precip. + if ( iflag_clw.eq.2 ) then + do l=1,klev + do i=1,klon + if (ktop(i)-kbas(i).gt.0.and. + s l.ge.kbas(i).and.l.le.ktop(i)) then + qcond_incld(i,l)=rain(i)*8.e4 +c s *(pplay(i,l )-paprs(i,ktop(i)+1)) + s /(pplay(i,kbas(i))-pplay(i,ktop(i))) +c s **2 + else + qcond_incld(i,l)=0. + endif + enddo + print*,'l=',l,', qcond_incld=',qcond_incld(1,l) + enddo + endif + + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conema3.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conema3.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conema3.h (revision 1634) @@ -0,0 +1,17 @@ +! +! $Header$ +!-- Modified by : Filiberti M-A 06/2005 +! + real epmax ! 0.993 + logical ok_adj_ema ! F + integer iflag_clw ! 0 + integer iflag_cvl_sigd + real sig1feed ! 1. + real sig2feed ! 0.95 + + common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed + common/comconema2/iflag_cvl_sigd + +! common/comconema/epmax,ok_adj_ema,iflag_clw +!$OMP THREADPRIVATE(/comconema1/) +!$OMP THREADPRIVATE(/comconema2/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conemav.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conemav.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conemav.F (revision 1634) @@ -0,0 +1,151 @@ +! +! $Header$ +! + SUBROUTINE conemav (dtime,paprs,pplay,t,q,u,v,tra,ntra, + . work1,work2,d_t,d_q,d_u,d_v,d_tra, + . rain, snow, kbas, ktop, + . upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr) + +c + USE dimphy + USE infotrac, ONLY : nbtr + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: schema de convection de Emanuel (1991) interface +c====================================================================== +c Arguments: +c dtime--input-R-pas d'integration (s) +c s-------input-R-la valeur "s" pour chaque couche +c sigs----input-R-la valeur "sigma" de chaque couche +c sig-----input-R-la valeur de "sigma" pour chaque niveau +c psolpa--input-R-la pression au sol (en Pa) +C pskapa--input-R-exponentiel kappa de psolpa +c h-------input-R-enthalpie potentielle (Cp*T/P**kappa) +c q-------input-R-vapeur d'eau (en kg/kg) +c +c work*: input et output: deux variables de travail, +c on peut les mettre a 0 au debut +c ALE-----input-R-energie disponible pour soulevement +c +C d_h-----output-R-increment de l'enthalpie potentielle (h) +c d_q-----output-R-increment de la vapeur d'eau +c rain----output-R-la pluie (mm/s) +c snow----output-R-la neige (mm/s) +c upwd----output-R-saturated updraft mass flux (kg/m**2/s) +c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s) +c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s) +c Cape----output-R-CAPE (J/kg) +c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee +c adiabatiquement a partir du niveau 1 (K) +c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa) +c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace +c====================================================================== +c +#include "dimensions.h" +c +c + REAL dtime, paprs(klon,klev+1),pplay(klon,klev) + REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev) + REAL tra(klon,klev,nbtr) + INTEGER ntra + REAL work1(klon,klev),work2(klon,klev) +c + REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev) + REAL d_tra(klon,klev,nbtr) + REAL rain(klon),snow(klon) +c + INTEGER kbas(klon),ktop(klon) + REAL em_ph(klon,klev+1),em_p(klon,klev) + REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev) + REAL Ma(klon,klev),cape(klon),tvp(klon,klev) + INTEGER iflag(klon) + REAL rflag(klon) + REAL pbase(klon),bbase(klon) + REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev) + REAL dplcldt(klon),dplcldr(klon) +c + REAL zx_t,zdelta,zx_qs,zcor +c + INTEGER noff, minorig + INTEGER i,k,itra + REAL qs(klon,klev) + REAL,ALLOCATABLE,SAVE :: cbmf(:) +c$OMP THREADPRIVATE(cbmf) + INTEGER ifrst + SAVE ifrst + DATA ifrst /0/ +c$OMP THREADPRIVATE(ifrst) +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +c +c + IF (ifrst .EQ. 0) THEN + ifrst = 1 + allocate(cbmf(klon)) + DO i = 1, klon + cbmf(i) = 0. + ENDDO + ENDIF + + DO k = 1, klev+1 + DO i=1,klon + em_ph(i,k) = paprs(i,k) / 100.0 + ENDDO + ENDDO +c + DO k = 1, klev + DO i=1,klon + em_p(i,k) = pplay(i,k) / 100.0 + ENDDO + ENDDO + +c + DO k = 1, klev + DO i = 1, klon + zx_t = t(i,k) + zdelta=MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0) + zcor=1./(1.-retv*zx_qs) + qs(i,k)=zx_qs*zcor + ENDDO + ENDDO +c + noff = 2 + minorig = 2 + CALL convect1(klon,klev,klev+1,noff,minorig,t,q,qs,u,v, + $ em_p,em_ph,iflag, + $ d_t,d_q,d_u,d_v,rain,cbmf,dtime,Ma) +c + DO i = 1,klon + rain(i) = rain(i)/86400. + rflag(i)=iflag(i) + ENDDO +c call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION ') +c if (klon.eq.1) then +c print*,'IFLAG ',iflag +c else +c write(*,'(96i1)') (iflag(i),i=2,klon-1) +c endif + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = dtime*d_t(i,k) + d_q(i,k) = dtime*d_q(i,k) + d_u(i,k) = dtime*d_u(i,k) + d_v(i,k) = dtime*d_v(i,k) + ENDDO + DO itra = 1,ntra + DO i = 1, klon + d_tra(i,k,itra) = 0. + ENDDO + ENDDO + ENDDO + +c +c +c + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conf_phys.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conf_phys.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conf_phys.F90 (revision 1634) @@ -0,0 +1,1900 @@ + +! +! $Id$ +! +! +! +module conf_phys_m + + implicit none + +contains + + subroutine conf_phys(ok_journe, ok_mensuel, ok_instan, ok_hf, & + ok_LES,& + callstats,& + solarlong0,seuil_inversion, & + fact_cldcon, facttemps,ok_newmicro,iflag_radia,& + iflag_cldcon, & + iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + ok_ade, ok_aie, aerosol_couple, & + flag_aerosol, new_aod, & + bl95_b0, bl95_b1,& + read_climoz, & + alp_offset) + + use IOIPSL + USE surface_data + USE phys_cal_mod + USE carbon_cycle_mod, ONLY : carbon_cycle_tr, carbon_cycle_cpl + use control_mod + + include "conema3.h" + include "fisrtilp.h" + include "nuage.h" + include "YOMCST.h" + include "YOMCST2.h" + + include "thermcell.h" + +!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12 +include "clesphys.h" +include "compbl.h" +include "comsoil.h" +! +! Configuration de la "physique" de LMDZ a l'aide de la fonction +! GETIN de IOIPSL +! +! LF 05/2001 +! + +! +! type_ocean: type d'ocean (force, slab, couple) +! version_ocean: version d'ocean (opa8/nemo pour type_ocean=couple ou +! sicOBS pour type_ocean=slab) +! ok_veget: type de modele de vegetation +! ok_journe: sorties journalieres +! ok_hf: sorties haute frequence +! ok_mensuel: sorties mensuelles +! ok_instan: sorties instantanees +! ok_ade, ok_aie: apply or not aerosol direct and indirect effects +! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc +! + + +! Sortie: + logical :: ok_newmicro + integer :: iflag_radia + logical :: ok_journe, ok_mensuel, ok_instan, ok_hf + logical :: ok_LES + LOGICAL :: callstats + LOGICAL :: ok_ade, ok_aie, aerosol_couple + INTEGER :: flag_aerosol + LOGICAL :: new_aod + REAL :: bl95_b0, bl95_b1 + real :: fact_cldcon, facttemps,ratqsbas,ratqshaut,tau_ratqs + integer :: iflag_cldcon + integer :: iflag_ratqs + + character (len = 6),SAVE :: type_ocean_omp, version_ocean_omp, ocean_omp + CHARACTER(len = 8),SAVE :: aer_type_omp + logical,SAVE :: ok_veget_omp, ok_newmicro_omp + logical,SAVE :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp + logical,SAVE :: ok_LES_omp + LOGICAL,SAVE :: callstats_omp + LOGICAL,SAVE :: ok_ade_omp, ok_aie_omp, aerosol_couple_omp + INTEGER, SAVE :: flag_aerosol_omp + LOGICAL, SAVE :: new_aod_omp + REAL,SAVE :: bl95_b0_omp, bl95_b1_omp + REAL,SAVE :: freq_ISCCP_omp, ecrit_ISCCP_omp + REAL,SAVE :: freq_COSP_omp + real,SAVE :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp + real,SAVE :: ratqshaut_omp + real,SAVE :: tau_ratqs_omp + integer,SAVE :: iflag_radia_omp + integer,SAVE :: iflag_rrtm_omp + integer,SAVE :: iflag_cldcon_omp, ip_ebil_phy_omp + integer,SAVE :: iflag_ratqs_omp + + Real,SAVE :: f_cdrag_ter_omp,f_cdrag_oce_omp + Real,SAVE :: f_rugoro_omp + +! Local + integer :: numout = 6 + real :: zzz + + real :: seuil_inversion + real,save :: seuil_inversion_omp + + integer,SAVE :: iflag_thermals_ed_omp,iflag_thermals_optflux_omp + integer,SAVE :: iflag_thermals_omp,nsplit_thermals_omp + real,save :: tau_thermals_omp,alp_bl_k_omp + real :: alp_offset + REAL, SAVE :: alp_offset_omp + integer,SAVE :: iflag_coupl_omp,iflag_clos_omp,iflag_wake_omp + integer,SAVE :: iflag_cvl_sigd_omp + REAL, SAVE :: supcrit1_omp, supcrit2_omp + INTEGER, SAVE :: iflag_mix_omp + real, save :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp + + REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp + REAL,SAVE :: co2_ppm_omp, RCO2_omp, co2_ppm_per_omp, RCO2_per_omp + REAL,SAVE :: CH4_ppb_omp, RCH4_omp, CH4_ppb_per_omp, RCH4_per_omp + REAL,SAVE :: N2O_ppb_omp, RN2O_omp, N2O_ppb_per_omp, RN2O_per_omp + REAL,SAVE :: CFC11_ppt_omp,RCFC11_omp,CFC11_ppt_per_omp,RCFC11_per_omp + REAL,SAVE :: CFC12_ppt_omp,RCFC12_omp,CFC12_ppt_per_omp,RCFC12_per_omp + REAL,SAVE :: epmax_omp + LOGICAL,SAVE :: ok_adj_ema_omp + INTEGER,SAVE :: iflag_clw_omp + REAL,SAVE :: cld_lc_lsc_omp,cld_lc_con_omp,cld_tau_lsc_omp,cld_tau_con_omp + REAL,SAVE :: ffallv_lsc_omp, ffallv_con_omp,coef_eva_omp + LOGICAL,SAVE :: reevap_ice_omp + INTEGER,SAVE :: iflag_pdf_omp + REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp + REAL,SAVE :: t_glace_min_omp, t_glace_max_omp + REAL,SAVE :: rei_min_omp, rei_max_omp + REAL,SAVE :: inertie_sol_omp,inertie_sno_omp,inertie_ice_omp + REAL,SAVE :: qsol0_omp + REAL :: solarlong0 + REAL,SAVE :: solarlong0_omp + INTEGER,SAVE :: top_height_omp,overlap_omp + REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp + LOGICAL,SAVE :: ok_kzmin_omp + REAL, SAVE :: fmagic_omp, pmagic_omp + INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp + Integer, save :: lev_histins_omp, lev_histLES_omp + INTEGER, SAVE :: lev_histdayNMC_omp + 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_isccp_omp + LOGICAL,SAVE :: ok_cosp_omp + LOGICAL,SAVE :: ok_mensuelCOSP_omp,ok_journeCOSP_omp,ok_hfCOSP_omp + REAL,SAVE :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp + REAL,SAVE :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp + REAL,SAVE :: ecrit_ins_omp + REAL,SAVE :: ecrit_LES_omp + REAL,SAVE :: ecrit_tra_omp + REAL,SAVE :: cvl_corr_omp + LOGICAL,SAVE :: ok_lic_melt_omp +! + LOGICAL,SAVE :: cycle_diurne_omp,soil_model_omp,new_oliq_omp + LOGICAL,SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp + INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp + LOGICAL,SAVE :: ok_strato_omp + LOGICAL,SAVE :: ok_hines_omp + LOGICAL,SAVE :: carbon_cycle_tr_omp + LOGICAL,SAVE :: carbon_cycle_cpl_omp + + integer, intent(out):: read_climoz ! read ozone climatology, OpenMP shared + ! Allowed values are 0, 1 and 2 + ! 0: do not read an ozone climatology + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + +!$OMP MASTER +!Config Key = type_ocean +!Config Desc = Type d'ocean +!Config Def = force +!Config Help = Type d'ocean utilise: force, slab,couple +! + type_ocean_omp = 'force ' + call getin('type_ocean', type_ocean_omp) +! +!Config Key = version_ocean +!Config Desc = Version d'ocean +!Config Def = xxxxxx +!Config Help = Version d'ocean utilise: opa8/nemo/sicOBS/xxxxxx +! + version_ocean_omp = 'xxxxxx' + call getin('version_ocean', version_ocean_omp) + +!Config Key = OCEAN +!Config Desc = Old parameter name for type_ocean +!Config Def = yyyyyy +!Config Help = This is only for testing purpose +! + ocean_omp = 'yyyyyy' + call getin('OCEAN', ocean_omp) + IF (ocean_omp /= 'yyyyyy') THEN + WRITE(numout,*)'ERROR!! Old variable name OCEAN used in parmeter file.' + WRITE(numout,*)'Variable OCEAN has been replaced by the variable type_ocean.' + WRITE(numout,*)'You have to update your parameter file physiq.def to succed running' + CALL abort_gcm('conf_phys','Variable OCEAN no longer existing, use variable name type_ocean',1) + END IF + +! +!Config Key = VEGET +!Config Desc = Type de modele de vegetation +!Config Def = .false. +!Config Help = Type de modele de vegetation utilise +! + ok_veget_omp = .false. + call getin('VEGET', ok_veget_omp) +! +!Config Key = OK_journe +!Config Desc = Pour des sorties journalieres +!Config Def = .false. +!Config Help = Pour creer le fichier histday contenant les sorties +! journalieres +! + ok_journe_omp = .false. + call getin('OK_journe', ok_journe_omp) +! +!Config Key = ok_hf +!Config Desc = Pour des sorties haute frequence +!Config Def = .false. +!Config Help = Pour creer le fichier histhf contenant les sorties +! haute frequence ( 3h ou 6h) +! + ok_hf_omp = .false. + call getin('ok_hf', ok_hf_omp) +! +!Config Key = OK_mensuel +!Config Desc = Pour des sorties mensuelles +!Config Def = .true. +!Config Help = Pour creer le fichier histmth contenant les sorties +! mensuelles +! + ok_mensuel_omp = .true. + call getin('OK_mensuel', ok_mensuel_omp) +! +!Config Key = OK_instan +!Config Desc = Pour des sorties instantanees +!Config Def = .false. +!Config Help = Pour creer le fichier histins contenant les sorties +! instantanees +! + ok_instan_omp = .false. + call getin('OK_instan', ok_instan_omp) +! +!Config Key = ok_ade +!Config Desc = Aerosol direct effect or not? +!Config Def = .false. +!Config Help = Used in radlwsw.F +! + ok_ade_omp = .false. + call getin('ok_ade', ok_ade_omp) + +! +!Config Key = ok_aie +!Config Desc = Aerosol indirect effect or not? +!Config Def = .false. +!Config Help = Used in nuage.F and radlwsw.F +! + ok_aie_omp = .false. + call getin('ok_aie', ok_aie_omp) + +! +!Config Key = aerosol_couple +!Config Desc = read aerosol in file or calcul by inca +!Config Def = .false. +!Config Help = Used in physiq.F +! + aerosol_couple_omp = .false. + CALL getin('aerosol_couple',aerosol_couple_omp) + +! +!Config Key = flag_aerosol +!Config Desc = which aerosol is use for coupled model +!Config Def = 1 +!Config Help = Used in physiq.F +! +! - flag_aerosol=1 => so4 only (defaut) +! - flag_aerosol=2 => bc only +! - flag_aerosol=3 => pom only +! - flag_aerosol=4 => seasalt only +! - flag_aerosol=5 => dust only +! - flag_aerosol=6 => all aerosol + + flag_aerosol_omp = 1 + CALL getin('flag_aerosol',flag_aerosol_omp) + +! Temporary variable for testing purpose!! +!Config Key = new_aod +!Config Desc = which calcul of aeropt +!Config Def = false +!Config Help = Used in physiq.F +! + new_aod_omp = .true. + CALL getin('new_aod',new_aod_omp) + +! +!Config Key = aer_type +!Config Desc = Use a constant field for the aerosols +!Config Def = scenario +!Config Help = Used in readaerosol.F90 +! + aer_type_omp = 'scenario' + call getin('aer_type', aer_type_omp) + +! +!Config Key = bl95_b0 +!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +!Config Def = .false. +!Config Help = Used in nuage.F +! + bl95_b0_omp = 2. + call getin('bl95_b0', bl95_b0_omp) + +!Config Key = bl95_b1 +!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995) +!Config Def = .false. +!Config Help = Used in nuage.F +! + bl95_b1_omp = 0.2 + call getin('bl95_b1', bl95_b1_omp) + +!Config Key = freq_ISCCP +!Config Desc = Frequence d'appel du simulateur ISCCP en secondes; +! par defaut 10800, i.e. 3 heures +!Config Def = 10800. +!Config Help = Used in ini_histISCCP.h +! + freq_ISCCP_omp = 10800. + call getin('freq_ISCCP', freq_ISCCP_omp) +! +!Config Key = ecrit_ISCCP +!Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours; +! par defaut 1., i.e. 1 jour +!Config Def = 1. +!Config Help = Used in ini_histISCCP.h +! +! + ecrit_ISCCP_omp = 1. + call getin('ecrit_ISCCP', ecrit_ISCCP_omp) + +!Config Key = freq_COSP +!Config Desc = Frequence d'appel du simulateur COSP en secondes; +! par defaut 10800, i.e. 3 heures +!Config Def = 10800. +!Config Help = Used in ini_histdayCOSP.h +! + freq_COSP_omp = 10800. + call getin('freq_COSP', freq_COSP_omp) + +! +!Config Key = ip_ebil_phy +!Config Desc = Niveau de sortie pour les diags bilan d'energie +!Config Def = 0 +!Config Help = +! + ip_ebil_phy_omp = 0 + call getin('ip_ebil_phy', ip_ebil_phy_omp) +! +!Config Key = seuil_inversion +!Config Desc = Seuil ur dTh pour le choix entre les schemas de CL +!Config Def = -0.1 +!Config Help = +! + seuil_inversion_omp = -0.1 + call getin('seuil_inversion', seuil_inversion_omp) + +!! +!! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG +!! +!Config Key = R_ecc +!Config Desc = Excentricite +!Config Def = 0.016715 +!Config Help = +! +!valeur AMIP II + R_ecc_omp = 0.016715 + call getin('R_ecc', R_ecc_omp) +!! +!Config Key = R_peri +!Config Desc = Equinoxe +!Config Def = +!Config Help = +! +! +!valeur AMIP II + R_peri_omp = 102.7 + call getin('R_peri', R_peri_omp) +!! +!Config Key = R_incl +!Config Desc = Inclinaison +!Config Def = +!Config Help = +! +! +!valeur AMIP II + R_incl_omp = 23.441 + call getin('R_incl', R_incl_omp) +!! +!Config Key = solaire +!Config Desc = Constante solaire en W/m2 +!Config Def = 1365. +!Config Help = +! +! +!valeur AMIP II + solaire_omp = 1365. + call getin('solaire', solaire_omp) +!! +!Config Key = co2_ppm +!Config Desc = concentration du gaz carbonique en ppmv +!Config Def = 348. +!Config Help = +! +! +!valeur AMIP II + co2_ppm_omp = 348. + call getin('co2_ppm', co2_ppm_omp) +!! +!Config Key = RCO2 +!Config Desc = Concentration du CO2 +!Config Def = co2_ppm * 1.0e-06 * 44.011/28.97 +!Config Def = 348. * 1.0e-06 * 44.011/28.97 +!Config Help = +! +! RCO2 = 5.286789092164308E-04 +!ancienne valeur + RCO2_omp = co2_ppm_omp * 1.0e-06 * 44.011/28.97 ! pour co2_ppm=348. + +!! call getin('RCO2', RCO2) +!! +!Config Key = RCH4 +!Config Desc = Concentration du CH4 +!Config Def = 1.65E-06* 16.043/28.97 +!Config Help = +! +! +!valeur AMIP II +!OK RCH4 = 1.65E-06* 16.043/28.97 +! RCH4 = 9.137366240938903E-07 +! +!ancienne valeur +! RCH4 = 1.72E-06* 16.043/28.97 +!OK call getin('RCH4', RCH4) + zzz = 1650. + call getin('CH4_ppb', zzz) + CH4_ppb_omp = zzz + RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97 +!! +!Config Key = RN2O +!Config Desc = Concentration du N2O +!Config Def = 306.E-09* 44.013/28.97 +!Config Help = +! +! +!valeur AMIP II +!OK RN2O = 306.E-09* 44.013/28.97 +! RN2O = 4.648939592682085E-07 +! +!ancienne valeur +! RN2O = 310.E-09* 44.013/28.97 +!OK call getin('RN2O', RN2O) + zzz=306. + call getin('N2O_ppb', zzz) + N2O_ppb_omp = zzz + RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97 +!! +!Config Key = RCFC11 +!Config Desc = Concentration du CFC11 +!Config Def = 280.E-12* 137.3686/28.97 +!Config Help = +! +! +!OK RCFC11 = 280.E-12* 137.3686/28.97 + zzz = 280. + call getin('CFC11_ppt',zzz) + CFC11_ppt_omp = zzz + RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97 +! RCFC11 = 1.327690990680013E-09 +!OK call getin('RCFC11', RCFC11) +!! +!Config Key = RCFC12 +!Config Desc = Concentration du CFC12 +!Config Def = 484.E-12* 120.9140/28.97 +!Config Help = +! +! +!OK RCFC12 = 484.E-12* 120.9140/28.97 + zzz = 484. + call getin('CFC12_ppt',zzz) + CFC12_ppt_omp = zzz + RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97 +! RCFC12 = 2.020102726958923E-09 +!OK call getin('RCFC12', RCFC12) + +!ajout CFMIP begin +!! +!Config Key = co2_ppm_per +!Config Desc = concentration du co2_ppm_per +!Config Def = 348. +!Config Help = +! + co2_ppm_per_omp = co2_ppm_omp + call getin('co2_ppm_per', co2_ppm_per_omp) +!! +!Config Key = RCO2_per +!Config Desc = Concentration du CO2_per +!Config Def = co2_ppm_per * 1.0e-06 * 44.011/28.97 +!Config Def = 348. * 1.0e-06 * 44.011/28.97 +!Config Help = +! + RCO2_per_omp = co2_ppm_per_omp * 1.0e-06 * 44.011/28.97 + +!Config Key = RCH4_per +!Config Desc = Concentration du CH4_per +!Config Def = 1.65E-06* 16.043/28.97 +!Config Help = +! + zzz = CH4_ppb_omp + call getin('CH4_ppb_per', zzz) + CH4_ppb_per_omp = zzz + RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * 16.043/28.97 +!! +!Config Key = RN2O_per +!Config Desc = Concentration du N2O_per +!Config Def = 306.E-09* 44.013/28.97 +!Config Help = +! + zzz = N2O_ppb_omp + call getin('N2O_ppb_per', zzz) + N2O_ppb_per_omp = zzz + RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * 44.013/28.97 +!! +!Config Key = RCFC11_per +!Config Desc = Concentration du CFC11_per +!Config Def = 280.E-12* 137.3686/28.97 +!Config Help = +! + zzz = CFC11_ppt_omp + call getin('CFC11_ppt_per',zzz) + CFC11_ppt_per_omp = zzz + RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * 137.3686/28.97 +!! +!Config Key = RCFC12_per +!Config Desc = Concentration du CFC12_per +!Config Def = 484.E-12* 120.9140/28.97 +!Config Help = +! + zzz = CFC12_ppt_omp + call getin('CFC12_ppt_per',zzz) + CFC12_ppt_per_omp = zzz + RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * 120.9140/28.97 +!ajout CFMIP end + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! Constantes precedemment dans dyn3d/conf_gcm + +!Config Key = cycle_diurne +!Config Desc = Cycle ddiurne +!Config Def = y +!Config Help = Cette option permet d'eteidre le cycle diurne. +!Config Peut etre util pour accelerer le code ! + cycle_diurne_omp = .TRUE. + CALL getin('cycle_diurne',cycle_diurne_omp) + +!Config Key = soil_model +!Config Desc = Modele de sol +!Config Def = y +!Config Help = Choix du modele de sol (Thermique ?) +!Config Option qui pourait un string afin de pouvoir +!Config plus de choix ! Ou meme une liste d'options ! + soil_model_omp = .TRUE. + CALL getin('soil_model',soil_model_omp) + +!Config Key = new_oliq +!Config Desc = Nouvelle eau liquide +!Config Def = y +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + new_oliq_omp = .TRUE. + CALL getin('new_oliq',new_oliq_omp) + +!Config Key = ok_orodr +!Config Desc = Orodr ??? +!Config Def = y +!Config Help = Y en a pas comprendre ! +!Config + ok_orodr_omp = .TRUE. + CALL getin('ok_orodr',ok_orodr_omp) + +!Config Key = ok_orolf +!Config Desc = Orolf ?? +!Config Def = y +!Config Help = Connais pas ! + ok_orolf_omp = .TRUE. + CALL getin('ok_orolf', ok_orolf_omp) + +!Config Key = ok_limitvrai +!Config Desc = Force la lecture de la bonne annee +!Config Def = n +!Config Help = On peut forcer le modele a lire le +!Config fichier SST de la bonne annee. C'est une tres bonne +!Config idee, pourquoi ne pas mettre toujours a y ??? + ok_limitvrai_omp = .FALSE. + CALL getin('ok_limitvrai',ok_limitvrai_omp) + +!Config Key = nbapp_rad +!Config Desc = Frequence d'appel au rayonnement +!Config Def = 12 +!Config Help = Nombre d'appels des routines de rayonnements +!Config par jour. + nbapp_rad_omp = 12 + CALL getin('nbapp_rad',nbapp_rad_omp) + +!Config Key = iflag_con +!Config Desc = Flag de convection +!Config Def = 2 +!Config Help = Flag pour la convection les options suivantes existent : +!Config 1 pour LMD, +!Config 2 pour Tiedtke, +!Config 3 pour CCM(NCAR) + iflag_con_omp = 2 + CALL getin('iflag_con',iflag_con_omp) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! Constante solaire & Parametres orbitaux & taux gaz effet de serre END +!! +!! KE +! + +!Config key = cvl_corr +!Config Desc = Facteur multiplication des precip convectives dans KE +!Config Def = 1.00 +!Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire + cvl_corr_omp = 1.00 + CALL getin('cvl_corr', cvl_corr_omp) + + +!Config Key = epmax +!Config Desc = Efficacite precip +!Config Def = 0.993 +!Config Help = +! + epmax_omp = .993 + call getin('epmax', epmax_omp) +! +!Config Key = ok_adj_ema +!Config Desc = +!Config Def = false +!Config Help = +! + ok_adj_ema_omp = .false. + call getin('ok_adj_ema',ok_adj_ema_omp) +! +!Config Key = iflag_clw +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_clw_omp = 0 + call getin('iflag_clw',iflag_clw_omp) +! +!Config Key = cld_lc_lsc +!Config Desc = +!Config Def = 2.6e-4 +!Config Help = +! + cld_lc_lsc_omp = 2.6e-4 + call getin('cld_lc_lsc',cld_lc_lsc_omp) +! +!Config Key = cld_lc_con +!Config Desc = +!Config Def = 2.6e-4 +!Config Help = +! + cld_lc_con_omp = 2.6e-4 + call getin('cld_lc_con',cld_lc_con_omp) +! +!Config Key = cld_tau_lsc +!Config Desc = +!Config Def = 3600. +!Config Help = +! + cld_tau_lsc_omp = 3600. + call getin('cld_tau_lsc',cld_tau_lsc_omp) +! +!Config Key = cld_tau_con +!Config Desc = +!Config Def = 3600. +!Config Help = +! + cld_tau_con_omp = 3600. + call getin('cld_tau_con',cld_tau_con_omp) +! +!Config Key = ffallv_lsc +!Config Desc = +!Config Def = 1. +!Config Help = +! + ffallv_lsc_omp = 1. + call getin('ffallv_lsc',ffallv_lsc_omp) +! +!Config Key = ffallv_con +!Config Desc = +!Config Def = 1. +!Config Help = +! + ffallv_con_omp = 1. + call getin('ffallv_con',ffallv_con_omp) +! +!Config Key = coef_eva +!Config Desc = +!Config Def = 2.e-5 +!Config Help = +! + coef_eva_omp = 2.e-5 + call getin('coef_eva',coef_eva_omp) +! +!Config Key = reevap_ice +!Config Desc = +!Config Def = .false. +!Config Help = +! + reevap_ice_omp = .false. + call getin('reevap_ice',reevap_ice_omp) + +!Config Key = iflag_ratqs +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_ratqs_omp = 1 + call getin('iflag_ratqs',iflag_ratqs_omp) + +! +!Config Key = iflag_radia +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_radia_omp = 1 + call getin('iflag_radia',iflag_radia_omp) + +! +!Config Key = iflag_rrtm +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_rrtm_omp = 0 + call getin('iflag_rrtm',iflag_rrtm_omp) + +! +!Config Key = iflag_cldcon +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_cldcon_omp = 1 + call getin('iflag_cldcon',iflag_cldcon_omp) + +! +!Config Key = iflag_pdf +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_pdf_omp = 0 + call getin('iflag_pdf',iflag_pdf_omp) +! +!Config Key = fact_cldcon +!Config Desc = +!Config Def = 0.375 +!Config Help = +! + fact_cldcon_omp = 0.375 + call getin('fact_cldcon',fact_cldcon_omp) + +! +!Config Key = facttemps +!Config Desc = +!Config Def = 1.e-4 +!Config Help = +! + facttemps_omp = 1.e-4 + call getin('facttemps',facttemps_omp) + +! +!Config Key = ok_newmicro +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_newmicro_omp = .true. + call getin('ok_newmicro',ok_newmicro_omp) +! +!Config Key = ratqsbas +!Config Desc = +!Config Def = 0.01 +!Config Help = +! + ratqsbas_omp = 0.01 + call getin('ratqsbas',ratqsbas_omp) +! +!Config Key = ratqshaut +!Config Desc = +!Config Def = 0.3 +!Config Help = +! + ratqshaut_omp = 0.3 + call getin('ratqshaut',ratqshaut_omp) + +!Config Key = tau_ratqs +!Config Desc = +!Config Def = 1800. +!Config Help = +! + tau_ratqs_omp = 1800. + call getin('tau_ratqs',tau_ratqs_omp) + +! +!----------------------------------------------------------------------- +! Longitude solaire pour le calcul de l'ensoleillement en degre +! si on veut imposer la saison. Sinon, solarlong0=-999.999 +!Config Key = solarlong0 +!Config Desc = +!Config Def = -999.999 +!Config Help = +! + solarlong0_omp = -999.999 + call getin('solarlong0',solarlong0_omp) +! +!----------------------------------------------------------------------- +! Valeur imposee de l'humidite du sol pour le modele bucket. +!Config Key = qsol0 +!Config Desc = +!Config Def = -1. +!Config Help = +! + qsol0_omp = -1. + call getin('qsol0',qsol0_omp) +! +!----------------------------------------------------------------------- +! +!Config Key = inertie_ice +!Config Desc = +!Config Def = 2000. +!Config Help = +! + inertie_ice_omp = 2000. + call getin('inertie_ice',inertie_ice_omp) +! +!Config Key = inertie_sno +!Config Desc = +!Config Def = 2000. +!Config Help = +! + inertie_sno_omp = 2000. + call getin('inertie_sno',inertie_sno_omp) +! +!Config Key = inertie_sol +!Config Desc = +!Config Def = 2000. +!Config Help = +! + inertie_sol_omp = 2000. + call getin('inertie_sol',inertie_sol_omp) + +! +!Config Key = rad_froid +!Config Desc = +!Config Def = 35.0 +!Config Help = +! + rad_froid_omp = 35.0 + call getin('rad_froid',rad_froid_omp) + +! +!Config Key = rad_chau1 +!Config Desc = +!Config Def = 13.0 +!Config Help = +! + rad_chau1_omp = 13.0 + call getin('rad_chau1',rad_chau1_omp) + +! +!Config Key = rad_chau2 +!Config Desc = +!Config Def = 9.0 +!Config Help = +! + rad_chau2_omp = 9.0 + call getin('rad_chau2',rad_chau2_omp) + +! +!Config Key = t_glace_min +!Config Desc = +!Config Def = 258. +!Config Help = +! + t_glace_min_omp = 258. + call getin('t_glace_min',t_glace_min_omp) + +! +!Config Key = t_glace_max +!Config Desc = +!Config Def = 273.13 +!Config Help = +! + t_glace_max_omp = 273.13 + call getin('t_glace_max',t_glace_max_omp) + +!Config Key = rei_min +!Config Desc = +!Config Def = 3.5 +!Config Help = +! + rei_min_omp = 3.5 + call getin('rei_min',rei_min_omp) + +! +!Config Key = rei_max +!Config Desc = +!Config Def = 61.29 +!Config Help = +! + rei_max_omp = 61.29 + call getin('rei_max',rei_max_omp) + +! +!Config Key = top_height +!Config Desc = +!Config Def = 3 +!Config Help = +! + top_height_omp = 3 + call getin('top_height',top_height_omp) + +! +!Config Key = overlap +!Config Desc = +!Config Def = 3 +!Config Help = +! + overlap_omp = 3 + call getin('overlap',overlap_omp) + + +! +! +!Config Key = cdmmax +!Config Desc = +!Config Def = 1.3E-3 +!Config Help = +! + cdmmax_omp = 1.3E-3 + call getin('cdmmax',cdmmax_omp) + +! +!Config Key = cdhmax +!Config Desc = +!Config Def = 1.1E-3 +!Config Help = +! + cdhmax_omp = 1.1E-3 + call getin('cdhmax',cdhmax_omp) + +!261103 +! +!Config Key = ksta +!Config Desc = +!Config Def = 1.0e-10 +!Config Help = +! + ksta_omp = 1.0e-10 + call getin('ksta',ksta_omp) + +! +!Config Key = ksta_ter +!Config Desc = +!Config Def = 1.0e-10 +!Config Help = +! + ksta_ter_omp = 1.0e-10 + call getin('ksta_ter',ksta_ter_omp) + +! +!Config Key = ok_kzmin +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_kzmin_omp = .true. + call getin('ok_kzmin',ok_kzmin_omp) + +! +!Config Key = fmagic +!Config Desc = additionnal multiplicator factor used for albedo +!Config Def = 1. +!Config Help = additionnal multiplicator factor used in albedo.F +! + fmagic_omp = 1. + call getin('fmagic',fmagic_omp) + +! +!Config Key = pmagic +!Config Desc = additional factor used for albedo +!Config Def = 0. +!Config Help = additional factor used in albedo.F +! + pmagic_omp = 0. + call getin('pmagic',pmagic_omp) + + +!Config Key = ok_lic_melt +!Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau +!Config Def = .false. +!Config Help = mettre a .false. pour assurer la conservation en eau + ok_lic_melt_omp = .false. + call getin('ok_lic_melt', ok_lic_melt_omp) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! PARAMETER FOR THE PLANETARY BOUNDARY LAYER +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!Config Key = iflag_pbl +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_pbl_omp = 1 + call getin('iflag_pbl',iflag_pbl_omp) +! +!Config Key = iflag_thermals +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_thermals_omp = 0 + call getin('iflag_thermals',iflag_thermals_omp) +! +! +!Config Key = iflag_thermals_ed +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_thermals_ed_omp = 0 + call getin('iflag_thermals_ed',iflag_thermals_ed_omp) +! +! +!Config Key = iflag_thermals_optflux +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_thermals_optflux_omp = 0 + call getin('iflag_thermals_optflux',iflag_thermals_optflux_omp) +! +! +!Config Key = nsplit_thermals +!Config Desc = +!Config Def = 1 +!Config Help = +! + nsplit_thermals_omp = 1 + call getin('nsplit_thermals',nsplit_thermals_omp) + +!Config Key = alp_bl_k +!Config Desc = +!Config Def = 0. +!Config Help = +! + alp_bl_k_omp = 1. + call getin('alp_bl_k',alp_bl_k_omp) + +! +!Config Key = tau_thermals +!Config Desc = +!Config Def = 0. +!Config Help = +! + tau_thermals_omp = 0. + call getin('tau_thermals',tau_thermals_omp) + +! +!Config Key = iflag_coupl +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_coupl_omp = 0 + call getin('iflag_coupl',iflag_coupl_omp) + +! +!Config Key = iflag_clos +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_clos_omp = 1 + call getin('iflag_clos',iflag_clos_omp) +! +!Config Key = iflag_cvl_sigd +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_cvl_sigd_omp = 0 + call getin('iflag_cvl_sigd',iflag_cvl_sigd_omp) + +!Config Key = iflag_wake +!Config Desc = +!Config Def = 0 +!Config Help = +! + iflag_wake_omp = 0 + call getin('iflag_wake',iflag_wake_omp) + +!Config Key = alp_offset +!Config Desc = +!Config Def = 0 +!Config Help = +! + alp_offset_omp = 0. + call getin('alp_offset',alp_offset_omp) + +! +!Config Key = lev_histhf +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histhf_omp = 1 + call getin('lev_histhf',lev_histhf_omp) + +! +!Config Key = lev_histday +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histday_omp = 1 + call getin('lev_histday',lev_histday_omp) + +! +!Config Key = lev_histmth +!Config Desc = +!Config Def = 2 +!Config Help = +! + lev_histmth_omp = 2 + call getin('lev_histmth',lev_histmth_omp) +! +!Config Key = lev_histins +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histins_omp = 1 + call getin('lev_histins',lev_histins_omp) + ! +!Config Key = lev_histLES +!Config Desc = +!Config Def = 1 +!Config Help = +! + lev_histLES_omp = 1 + 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) +! +!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. +!Config Help = +! +! freq_outNMC_omp(1) = 2592000. + freq_outNMC_omp(1) = mth_len*86400. + freq_outNMC_omp(2) = 86400. + freq_outNMC_omp(3) = 21600. + 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 = pasphys +!Config Help = +! + freq_calNMC_omp(1) = pasphys + freq_calNMC_omp(2) = pasphys + freq_calNMC_omp(3) = pasphys + call getin('freq_calNMC',freq_calNMC_omp) +! +!Config Key = type_run +!Config Desc = +!Config Def = 'AMIP'/'CFMIP' ou 'CLIM'/'ENSP' +!Config Help = +! + type_run_omp = 'AMIP' + call getin('type_run',type_run_omp) + +! +!Config Key = ok_isccp +!Config Desc = +!Config Def = .true. +!Config Help = +! +! ok_isccp = .true. + ok_isccp_omp = .false. + call getin('ok_isccp',ok_isccp_omp) + +! +!Config Key = ok_cosp +!Config Desc = +!Config Def = .false. +!Config Help = +! + ok_cosp_omp = .false. + call getin('ok_cosp',ok_cosp_omp) + +! +!Config Key = ok_mensuelCOSP +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_mensuelCOSP_omp = .true. + call getin('ok_mensuelCOSP',ok_mensuelCOSP_omp) + +! +!Config Key = ok_journeCOSP +!Config Desc = +!Config Def = .true. +!Config Help = +! + ok_journeCOSP_omp = .true. + call getin('ok_journeCOSP',ok_journeCOSP_omp) + +! +!Config Key = ok_hfCOSP +!Config Desc = +!Config Def = .false. +!Config Help = +! + ok_hfCOSP_omp = .false. + call getin('ok_hfCOSP',ok_hfCOSP_omp) + +! +! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone +! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc" +! +!Config Key = lonmin_ins +!Config Desc = 100. +!Config Def = longitude minimale sorties "bilKP_ins" +!Config Help = +! + lonmin_ins_omp = 100. + call getin('lonmin_ins',lonmin_ins_omp) +! +!Config Key = lonmax_ins +!Config Desc = 130. +!Config Def = longitude maximale sorties "bilKP_ins" +!Config Help = +! + lonmax_ins_omp = 130. + call getin('lonmax_ins',lonmax_ins_omp) +! +!Config Key = latmin_ins +!Config Desc = -20. +!Config Def = latitude minimale sorties "bilKP_ins" +!Config Help = +! + latmin_ins_omp = -20. + call getin('latmin_ins',latmin_ins_omp) +! +!Config Key = latmax_ins +!Config Desc = 20. +!Config Def = latitude maximale sorties "bilKP_ins" +!Config Help = +! + latmax_ins_omp = 20. + call getin('latmax_ins',latmax_ins_omp) +! +!Config Key = ecrit_hf +!Config Desc = +!Config Def = 1./8. !toutes les 3h +!Config Help = +! + ecrit_hf_omp = 1./8. + call getin('ecrit_hf',ecrit_hf_omp) +! +!Config Key = ecrit_ins +!Config Desc = +!Config Def = 1./48. ! toutes les 1/2 h +!Config Help = +! + ecrit_ins_omp = 1./48. + call getin('ecrit_ins',ecrit_ins_omp) +! +!Config Key = ecrit_day +!Config Desc = +!Config Def = 1.0 !tous les jours +!Config Help = nombre de jours pour ecriture fichier histday.nc +! + ecrit_day_omp = 1.0 + call getin('ecrit_day',ecrit_day_omp) +! +!Config Key = ecrit_mth +!Config Desc = +!Config Def = 30. !tous les 30jours (1 fois par mois) +!Config Help = +! + ecrit_mth_omp = 30. + call getin('ecrit_mth',ecrit_mth_omp) +! +!Config Key = ecrit_tra +!Config Desc = +!Config Def = 30. !tous les 30jours (1 fois par mois) +!Config Help = +! + ecrit_tra_omp = 30. + call getin('ecrit_tra',ecrit_tra_omp) +! +!Config Key = ecrit_reg +!Config Desc = +!Config Def = 0.25 !4 fois par jour +!Config Help = +! + ecrit_reg_omp = 0.25 !4 fois par jour + call getin('ecrit_reg',ecrit_reg_omp) +! +! +! +! PARAMETRES CDRAG +! +!Config Key = f_cdrag_ter +!Config Desc = +!Config Def = 0.8 +!Config Help = +! + f_cdrag_ter_omp = 0.8 + call getin('f_cdrag_ter',f_cdrag_ter_omp) +! +!Config Key = f_cdrag_oce +!Config Desc = +!Config Def = 0.8 +!Config Help = +! + f_cdrag_oce_omp = 0.8 + call getin('f_cdrag_oce',f_cdrag_oce_omp) +! +! RUGORO +!Config Key = f_rugoro +!Config Desc = +!Config Def = 0. +!Config Help = +! + f_rugoro_omp = 0. + call getin('f_rugoro',f_rugoro_omp) + +! PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS +! +!Config Key = supcrit1 +!Config Desc = +!Config Def = .540 +!Config Help = +! + supcrit1_omp = .540 + call getin('supcrit1',supcrit1_omp) + +! +!Config Key = supcrit2 +!Config Desc = +!Config Def = .600 +!Config Help = +! + supcrit2_omp = .600 + call getin('supcrit2',supcrit2_omp) + +! +! PARAMETERS FOR THE MIXING DISTRIBUTION +! iflag_mix: 0=OLD, +! 1=NEW (JYG), +! 2=NEW + conv. depth inhib. by tropos. dryness +! '2' is NOT operationnal and should not be used. +! +!Config Key = iflag_mix +!Config Desc = +!Config Def = 1 +!Config Help = +! + iflag_mix_omp = 1 + call getin('iflag_mix',iflag_mix_omp) + +! +!Config Key = scut +!Config Desc = +!Config Def = 0.95 +!Config Help = +! + scut_omp = 0.95 + call getin('scut',scut_omp) + +! +!Config Key = qqa1 +!Config Desc = +!Config Def = 1.0 +!Config Help = +! + qqa1_omp = 1.0 + call getin('qqa1',qqa1_omp) + +! +!Config Key = qqa2 +!Config Desc = +!Config Def = 0.0 +!Config Help = +! + qqa2_omp = 0.0 + call getin('qqa2',qqa2_omp) + +! +!Config Key = gammas +!Config Desc = +!Config Def = 0.05 +!Config Help = +! + gammas_omp = 0.05 + call getin('gammas',gammas_omp) + +! +!Config Key = Fmax +!Config Desc = +!Config Def = 0.65 +!Config Help = +! + Fmax_omp = 0.65 + call getin('Fmax',Fmax_omp) + +! +!Config Key = alphas +!Config Desc = +!Config Def = -5. +!Config Help = +! + alphas_omp = -5. + call getin('alphas',alphas_omp) + +!Config key = ok_strato +!Config Desc = activation de la version strato +!Config Def = .FALSE. +!Config Help = active la version stratosphérique de LMDZ de F. Lott + + ok_strato_omp=.FALSE. + CALL getin('ok_strato',ok_strato_omp) + +!Config key = ok_hines +!Config Desc = activation de la parametrisation de hines +!Config Def = .FALSE. +!Config Help = Clefs controlant la parametrization de Hines +! Et la sponge layer (Runs Stratospheriques) + + ok_hines_omp=.FALSE. + CALL getin('ok_hines',ok_hines_omp) + +!Config Key = OK_LES +!Config Desc = Pour des sorties LES +!Config Def = .false. +!Config Help = Pour creer le fichier histLES contenant les sorties +! LES +! + ok_LES_omp = .false. + call getin('OK_LES', ok_LES_omp) + +!Config Key = callstats +!Config Desc = Pour des sorties callstats +!Config Def = .false. +!Config Help = Pour creer le fichier stats contenant les sorties +! stats +! + callstats_omp = .false. + call getin('callstats', callstats_omp) +! +!Config Key = ecrit_LES +!Config Desc = Frequence d'ecriture des resultats du LES en nombre de jours; +! par defaut 1., i.e. 1 jour +!Config Def = 1./8. +!Config Help = ... +! +! + ecrit_LES_omp = 1./8. + call getin('ecrit_LES', ecrit_LES_omp) +! + read_climoz = 0 ! default value + call getin('read_climoz', read_climoz) + + carbon_cycle_tr_omp=.FALSE. + CALL getin('carbon_cycle_tr',carbon_cycle_tr_omp) + + carbon_cycle_cpl_omp=.FALSE. + CALL getin('carbon_cycle_cpl',carbon_cycle_cpl_omp) + +!$OMP END MASTER +!$OMP BARRIER + + R_ecc = R_ecc_omp + R_peri = R_peri_omp + R_incl = R_incl_omp + solaire = solaire_omp + co2_ppm = co2_ppm_omp + RCO2 = RCO2_omp + CH4_ppb = CH4_ppb_omp + RCH4 = RCH4_omp + N2O_ppb = N2O_ppb_omp + RN2O = RN2O_omp + CFC11_ppt = CFC11_ppt_omp + RCFC11 = RCFC11_omp + CFC12_ppt = CFC12_ppt_omp + RCFC12 = RCFC12_omp + RCO2_act = RCO2 + RCH4_act = RCH4 + RN2O_act = RN2O + RCFC11_act = RCFC11 + RCFC12_act = RCFC12 + RCO2_per = RCO2_per_omp + RCH4_per = RCH4_per_omp + RN2O_per = RN2O_per_omp + RCFC11_per = RCFC11_per_omp + RCFC12_per = RCFC12_per_omp + + cycle_diurne = cycle_diurne_omp + soil_model = soil_model_omp + new_oliq = new_oliq_omp + ok_orodr = ok_orodr_omp + ok_orolf = ok_orolf_omp + ok_limitvrai = ok_limitvrai_omp + nbapp_rad = nbapp_rad_omp + iflag_con = iflag_con_omp + + epmax = epmax_omp + ok_adj_ema = ok_adj_ema_omp + iflag_clw = iflag_clw_omp + cld_lc_lsc = cld_lc_lsc_omp + cld_lc_con = cld_lc_con_omp + cld_tau_lsc = cld_tau_lsc_omp + cld_tau_con = cld_tau_con_omp + ffallv_lsc = ffallv_lsc_omp + ffallv_con = ffallv_con_omp + coef_eva = coef_eva_omp + reevap_ice = reevap_ice_omp + iflag_pdf = iflag_pdf_omp + solarlong0 = solarlong0_omp + qsol0 = qsol0_omp + inertie_sol = inertie_sol_omp + inertie_ice = inertie_ice_omp + inertie_sno = inertie_sno_omp + rad_froid = rad_froid_omp + rad_chau1 = rad_chau1_omp + rad_chau2 = rad_chau2_omp + t_glace_min = t_glace_min_omp + t_glace_max = t_glace_max_omp + rei_min = rei_min_omp + rei_max = rei_max_omp + top_height = top_height_omp + overlap = overlap_omp + cdmmax = cdmmax_omp + cdhmax = cdhmax_omp + ksta = ksta_omp + ksta_ter = ksta_ter_omp + ok_kzmin = ok_kzmin_omp + fmagic = fmagic_omp + pmagic = pmagic_omp + iflag_pbl = iflag_pbl_omp + lev_histhf = lev_histhf_omp + lev_histday = lev_histday_omp + lev_histmth = lev_histmth_omp + lev_histins = lev_histins_omp + lev_histLES = lev_histLES_omp + lev_histdayNMC = lev_histdayNMC_omp + ok_histNMC(:) = ok_histNMC_omp(:) + freq_outNMC(:) = freq_outNMC_omp(:) + freq_calNMC(:) = freq_calNMC_omp(:) + + type_ocean = type_ocean_omp + version_ocean = version_ocean_omp + ok_veget = ok_veget_omp + ok_newmicro = ok_newmicro_omp + ok_journe = ok_journe_omp + ok_hf = ok_hf_omp + ok_mensuel = ok_mensuel_omp + ok_instan = ok_instan_omp + freq_ISCCP = freq_ISCCP_omp + ecrit_ISCCP = ecrit_ISCCP_omp + freq_COSP = freq_COSP_omp + ok_ade = ok_ade_omp + ok_aie = ok_aie_omp + aerosol_couple = aerosol_couple_omp + flag_aerosol=flag_aerosol_omp + new_aod=new_aod_omp + aer_type = aer_type_omp + bl95_b0 = bl95_b0_omp + bl95_b1 = bl95_b1_omp + fact_cldcon = fact_cldcon_omp + facttemps = facttemps_omp + ratqsbas = ratqsbas_omp + ratqshaut = ratqshaut_omp + tau_ratqs = tau_ratqs_omp + + iflag_radia = iflag_radia_omp + iflag_rrtm = iflag_rrtm_omp + iflag_cldcon = iflag_cldcon_omp + iflag_ratqs = iflag_ratqs_omp + ip_ebil_phy = ip_ebil_phy_omp + iflag_thermals = iflag_thermals_omp + iflag_thermals_ed = iflag_thermals_ed_omp + iflag_thermals_optflux = iflag_thermals_optflux_omp + nsplit_thermals = nsplit_thermals_omp + tau_thermals = tau_thermals_omp + alp_bl_k = alp_bl_k_omp + iflag_coupl = iflag_coupl_omp + iflag_clos = iflag_clos_omp + iflag_wake = iflag_wake_omp + alp_offset = alp_offset_omp + iflag_cvl_sigd = iflag_cvl_sigd_omp + type_run = type_run_omp + ok_isccp = ok_isccp_omp + ok_cosp = ok_cosp_omp + ok_mensuelCOSP = ok_mensuelCOSP_omp + ok_journeCOSP = ok_journeCOSP_omp + ok_hfCOSP = ok_hfCOSP_omp + seuil_inversion=seuil_inversion_omp + lonmin_ins = lonmin_ins_omp + lonmax_ins = lonmax_ins_omp + latmin_ins = latmin_ins_omp + latmax_ins = latmax_ins_omp + ecrit_hf = ecrit_hf_omp + ecrit_ins = ecrit_ins_omp + ecrit_day = ecrit_day_omp + ecrit_mth = ecrit_mth_omp + ecrit_tra = ecrit_tra_omp + ecrit_reg = ecrit_reg_omp + cvl_corr = cvl_corr_omp + ok_lic_melt = ok_lic_melt_omp + f_cdrag_ter=f_cdrag_ter_omp + f_cdrag_oce=f_cdrag_oce_omp + f_rugoro=f_rugoro_omp + supcrit1 = supcrit1_omp + supcrit2 = supcrit2_omp + iflag_mix = iflag_mix_omp + scut = scut_omp + qqa1 = qqa1_omp + qqa2 = qqa2_omp + gammas = gammas_omp + Fmax = Fmax_omp + alphas = alphas_omp + ok_strato = ok_strato_omp + ok_hines = ok_hines_omp + ok_LES = ok_LES_omp + callstats = callstats_omp + ecrit_LES = ecrit_LES_omp + carbon_cycle_tr = carbon_cycle_tr_omp + carbon_cycle_cpl = carbon_cycle_cpl_omp + +! Test of coherence between type_ocean and version_ocean + IF (type_ocean=='couple' .AND. (version_ocean/='opa8' .AND. version_ocean/='nemo') ) THEN + WRITE(numout,*)' ERROR version_ocean=',version_ocean,' not valid in coupled configuration' + CALL abort_gcm('conf_phys','version_ocean not valid',1) + END IF + + IF (type_ocean=='slab' .AND. version_ocean=='xxxxxx') THEN + version_ocean='sicOBS' + ELSE IF (type_ocean=='slab' .AND. version_ocean/='sicOBS') THEN + WRITE(numout,*)' ERROR version_ocean=',version_ocean,' not valid with slab ocean' + CALL abort_gcm('conf_phys','version_ocean not valid',1) + END IF + +! Test sur new_aod. Ce flag permet de retrouver les resultats de l'AR4 +! il n'est utilisable que lors du couplage avec le SO4 seul + IF (ok_ade .OR. ok_aie) THEN + IF ( .NOT. new_aod .AND. flag_aerosol .NE. 1) THEN + CALL abort_gcm('conf_phys','new_aod=.FALSE. not compatible avec flag_aerosol=1',1) + END IF + END IF + +!$OMP MASTER + + write(numout,*)' ##############################################' + write(numout,*)' Configuration des parametres de la physique: ' + write(numout,*)' Type ocean = ', type_ocean + write(numout,*)' Version ocean = ', version_ocean + write(numout,*)' Config veget = ', ok_veget + write(numout,*)' Sortie journaliere = ', ok_journe + write(numout,*)' Sortie haute frequence = ', ok_hf + write(numout,*)' Sortie mensuelle = ', ok_mensuel + write(numout,*)' Sortie instantanee = ', ok_instan + write(numout,*)' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP + write(numout,*)' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP + write(numout,*)' Frequence appel simulateur COSP, freq_COSP =', freq_COSP + write(numout,*)' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy + write(numout,*)' Excentricite = ',R_ecc + write(numout,*)' Equinoxe = ',R_peri + write(numout,*)' Inclinaison =',R_incl + write(numout,*)' Constante solaire =',solaire + write(numout,*)' co2_ppm =',co2_ppm + write(numout,*)' RCO2_act = ',RCO2_act + write(numout,*)' CH4_ppb =',CH4_ppb,' RCH4_act = ',RCH4_act + write(numout,*)' N2O_ppb =',N2O_ppb,' RN2O_act= ',RN2O_act + write(numout,*)' CFC11_ppt=',CFC11_ppt,' RCFC11_act= ',RCFC11_act + write(numout,*)' CFC12_ppt=',CFC12_ppt,' RCFC12_act= ',RCFC12_act + write(numout,*)' RCO2_per = ',RCO2_per,' RCH4_per = ', RCH4_per + write(numout,*)' RN2O_per = ',RN2O_per,' RCFC11_per = ', RCFC11_per + write(numout,*)' RCFC12_per = ',RCFC12_per + write(numout,*)' cvl_corr=', cvl_corr + write(numout,*)'ok_lic_melt=', ok_lic_melt + write(numout,*)'cycle_diurne=',cycle_diurne + write(numout,*)'soil_model=',soil_model + write(numout,*)'new_oliq=',new_oliq + write(numout,*)'ok_orodr=',ok_orodr + write(numout,*)'ok_orolf=',ok_orolf + write(numout,*)'ok_limitvrai=',ok_limitvrai + write(numout,*)'nbapp_rad=',nbapp_rad + write(numout,*)'iflag_con=',iflag_con + write(numout,*)' epmax = ', epmax + write(numout,*)' ok_adj_ema = ', ok_adj_ema + write(numout,*)' iflag_clw = ', iflag_clw + write(numout,*)' cld_lc_lsc = ', cld_lc_lsc + write(numout,*)' cld_lc_con = ', cld_lc_con + write(numout,*)' cld_tau_lsc = ', cld_tau_lsc + write(numout,*)' cld_tau_con = ', cld_tau_con + write(numout,*)' ffallv_lsc = ', ffallv_lsc + write(numout,*)' ffallv_con = ', ffallv_con + write(numout,*)' coef_eva = ', coef_eva + write(numout,*)' reevap_ice = ', reevap_ice + write(numout,*)' iflag_pdf = ', iflag_pdf + write(numout,*)' iflag_cldcon = ', iflag_cldcon + write(numout,*)' iflag_radia = ', iflag_radia + write(numout,*)' iflag_rrtm = ', iflag_rrtm + write(numout,*)' iflag_ratqs = ', iflag_ratqs + write(numout,*)' seuil_inversion = ', seuil_inversion + write(numout,*)' fact_cldcon = ', fact_cldcon + write(numout,*)' facttemps = ', facttemps + write(numout,*)' ok_newmicro = ',ok_newmicro + write(numout,*)' ratqsbas = ',ratqsbas + write(numout,*)' ratqshaut = ',ratqshaut + write(numout,*)' tau_ratqs = ',tau_ratqs + write(numout,*)' top_height = ',top_height + write(numout,*)' rad_froid = ',rad_froid + write(numout,*)' rad_chau1 = ',rad_chau1 + write(numout,*)' rad_chau2 = ',rad_chau2 + write(numout,*)' t_glace_min = ',t_glace_min + write(numout,*)' t_glace_max = ',t_glace_max + write(numout,*)' rei_min = ',rei_min + write(numout,*)' rei_max = ',rei_max + write(numout,*)' overlap = ',overlap + write(numout,*)' cdmmax = ',cdmmax + write(numout,*)' cdhmax = ',cdhmax + write(numout,*)' ksta = ',ksta + write(numout,*)' ksta_ter = ',ksta_ter + write(numout,*)' ok_kzmin = ',ok_kzmin + write(numout,*)' fmagic = ',fmagic + write(numout,*)' pmagic = ',pmagic + write(numout,*)' ok_ade = ',ok_ade + write(numout,*)' ok_aie = ',ok_aie + write(numout,*)' aerosol_couple = ', aerosol_couple + write(numout,*)' flag_aerosol = ', flag_aerosol + write(numout,*)' new_aod = ', new_aod + write(numout,*)' aer_type = ',aer_type + write(numout,*)' bl95_b0 = ',bl95_b0 + write(numout,*)' bl95_b1 = ',bl95_b1 + write(numout,*)' lev_histhf = ',lev_histhf + write(numout,*)' lev_histday = ',lev_histday + write(numout,*)' lev_histmth = ',lev_histmth + write(numout,*)' lev_histins = ',lev_histins + write(numout,*)' lev_histLES = ',lev_histLES + write(numout,*)' lev_histdayNMC = ',lev_histdayNMC + write(numout,*)' ok_histNMC = ',ok_histNMC + write(numout,*)' freq_outNMC = ',freq_outNMC + write(numout,*)' freq_calNMC = ',freq_calNMC + write(numout,*)' iflag_pbl = ', iflag_pbl + write(numout,*)' iflag_thermals = ', iflag_thermals + write(numout,*)' iflag_thermals_ed = ', iflag_thermals_ed + write(numout,*)' iflag_thermals_optflux = ', iflag_thermals_optflux + write(numout,*)' iflag_clos = ', iflag_clos + write(numout,*)' type_run = ',type_run + write(numout,*)' ok_isccp = ',ok_isccp + write(numout,*)' ok_cosp = ',ok_cosp + write(numout,*)' ok_mensuelCOSP = ',ok_mensuelCOSP + write(numout,*)' ok_journeCOSP = ',ok_journeCOSP + write(numout,*)' ok_hfCOSP =',ok_hfCOSP + write(numout,*)' solarlong0 = ', solarlong0 + write(numout,*)' qsol0 = ', qsol0 + write(numout,*)' inertie_sol = ', inertie_sol + write(numout,*)' inertie_ice = ', inertie_ice + write(numout,*)' inertie_sno = ', inertie_sno + write(numout,*)' f_cdrag_ter = ',f_cdrag_ter + write(numout,*)' f_cdrag_oce = ',f_cdrag_oce + write(numout,*)' f_rugoro = ',f_rugoro + write(numout,*)' supcrit1 = ', supcrit1 + write(numout,*)' supcrit2 = ', supcrit2 + write(numout,*)' iflag_mix = ', iflag_mix + write(numout,*)' scut = ', scut + write(numout,*)' qqa1 = ', qqa1 + write(numout,*)' qqa2 = ', qqa2 + write(numout,*)' gammas = ', gammas + write(numout,*)' Fmax = ', Fmax + write(numout,*)' alphas = ', alphas + write(numout,*)' iflag_wake = ', iflag_wake + write(numout,*)' alp_offset = ', alp_offset + + write(numout,*)' lonmin lonmax latmin latmax bilKP_ins =',& + lonmin_ins, lonmax_ins, latmin_ins, latmax_ins + write(numout,*)' ecrit_ hf, ins, day, mth, reg, tra, ISCCP, LES',& + ecrit_hf, ecrit_ins, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP, ecrit_LES + + write(numout,*) 'ok_strato = ', ok_strato + write(numout,*) 'ok_hines = ', ok_hines + write(numout,*) 'read_climoz = ', read_climoz + write(numout,*) 'carbon_cycle_tr = ', carbon_cycle_tr + write(numout,*) 'carbon_cycle_cpl = ', carbon_cycle_cpl + +!$OMP END MASTER + + return + + end subroutine conf_phys + +end module conf_phys_m +! +!################################################################# +! + + subroutine conf_interface(tau_calv) + + use IOIPSL + implicit none + +! Configuration de l'interace atm/surf +! +! tau_calv: temps de relaxation pour la fonte des glaciers + + REAL :: tau_calv + REAL,SAVE :: tau_calv_omp + +! Local + integer :: numout = 6 +! +!Config Key = tau_calv +!Config Desc = temps de relaxation pour fonte des glaciers en jours +!Config Def = 1 an +!Config Help = +! + tau_calv_omp = 360.*10. +!$OMP MASTER + call getin('tau_calv',tau_calv_omp) +!$OMP END MASTER +!$OMP BARRIER + + tau_calv=tau_calv_omp + +!$OMP MASTER + write(numout,*)' ##############################################' + WRITE(numout,*)' Configuration de l''interface atm/surfaces : ' + WRITE(numout,*)' tau_calv = ',tau_calv +!$OMP END MASTER + + return + + end subroutine conf_interface Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conflx.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conflx.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conflx.F (revision 1634) @@ -0,0 +1,1676 @@ +! +! $Header$ +! + SUBROUTINE conflx (dtime,pres_h,pres_f, + e t, q, con_t, con_q, pqhfl, w, + s d_t, d_q, rain, snow, + s pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + s kcbot, kctop, kdtop, pmflxr, pmflxs) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014 +c Objet: Schema flux de masse pour la convection +c (schema de Tiedtke avec qqs modifications mineures) +c Dec.97: Prise en compte des modifications introduites par +c Olivier Boucher et Alexandre Armengaud pour melange +c et lessivage des traceurs passifs. +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +c Entree: + REAL dtime ! pas d'integration (s) + REAL pres_h(klon,klev+1) ! pression half-level (Pa) + REAL pres_f(klon,klev)! pression full-level (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (g/g) + REAL w(klon,klev) ! vitesse verticale (Pa/s) + REAL con_t(klon,klev) ! convergence de temperature (K/s) + REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s) + REAL pqhfl(klon) ! evaporation (negative vers haut) mm/s +c Sortie: + REAL d_t(klon,klev) ! incrementation de temperature + REAL d_q(klon,klev) ! incrementation d'humidite + REAL pmfu(klon,klev) ! flux masse (kg/m2/s) panache ascendant + REAL pmfd(klon,klev) ! flux masse (kg/m2/s) panache descendant + REAL pen_u(klon,klev) + REAL pen_d(klon,klev) + REAL pde_u(klon,klev) + REAL pde_d(klon,klev) + REAL rain(klon) ! pluie (mm/s) + REAL snow(klon) ! neige (mm/s) + REAL pmflxr(klon,klev+1) + REAL pmflxs(klon,klev+1) + INTEGER kcbot(klon) ! niveau du bas de la convection + INTEGER kctop(klon) ! niveau du haut de la convection + INTEGER kdtop(klon) ! niveau du haut des downdrafts +c Local: + REAL pt(klon,klev) + REAL pq(klon,klev) + REAL pqs(klon,klev) + REAL pvervel(klon,klev) + LOGICAL land(klon) +c + REAL d_t_bis(klon,klev) + REAL d_q_bis(klon,klev) + REAL paprs(klon,klev+1) + REAL paprsf(klon,klev) + REAL zgeom(klon,klev) + REAL zcvgq(klon,klev) + REAL zcvgt(klon,klev) +cAA + REAL zmfu(klon,klev) + REAL zmfd(klon,klev) + REAL zen_u(klon,klev) + REAL zen_d(klon,klev) + REAL zde_u(klon,klev) + REAL zde_d(klon,klev) + REAL zmflxr(klon,klev+1) + REAL zmflxs(klon,klev+1) +cAA + +c + INTEGER i, k + REAL zdelta, zqsat +c +#include "FCTTRE.h" +c +c initialiser les variables de sortie (pour securite) + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + kcbot(i) = 0 + kctop(i) = 0 + kdtop(i) = 0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + pmfu(i,k) = 0.0 + pmfd(i,k) = 0.0 + pen_u(i,k) = 0.0 + pde_u(i,k) = 0.0 + pen_d(i,k) = 0.0 + pde_d(i,k) = 0.0 + zmfu(i,k) = 0.0 + zmfd(i,k) = 0.0 + zen_u(i,k) = 0.0 + zde_u(i,k) = 0.0 + zen_d(i,k) = 0.0 + zde_d(i,k) = 0.0 + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + zmflxr(i,k) = 0.0 + zmflxs(i,k) = 0.0 + ENDDO + ENDDO +c +c calculer la nature du sol (pour l'instant, ocean partout) + DO i = 1, klon + land(i) = .FALSE. + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pq(i,k) = q(i,klev-k+1) + paprsf(i,k) = pres_f(i,klev-k+1) + paprs(i,k) = pres_h(i,klev+1-k+1) + pvervel(i,k) = w(i,klev+1-k) + zcvgt(i,k) = con_t(i,klev-k+1) + zcvgq(i,k) = con_q(i,klev-k+1) +c + zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k))) + zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k) + zqsat=MIN(0.5,zqsat) + zqsat=zqsat/(1.-RETV *zqsat) + pqs(i,k) = zqsat + ENDDO + ENDDO + DO i = 1, klon + paprs(i,klev+1) = pres_h(i,1) + zgeom(i,klev) = RD * pt(i,klev) + . / (0.5*(paprs(i,klev+1)+paprsf(i,klev))) + . * (paprs(i,klev+1)-paprsf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + . + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1) + . * (paprsf(i,k+1)-paprsf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + CALL flxmain(dtime, pt, pq, pqs, pqhfl, + . paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel, + . rain, snow, kcbot, kctop, kdtop, + . zmfu, zmfd, zen_u, zde_u, zen_d, zde_d, + . d_t_bis, d_q_bis, zmflxr, zmflxs) +C +cAA-------------------------------------------------------- +cAA rem : De la meme facon que l'on effectue le reindicage +cAA pour la temperature t et le champ q +cAA on reindice les flux necessaires a la convection +cAA des traceurs +cAA-------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + d_q(i,klev+1-k) = dtime*d_q_bis(i,k) + d_t(i,klev+1-k) = dtime*d_t_bis(i,k) + ENDDO + ENDDO +c + DO i = 1, klon + pmfu(i,1)= 0. + pmfd(i,1)= 0. + pen_d(i,1)= 0. + pde_d(i,1)= 0. + ENDDO + + DO k = 2, klev + DO i = 1, klon + pmfu(i,klev+2-k)= zmfu(i,k) + pmfd(i,klev+2-k)= zmfd(i,k) + ENDDO + ENDDO +c + DO k = 1, klev + DO i = 1, klon + pen_u(i,klev+1-k)= zen_u(i,k) + pde_u(i,klev+1-k)= zde_u(i,k) + ENDDO + ENDDO +c + DO k = 1, klev-1 + DO i = 1, klon + pen_d(i,klev+1-k)= -zen_d(i,k+1) + pde_d(i,klev+1-k)= -zde_d(i,k+1) + ENDDO + ENDDO + + DO k = 1, klev+1 + DO i = 1, klon + pmflxr(i,klev+2-k)= zmflxr(i,k) + pmflxs(i,klev+2-k)= zmflxs(i,k) + ENDDO + ENDDO + + RETURN + END +c-------------------------------------------------------------------- + SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph, + . pgeo, ldland, ptte, pqte, pvervel, + . prsfc, pssfc, kcbot, kctop, kdtop, +c * ldcum, ktype, + . pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + . dt_con, dq_con, pmflxr, pmflxs) + USE dimphy + IMPLICIT none +C ------------------------------------------------------------------ +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C ---------------------------------------------------------------- + REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev) + REAL ptte(klon,klev) + REAL pqte(klon,klev) + REAL pvervel(klon,klev) + REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1) + REAL pqhfl(klon) +c + REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev) + REAL plude(klon,klev) + REAL pmfu(klon,klev) + REAL prsfc(klon), pssfc(klon) + INTEGER kcbot(klon), kctop(klon), ktype(klon) + LOGICAL ldland(klon), ldcum(klon) +c + REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev) + REAL zgeoh(klon,klev) + REAL zmfub(klon), zmfub1(klon) + REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev) + REAL zdmfup(klon,klev), zdpmel(klon,klev) + REAL zentr(klon), zhcbase(klon) + REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon) + REAL zrfl(klon) + REAL pmflxr(klon,klev+1) + REAL pmflxs(klon,klev+1) + INTEGER ilab(klon,klev), ictop0(klon) + LOGICAL llo1 + REAL dt_con(klon,klev), dq_con(klon,klev) + REAL zmfmax, zdh + REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz + REAL zhhat, zpbmpt, zgam, zeps, zfac + INTEGER i, k, ikb, itopm2, kcum +c + REAL pen_u(klon,klev), pde_u(klon,klev) + REAL pen_d(klon,klev), pde_d(klon,klev) +c + REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev) + REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev) + INTEGER kdtop(klon) + LOGICAL lddraf(klon) +C--------------------------------------------------------------------- + LOGICAL firstcal + SAVE firstcal + DATA firstcal / .TRUE. / +c$OMP THREADPRIVATE(firstcal) +C--------------------------------------------------------------------- + IF (firstcal) THEN + CALL flxsetup + firstcal = .FALSE. + ENDIF +C--------------------------------------------------------------------- + DO i = 1, klon + ldcum(i) = .FALSE. + ENDDO + DO k = 1, klev + DO i = 1, klon + dt_con(i,k) = 0.0 + dq_con(i,k) = 0.0 + ENDDO + ENDDO +c---------------------------------------------------------------------- +c initialiser les variables et faire l'interpolation verticale +c---------------------------------------------------------------------- + CALL flxini(pten, pqen, pqsen, pgeo, + . paph, zgeoh, ztenh, zqenh, zqsenh, + . ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, + . pmfu, zmfus, zmfuq, zdmfup, + . zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d) +c--------------------------------------------------------------------- +c determiner les valeurs au niveau de base de la tour convective +c--------------------------------------------------------------------- + CALL flxbase(ztenh, zqenh, zgeoh, paph, + * ptu, pqu, plu, ldcum, kcbot, ilab) +c--------------------------------------------------------------------- +c calculer la convergence totale de l'humidite et celle en provenance +c de la couche limite, plus precisement, la convergence integree entre +c le sol et la base de la convection. Cette derniere convergence est +c comparee avec l'evaporation obtenue dans la couche limite pour +c determiner le type de la convection +c--------------------------------------------------------------------- + k=1 + DO i = 1, klon + zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k)) + zdhpbl(i) = 0.0 + zdqpbl(i) = 0.0 + ENDDO +c + DO k=2,klev + DO i = 1, klon + zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k)) + IF (k.GE.kcbot(i)) THEN + zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k)) + zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k)) + . *(paph(i,k+1)-paph(i,k)) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + ktype(i) = 2 + if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1 +ccc if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1 + ENDDO +c +c--------------------------------------------------------------------- +c determiner le flux de masse entrant a travers la base. +c on ignore, pour l'instant, l'effet du panache descendant +c--------------------------------------------------------------------- + DO i = 1, klon + ikb=kcbot(i) + zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb) + zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10) + IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN + zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin)) + ELSE + zmfub(i) = 0.01 + ldcum(i)=.FALSE. + ENDIF + IF (ktype(i).EQ.2) THEN + zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe + zdh = RG * MAX(zdh,1.0E5*zdqmin) + IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh + ENDIF + zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime) + zmfub(i) = MIN(zmfub(i),zmfmax) + zentr(i) = ENTRSCV + IF (ktype(i).EQ.1) zentr(i) = ENTRPEN + ENDDO +C----------------------------------------------------------------------- +C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME +C----------------------------------------------------------------------- +c (A) calculer d'abord la hauteur "theorique" de la tour convective sans +c considerer l'entrainement ni le detrainement du panache, sachant +c ces derniers peuvent abaisser la hauteur theorique. +c + DO i = 1, klon + ikb=kcbot(i) + zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb) + ictop0(i)=kcbot(i)-1 + ENDDO +c + zalvdcp=RLVTT/RCPD + DO k=klev-1,3,-1 + DO i = 1, klon + zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k) + zgam=R5LES*zalvdcp*zqsenh(i,k)/ + . ((1.-RETV *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2) + zzz=RCPD*ztenh(i,k)*0.608 + zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)* + . MAX(zqsenh(i,k)-zqenh(i,k),0.) + IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k + ENDDO + ENDDO +c +c (B) calculer le panache ascendant +c + CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen, + . pgeo, zgeoh, pap, paph, pqte, pvervel, + . ldland, ldcum, ktype, ilab, + . ptu, pqu, plu, pmfu, zmfub, zentr, + . zmfus, zmfuq, zmful, plude, zdmfup, + . kcbot, kctop, ictop0, kcum, pen_u, pde_u) + IF (kcum.EQ.0) GO TO 1000 +C +C verifier l'epaisseur de la convection et changer eventuellement +c le taux d'entrainement/detrainement +C + DO i = 1, klon + zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i)) + IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2 + IF(ldcum(i)) ictop0(i)=kctop(i) + IF(ktype(i).EQ.2) zentr(i)=ENTRSCV + ENDDO +c + IF (lmfdd) THEN ! si l'on considere le panache descendant +c +c calculer la precipitation issue du panache ascendant pour +c determiner l'existence du panache descendant dans la convection + DO i = 1, klon + zrfl(i)=zdmfup(i,1) + ENDDO + DO k=2,klev + DO i = 1, klon + zrfl(i)=zrfl(i)+zdmfup(i,k) + ENDDO + ENDDO +c +c determiner le LFS (level of free sinking: niveau de plonge libre) + CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu, + * ldcum, kcbot, kctop, zmfub, zrfl, + * ptd, pqd, + * pmfd, zmfds, zmfdq, zdmfdp, + * kdtop, lddraf) +c +c calculer le panache descendant + CALL flxddraf(ztenh, zqenh, + * zgeoh, paph, zrfl, + * ptd, pqd, + * pmfd, zmfds, zmfdq, zdmfdp, + * lddraf, pen_d, pde_d) +c +c calculer de nouveau le flux de masse entrant a travers la base +c de la convection, sachant qu'il a ete modifie par le panache +c descendant + DO i = 1, klon + IF (lddraf(i)) THEN + ikb = kcbot(i) + llo1 = PMFD(i,ikb).LT.0. + zeps = 0. + IF ( llo1 ) zeps = CMFDEPS + zqumqe = pqu(i,ikb)+plu(i,ikb)- + . zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb) + zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10) + zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime) + IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i) + . .AND.zmfub(i).LT.zmfmax) THEN + zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin)) + ELSE + zmfub1(i) = zmfub(i) + ENDIF + IF (ktype(i).EQ.2) THEN + zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)- + . (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe + zdh = RG * MAX(zdh,1.0E5*zdqmin) + IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh + ENDIF + IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND. + . ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) ) + . zmfub1(i) = zmfub(i) + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (lddraf(i)) THEN + zfac = zmfub1(i)/MAX(zmfub(i),1.E-10) + pmfd(i,k) = pmfd(i,k)*zfac + zmfds(i,k) = zmfds(i,k)*zfac + zmfdq(i,k) = zmfdq(i,k)*zfac + zdmfdp(i,k) = zdmfdp(i,k)*zfac + pen_d(i,k) = pen_d(i,k)*zfac + pde_d(i,k) = pde_d(i,k)*zfac + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (lddraf(i)) zmfub(i)=zmfub1(i) + ENDDO +c + ENDIF ! fin de test sur lmfdd +c +c----------------------------------------------------------------------- +c calculer de nouveau le panache ascendant +c----------------------------------------------------------------------- + CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen, + . pgeo, zgeoh, pap, paph, pqte, pvervel, + . ldland, ldcum, ktype, ilab, + . ptu, pqu, plu, pmfu, zmfub, zentr, + . zmfus, zmfuq, zmful, plude, zdmfup, + . kcbot, kctop, ictop0, kcum, pen_u, pde_u) +c +c----------------------------------------------------------------------- +c determiner les flux convectifs en forme finale, ainsi que +c la quantite des precipitations +c----------------------------------------------------------------------- + CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, + . ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum, + . pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude, + . zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2, + . pmflxr, pmflxs) +c +c---------------------------------------------------------------------- +c calculer les tendances pour T et Q +c---------------------------------------------------------------------- + CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten, + e zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel, + s dt_con,dq_con) +c + 1000 CONTINUE + RETURN + END + SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh, + . pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq, + . pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude, + . klab,pen_u, pde_u, pen_d, pde_d) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC. +C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME), +C AND INITIALIZES VALUES FOR UPDRAFTS +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C + REAL pten(klon,klev) ! temperature (environnement) + REAL pqen(klon,klev) ! humidite (environnement) + REAL pqsen(klon,klev) ! humidite saturante (environnement) + REAL pgeo(klon,klev) ! geopotentiel (g * metre) + REAL pgeoh(klon,klev) ! geopotentiel aux demi-niveaux + REAL paph(klon,klev+1) ! pression aux demi-niveaux + REAL ptenh(klon,klev) ! temperature aux demi-niveaux + REAL pqenh(klon,klev) ! humidite aux demi-niveaux + REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux +C + REAL ptu(klon,klev) ! temperature du panache ascendant (p-a) + REAL pqu(klon,klev) ! humidite du p-a + REAL plu(klon,klev) ! eau liquide du p-a + REAL pmfu(klon,klev) ! flux de masse du p-a + REAL pmfus(klon,klev) ! flux de l'energie seche dans le p-a + REAL pmfuq(klon,klev) ! flux de l'humidite dans le p-a + REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a + REAL plude(klon,klev) ! quantite de l'eau liquide jetee du +c p-a a l'environnement + REAL pdpmel(klon,klev) ! quantite de neige fondue +c + REAL ptd(klon,klev) ! temperature du panache descendant (p-d) + REAL pqd(klon,klev) ! humidite du p-d + REAL pmfd(klon,klev) ! flux de masse du p-d + REAL pmfds(klon,klev) ! flux de l'energie seche dans le p-d + REAL pmfdq(klon,klev) ! flux de l'humidite dans le p-d + REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d +c + REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a + REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a + REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d + REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d +C + INTEGER klab(klon,klev) + LOGICAL llflag(klon) + INTEGER k, i, icall + REAL zzs +C---------------------------------------------------------------------- +C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS +C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE +C---------------------------------------------------------------------- + DO 130 k = 2, klev +c + DO i = 1, klon + pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5 + ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1), + . RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD + pqsenh(i,k)=pqsen(i,k-1) + llflag(i)=.TRUE. + ENDDO +c + icall=0 + CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall) +c + DO i = 1, klon + pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1)) + . +(pqsenh(i,k)-pqsen(i,k-1)) + pqenh(i,k)=MAX(pqenh(i,k),0.) + ENDDO +c + 130 CONTINUE +C + DO 140 i = 1, klon + ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)- + 1 pgeoh(i,klev))/RCPD + pqenh(i,klev)=pqen(i,klev) + ptenh(i,1)=pten(i,1) + pqenh(i,1)=pqen(i,1) + pgeoh(i,1)=pgeo(i,1) + 140 CONTINUE +c + DO 160 k = klev-1, 2, -1 + DO 150 i = 1, klon + zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k), + . RCPD*ptenh(i,k+1)+pgeoh(i,k+1)) + ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD + 150 CONTINUE + 160 CONTINUE +C +C----------------------------------------------------------------------- +C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS +C----------------------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + ptu(i,k) = ptenh(i,k) + pqu(i,k) = pqenh(i,k) + plu(i,k) = 0. + pmfu(i,k) = 0. + pmfus(i,k) = 0. + pmfuq(i,k) = 0. + pdmfup(i,k) = 0. + pdpmel(i,k) = 0. + plude(i,k) = 0. +c + klab(i,k) = 0 +c + ptd(i,k) = ptenh(i,k) + pqd(i,k) = pqenh(i,k) + pmfd(i,k) = 0.0 + pmfds(i,k) = 0.0 + pmfdq(i,k) = 0.0 + pdmfdp(i,k) = 0.0 +c + pen_u(i,k) = 0.0 + pde_u(i,k) = 0.0 + pen_d(i,k) = 0.0 + pde_d(i,k) = 0.0 + ENDDO + ENDDO +C + RETURN + END + SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, + * ptu, pqu, plu, ldcum, kcbot, klab) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q) +C +C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS. +C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS; +C klab=1 FOR SUBCLOUD LEVELS +C klab=2 FOR CONDENSATION LEVEL +C +C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE +C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX) +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C ---------------------------------------------------------------- + REAL ptenh(klon,klev), pqenh(klon,klev) + REAL pgeoh(klon,klev), paph(klon,klev+1) +C + REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev) + INTEGER klab(klon,klev), kcbot(klon) +C + LOGICAL llflag(klon), ldcum(klon) + INTEGER i, k, icall, is + REAL zbuo, zqold(klon) +C---------------------------------------------------------------------- +C INITIALIZE VALUES AT LIFTING LEVEL +C---------------------------------------------------------------------- + DO i = 1, klon + klab(i,klev)=1 + kcbot(i)=klev-1 + ldcum(i)=.FALSE. + ENDDO +C---------------------------------------------------------------------- +C DO ASCENT IN SUBCLOUD LAYER, +C CHECK FOR EXISTENCE OF CONDENSATION LEVEL, +C ADJUST T,Q AND L ACCORDINGLY +C CHECK FOR BUOYANCY AND SET FLAGS +C---------------------------------------------------------------------- + DO 290 k = klev-1, 2, -1 +c + is = 0 + DO i = 1, klon + IF (klab(i,k+1).EQ.1) is = is + 1 + llflag(i) = .FALSE. + IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE. + ENDDO + IF (is.EQ.0) GOTO 290 +c + DO i = 1, klon + IF(llflag(i)) THEN + pqu(i,k) = pqu(i,k+1) + ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD + zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- + . ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5 + IF (zbuo.GT.0.) klab(i,k) = 1 + zqold(i) = pqu(i,k) + ENDIF + ENDDO +c + icall=1 + CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall) +c + DO i = 1, klon + IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN + klab(i,k) = 2 + plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k) + zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- + . ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5 + IF (zbuo.GT.0.) kcbot(i) = k + IF (zbuo.GT.0.) ldcum(i) = .TRUE. + ENDIF + ENDDO +c + 290 CONTINUE +c + RETURN + END + SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen, + . pgeo, pgeoh, pap, paph, pqte, pvervel, + . ldland, ldcum, ktype, klab, ptu, pqu, plu, + . pmfu, pmfub, pentr, pmfus, pmfuq, + . pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum, + . pen_u, pde_u) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS +C FOR CUMULUS PARAMETERIZATION +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL pdtime + REAL pten(klon,klev), ptenh(klon,klev) + REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev) + REAL pgeo(klon,klev), pgeoh(klon,klev) + REAL pap(klon,klev), paph(klon,klev+1) + REAL pqte(klon,klev) + REAL pvervel(klon,klev) ! vitesse verticale en Pa/s +C + REAL pmfub(klon), pentr(klon) + REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev) + REAL plude(klon,klev) + REAL pmfu(klon,klev), pmfus(klon,klev) + REAL pmfuq(klon,klev), pmful(klon,klev) + REAL pdmfup(klon,klev) + INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon) + INTEGER kctop0(klon) + LOGICAL ldland(klon), ldcum(klon) +C + REAL pen_u(klon,klev), pde_u(klon,klev) + REAL zqold(klon) + REAL zdland(klon) + LOGICAL llflag(klon) + INTEGER k, i, is, icall, kcum + REAL ztglace, zdphi, zqeen, zseen, zscde, zqude + REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew +c + REAL zpbot(klon), zptop(klon), zrho(klon) + REAL zdprho, zentr, zpmid, zmftest, zmfmax + LOGICAL llo1, llo2 +c + REAL zwmax(klon), zzzmb + INTEGER klwmin(klon) ! level of maximum vertical velocity +C---------------------------------------------------------------------- + ztglace = RTT - 13. +c +c Chercher le niveau ou la vitesse verticale est maximale: + DO i = 1, klon + klwmin(i) = klev + zwmax(i) = 0.0 + ENDDO + DO k = klev, 3, -1 + DO i = 1, klon + IF (pvervel(i,k).LT.zwmax(i)) THEN + zwmax(i) = pvervel(i,k) + klwmin(i) = k + ENDIF + ENDDO + ENDDO +C---------------------------------------------------------------------- +C SET DEFAULT VALUES +C---------------------------------------------------------------------- + DO i = 1, klon + IF (.NOT.ldcum(i)) ktype(i)=0 + ENDDO +c + DO k=1,klev + DO i = 1, klon + plu(i,k)=0. + pmfu(i,k)=0. + pmfus(i,k)=0. + pmfuq(i,k)=0. + pmful(i,k)=0. + plude(i,k)=0. + pdmfup(i,k)=0. + IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0 + IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k + ENDDO + ENDDO +c + DO i = 1, klon + IF (ldland(i)) THEN + zdland(i)=3.0E4 + zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i)) + IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi + zdland(i)=MAX(3.0E4,zdland(i)) + zdland(i)=MIN(5.0E4,zdland(i)) + ENDIF + ENDDO +C +C Initialiser les valeurs au niveau d'ascendance +C + DO i = 1, klon + kctop(i) = klev-1 + IF (.NOT.ldcum(i)) THEN + kcbot(i) = klev-1 + pmfub(i) = 0. + pqu(i,klev) = 0. + ENDIF + pmfu(i,klev) = pmfub(i) + pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev)) + pmfuq(i,klev) = pmfub(i)*pqu(i,klev) + ENDDO +c + DO i = 1, klon + ldcum(i) = .FALSE. + ENDDO +C---------------------------------------------------------------------- +C DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2) +C BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN +C BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*, +C THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY +C---------------------------------------------------------------------- + DO 480 k = klev-1,3,-1 +c + IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN + DO i = 1, klon + IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND. + . pqen(i,k).GT.0.9*pqsen(i,k)) THEN + ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD + pqu(i,k+1) = pqen(i,k) + plu(i,k+1) = 0.0 + zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG) + zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime) + pmfub(i) = MIN(zzzmb,zmfmax) + pmfu(i,k+1) = pmfub(i) + pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1)) + pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1) + pmful(i,k+1) = 0.0 + pdmfup(i,k+1) = 0.0 + kcbot(i) = k + klab(i,k+1) = 1 + ktype(i) = 3 + pentr(i) = ENTRMID + ENDIF + ENDDO + ENDIF +c + is = 0 + DO i = 1, klon + is = is + klab(i,k+1) + IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0 + llflag(i) = .FALSE. + IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE. + ENDDO + IF (is .EQ. 0) GOTO 480 +c +c calculer le taux d'entrainement et de detrainement +c + DO i = 1, klon + pen_u(i,k) = 0.0 + pde_u(i,k) = 0.0 + zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1)) + zpbot(i)=paph(i,kcbot(i)) + zptop(i)=paph(i,kctop0(i)) + ENDDO +c + DO 125 i = 1, klon + IF(ldcum(i)) THEN + zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i)) + zentr=pentr(i)*pmfu(i,k+1)*zdprho + llo1=k.LT.kcbot(i) + IF(llo1) pde_u(i,k)=zentr + zpmid=0.5*(zpbot(i)+zptop(i)) + llo2=llo1.AND.ktype(i).EQ.2.AND. + . (zpbot(i)-paph(i,k).LT.0.2E5.OR. + . paph(i,k).GT.zpmid) + IF(llo2) pen_u(i,k)=zentr + llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND. + . (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid) + IF(llo2) pen_u(i,k)=zentr + llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2) + IF(llo1) THEN + zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4))) + pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1., + . (zpbot(i)-pap(i,k))/1.5E4))) + pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1., + . (zpbot(i)-pap(i,k))/1.5E4))) + ENDIF + IF(llo2.AND.pqenh(i,k+1).GT.1.E-5) + . pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)* + . zrho(i)*zdprho + ENDIF + 125 CONTINUE +c +C---------------------------------------------------------------------- +c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME +C---------------------------------------------------------------------- +c + DO 420 i = 1, klon + IF (llflag(i)) THEN + IF (k.LT.kcbot(i)) THEN + zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k) + zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime)) + pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0) + ENDIF + pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1)) +c calculer le flux de masse du niveau k a partir de celui du k+1 + pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k) +c calculer les valeurs Su, Qu et l du niveau k dans le panache montant + zqeen=pqenh(i,k+1)*pen_u(i,k) + zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k) + zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k) + zqude=pqu(i,k+1)*pde_u(i,k) + plude(i,k)=plu(i,k+1)*pde_u(i,k) + zmfusk=pmfus(i,k+1)+zseen-zscde + zmfuqk=pmfuq(i,k+1)+zqeen-zqude + zmfulk=pmful(i,k+1) -plude(i,k) + plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k))) + pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k))) + ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))- + 1 pgeoh(i,k))/RCPD + ptu(i,k)=MAX(100.,ptu(i,k)) + ptu(i,k)=MIN(400.,ptu(i,k)) + zqold(i)=pqu(i,k) + ELSE + zqold(i)=0.0 + ENDIF + 420 CONTINUE +c +C---------------------------------------------------------------------- +c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L +C---------------------------------------------------------------------- +c + icall = 1 + CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall) +C + DO 440 i = 1, klon + IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN + klab(i,k) = 2 + plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k) + zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- + . ptenh(i,k)*(1.+RETV*pqenh(i,k)) + IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5 + IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN + kctop(i) = k + ldcum(i) = .TRUE. + zdnoprc = 1.5E4 + IF (ldland(i)) zdnoprc = zdland(i) + zprcon = CPRCON + IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0 + zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1))) + pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k)) + plu(i,k)=zlnew + ELSE + klab(i,k)=0 + pmfu(i,k)=0. + ENDIF + ENDIF + 440 CONTINUE + DO 455 i = 1, klon + IF (llflag(i)) THEN + pmful(i,k)=plu(i,k)*pmfu(i,k) + pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k) + pmfuq(i,k)=pqu(i,k)*pmfu(i,k) + ENDIF + 455 CONTINUE +C + 480 CONTINUE +C---------------------------------------------------------------------- +C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL +C (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT +C AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN +C FROM PREVIOUS CALCULATIONS ABOVE) +C---------------------------------------------------------------------- + DO i = 1, klon + IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE. + kcbot(i) = MAX(kcbot(i),kctop(i)) + ENDDO +c + ldcum(1)=ldcum(1) +c + is = 0 + DO i = 1, klon + if (ldcum(i)) is = is + 1 + ENDDO + kcum = is + IF (is.EQ.0) GOTO 800 +c + DO 530 i = 1, klon + IF (ldcum(i)) THEN + k=kctop(i)-1 + pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1) + plude(i,k)=pde_u(i,k)*plu(i,k+1) + pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k) + zlnew=plu(i,k) + pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k)) + plu(i,k)=zlnew + pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k) + pmfuq(i,k)=pqu(i,k)*pmfu(i,k) + pmful(i,k)=plu(i,k)*pmfu(i,k) + plude(i,k-1)=pmful(i,k) + ENDIF + 530 CONTINUE +C + 800 CONTINUE + RETURN + END + SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap + . , paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop + . , ktype, ldcum, pmfu, pmfd, pmfus, pmfds + . , pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp + . , pten, prfl, psfl, pdpmel, ktopm2 + . , pmflxr, pmflxs) + USE dimphy + IMPLICIT none +C---------------------------------------------------------------------- +C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE +C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL cevapcu(klon,klev) +C ----------------------------------------------------------------- + REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev) + REAL pten(klon,klev), ptenh(klon,klev) + REAL paph(klon,klev+1), pgeoh(klon,klev) +c + REAL pap(klon,klev) + REAL ztmsmlt, zdelta, zqsat +C + REAL pmfu(klon,klev), pmfus(klon,klev) + REAL pmfd(klon,klev), pmfds(klon,klev) + REAL pmfuq(klon,klev), pmful(klon,klev) + REAL pmfdq(klon,klev) + REAL plude(klon,klev) + REAL pdmfup(klon,klev), pdpmel(klon,klev) +cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher +cjq 14/11/00 to fix the problem with the negative precipitation. + REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) + REAL prfl(klon), psfl(klon) + REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1) + INTEGER kcbot(klon), kctop(klon), ktype(klon) + LOGICAL ldland(klon), ldcum(klon) + INTEGER k, kp, i + REAL zcons1, zcons2, zcucov, ztmelp2 + REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew + REAL zrmin, zrfln, zdrfl + REAL zpds, zpdr, zdenom + INTEGER ktopm2, itop, ikb +c + LOGICAL lddraf(klon) + INTEGER kdtop(klon) +c +#include "FCTTRE.h" +c + DO 101 k=1,klev + DO i=1,klon + CEVAPCU(i,k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293) + 1 *SQRT(0.5*(paph(i,k)+paph(i,k+1))/paph(i,klev+1)) ) * 0.5/RG + ENDDO + 101 CONTINUE +c +c SPECIFY CONSTANTS +c + zcons1 = RCPD/(RLMLT*RG*pdtime) + zcons2 = 1./(RG*pdtime) + zcucov = 0.05 + ztmelp2 = RTT + 2. +c +c DETERMINE FINAL CONVECTIVE FLUXES +c + itop=klev + DO 110 i = 1, klon + itop=MIN(itop,kctop(i)) + IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE. + IF(.NOT.ldcum(i)) ktype(i)=0 + 110 CONTINUE +c + ktopm2=itop-2 + DO 120 k=ktopm2,klev + DO 115 i = 1, klon + IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN + pmfus(i,k)=pmfus(i,k)-pmfu(i,k)* + . (RCPD*ptenh(i,k)+pgeoh(i,k)) + pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k) + zdp = 1.5E4 + IF ( ldland(i) ) zdp = 3.E4 +c +c l'eau liquide detrainee est precipitee quand certaines +c conditions sont reunies (sinon, elle est consideree +c evaporee dans l'environnement) +c + IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND. + . pqen(i,k-1).GT.0.8*pqsen(i,k-1)) + . pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1) +c + IF(lddraf(i).AND.k.GE.kdtop(i)) THEN + pmfds(i,k)=pmfds(i,k)-pmfd(i,k)* + . (RCPD*ptenh(i,k)+pgeoh(i,k)) + pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k) + ELSE + pmfd(i,k)=0. + pmfds(i,k)=0. + pmfdq(i,k)=0. + pdmfdp(i,k-1)=0. + END IF + ELSE + pmfu(i,k)=0. + pmfus(i,k)=0. + pmfuq(i,k)=0. + pmful(i,k)=0. + pdmfup(i,k-1)=0. + plude(i,k-1)=0. + pmfd(i,k)=0. + pmfds(i,k)=0. + pmfdq(i,k)=0. + pdmfdp(i,k-1)=0. + ENDIF + 115 CONTINUE + 120 CONTINUE +c + DO 130 k=ktopm2,klev + DO 125 i = 1, klon + IF(ldcum(i).AND.k.GT.kcbot(i)) THEN + ikb=kcbot(i) + zzp=((paph(i,klev+1)-paph(i,k))/ + . (paph(i,klev+1)-paph(i,ikb))) + IF (ktype(i).EQ.3) zzp = zzp**2 + pmfu(i,k)=pmfu(i,ikb)*zzp + pmfus(i,k)=pmfus(i,ikb)*zzp + pmfuq(i,k)=pmfuq(i,ikb)*zzp + pmful(i,k)=pmful(i,ikb)*zzp + ENDIF + 125 CONTINUE + 130 CONTINUE +c +c CALCULATE RAIN/SNOW FALL RATES +c CALCULATE MELTING OF SNOW +c CALCULATE EVAPORATION OF PRECIP +c + DO k = 1, klev+1 + DO i = 1, klon + pmflxr(i,k) = 0.0 + pmflxs(i,k) = 0.0 + ENDDO + ENDDO + DO k = ktopm2, klev + DO i = 1, klon + IF (ldcum(i)) THEN + IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN + zfac=zcons1*(paph(i,k+1)-paph(i,k)) + zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2)) + pdpmel(i,k)=zsnmlt + ztmsmlt=pten(i,k)-zsnmlt/zfac + zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt)) + zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k) + zqsat=MIN(0.5,zqsat) + zqsat=zqsat/(1.-RETV *zqsat) + pqsen(i,k) = zqsat + ENDIF + IF (pten(i,k).GT.RTT) THEN + pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k) + pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k) + ELSE + pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k) + pmflxr(i,k+1)=pmflxr(i,k) + ENDIF +c si la precipitation est negative, on ajuste le plux du +c panache descendant pour eliminer la negativite + IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN + pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k) + pmflxr(i,k+1) = 0.0 + pmflxs(i,k+1) = 0.0 + pdpmel(i,k) = 0.0 + ENDIF + ENDIF + ENDDO + ENDDO +c +cjq The new variable is initialized here. +cjq It contains the humidity which is fed to the downdraft +cjq by evaporation of precipitation in the column below the base +cjq of convection. +cjq +cjq In the former version, this term has been subtracted from precip +cjq as well as the evaporation. +cjq + DO k = 1, klev + DO i = 1, klon + maxpdmfdp(i,k)=0.0 + ENDDO + ENDDO + DO k = 1, klev + DO kp = k, klev + DO i = 1, klon + maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp) + ENDDO + ENDDO + ENDDO +cjq End of initialization +c + DO k = ktopm2, klev + DO i = 1, klon + IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN + zrfl = pmflxr(i,k) + pmflxs(i,k) + IF (zrfl.GT.1.0E-20) THEN + zrnew=(MAX(0.,SQRT(zrfl/zcucov)- + . CEVAPCU(i,k)*(paph(i,k+1)-paph(i,k))* + . MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov + zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k)) + . *zcons2*(paph(i,k+1)-paph(i,k)) + zrnew=MAX(zrnew,zrmin) + zrfln=MAX(zrnew,0.) + zdrfl=MIN(0.,zrfln-zrfl) +cjq At least the amount of precipiation needed to feed the downdraft +cjq with humidity below the base of convection has to be left and can't +cjq be evaporated (surely the evaporation can't be positive): + zdrfl=MAX(zdrfl, + . MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0)) +cjq End of insertion +c + zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k)) + IF (pten(i,k).GT.RTT) THEN + zpdr = pdmfdp(i,k) + zpds = 0.0 + ELSE + zpdr = 0.0 + zpds = pdmfdp(i,k) + ENDIF + pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k) + . + zdrfl*pmflxr(i,k)*zdenom + pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k) + . + zdrfl*pmflxs(i,k)*zdenom + pdmfup(i,k) = pdmfup(i,k) + zdrfl + ELSE + pmflxr(i,k+1) = 0.0 + pmflxs(i,k+1) = 0.0 + pdmfdp(i,k) = 0.0 + pdpmel(i,k) = 0.0 + ENDIF + if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) + . write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k) + ENDIF + ENDDO + ENDDO +c + DO 210 i = 1, klon + prfl(i) = pmflxr(i,klev+1) + psfl(i) = pmflxs(i,klev+1) + 210 CONTINUE +c + RETURN + END + SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten + . , pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp + . , pdpmel, dt_con, dq_con) + USE dimphy + IMPLICIT none +c---------------------------------------------------------------------- +c calculer les tendances T et Q +c---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C ----------------------------------------------------------------- + LOGICAL llo1 +C + REAL pten(klon,klev), paph(klon,klev+1) + REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev) + REAL pmfds(klon,klev), pmfdq(klon,klev) + REAL pdmfup(klon,klev) + REAL pdmfdp(klon,klev) + REAL pdpmel(klon,klev) + LOGICAL ldcum(klon) + REAL dt_con(klon,klev), dq_con(klon,klev) +c + INTEGER ktopm2 + REAL pdtime +c + INTEGER i, k + REAL zalv, zdtdt, zdqdt +c + DO 210 k=ktopm2,klev-1 + DO 220 i = 1, klon + IF (ldcum(i)) THEN + llo1 = (pten(i,k)-RTT).GT.0. + zalv = RLSTT + IF (llo1) zalv = RLVTT + zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD + . *(pmfus(i,k+1)-pmfus(i,k) + . +pmfds(i,k+1)-pmfds(i,k) + . -RLMLT*pdpmel(i,k) + . -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k)) + . ) + dt_con(i,k)=zdtdt + zdqdt=RG/(paph(i,k+1)-paph(i,k)) + . *(pmfuq(i,k+1)-pmfuq(i,k) + . +pmfdq(i,k+1)-pmfdq(i,k) + . +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k)) + dq_con(i,k)=zdqdt + ENDIF + 220 CONTINUE + 210 CONTINUE +C + k = klev + DO 230 i = 1, klon + IF (ldcum(i)) THEN + llo1 = (pten(i,k)-RTT).GT.0. + zalv = RLSTT + IF (llo1) zalv = RLVTT + zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD + . *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k) + . -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k))) + dt_con(i,k)=zdtdt + zdqdt=-RG/(paph(i,k+1)-paph(i,k)) + . *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k) + . +pdmfup(i,k)+pdmfdp(i,k)) + dq_con(i,k)=zdqdt + ENDIF + 230 CONTINUE +C + RETURN + END + SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu, + . ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd, + . pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf) + USE dimphy + IMPLICIT none +C +C---------------------------------------------------------------------- +C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR +C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES +C +C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS +C FOR MASSFLUX CUMULUS PARAMETERIZATION +C +C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI +C AND UPDRAFT VALUES T,Q,U AND V AND ALSO +C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE. +C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS. +C +C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF +C MOIST ENVIRONMENTAL AIR AND CLOUD AIR. +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL ptenh(klon,klev) + REAL pqenh(klon,klev) + REAL pgeoh(klon,klev), paph(klon,klev+1) + REAL ptu(klon,klev), pqu(klon,klev) + REAL pmfub(klon) + REAL prfl(klon) +C + REAL ptd(klon,klev), pqd(klon,klev) + REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev) + REAL pdmfdp(klon,klev) + INTEGER kcbot(klon), kctop(klon), kdtop(klon) + LOGICAL ldcum(klon), lddraf(klon) +C + REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon) + REAL zttest, zqtest, zbuo, zmftop + LOGICAL llo2(klon) + INTEGER i, k, is, icall +C---------------------------------------------------------------------- + DO i= 1, klon + lddraf(i)=.FALSE. + kdtop(i)=klev+1 + ENDDO +C +C---------------------------------------------------------------------- +C DETERMINE LEVEL OF FREE SINKING BY +C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS +C +C FOR EVERY POINT AND PROCEED AS FOLLOWS: +C (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q +C (2) DO MIXING WITH CUMULUS CLOUD AIR +C (3) CHECK FOR NEGATIVE BUOYANCY +C +C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE +C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB +C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO +C EVAPORATION OF RAIN AND CLOUD WATER) +C---------------------------------------------------------------------- +C + DO 290 k = 3, klev-3 +C + is=0 + DO 212 i= 1, klon + ztenwb(i,k)=ptenh(i,k) + zqenwb(i,k)=pqenh(i,k) + llo2(i) = ldcum(i).AND.prfl(i).GT.0. + . .AND..NOT.lddraf(i) + . .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i)) + IF ( llo2(i) ) is = is + 1 + 212 CONTINUE + IF(is.EQ.0) GO TO 290 +C + icall=2 + CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall) +C +C---------------------------------------------------------------------- +C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR +C AND CHECK FOR NEGATIVE BUOYANCY. +C THEN SET VALUES FOR DOWNDRAFT AT LFS. +C---------------------------------------------------------------------- + DO 222 i= 1, klon + IF (llo2(i)) THEN + zttest=0.5*(ptu(i,k)+ztenwb(i,k)) + zqtest=0.5*(pqu(i,k)+zqenwb(i,k)) + zbuo=zttest*(1.+RETV*zqtest)- + . ptenh(i,k)*(1.+RETV *pqenh(i,k)) + zcond(i)=pqenh(i,k)-zqenwb(i,k) + zmftop=-CMFDEPS*pmfub(i) + IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN + kdtop(i)=k + lddraf(i)=.TRUE. + ptd(i,k)=zttest + pqd(i,k)=zqtest + pmfd(i,k)=zmftop + pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k)) + pmfdq(i,k)=pmfd(i,k)*pqd(i,k) + pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i) + prfl(i)=prfl(i)+pdmfdp(i,k-1) + ENDIF + ENDIF + 222 CONTINUE +c + 290 CONTINUE +C + RETURN + END + SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, + . ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, + . lddraf, pen_d, pde_d) + USE dimphy + IMPLICIT none +C +C---------------------------------------------------------------------- +C THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT +C +C TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS +C (I.E. T,Q,U AND V AND FLUXES) +C +C INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS. +C IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE +C AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS +C +C CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY +C A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND +C B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE. +C +C---------------------------------------------------------------------- +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "YOECUMF.h" +C + REAL ptenh(klon,klev), pqenh(klon,klev) + REAL pgeoh(klon,klev), paph(klon,klev+1) +C + REAL ptd(klon,klev), pqd(klon,klev) + REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev) + REAL pdmfdp(klon,klev) + REAL prfl(klon) + LOGICAL lddraf(klon) +C + REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon) + LOGICAL llo2(klon), llo1 + INTEGER i, k, is, icall, itopde + REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp + REAL zbuo +C---------------------------------------------------------------------- +C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY +C (A) CALCULATING ENTRAINMENT RATES, ASSUMING +C LINEAR DECREASE OF MASSFLUX IN PBL +C (B) DOING MOIST DESCENT - EVAPORATIVE COOLING +C AND MOISTENING IS CALCULATED IN *flxadjtq* +C (C) CHECKING FOR NEGATIVE BUOYANCY AND +C SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES +C + DO 180 k = 3, klev +c + is = 0 + DO i = 1, klon + llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0. + IF (llo2(i)) is = is + 1 + ENDDO + IF (is.EQ.0) GOTO 180 +c + DO i = 1, klon + IF (llo2(i)) THEN + zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/ + . (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1)) + pen_d(i,k) = zentr + pde_d(i,k) = zentr + ENDIF + ENDDO +c + itopde = klev-2 + IF (k.GT.itopde) THEN + DO i = 1, klon + IF (llo2(i)) THEN + pen_d(i,k)=0. + pde_d(i,k)=pmfd(i,itopde)* + . (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde)) + ENDIF + ENDDO + ENDIF +C + DO i = 1, klon + IF (llo2(i)) THEN + pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k) + zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k) + zqeen = pqenh(i,k-1)*pen_d(i,k) + zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k) + zqdde = pqd(i,k-1)*pde_d(i,k) + zmfdsk = pmfds(i,k-1)+zseen-zsdde + zmfdqk = pmfdq(i,k-1)+zqeen-zqdde + pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k))) + ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))- + . pgeoh(i,k))/RCPD + ptd(i,k) = MIN(400.,ptd(i,k)) + ptd(i,k) = MAX(100.,ptd(i,k)) + zcond(i) = pqd(i,k) + ENDIF + ENDDO +C + icall = 2 + CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall) +C + DO i = 1, klon + IF (llo2(i)) THEN + zcond(i) = zcond(i)-pqd(i,k) + zbuo = ptd(i,k)*(1.+RETV *pqd(i,k))- + . ptenh(i,k)*(1.+RETV *pqenh(i,k)) + llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.) + IF (.not.llo1) pmfd(i,k) = 0.0 + pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k) + pmfdq(i,k) = pqd(i,k)*pmfd(i,k) + zdmfdp = -pmfd(i,k)*zcond(i) + pdmfdp(i,k-1) = zdmfdp + prfl(i) = prfl(i)+zdmfdp + ENDIF + ENDDO +c + 180 CONTINUE + RETURN + END + SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall) + USE dimphy + IMPLICIT none +c====================================================================== +c Objet: ajustement entre T et Q +c====================================================================== +C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS +C kcall=0 ENV. T AND QS IN*CUINI* +C kcall=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC) +C kcall=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF) +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +C + REAL pt(klon), pq(klon), pp(klon) + LOGICAL ldflag(klon) + INTEGER kcall +c + REAL zcond(klon), zcond1 + REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp + REAL zdelta, zcvm5, zldcp, zqsat, zcor + INTEGER is, i +#include "YOETHF.h" +#include "FCTTRE.h" +C + z5alvcp = r5les*RLVTT/RCPD + z5alscp = r5ies*RLSTT/RCPD + zalvdcp = rlvtt/RCPD + zalsdcp = rlstt/RCPD +C + + DO i = 1, klon + zcond(i) = 0.0 + ENDDO + + DO 210 i =1, klon + IF (ldflag(i)) THEN + zdelta = MAX(0.,SIGN(1.,RTT-pt(i))) + zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp + zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp + zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i) + zqsat = MIN(0.5,zqsat) + zcor = 1./(1.-RETV*zqsat) + zqsat = zqsat*zcor + zcond(i) = (pq(i)-zqsat) + . / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)) + IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.) + IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.) + pt(i) = pt(i) + zldcp*zcond(i) + pq(i) = pq(i) - zcond(i) + ENDIF + 210 CONTINUE +C + is = 0 + DO i =1, klon + IF (zcond(i).NE.0.) is = is + 1 + ENDDO + IF (is.EQ.0) GOTO 230 +C + DO 220 i = 1, klon + IF(ldflag(i).AND.zcond(i).NE.0.) THEN + zdelta = MAX(0.,SIGN(1.,RTT-pt(i))) + zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp + zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp + zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i) + zqsat = MIN(0.5,zqsat) + zcor = 1./(1.-RETV*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(i)-zqsat) + . / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor)) + pt(i) = pt(i) + zldcp*zcond1 + pq(i) = pq(i) - zcond1 + ENDIF + 220 CONTINUE +C + 230 CONTINUE + RETURN + END + SUBROUTINE flxsetup + IMPLICIT none +C +C THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME +C +#include "YOECUMF.h" +C + ENTRPEN=1.0E-4 ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION + ENTRSCV=3.0E-4 ! ENTRAINMENT RATE FOR SHALLOW CONVECTION + ENTRMID=1.0E-4 ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION + ENTRDD =2.0E-4 ! ENTRAINMENT RATE FOR DOWNDRAFTS + CMFCTOP=0.33 ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL + CMFCMAX=1.0 ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC + CMFCMIN=1.E-10 ! MINIMUM MASSFLUX VALUE (FOR SAFETY) + CMFDEPS=0.3 ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS + CPRCON =2.0E-4 ! CONVERSION FROM CLOUD WATER TO RAIN + RHCDD=1. ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED) +c (FORMULATION IMPLIES SATURATION) + LMFPEN = .TRUE. + LMFSCV = .TRUE. + LMFMID = .TRUE. + LMFDD = .TRUE. + LMFDUDV = .TRUE. +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conlmd.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conlmd.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/conlmd.F (revision 1634) @@ -0,0 +1,2321 @@ +! +! $Header$ +! + SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q, + s d_t, d_q, rain, snow, ibas, itop) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Schema de convection utilis'e dans le modele du LMD +c Ajustement humide (Manabe) + Ajustement convectif (Kuo) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +c +c Arguments: +c + REAL dtime ! pas d'integration (s) + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s) +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER ibas(klon) ! niveau du bas + INTEGER itop(klon) ! niveau du haut +c + LOGICAL usekuo ! utiliser convection profonde (schema Kuo) + PARAMETER (usekuo=.TRUE.) +c + REAL d_t_bis(klon,klev) + REAL d_q_bis(klon,klev) + REAL rain_bis(klon) + REAL snow_bis(klon) + INTEGER ibas_bis(klon) + INTEGER itop_bis(klon) + REAL d_ql(klon,klev), d_ql_bis(klon,klev) + REAL rneb(klon,klev), rneb_bis(klon,klev) +c + INTEGER i, k + REAL zlvdcp, zlsdcp, zdelta, zz, za, zb +c +ccc CALL fiajh ! ancienne version de Convection Manabe + CALL conman ! nouvelle version de Convection Manabe + e (dtime, paprs, pplay, t, q, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop) +c + IF (usekuo) THEN +ccc CALL fiajc ! ancienne version de Convection Kuo + CALL conkuo ! nouvelle version de Convection Kuo + e (dtime, paprs, pplay, t, q, conv_q, + s d_t_bis, d_q_bis, d_ql_bis, rneb_bis, + s rain_bis, snow_bis, ibas_bis, itop_bis) + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = d_t(i,k) + d_t_bis(i,k) + d_q(i,k) = d_q(i,k) + d_q_bis(i,k) + d_ql(i,k) = d_ql(i,k) + d_ql_bis(i,k) + ENDDO + ENDDO + DO i = 1, klon + rain(i) = rain(i) + rain_bis(i) + snow(i) = snow(i) + snow_bis(i) + ibas(i) = MIN(ibas(i),ibas_bis(i)) + itop(i) = MAX(itop(i),itop_bis(i)) + ENDDO + ENDIF +c +c L'eau liquide convective est dispersee dans l'air: +c + DO k = 1, klev + DO i = 1, klon + zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k)) + zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k)) + zdelta = MAX(0.,SIGN(1.,RTT-t(i,k))) + zz = d_ql(i,k) ! re-evap. de l'eau liquide + zb = MAX(0.0,zz) + za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + d_t(i,k) = d_t(i,k) + za + d_q(i,k) = d_q(i,k) + zb + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE conman (dtime, paprs, pplay, t, q, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324 +c Objet: ajustement humide convectif avec la possibilite de faire +c l'ajustement sur une fraction de la maille. +c Methode: On impose une distribution uniforme pour la vapeur d'eau +c au sein d'une maille. On applique la procedure d'ajustement +c successivement a la totalite, 75%, 50%, 25% et 5% de la maille +c jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente +c les activites convectives et corrige le biais "trop froid et sec" +c du modele. +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c + REAL dtime ! pas d'integration (s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL d_ql(klon,klev) ! incrementation eau liquide + REAL rneb(klon,klev) ! nebulosite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER ibas(klon) ! niveau du bas + INTEGER itop(klon) ! niveau du haut +c + LOGICAL afaire(klon) ! .TRUE. implique l'ajustement + LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif +c + INTEGER nb ! nombre de sous-fractions a considere + PARAMETER (nb=1) +ccc PARAMETER (nb=3) +c + REAL ratqs ! largeur de la distribution pour vapeur d'eau + PARAMETER (ratqs=0.05) +c + REAL w_q(klon,klev) + REAL w_d_t(klon,klev), w_d_q(klon,klev), w_d_ql(klon,klev) + REAL w_rneb(klon,klev) + REAL w_rain(klon), w_snow(klon) + INTEGER w_ibas(klon), w_itop(klon) + REAL zq1, zq2 + INTEGER i, k, n +c + REAL t_coup + PARAMETER (t_coup=234.0) + REAL zdp1, zdp2 + REAL zqs1, zqs2, zdqs1, zdqs2 + REAL zgamdz + REAL zflo ! flotabilite + REAL zsat ! sur-saturation + REAL zdelta, zcor, zcvm5 + LOGICAL imprim +c + INTEGER ncpt + SAVE ncpt +c$OMP THREADPRIVATE(ncpt) + REAL frac(nb) ! valeur de la maille fractionnelle + SAVE frac +c$OMP THREADPRIVATE(frac) + INTEGER opt_cld(nb) ! option pour le modele nuageux + SAVE opt_cld +c$OMP THREADPRIVATE(opt_cld) + LOGICAL appel1er + SAVE appel1er +c$OMP THREADPRIVATE(appel1er) +c +c Fonctions thermodynamiques: +c +#include "YOETHF.h" +#include "FCTTRE.h" +c + DATA frac / 1.0 / + DATA opt_cld / 4 / +ccc DATA frac / 1.0, 0.50, 0.25/ +ccc DATA opt_cld / 4, 4, 4/ +c + DATA appel1er /.TRUE./ + DATA ncpt /0/ +c + IF (appel1er) THEN + PRINT*, 'conman, nb:', nb + PRINT*, 'conman, frac:', frac + PRINT*, 'conman, opt_cld:', opt_cld + appel1er = .FALSE. + ENDIF +c +c Initialiser les sorties a zero: +c + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + ibas(i) = klev + itop(i) = 1 + rain(i) = 0.0 + snow(i) = 0.0 + ENDDO +c +c S'il n'y a pas d'instabilite conditionnelle, +c pas la penne de se fatiguer: +c + DO i = 1, klon + afaire(i) = .FALSE. + ENDDO + DO k = 1, klev-1 + DO i = 1, klon + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-t(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k)) + zqs1= R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k) + zqs1=MIN(0.5,zqs1) + zcor=1./(1.-RETV*zqs1) + zqs1=zqs1*zcor + zdqs1 =FOEDE(t(i,k),zdelta,zcvm5,zqs1,zcor) +c + zdelta=MAX(0.,SIGN(1.,RTT-t(i,k+1))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k+1)) + zqs2= R2ES*FOEEW(t(i,k+1),zdelta)/pplay(i,k+1) + zqs2=MIN(0.5,zqs2) + zcor=1./(1.-RETV*zqs2) + zqs2=zqs2*zcor + zdqs2 =FOEDE(t(i,k+1),zdelta,zcvm5,zqs2,zcor) + ELSE + IF (t(i,k) .LT. t_coup) THEN + zqs1= qsats(t(i,k)) / pplay(i,k) + zdqs1= dqsats(t(i,k),zqs1) +c + zqs2= qsats(t(i,k+1)) / pplay(i,k+1) + zdqs2= dqsats(t(i,k+1),zqs2) + ELSE + zqs1= qsatl(t(i,k)) / pplay(i,k) + zdqs1= dqsatl(t(i,k),zqs1) +c + zqs2= qsatl(t(i,k+1)) / pplay(i,k+1) + zdqs2= dqsatl(t(i,k+1),zqs2) + ENDIF + ENDIF + zdp1 = paprs(i,k) - paprs(i,k+1) + zdp2 = paprs(i,k+1) - paprs(i,k+2) + zgamdz = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD + . *( RD*(t(i,k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2) + . +RLVTT*(zqs1*zdp1+zqs2*zdp2)/(zdp1+zdp2) + . ) / (1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2) ) + zflo = t(i,k) + zgamdz - t(i,k+1) + zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2 + IF (zflo.GT.0.0) afaire(i) = .TRUE. +c erreur IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE. + ENDDO + ENDDO +c + imprim = MOD(ncpt,48).EQ.0 + DO 99999 n = 1, nb +c + DO k = 1, klev + DO i = 1, klon + IF (afaire(i)) THEN + zq1 = q(i,k) * (1.0-ratqs) + zq2 = q(i,k) * (1.0+ratqs) + w_q(i,k) = zq2 - frac(n)/2.0 * (zq2-zq1) + ENDIF + ENDDO + ENDDO +c + CALL conmanv (dtime, paprs, pplay, t, w_q, + e afaire, opt_cld(n), + s w_d_t, w_d_q, w_d_ql, w_rneb, + s w_rain, w_snow, w_ibas, w_itop,accompli,imprim) + DO k = 1, klev + DO i = 1, klon + IF (afaire(i) .AND. accompli(i)) THEN + d_t(i,k) = w_d_t(i,k) * frac(n) + d_q(i,k) = w_d_q(i,k) * frac(n) + d_ql(i,k) = w_d_ql(i,k) * frac(n) + IF (NINT(w_rneb(i,k)).EQ.1) rneb(i,k) = frac(n) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (afaire(i) .AND. accompli(i)) THEN + rain(i) = w_rain(i) * frac(n) + snow(i) = w_snow(i) * frac(n) + ibas(i) = MIN(ibas(i),w_ibas(i)) + itop(i) = MAX(itop(i),w_itop(i)) + ENDIF + ENDDO + DO i = 1, klon + IF(afaire(i) .AND. accompli(i)) afaire(i) = .FALSE. + ENDDO +c +99999 CONTINUE +c + ncpt = ncpt + 1 +c + RETURN + END + SUBROUTINE conmanv (dtime, paprs, pplay, t, q, + e afaire, opt_cld, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop,accompli,imprim) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: ajustement humide (convection proposee par Manabe). +c Pour une colonne verticale, il peut avoir plusieurs blocs +c necessitant l'ajustement. ibas est le bas du plus bas bloc +c et itop est le haut du plus haut bloc +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL dtime ! pas d'integration (s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL paprs(klon,klev+1) ! pression inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + INTEGER opt_cld ! comment traiter l'eau liquide + LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input) + LOGICAL imprim ! .T. pour imprimer quelques diagnostiques +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL d_ql(klon,klev) ! incrementation eau liquide + REAL rneb(klon,klev) ! nebulosite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER ibas(klon) ! niveau du bas + INTEGER itop(klon) ! niveau du haut + LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output) +c +c Quelques options: +c + LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait + PARAMETER (new_top=.FALSE.) + LOGICAL evap_prec ! evaporation de pluie au-dessous de convection + PARAMETER (evap_prec=.TRUE.) + REAL coef_eva + PARAMETER (coef_eva=1.0E-05) + REAL t_coup + PARAMETER (t_coup=234.0) + REAL seuil_vap + PARAMETER (seuil_vap=1.0E-10) + LOGICAL old_tau ! implique precip nulle, si vrai. + PARAMETER (old_tau=.FALSE.) + REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante + REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande + PARAMETER (dpmin=0.15, tomax=0.97) + REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible + PARAMETER (dpmax=0.30, tomin=0.05) + REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to + PARAMETER (deep_sig=0.50, deep_to=0.05) + LOGICAL exigent ! implique un calcul supplementaire pour Qs + PARAMETER (exigent=.FALSE.) +c + INTEGER kbase + PARAMETER (kbase=0) +c +c Variables locales: +c + INTEGER nexpo + INTEGER i, k, k1min, k1max, k2min, k2max, is + REAL zgamdz(klon,klev-1) + REAL zt(klon,klev), zq(klon,klev) + REAL zqs(klon,klev), zdqs(klon,klev) + REAL zqmqsdp(klon,klev) + REAL ztnew(klon,klev), zqnew(klon,klev) + REAL zcond(klon), zvapo(klon), zrapp(klon) + REAL zrfl(klon), zrfln, zqev, zqevt + REAL zsat(klon) ! sur-saturation + REAL zflo(klon) ! flotabilite + REAL za(klon), zb(klon), zc(klon) + INTEGER k1(klon), k2(klon) + REAL zdelta, zcor, zcvm5 + REAL delp(klon,klev) + LOGICAL possible(klon), todo(klon), etendre(klon) + LOGICAL aller(klon), todobis(klon) + REAL zalfa + INTEGER nbtodo, nbdone +c +c Fonctions thermodynamiques: +c +#include "YOETHF.h" +#include "FCTTRE.h" +c + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k) - paprs(i,k+1) + ENDDO + ENDDO +c +c Initialiser les sorties a zero +c + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + ibas(i) = klev + itop(i) = 1 + rain(i) = 0.0 + snow(i) = 0.0 + accompli(i) = .FALSE. + ENDDO +c +c Preparations +c + DO k = 1, klev + DO i = 1, klon + IF (afaire(i)) THEN + zt(i,k) = t(i,k) + zq(i,k) = q(i,k) +c +c Calculer Qs et L/Cp*dQs/dT +c + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k)) + zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (zt(i,k) .LT. t_coup) THEN + zqs(i,k)= qsats(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsats(zt(i,k),zqs(i,k)) + ELSE + zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k)) + ENDIF + ENDIF +c +c Calculer (q-qs)*dp + zqmqsdp(i,k) = (zq(i,k)-zqs(i,k)) * delp(i,k) + ENDIF + ENDDO + ENDDO +c +c-----zgama is the moist convective lapse rate (-dT/dz). +c-----zgamdz(*,k) est la difference minimale autorisee des temperatures +c-----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur +c-----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement +c + DO k = 1, klev-1 + DO i = 1, klon + IF (afaire(i)) THEN + zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD + . *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) ) + ENDIF + ENDDO + ENDDO +c +c On cherche la presence simultanee d'instabilite conditionnelle +c et de sur-saturation. Sinon, pas la penne de se fatiguer: +c + DO i = 1, klon + possible(i) = .FALSE. + ENDDO + DO k = 2, klev + DO i = 1, klon + IF (afaire(i)) THEN + zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) + zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1) + IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) possible(i) = .TRUE. + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (possible(i)) THEN + k1(i) = kbase + k2(i) = k1(i) + 1 + ENDIF + ENDDO +c + 810 CONTINUE ! chercher le bas de la colonne a ajuster +c + k2min = klev + DO i = 1, klon + todo(i) = .FALSE. + aller(i) = .TRUE. + IF (possible(i)) k2min = MIN(k2min,k2(i)) + ENDDO + IF (k2min.EQ.klev) GOTO 860 + DO k = k2min, klev-1 + DO i = 1, klon + IF (possible(i) .AND. k.GE.k2(i) .AND. aller(i)) THEN + zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1) + zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k+1) + IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN + k1(i) = k + k2(i) = k+1 + todo(i) = .TRUE. + aller(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (possible(i).AND.aller(i)) THEN + todo(i) = .FALSE. + k1(i) = klev + k2(i) = klev + ENDIF + ENDDO +c +CCC DO i = 1, klon +CCC IF (possible(i)) THEN +CCC 811 k2(i) = k2(i) + 1 +CCC IF (k2(i) .GT. klev) THEN +CCC todo(i) = .FALSE. +CCC GOTO 812 +CCC ENDIF +CCC k = k2(i) +CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) +CCC zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1) +CCC IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811 +CCC k1(i) = k2(i) - 1 +CCC todo(i) = .TRUE. +CCC ENDIF +CCC 812 CONTINUE +CCC ENDDO +c + 820 CONTINUE ! chercher le haut de la colonne +c + k2min = klev + DO i = 1, klon + aller(i) = .TRUE. + IF (todo(i)) k2min = MIN(k2min,k2(i)) + ENDDO + IF (k2min.LT.klev) THEN + DO k = k2min, klev + DO i = 1, klon + IF (todo(i) .AND. k.GT.k2(i) .AND. aller(i)) THEN + zsat(i) = zsat(i) + zqmqsdp(i,k) + zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) + IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN + aller(i) = .FALSE. + ELSE + k2(i) = k + ENDIF + ENDIF + ENDDO + ENDDO +c error is = 0 +c error DO i = 1, klon +c error IF(todo(i).AND.aller(i)) THEN +c error is = is + 1 +c error todo(i) = .FALSE. +c error k2(i) = klev +c error ENDIF +c error ENDDO +c error IF (is.GT.0) THEN +c error PRINT*, "Bizard. je pourrais continuer mais j arrete" +c error CALL abort +c error ENDIF + ENDIF +c +CCC DO i = 1, klon +CCC IF (todo(i)) THEN +CCC 821 CONTINUE +CCC IF (k2(i) .EQ. klev) GOTO 822 +CCC k = k2(i) + 1 +CCC zsat(i) = zsat(i) + zqmqsdp(i,k) +CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) +CCC IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822 +CCC k2(i) = k +CCC GOTO 821 +CCC ENDIF +CCC 822 CONTINUE +CCC ENDDO +c + 830 CONTINUE ! faire l'ajustement en sachant k1 et k2 +c + is = 0 + DO i = 1, klon + IF (todo(i)) THEN + IF (k2(i).LE.k1(i)) is = is + 1 + ENDIF + ENDDO + IF (is.GT.0) THEN + PRINT*, "Impossible: k1 trop grand ou k2 trop petit" + PRINT*, "is=", is + CALL abort + ENDIF +c + k1min = klev + k1max = 1 + k2max = 1 + DO i = 1, klon + IF (todo(i)) THEN + k1min = MIN(k1min,k1(i)) + k1max = MAX(k1max,k1(i)) + k2max = MAX(k2max,k2(i)) + ENDIF + ENDDO +c + DO i = 1, klon + IF (todo(i)) THEN + k = k1(i) + za(i) = 0. + zb(i) = ( RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i)) + . -RLVTT*(zqs(i,k)-zq(i,k)) )*delp(i,k) + zc(i) = delp(i,k) * RCPD*(1.+zdqs(i,k)) + ENDIF + ENDDO +c + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN + za(i) = za(i) + zgamdz(i,k-1) + zb(i) = zb(i)+(RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i)) + . -RLVTT*(zqs(i,k)-zq(i,k)) ) * delp(i,k) + zc(i) = zc(i) + delp(i,k)*RCPD*(1.+zdqs(i,k)) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (todo(i)) THEN + k = k1(i) + ztnew(i,k) = zb(i)/zc(i) + zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k)) + . *RCPD/RLVTT*zdqs(i,k) + ENDIF + ENDDO +c + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN + ztnew(i,k) = ztnew(i,k-1) + zgamdz(i,k-1) + zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k)) + . *RCPD/RLVTT*zdqs(i,k) + ENDIF + ENDDO + ENDDO +c +c Quantite de condensation produite pendant l'ajustement: +c + DO i = 1, klon + zcond(i) = 0.0 + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + rneb(i,k) = 1.0 + zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k)) *delp(i,k)/RG + ENDIF + ENDDO + ENDDO +c +c Si condensation negative, effort completement perdu: +c + DO i = 1, klon + IF (todo(i).AND.zcond(i).LE.0.) todo(i) = .FALSE. + ENDDO +c +c L'ajustement a ete accompli, meme les calculs accessoires +c ne sont pas encore faits: +c + DO i = 1, klon + IF (todo(i)) accompli(i) = .TRUE. + ENDDO +c +c===== +c Une fois que la condensation a lieu, on doit construire un +c "modele nuageux" pour partager la condensation entre l'eau +c liquide nuageuse et la precipitation (leur rapport toliq +c est calcule selon l'epaisseur nuageuse). Je suppose que +c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin, +c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation +c lineaire entre dpmin et dpmax). +c===== + DO i = 1, klon + IF (todo(i)) THEN + toliq(i) = tomax-((paprs(i,k1(i))-paprs(i,k2(i)+1)) + . /paprs(i,1)-dpmin) + . *(tomax-tomin)/(dpmax-dpmin) + toliq(i) = MAX(tomin,MIN(tomax,toliq(i))) + IF (pplay(i,k2(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to + IF (old_tau) toliq(i) = 1.0 + ENDIF + ENDDO +c===== +c On doit aussi determiner la distribution verticale de +c l'eau nuageuse. Plusieurs options sont proposees: +c +c (0) La condensation precipite integralement (toliq ne sera +c pas utilise). +c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle +c a la vapeur d'eau locale. +c (2) Elle est distribuee entre k1 et k2 avec une valeur constante. +c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau +c est effectivement diminuee pendant le processus d'ajustement. +c (4) Elle est en fonction (lineaire ou exponentielle) de la +c distance (epaisseur en pression) avec le niveau k1 (la couche +c k1 n'aura donc pas d'eau liquide). +c===== +c + IF (opt_cld.EQ.0) THEN +c + DO i = 1, klon + IF (todo(i)) zrfl(i) = zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.1) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + zqnew(i,k)*delp(i,k)/RG + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrapp(i) = toliq(i) * zcond(i) / zvapo(i) + zrapp(i) = MAX(0.,MIN(1.,zrapp(i))) + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + d_ql(i,k) = d_ql(i,k) + zrapp(i) * zqnew(i,k) + ENDIF + ENDDO + ENDDO +c + ELSE IF (opt_cld.EQ.2) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + delp(i,k)/RG + ENDDO + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.3) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + MAX(0.0,zq(i,k)-zqnew(i,k)) + . * delp(i,k)/RG + ENDDO + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i) .AND. + . zvapo(i).GT.0.0) + . d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * MAX(0.0,zq(i,k)-zqnew(i,k)) + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.4) THEN +c + nexpo = 3 +ccc nexpo = 1 ! distribution lineaire +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse + ENDDO ! (avec ponderation) + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) + . zvapo(i) = zvapo(i) + delp(i,k) / RG + . * (pplay(i,k1(i))-pplay(i,k))**nexpo + ENDDO + ENDDO + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) + . d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * (pplay(i,k1(i))-pplay(i,k))**nexpo + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDDO +c + ELSE ! valeur non-prevue pour opt_cld +c + PRINT*, "opt_cld est faux:", opt_cld + CALL abort +c + ENDIF ! fin de opt_cld +c +c L'eau precipitante peut etre evaporee: +c + zalfa = 0.05 + IF (evap_prec .AND. (k1max.GE.2)) THEN + DO k = k1max-1, 1, -1 + DO i = 1, klon + IF (todo(i) .AND. k.LT.k1(i) .AND. zrfl(i).GT.0.0) THEN + zqev = MAX (0.0, (zqs(i,k)-zq(i,k))*zalfa ) + zqevt = coef_eva * (1.0-zq(i,k)/zqs(i,k))*SQRT(zrfl(i)) + . * delp(i,k)/pplay(i,k)*zt(i,k)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * RG*dtime/delp(i,k) + zqev = MIN (zqev, zqevt) + zrfln = zrfl(i) - zqev*(delp(i,k))/RG/dtime + zq(i,k) = zq(i,k) - (zrfln-zrfl(i)) + . * (RG/(delp(i,k)))*dtime + zt(i,k) = zt(i,k) + (zrfln-zrfl(i)) + . * (RG/(delp(i,k)))*dtime + . * RLVTT/RCPD/(1.0+RVTMP2*zq(i,k)) + zrfl(i) = zrfln + ENDIF + ENDDO + ENDDO + ENDIF +c +c La temperature de la premiere couche determine la pluie ou la neige: +c + DO i = 1, klon + IF (todo(i)) THEN + IF (zt(i,1) .GT. RTT) THEN + rain(i) = rain(i) + zrfl(i) + ELSE + snow(i) = snow(i) + zrfl(i) + ENDIF + ENDIF + ENDDO +c +c Mise a jour de la temperature et de l'humidite +c + DO k = k1min, k2max + DO i = 1, klon + IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN + zt(i,k) = ztnew(i,k) + zq(i,k) = zqnew(i,k) + ENDIF + ENDDO + ENDDO +c +c Re-calculer certaines variables pour etendre et re-ajuster la colonne +c + IF (exigent) THEN + DO k = 1, klev + DO i = 1, klon + IF (todo(i)) THEN + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k)) + zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (zt(i,k) .LT. t_coup) THEN + zqs(i,k)= qsats(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsats(zt(i,k),zqs(i,k)) + ELSE + zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k) + zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k)) + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF +c + IF (exigent) THEN + DO k = 1, klev-1 + DO i = 1, klon + IF (todo(i)) THEN + zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD + . *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) + . ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1)) + . /(delp(i,k)+delp(i,k+1)) ) + ENDIF + ENDDO + ENDDO + ENDIF +c +c Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp +c + DO k = 1, klev + DO i = 1, klon + IF (todo(i)) THEN + zqmqsdp(i,k) = (zq(i,k)-zqs(i,k))*delp(i,k) + ENDIF + ENDDO + ENDDO +c +c Verifier si l'on peut etendre le bas de la colonne +c + DO i = 1, klon + etendre(i) = .FALSE. + ENDDO +c + k1max = 1 + DO i = 1, klon + IF (todo(i) .AND. k1(i).GT.(kbase+1)) THEN + k = k1(i) + zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) + zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1) +csc voici l'ancienne ligne: +csc IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN +csc sylvain: il faut RESPECTER les 2 criteres: + IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN + etendre(i) = .TRUE. + k1(i) = k1(i) - 1 + k1max = MAX(k1max,k1(i)) + aller(i) = .TRUE. + ENDIF + ENDIF + ENDDO +c + IF (k1max.GT.(kbase+1)) THEN + DO k = k1max, kbase+1, -1 + DO i = 1, klon + IF (etendre(i) .AND. k.LT.k1(i) .AND. aller(i)) THEN + zsat(i) = zsat(i) + zqmqsdp(i,k) + zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1) + IF (zsat(i).LE.0.0 .OR. zflo(i).LE.0.0) THEN + aller(i) = .FALSE. + ELSE + k1(i) = k + ENDIF + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (etendre(i).AND.aller(i)) THEN + k1(i) = 1 + ENDIF + ENDDO + ENDIF +c +CCC DO i = 1, klon +CCC IF (etendre(i)) THEN +CCC 840 k = k1(i) +CCC IF (k.GT.1) THEN +CCC zsat(i) = zsat(i) + zqmqsdp(i,k-1) +CCC zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k) +CCC IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN +CCC k1(i) = k - 1 +CCC GOTO 840 +CCC ENDIF +CCC ENDIF +CCC ENDIF +CCC ENDDO +c + DO i = 1, klon + todobis(i) = todo(i) + todo(i) = .FALSE. + ENDDO + is = 0 + DO i = 1, klon + IF (etendre(i)) THEN + todo(i) = .TRUE. + is = is + 1 + ENDIF + ENDDO + IF (is.GT.0) THEN + IF (new_top) THEN + GOTO 820 ! chercher de nouveau le sommet k2 + ELSE + GOTO 830 ! supposer que le sommet est celui deja trouve + ENDIF + ENDIF +c + DO i = 1, klon + possible(i) = .FALSE. + ENDDO + is = 0 + DO i = 1, klon + IF (todobis(i) .AND. k2(i).LT.klev) THEN + is = is + 1 + possible(i) = .TRUE. + ENDIF + ENDDO + IF (is.GT.0) GOTO 810 !on cherche en haut d'autres blocks +c a ajuster a partir du sommet de la colonne precedente +c + 860 CONTINUE ! Calculer les tendances et diagnostiques +ccc print*, "Apres 860" +c + DO k = 1, klev + DO i = 1, klon + IF (accompli(i)) THEN + d_t(i,k) = zt(i,k) - t(i,k) + zq(i,k) = MAX(zq(i,k),seuil_vap) + d_q(i,k) = zq(i,k) - q(i,k) + ENDIF + ENDDO + ENDDO +c + DO 888 i = 1, klon + IF (accompli(i)) THEN + DO k = 1, klev + IF (rneb(i,k).GT.0.0) THEN + ibas(i) = k + GOTO 807 + ENDIF + ENDDO + 807 CONTINUE + DO k = klev, 1, -1 + IF (rneb(i,k).GT.0.0) THEN + itop(i) = k + GOTO 808 + ENDIF + ENDDO + 808 CONTINUE + ENDIF + 888 CONTINUE +c + IF (imprim) THEN + nbtodo = 0 + nbdone = 0 + DO i = 1, klon + IF (afaire(i)) nbtodo = nbtodo + 1 + IF (accompli(i)) nbdone = nbdone + 1 + ENDDO + PRINT*, "nbTodo, nbDone=", nbtodo, nbdone + ENDIF +c + RETURN + END + SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q, + s d_t, d_q, d_ql, rneb, + s rain, snow, ibas, itop) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Schema de convection de type Kuo (1965). +c Cette version du code peut calculer le niveau de depart +c N.B. version vectorielle (le 6 oct. 1997) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL dtime ! intervalle du temps (s) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique + REAL conv_q(klon,klev) ! taux de convergence humidite (g/g/s) +c + REAL d_t(klon,klev) ! incrementation temperature + REAL d_q(klon,klev) ! incrementation humidite + REAL d_ql(klon,klev) ! incrementation eau liquide + REAL rneb(klon,klev) ! nebulosite + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + INTEGER itop(klon) ! niveau du sommet + INTEGER ibas(klon) ! niveau du bas +c + LOGICAL ldcum(klon) ! convection existe + LOGICAL todo(klon) +c +c Quelsques options: +c + LOGICAL calcfcl ! calculer le niveau de convection libre + PARAMETER (calcfcl=.TRUE.) + INTEGER ldepar ! niveau fixe de convection libre + PARAMETER (ldepar=4) + INTEGER opt_cld ! comment traiter l'eau liquide + PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4 + LOGICAL evap_prec ! evaporation de pluie au-dessous de convection + PARAMETER (evap_prec=.TRUE.) + REAL coef_eva + PARAMETER (coef_eva=1.0E-05) + LOGICAL new_deh ! nouvelle facon de calculer dH + PARAMETER (new_deh=.FALSE.) + REAL t_coup + PARAMETER (t_coup=234.0) + LOGICAL old_tau ! implique precipitation nulle + PARAMETER (old_tau=.FALSE.) + REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante + REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande + PARAMETER (dpmin=0.15, tomax=0.97) + REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible + PARAMETER (dpmax=0.30, tomin=0.05) + REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to + PARAMETER (deep_sig=0.50, deep_to=0.05) +c +c Variables locales: +c + INTEGER nexpo + LOGICAL nuage(klon) + INTEGER i, k, kbmin, kbmax, khmax + REAL ztotal(klon,klev), zdeh(klon,klev) + REAL zgz(klon,klev) + REAL zqs(klon,klev) + REAL zdqs(klon,klev) + REAL ztemp(klon,klev) + REAL zpres(klon,klev) + REAL zconv(klon) ! convergence d'humidite + REAL zvirt(klon) ! convergence virtuelle d'humidite + REAL zfrac(klon) ! fraction convective + INTEGER kb(klon), kh(klon) +c + REAL zcond(klon), zvapo(klon), zrapp(klon) + REAL zrfl(klon), zrfln, zqev, zqevt + REAL zdelta, zcvm5, zcor + REAL zvar +c + LOGICAL appel1er + SAVE appel1er +c$OMP THREADPRIVATE(appel1er) +c +c Fonctions thermodynamiques +c +#include "YOETHF.h" +#include "FCTTRE.h" +c + DATA appel1er /.TRUE./ +c + IF (appel1er) THEN + PRINT*, 'conkuo, calcfcl:', calcfcl + IF (.NOT.calcfcl) PRINT*, 'conkuo, ldepar:', ldepar + PRINT*, 'conkuo, opt_cld:', opt_cld + PRINT*, 'conkuo, evap_prec:', evap_prec + PRINT*, 'conkuo, new_deh:', new_deh + appel1er = .FALSE. + ENDIF +c +c Initialiser les sorties a zero +c + DO k = 1, klev + DO i = 1, klon + d_q(i,k) = 0.0 + d_t(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + ibas(i) = 0 + itop(i) = 0 + ENDDO +c +c Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT +c + DO k = 1, klev + DO i = 1, klon + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-t(i,k))) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k)) + zqs(i,k)=R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(t(i,k),zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (t(i,k).LT.t_coup) THEN + zqs(i,k) = qsats(t(i,k))/pplay(i,k) + zdqs(i,k) = dqsats(t(i,k),zqs(i,k)) + ELSE + zqs(i,k) = qsatl(t(i,k))/pplay(i,k) + zdqs(i,k) = dqsatl(t(i,k),zqs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c Calculer gz (energie potentielle) +c + DO i = 1, klon + zgz(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) + ENDDO + DO k = 2, klev + DO i = 1, klon + zgz(i,k) = zgz(i,k-1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) + ENDDO + ENDDO +c +c Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs) +c + DO k = 1, klev + DO i = 1, klon + ztotal(i,k) = RCPD*t(i,k) + RLVTT*zqs(i,k) + zgz(i,k) + ENDDO + ENDDO +c +c Determiner le niveau de depart et calculer la difference de +c l'energie statique humide saturee (ztotal) entre la couche +c de depart et chaque couche au-dessus. +c + IF (calcfcl) THEN + DO k = 1, klev + DO i = 1, klon + zpres(i,k) = pplay(i,k) + ztemp(i,k) = t(i,k) + ENDDO + ENDDO + CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb) + DO i = 1, klon + IF (ldcum(i)) THEN + k = kb(i) + IF (new_deh) THEN + zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k) + ELSE + zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + zdeh(i,k) = zdeh(i,k) * 0.5 + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (ldcum(i) .AND. k.GE.(kb(i)+1)) THEN + IF (new_deh) THEN + zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k)) + ELSE + zdeh(i,k) = zdeh(i,k-1) + . + RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO + ELSE + DO i = 1, klon + k = ldepar + kb(i) = ldepar + ldcum(i) = .TRUE. + IF (new_deh) THEN + zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k) + ELSE + zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + zdeh(i,k) = zdeh(i,k) * 0.5 + ENDDO + DO k = ldepar+1, klev + DO i = 1, klon + IF (new_deh) THEN + zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k)) + ELSE + zdeh(i,k) = zdeh(i,k-1) + . + RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDIF + ENDDO + ENDDO + ENDIF +c +c-----Chercher le sommet du nuage +c-----Calculer la convergence de l'humidite (en kg/m**2 a un facteur +c-----psolpa/RG pres) du bas jusqu'au sommet du nuage. +c-----Calculer la convergence virtuelle pour que toute la maille +c-----deviennt nuageuse (du bas jusqu'au sommet du nuage) +c + DO i = 1, klon + nuage(i) = .TRUE. + zconv(i) = 0.0 + zvirt(i) = 0.0 + kh(i) = -999 + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (k.GE.kb(i) .AND. ldcum(i)) THEN + nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0 + IF (nuage(i)) THEN + kh(i) = k + zconv(i)=zconv(i)+conv_q(i,k)*dtime + . *(paprs(i,k)-paprs(i,k+1)) + zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k)) + . *(paprs(i,k)-paprs(i,k+1)) + ENDIF + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + todo(i) = ldcum(i) .AND. kh(i).GT.kb(i) .AND. zconv(i).GT.0.0 + ENDDO +c + kbmin = klev + kbmax = 0 + khmax = 0 + DO i = 1, klon + IF (todo(i)) THEN + kbmin = MIN(kbmin,kb(i)) + kbmax = MAX(kbmax,kb(i)) + khmax = MAX(khmax,kh(i)) + ENDIF + ENDDO +c +c-----Calculer la surface couverte par le nuage +c + DO i = 1, klon + IF (todo(i)) THEN + zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i), 1.0)) + ENDIF + ENDDO +c +c-----Calculs essentiels: +c + DO i = 1, klon + IF (todo(i)) THEN + zcond(i) = 0.0 + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvar = zdeh(i,k)/(1.+zdqs(i,k)) + d_t(i,k) = zvar * zfrac(i) / RCPD + d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i) + . - conv_q(i,k)*dtime + zcond(i) = zcond(i) - d_q(i,k) *(paprs(i,k)-paprs(i,k+1))/RG + rneb(i,k) = zfrac(i) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (todo(i) .AND. zcond(i).LT.0.0) THEN + PRINT*, 'WARNING: cond. negative (Kuo) ', + . i,kb(i),kh(i), zcond(i) + zcond(i) = 0.0 + DO k = kb(i), kh(i) + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + todo(i) = .FALSE. ! effort totalement perdu + ENDIF + ENDDO +c +c===== +c Une fois que la condensation a lieu, on doit construire un +c "modele nuageux" pour partager la condensation entre l'eau +c liquide nuageuse et la precipitation (leur rapport toliq +c est calcule selon l'epaisseur nuageuse). Je suppose que +c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin, +c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation +c lineaire entre dpmin et dpmax). +c===== + DO i = 1, klon + IF (todo(i)) THEN + toliq(i) = tomax-((paprs(i,kb(i))-paprs(i,kh(i)+1)) + . /paprs(i,1)-dpmin) + . *(tomax-tomin)/(dpmax-dpmin) + toliq(i) = MAX(tomin,MIN(tomax,toliq(i))) + IF (pplay(i,kh(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to + IF (old_tau) toliq(i) = 1.0 + ENDIF + ENDDO +c===== +c On doit aussi determiner la distribution verticale de +c l'eau nuageuse. Plusieurs options sont proposees: +c +c (0) La condensation precipite integralement (toliq ne sera +c pas utilise). +c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle +c a la vapeur d'eau locale. +c (2) Elle est distribuee entre k1 et k2 avec une valeur constante. +c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau +c est effectivement diminuee pendant le processus d'ajustement. +c (4) Elle est en fonction (lineaire ou exponentielle) de la +c distance (epaisseur en pression) avec le niveau k1 (la couche +c k1 n'aura donc pas d'eau liquide). +c===== +c + IF (opt_cld.EQ.0) THEN +c + DO i = 1, klon + IF (todo(i)) zrfl(i) = zcond(i) / dtime + ENDDO +c + ELSE IF (opt_cld.EQ.1) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k)) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrapp(i) = toliq(i) * zcond(i) / zvapo(i) + zrapp(i) = MAX(0.,MIN(1.,zrapp(i))) + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + d_ql(i,k) = zrapp(i) * (q(i,k)+d_q(i,k)) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE IF (opt_cld.EQ.2) THEN +c + DO i = 1, klon + IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/RG + ENDIF + ENDDO + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + d_ql(i,k) = toliq(i) * zcond(i) / zvapo(i) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE IF (opt_cld.EQ.3) THEN +c + DO i = 1, klon + IF (todo(i)) THEN + zvapo(i) = 0.0 ! quantite de l'eau strictement condensee + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + MAX(0.0,-d_q(i,k)) + . * (paprs(i,k)-paprs(i,k+1))/RG + ENDIF + ENDDO + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i) .AND. + . zvapo(i).GT.0.0) THEN + d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * MAX(0.0,-d_q(i,k)) + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE IF (opt_cld.EQ.4) THEN +c + nexpo = 3 +ccc nexpo = 1 ! distribution lineaire +c + DO i = 1, klon + IF (todo(i)) THEN + zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation) + ENDIF + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN + zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1)) / RG + . * (pplay(i,kb(i))-pplay(i,k))**nexpo + ENDIF + ENDDO + ENDDO + DO k = kbmin, khmax + DO i = 1, klon + IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN + d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i) + . * (pplay(i,kb(i))-pplay(i,k))**nexpo + ENDIF + ENDDO + ENDDO + DO i = 1, klon + IF (todo(i)) THEN + zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime + ENDIF + ENDDO +c + ELSE ! valeur non-prevue pour opt_cld +c + PRINT*, "opt_cld est faux:", opt_cld + CALL abort +c + ENDIF ! fin de opt_cld +c +c L'eau precipitante peut etre re-evaporee: +c + IF (evap_prec .AND. kbmax.GE.2) THEN + DO k = kbmax, 1, -1 + DO i = 1, klon + IF (todo(i) .AND. k.LE.(kb(i)-1) .AND. zrfl(i).GT.0.0) THEN + zqev = MAX (0.0, (zqs(i,k)-q(i,k))*zfrac(i) ) + zqevt = coef_eva * (1.0-q(i,k)/zqs(i,k))*SQRT(zrfl(i)) + . * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*t(i,k)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) + . * RG*dtime/(paprs(i,k)-paprs(i,k+1)) + zqev = MIN (zqev, zqevt) + zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) + . /RG/dtime + d_q(i,k) = - (zrfln-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + d_t(i,k) = (zrfln-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + . * RLVTT/RCPD + zrfl(i) = zrfln + ENDIF + ENDDO + ENDDO + ENDIF +c +c La temperature de la premiere couche determine la pluie ou la neige: +c + DO i = 1, klon + IF (todo(i)) THEN + IF (t(i,1) .GT. RTT) THEN + rain(i) = rain(i) + zrfl(i) + ELSE + snow(i) = snow(i) + zrfl(i) + ENDIF + ENDIF + ENDDO +c + RETURN + END + SUBROUTINE kuofcl(pt, pq, pg, pp, LDCUM, kcbot) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927 +c adaptation du code de Tiedtke du ECMWF +c Objet: calculer le niveau de convection libre +c (FCL: Free Convection Level) +c====================================================================== +c Arguments: +c pt---input-R- temperature (K) +c pq---input-R- vapeur d'eau (kg/kg) +c pg---input-R- geopotentiel (g*z ou z est en metre) +c pp---input-R- pression (Pa) +c +c LDCUM---output-L- Y-t-il la convection +c kcbot---output-I- Niveau du bas de la convection +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C + REAL pt(klon,klev), pq(klon,klev), pg(klon,klev), pp(klon,klev) + INTEGER kcbot(klon) + LOGICAL LDCUM(klon) +C + REAL ztu(klon,klev), zqu(klon,klev), zlu(klon,klev) + REAL zqold(klon), zbuo + INTEGER is, i, k +c +c klab=1: on est sous le nuage convectif +c klab=2: le bas du nuage convectif +c klab=0: autres couches + INTEGER klab(klon,klev) +c +c quand lflag=.true., on est sous le nuage, il faut donc appliquer +c le processus d'elevation. + LOGICAL lflag(klon) +C + DO k = 1, klev + DO i = 1, klon + ztu(i,k) = pt(i,k) + zqu(i,k) = pq(i,k) + zlu(i,k) = 0.0 + klab(i,k) = 0 + ENDDO + ENDDO +C---------------------------------------------------------------------- + DO i = 1, klon + klab(i,1)=1 + kcbot(i)=2 + LDCUM(i)=.FALSE. + ENDDO +C + DO 290 k = 2, klev-1 +c + is=0 + DO i = 1, klon + if (klab(i,k-1).EQ.1) is = is + 1 + lflag(i) = .FALSE. + if (klab(i,k-1).EQ.1) lflag(i) = .TRUE. + ENDDO + IF (is.EQ.0) GOTO 290 +c +c on eleve le parcel d'air selon l'adiabatique sec +c + DO i = 1, klon + IF (lflag(i)) THEN + zqu(i,k) = zqu(i,k-1) + ztu(i,k) = ztu(i,k-1) + (pg(i,k-1)-pg(i,k))/RCPD + zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))- + . pt(i,k)*(1.+RETV*pq(i,k))+0.5 + IF (zbuo.GT.0.) klab(i,k)=1 + zqold(i) = zqu(i,k) + ENDIF + ENDDO +c +c on calcule la condensation eventuelle +c + CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1) +c +c s'il y a la condensation et la "buoyancy" force est positive +c c'est bien le bas de la tour de convection +c + DO i=1, klon + IF(lflag(i).AND.zqu(i,k).NE.zqold(i)) THEN + klab(i,k) = 2 + zlu(i,k) = zlu(i,k)+zqold(i)-zqu(i,k) + zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))- + . pt(i,k)*(1.+RETV*pq(i,k))+0.5 + IF (zbuo.GT.0.) THEN + kcbot(i) = k + LDCUM(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C + 290 CONTINUE +C + RETURN + END + SUBROUTINE adjtq(pp, pt, pq, LDFLAG, KCALL) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927 +c adaptation du code de Tiedtke du ECMWF +c Objet: ajustement entre T et Q +c====================================================================== +c Arguments: +c pp---input-R- pression (Pa) +c pt---input/output-R- temperature (K) +c pq---input/output-R- vapeur d'eau (kg/kg) +c====================================================================== +C TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT +C +C NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS +C KCALL=0 ENV. T AND QS IN*CUINI* +C KCALL=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC) +C KCALL=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF) +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +C + REAL pt(klon), pq(klon), pp(klon) + LOGICAL ldflag(klon) + INTEGER KCALL +c + REAL t_coup + PARAMETER (t_coup=234.0) +c + REAL zcond(klon), zcond1 + REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat + INTEGER is, i +#include "YOETHF.h" +#include "FCTTRE.h" +c + DO i = 1, klon + zcond(i) = 0.0 + ENDDO +C + DO 210 i=1, klon + IF (LDFLAG(i)) THEN + zdelta=MAX(0.,SIGN(1.,RTT-pt(i))) + zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT + zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i)) + IF (thermcep) THEN + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i)) + zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i) + zqsat=MIN(0.5,zqsat) + zcor=1./(1.-RETV *zqsat) + zqsat=zqsat*zcor + zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor) + ELSE + IF (pt(i).LT.t_coup) THEN + zqsat = qsats(pt(i))/pp(i) + zdqsat = dqsats(pt(i),zqsat) + ELSE + zqsat = qsatl(pt(i))/pp(i) + zdqsat = dqsatl(pt(i),zqsat) + ENDIF + ENDIF + zcond(i)=(pq(i)-zqsat) / (1. + zdqsat) + IF(KCALL.EQ.1) zcond(i)=MAX(zcond(i),0.) + IF(KCALL.EQ.2) zcond(i)=MIN(zcond(i),0.) + pt(i)=pt(i)+zldcp*zcond(i) + pq(i)=pq(i)-zcond(i) + ENDIF + 210 CONTINUE +C + is = 0 + DO i=1, klon + if (zcond(i).NE.0.) is = is + 1 + ENDDO + IF(is.EQ.0) GOTO 230 +C + DO 220 i = 1, klon + IF(LDFLAG(i).AND.zcond(i).NE.0.) THEN + zdelta=MAX(0.,SIGN(1.,RTT-pt(i))) + zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT + zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i)) + IF (thermcep) THEN + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i)) + zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i) + zqsat=MIN(0.5,zqsat) + zcor=1./(1.-RETV *zqsat) + zqsat=zqsat*zcor + zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor) + ELSE + IF (pt(i).LT.t_coup) THEN + zqsat = qsats(pt(i))/pp(i) + zdqsat = dqsats(pt(i),zqsat) + ELSE + zqsat = qsatl(pt(i))/pp(i) + zdqsat = dqsatl(pt(i),zqsat) + ENDIF + ENDIF + zcond1=(pq(i)-zqsat) / (1.+zdqsat) + pt(i)=pt(i)+zldcp*zcond1 + pq(i)=pq(i)-zcond1 + END IF + 220 CONTINUE +C + 230 CONTINUE + RETURN + END + SUBROUTINE fiajh(dtime, paprs, pplay, t, q, + . d_t, d_q, d_ql, rneb, + . rain, snow, ibas, itop) + USE dimphy + IMPLICIT NONE +c +c Ajustement humide (Schema de convection de Manabe) +C. +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + REAL dtime ! intervalle du temps (s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) +c + REAL d_t(klon,klev) ! incrementation pour la temperature + REAL d_q(klon,klev) ! incrementation pour vapeur d'eau + REAL d_ql(klon,klev) ! incrementation pour l'eau liquide + REAL rneb(klon,klev) ! fraction nuageuse +c + REAL rain(klon) ! variable non utilisee + REAL snow(klon) ! variable non utilisee + INTEGER ibas(klon) ! variable non utilisee + INTEGER itop(klon) ! variable non utilisee + + REAL t_coup + PARAMETER (t_coup=234.0) + REAL seuil_vap + PARAMETER (seuil_vap=1.0E-10) +c +c Variables locales: +c + INTEGER i, k + INTEGER k1, k1p, k2, k2p + LOGICAL itest(klon) + REAL delta_q(klon, klev) + REAL cp_new_t(klev) + REAL cp_delta_t(klev) + REAL new_qb(klev) + REAL v_cptj(klev), v_cptjk1, v_ssig + REAL v_cptt(klon,klev), v_p, v_t + REAL v_qs(klon,klev), v_qsd(klon,klev) + REAL zq1(klon), zq2(klon) + REAL gamcpdz(klon,2:klev) + REAL zdp, zdpm +c + REAL zsat ! sur-saturation + REAL zflo ! flotabilite +c + REAL local_q(klon,klev),local_t(klon,klev) +c + REAL zdelta, zcor, zcvm5 +C +#include "YOETHF.h" +#include "FCTTRE.h" +C + DO k = 1, klev + DO i = 1, klon + local_q(i,k) = q(i,k) + local_t(i,k) = t(i,k) + rneb(i,k) = 0.0 + d_ql(i,k) = 0.0 + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + ibas(i) = 0 + itop(i) = 0 + ENDDO +c +c Calculer v_qs et v_qsd: +c + DO k = 1, klev + DO i = 1, klon + v_cptt(i,k) = RCPD * local_t(i,k) + v_t = local_t(i,k) + v_p = pplay(i,k) +c + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-v_t)) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k)) + v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p + v_qs(i,k)=MIN(0.5,v_qs(i,k)) + zcor=1./(1.-RETV*v_qs(i,k)) + v_qs(i,k)=v_qs(i,k)*zcor + v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor) + ELSE + IF (v_t.LT.t_coup) THEN + v_qs(i,k) = qsats(v_t) / v_p + v_qsd(i,k) = dqsats(v_t,v_qs(i,k)) + ELSE + v_qs(i,k) = qsatl(v_t) / v_p + v_qsd(i,k) = dqsatl(v_t,v_qs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c Calculer Gamma * Cp * dz: (gamm est le gradient critique) +c + DO k = 2, klev + DO i = 1, klon + zdp = paprs(i,k)-paprs(i,k+1) + zdpm = paprs(i,k-1)-paprs(i,k) + gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * + . (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp) + . +RLVTT /(zdpm+zdp) * + . (v_qs(i,k-1)*zdpm + v_qs(i,k)*zdp) + . )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) ) + . / (1.0+(v_qsd(i,k-1)*zdpm+ + . v_qsd(i,k)*zdp)/(zdpm+zdp) ) + ENDDO + ENDDO +C +C------------------------------------ modification des profils instables + DO 9999 i = 1, klon + itest(i) = .FALSE. +C + k1 = 0 + k2 = 1 +C + 810 CONTINUE ! chercher k1, le bas de la colonne + k2 = k2 + 1 + IF (k2 .GT. klev) GOTO 9999 + zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2) + zsat=(local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2)) + . +(local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1)) + IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810 + k1 = k2 - 1 + itest(i) = .TRUE. +C + 820 CONTINUE ! chercher k2, le haut de la colonne + IF (k2 .EQ. klev) GOTO 821 + k2p = k2 + 1 + zsat=zsat +(paprs(i,k2p)-paprs(i,k2p+1)) + . *(local_q(i,k2p)-v_qs(i,k2p)) + zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p) + IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821 + k2 = k2p + GOTO 820 + 821 CONTINUE +C +C------------------------------------------------------ ajustement local + 830 CONTINUE ! ajustement proprement dit + v_cptj(k1) = 0.0 + zdp = paprs(i,k1)-paprs(i,k1+1) + v_cptjk1 = ( (1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1)) + . + RLVTT*(local_q(i,k1)-v_qs(i,k1)) ) * zdp + v_ssig = zdp * (1.0+v_qsd(i,k1)) +C + k1p = k1 + 1 + DO k = k1p, k2 + zdp = paprs(i,k)-paprs(i,k+1) + v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k) + v_cptjk1 = v_cptjk1 + zdp + . * ( (1.0+v_qsd(i, k))*(v_cptt(i,k)+v_cptj(k)) + . + RLVTT*(local_q(i,k)-v_qs(i,k)) ) + v_ssig = v_ssig + zdp *(1.0+v_qsd(i,k)) + ENDDO +C + DO k = k1, k2 + cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k) + cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k) + new_qb(k) = v_qs(i,k) + v_qsd(i,k)*cp_delta_t(k)/RLVTT + local_q(i,k) = new_qb(k) + local_t(i,k) = cp_new_t(k) / RCPD + ENDDO +C +C--------------------------------------------------- sondage vers le bas +C -- on redefinit les variables prognostiques dans +C -- la colonne qui vient d'etre ajustee +C + DO k = k1, k2 + v_cptt(i,k) = RCPD * local_t(i,k) + v_t = local_t(i,k) + v_p = pplay(i,k) +C + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-v_t)) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k)) + v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p + v_qs(i,k)=MIN(0.5,v_qs(i,k)) + zcor=1./(1.-RETV*v_qs(i,k)) + v_qs(i,k)=v_qs(i,k)*zcor + v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor) + ELSE + IF (v_t.LT.t_coup) THEN + v_qs(i,k) = qsats(v_t) / v_p + v_qsd(i,k) = dqsats(v_t,v_qs(i,k)) + ELSE + v_qs(i,k) = qsatl(v_t) / v_p + v_qsd(i,k) = dqsatl(v_t,v_qs(i,k)) + ENDIF + ENDIF + ENDDO + DO k = 2, klev + zdpm = paprs(i,k-1) - paprs(i,k) + zdp = paprs(i,k) - paprs(i,k+1) + gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * + . (v_cptt(i,k-1)*zdpm+v_cptt(i,k)*zdp) + . +RLVTT /(zdpm+zdp) * + . (v_qs(i,k-1)*zdpm+v_qs(i,k)*zdp) + . )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) ) + . / (1.0+(v_qsd(i,k-1)*zdpm+v_qsd(i,k)*zdp) + . /(zdpm+zdp) ) + ENDDO +C +C Verifier si l'on peut etendre la colonne vers le bas +C + IF (k1 .EQ. 1) GOTO 841 ! extension echouee + zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1) + zsat=(local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1)) + . + (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1)) + IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! extension echouee +C + 840 CONTINUE + k1 = k1 - 1 + IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995) + zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1)) + . *(paprs(i,k1-1)-paprs(i,k1)) + zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1) + IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN + GOTO 840 + ELSE + GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995) + ENDIF + 841 CONTINUE +C + GOTO 810 ! chercher d'autres blocks en haut +C + 9999 CONTINUE ! boucle sur tous les points +C----------------------------------------------------------------------- +c +c Determiner la fraction nuageuse (hypothese: la nebulosite a lieu +c a l'endroit ou la vapeur d'eau est diminuee par l'ajustement): +c + DO k = 1, klev + DO i = 1, klon + IF (itest(i)) THEN + delta_q(i,k) = local_q(i,k) - q(i,k) + IF (delta_q(i,k).LT.0.) rneb(i,k) = 1.0 + ENDIF + ENDDO + ENDDO +c +c Distribuer l'eau condensee en eau liquide nuageuse (hypothese: +c l'eau liquide est distribuee aux endroits ou la vapeur d'eau +c diminue et d'une maniere proportionnelle a cet diminution): +c + DO i = 1, klon + IF (itest(i)) THEN + zq1(i) = 0.0 + zq2(i) = 0.0 + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (itest(i)) THEN + zdp = paprs(i,k)-paprs(i,k+1) + zq1(i) = zq1(i) - delta_q(i,k) * zdp + zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp + ENDIF + ENDDO + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (itest(i)) THEN + IF (zq2(i).NE.0.0) + . d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i) + ENDIF + ENDDO + ENDDO +C + DO k = 1, klev + DO i = 1, klon + local_q(i, k) = MAX(local_q(i, k), seuil_vap) + ENDDO + ENDDO +C + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = local_t(i,k) - t(i,k) + d_q(i,k) = local_q(i,k) - q(i,k) + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE fiajc(dtime,paprs,pplay, + . t, q,conv_q, + . d_t, d_q, d_ql,rneb, + . rain, snow, ibas, itop) + USE dimphy + IMPLICIT NONE +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Options: +c + INTEGER plb ! niveau de depart pour la convection + PARAMETER (plb=4) +c +c Mystere: cette option n'est pas innocente pour les resultats ! +c Qui peut resoudre ce mystere ? (Z.X.Li mars 1995) + LOGICAL vector ! calcul vectorise + PARAMETER (vector=.FALSE.) +c + REAL t_coup + PARAMETER (t_coup=234.0) +c +c Arguments: +c + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL t(klon,klev) ! temperature (K) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL dtime ! intervalle du temps (s) + REAL conv_q(klon,klev) ! taux de convergence de l'humidite + REAL rneb(klon,klev) ! fraction nuageuse + REAL d_q(klon,klev) ! incrementaion pour la vapeur d'eau + REAL d_ql(klon,klev) ! incrementation pour l'eau liquide + REAL d_t(klon,klev) ! incrementation pour la temperature + REAL rain(klon) ! variable non-utilisee + REAL snow(klon) ! variable non-utilisee + INTEGER itop(klon) ! variable non-utilisee + INTEGER ibas(klon) ! variable non-utilisee +c + INTEGER kh(klon), i, k + LOGICAL nuage(klon), test(klon,klev) + REAL zconv(klon), zdeh(klon,klev), zvirt(klon) + REAL zdqs(klon,klev), zqs(klon,klev) + REAL ztt, zvar, zfrac(klon) + REAL zq1(klon), zq2(klon) + REAL zdelta, zcor, zcvm5 +C +#include "YOETHF.h" +#include "FCTTRE.h" +c +c Initialiser les sorties: +c + DO k = 1, klev + DO i = 1, klon + rneb(i,k) = 0.0 + d_ql(i,k) = 0.0 + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + ENDDO + ENDDO + DO i = 1, klon + itop(i) = 0 + ibas(i) = 0 + rain(i) = 0.0 + snow(i) = 0.0 + ENDDO +c +c Calculer Qs et L/Cp * dQs/dT: +c + DO k = 1, klev + DO i = 1, klon + ztt = t(i,k) + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-ztt)) + zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k)) + zqs(i,k)= R2ES*FOEEW(ztt,zdelta)/pplay(i,k) + zqs(i,k)=MIN(0.5,zqs(i,k)) + zcor=1./(1.-RETV*zqs(i,k)) + zqs(i,k)=zqs(i,k)*zcor + zdqs(i,k) =FOEDE(ztt,zdelta,zcvm5,zqs(i,k),zcor) + ELSE + IF (ztt .LT. t_coup) THEN + zqs(i,k) = qsats(ztt) / pplay(i,k) + zdqs(i,k) = dqsats(ztt,zqs(i,k)) + ELSE + zqs(i,k) = qsatl(ztt) / pplay(i,k) + zdqs(i,k) = dqsatl(ztt,zqs(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c Determiner la difference de l'energie totale saturee: +c + DO i = 1, klon + k = plb + zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + zdeh(i,k) = zdeh(i,k) * 0.5 ! on prend la moitie + ENDDO + DO k = plb+1, klev + DO i = 1, klon + zdeh(i,k) = zdeh(i,k-1) + . + RCPD * (t(i,k-1)-t(i,k)) + . - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k) + . *(pplay(i,k-1)-pplay(i,k)) + . + RLVTT*(zqs(i,k-1)-zqs(i,k)) + ENDDO + ENDDO +c +c Determiner le sommet du nuage selon l'instabilite +c Calculer les convergences d'humidite (reelle et virtuelle) +c + DO i = 1, klon + nuage(i) = .TRUE. + zconv(i) = 0.0 + zvirt(i) = 0.0 + kh(i) = -999 + ENDDO + DO k = plb, klev + DO i = 1, klon + nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0 + IF (nuage(i)) THEN + kh(i) = k + zconv(i) = zconv(i)+conv_q(i,k)*dtime + . *(paprs(i,k)-paprs(i,k+1)) + zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k)) + . *(paprs(i,k)-paprs(i,k+1)) + ENDIF + ENDDO + ENDDO +c + IF (vector) THEN +c +c + DO k = plb, klev + DO i = 1, klon + IF (k.LE.kh(i) .AND. kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN + test(i,k) = .TRUE. + zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0)) + ELSE + test(i,k) = .FALSE. + ENDIF + ENDDO + ENDDO +c + DO k = plb, klev + DO i = 1, klon + IF (test(i,k)) THEN + zvar = zdeh(i,k)/(1.0+zdqs(i,k)) + d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i) + . - conv_q(i,k)*dtime + d_t(i,k) = zvar * zfrac(i) / RCPD + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + zq1(i) = 0.0 + zq2(i) = 0.0 + ENDDO + DO k = plb, klev + DO i = 1, klon + IF (test(i,k)) THEN + IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i) + zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1)) + zq2(i) = zq2(i) - MIN(0.0, d_q(i,k)) + . * (paprs(i,k)-paprs(i,k+1)) + ENDIF + ENDDO + ENDDO +c + DO k = plb, klev + DO i = 1, klon + IF (test(i,k)) THEN + IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i) + ENDIF + ENDDO + ENDDO +c + ELSE ! (.NOT. vector) +c + DO 999 i = 1, klon + IF (kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN +ccc IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite +ccc IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante + zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0)) + DO k = plb, kh(i) + zvar = zdeh(i,k)/(1.0+zdqs(i,k)) + d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i) + . - conv_q(i,k)*dtime + d_t(i,k) = zvar * zfrac(i) / RCPD + ENDDO +c + zq1(i) = 0.0 + zq2(i) = 0.0 + DO k = plb, kh(i) + IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i) + zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1)) + zq2(i) = zq2(i) - MIN(0.0, d_q(i,k)) + . * (paprs(i,k)-paprs(i,k+1)) + ENDDO + DO k = plb, kh(i) + IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i) + ENDDO + ENDIF + 999 CONTINUE +c + ENDIF ! fin de teste sur vector +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect1.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect1.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect1.F (revision 1634) @@ -0,0 +1,649 @@ +! +! $Header$ +! + subroutine convect1(len,nd,ndp1,noff,minorig, + & t,q,qs,u,v, + & p,ph,iflag,ft, + & fq,fu,fv,precip,cbmf,delt,Ma) +C.............................START PROLOGUE............................ +C +C SCCS IDENTIFICATION: @(#)convect1.f 1.1 04/21/00 +C 19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v +C +C CONFIGURATION IDENTIFICATION: None +C +C MODULE NAME: convect1 +C +C DESCRIPTION: +C +C convect1 The Emanuel Cumulus Convection Scheme +C +C CONTRACT NUMBER AND TITLE: None +C +C REFERENCES: Programmers K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL) +C +C CLASSIFICATION: Unclassified +C +C RESTRICTIONS: None +C +C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90 +C +C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress" +C Fortran 90: -O vector3,scalar3,task1,aggress,overindex -ei -r 2 +C +C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a +C +C USAGE: call convect1(len,nd,noff,minorig, +C & t,q,qs,u,v, +C & p,ph,iflag,ft, +C & fq,fu,fv,precip,cbmf,delt) +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C len Integer Input first (i) dimension +C nd Integer Input vertical (k) dimension +C ndp1 Integer Input nd + 1 +C noff Integer Input integer limit for convection (nd-noff) +C minorig Integer Input First level of convection +C t Real Input temperature +C q Real Input specific hum +C qs Real Input sat specific hum +C u Real Input u-wind +C v Real Input v-wind +C p Real Input full level pressure +C ph Real Input half level pressure +C iflag Integer Output iflag on latitude strip +C ft Real Output temp tend +C fq Real Output spec hum tend +C fu Real Output u-wind tend +C fv Real Output v-wind tend +C cbmf Real In/Out cumulus mass flux +C delt Real Input time step +C iflag Integer Output integer flag for Emanuel conditions +C +C COMMON BLOCKS: +C Block Name Type Usage Notes +C -------- -------- ---- ------ ------------------------ +C +C FILES: None +C +C DATA BASES: None +C +C NON-FILE INPUT/OUTPUT: None +C +C ERROR CONDITIONS: None +C +C ADDITIONAL COMMENTS: None +C +C.................MAINTENANCE SECTION................................ +C +C MODULES CALLED: +C Name Description +C convect2 Emanuel cumulus convection tendency calculations +C ------- ---------------------- +C LOCAL VARIABLES AND +C STRUCTURES: +C Name Type Description +C ------- ------ ----------- +C See Comments Below +C +C i Integer loop index +C k Integer loop index +c +C METHOD: +C +C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a +C convective scheme for use in climate models. +C +C FILES: None +C +C INCLUDE FILES: None +C +C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak +C +C..............................END PROLOGUE............................. +c +c + USE dimphy + implicit none +c +cym#include "dimensions.h" +cym#include "dimphy.h" +c + integer len + integer nd + integer ndp1 + integer noff + real t(len,nd) + real q(len,nd) + real qs(len,nd) + real u(len,nd) + real v(len,nd) + real p(len,nd) + real ph(len,ndp1) + integer iflag(len) + real ft(len,nd) + real fq(len,nd) + real fu(len,nd) + real fv(len,nd) + real precip(len) + real cbmf(len) + real Ma(len,nd) + integer minorig + real delt,cpd,cpv,cl,rv,rd,lv0,g + real sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp + real alpha,entp,coeffs,coeffr,omtrain,cu +c +!------------------------------------------------------------------- +! --- ARGUMENTS +!------------------------------------------------------------------- +! --- On input: +! +! t: Array of absolute temperature (K) of dimension ND, with first +! index corresponding to lowest model level. Note that this array +! will be altered by the subroutine if dry convective adjustment +! occurs and if IPBL is not equal to 0. +! +! q: Array of specific humidity (gm/gm) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! qs: Array of saturation specific humidity of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! u: Array of zonal wind velocity (m/s) of dimension ND, witth first +! index corresponding with the lowest model level. Defined at +! same levels as T. Note that this array will be altered if +! dry convective adjustment occurs and if IPBL is not equal to 0. +! +! v: Same as u but for meridional velocity. +! +! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA), +! where NTRA is the number of different tracers. If no +! convective tracer transport is needed, define a dummy +! input array of dimension (ND,1). Tracers are defined at +! same vertical levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! p: Array of pressure (mb) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. +! +! ph: Array of pressure (mb) of dimension ND+1, with first index +! corresponding to lowest level. These pressures are defined at +! levels intermediate between those of P, T, Q and QS. The first +! value of PH should be greater than (i.e. at a lower level than) +! the first value of the array P. +! +! nl: The maximum number of levels to which convection can penetrate, plus 1. +! NL MUST be less than or equal to ND-1. +! +! delt: The model time step (sec) between calls to CONVECT +! +!---------------------------------------------------------------------------- +! --- On Output: +! +! iflag: An output integer whose value denotes the following: +! VALUE INTERPRETATION +! ----- -------------- +! 0 Moist convection occurs. +! 1 Moist convection occurs, but a CFL condition +! on the subsidence warming is violated. This +! does not cause the scheme to terminate. +! 2 Moist convection, but no precip because ep(inb) lt 0.0001 +! 3 No moist convection because new cbmf is 0 and old cbmf is 0. +! 4 No moist convection; atmosphere is not +! unstable +! 6 No moist convection because ihmin le minorig. +! 7 No moist convection because unreasonable +! parcel level temperature or specific humidity. +! 8 No moist convection: lifted condensation +! level is above the 200 mb level. +! 9 No moist convection: cloud base is higher +! then the level NL-1. +! +! ft: Array of temperature tendency (K/s) of dimension ND, defined at same +! grid levels as T, Q, QS and P. +! +! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, +! defined at same grid levels as T. +! +! fv: Same as FU, but for forcing of meridional velocity. +! +! ftra: Array of forcing of tracer content, in tracer mixing ratio per +! second, defined at same levels as T. Dimensioned (ND,NTRA). +! +! precip: Scalar convective precipitation rate (mm/day). +! +! wd: A convective downdraft velocity scale. For use in surface +! flux parameterizations. See convect.ps file for details. +! +! tprime: A convective downdraft temperature perturbation scale (K). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! qprime: A convective downdraft specific humidity +! perturbation scale (gm/gm). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST +! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT +! ITS NEXT CALL. That is, the value of CBMF must be "remembered" +! by the calling program between calls to CONVECT. +! +! det: Array of detrainment mass flux of dimension ND. +! +!------------------------------------------------------------------- +c +c Local arrays +c + integer nl + integer nlp + integer nlm + integer i,k,n + real delti + real rowl + real clmcpv + real clmcpd + real cpdmcp + real cpvmcpd + real eps + real epsi + real epsim1 + real ginv + real hrd + real prccon1 + integer icbmax + real lv(klon,klev) + real cpn(klon,klev) + real cpx(klon,klev) + real tv(klon,klev) + real gz(klon,klev) + real hm(klon,klev) + real h(klon,klev) + real work(klon) + integer ihmin(klon) + integer nk(klon) + real rh(klon) + real chi(klon) + real plcl(klon) + integer icb(klon) + real tnk(klon) + real qnk(klon) + real gznk(klon) + real pnk(klon) + real qsnk(klon) + real ticb(klon) + real gzicb(klon) + real tp(klon,klev) + real tvp(klon,klev) + real clw(klon,klev) +c + real ah0(klon),cpp(klon) + real tg,qg,s,alv,tc,ahg,denom,es,rg +c + integer ncum + integer idcum(klon) +c + cpd=1005.7 + cpv=1870.0 + cl=4190.0 + rv=461.5 + rd=287.04 + lv0=2.501E6 + g=9.8 +C +C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** +C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** +C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** +C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** +C *** BETWEEN 0 C AND TLCRIT) *** +C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** +C *** FORMULATION *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** +C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** +C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF RAIN *** +C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF SNOW *** +C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** +C *** TRANSPORT *** +C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** +C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** +C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** +C *** (DAMP MUST BE LESS THAN 1) *** +c + sigs=0.12 + sigd=0.05 + elcrit=0.0011 + tlcrit=-55.0 + omtsnow=5.5 + dtmax=0.9 + damp=0.1 + alpha=0.2 + entp=1.5 + coeffs=0.8 + coeffr=1.0 + omtrain=50.0 +c + cu=0.70 + damp=0.1 +c +c +c Define nl, nlp, nlm, and delti +c + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + delti=1.0/delt +! +!------------------------------------------------------------------- +! --- SET CONSTANTS +!------------------------------------------------------------------- +! + rowl=1000.0 + clmcpv=cl-cpv + clmcpd=cl-cpd + cpdmcp=cpd-cpv + cpvmcpd=cpv-cpd + eps=rd/rv + epsi=1.0/eps + epsim1=epsi-1.0 + ginv=1.0/g + hrd=0.5*rd + prccon1=86400.0*1000.0/(rowl*g) +! +! dtmax is the maximum negative temperature perturbation. +! +!===================================================================== +! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS +!===================================================================== +! + do 20 k=1,nd + do 10 i=1,len + ft(i,k)=0.0 + fq(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + tvp(i,k)=0.0 + tp(i,k)=0.0 + clw(i,k)=0.0 + gz(i,k) = 0. + 10 continue + 20 continue + do 60 i=1,len + precip(i)=0.0 + iflag(i)=0 + 60 continue +c +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!===================================================================== + do 110 k=1,nl+1 + do 100 i=1,len + lv(i,k)= lv0-clmcpv*(t(i,k)-273.15) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) + tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue + do 140 k=2,nlp + do 130 i=1,len + gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) + & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c + do 170 k=1,nlp + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue +c +!------------------------------------------------------------------- +! --- Find level of minimum moist static energy +! --- If level of minimum moist static energy coincides with +! --- or is lower than minimum allowable parcel origin level, +! --- set iflag to 6. +!------------------------------------------------------------------- + do 180 i=1,len + work(i)=1.0e12 + ihmin(i)=nl + 180 continue + do 200 k=2,nlp + do 190 i=1,len + if((hm(i,k).lt.work(i)).and. + & (hm(i,k).lt.hm(i,k-1)))then + work(i)=hm(i,k) + ihmin(i)=k + endif + 190 continue + 200 continue + do 210 i=1,len + ihmin(i)=min(ihmin(i),nlm) + if(ihmin(i).le.minorig)then + iflag(i)=6 + endif + 210 continue +c +!------------------------------------------------------------------- +! --- Find that model level below the level of minimum moist static +! --- energy that has the maximum value of moist static energy +!------------------------------------------------------------------- + + do 220 i=1,len + work(i)=hm(i,minorig) + nk(i)=minorig + 220 continue + do 240 k=minorig+1,nl + do 230 i=1,len + if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then + work(i)=hm(i,k) + nk(i)=k + endif + 230 continue + 240 continue +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if(((t(i,nk(i)).lt.250.0).or. + & (q(i,nk(i)).le.0.0).or. + & (p(i,ihmin(i)).lt.400.0)).and. + & (iflag(i).eq.0))iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- Calculate lifted condensation level of air at parcel origin level +! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) +!------------------------------------------------------------------- + do 260 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) + rh(i)=min(1.0,rh(i)) + chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + plcl(i)=pnk(i)*(rh(i)**chi(i)) + if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0)) + & .and.(iflag(i).eq.0))iflag(i)=8 + 260 continue +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + do 270 i=1,len + icb(i)=nlm + 270 continue +c + do 290 k=minorig,nl + do 280 i=1,len + if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) + & icb(i)=min(icb(i),k) + 280 continue + 290 continue +c + do 300 i=1,len + if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 + 300 continue +c +c Compute icbmax. +c + icbmax=2 + do 310 i=1,len + icbmax=max(icbmax,icb(i)) + 310 continue +! +!------------------------------------------------------------------- +! --- Calculates the lifted parcel virtual temperature at nk, +! --- the actual temperature, and the adiabatic +! --- liquid water content. The procedure is to solve the equation. +! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +!------------------------------------------------------------------- +! + do 320 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + ticb(i)=t(i,icb(i)) + gzicb(i)=gz(i,icb(i)) + 320 continue +c +c *** Calculate certain parcel quantities, including static energy *** +c + do 330 i=1,len + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv + 330 continue +c +c *** Calculate lifted parcel quantities below cloud base *** +c + do 350 k=minorig,icbmax-1 + do 340 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) + 340 continue + 350 continue +c +c *** Find lifted parcel quantities above cloud base *** +c + do 360 i=1,len + tg=ticb(i) + qg=qs(i,icb(i)) + alv=lv0-clmcpv*(ticb(i)-273.15) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + end if + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c + alv=lv0-clmcpv*(ticb(i)-273.15) + tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) + & -gz(i,icb(i))-alv*qg)/cpd + clw(i,icb(i))=qnk(i)-qg + clw(i,icb(i))=max(0.0,clw(i,icb(i))) + rg=qg/(1.-qnk(i)) + tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) + 360 continue +c + do 380 k=minorig,icbmax + do 370 i=1,len + tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i) + 370 continue + 380 continue +c +!------------------------------------------------------------------- +! --- Test for instability. +! --- If there was no convection at last time step and parcel +! --- is stable at icb, then set iflag to 4. +!------------------------------------------------------------------- + + do 390 i=1,len + if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and. + & (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4 + 390 continue + +!===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +!===================================================================== +c + ncum=0 + do 400 i=1,len + if(iflag(i).eq.0)then + ncum=ncum+1 + idcum(ncum)=i + endif + 400 continue +c +c Call convect2, which compresses the points and computes the heating, +c moistening, velocity mixing, and precipiation. +c +c print*,'cpd avant convect2 ',cpd + if(ncum.gt.0)then + call convect2(ncum,idcum,len,nd,ndp1,nl,minorig, + & nk,icb, + & t,q,qs,u,v,gz,tv,tp,tvp,clw,h, + & lv,cpn,p,ph,ft,fq,fu,fv, + & tnk,qnk,gznk,plcl, + & precip,cbmf,iflag, + & delt,cpd,cpv,cl,rv,rd,lv0,g, + & sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp, + & alpha,entp,coeffs,coeffr,omtrain,cu,Ma) + endif +c + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect2.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect2.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect2.F (revision 1634) @@ -0,0 +1,1395 @@ +! +! $Id$ +! + subroutine convect2(ncum,idcum,len,nd,ndp1,nl,minorig, + & nk1,icb1, + & t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1, + & lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1, + & tnk1,qnk1,gznk1,plcl1, + & precip1,cbmf1,iflag1, + & delt,cpd,cpv,cl,rv,rd,lv0,g, + & sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp, + & alpha,entp,coeffs,coeffr,omtrain,cu,Ma) +C.............................START PROLOGUE............................ +C +C SCCS IDENTIFICATION: @(#)convect2.f 1.2 05/18/00 +C 22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v +C +C CONFIGURATION IDENTIFICATION: None +C +C MODULE NAME: convect2 +C +C DESCRIPTION: +C +C convect1 The Emanuel Cumulus Convection Scheme - compute tendencies +C +C CONTRACT NUMBER AND TITLE: None +C +C REFERENCES: Programmers K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL) +C +C CLASSIFICATION: Unclassified +C +C RESTRICTIONS: None +C +C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90 +C +C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress" +C Fortran 90: -O vector3,scalar3,task1,aggress,overindex -ei -r 2 +C +C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a +C +C USAGE: call convect2(ncum,idcum,len,nd,nl,minorig, +C & nk1,icb1, +C & t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1, +C & lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1, +C & tnk1,qnk1,gznk1,plcl1, +C & precip1,cbmf1,iflag1, +C & delt,cpd,cpv,cl,rv,rd,lv0,g, +C & sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp, +C & alpha,entp,coeffs,coeffr,omtrain,cu) +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C ncum Integer Input number of cumulus points +C idcum Integer Input index of cumulus point +C len Integer Input first dimension +C nd Integer Input total vertical dimension +C ndp1 Integer Input nd + 1 +C nl Integer Input vertical dimension for convection +C minorig Integer Input First level where convection is allow to begin +C nk1 Integer Input First level of convection +C ncb1 Integer Input Level of free convection +C t1 Real Input temperature +C q1 Real Input specific hum +C qs1 Real Input sat specific hum +C u1 Real Input u-wind +C v1 Real Input v-wind +C gz1 Real Inout geop +C tv1 Real Input virtual temp +C tp1 Real Input +C clw1 Real Inout cloud liquid water +C h1 Real Inout +C lv1 Real Inout +C cpn1 Real Inout +C p1 Real Input full level pressure +C ph1 Real Input half level pressure +C ft1 Real Output temp tend +C fq1 Real Output spec hum tend +C fu1 Real Output u-wind tend +C fv1 Real Output v-wind tend +C precip1 Real Output prec +C cbmf1 Real In/Out cumulus mass flux +C iflag1 Integer Output iflag on latitude strip +C delt Real Input time step +C cpd Integer Input See description below +C cpv Integer Input See description below +C cl Integer Input See description below +C rv Integer Input See description below +C rd Integer Input See description below +C lv0 Integer Input See description below +C g Integer Input See description below +C sigs Integer Input See description below +C sigd Integer Input See description below +C elcrit Integer Input See description below +C tlcrit Integer Input See description below +C omtsnow Integer Input See description below +C dtmax Integer Input See description below +C damp Integer Input See description below +C alpha Integer Input See description below +C ent Integer Input See description below +C coeffs Integer Input See description below +C coeffr Integer Input See description below +C omtrain Integer Input See description below +C cu Integer Input See description below +C +C COMMON BLOCKS: +C Block Name Type Usage Notes +C -------- -------- ---- ------ ------------------------ +C +C FILES: None +C +C DATA BASES: None +C +C NON-FILE INPUT/OUTPUT: None +C +C ERROR CONDITIONS: None +C +C ADDITIONAL COMMENTS: None +C +C.................MAINTENANCE SECTION................................ +C +C MODULES CALLED: +C Name Description +C zilch Zero out an array +C ------- ---------------------- +C LOCAL VARIABLES AND +C STRUCTURES: +C Name Type Description +C ------- ------ ----------- +C See Comments Below +C +C i Integer loop index +C k Integer loop index +c +C METHOD: +C +C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a +C convective scheme for use in climate models. +C +C FILES: None +C +C INCLUDE FILES: None +C +C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak +C +C..............................END PROLOGUE............................. +c +c + USE dimphy + implicit none +c +cym#include "dimensions.h" +cym#include "dimphy.h" +c + integer kmax2,imax2,kmin2,imin2 + real ftmax2,ftmin2 + integer kmax,imax,kmin,imin + real ftmax,ftmin +c + integer ncum + integer idcum(len) + integer len + integer nd + integer ndp1 + integer nl + integer minorig + integer nk1(len) + integer icb1(len) + real t1(len,nd) + real q1(len,nd) + real qs1(len,nd) + real u1(len,nd) + real v1(len,nd) + real gz1(len,nd) + real tv1(len,nd) + real tp1(len,nd) + real tvp1(len,nd) + real clw1(len,nd) + real h1(len,nd) + real lv1(len,nd) + real cpn1(len,nd) + real p1(len,nd) + real ph1(len,ndp1) + real ft1(len,nd) + real fq1(len,nd) + real fu1(len,nd) + real fv1(len,nd) + real tnk1(len) + real qnk1(len) + real gznk1(len) + real precip1(len) + real cbmf1(len) + real plcl1(len) + integer iflag1(len) + real delt + real cpd + real cpv + real cl + real rv + real rd + real lv0 + real g + real sigs ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE + real sigd ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT + real elcrit ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) + real tlcrit ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- +c CONVERSION THRESHOLD IS ASSUMED TO BE ZERO + real omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW + real dtmax ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION +c A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC. + real damp + real alpha + real entp ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION + real coeffs ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF SNOW + real coeffr ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF RAIN + real omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN + real cu ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT +c + real Ma(len,nd) +c +C +C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** +C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** +C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** +C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** +C *** BETWEEN 0 C AND TLCRIT) *** +C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** +C *** FORMULATION *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** +C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** +C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF RAIN *** +C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF SNOW *** +C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** +C *** TRANSPORT *** +C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** +C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** +C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** +C *** (DAMP MUST BE LESS THAN 1) *** +c +c Local arrays. +c + real work(ncum) + real t(ncum,klev) + real q(ncum,klev) + real qs(ncum,klev) + real u(ncum,klev) + real v(ncum,klev) + real gz(ncum,klev) + real h(ncum,klev) + real lv(ncum,klev) + real cpn(ncum,klev) + real p(ncum,klev) + real ph(ncum,klev) + real ft(ncum,klev) + real fq(ncum,klev) + real fu(ncum,klev) + real fv(ncum,klev) + real precip(ncum) + real cbmf(ncum) + real plcl(ncum) + real tnk(ncum) + real qnk(ncum) + real gznk(ncum) + real tv(ncum,klev) + real tp(ncum,klev) + real tvp(ncum,klev) + real clw(ncum,klev) +c real det(ncum,klev) + real dph(ncum,klev) +c real wd(ncum) +c real tprime(ncum) +c real qprime(ncum) + real ah0(ncum) + real ep(ncum,klev) + real sigp(ncum,klev) + integer nent(ncum,klev) + real water(ncum,klev) + real evap(ncum,klev) + real mp(ncum,klev) + real m(ncum,klev) + real qti + real wt(ncum,klev) + real hp(ncum,klev) + real lvcp(ncum,klev) + real elij(ncum,klev,klev) + real ment(ncum,klev,klev) + real sij(ncum,klev,klev) + real qent(ncum,klev,klev) + real uent(ncum,klev,klev) + real vent(ncum,klev,klev) + real qp(ncum,klev) + real up(ncum,klev) + real vp(ncum,klev) + real cape(ncum) + real capem(ncum) + real frac(ncum) + real dtpbl(ncum) + real tvpplcl(ncum) + real tvaplcl(ncum) + real dtmin(ncum) + real w3d(ncum,klev) + real am(ncum) + real ents(ncum) + real uav(ncum) + real vav(ncum) +c + integer iflag(ncum) + integer nk(ncum) + integer icb(ncum) + integer inb(ncum) + integer inb1(ncum) + integer jtt(ncum) +c + integer nn,i,k,n,icbmax,nlp,j + integer ij + integer nn2,nn3 + real clmcpv + real clmcpd + real cpdmcp + real cpvmcpd + real eps + real epsi + real epsim1 + real tg,qg,s,alv,tc,ahg,denom,es,rg,ginv,rowl + real delti + real tca,elacrit + real by,defrac +c real byp + real byp(ncum) + logical lcape(ncum) + real dbo + real bf2,anum,dei,altem,cwat,stemp + real alt,qp1,smid,sjmax,sjmin + real delp,delm + real awat,coeff,afac,revap,dhdp,fac,qstm,rat + real qsm,sigt,b6,c6 + real dpinv,cpinv + real fqold,ftold,fuold,fvold + real wdtrain(ncum),xxx + real bsum(ncum,klev) + real asij(ncum) + real smin(ncum) + real scrit(ncum) +c real amp1,ad + real amp1(ncum),ad(ncum) + logical lwork(ncum) + integer num1,num2 +c +c print*,'cpd en entree de convect2 ',cpd + nlp=nl+1 +c + rowl=1000.0 + ginv=1.0/g + delti=1.0/delt +c +c Define some thermodynamic variables. +c + clmcpv=cl-cpv + clmcpd=cl-cpd + cpdmcp=cpd-cpv + cpvmcpd=cpv-cpd + eps=rd/rv + epsi=1.0/eps + epsim1=epsi-1.0 +c +c Compress the fields. +c + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.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) + endif + 100 continue +c print*,'100 ncum,nn',ncum,nn + 110 continue + nn=0 + do 150 i=1,len + if(iflag1(i).eq.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) + endif + 150 continue +c print*,'150 ncum,nn',ncum,nn +c +c Initialize the tendencies, det, wd, tprime, qprime. +c + do 170 k=1,nl + do 160 i=1,ncum +c det(i,k)=0.0 + ft(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + fq(i,k)=0.0 + dph(i,k)=ph(i,k)-ph(i,k+1) + ep(i,k)=0.0 + sigp(i,k)=sigs + 160 continue + 170 continue + do 180 i=1,ncum +c wd(i)=0.0 +c tprime(i)=0.0 +c qprime(i)=0.0 + precip(i)=0.0 + ft(i,nl+1)=0.0 + fu(i,nl+1)=0.0 + fv(i,nl+1)=0.0 + fq(i,nl+1)=0.0 + 180 continue +c +c Compute icbmax. +c + icbmax=2 + do 230 i=1,ncum + icbmax=max(icbmax,icb(i)) + 230 continue +c +c +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum + if(k.ge.(icb(i)+1))then + tg=t(i,k) + qg=qs(i,k) + alv=lv0-clmcpv*(t(i,k)-273.15) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-273.15 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c + alv=lv0-clmcpv*(t(i,k)-273.15) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg) + & /cpd +c if (.not.cpd.gt.1000.) then +c print*,'CPD=',cpd +c stop +c endif + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) + tvp(i,k)=tp(i,k)*(1.+rg*epsi) + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== +c + do 320 k=minorig+1,nl + do 310 i=1,ncum + if(k.ge.(nk(i)+1))then + tca=tp(i,k)-273.15 + if(tca.ge.0.0)then + elacrit=elcrit + else + elacrit=elcrit*(1.0-tca/tlcrit) + endif + elacrit=max(elacrit,0.0) + ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) + ep(i,k)=max(ep(i,k),0.0 ) + ep(i,k)=min(ep(i,k),1.0 ) + sigp(i,k)=sigs + endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c + do 340 k=minorig+1,nl + do 330 i=1,ncum + if(k.ge.(icb(i)+1))then + tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) + endif + 330 continue + 340 continue + do 350 i=1,ncum + tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd + 350 continue +c +c +c===================================================================== +c --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== +c + do 360 i=1,ncum*nlp + nent(i,1)=0 + water(i,1)=0.0 + evap(i,1)=0.0 + mp(i,1)=0.0 + m(i,1)=0.0 + wt(i,1)=omtsnow + hp(i,1)=h(i,1) +c if(.not.cpn(i,1).gt.900.) then +c print*,'i,lv(i,1),cpn(i,1)' +c print*, i,lv(i,1),cpn(i,1) +c k=(i-1)/ncum+1 +c print*,'i,k',mod(i,ncum),k,' cpn',cpn(mod(i,ncum),k) +c stop +c endif + lvcp(i,1)=lv(i,1)/cpn(i,1) + 360 continue +c + do 380 i=1,ncum*nlp*nlp + elij(i,1,1)=0.0 + ment(i,1,1)=0.0 + sij(i,1,1)=0.0 + 380 continue +c + do 400 k=1,nlp + do 390 j=1,nlp + do 385 i=1,ncum + qent(i,k,j)=q(i,j) + uent(i,k,j)=u(i,j) + vent(i,k,j)=v(i,j) + 385 continue + 390 continue + 400 continue +c + do 420 i=1,ncum + qp(i,1)=q(i,1) + up(i,1)=u(i,1) + vp(i,1)=v(i,1) + 420 continue + do 440 k=2,nlp + do 430 i=1,ncum + qp(i,k)=q(i,k-1) + up(i,k)=u(i,k-1) + vp(i,k)=v(i,k-1) + 430 continue + 440 continue +c +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S +c --- HIGHEST LEVEL OF NEUTRAL BUOYANCY +c --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) +c===================================================================== +c + do 510 i=1,ncum + cape(i)=0.0 + capem(i)=0.0 + inb(i)=icb(i)+1 + inb1(i)=inb(i) + 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c + call zilch(byp,ncum) + do 515 i=1,ncum + lcape(i)=.true. + 515 continue + do 530 k=minorig+1,nl-1 + do 520 i=1,ncum + if(cape(i).lt.0.0)lcape(i)=.false. + if((k.ge.(icb(i)+1)).and.lcape(i))then + by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) + byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) + cape(i)=cape(i)+by + if(by.ge.0.0)inb1(i)=k+1 + if(cape(i).gt.0.0)then + inb(i)=k+1 + capem(i)=cape(i) + endif + endif + 520 continue + 530 continue + do 540 i=1,ncum + cape(i)=capem(i)+byp(i) + defrac=capem(i)-cape(i) + defrac=max(defrac,0.001) + frac(i)=-cape(i)/defrac + frac(i)=min(frac(i),1.0) + frac(i)=max(frac(i),0.0) + 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue +c +c===================================================================== +c --- CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), +c --- AT EACH MODEL LEVEL +c===================================================================== +c +c tvpplcl = parcel temperature lifted adiabatically from level +c icb-1 to the LCL. +c tvaplcl = virtual temperature at the LCL. +c + do 610 i=1,ncum + dtpbl(i)=0.0 + tvpplcl(i)=tvp(i,icb(i)-1) + & -rd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i)) + & /(cpn(i,icb(i)-1)*p(i,icb(i)-1)) + tvaplcl(i)=tv(i,icb(i)) + & +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i))) + & /(p(i,icb(i))-p(i,icb(i)+1)) + 610 continue +c +c------------------------------------------------------------------- +c --- Interpolate difference between lifted parcel and +c --- environmental temperatures to lifted condensation level +c------------------------------------------------------------------- +c +c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). +c + do 630 k=minorig,icbmax + do 620 i=1,ncum + if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then + dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k) + endif + 620 continue + 630 continue + do 640 i=1,ncum + dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i))) + dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i) + 640 continue +c +c------------------------------------------------------------------- +c --- Adjust cloud base mass flux +c------------------------------------------------------------------- +c + do 650 i=1,ncum + work(i)=cbmf(i) + cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i)) + if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then + iflag(i)=3 + endif + 650 continue +c +c------------------------------------------------------------------- +c --- Calculate rates of mixing, m(i) +c------------------------------------------------------------------- +c + call zilch(work,ncum) +c + do 670 j=minorig+1,nl + do 660 i=1,ncum + if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then + k=min(j,inb1(i)) + dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + & +entp*0.04*(ph(i,k)-ph(i,k+1)) + work(i)=work(i)+dbo + m(i,j)=cbmf(i)*dbo + endif + 660 continue + 670 continue + do 690 k=minorig+1,nl + do 680 i=1,ncum + if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then + m(i,k)=m(i,k)/work(i) + endif + 680 continue + 690 continue +c +c +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== +c +c + do 750 i=minorig+1,nl + do 710 j=minorig+1,nl + do 700 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij)) + & .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then + qti=qnk(ij)-ep(ij,i)*clw(ij,i) + bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j) + & /(rv*t(ij,j)*t(ij,j)*cpd) + anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j)) + denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(ij,i,j)=anum/dei + sij(ij,i,i)=1.0 + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem/bf2 + cwat=clw(ij,j)*(1.-ep(ij,j)) + stemp=sij(ij,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or. + 1 altem.gt.cwat).and.j.gt.i)then + anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2) + denom=denom+lv(ij,j)*(q(ij,i)-qti) + if(abs(denom).lt.0.01)denom=0.01 + sij(ij,i,j)=anum/denom + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem-(bf2-1.)*cwat + endif + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + qent(ij,i,j)=sij(ij,i,j)*q(ij,i) + & +(1.-sij(ij,i,j))*qti + uent(ij,i,j)=sij(ij,i,j)*u(ij,i) + & +(1.-sij(ij,i,j))*u(ij,nk(ij)) + vent(ij,i,j)=sij(ij,i,j)*v(ij,i) + & +(1.-sij(ij,i,j))*v(ij,nk(ij)) + elij(ij,i,j)=altem + elij(ij,i,j)=max(0.0,elij(ij,i,j)) + ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j)) + nent(ij,i)=nent(ij,i)+1 + endif + sij(ij,i,j)=max(0.0,sij(ij,i,j)) + sij(ij,i,j)=min(1.0,sij(ij,i,j)) + endif + 700 continue + 710 continue +c +c *** If no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + do 740 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij)) + & .and.(nent(ij,i).eq.0))then + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 740 continue + 750 continue +c + do 770 i=1,ncum + sij(i,inb(i),inb(i))=1.0 + 770 continue +c +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== +c +c + call zilch(bsum,ncum*nlp) + do 780 ij=1,ncum + lwork(ij)=.false. + 780 continue + do 789 i=minorig+1,nl +c + num1=0 + do 779 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1 + 779 continue + if(num1.le.0)go to 789 +c + do 781 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then + lwork(ij)=(nent(ij,i).ne.0) + qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i)) + denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1) + if(abs(denom).lt.0.01)denom=0.01 + scrit(ij)=anum/denom + alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1) + if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0 + asij(ij)=0.0 + smin(ij)=1.0 + endif + 781 continue + do 783 j=minorig,nl +c + num2=0 + do 778 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))num2=num2+1 + 778 continue + if(num2.le.0)go to 783 +c + do 782 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + if(j.gt.i)then + smid=min(sij(ij,i,j),scrit(ij)) + sjmax=smid + sjmin=smid + if(smid.lt.smin(ij) + & .and.sij(ij,i,j+1).lt.smid)then + smin(ij)=smid + sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij)) + sjmin=max(sij(ij,i,j-1),sij(ij,i,j)) + sjmin=min(sjmin,scrit(ij)) + endif + else + sjmax=max(sij(ij,i,j+1),scrit(ij)) + smid=max(sij(ij,i,j),scrit(ij)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(ij,i,j-1) + sjmin=max(sjmin,scrit(ij)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(ij)=asij(ij)+(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + ment(ij,i,j)=ment(ij,i,j)*(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + endif + endif + 782 continue + 783 continue + do 784 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then + asij(ij)=max(1.0e-21,asij(ij)) + asij(ij)=1.0/asij(ij) + bsum(ij,i)=0.0 + endif + 784 continue + do 786 j=minorig,nl+1 + do 785 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))then + ment(ij,i,j)=ment(ij,i,j)*asij(ij) + bsum(ij,i)=bsum(ij,i)+ment(ij,i,j) + endif + 785 continue + 786 continue + do 787 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then + nent(ij,i)=0 + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 787 continue + 789 continue +c +c===================================================================== +c --- PRECIPITATING DOWNDRAFT CALCULATION +c===================================================================== +c +c *** Check whether ep(inb)=0, if so, skip precipitating *** +c *** downdraft calculation *** +c +c +c *** Integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c +c + do 890 i=1,ncum + jtt(i)=2 + if(ep(i,inb(i)).le.0.0001)iflag(i)=2 + if(iflag(i).eq.0)then + lwork(i)=.true. + else + lwork(i)=.false. + endif + 890 continue +c +c *** Begin downdraft loop *** +c +c + call zilch(wdtrain,ncum) + do 899 i=nl+1,1,-1 +c + num1=0 + do 879 ij=1,ncum + if((i.le.inb(ij)).and.lwork(ij))num1=num1+1 + 879 continue + if(num1.le.0)go to 899 +c +c +c *** Calculate detrained precipitation *** +c + do 891 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i) + endif + 891 continue +c + if(i.gt.1)then + do 893 j=1,i-1 + do 892 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(0.0,awat) + wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i) + endif + 892 continue + 893 continue + endif +c +c *** Find rain water and evaporation using provisional *** +c *** estimates of qp(i)and qp(i-1) *** +c +c +c *** Value of terminal velocity and coeffecient of evaporation for snow *** +c + do 894 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + coeff=coeffs + wt(ij,i)=omtsnow +c +c *** Value of terminal velocity and coeffecient of evaporation for rain *** +c + if(t(ij,i).gt.273.0)then + coeff=coeffr + wt(ij,i)=omtrain + endif + qsm=0.5*(q(ij,i)+qp(ij,i+1)) + afac=coeff*ph(ij,i)*(qs(ij,i)-qsm) + & /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i)) + afac=max(afac,0.0) + sigt=sigp(ij,i) + sigt=max(0.0,sigt) + sigt=min(1.0,sigt) + b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i) + c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i) + revap=0.5*(-b6+sqrt(b6*b6+4.*c6)) + evap(ij,i)=sigt*afac*revap + water(ij,i)=revap*revap +c +c *** Calculate precipitating downdraft mass flux under *** +c *** hydrostatic approximation *** +c + if(i.gt.1)then + dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i)) + dhdp=max(dhdp,10.0) + mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp + mp(ij,i)=max(mp(ij,i),0.0) +c +c *** Add small amount of inertia to downdraft *** +c + fac=20.0/(ph(ij,i-1)-ph(ij,i)) + mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac) +c +c *** Force mp to decrease linearly to zero *** +c *** between about 950 mb and the surface *** +c + if(p(ij,i).gt.(0.949*p(ij,1)))then + jtt(ij)=max(jtt(ij),i) + mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i)) + & /(p(ij,1)-p(ij,jtt(ij))) + endif + endif +c +c *** Find mixing ratio of precipitating downdraft *** +c + if(i.ne.inb(ij))then + if(i.eq.1)then + qstm=qs(ij,1) + else + qstm=qs(ij,i-1) + endif + if(mp(ij,i).gt.mp(ij,i+1))then + rat=mp(ij,i+1)/mp(ij,i) + qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv* + & sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i)) + up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat) + vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat) + else + if(mp(ij,i+1).gt.0.0)then + qp(ij,i)=(gz(ij,i+1)-gz(ij,i) + & +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1) + & *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i))) + & /(lv(ij,i)+t(ij,i)*(cl-cpd)) + up(ij,i)=up(ij,i+1) + vp(ij,i)=vp(ij,i+1) + endif + endif + qp(ij,i)=min(qp(ij,i),qstm) + qp(ij,i)=max(qp(ij,i),0.0) + endif + endif + 894 continue + 899 continue +c +c *** Calculate surface precipitation in mm/day *** +c + do 1190 i=1,ncum + if(iflag(i).le.1)then +cc precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000. +cc & /(rowl*g) +cc precip(i)=precip(i)*delt/86400. + precip(i) = wt(i,1)*sigd*water(i,1)*86400/g + endif + 1190 continue +c +c +c *** Calculate downdraft velocity scale and surface temperature and *** +c *** water vapor fluctuations *** +c +c wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb)) +c qprime=0.5*(qp(1)-q(1)) +c tprime=lv0*qprime/cpd +c +c *** Calculate tendencies of lowest level potential temperature *** +c *** and mixing ratio *** +c + do 1200 i=1,ncum + work(i)=0.01/(ph(i,1)-ph(i,2)) + am(i)=0.0 + 1200 continue + do 1220 k=2,nl + do 1210 i=1,ncum + if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then + am(i)=am(i)+m(i,k) + endif + 1210 continue + 1220 continue + do 1240 i=1,ncum + if((g*work(i)*am(i)).ge.delti)iflag(i)=1 + ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1) + & +(gz(i,2)-gz(i,1))/cpn(i,1)) + ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1) + ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2) + & -t(i,1))*work(i)/cpn(i,1) + fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))* + & work(i)+sigd*evap(i,1) + fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i) + fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1)) + & +am(i)*(u(i,2)-u(i,1))) + fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1)) + & +am(i)*(v(i,2)-v(i,1))) + 1240 continue + do 1260 j=2,nl + do 1250 i=1,ncum + if(j.le.inb(i))then + fq(i,1)=fq(i,1) + & +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1)) + fu(i,1)=fu(i,1) + & +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1)) + fv(i,1)=fv(i,1) + & +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1)) + endif + 1250 continue + 1260 continue +c +c *** Calculate tendencies of potential temperature and mixing ratio *** +c *** at levels above the lowest level *** +c +c *** First find the net saturated updraft and downdraft mass fluxes *** +c *** through each level *** +c + do 1500 i=2,nl+1 +c + num1=0 + do 1265 ij=1,ncum + if(i.le.inb(ij))num1=num1+1 + 1265 continue + if(num1.le.0)go to 1500 +c + call zilch(amp1,ncum) + call zilch(ad,ncum) +c + do 1280 k=i+1,nl+1 + do 1270 ij=1,ncum + if((i.ge.nk(ij)).and.(i.le.inb(ij)) + & .and.(k.le.(inb(ij)+1)))then + amp1(ij)=amp1(ij)+m(ij,k) + endif + 1270 continue + 1280 continue +c + do 1310 k=1,i + do 1300 j=i+1,nl+1 + do 1290 ij=1,ncum + if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then + amp1(ij)=amp1(ij)+ment(ij,k,j) + endif + 1290 continue + 1300 continue + 1310 continue + do 1340 k=1,i-1 + do 1330 j=i,nl+1 + do 1320 ij=1,ncum + if((i.le.inb(ij)).and.(j.le.inb(ij)))then + ad(ij)=ad(ij)+ment(ij,j,k) + endif + 1320 continue + 1330 continue + 1340 continue +c + do 1350 ij=1,ncum + if(i.le.inb(ij))then + dpinv=0.01/(ph(ij,i)-ph(ij,i+1)) + cpinv=1.0/cpn(ij,i) +c + ft(ij,i)=ft(ij,i) + & +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i) + & +(gz(ij,i+1)-gz(ij,i))*cpinv) + & -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) + & -sigd*lvcp(ij,i)*evap(ij,i) + ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+ + & t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv + ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)* + & (t(ij,i+1)-t(ij,i))*dpinv*cpinv + fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))- + & ad(ij)*(q(ij,i)-q(ij,i-1))) + fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))- + & ad(ij)*(u(ij,i)-u(ij,i-1))) + fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))- + & ad(ij)*(v(ij,i)-v(ij,i-1))) + endif + 1350 continue + do 1370 k=1,i-1 + do 1360 ij=1,ncum + if(i.le.inb(ij))then + awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(awat,0.0) + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) + endif + 1360 continue + 1370 continue + do 1390 k=i,nl+1 + do 1380 ij=1,ncum + if((i.le.inb(ij)).and.(k.le.inb(ij)))then + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) + endif + 1380 continue + 1390 continue + do 1400 ij=1,ncum + if(i.le.inb(ij))then + 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 + fu(ij,i)=fu(ij,i) + & +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)* + & (up(ij,i)-u(ij,i-1)))*dpinv + fv(ij,i)=fv(ij,i) + & +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)* + & (vp(ij,i)-v(ij,i-1)))*dpinv + endif + 1400 continue + 1500 continue +c +c *** Adjust tendencies at top of convection layer to reflect *** +c *** actual position of the level zero cape *** +c + do 503 ij=1,ncum + fqold=fq(ij,inb(ij)) + fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij)) + fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1) + & +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij)) + & /lv(ij,inb(ij)-1) + ftold=ft(ij,inb(ij)) + ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij)) + ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1) + & +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij)) + & /cpn(ij,inb(ij)-1) + fuold=fu(ij,inb(ij)) + fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij)) + fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1) + & +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + fvold=fv(ij,inb(ij)) + fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij)) + fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1) + & +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + 503 continue +c +c *** Very slightly adjust tendencies to force exact *** +c *** enthalpy, momentum and tracer conservation *** +c + do 682 ij=1,ncum + ents(ij)=0.0 + uav(ij)=0.0 + vav(ij)=0.0 + do 681 i=1,inb(ij) + ents(ij)=ents(ij) + & +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1)) + uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1)) + vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1)) + 681 continue + 682 continue + do 683 ij=1,ncum + ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + 683 continue + do 642 ij=1,ncum + do 641 i=1,inb(ij) + ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i) + fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij)) + fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij)) + 641 continue + 642 continue +c + do 1810 k=1,nl+1 + do 1800 i=1,ncum + if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10 + 1800 continue + 1810 continue +c +c + do 1900 i=1,ncum + if(iflag(i).gt.2)then + precip(i)=0.0 + cbmf(i)=0.0 + endif + 1900 continue + do 1920 k=1,nl + do 1910 i=1,ncum + if(iflag(i).gt.2)then + ft(i,k)=0.0 + fq(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + endif + 1910 continue + 1920 continue + do 2000 i=1,ncum + precip1(idcum(i))=precip(i) + cbmf1(idcum(i))=cbmf(i) + iflag1(idcum(i))=iflag(i) + 2000 continue + do 2020 k=1,nl + do 2010 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) + 2010 continue + 2020 continue +c + DO k=1,nd + DO i=1,len + Ma(i,k) = 0. + ENDDO + ENDDO + DO k=nl,1,-1 + DO i=1,ncum + Ma(i,k) = Ma(i,k+1)+m(i,k) + ENDDO + ENDDO +c + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect3.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect3.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/convect3.F (revision 1634) @@ -0,0 +1,1410 @@ +! +! $Header$ +! + SUBROUTINE CONVECT3 + * (DTIME,EPMAX,ok_adj, + * T1, R1, RS, U, V, TRA, P, PH, + * ND, NDP1, NL, NTRA, DELT, IFLAG, + * FT, FR, FU, FV, FTRA, PRECIP, + * icb,inb, upwd,dnwd,dnwd0,SIG, W0,Mike,Mke, + * Ma,MENTS,QENTS,TPS,TLS,SIGIJ,CAPE,TVP,PBASE,BUOYBASE, +cccc * DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR) + * DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR, ! sbl + * FT2,FR2,FU2,FV2,WD,QCOND,QCONDC) ! sbl +C +C *** THE PARAMETER NA SHOULD IN GENERAL EQUAL ND *** +C +c################################################################# +cFleur Introduction des traceurs dans convect3 le 6 juin 200 +c################################################################# + USE dimphy + USE infotrac, ONLY : NBTR + +#include "dimensions.h" + INTEGER NA + PARAMETER (NA=60) + + REAL DELTAC ! cld + PARAMETER (DELTAC=0.01) ! cld + + INTEGER NENT(NA) + INTEGER ND, NDP1, NL, NTRA, IFLAG, icb, inb + REAL DTIME, EPMAX, DELT, PRECIP, CAPE + REAL DPLCLDT, DPLCLDR + REAL T1(ND),R1(ND),RS(ND),U(ND),V(ND),TRA(ND,NTRA) + REAL P(ND),PH(NDP1) + REAL FT(ND),FR(ND),FU(ND),FV(ND),FTRA(ND,NTRA) + REAL SIG(ND),W0(ND) + REAL UENT(NA,NA),VENT(NA,NA),TRAENT(NA,NA,NBTR),TRATM(NA) + REAL UP(NA),VP(NA),TRAP(NA,NBTR) + REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA) + REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA) + REAL RP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA) + REAL SIGP(NA),B(NA),TP(NA),CPN(NA) + REAL LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA) + REAL T(NA),RR(NA) +C + REAL FT2(ND),FR2(ND),FU2(ND),FV2(ND) ! added sbl + REAL U1(ND),V1(ND) ! added sbl +C + REAL BUOY(NA) ! Lifted parcel buoyancy + REAL DTVPDT1(ND),DTVPDQ1(ND) ! Derivatives of parcel virtual +C temperature wrt T1 and Q1 + REAL CLW_NEW(NA),QI(NA) +C + REAL WD, BETAD ! for gust factor (sb) + REAL QCONDC(ND) ! interface cld param (sb) + REAL QCOND(ND),NQCOND(NA),WA(NA),MAA(NA),SIGA(NA),AXC(NA) ! cld +C + LOGICAL ICE_CONV,ok_adj + PARAMETER (ICE_CONV=.TRUE.) + +cccccccccccccccccccccccccccccccccccccccccccccc +c declaration des variables a sortir +ccccccccccccccccccccccccccccccccccccccccccccc + real Mke(nd) + real Mike(nd) + real Ma(nd) + real TPS(ND) !temperature dans les ascendances non diluees + real TLS(ND) !temperature potentielle + real MENTS(nd,nd) + real QENTS(nd,nd) + REAL SIGIJ(KLEV,KLEV) + REAL PBASE ! pressure at the cloud base level + REAL BUOYBASE ! buoyancy at the cloud base level +cccccccccccccccccccccccccccccccccccccccccccccc + + + +c + real dnwd0(nd) ! precipitation driven unsaturated downdraft flux + real dnwd(nd), dn1 ! in-cloud saturated downdraft mass flux + real upwd(nd), up1 ! in-cloud saturated updraft mass flux +C +C *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS *** +C *** THESE SHOULD BE CONSISTENT WITH *** +C *** THOSE USED IN CALLING PROGRAM *** +C *** NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT *** +C +c sb CPD=1005.7 +c sb CPV=1870.0 +c sb CL=4190.0 +c sb CPVMCL=CL-CPV +c sb RV=461.5 +c sb RD=287.04 +c sb EPS=RD/RV +c sb ALV0=2.501E6 +ccccccccccccccccccccccc +c constantes coherentes avec le modele du Centre Europeen +c sb RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644 +c sb RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153 +c sb CPD = 3.5 * RD +c sb CPV = 4.0 * RV +c sb CL = 4218.0 +c sb CPVMCL=CL-CPV +c sb EPS=RD/RV +c sb ALV0=2.5008E+06 +cccccccccccccccccccccc +c on utilise les constantes thermo du Centre Europeen: (SB) +c +#include "YOMCST.h" +c + CPD = RCPD + CPV = RCPV + CL = RCW + CPVMCL = CL-CPV + EPS = RD/RV + ALV0 = RLVTT +c + NK = 1 ! origin level of the lifted parcel +c +cccccccccccccccccccccc +C +C *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS *** +C + DO 5 I=1,ND + FT(I)=0.0 + FR(I)=0.0 + FU(I)=0.0 + FV(I)=0.0 + + FT2(I)=0.0 + FR2(I)=0.0 + FU2(I)=0.0 + FV2(I)=0.0 + + DO 4 J=1,NTRA + FTRA(I,J)=0.0 + 4 CONTINUE + + QCONDC(I)=0.0 ! cld + QCOND(I)=0.0 ! cld + NQCOND(I)=0.0 ! cld + + T(I)=T1(I) + RR(I)=R1(I) + U1(I)=U(I) ! added sbl + V1(I)=V(I) ! added sbl + 5 CONTINUE + DO 7 I=1,NL + RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV) + TH(I)=T(I)*(1000.0/P(I))**RDCP + 7 CONTINUE +C +************************************************************* +** CALCUL DES TEMPERATURES POTENTIELLES A SORTIR +************************************************************* + do i=1,ND + RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV) + + TLS(i)=T(I)*(1000.0/P(I))**RDCP + enddo + + + + +************************************************************ + + + PRECIP=0.0 + WD=0.0 ! sb + IFLAG=1 +C +C *** SPECIFY PARAMETERS *** +C *** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** +C *** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** +C *** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** +C *** EFFICIENCY IS ASSUMED TO BE UNITY *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** +C *** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** +C *** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** IT MUST BE LESS THAN 0 *** +C + PBCRIT=150.0 + PTCRIT=500.0 + SIGD=0.01 + SPFAC=0.15 +c sb: +c EPMAX=0.993 ! precip efficiency less than unity +c EPMAX=1. ! precip efficiency less than unity +C +Cjyg +CCC BETA=0.96 +C Beta is now expressed as a function of the characteristic time +C of the convective process. +CCC Old value : TAU = 15000. !(for dtime = 600.s) +CCC Other value (inducing little change) :TAU = 8000. + TAU = 8000. + BETA = 1.-DTIME/TAU +Cjyg +CCC ALPHA=1.0 + ALPHA=1.5E-3*DTIME/TAU +C Increase alpha in order to compensate W decrease + ALPHA = ALPHA*1.5 +C +Cjyg (voir CONVECT 3) +CCC DTCRIT=-0.2 + DTCRIT=-2. +Cgf&jyg +CCC DT pour l'overshoot. + DTOVSH = -0.2 + +C +C *** INCREMENT THE COUNTER *** +C + SIG(ND)=SIG(ND)+1.0 + SIG(ND)=AMIN1(SIG(ND),12.1) +C +C *** IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT *** +C *** RETURNS ARRAYS T AND R THAT MAY HAVE BEEN *** +C *** ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE *** +C *** THE RETURNED ARRAYS ARE UNALTERED. *** +C + NOPT=0 +c! NOPT=1 ! sbl +C +C *** PERFORM DRY ADIABATIC ADJUSTMENT *** +C +C *** DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A *** +C *** BOUNDARY LAYER SCHEME !!! *** +C + IF (ok_adj) THEN ! added sbl + + DO 30 I=NL-1,1,-1 + JN=0 + DO 10 J=I+1,NL + 10 IF(TH(J).LT.TH(I))JN=J + IF(JN.EQ.0)GOTO 30 + AHM=0.0 + RM=0.0 + UM=0.0 + VM=0.0 + DO K=1,NTRA + TRATM(K)=0.0 + END DO + DO 15 J=I,JN + AHM=AHM+(CPD*(1.-RR(J))+RR(J)*CPV)*T(J)*(PH(J)-PH(J+1)) + RM=RM+RR(J)*(PH(J)-PH(J+1)) + UM=UM+U(J)*(PH(J)-PH(J+1)) + VM=VM+V(J)*(PH(J)-PH(J+1)) + DO K=1,NTRA + TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1)) + END DO + 15 CONTINUE + DPHINV=1./(PH(I)-PH(JN+1)) + RM=RM*DPHINV + UM=UM*DPHINV + VM=VM*DPHINV + DO K=1,NTRA + TRATM(K)=TRATM(K)*DPHINV + END DO + A2=0.0 + DO 20 J=I,JN + RR(J)=RM + U(J)=UM + V(J)=VM + DO K=1,NTRA + TRA(J,K)=TRATM(K) + END DO + RDCP=(RD*(1.-RR(J))+RR(J)*RV)/ (CPD*(1.-RR(J))+RR(J)*CPV) + X=(0.001*P(J))**RDCP + T(J)=X + A2=A2+(CPD*(1.-RR(J))+RR(J)*CPV)*X*(PH(J)-PH(J+1)) + 20 CONTINUE + DO 25 J=I,JN + TH(J)=AHM/A2 + T(J)=T(J)*TH(J) + 25 CONTINUE + 30 CONTINUE + + ENDIF ! added sbl +C +C *** RESET INPUT ARRAYS IF ok_adj 0 *** +C + IF (ok_adj)THEN + DO 35 I=1,ND + + FT2(I)=(T(I)-T1(I))/DELT ! sbl + FR2(I)=(RR(I)-R1(I))/DELT ! sbl + FU2(I)=(U(I)-U1(I))/DELT ! sbl + FV2(I)=(V(I)-V1(I))/DELT ! sbl + +c! T1(I)=T(I) ! commente sbl +c! R1(I)=RR(I) ! commente sbl + 35 CONTINUE + END IF +C +C *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY +C + GZ(1)=0.0 + CPN(1)=CPD*(1.-RR(1))+RR(1)*CPV + H(1)=T(1)*CPN(1) + DO 40 I=2,NL + TVX=T(I)*(1.+RR(I)/EPS-RR(I)) + TVY=T(I-1)*(1.+RR(I-1)/EPS-RR(I-1)) + GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I) + CPN(I)=CPD*(1.-RR(I))+CPV*RR(I) + H(I)=T(I)*CPN(I)+GZ(I) + 40 CONTINUE +C +C *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL *** +C *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) *** +C + IF (T(1).LT.250.0.OR.RR(1).LE.0.0)THEN + IFLAG=0 +c sb3d print*,'je suis passe par 366' + RETURN + END IF + +cjyg1 Utilisation de la subroutine CLIFT +CC RH=RR(1)/RS(1) +CC CHI=T(1)/(1669.0-122.0*RH-T(1)) +CC PLCL=P(1)*(RH**CHI) + CALL CLIFT(P(1),T(1),RR(1),RS(1),PLCL,DPLCLDT,DPLCLDR) +cjyg2 +c sb3d PRINT *,' em_plcl,p1,t1,r1,rs1,rh ' +c sb3d $ ,PLCL,P(1),T(1),RR(1),RS(1),RH +c + IF (PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN + IFLAG=2 + RETURN + END IF +Cjyg1 +C Essais de modification de ICB +C +C *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) *** +C +CC ICB=NL-1 +CC DO 50 I=2,NL-1 +CC IF(P(I).LT.PLCL)THEN +CC ICB=MIN(ICB,I) ! ICB sup ou egal a 2 +CC END IF +CC 50 CONTINUE +CC IF(ICB.EQ.(NL-1))THEN +CC IFLAG=3 +CC RETURN +CC END IF +C +C *** CALCULATE LAYER CONTAINING LCL (=ICB) *** +C + ICB=NL-1 +c sb DO 50 I=2,NL-1 + DO 50 I=3,NL-1 ! modif sb pour que ICB soit sup/egal a 2 +C la modification consiste a comparer PLCL a PH et non a P: +C ICB est defini par : PH(ICB) adiabatic CAPE) +C +ccc TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I)) +c!!! sb TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift +Ccd2 +C +C *** Calculate first estimate of buoyancy +C + BUOY(I) = TVP(I) - TV(I) + 55 CONTINUE +C +C *** Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy +C + DPBASE = -40. !That is 400m above LCL + PBASE = PLCL + DPBASE + TVPBASE = TVP(ICB )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1)) + $ +TVP(ICB+1)*(P(ICB)-PBASE )/(P(ICB)-P(ICB+1)) + TVBASE = TV(ICB )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1)) + $ +TV(ICB+1)*(P(ICB)-PBASE )/(P(ICB)-P(ICB+1)) +C +c test sb: +c@ write(*,*) '++++++++++++++++++++++++++++++++++++++++' +c@ write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1) +c@ : ,tv(icb),tv(icb1)' +c@ write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb) +c@ L ,tvp(icb+1),tv(icb),tv(icb+1) +c@ write(*,*) '++++++++++++++++++++++++++++++++++++++++' +c fin test sb + BUOYBASE = TVPBASE - TVBASE +C +CC Set buoyancy = BUOYBASE for all levels below BASE. +CC For safety, set : BUOY(ICB) = BUOYBASE + DO I = ICB,NL + IF (P(I) .GE. PBASE) THEN + BUOY(I) = BUOYBASE + ENDIF + ENDDO + BUOY(ICB) = BUOYBASE +C +c sb3d print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl' +c sb3d $, buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl +c sb3d print *,'TVP ',(tvp(i),i=1,nl) +c sb3d print *,'TV ',(tv(i),i=1,nl) +c sb3d print *, 'P ',(p(i),i=1,nl) +c sb3d print *,'ICB ',icb +c test sb: +c@ write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' +c@ write(*,*) 'icb,icbs,inb,buoybase:' +c@ write(*,*) icb,icb+1,inb,buoybase +c@ write(*,*) 'k,tvp,tv,tp,buoy,ep: ' +c@ do k=1,nl +c@ write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k) +c@ enddo +c@ write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' +c fin test sb + + +C +C *** MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE *** +C *** AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT *** +C *** AT CLOUD BASE *** +C *** IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING *** +C *** SIG(I) AND W0(I) *** +C +Cjyg +CCC TDIF=TVP(ICB)-TV(ICB) + TDIF = BUOY(ICB) + ATH1=TH(1) +Cjyg +CCC ATH=TH(ICB-1)-1.0 + ATH=TH(ICB-1)-5.0 +c ATH=0. ! ajout sb +c IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb + IF(TDIF.LT.DTCRIT.OR.ATH.GT.ATH1)THEN + DO 60 I=1,NL + SIG(I)=BETA*SIG(I)-2.*ALPHA*TDIF*TDIF + SIG(I)=AMAX1(SIG(I),0.0) + W0(I)=BETA*W0(I) + 60 CONTINUE + IFLAG=0 + RETURN + END IF +C + + +C *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY *** +C *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS *** +C + DO 70 I=1,NL + HP(I)=H(I) + WT(I)=0.001 + RP(I)=RR(I) + UP(I)=U(I) + VP(I)=V(I) + DO 71 J=1,NTRA + TRAP(I,J)=TRA(I,J) + 71 CONTINUE + NENT(I)=0 + WATER(I)=0.0 + EVAP(I)=0.0 + B(I)=0.0 + MP(I)=0.0 + M(I)=0.0 + LV(I)=ALV0-CPVMCL*(T(I)-273.15) + LVCP(I)=LV(I)/CPN(I) + DO 70 J=1,NL + QENT(I,J)=RR(J) + ELIJ(I,J)=0.0 + MENT(I,J)=0.0 + SIJ(I,J)=0.0 + UENT(I,J)=U(J) + VENT(I,J)=V(J) + DO 70 K=1,NTRA + TRAENT(I,J,K)=TRA(J,K) + 70 CONTINUE + + DELTI=1.0/DELT +C +C *** FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S *** +C *** LEVEL OF NEUTRAL BUOYANCY *** +C + INB=NL-1 + DO 80 I=ICB,NL-1 +Cjyg +CCC IF((TVP(I)-TV(I)).LT.DTCRIT)THEN + IF(BUOY(I).LT.DTOVSH)THEN + INB=MIN(INB,I) + END IF + 80 CONTINUE + + + + +C +C *** RESET SIG(I) AND W0(I) FOR I>INB AND IPH(I), PR1=1 & PR2=0 +C Pour PH(I+1) 0.) THEN + pctsrf(i,is_sic) = (pctsrf_old(i,is_oce) + pctsrf_old(i,is_sic)) & + * read_sic1D(i) + pctsrf(i,is_oce) = (pctsrf_old(i,is_oce) + pctsrf_old(i,is_sic)) & + - pctsrf(i,is_sic) + ENDIF + ENDDO + + END IF ! if time to receive + + END SUBROUTINE cpl_receive_frac + +! +!************************************************************************************* +! + + SUBROUTINE cpl_receive_ocean_fields(knon, knindex, tsurf_new, u0_new, v0_new) +! +! This routine returns the field for the ocean that has been read from the coupler +! (done earlier with cpl_receive_frac). The field is the temperature. +! The temperature is transformed into 1D array with valid points from index 1 to knon. +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_ocn_day + INCLUDE "indicesol.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!************************************************************************************* + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: u0_new + REAL, DIMENSION(klon), INTENT(OUT) :: v0_new + +! Local variables +!************************************************************************************* + INTEGER :: i + INTEGER, DIMENSION(klon) :: index + REAL, DIMENSION(klon) :: sic_new + +!************************************************************************************* +! Transform read_sst into compressed 1D variable tsurf_new +! +!************************************************************************************* + CALL cpl2gath(read_sst, tsurf_new, knon, knindex) + CALL cpl2gath(read_sic, sic_new, knon, knindex) + CALL cpl2gath(read_u0, u0_new, knon, knindex) + CALL cpl2gath(read_v0, v0_new, knon, knindex) + +!************************************************************************************* +! Transform read_co2 into uncompressed 1D variable fco2_ocn_day added directly in +! the module carbon_cycle_mod +! +!************************************************************************************* + IF (carbon_cycle_cpl) THEN + DO i=1,klon + index(i)=i + END DO + CALL cpl2gath(read_co2, fco2_ocn_day, klon, index) + END IF + +!************************************************************************************* +! The fields received from the coupler have to be weighted with the fraction of ocean +! in relation to the total sea-ice+ocean +! +!************************************************************************************* + DO i=1, knon + tsurf_new(i) = tsurf_new(i)/(1. - sic_new(i)) + END DO + + END SUBROUTINE cpl_receive_ocean_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_receive_seaice_fields(knon, knindex, & + tsurf_new, alb_new, u0_new, v0_new) +! +! This routine returns the fields for the seaice that have been read from the coupler +! (done earlier with cpl_receive_frac). These fields are the temperature and +! albedo at sea ice surface and fraction of sea ice. +! The fields are transformed into 1D arrays with valid points from index 1 to knon. +! + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!************************************************************************************* + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb_new + REAL, DIMENSION(klon), INTENT(OUT) :: u0_new + REAL, DIMENSION(klon), INTENT(OUT) :: v0_new + +! Local variables +!************************************************************************************* + INTEGER :: i + REAL, DIMENSION(klon) :: sic_new + +!************************************************************************************* +! Transform fields read from coupler from 2D into compressed 1D variables +! +!************************************************************************************* + CALL cpl2gath(read_sit, tsurf_new, knon, knindex) + CALL cpl2gath(read_alb_sic, alb_new, knon, knindex) + CALL cpl2gath(read_sic, sic_new, knon, knindex) + CALL cpl2gath(read_u0, u0_new, knon, knindex) + CALL cpl2gath(read_v0, v0_new, knon, knindex) + +!************************************************************************************* +! The fields received from the coupler have to be weighted with the sea-ice +! concentration (in relation to the total sea-ice + ocean). +! +!************************************************************************************* + DO i= 1, knon + tsurf_new(i) = tsurf_new(i) / sic_new(i) + alb_new(i) = alb_new(i) / sic_new(i) + END DO + + END SUBROUTINE cpl_receive_seaice_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, & + swdown, lwdown, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp) +! +! This subroutine cumulates some fields for each time-step during a coupling +! period. At last time-step in a coupling period the fields are transformed to the +! grid accepted by the coupler. No sending to the coupler will be done from here +! (it is done in cpl_send_seaice_fields). +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: swdown, lwdown + REAL, DIMENSION(klon), INTENT(IN) :: fluxlat, fluxsens + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: evap, tsurf, fder, albsol + REAL, DIMENSION(klon), INTENT(IN) :: taux, tauy, windsp + +! Local variables +!************************************************************************************* + INTEGER :: cpl_index, ig + INTEGER :: error, sum_error + CHARACTER(len = 25) :: modname = 'cpl_send_ocean_fields' + CHARACTER(len = 80) :: abort_message + +!************************************************************************************* +! Start calculation +! The ocean points are saved with second array index=1 +! +!************************************************************************************* + cpl_index = 1 + +!************************************************************************************* +! Reset fields to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN + cpl_sols(1:knon,cpl_index) = 0.0 + cpl_nsol(1:knon,cpl_index) = 0.0 + cpl_rain(1:knon,cpl_index) = 0.0 + cpl_snow(1:knon,cpl_index) = 0.0 + cpl_evap(1:knon,cpl_index) = 0.0 + cpl_tsol(1:knon,cpl_index) = 0.0 + cpl_fder(1:knon,cpl_index) = 0.0 + cpl_albe(1:knon,cpl_index) = 0.0 + cpl_taux(1:knon,cpl_index) = 0.0 + cpl_tauy(1:knon,cpl_index) = 0.0 + cpl_windsp(1:knon,cpl_index) = 0.0 + cpl_taumod(1:knon,cpl_index) = 0.0 + IF (carbon_cycle_cpl) cpl_atm_co2(1:knon,cpl_index) = 0.0 + ENDIF + +!************************************************************************************* +! Cumulate at each time-step +! +!************************************************************************************* + DO ig = 1, knon + cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + & + swdown(ig) / REAL(nexca) + cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + & + (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / REAL(nexca) + cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + & + precip_rain(ig) / REAL(nexca) + cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + & + precip_snow(ig) / REAL(nexca) + cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + & + evap(ig) / REAL(nexca) + cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + & + tsurf(ig) / REAL(nexca) + cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + & + fder(ig) / REAL(nexca) + cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + & + albsol(ig) / REAL(nexca) + cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + & + taux(ig) / REAL(nexca) + cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + & + tauy(ig) / REAL(nexca) + cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + & + windsp(ig) / REAL(nexca) + cpl_taumod(ig,cpl_index) = cpl_taumod(ig,cpl_index) + & + SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / REAL (nexca) + + IF (carbon_cycle_cpl) THEN + cpl_atm_co2(ig,cpl_index) = cpl_atm_co2(ig,cpl_index) + & + co2_send(knindex(ig))/ REAL(nexca) + END IF + ENDDO + +!************************************************************************************* +! If the time-step corresponds to the end of coupling period the +! fields are transformed to the 2D grid. +! No sending to the coupler (it is done from cpl_send_seaice_fields). +! +!************************************************************************************* + IF (MOD(itime, nexca) == 0) THEN + + IF (.NOT. ALLOCATED(cpl_sols2D)) THEN + sum_error = 0 + ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taumod2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + + IF (carbon_cycle_cpl) THEN + ALLOCATE(cpl_atm_co22D(iim,jj_nb), stat=error) + sum_error = sum_error + error + END IF + + IF (sum_error /= 0) THEN + abort_message='Pb allocation variables couplees pour l''ecriture' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + + CALL gath2cpl(cpl_sols(:,cpl_index), cpl_sols2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_nsol(:,cpl_index), cpl_nsol2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_rain(:,cpl_index), cpl_rain2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_snow(:,cpl_index), cpl_snow2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_evap(:,cpl_index), cpl_evap2D(:,:,cpl_index), & + knon, knindex) + +! cpl_tsol2D(:,:,:) not used! + CALL gath2cpl(cpl_tsol(:,cpl_index), cpl_tsol2D(:,:, cpl_index), & + knon, knindex) + +! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)! + CALL gath2cpl(cpl_fder(:,cpl_index), cpl_fder2D(:,:,cpl_index), & + knon, knindex) + +! cpl_albe2D(:,:,:) not used! + CALL gath2cpl(cpl_albe(:,cpl_index), cpl_albe2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_taux(:,cpl_index), cpl_taux2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_tauy(:,cpl_index), cpl_tauy2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_windsp(:,cpl_index), cpl_windsp2D(:,:), & + knon, knindex) + + CALL gath2cpl(cpl_taumod(:,cpl_index), cpl_taumod2D(:,:,cpl_index), & + knon, knindex) + + IF (carbon_cycle_cpl) & + CALL gath2cpl(cpl_atm_co2(:,cpl_index), cpl_atm_co22D(:,:), knon, knindex) + ENDIF + + END SUBROUTINE cpl_send_ocean_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, & + pctsrf, lafin, rlon, rlat, & + swdown, lwdown, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy) +! +! This subroutine cumulates some fields for each time-step during a coupling +! period. At last time-step in a coupling period the fields are transformed to the +! grid accepted by the coupler. All fields for all types of surfaces are sent to +! the coupler. +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swdown, lwdown + REAL, DIMENSION(klon), INTENT(IN) :: fluxlat, fluxsens + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: evap, tsurf, fder + REAL, DIMENSION(klon), INTENT(IN) :: albsol, taux, tauy + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + LOGICAL, INTENT(IN) :: lafin + +! Local variables +!************************************************************************************* + INTEGER :: cpl_index, ig + INTEGER :: error, sum_error + CHARACTER(len = 25) :: modname = 'cpl_send_seaice_fields' + CHARACTER(len = 80) :: abort_message + REAL, DIMENSION(klon) :: cpl_fder_tmp + +!************************************************************************************* +! Start calulation +! The sea-ice points are saved with second array index=2 +! +!************************************************************************************* + cpl_index = 2 + +!************************************************************************************* +! Reset fields to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN + cpl_sols(1:knon,cpl_index) = 0.0 + cpl_nsol(1:knon,cpl_index) = 0.0 + cpl_rain(1:knon,cpl_index) = 0.0 + cpl_snow(1:knon,cpl_index) = 0.0 + cpl_evap(1:knon,cpl_index) = 0.0 + cpl_tsol(1:knon,cpl_index) = 0.0 + cpl_fder(1:knon,cpl_index) = 0.0 + cpl_albe(1:knon,cpl_index) = 0.0 + cpl_taux(1:knon,cpl_index) = 0.0 + cpl_tauy(1:knon,cpl_index) = 0.0 + cpl_taumod(1:knon,cpl_index) = 0.0 + ENDIF + +!************************************************************************************* +! Cumulate at each time-step +! +!************************************************************************************* + DO ig = 1, knon + cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + & + swdown(ig) / REAL(nexca) + cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + & + (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / REAL(nexca) + cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + & + precip_rain(ig) / REAL(nexca) + cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + & + precip_snow(ig) / REAL(nexca) + cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + & + evap(ig) / REAL(nexca) + cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + & + tsurf(ig) / REAL(nexca) + cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + & + fder(ig) / REAL(nexca) + cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + & + albsol(ig) / REAL(nexca) + cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + & + taux(ig) / REAL(nexca) + cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + & + tauy(ig) / REAL(nexca) + cpl_taumod(ig,cpl_index) = cpl_taumod(ig,cpl_index) + & + SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / REAL(nexca) + ENDDO + +!************************************************************************************* +! If the time-step corresponds to the end of coupling period the +! fields are transformed to the 2D grid and all fields are sent to coupler. +! +!************************************************************************************* + IF (MOD(itime, nexca) == 0) THEN + IF (.NOT. ALLOCATED(cpl_sols2D)) THEN + sum_error = 0 + ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error) + sum_error = sum_error + error + ALLOCATE(cpl_taumod2D(iim,jj_nb,2), stat=error) + sum_error = sum_error + error + + IF (carbon_cycle_cpl) THEN + ALLOCATE(cpl_atm_co22D(iim,jj_nb), stat=error) + sum_error = sum_error + error + END IF + + IF (sum_error /= 0) THEN + abort_message='Pb allocation variables couplees pour l''ecriture' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + CALL gath2cpl(cpl_sols(:,cpl_index), cpl_sols2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_nsol(:,cpl_index), cpl_nsol2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_rain(:,cpl_index), cpl_rain2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_snow(:,cpl_index), cpl_snow2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_evap(:,cpl_index), cpl_evap2D(:,:,cpl_index), & + knon, knindex) + +! cpl_tsol2D(:,:,:) not used! + CALL gath2cpl(cpl_tsol(:,cpl_index), cpl_tsol2D(:,:, cpl_index), & + knon, knindex) + + ! Set default value and decompress before gath2cpl + cpl_fder_tmp(:) = -20. + DO ig = 1, knon + cpl_fder_tmp(knindex(ig))=cpl_fder(ig,cpl_index) + END DO + CALL gath2cpl(cpl_fder_tmp(:), cpl_fder2D(:,:,cpl_index), & + klon, unity) + +! cpl_albe2D(:,:,:) not used! + CALL gath2cpl(cpl_albe(:,cpl_index), cpl_albe2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_taux(:,cpl_index), cpl_taux2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_tauy(:,cpl_index), cpl_tauy2D(:,:,cpl_index), & + knon, knindex) + + CALL gath2cpl(cpl_taumod(:,cpl_index), cpl_taumod2D(:,:,cpl_index), & + knon, knindex) + + ! Send all fields + CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat) + ENDIF + + END SUBROUTINE cpl_send_seaice_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in) +! +! This subroutine cumulates some fields for each time-step during a coupling +! period. At last time-step in a coupling period the fields are transformed to the +! grid accepted by the coupler. No sending to the coupler will be done from here +! (it is done in cpl_send_seaice_fields). +! + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: rriv_in + REAL, DIMENSION(klon), INTENT(IN) :: rcoa_in + +! Local variables +!************************************************************************************* + REAL, DIMENSION(iim,jj_nb) :: rriv2D + REAL, DIMENSION(iim,jj_nb) :: rcoa2D + +!************************************************************************************* +! Rearrange fields in 2D variables +! First initialize to zero to avoid unvalid points causing problems +! +!************************************************************************************* +!$OMP MASTER + rriv2D(:,:) = 0.0 + rcoa2D(:,:) = 0.0 +!$OMP END MASTER + CALL gath2cpl(rriv_in, rriv2D, knon, knindex) + CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex) + +!************************************************************************************* +! Reset cumulated fields to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN +!$OMP MASTER + cpl_rriv2D(:,:) = 0.0 + cpl_rcoa2D(:,:) = 0.0 +!$OMP END MASTER + ENDIF + +!************************************************************************************* +! Cumulate : Following fields should be cumulated at each time-step +! +!************************************************************************************* +!$OMP MASTER + cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / REAL(nexca) + cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / REAL(nexca) +!$OMP END MASTER + + END SUBROUTINE cpl_send_land_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in) +! This subroutine cumulates the field for melting ice for each time-step +! during a coupling period. This routine will not send to coupler. Sending +! will be done in cpl_send_seaice_fields. +! + + INCLUDE "dimensions.h" + +! Input varibales +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: rlic_in + +! Local varibales +!************************************************************************************* + REAL, DIMENSION(iim,jj_nb) :: rlic2D + +!************************************************************************************* +! Rearrange field in a 2D variable +! First initialize to zero to avoid unvalid points causing problems +! +!************************************************************************************* +!$OMP MASTER + rlic2D(:,:) = 0.0 +!$OMP END MASTER + CALL gath2cpl(rlic_in, rlic2D, knon, knindex) + +!************************************************************************************* +! Reset field to zero in the beginning of a new coupling period +! +!************************************************************************************* + IF (MOD(itime, nexca) == 1) THEN +!$OMP MASTER + cpl_rlic2D(:,:) = 0.0 +!$OMP END MASTER + ENDIF + +!************************************************************************************* +! Cumulate : Melting ice should be cumulated at each time-step +! +!************************************************************************************* +!$OMP MASTER + cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / REAL(nexca) +!$OMP END MASTER + + END SUBROUTINE cpl_send_landice_fields + +! +!************************************************************************************* +! + + SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat) +! This routine will send fields for all different surfaces to the coupler. +! This subroutine should be executed after calculations by the last surface(sea-ice), +! all calculations at the different surfaces have to be done before. +! + USE surface_data + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl +! Some includes +!************************************************************************************* + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: itime + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + LOGICAL, INTENT(IN) :: lafin + +! Local variables +!************************************************************************************* + INTEGER :: error, sum_error, j + INTEGER :: itau_w + INTEGER :: time_sec + INTEGER, DIMENSION(iim*(jjm+1)) :: ndexct + REAL :: Up, Down + REAL, DIMENSION(iim, jj_nb) :: tmp_lon, tmp_lat + REAL, DIMENSION(iim, jj_nb, 4) :: pctsrf2D + REAL, DIMENSION(iim, jj_nb) :: deno + CHARACTER(len = 20) :: modname = 'cpl_send_all' + CHARACTER(len = 80) :: abort_message + +! Variables with fields to coupler + REAL, DIMENSION(iim, jj_nb) :: tmp_taux + REAL, DIMENSION(iim, jj_nb) :: tmp_tauy + REAL, DIMENSION(iim, jj_nb) :: tmp_calv +! Table with all fields to send to coupler + REAL, DIMENSION(iim, jj_nb, maxsend) :: tab_flds + REAL, DIMENSION(klon_mpi) :: rlon_mpi, rlat_mpi + +#ifdef CPP_MPI + INCLUDE 'mpif.h' + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status +#endif + +! End definitions +!************************************************************************************* + + + +!************************************************************************************* +! All fields are stored in a table tab_flds(:,:,:) +! First store the fields which are already on the right format +! +!************************************************************************************* +!$OMP MASTER + tab_flds(:,:,ids_windsp) = cpl_windsp2D(:,:) + tab_flds(:,:,ids_shfice) = cpl_sols2D(:,:,2) + tab_flds(:,:,ids_nsfice) = cpl_nsol2D(:,:,2) + tab_flds(:,:,ids_dflxdt) = cpl_fder2D(:,:,2) + + IF (version_ocean=='nemo') THEN + tab_flds(:,:,ids_liqrun) = cpl_rriv2D(:,:) + cpl_rcoa2D(:,:) + IF (carbon_cycle_cpl) tab_flds(:,:,ids_atmco2)=cpl_atm_co22D(:,:) + ELSE IF (version_ocean=='opa8') THEN + tab_flds(:,:,ids_shfoce) = cpl_sols2D(:,:,1) + tab_flds(:,:,ids_nsfoce) = cpl_nsol2D(:,:,1) + tab_flds(:,:,ids_icevap) = cpl_evap2D(:,:,2) + tab_flds(:,:,ids_ocevap) = cpl_evap2D(:,:,1) + tab_flds(:,:,ids_runcoa) = cpl_rcoa2D(:,:) + tab_flds(:,:,ids_rivflu) = cpl_rriv2D(:,:) + END IF + +!************************************************************************************* +! Transform the fraction of sub-surfaces from 1D to 2D array +! +!************************************************************************************* + pctsrf2D(:,:,:) = 0. +!$OMP END MASTER + CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity) + CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity) + CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity) + +!************************************************************************************* +! Calculate the average calving per latitude +! Store calving in tab_flds(:,:,19) +! +!************************************************************************************* + IF (is_omp_root) THEN + + DO j = 1, jj_nb + tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), & + pctsrf2D(1:iim,j,is_lic)) / REAL(iim) + ENDDO + + + IF (is_parallel) THEN + IF (.NOT. is_north_pole) THEN +#ifdef CPP_MPI + CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error) + CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error) +#endif + ENDIF + + IF (.NOT. is_south_pole) THEN +#ifdef CPP_MPI + CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error) + CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error) +#endif + ENDIF + + IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN + Up=Up+tmp_calv(iim,1) + tmp_calv(:,1)=Up + ENDIF + + IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN + Down=Down+tmp_calv(1,jj_nb) + tmp_calv(:,jj_nb)=Down + ENDIF + ENDIF + + tab_flds(:,:,ids_calvin) = tmp_calv(:,:) + +!************************************************************************************* +! Calculate total flux for snow, rain and wind with weighted addition using the +! fractions of ocean and seaice. +! +!************************************************************************************* + ! fraction oce+seaice + deno = pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic) + + IF (version_ocean=='nemo') THEN + tab_flds(:,:,ids_shftot) = 0.0 + tab_flds(:,:,ids_nsftot) = 0.0 + tab_flds(:,:,ids_totrai) = 0.0 + tab_flds(:,:,ids_totsno) = 0.0 + tab_flds(:,:,ids_toteva) = 0.0 + tab_flds(:,:,ids_taumod) = 0.0 + + tmp_taux(:,:) = 0.0 + tmp_tauy(:,:) = 0.0 + ! For all valid grid cells containing some fraction of ocean or sea-ice + WHERE ( deno(:,:) /= 0 ) + tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + + tab_flds(:,:,ids_shftot) = cpl_sols2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_sols2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_nsftot) = cpl_nsol2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_nsol2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_totrai) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_totsno) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_toteva) = cpl_evap2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_evap2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_taumod) = cpl_taumod2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_taumod2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + + ENDWHERE + + tab_flds(:,:,ids_icevap) = cpl_evap2D(:,:,2) + + ELSE IF (version_ocean=='opa8') THEN + ! Store fields for rain and snow in tab_flds(:,:,15) and tab_flds(:,:,16) + tab_flds(:,:,ids_totrai) = 0.0 + tab_flds(:,:,ids_totsno) = 0.0 + tmp_taux(:,:) = 0.0 + tmp_tauy(:,:) = 0.0 + ! For all valid grid cells containing some fraction of ocean or sea-ice + WHERE ( deno(:,:) /= 0 ) + tab_flds(:,:,ids_totrai) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tab_flds(:,:,ids_totsno) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + + tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) + & + cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) + ENDWHERE + END IF + + ENDIF ! is_omp_root + +!************************************************************************************* +! Transform the wind components from local atmospheric 2D coordinates to geocentric +! 3D coordinates. +! Store the resulting wind components in tab_flds(:,:,1:6) +!************************************************************************************* + +! Transform the longitudes and latitudes on 2D arrays + + CALL gather_omp(rlon,rlon_mpi) + CALL gather_omp(rlat,rlat_mpi) +!$OMP MASTER + CALL Grid1DTo2D_mpi(rlon_mpi,tmp_lon) + CALL Grid1DTo2D_mpi(rlat_mpi,tmp_lat) +!$OMP END MASTER + + IF (is_sequential) THEN + IF (is_north_pole) tmp_lon(:,1) = tmp_lon(:,2) + IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm) + ENDIF + +! NetCDF output of the wind before transformation of coordinate system + IF (is_sequential) THEN + ndexct(:) = 0 + itau_w = itau_phy + itime + CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct) + CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct) + CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct) + CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct) + ENDIF + +! Transform the wind from spherical atmospheric 2D coordinates to geocentric +! cartesian 3D coordinates +!$OMP MASTER + CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, & + tab_flds(:,:,ids_tauxxu), tab_flds(:,:,ids_tauyyu), tab_flds(:,:,ids_tauzzu) ) + + tab_flds(:,:,ids_tauxxv) = tab_flds(:,:,ids_tauxxu) + tab_flds(:,:,ids_tauyyv) = tab_flds(:,:,ids_tauyyu) + tab_flds(:,:,ids_tauzzv) = tab_flds(:,:,ids_tauzzu) +!$OMP END MASTER + +!************************************************************************************* +! NetCDF output of all fields just before sending to coupler. +! +!************************************************************************************* + IF (is_sequential) THEN + DO j=1,maxsend + IF (infosend(j)%action) CALL histwrite(nidct,infosend(j)%name, itau_w, & + tab_flds(:,:,j),iim*(jjm+1),ndexct) + ENDDO + ENDIF +!************************************************************************************* +! Send the table of all fields +! +!************************************************************************************* + time_sec=(itime-1)*dtime +#ifdef CPP_COUPLE +!$OMP MASTER + CALL intocpl(time_sec, lafin, tab_flds(:,:,:)) +!$OMP END MASTER +#endif + +!************************************************************************************* +! Finish with some dellocate +! +!************************************************************************************* + sum_error=0 + DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error ) + sum_error = sum_error + error + DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error ) + sum_error = sum_error + error + DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, cpl_taumod2D, stat=error ) + sum_error = sum_error + error + + IF (carbon_cycle_cpl) THEN + DEALLOCATE(cpl_atm_co22D, stat=error ) + sum_error = sum_error + error + END IF + + IF (sum_error /= 0) THEN + abort_message='Pb in deallocation of cpl_xxxx2D coupling variables' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + END SUBROUTINE cpl_send_all +! +!************************************************************************************* +! + SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex) + USE mod_phys_lmdz_para +! Cette routine transforme un champs de la grille 2D recu du coupleur sur la grille +! 'gathered' (la grille physiq comprime). +! +! +! input: +! champ_in champ sur la grille 2D +! knon nombre de points dans le domaine a traiter +! knindex index des points de la surface a traiter +! +! output: +! champ_out champ sur la grille 'gatherd' +! + INCLUDE "dimensions.h" + +! Input + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(iim,jj_nb), INTENT(IN) :: champ_in + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output + REAL, DIMENSION(klon_mpi), INTENT(OUT) :: champ_out + +! Local + INTEGER :: i, ig + REAL, DIMENSION(klon_mpi) :: temp_mpi + REAL, DIMENSION(klon) :: temp_omp + +!************************************************************************************* +! + + +! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon) +!$OMP MASTER + CALL Grid2Dto1D_mpi(champ_in,temp_mpi) +!$OMP END MASTER + + CALL scatter_omp(temp_mpi,temp_omp) + +! Compress from klon to knon + DO i = 1, knon + ig = knindex(i) + champ_out(i) = temp_omp(ig) + ENDDO + + END SUBROUTINE cpl2gath +! +!************************************************************************************* +! + SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex) + USE mod_phys_lmdz_para +! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer +! au coupleur. +! +! input: +! champ_in champ sur la grille gathere +! knon nombre de points dans le domaine a traiter +! knindex index des points de la surface a traiter +! +! output: +! champ_out champ sur la grille 2D +! + INCLUDE "dimensions.h" + +! Input arguments +!************************************************************************************* + INTEGER, INTENT(IN) :: knon + REAL, DIMENSION(klon), INTENT(IN) :: champ_in + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!************************************************************************************* + REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out + +! Local variables +!************************************************************************************* + INTEGER :: i, ig + REAL, DIMENSION(klon) :: temp_omp + REAL, DIMENSION(klon_mpi) :: temp_mpi +!************************************************************************************* + +! Decompress from knon to klon + temp_omp = 0. + DO i = 1, knon + ig = knindex(i) + temp_omp(ig) = champ_in(i) + ENDDO + +! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb) + CALL gather_omp(temp_omp,temp_mpi) + +!$OMP MASTER + CALL Grid1Dto2D_mpi(temp_mpi,champ_out) + + IF (is_north_pole) champ_out(:,1)=temp_mpi(1) + IF (is_south_pole) champ_out(:,jj_nb)=temp_mpi(klon) +!$OMP END MASTER + + END SUBROUTINE gath2cpl +! +!************************************************************************************* +! +END MODULE cpl_mod + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv30_routines.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv30_routines.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv30_routines.F (revision 1634) @@ -0,0 +1,3150 @@ +! +! $Id$ +! +c +c + SUBROUTINE cv30_param(nd,delt) + implicit none + +c------------------------------------------------------------ +c Set parameters for convectL for iflag_con = 3 +c------------------------------------------------------------ + +C +C *** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** +C *** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** +C *** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** +C *** EFFICIENCY IS ASSUMED TO BE UNITY *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C +C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA] +C *** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** +C *** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** +C +C *** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** IT MUST BE LESS THAN 0 *** + +#include "cv30param.h" +#include "conema3.h" + + integer nd + real delt ! timestep (seconds) + +c noff: integer limit for convection (nd-noff) +c minorig: First level of convection + +c -- limit levels for convection: + + noff = 1 + minorig = 1 + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + +c -- "microphysical" parameters: + + sigd = 0.01 + spfac = 0.15 + pbcrit = 150.0 + ptcrit = 500.0 +cIM cf. FH epmax = 0.993 + + omtrain = 45.0 ! used also for snow (no disctinction rain/snow) + +c -- misc: + + dtovsh = -0.2 ! dT for overshoot + dpbase = -40. ! definition cloud base (400m above LCL) + dttrig = 5. ! (loose) condition for triggering + +c -- rate of approach to quasi-equilibrium: + + dtcrit = -2.0 + tau = 8000. + beta = 1.0 - delt/tau + alpha = 1.5E-3 * delt/tau +c increase alpha to compensate W decrease: + alpha = alpha*1.5 + +c -- interface cloud parameterization: + + delta=0.01 ! cld + +c -- interface with boundary-layer (gust factor): (sb) + + betad=10.0 ! original value (from convect 4.3) + + return + end + + SUBROUTINE cv30_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,cpn,tv,gz,h,hm,th) + implicit none + +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +! "ori": from convect4.3 (vectorized) +! "convect3": to be exactly consistent with convect3 +!===================================================================== + +c inputs: + integer len, nd, ndp1 + real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1) + +c outputs: + real lv(len,nd), cpn(len,nd), tv(len,nd) + real gz(len,nd), h(len,nd), hm(len,nd) + real th(len,nd) + +c local variables: + integer k, i + real rdcp + real tvx,tvy ! convect3 + real cpx(len,nd) + +#include "cvthermo.h" +#include "cv30param.h" + + +c ori do 110 k=1,nlp + do 110 k=1,nl ! convect3 + do 100 i=1,len +cdebug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + lv(i,k)= lv0-clmcpv*(t(i,k)-273.15) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) +c ori tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k)) + rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k) + th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue +c ori do 140 k=2,nlp + do 140 k=2,nl ! convect3 + do 130 i=1,len + tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k)) !convect3 + tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3 + gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy) !convect3 + & *(p(i,k-1)-p(i,k))/ph(i,k) !convect3 + +c ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) +c ori & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c +c ori do 170 k=1,nlp + do 170 k=1,nl ! convect3 + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv30_feed(len,nd,t,q,qs,p,ph,hm,gz + : ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl) + implicit none + +C================================================================ +C Purpose: CONVECTIVE FEED +C +C Main differences with cv_feed: +C - ph added in input +C - here, nk(i)=minorig +C - icb defined differently (plcl compared with ph instead of p) +C +C Main differences with convect3: +C - we do not compute dplcldt and dplcldr of CLIFT anymore +C - values iflag different (but tests identical) +C - A,B explicitely defined (!...) +C================================================================ + +#include "cv30param.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), qs(len,nd), p(len,nd) + real hm(len,nd), gz(len,nd) + real ph(len,nd+1) + +c outputs: + integer iflag(len), nk(len), icb(len), icbmax + real tnk(len), qnk(len), gznk(len), plcl(len) + +c local variables: + integer i, k + integer ihmin(len) + real work(len) + real pnk(len), qsnk(len), rh(len), chi(len) + real A, B ! convect3 +cym + plcl=0.0 +c@ !------------------------------------------------------------------- +c@ ! --- Find level of minimum moist static energy +c@ ! --- If level of minimum moist static energy coincides with +c@ ! --- or is lower than minimum allowable parcel origin level, +c@ ! --- set iflag to 6. +c@ !------------------------------------------------------------------- +c@ +c@ do 180 i=1,len +c@ work(i)=1.0e12 +c@ ihmin(i)=nl +c@ 180 continue +c@ do 200 k=2,nlp +c@ do 190 i=1,len +c@ if((hm(i,k).lt.work(i)).and. +c@ & (hm(i,k).lt.hm(i,k-1)))then +c@ work(i)=hm(i,k) +c@ ihmin(i)=k +c@ endif +c@ 190 continue +c@ 200 continue +c@ do 210 i=1,len +c@ ihmin(i)=min(ihmin(i),nlm) +c@ if(ihmin(i).le.minorig)then +c@ iflag(i)=6 +c@ endif +c@ 210 continue +c@ c +c@ !------------------------------------------------------------------- +c@ ! --- Find that model level below the level of minimum moist static +c@ ! --- energy that has the maximum value of moist static energy +c@ !------------------------------------------------------------------- +c@ +c@ do 220 i=1,len +c@ work(i)=hm(i,minorig) +c@ nk(i)=minorig +c@ 220 continue +c@ do 240 k=minorig+1,nl +c@ do 230 i=1,len +c@ if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then +c@ work(i)=hm(i,k) +c@ nk(i)=k +c@ endif +c@ 230 continue +c@ 240 continue + +!------------------------------------------------------------------- +! --- Origin level of ascending parcels for convect3: +!------------------------------------------------------------------- + + do 220 i=1,len + nk(i)=minorig + 220 continue + +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if( ( ( t(i,nk(i)).lt.250.0 ) + & .or.( q(i,nk(i)).le.0.0 ) ) +c@ & .or.( p(i,ihmin(i)).lt.400.0 ) ) + & .and. + & ( iflag(i).eq.0) ) iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- Calculate lifted condensation level of air at parcel origin level +! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) +!------------------------------------------------------------------- + + A = 1669.0 ! convect3 + B = 122.0 ! convect3 + + do 260 i=1,len + + if (iflag(i).ne.7) then ! modif sb Jun7th 2002 + + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) +c ori rh(i)=min(1.0,rh(i)) ! removed for convect3 +c ori chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3 + plcl(i)=pnk(i)*(rh(i)**chi(i)) + if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0)) + & .and.(iflag(i).eq.0))iflag(i)=8 + + endif ! iflag=7 + + 260 continue + +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + +c@ do 270 i=1,len +c@ icb(i)=nlm +c@ 270 continue +c@c +c@ do 290 k=minorig,nl +c@ do 280 i=1,len +c@ if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) +c@ & icb(i)=min(icb(i),k) +c@ 280 continue +c@ 290 continue +c@c +c@ do 300 i=1,len +c@ if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 +c@ 300 continue + + do 270 i=1,len + icb(i)=nlm + 270 continue +c +c la modification consiste a comparer plcl a ph et non a p: +c icb est defini par : ph(icb)p(icb), then icbs=icb +c +c * the routine above computes tvp from minorig to icbs (included). +c +c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1) +c must be known. This is the case if icbs=icb+1, but not if icbs=icb. +c +c * therefore, in the case icbs=icb, we compute tvp at level icb+1 +c (tvp at other levels will be computed in cv3_undilute2.F) +c + + do i=1,len + ticb(i)=t(i,icb(i)+1) + gzicb(i)=gz(i,icb(i)+1) + qsicb(i)=qs(i,icb(i)+1) + enddo + + do 460 i=1,len + tg=ticb(i) + qg=qsicb(i) ! convect3 +cdebug alv=lv0-clmcpv*(ticb(i)-t0) + alv=lv0-clmcpv*(ticb(i)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) +c +c Second iteration. +c + +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori end if +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) + + alv=lv0-clmcpv*(ticb(i)-273.15) + +c ori c approximation here: +c ori tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) +c ori & -gz(i,icb(i))-alv*qg)/cpd + +c convect3: no approximation: + tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg) + : /(cpd+(cl-cpd)*qnk(i)) + +c ori clw(i,icb(i))=qnk(i)-qg +c ori clw(i,icb(i))=max(0.0,clw(i,icb(i))) + clw(i,icb(i)+1)=qnk(i)-qg + clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1)) + + rg=qg/(1.-qnk(i)) +c ori tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg) + tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing + + 460 continue + + return + end + + SUBROUTINE cv30_trigger(len,nd,icb,plcl,p,th,tv,tvp + o ,pbase,buoybase,iflag,sig,w0) + implicit none + +!------------------------------------------------------------------- +! --- TRIGGERING +! +! - computes the cloud base +! - triggering (crude in this version) +! - relaxation of sig and w0 when no convection +! +! Caution1: if no convection, we set iflag=4 +! (it used to be 0 in convect3) +! +! Caution2: at this stage, tvp (and thus buoy) are know up +! through icb only! +! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy +!------------------------------------------------------------------- + +#include "cv30param.h" + +c input: + integer len, nd + integer icb(len) + real plcl(len), p(len,nd) + real th(len,nd), tv(len,nd), tvp(len,nd) + +c output: + real pbase(len), buoybase(len) + +c input AND output: + integer iflag(len) + real sig(len,nd), w0(len,nd) + +c local variables: + integer i,k + real tvpbase, tvbase, tdif, ath, ath1 + +c +c *** set cloud base buoyancy at (plcl+dpbase) level buoyancy +c + do 100 i=1,len + pbase(i) = plcl(i) + dpbase + tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + buoybase(i) = tvpbase - tvbase +100 continue + +c +c *** make sure that column is dry adiabatic between the surface *** +c *** and cloud base, and that lifted air is positively buoyant *** +c *** at cloud base *** +c *** if not, return to calling program after resetting *** +c *** sig(i) and w0(i) *** +c + +c oct3 do 200 i=1,len +c oct3 +c oct3 tdif = buoybase(i) +c oct3 ath1 = th(i,1) +c oct3 ath = th(i,icb(i)-1) - dttrig +c oct3 +c oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then +c oct3 do 60 k=1,nl +c oct3 sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif +c oct3 sig(i,k) = AMAX1(sig(i,k),0.0) +c oct3 w0(i,k) = beta*w0(i,k) +c oct3 60 continue +c oct3 iflag(i)=4 ! pour version vectorisee +c oct3c convect3 iflag(i)=0 +c oct3cccc return +c oct3 endif +c oct3 +c oct3200 continue + +c -- oct3: on reecrit la boucle 200 (pour la vectorisation) + + do 60 k=1,nl + do 200 i=1,len + + tdif = buoybase(i) + ath1 = th(i,1) + ath = th(i,icb(i)-1) - dttrig + + if (tdif.lt.dtcrit .or. ath.gt.ath1) then + sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif + sig(i,k) = AMAX1(sig(i,k),0.0) + w0(i,k) = beta*w0(i,k) + iflag(i)=4 ! pour version vectorisee +c convect3 iflag(i)=0 + endif + +200 continue + 60 continue + +c fin oct3 -- + + return + end + + SUBROUTINE cv30_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1 + : ,t1,q1,qs1,u1,v1,gz1,th1 + : ,tra1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + : ,sig1,w01 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,pbase,buoybase + o ,t,q,qs,u,v,gz,th + o ,tra + o ,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,sig,w0 ) + implicit none + +#include "cv30param.h" + include 'iniprint.h' + +c inputs: + integer len,ncum,nd,ntra,nloc + integer iflag1(len),nk1(len),icb1(len),icbs1(len) + real plcl1(len),tnk1(len),qnk1(len),gznk1(len) + real pbase1(len),buoybase1(len) + real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd) + real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd) + real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd) + real tvp1(len,nd),clw1(len,nd) + real th1(len,nd) + real sig1(len,nd), w01(len,nd) + real tra1(len,nd,ntra) + +c outputs: +c en fait, on a nloc=len pour l'instant (cf cv_driver) + integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc) + real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real pbase(nloc),buoybase(nloc) + real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd) + real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd) + real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd) + real tvp(nloc,nd),clw(nloc,nd) + real th(nloc,nd) + real sig(nloc,nd), w0(nloc,nd) + real tra(nloc,nd,ntra) + +c local variables: + integer i,k,nn,j + + CHARACTER (LEN=20) :: modname='cv30_compress' + CHARACTER (LEN=80) :: abort_message + + + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + sig(nn,k)=sig1(i,k) + w0(nn,k)=w01(i,k) + 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) + th(nn,k)=th1(i,k) + endif + 100 continue + 110 continue + +c do 121 j=1,ntra +c do 111 k=1,nd +c nn=0 +c do 101 i=1,len +c if(iflag1(i).eq.0)then +c nn=nn+1 +c tra(nn,k,j)=tra1(i,k,j) +c endif +c 101 continue +c 111 continue +c 121 continue + + if (nn.ne.ncum) then + write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + endif + + nn=0 + do 150 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + pbase(nn)=pbase1(i) + buoybase(nn)=buoybase1(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) + icbs(nn)=icbs1(i) + iflag(nn)=iflag1(i) + endif + 150 continue + + return + end + + SUBROUTINE cv30_undilute2(nloc,ncum,nd,icb,icbs,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + implicit none + +C--------------------------------------------------------------------- +C Purpose: +C FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +C & +C COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +C FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +C & +C FIND THE LEVEL OF NEUTRAL BUOYANCY +C +C Main differences convect3/convect4: +C - icbs (input) is the first level above LCL (may differ from icb) +C - many minor differences in the iterations +C - condensed water not removed from tvp in convect3 +C - vertical profile of buoyancy computed here (use of buoybase) +C - the determination of inb is different +C - no inb1, only inb in output +C--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cv30param.h" +#include "conema3.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), icbs(nloc), nk(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) + real p(nloc,nd) + real tnk(nloc), qnk(nloc), gznk(nloc) + real lv(nloc,nd), tv(nloc,nd), h(nloc,nd) + real pbase(nloc), buoybase(nloc), plcl(nloc) + +c outputs: + integer inb(nloc) + real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) + real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) + real buoy(nloc,nd) + +c local variables: + integer i, k + real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit + real by, defrac, pden + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=spfac + 160 continue + 170 continue + +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) +cdebug & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum +c ori if(k.ge.(icb(i)+1))then + if(k.ge.(icbs(i)+1))then ! convect3 + tg=t(i,k) + qg=qs(i,k) +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + +c ori c approximation here: +c ori tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd + +c convect3: no approximation: + tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) + + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) +c ori tvp(i,k)=tp(i,k)*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg): + tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== +c +c ori do 320 k=minorig+1,nl + do 320 k=1,nl ! convect3 + do 310 i=1,ncum + pden=ptcrit-pbcrit + ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax + ep(i,k)=amax1(ep(i,k),0.0) + ep(i,k)=amin1(ep(i,k),epmax) + sigp(i,k)=spfac +c ori if(k.ge.(nk(i)+1))then +c ori tca=tp(i,k)-t0 +c ori if(tca.ge.0.0)then +c ori elacrit=elcrit +c ori else +c ori elacrit=elcrit*(1.0-tca/tlcrit) +c ori endif +c ori elacrit=max(elacrit,0.0) +c ori ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) +c ori ep(i,k)=max(ep(i,k),0.0 ) +c ori ep(i,k)=min(ep(i,k),1.0 ) +c ori sigp(i,k)=sigs +c ori endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c +c dans convect3, tvp est calcule en une seule fois, et sans retirer +c l'eau condensee (~> reversible CAPE) +c +c ori do 340 k=minorig+1,nl +c ori do 330 i=1,ncum +c ori if(k.ge.(icb(i)+1))then +c ori tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) +c ori endif +c ori 330 continue +c ori 340 continue + +c ori do 350 i=1,ncum +c ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd +c ori 350 continue + + do 350 i=1,ncum ! convect3 + tp(i,nlp)=tp(i,nl) ! convect3 + 350 continue ! convect3 +c +c===================================================================== +c --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only): +c===================================================================== + +c-- this is for convect3 only: + +c first estimate of buoyancy: + + do 500 i=1,ncum + do 501 k=1,nl + buoy(i,k)=tvp(i,k)-tv(i,k) + 501 continue + 500 continue + +c set buoyancy=buoybase for all levels below base +c for safety, set buoy(icb)=buoybase + + do 505 i=1,ncum + do 506 k=1,nl + if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then + buoy(i,k)=buoybase(i) + endif + 506 continue +cIM cf. CRio/JYG 270807 buoy(icb(i),k)=buoybase(i) + buoy(i,icb(i))=buoybase(i) + 505 continue + +c-- end convect3 + +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S +c --- LEVEL OF NEUTRAL BUOYANCY +c===================================================================== +c +c-- this is for convect3 only: + + do 510 i=1,ncum + inb(i)=nl-1 + 510 continue + + do 530 i=1,ncum + do 535 k=1,nl-1 + if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then + inb(i)=MIN(inb(i),k) + endif + 535 continue + 530 continue + +c-- end convect3 + +c ori do 510 i=1,ncum +c ori cape(i)=0.0 +c ori capem(i)=0.0 +c ori inb(i)=icb(i)+1 +c ori inb1(i)=inb(i) +c ori 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c +c ori call zilch(byp,ncum) +c ori do 515 i=1,ncum +c ori lcape(i)=.true. +c ori 515 continue +c ori do 530 k=minorig+1,nl-1 +c ori do 520 i=1,ncum +c ori if(cape(i).lt.0.0)lcape(i)=.false. +c ori if((k.ge.(icb(i)+1)).and.lcape(i))then +c ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c ori cape(i)=cape(i)+by +c ori if(by.ge.0.0)inb1(i)=k+1 +c ori if(cape(i).gt.0.0)then +c ori inb(i)=k+1 +c ori capem(i)=cape(i) +c ori endif +c ori endif +c ori 520 continue +c ori 530 continue +c ori do 540 i=1,ncum +c ori cape(i)=capem(i)+byp(i) +c ori defrac=capem(i)-cape(i) +c ori defrac=max(defrac,0.001) +c ori frac(i)=-cape(i)/defrac +c ori frac(i)=min(frac(i),1.0) +c ori frac(i)=max(frac(i),0.0) +c ori 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c +cym do i=1,ncum*nlp +cym hp(i,1)=h(i,1) +cym enddo + + do k=1,nlp + do i=1,ncum + hp(i,k)=h(i,k) + enddo + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue + + return + end + + SUBROUTINE cv30_closure(nloc,ncum,nd,icb,inb + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m) + implicit none + +!=================================================================== +! --- CLOSURE OF CONVECT3 +! +! vectorization: S. Bony +!=================================================================== + +#include "cvthermo.h" +#include "cv30param.h" + +c input: + integer ncum, nd, nloc + integer icb(nloc), inb(nloc) + real pbase(nloc) + real p(nloc,nd), ph(nloc,nd+1) + real tv(nloc,nd), buoy(nloc,nd) + +c input/output: + real sig(nloc,nd), w0(nloc,nd) + +c output: + real cape(nloc) + real m(nloc,nd) + +c local variables: + integer i, j, k, icbmax + real deltap, fac, w, amu + real dtmin(nloc,nd), sigold(nloc,nd) + + +c ------------------------------------------------------- +c -- Initialization +c ------------------------------------------------------- + + do k=1,nl + do i=1,ncum + m(i,k)=0.0 + enddo + enddo + +c ------------------------------------------------------- +c -- Reset sig(i) and w0(i) for i>inb and i qnk(il) +! - vectorisation de la partie normalisation des flux (do 789...) +!--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cv30param.h" + +c inputs: + integer ncum, nd, na, ntra, nloc + integer icb(nloc), inb(nloc), nk(nloc) + real sig(nloc,nd) + real qnk(nloc) + real ph(nloc,nd+1) + real t(nloc,nd), rr(nloc,nd), rs(nloc,nd) + real u(nloc,nd), v(nloc,nd) + real tra(nloc,nd,ntra) ! input of convect3 + real lv(nloc,na), h(nloc,na), hp(nloc,na) + real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na) + real m(nloc,na) ! input of convect3 + +c outputs: + real ment(nloc,na,na), qent(nloc,na,na) + real uent(nloc,na,na), vent(nloc,na,na) + real sij(nloc,na,na), elij(nloc,na,na) + real traent(nloc,nd,nd,ntra) + real ments(nloc,nd,nd), qents(nloc,nd,nd) + real sigij(nloc,nd,nd) + +c local variables: + integer i, j, k, il, im, jm + integer num1, num2 + integer nent(nloc,na) + real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp + real alt, smid, sjmin, sjmax, delp, delm + real asij(nloc), smax(nloc), scrit(nloc) + real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd) + real wgh + real zm(nloc,na) + logical lwork(nloc) + +c===================================================================== +c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== + +c ori do 360 i=1,ncum*nlp + do 361 j=1,nl + do 360 i=1,ncum + nent(i,j)=0 +c in convect3, m is computed in cv3_closure +c ori m(i,1)=0.0 + 360 continue + 361 continue + +c ori do 400 k=1,nlp +c ori do 390 j=1,nlp + do 400 j=1,nl + do 390 k=1,nl + do 385 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 +cym ment(i,k,j)=0.0 +cym sij(i,k,j)=0.0 + 385 continue + 390 continue + 400 continue + +cym + ment(1:ncum,1:nd,1:nd)=0.0 + sij(1:ncum,1:nd,1:nd)=0.0 + +c do k=1,ntra +c do j=1,nd ! instead nlp +c do i=1,nd ! instead nlp +c do il=1,ncum +c traent(il,i,j,k)=tra(il,j,k) +c enddo +c enddo +c enddo +c enddo + zm(:,:)=0. + +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== + + do 750 i=minorig+1, nl + + do 710 j=minorig,nl + do 700 il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then + + rti=rr(il,1)-ep(il,i)*clw(il,i) + bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd) + anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j)) + denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(il,i,j)=anum/dei + sij(il,i,i)=1.0 + altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j) + altem=altem/bf2 + cwat=clw(il,j)*(1.-ep(il,j)) + stemp=sij(il,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat) + : .and.j.gt.i)then + anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2) + denom=denom+lv(il,j)*(rr(il,i)-rti) + if(abs(denom).lt.0.01)denom=0.01 + sij(il,i,j)=anum/denom + altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j) + altem=altem-(bf2-1.)*cwat + end if + if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then + qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti + uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il)) + vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il)) +c!!! do k=1,ntra +c!!! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) +c!!! : +(1.-sij(il,i,j))*tra(il,nk(il),k) +c!!! end do + elij(il,i,j)=altem + elij(il,i,j)=amax1(0.0,elij(il,i,j)) + ment(il,i,j)=m(il,i)/(1.-sij(il,i,j)) + nent(il,i)=nent(il,i)+1 + end if + sij(il,i,j)=amax1(0.0,sij(il,i,j)) + sij(il,i,j)=amin1(1.0,sij(il,i,j)) + endif ! new + 700 continue + 710 continue + +c do k=1,ntra +c do j=minorig,nl +c do il=1,ncum +c if( (i.ge.icb(il)).and.(i.le.inb(il)).and. +c : (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then +c traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k) +c : +(1.-sij(il,i,j))*tra(il,nk(il),k) +c endif +c enddo +c enddo +c enddo + +c +c *** if no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + +c@ do 170 i=icb(il),inb(il) + + do 740 il=1,ncum + if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then +c@ if(nent(il,i).eq.0)then + ment(il,i,i)=m(il,i) + qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i) + uent(il,i,i)=u(il,nk(il)) + vent(il,i,i)=v(il,nk(il)) + elij(il,i,i)=clw(il,i) +cMAF sij(il,i,i)=1.0 + sij(il,i,i)=0.0 + end if + 740 continue + 750 continue + +c do j=1,ntra +c do i=minorig+1,nl +c do il=1,ncum +c if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then +c traent(il,i,i,j)=tra(il,nk(il),j) +c endif +c enddo +c enddo +c enddo + + do 100 j=minorig,nl + do 101 i=minorig,nl + do 102 il=1,ncum + if ((j.ge.(icb(il)-1)).and.(j.le.inb(il)) + : .and.(i.ge.icb(il)).and.(i.le.inb(il)))then + sigij(il,i,j)=sij(il,i,j) + endif + 102 continue + 101 continue + 100 continue +c@ enddo + +c@170 continue + +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== + +cym call zilch(asum,ncum*nd) +cym call zilch(bsum,ncum*nd) +cym call zilch(csum,ncum*nd) + call zilch(asum,nloc*nd) + call zilch(csum,nloc*nd) + call zilch(csum,nloc*nd) + + do il=1,ncum + lwork(il) = .FALSE. + enddo + + DO 789 i=minorig+1,nl + + num1=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1 + enddo + if (num1.le.0) goto 789 + + + do 781 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) ) then + lwork(il)=(nent(il,i).ne.0) + qp=rr(il,1)-ep(il,i)*clw(il,i) + anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i)) + : +(cpv-cpd)*t(il,i)*(qp-rr(il,i)) + denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp) + : +(cpd-cpv)*t(il,i)*(rr(il,i)-qp) + if(abs(denom).lt.0.01)denom=0.01 + scrit(il)=anum/denom + alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp) + if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0 + smax(il)=0.0 + asij(il)=0.0 + endif +781 continue + + do 175 j=nl,minorig,-1 + + num2=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) num2=num2+1 + enddo + if (num2.le.0) goto 175 + + do 782 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + + if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then + wgh=1.0 + if(j.gt.i)then + sjmax=amax1(sij(il,i,j+1),smax(il)) + sjmax=amin1(sjmax,scrit(il)) + smax(il)=amax1(sij(il,i,j),smax(il)) + sjmin=amax1(sij(il,i,j-1),smax(il)) + sjmin=amin1(sjmin,scrit(il)) + if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0 + smid=amin1(sij(il,i,j),scrit(il)) + else + sjmax=amax1(sij(il,i,j+1),scrit(il)) + smid=amax1(sij(il,i,j),scrit(il)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(il,i,j-1) + sjmin=amax1(sjmin,scrit(il)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(il)=asij(il)+wgh*(delp+delm) + ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh + endif + endif +782 continue + +175 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + asij(il)=amax1(1.0e-16,asij(il)) + asij(il)=1.0/asij(il) + asum(il,i)=0.0 + bsum(il,i)=0.0 + csum(il,i)=0.0 + endif + enddo + + do 180 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asij(il) + endif + enddo +180 continue + + do 190 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + asum(il,i)=asum(il,i)+ment(il,i,j) + ment(il,i,j)=ment(il,i,j)*sig(il,j) + bsum(il,i)=bsum(il,i)+ment(il,i,j) + endif + enddo +190 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + bsum(il,i)=amax1(bsum(il,i),1.0e-16) + bsum(il,i)=1.0/bsum(il,i) + endif + enddo + + do 195 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i) + endif + enddo +195 continue + + do 197 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + csum(il,i)=csum(il,i)+ment(il,i,j) + endif + enddo +197 continue + + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.m(il,i) ) then + nent(il,i)=0 + ment(il,i,i)=m(il,i) + qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i) + uent(il,i,i)=u(il,nk(il)) + vent(il,i,i)=v(il,nk(il)) + elij(il,i,i)=clw(il,i) +cMAF sij(il,i,i)=1.0 + sij(il,i,i)=0.0 + endif + enddo ! il + +c do j=1,ntra +c do il=1,ncum +c if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) +c : .and. csum(il,i).lt.m(il,i) ) then +c traent(il,i,i,j)=tra(il,nk(il),j) +c endif +c enddo +c enddo +789 continue +c +c MAF: renormalisation de MENT + do jm=1,nd + do im=1,nd + do il=1,ncum + zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm) + end do + end do + end do +c + do jm=1,nd + do im=1,nd + do il=1,ncum + if(zm(il,im).ne.0.) then + ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im) + endif + end do + end do + end do +c + do jm=1,nd + do im=1,nd + do 999 il=1,ncum + qents(il,im,jm)=qent(il,im,jm) + ments(il,im,jm)=ment(il,im,jm) +999 continue + enddo + enddo + + return + end + + + SUBROUTINE cv30_unsat(nloc,ncum,nd,na,ntra,icb,inb + : ,t,rr,rs,gz,u,v,tra,p,ph + : ,th,tv,lv,cpn,ep,sigp,clw + : ,m,ment,elij,delt,plcl + : ,mp,rp,up,vp,trap,wt,water,evap,b) + implicit none + + +#include "cvthermo.h" +#include "cv30param.h" +#include "cvflag.h" + +c inputs: + integer ncum, nd, na, ntra, nloc + integer icb(nloc), inb(nloc) + real delt, plcl(nloc) + real t(nloc,nd), rr(nloc,nd), rs(nloc,nd) + real u(nloc,nd), v(nloc,nd) + real tra(nloc,nd,ntra) + real p(nloc,nd), ph(nloc,nd+1) + real th(nloc,na), gz(nloc,na) + real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na) + real cpn(nloc,na), tv(nloc,na) + real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na) + +c outputs: + real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na) + real water(nloc,na), evap(nloc,na), wt(nloc,na) + real trap(nloc,na,ntra) + real b(nloc,na) + +c local variables + integer i,j,k,il,num1 + real tinv, delti + real awat, afac, afac1, afac2, bfac + real pr1, pr2, sigt, b6, c6, revap, tevap, delth + real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf + real ampmax + real lvcp(nloc,na) + real wdtrain(nloc) + logical lwork(nloc) + + +c------------------------------------------------------ + + delti = 1./delt + tinv=1./3. + + mp(:,:)=0. + + do i=1,nl + do il=1,ncum + mp(il,i)=0.0 + rp(il,i)=rr(il,i) + up(il,i)=u(il,i) + vp(il,i)=v(il,i) + wt(il,i)=0.001 + water(il,i)=0.0 + evap(il,i)=0.0 + b(il,i)=0.0 + lvcp(il,i)=lv(il,i)/cpn(il,i) + enddo + enddo + +c do k=1,ntra +c do i=1,nd +c do il=1,ncum +c trap(il,i,k)=tra(il,i,k) +c enddo +c enddo +c enddo + +c +c *** check whether ep(inb)=0, if so, skip precipitating *** +c *** downdraft calculation *** +c + + do il=1,ncum + lwork(il)=.TRUE. + if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE. + enddo + + call zilch(wdtrain,ncum) + + DO 400 i=nl+1,1,-1 + + num1=0 + do il=1,ncum + if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1 + enddo + if (num1.le.0) goto 400 + +c +c *** integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c + +c +c *** begin downdraft loop *** +c + +c +c *** calculate detrained precipitation *** +c + do il=1,ncum + if (i.le.inb(il) .and. lwork(il)) then + if (cvflag_grav) then + wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i) + else + wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i) + endif + endif + enddo + + if(i.gt.1)then + do 320 j=1,i-1 + do il=1,ncum + if (i.le.inb(il) .and. lwork(il)) then + awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i) + awat=amax1(awat,0.0) + if (cvflag_grav) then + wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i) + else + wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i) + endif + endif + enddo +320 continue + endif + +c +c *** find rain water and evaporation using provisional *** +c *** estimates of rp(i)and rp(i-1) *** +c + + do 999 il=1,ncum + + if (i.le.inb(il) .and. lwork(il)) then + + wt(il,i)=45.0 + + if(i.lt.inb(il))then + rp(il,i)=rp(il,i+1) + : +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i) + rp(il,i)=0.5*(rp(il,i)+rr(il,i)) + endif + rp(il,i)=amax1(rp(il,i),0.0) + rp(il,i)=amin1(rp(il,i),rs(il,i)) + rp(il,inb(il))=rr(il,inb(il)) + + if(i.eq.1)then + afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1)) + else + rp(il,i-1)=rp(il,i) + : +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i) + rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1)) + rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1)) + rp(il,i-1)=amax1(rp(il,i-1),0.0) + afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i)) + afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1)) + : /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1)) + afac=0.5*(afac1+afac2) + endif + if(i.eq.inb(il))afac=0.0 + afac=amax1(afac,0.0) + bfac=1./(sigd*wt(il,i)) +c +cjyg1 +ccc sigt=1.0 +ccc if(i.ge.icb)sigt=sigp(i) +c prise en compte de la variation progressive de sigt dans +c les couches icb et icb-1: +c pour plclph(i), pr1=1 & pr2=0 +c pour ph(i+1)9)WRITE(lunout,*) & + & pdf, Qmix(ff), aire, ff + ff=ff+df + enddo +c +c do ff=0.0+df,1.0 - 2.*df,df + ff=df + dowhile ( ff .le. 1.0 - 2.*df ) + pdf = (Qmix(ff+df)- Qmix(ff)) * (1.-ff) / df + sigma = sigma+pdf*(ff - mu)*(ff - mu)*df + ff=ff+df + enddo + sigma = sqrt(sigma) +c + if (abs(aire-1.0) .gt. 0.02) then + write(lunout,*)'WARNING:: AREA OF MIXING PDF IS::', aire + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + else + print *,'Area, mean & std deviation are ::', aire,mu,sigma + endif + endif ! (iflag_mix .gt. 0) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3_mixscale.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3_mixscale.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3_mixscale.F (revision 1634) @@ -0,0 +1,29 @@ + SUBROUTINE cv3_mixscale(nloc,ncum,na,ment,m) +*************************************************************** +* * +* CV3_MIXSCALE * +* * +* * +* written by : Jean-Yves Grandpeix, 30/05/2003, 16.34.37 * +* modified by : * +*************************************************************** +* + implicit none + +#include "cv3param.h" + + integer nloc,ncum,na + integer i,j,il + real ment(nloc,na,na),m(nloc,na) +c + do 100 j=1,nl + do 101 i=1,nl + do 102 il=1,ncum + ment(il,i,j) = m(il,i)*ment(il,i,j) +102 continue +101 continue +100 continue + +c + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3_routines.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3_routines.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3_routines.F (revision 1634) @@ -0,0 +1,3621 @@ +! +! $Id$ +! +c +c + SUBROUTINE cv3_param(nd,delt) + implicit none + +c------------------------------------------------------------ +c Set parameters for convectL for iflag_con = 3 +c------------------------------------------------------------ + +C +C *** PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE *** +C *** PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO *** +C *** PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. *** +C *** EFFICIENCY IS ASSUMED TO BE UNITY *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C +C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA] +C *** ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) *** +C *** (BETA MUST BE LESS THAN OR EQUAL TO 1) *** +C +C *** DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** IT MUST BE LESS THAN 0 *** + +#include "cv3param.h" +#include "conema3.h" + + integer nd + real delt ! timestep (seconds) + + + CHARACTER (LEN=20) :: modname='cv3_param' + CHARACTER (LEN=80) :: abort_message + + LOGICAL,SAVE :: first=.true. +c$OMP THREADPRIVATE(first) + +c noff: integer limit for convection (nd-noff) +c minorig: First level of convection + +c -- limit levels for convection: + + noff = 1 + minorig = 1 + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + + IF (first) THEN + +c -- "microphysical" parameters: + sigdz=0.01 + spfac = 0.15 + pbcrit = 150.0 + ptcrit = 500.0 +cIM beg: ajout fis. reglage ep + flag_epKEorig=1 + elcrit=0.0003 + tlcrit=-55.0 +cIM lu dans physiq.def via conf_phys.F90 epmax = 0.993 + + omtrain = 45.0 ! used also for snow (no disctinction rain/snow) + +c -- misc: + + dtovsh = -0.2 ! dT for overshoot + dpbase = -40. ! definition cloud base (400m above LCL) +ccc dttrig = 5. ! (loose) condition for triggering + dttrig = 10. ! (loose) condition for triggering + flag_wb=1 + wbmax = 6. ! (m/s) adiab updraught speed at LFC (used in cv3p1_closure) + +c -- rate of approach to quasi-equilibrium: + + dtcrit = -2.0 + tau = 8000. + +c -- interface cloud parameterization: + + delta=0.01 ! cld + +c -- interface with boundary-layer (gust factor): (sb) + + betad=10.0 ! original value (from convect 4.3) + + OPEN(99,file='conv_param.data',status='old', + $ form='formatted',err=9999) + READ(99,*,end=9998) dpbase + READ(99,*,end=9998) pbcrit + READ(99,*,end=9998) ptcrit + READ(99,*,end=9998) sigdz + READ(99,*,end=9998) spfac + READ(99,*,end=9998) tau + READ(99,*,end=9998) flag_wb + READ(99,*,end=9998) wbmax +9998 Continue + CLOSE(99) +9999 Continue + WRITE(*,*)'dpbase=',dpbase + WRITE(*,*)'pbcrit=',pbcrit + WRITE(*,*)'ptcrit=',ptcrit + WRITE(*,*)'sigdz=',sigdz + WRITE(*,*)'spfac=',spfac + WRITE(*,*)'tau=',tau + WRITE(*,*)'flag_wb =',flag_wb + WRITE(*,*)'wbmax =',wbmax + +cIM Lecture du fichier ep_param.data + OPEN(79,file='ep_param.data',status='old', + $ form='formatted',err=7999) + READ(79,*,end=7998) flag_epKEorig + READ(79,*,end=7998) elcrit + READ(79,*,end=7998) tlcrit +7998 Continue + CLOSE(79) +7999 Continue + WRITE(*,*)'flag_epKEorig',flag_epKEorig + WRITE(*,*)'elcrit=',elcrit + WRITE(*,*)'tlcrit=',tlcrit +cIM end: ajout fis. reglage ep + + first = .false. + ENDIF + + beta = 1.0 - delt/tau + alpha1 = 1.5e-3 +cjyg Correction bug alpha + alpha1 = alpha1*1.5 + alpha = alpha1 * delt/tau +cjyg Bug +ccc increase alpha to compensate W decrease: +cc alpha = alpha*1.5 + + return + end + + SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,cpn,tv,gz,h,hm,th) + implicit none + +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +! "ori": from convect4.3 (vectorized) +! "convect3": to be exactly consistent with convect3 +!===================================================================== + +c inputs: + integer len, nd, ndp1 + real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1) + +c outputs: + real lv(len,nd), cpn(len,nd), tv(len,nd) + real gz(len,nd), h(len,nd), hm(len,nd) + real th(len,nd) + +c local variables: + integer k, i + real rdcp + real tvx,tvy ! convect3 + real cpx(len,nd) + +#include "cvthermo.h" +#include "cv3param.h" + + +c ori do 110 k=1,nlp +! abderr do 110 k=1,nl ! convect3 + do 110 k=1,nlp + + do 100 i=1,len +cdebug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + lv(i,k)= lv0-clmcpv*(t(i,k)-273.15) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) +c ori tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k)) + rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k) + th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue +c ori do 140 k=2,nlp + do 140 k=2,nl ! convect3 + do 130 i=1,len + tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k)) !convect3 + tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3 + gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy) !convect3 + & *(p(i,k-1)-p(i,k))/ph(i,k) !convect3 +c +cc print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy +c +c ori gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) +c ori & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c +c ori do 170 k=1,nlp + do 170 k=1,nl ! convect3 + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv3_feed(len,nd,t,q,u,v,p,ph,hm,gz + : ,p1feed,p2feed,wght + : ,wghti,tnk,thnk,qnk,qsnk,unk,vnk + : ,cpnk,hnk,nk,icb,icbmax,iflag,gznk,plcl) + implicit none + +C================================================================ +C Purpose: CONVECTIVE FEED +C +C Main differences with cv_feed: +C - ph added in input +C - here, nk(i)=minorig +C - icb defined differently (plcl compared with ph instead of p) +C +C Main differences with convect3: +C - we do not compute dplcldt and dplcldr of CLIFT anymore +C - values iflag different (but tests identical) +C - A,B explicitely defined (!...) +C================================================================ + +#include "cv3param.h" +#include "cvthermo.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), p(len,nd) + real u(len,nd), v(len,nd) + real hm(len,nd), gz(len,nd) + real ph(len,nd+1) + real p1feed(len) +c, wght(len) + real wght(nd) +c input-output + real p2feed(len) +c outputs: + integer iflag(len), nk(len), icb(len), icbmax +c real wghti(len) + real wghti(len,nd) + real tnk(len), thnk(len), qnk(len), qsnk(len) + real unk(len), vnk(len) + real cpnk(len), hnk(len), gznk(len) + real plcl(len) + +c local variables: + integer i, k, iter, niter + integer ihmin(len) + real work(len) + real pup(len),plo(len),pfeed(len) + real plclup(len),plcllo(len),plclfeed(len) + real posit(len) + logical nocond(len) +! +!------------------------------------------------------------------- +! --- Origin level of ascending parcels for convect3: +!------------------------------------------------------------------- + + do 220 i=1,len + nk(i)=minorig + gznk(i)=gz(i,nk(i)) + 220 continue +! +!------------------------------------------------------------------- +! --- Adjust feeding layer thickness so that lifting up to the top of +! --- the feeding layer does not induce condensation (i.e. so that +! --- plcl < p2feed). +! --- Method : iterative secant method. +!------------------------------------------------------------------- +! +c 1- First bracketing of the solution : ph(nk+1), p2feed +c +c 1.a- LCL associated to p2feed + do i = 1,len + pup(i) = p2feed(i) + enddo + call cv3_vertmix(len,nd,iflag,p1feed,pup,p,ph + i ,t,q,u,v,wght + o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclup) +c 1.b- LCL associated to ph(nk+1) + do i = 1,len + plo(i) = ph(i,nk(i)+1) + enddo + call cv3_vertmix(len,nd,iflag,p1feed,plo,p,ph + i ,t,q,u,v,wght + o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plcllo) +c 2- Iterations + niter = 5 + do iter = 1,niter + do i = 1,len + plcllo(i) = min(plo(i),plcllo(i)) + plclup(i) = max(pup(i),plclup(i)) + nocond(i) = plclup(i).le.pup(i) + enddo + do i = 1,len + if(nocond(i)) then + pfeed(i)=pup(i) + else + pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+ + : plo(i)*(plclup(i)-pup(i)))/ + : (plo(i)-plcllo(i)+plclup(i)-pup(i)) + endif + enddo + call cv3_vertmix(len,nd,iflag,p1feed,pfeed,p,ph + i ,t,q,u,v,wght + o ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclfeed) + do i = 1,len + posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5 + if (plclfeed(i) .eq. pfeed(i)) posit(i) = 1. +c- posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed) +c- => pup=pfeed +c- posit = 0 when lcl is above top of feeding layer (plclfeed plo=pfeed + pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i) + plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i) + plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i) + plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i) + enddo + enddo ! iter + do i = 1,len + p2feed(i) = pfeed(i) + plcl(i) = plclfeed(i) + enddo +! + do 175 i=1,len + cpnk(i)=cpd*(1.0-qnk(i))+cpv*qnk(i) + hnk(i)=gz(i,1)+cpnk(i)*tnk(i) + 175 continue +! +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if( ( ( tnk(i).lt.250.0 ) + & .or.( qnk(i).le.0.0 ) ) + & .and. + & ( iflag(i).eq.0) ) iflag(i)=7 + 250 continue +c +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + +c@ do 270 i=1,len +c@ icb(i)=nlm +c@ 270 continue +c@c +c@ do 290 k=minorig,nl +c@ do 280 i=1,len +c@ if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) +c@ & icb(i)=min(icb(i),k) +c@ 280 continue +c@ 290 continue +c@c +c@ do 300 i=1,len +c@ if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 +c@ 300 continue + + do 270 i=1,len + icb(i)=nlm + 270 continue +c +c la modification consiste a comparer plcl a ph et non a p: +c icb est defini par : ph(icb)p(icb), then icbs=icb +c +c * the routine above computes tvp from minorig to icbs (included). +c +c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1) +c must be known. This is the case if icbs=icb+1, but not if icbs=icb. +c +c * therefore, in the case icbs=icb, we compute tvp at level icb+1 +c (tvp at other levels will be computed in cv3_undilute2.F) +c + + do i=1,len + ticb(i)=t(i,icb(i)+1) + gzicb(i)=gz(i,icb(i)+1) + qsicb(i)=qs(i,icb(i)+1) + enddo + + do 460 i=1,len + tg=ticb(i) + qg=qsicb(i) ! convect3 +cdebug alv=lv0-clmcpv*(ticb(i)-t0) + alv=lv0-clmcpv*(ticb(i)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) +c +c Second iteration. +c + +c ori s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori end if +c ori qg=eps*es/(p(i,icb(i))-es*(1.-eps)) + qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps)) + + alv=lv0-clmcpv*(ticb(i)-273.15) + +c ori c approximation here: +c ori tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) +c ori & -gz(i,icb(i))-alv*qg)/cpd + +c convect3: no approximation: + tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg) + : /(cpd+(cl-cpd)*qnk(i)) + +c ori clw(i,icb(i))=qnk(i)-qg +c ori clw(i,icb(i))=max(0.0,clw(i,icb(i))) + clw(i,icb(i)+1)=qnk(i)-qg + clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1)) + + rg=qg/(1.-qnk(i)) +c ori tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg) + tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing + + 460 continue + + return + end + + SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp,thnk, + o pbase,buoybase,iflag,sig,w0) + implicit none + +!------------------------------------------------------------------- +! --- TRIGGERING +! +! - computes the cloud base +! - triggering (crude in this version) +! - relaxation of sig and w0 when no convection +! +! Caution1: if no convection, we set iflag=4 +! (it used to be 0 in convect3) +! +! Caution2: at this stage, tvp (and thus buoy) are know up +! through icb only! +! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy +!------------------------------------------------------------------- + +#include "cv3param.h" + +c input: + integer len, nd + integer icb(len) + real plcl(len), p(len,nd) + real th(len,nd), tv(len,nd), tvp(len,nd) + real thnk(len) + +c output: + real pbase(len), buoybase(len) + +c input AND output: + integer iflag(len) + real sig(len,nd), w0(len,nd) + +c local variables: + integer i,k + real tvpbase, tvbase, tdif, ath, ath1 + +c +c *** set cloud base buoyancy at (plcl+dpbase) level buoyancy +c + do 100 i=1,len + pbase(i) = plcl(i) + dpbase + tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + : + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i)) + : /(p(i,icb(i))-p(i,icb(i)+1)) + buoybase(i) = tvpbase - tvbase +100 continue + +c +c *** make sure that column is dry adiabatic between the surface *** +c *** and cloud base, and that lifted air is positively buoyant *** +c *** at cloud base *** +c *** if not, return to calling program after resetting *** +c *** sig(i) and w0(i) *** +c + +c oct3 do 200 i=1,len +c oct3 +c oct3 tdif = buoybase(i) +c oct3 ath1 = th(i,1) +c oct3 ath = th(i,icb(i)-1) - dttrig +c oct3 +c oct3 if (tdif.lt.dtcrit .or. ath.gt.ath1) then +c oct3 do 60 k=1,nl +c oct3 sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif +c oct3 sig(i,k) = AMAX1(sig(i,k),0.0) +c oct3 w0(i,k) = beta*w0(i,k) +c oct3 60 continue +c oct3 iflag(i)=4 ! pour version vectorisee +c oct3c convect3 iflag(i)=0 +c oct3cccc return +c oct3 endif +c oct3 +c oct3200 continue + +c -- oct3: on reecrit la boucle 200 (pour la vectorisation) + + do 60 k=1,nl + do 200 i=1,len + + tdif = buoybase(i) + ath1 = thnk(i) + ath = th(i,icb(i)-1) - dttrig + + if (tdif.lt.dtcrit .or. ath.gt.ath1) then + sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif + sig(i,k) = AMAX1(sig(i,k),0.0) + w0(i,k) = beta*w0(i,k) + iflag(i)=4 ! pour version vectorisee +c convect3 iflag(i)=0 + endif + +200 continue + 60 continue + +c fin oct3 -- + + return + end + + SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1 + : ,t1,q1,qs1,u1,v1,gz1,th1 + : ,tra1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + : ,sig1,w01 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,pbase,buoybase + o ,t,q,qs,u,v,gz,th + o ,tra + o ,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,sig,w0 ) + implicit none + +#include "cv3param.h" + include 'iniprint.h' + +c inputs: + integer len,ncum,nd,ntra,nloc + integer iflag1(len),nk1(len),icb1(len),icbs1(len) + real plcl1(len),tnk1(len),qnk1(len),gznk1(len) + real pbase1(len),buoybase1(len) + real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd) + real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd) + real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd) + real tvp1(len,nd),clw1(len,nd) + real th1(len,nd) + real sig1(len,nd), w01(len,nd) + real tra1(len,nd,ntra) + +c outputs: +c en fait, on a nloc=len pour l'instant (cf cv_driver) + integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc) + real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real pbase(nloc),buoybase(nloc) + real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd) + real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd) + real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd) + real tvp(nloc,nd),clw(nloc,nd) + real th(nloc,nd) + real sig(nloc,nd), w0(nloc,nd) + real tra(nloc,nd,ntra) + +c local variables: + integer i,k,nn,j + + CHARACTER (LEN=20) :: modname='cv3_compress' + CHARACTER (LEN=80) :: abort_message + + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + sig(nn,k)=sig1(i,k) + w0(nn,k)=w01(i,k) + 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) + th(nn,k)=th1(i,k) + endif + 100 continue + 110 continue + + do 121 j=1,ntra +ccccc do 111 k=1,nl+1 + do 111 k=1,nd + nn=0 + do 101 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + tra(nn,k,j)=tra1(i,k,j) + endif + 101 continue + 111 continue + 121 continue + + if (nn.ne.ncum) then + write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + endif + + nn=0 + do 150 i=1,len + if(iflag1(i).eq.0)then + nn=nn+1 + pbase(nn)=pbase1(i) + buoybase(nn)=buoybase1(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) + icbs(nn)=icbs1(i) + iflag(nn)=iflag1(i) + endif + 150 continue + + return + end + + SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk + : ,tnk,qnk,gznk,hnk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + implicit none + +C--------------------------------------------------------------------- +C Purpose: +C FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +C & +C COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +C FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +C & +C FIND THE LEVEL OF NEUTRAL BUOYANCY +C +C Main differences convect3/convect4: +C - icbs (input) is the first level above LCL (may differ from icb) +C - many minor differences in the iterations +C - condensed water not removed from tvp in convect3 +C - vertical profile of buoyancy computed here (use of buoybase) +C - the determination of inb is different +C - no inb1, only inb in output +C--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cv3param.h" +#include "conema3.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), icbs(nloc), nk(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) + real p(nloc,nd) + real tnk(nloc), qnk(nloc), gznk(nloc) + real hnk(nloc) + real lv(nloc,nd), tv(nloc,nd), h(nloc,nd) + real pbase(nloc), buoybase(nloc), plcl(nloc) + +c outputs: + integer inb(nloc) + real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) + real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) + real buoy(nloc,nd) + +c local variables: + integer i, k + real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit + real by, defrac, pden + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + integer iposit(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=spfac + 160 continue + 170 continue + +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) +cdebug & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum +c ori if(k.ge.(icb(i)+1))then + if(k.ge.(icbs(i)+1))then ! convect3 + tg=t(i,k) + qg=qs(i,k) +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c +c First iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=cpd*(1.-qnk(i))+cl*qnk(i) ! convect3 + : +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3 + s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c +c ori s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) +c ori s=1./s +c ori ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3 + tg=tg+s*(ah0(i)-ahg) +c ori tg=max(tg,35.0) +cdebug tc=tg-t0 + tc=tg-273.15 + denom=243.5+tc + denom=MAX(denom,1.0) ! convect3 +c ori if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) +c ori else +c ori es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) +c ori endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +cdebug alv=lv0-clmcpv*(t(i,k)-t0) + alv=lv0-clmcpv*(t(i,k)-273.15) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + +c ori c approximation here: +c ori tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd + +c convect3: no approximation: + tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)) + + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) +c ori tvp(i,k)=tp(i,k)*(1.+rg*epsi) +c convect3: (qg utilise au lieu du vrai mixing ratio rg): + tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== + + if(flag_epKEorig.ne.1) THEN + do 320 k=1,nl ! convect3 + do 310 i=1,ncum + pden=ptcrit-pbcrit + ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax + ep(i,k)=max(ep(i,k),0.0) + ep(i,k)=min(ep(i,k),epmax) + sigp(i,k)=spfac + 310 continue + 320 continue + else + do 325 k=1,nl + do 315 i=1,ncum + if(k.ge.(nk(i)+1))then + tca=tp(i,k)-t0 + if(tca.ge.0.0)then + elacrit=elcrit + else + elacrit=elcrit*(1.0-tca/tlcrit) + endif + elacrit=max(elacrit,0.0) + ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) + ep(i,k)=max(ep(i,k),0.0 ) + ep(i,k)=min(ep(i,k),epmax ) + sigp(i,k)=spfac + endif + 315 continue + 325 continue + endif +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c +c dans convect3, tvp est calcule en une seule fois, et sans retirer +c l'eau condensee (~> reversible CAPE) +c +c ori do 340 k=minorig+1,nl +c ori do 330 i=1,ncum +c ori if(k.ge.(icb(i)+1))then +c ori tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c oric print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c oric print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) +c ori endif +c ori 330 continue +c ori 340 continue + +c ori do 350 i=1,ncum +c ori tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd +c ori 350 continue + + do 350 i=1,ncum ! convect3 + tp(i,nlp)=tp(i,nl) ! convect3 + 350 continue ! convect3 +c +c===================================================================== +c --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only): +c===================================================================== + +c-- this is for convect3 only: + +c first estimate of buoyancy: + + do 500 i=1,ncum + do 501 k=1,nl + buoy(i,k)=tvp(i,k)-tv(i,k) + 501 continue + 500 continue + +c set buoyancy=buoybase for all levels below base +c for safety, set buoy(icb)=buoybase + + do 505 i=1,ncum + do 506 k=1,nl + if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then + buoy(i,k)=buoybase(i) + endif + 506 continue +c buoy(icb(i),k)=buoybase(i) + buoy(i,icb(i))=buoybase(i) + 505 continue + +c-- end convect3 + +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S +c --- LEVEL OF NEUTRAL BUOYANCY +c===================================================================== +c +c-- this is for convect3 only: + + do 510 i=1,ncum + inb(i)=nl-1 + iposit(i) = nl + 510 continue + +c +c-- iposit(i) = first level, above icb, with positive buoyancy + do k = 1,nl-1 + do i = 1,ncum + if (k .ge. icb(i) .and. buoy(i,k) .gt. 0.) then + iposit(i) = min(iposit(i),k) + endif + enddo + enddo + + do i = 1,ncum + if (iposit(i) .eq. nl) then + iposit(i) = icb(i) + endif + enddo + + do 535 k=1,nl-1 + do 530 i=1,ncum + if ((k.ge.iposit(i)).and.(buoy(i,k).lt.dtovsh)) then + inb(i)=MIN(inb(i),k) + endif + 530 continue + 535 continue +c +c-- end convect3 + +c ori do 510 i=1,ncum +c ori cape(i)=0.0 +c ori capem(i)=0.0 +c ori inb(i)=icb(i)+1 +c ori inb1(i)=inb(i) +c ori 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c +c ori call zilch(byp,ncum) +c ori do 515 i=1,ncum +c ori lcape(i)=.true. +c ori 515 continue +c ori do 530 k=minorig+1,nl-1 +c ori do 520 i=1,ncum +c ori if(cape(i).lt.0.0)lcape(i)=.false. +c ori if((k.ge.(icb(i)+1)).and.lcape(i))then +c ori by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c ori byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c ori cape(i)=cape(i)+by +c ori if(by.ge.0.0)inb1(i)=k+1 +c ori if(cape(i).gt.0.0)then +c ori inb(i)=k+1 +c ori capem(i)=cape(i) +c ori endif +c ori endif +c ori 520 continue +c ori 530 continue +c ori do 540 i=1,ncum +c ori cape(i)=capem(i)+byp(i) +c ori defrac=capem(i)-cape(i) +c ori defrac=max(defrac,0.001) +c ori frac(i)=-cape(i)/defrac +c ori frac(i)=min(frac(i),1.0) +c ori frac(i)=max(frac(i),0.0) +c ori 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c + do k = 1,nd + do i=1,ncum + hp(i,k)=h(i,k) + enddo + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue + + return + end + + SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m,iflag) + implicit none + +!=================================================================== +! --- CLOSURE OF CONVECT3 +! +! vectorization: S. Bony +!=================================================================== + +#include "cvthermo.h" +#include "cv3param.h" + +c input: + integer ncum, nd, nloc + integer icb(nloc), inb(nloc) + real pbase(nloc) + real p(nloc,nd), ph(nloc,nd+1) + real tv(nloc,nd), buoy(nloc,nd) + +c input/output: + real sig(nloc,nd), w0(nloc,nd) + integer iflag(nloc) + +c output: + real cape(nloc) + real m(nloc,nd) + +c local variables: + integer i, j, k, icbmax + real deltap, fac, w, amu + real dtmin(nloc,nd), sigold(nloc,nd) + real cbmflast(nloc) + + +c ------------------------------------------------------- +c -- Initialization +c ------------------------------------------------------- + + do k=1,nl + do i=1,ncum + m(i,k)=0.0 + enddo + enddo + +c ------------------------------------------------------- +c -- Reset sig(i) and w0(i) for i>inb and iph(i), pr1=1 & pr2=0 +c pour ph(i+1) cv3p1_closure, Ale ',ale(1) +c + +c ------------------------------------------------------- +c -- Initialization +c ------------------------------------------------------- + +c +c + do il = 1,ncum + alp2(il) = max(alp(il),1.e-5) +cIM + alp2(il) = max(alp(il),1.e-12) + enddo +c + PBMXUP=50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts +c exist (if any) + + if(prt_level.GE.20) + . print*,'cv3p1_param nloc ncum nd icb inb nl',nloc,ncum,nd, + . icb(nloc),inb(nloc),nl + do k=1,nl + do il=1,ncum + m(il,k)=0.0 + enddo + enddo + +c ------------------------------------------------------- +c -- Reset sig(i) and w0(i) for i>inb and iI, if any. +c + Sx(:) = 0. +c + DO il = 1,ncum + IF ( i.ge.icb(il) .and. i.le.inb(il) ) THEN + Signhpmh(il) = sign(1.,hp(il,i)-h(il,i)) + Sbef(il) = max(0.,signhpmh(il)) + ENDIF + ENDDO + + DO j = i+1,nl + DO il = 1,ncum + IF ( i.ge.icb(il) .and. i.le.inb(il) + : .and. j.le.inb(il) ) THEN + IF (Sbef(il) .LT. Sij(il,i,j)) THEN + Sx(il) = max(Sij(il,i,j),Sx(il)) + ENDIF + Sbef(il) = Sij(il,i,j) + ENDIF + ENDDO + ENDDO +c + + do 781 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) ) then + lwork(il)=(nent(il,i).ne.0) + qp=qnk(il)-ep(il,i)*clw(il,i) + anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i)) + : +(cpv-cpd)*t(il,i)*(qp-rr(il,i)) + denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp) + : +(cpd-cpv)*t(il,i)*(rr(il,i)-qp) + if(abs(denom).lt.0.01)denom=0.01 + scrit(il)=min(anum/denom,1.) + alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp) +c +cjyg1 Find new critical value Scrit2 +c such that : Sij > Scrit2 => mixed draught will detrain at J mixed draught will detrain at J>I +c + Scrit2 = min(Scrit(il),Sx(il))*max(0.,-signhpmh(il)) + : +Scrit(il)*max(0.,signhpmh(il)) +c + Scrit(il) = Scrit2 +c +cjyg Correction pour la nouvelle logique; la correction pour ALT +c est un peu au hazard + if(scrit(il).le.0.0)scrit(il)=0.0 + if(alt.le.0.0) scrit(il)=1.0 +C + smax(il)=0.0 + asij(il)=0.0 + Sup(il)=0. ! upper S-value reached by descending draughts + endif +781 continue + +c--------------------------------------------------------------- + do 175 j=minorig,nl !Loop on destination level "j" +c--------------------------------------------------------------- + + num2=0 + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) num2=num2+1 + enddo + if (num2.le.0) goto 175 + +c ----------------------------------------------- + IF (j .GT. i) THEN +c ----------------------------------------------- + do 782 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + Smid(il)=min(Sij(il,i,j),Scrit(il)) + Sjmax(il)=Smid(il) + Sjmin(il)=Smid(il) + IF (Smid(il) .LT. Smin(il) .AND. + 1 Sij(il,i,j+1) .LT. Smid(il)) THEN + Smin(il)=Smid(il) + Sjmax(il)=min( (Sij(il,i,j+1)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) , + 1 Scrit(il) ) + Sjmin(il)=max( (Sbef(il)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) ) + Sjmin(il)=min(Sjmin(il),Scrit(il)) + Sbef(il) = Sij(il,i,j) + ENDIF + endif + endif +782 continue +c ----------------------------------------------- + ELSE IF (j .EQ. i) THEN +c ----------------------------------------------- + do 783 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + Smid(il) = 1. + Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2.,Scrit(il)) + 1 *max(0.,-signhpmh(il)) + 1 +min((Sij(il,i,j+1)+Smid(il))/2.,Scrit(il)) + 1 *max(0., signhpmh(il)) + Sjmin(il) = max(Sjmin(il),Sup(il)) + Sjmax(il) = 1. +c +c- preparation des variables Scrit, Smin et Sbef pour la partie j>i + Scrit(il) = min(Sjmin(il),Sjmax(il),Scrit(il)) + + Smin(il) = 1. + Sbef(il) = max(0.,signhpmh(il)) + Supmax(il,i) = sign(Scrit(il),-signhpmh(il)) + endif + endif +783 continue +c ----------------------------------------------- + ELSE IF ( j .LT. i) THEN +c ----------------------------------------------- + do 784 il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + Smid(il)=max(Sij(il,i,j),Scrit(il)) + Sjmax(il) = Smid(il) + Sjmin(il) = Smid(il) + IF (Smid(il) .GT. Smax(il) .AND. + 1 Sij(il,i,j+1) .GT. Smid(il)) THEN + Smax(il) = Smid(il) + Sjmax(il) = max( (Sij(il,i,j+1)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) ) + Sjmax(il) = max(Sjmax(il),Scrit(il)) + Sjmin(il) = min( (Sbef(il)+Sij(il,i,j))/2. , + 1 Sij(il,i,j) ) + Sjmin(il) = max(Sjmin(il),Scrit(il)) + Sbef(il) = Sij(il,i,j) + ENDIF + IF (abs(Sjmin(il)-Sjmax(il)) .GT. 1.e-10) Sup(il)= + 1 max(Sjmin(il),Sjmax(il),Sup(il)) + endif + endif +784 continue +c ----------------------------------------------- + END IF +c ----------------------------------------------- +c +c + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + rti=qnk(il)-ep(il,i)*clw(il,i) + Qmixmax(il)=Qmix(Sjmax(il)) + Qmixmin(il)=Qmix(Sjmin(il)) + Rmixmax(il)=Rmix(Sjmax(il)) + Rmixmin(il)=Rmix(Sjmin(il)) + SQmRmax(il)= Sjmax(il)*Qmix(Sjmax(il))-Rmix(Sjmax(il)) + SQmRmin(il)= Sjmin(il)*Qmix(Sjmin(il))-Rmix(Sjmin(il)) +c + Ment(il,i,j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il,i,j) +c +c Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j) + IF (abs(Qmixmax(il)-Qmixmin(il)) .GT. 1.e-10) THEN + Sigij(il,i,j) = + : (SQmRmax(il)-SQmRmin(il))/(Qmixmax(il)-Qmixmin(il)) + ELSE + Sigij(il,i,j) = 0. + ENDIF +c +c -- Compute Qent, uent, vent according to the true mixing fraction + Qent(il,i,j) = (1.-Sigij(il,i,j))*rti + : + Sigij(il,i,j)*rr(il,i) + uent(il,i,j) = (1.-Sigij(il,i,j))*unk(il) + : + Sigij(il,i,j)*u(il,i) + vent(il,i,j) = (1.-Sigij(il,i,j))*vnk(il) + : + Sigij(il,i,j)*v(il,i) +c +c-- Compute liquid water static energy of mixed draughts +c IF (j .GT. i) THEN +c awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j) +c awat=amax1(awat,0.0) +c ELSE +c awat = 0. +c ENDIF +c Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i) +c : + Sigij(il,i,j)*H(il,i) +c : + (LV(il,j)+(cpd-cpv)*t(il,j))*awat +cIM 301008 beg + Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i) + : + Sigij(il,i,j)*H(il,i) + + Elij(il,i,j) = Qent(il,i,j)-rs(il,j) + Elij(il,i,j) = Elij(il,i,j) + : + ((h(il,j)-Hent(il,i,j))*rs(il,j)*LV(il,j) + : / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv) + : * rrv*t(il,j)*t(il,j))) + Elij(il,i,j) = Elij(il,i,j) + : / (1.+LV(il,j)*LV(il,j)*rs(il,j) + : / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv) + : * rrv*t(il,j)*t(il,j))) + + Elij(il,i,j) = max(elij(il,i,j),0.) + + Elij(il,i,j) = min(elij(il,i,j),Qent(il,i,j)) + + IF (j .GT. i) THEN + awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j) + awat=amax1(awat,0.0) + ELSE + awat = 0. + ENDIF + +c print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)* +c : t(il,j)) + + Hent(il,i,j) = Hent(il,i,j)+(LV(il,j)+(cpd-cpv)*t(il,j)) + : * awat +cIM 301008 end +c +c print *,'mix : i,j,hent(il,i,j),sigij(il,i,j) ', +c : i,j,hent(il,i,j),sigij(il,i,j) +c +c -- ASij is the integral of P(F) over the relevant F interval + ASij(il) = ASij(il) + 1 + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) + 1 -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) +c + endif + endif + enddo + do k=1,ntra + do il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + traent(il,i,j,k)=sigij(il,i,j)*tra(il,i,k) + : +(1.-sigij(il,i,j))*tra(il,nk(il),k) + endif + endif + enddo + enddo +c +c -- If I=J (detrainement and entrainement at the same level), then only the +c -- adiabatic ascent part of the mixture is considered + IF (I .EQ. J) THEN + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. + : j.ge.(icb(il)-1) .and. j.le.inb(il) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + rti=qnk(il)-ep(il,i)*clw(il,i) +ccc Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il)) + Ment(il,i,i) = abs(Qmixmax(il)*(1.-Sjmax(il)) + 1 +Rmixmax(il) + 1 -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il)) + Qent(il,i,i) = rti + uent(il,i,i) = unk(il) + vent(il,i,i) = vnk(il) + Hent(il,i,i) = hp(il,i) + Elij(il,i,i) = clw(il,i)*(1.-ep(il,i)) + Sigij(il,i,i) = 0. + endif + endif + enddo + do k=1,ntra + do il=1,ncum + if( (i.ge.icb(il)).and.(i.le.inb(il)).and. + : (j.ge.(icb(il)-1)).and.(j.le.inb(il)) + : .and. lwork(il) ) then + if(sij(il,i,j).gt.0.0)then + traent(il,i,i,k)=tra(il,nk(il),k) + endif + endif + enddo + enddo +c + ENDIF +c +175 continue + + do il=1,ncum + if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then + asij(il)=amax1(1.0e-16,asij(il)) + asij(il)=1.0/asij(il) + csum(il,i)=0.0 + endif + enddo + + do 180 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + ment(il,i,j)=ment(il,i,j)*asij(il) + endif + enddo +180 continue + + do 197 j=minorig,nl + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then + csum(il,i)=csum(il,i)+ment(il,i,j) + endif + enddo +197 continue + + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.1. ) then +ccc : .and. csum(il,i).lt.m(il,i) ) then + nent(il,i)=0 +ccc ment(il,i,i)=m(il,i) + ment(il,i,i)=1. + qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i) + uent(il,i,i)=unk(il) + vent(il,i,i)=vnk(il) + elij(il,i,i)=clw(il,i)*(1.-ep(il,i)) + sij(il,i,i)=0.0 + endif + enddo ! il + + do j=1,ntra + do il=1,ncum + if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il) + : .and. csum(il,i).lt.1. ) then +ccc : .and. csum(il,i).lt.m(il,i) ) then + traent(il,i,i,j)=tra(il,nk(il),j) + endif + enddo + enddo +c +789 continue +c + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3param.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3param.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv3param.h (revision 1634) @@ -0,0 +1,32 @@ +c------------------------------------------------------------ +c Parameters for convectL, iflag_con=3: +c (includes - microphysical parameters, +c - parameters that control the rate of approach +c to quasi-equilibrium) +c - noff & minorig (previously in input of convect1) +c------------------------------------------------------------ + + integer noff, minorig, nl, nlp, nlm + real sigdz, spfac + integer flag_epKEorig,flag_wb + real pbcrit, ptcrit + real elcrit, tlcrit + real omtrain + real dtovsh, dpbase, dttrig + real dtcrit, tau, beta, alpha, alpha1 + real wbmax + real delta + real betad + + COMMON /cv3param/ noff, minorig, nl, nlp, nlm + : , sigdz, spfac + : ,flag_epKEorig + : ,pbcrit, ptcrit + : ,elcrit, tlcrit + : ,omtrain + : ,dtovsh, dpbase, dttrig + : ,dtcrit, tau, beta, alpha, alpha1 + : ,flag_wb,wbmax + : ,delta, betad +!$OMP THREADPRIVATE(/cv3param/) + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv_driver.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv_driver.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv_driver.F (revision 1634) @@ -0,0 +1,707 @@ +! +! $Header$ +! + SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con, + & t1,q1,qs1,u1,v1,tra1, + & p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1, + & precip1,VPrecip1, + & cbmf1,sig1,w01, + & icb1,inb1, + & delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1, + & da1,phi1,mp1) +C + USE dimphy + implicit none +C +C.............................START PROLOGUE............................ +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C len Integer Input first (i) dimension +C nd Integer Input vertical (k) dimension +C ndp1 Integer Input nd + 1 +C ntra Integer Input number of tracors +C iflag_con Integer Input version of convect (3/4) +C t1 Real Input temperature +C q1 Real Input specific hum +C qs1 Real Input sat specific hum +C u1 Real Input u-wind +C v1 Real Input v-wind +C tra1 Real Input tracors +C p1 Real Input full level pressure +C ph1 Real Input half level pressure +C iflag1 Integer Output flag for Emanuel conditions +C ft1 Real Output temp tend +C fq1 Real Output spec hum tend +C fu1 Real Output u-wind tend +C fv1 Real Output v-wind tend +C ftra1 Real Output tracor tend +C precip1 Real Output precipitation +C VPrecip1 Real Output vertical profile of precipitations +C cbmf1 Real Output cloud base mass flux +C sig1 Real In/Out section adiabatic updraft +C w01 Real In/Out vertical velocity within adiab updraft +C delt Real Input time step +C Ma1 Real Output mass flux adiabatic updraft +C upwd1 Real Output total upward mass flux (adiab+mixed) +C dnwd1 Real Output saturated downward mass flux (mixed) +C dnwd01 Real Output unsaturated downward mass flux +C qcondc1 Real Output in-cld mixing ratio of condensed water +C wd1 Real Output downdraft velocity scale for sfc fluxes +C cape1 Real Output CAPE +C +C S. Bony, Mar 2002: +C * Several modules corresponding to different physical processes +C * Several versions of convect may be used: +C - iflag_con=3: version lmd (previously named convect3) +C - iflag_con=4: version 4.3b (vect. version, previously convect1/2) +C + tard: - iflag_con=5: version lmd with ice (previously named convectg) +C S. Bony, Oct 2002: +C * Vectorization of convect3 (ie version lmd) +C +C..............................END PROLOGUE............................. +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" + + integer len + integer nd + integer ndp1 + integer noff + integer iflag_con + integer ntra + real t1(len,nd) + real q1(len,nd) + real qs1(len,nd) + real u1(len,nd) + real v1(len,nd) + real p1(len,nd) + real ph1(len,ndp1) + integer iflag1(len) + real ft1(len,nd) + real fq1(len,nd) + real fu1(len,nd) + real fv1(len,nd) + real precip1(len) + real cbmf1(len) + real VPrecip1(len,nd+1) + real Ma1(len,nd) + real upwd1(len,nd) + real dnwd1(len,nd) + real dnwd01(len,nd) + + real qcondc1(len,nd) ! cld + real wd1(len) ! gust + real cape1(len) + + real da1(len,nd),phi1(len,nd,nd),mp1(len,nd) + real da(len,nd),phi(len,nd,nd),mp(len,nd) + real tra1(len,nd,ntra) + real ftra1(len,nd,ntra) + + real delt + +!------------------------------------------------------------------- +! --- ARGUMENTS +!------------------------------------------------------------------- +! --- On input: +! +! t: Array of absolute temperature (K) of dimension ND, with first +! index corresponding to lowest model level. Note that this array +! will be altered by the subroutine if dry convective adjustment +! occurs and if IPBL is not equal to 0. +! +! q: Array of specific humidity (gm/gm) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! qs: Array of saturation specific humidity of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! u: Array of zonal wind velocity (m/s) of dimension ND, witth first +! index corresponding with the lowest model level. Defined at +! same levels as T. Note that this array will be altered if +! dry convective adjustment occurs and if IPBL is not equal to 0. +! +! v: Same as u but for meridional velocity. +! +! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA), +! where NTRA is the number of different tracers. If no +! convective tracer transport is needed, define a dummy +! input array of dimension (ND,1). Tracers are defined at +! same vertical levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! p: Array of pressure (mb) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. +! +! ph: Array of pressure (mb) of dimension ND+1, with first index +! corresponding to lowest level. These pressures are defined at +! levels intermediate between those of P, T, Q and QS. The first +! value of PH should be greater than (i.e. at a lower level than) +! the first value of the array P. +! +! nl: The maximum number of levels to which convection can penetrate, plus 1. +! NL MUST be less than or equal to ND-1. +! +! delt: The model time step (sec) between calls to CONVECT +! +!---------------------------------------------------------------------------- +! --- On Output: +! +! iflag: An output integer whose value denotes the following: +! VALUE INTERPRETATION +! ----- -------------- +! 0 Moist convection occurs. +! 1 Moist convection occurs, but a CFL condition +! on the subsidence warming is violated. This +! does not cause the scheme to terminate. +! 2 Moist convection, but no precip because ep(inb) lt 0.0001 +! 3 No moist convection because new cbmf is 0 and old cbmf is 0. +! 4 No moist convection; atmosphere is not +! unstable +! 6 No moist convection because ihmin le minorig. +! 7 No moist convection because unreasonable +! parcel level temperature or specific humidity. +! 8 No moist convection: lifted condensation +! level is above the 200 mb level. +! 9 No moist convection: cloud base is higher +! then the level NL-1. +! +! ft: Array of temperature tendency (K/s) of dimension ND, defined at same +! grid levels as T, Q, QS and P. +! +! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, +! defined at same grid levels as T. +! +! fv: Same as FU, but for forcing of meridional velocity. +! +! ftra: Array of forcing of tracer content, in tracer mixing ratio per +! second, defined at same levels as T. Dimensioned (ND,NTRA). +! +! precip: Scalar convective precipitation rate (mm/day). +! +! VPrecip: Vertical profile of convective precipitation (kg/m2/s). +! +! wd: A convective downdraft velocity scale. For use in surface +! flux parameterizations. See convect.ps file for details. +! +! tprime: A convective downdraft temperature perturbation scale (K). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! qprime: A convective downdraft specific humidity +! perturbation scale (gm/gm). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST +! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT +! ITS NEXT CALL. That is, the value of CBMF must be "remembered" +! by the calling program between calls to CONVECT. +! +! det: Array of detrainment mass flux of dimension ND. +! +!------------------------------------------------------------------- +c +c Local arrays +c + + integer i,k,n,il,j + integer icbmax + integer nk1(klon) + integer icb1(klon) + integer inb1(klon) + integer icbs1(klon) + + real plcl1(klon) + real tnk1(klon) + real qnk1(klon) + real gznk1(klon) + real pnk1(klon) + real qsnk1(klon) + real pbase1(klon) + real buoybase1(klon) + + real lv1(klon,klev) + real cpn1(klon,klev) + real tv1(klon,klev) + real gz1(klon,klev) + real hm1(klon,klev) + real h1(klon,klev) + real tp1(klon,klev) + real tvp1(klon,klev) + real clw1(klon,klev) + real sig1(klon,klev) + real w01(klon,klev) + real th1(klon,klev) +c + integer ncum +c +c (local) compressed fields: +c +cym integer nloc +cym parameter (nloc=klon) ! pour l'instant +#define nloc klon + integer idcum(nloc) + integer iflag(nloc),nk(nloc),icb(nloc) + integer nent(nloc,klev) + integer icbs(nloc) + integer inb(nloc), inbis(nloc) + + real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real t(nloc,klev),q(nloc,klev),qs(nloc,klev) + real u(nloc,klev),v(nloc,klev) + real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev) + real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev) + real clw(nloc,klev) + real dph(nloc,klev) + real pbase(nloc), buoybase(nloc), th(nloc,klev) + real tvp(nloc,klev) + real sig(nloc,klev), w0(nloc,klev) + real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev) + real frac(nloc), buoy(nloc,klev) + real cape(nloc) + real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev) + real uent(nloc,klev,klev), vent(nloc,klev,klev) + real ments(nloc,klev,klev), qents(nloc,klev,klev) + real sij(nloc,klev,klev), elij(nloc,klev,klev) + real qp(nloc,klev), up(nloc,klev), vp(nloc,klev) + real wt(nloc,klev), water(nloc,klev), evap(nloc,klev) + real b(nloc,klev), ft(nloc,klev), fq(nloc,klev) + real fu(nloc,klev), fv(nloc,klev) + real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev) + real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev) + real tps(nloc,klev), qprime(nloc), tprime(nloc) + real precip(nloc) + real VPrecip(nloc,klev+1) + real tra(nloc,klev,ntra), trap(nloc,klev,ntra) + real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra) + real qcondc(nloc,klev) ! cld + real wd(nloc) ! gust + + nent(:,:)=0 +!------------------------------------------------------------------- +! --- SET CONSTANTS AND PARAMETERS +!------------------------------------------------------------------- + +c -- set simulation flags: +c (common cvflag) + + CALL cv_flag + +c -- set thermodynamical constants: +c (common cvthermo) + + CALL cv_thermo(iflag_con) + +c -- set convect parameters +c +c includes microphysical parameters and parameters that +c control the rate of approach to quasi-equilibrium) +c (common cvparam) + + + if (iflag_con.eq.30) then + CALL cv30_param(nd,delt) + endif + + if (iflag_con.eq.4) then + CALL cv_param(nd) + endif + +!--------------------------------------------------------------------- +! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS +!--------------------------------------------------------------------- + + do 20 k=1,nd + do 10 i=1,len + ft1(i,k)=0.0 + fq1(i,k)=0.0 + fu1(i,k)=0.0 + fv1(i,k)=0.0 + tvp1(i,k)=0.0 + tp1(i,k)=0.0 + clw1(i,k)=0.0 +cym + clw(i,k)=0.0 + gz1(i,k) = 0. + VPrecip1(i,k) = 0. + Ma1(i,k)=0.0 + upwd1(i,k)=0.0 + dnwd1(i,k)=0.0 + dnwd01(i,k)=0.0 + qcondc1(i,k)=0.0 + 10 continue + 20 continue + + do 30 j=1,ntra + do 31 k=1,nd + do 32 i=1,len + ftra1(i,k,j)=0.0 + 32 continue + 31 continue + 30 continue + + do 60 i=1,len + precip1(i)=0.0 + iflag1(i)=0 + wd1(i)=0.0 + cape1(i)=0.0 + VPrecip1(i,nd+1)=0.0 + 60 continue + + if (iflag_con.eq.30) then + do il=1,len + sig1(il,nd)=sig1(il,nd)+1. + sig1(il,nd)=amin1(sig1(il,nd),12.1) + enddo + endif + +!-------------------------------------------------------------------- +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!-------------------------------------------------------------------- + + if (iflag_con.eq.30) then + +! print*,'Emanuel version 30 ' + CALL cv30_prelim(len,nd,ndp1,t1,q1,p1,ph1 ! nd->na + o ,lv1,cpn1,tv1,gz1,h1,hm1,th1) + endif + + if (iflag_con.eq.4) then + CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1 + o ,lv1,cpn1,tv1,gz1,h1,hm1) + endif + +!-------------------------------------------------------------------- +! --- CONVECTIVE FEED +!-------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1 ! nd->na + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif + + if (iflag_con.eq.4) then + CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1 + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif + +!-------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part +! (up through ICB for convect4, up through ICB+1 for convect3) +! Calculates the lifted parcel virtual temperature at nk, the +! actual temperature, and the adiabatic liquid water content. +!-------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1 ! nd->na + o ,tp1,tvp1,clw1,icbs1) + endif + + if (iflag_con.eq.4) then + CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax + : ,tp1,tvp1,clw1) + endif + +!------------------------------------------------------------------- +! --- TRIGGERING +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1 ! nd->na + o ,pbase1,buoybase1,iflag1,sig1,w01) + endif + + if (iflag_con.eq.4) then + CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1) + endif + +!===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +!===================================================================== + + ncum=0 + do 400 i=1,len + if(iflag1(i).eq.0)then + ncum=ncum+1 + idcum(ncum)=i + endif + 400 continue + +c print*,'klon, ncum = ',len,ncum + + IF (ncum.gt.0) THEN + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- COMPRESS THE FIELDS +! (-> vectorization over convective gridpoints) +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (iflag_con.eq.30) then + CALL cv30_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1 + : ,t1,q1,qs1,u1,v1,gz1,th1 + : ,tra1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + : ,sig1,w01 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,pbase,buoybase + o ,t,q,qs,u,v,gz,th + o ,tra + o ,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,sig,w0 ) + endif + + if (iflag_con.eq.4) then + CALL cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + endif + +!------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / second part : +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +! --- & +! --- COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +! --- FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- & +! --- FIND THE LEVEL OF NEUTRAL BUOYANCY +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_undilute2(nloc,ncum,nd,icb,icbs,nk !na->nd + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + endif + + if (iflag_con.eq.4) then + CALL cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac) + endif + +!------------------------------------------------------------------- +! --- CLOSURE +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_closure(nloc,ncum,nd,icb,inb ! na->nd + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m) + endif + + if (iflag_con.eq.4) then + CALL cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + o ,iflag,cbmf) + endif + +!------------------------------------------------------------------- +! --- MIXING +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb ! na->nd + : ,ph,t,q,qs,u,v,tra,h,lv,qnk + : ,hp,tv,tvp,ep,clw,m,sig + o ,ment,qent,uent,vent,sij,elij,ments,qents,traent) + endif + + if (iflag_con.eq.4) then + CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + o ,m,ment,qent,uent,vent,nent,sij,elij) + endif + +!------------------------------------------------------------------- +! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_unsat(nloc,ncum,nd,nd,ntra,icb,inb ! na->nd + : ,t,q,qs,gz,u,v,tra,p,ph + : ,th,tv,lv,cpn,ep,sigp,clw + : ,m,ment,elij,delt,plcl + o ,mp,qp,up,vp,trap,wt,water,evap,b) + endif + + if (iflag_con.eq.4) then + CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + o ,iflag,mp,qp,up,vp,wt,water,evap) + endif + +!------------------------------------------------------------------- +! --- YIELD +! (tendencies, precipitation, variables of interface with other +! processes, etc) +!------------------------------------------------------------------- + + if (iflag_con.eq.30) then + CALL cv30_yield(nloc,ncum,nd,nd,ntra ! na->nd + : ,icb,inb,delt + : ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th + : ,ep,clw,m,tp,mp,qp,up,vp,trap + : ,wt,water,evap,b + : ,ment,qent,uent,vent,nent,elij,traent,sig + : ,tv,tvp + o ,iflag,precip,VPrecip,ft,fq,fu,fv,ftra + o ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd) + endif + + if (iflag_con.eq.4) then + CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,u,v,gz,p,ph,h,hp,lv,cpn + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + endif + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- passive tracers +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (iflag_con.eq.30) then + CALL cv30_tracer(nloc,len,ncum,nd,nd, + : ment,sij,da,phi) + endif + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- UNCOMPRESS THE FIELDS +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +c set iflag1 =42 for non convective points + do i=1,len + iflag1(i)=42 + end do +c + if (iflag_con.eq.30) then + CALL cv30_uncompress(nloc,len,ncum,nd,ntra,idcum + : ,iflag + : ,precip,VPrecip,sig,w0 + : ,ft,fq,fu,fv,ftra + : ,inb + : ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape + : ,da,phi,mp + o ,iflag1 + o ,precip1,VPrecip1,sig1,w01 + o ,ft1,fq1,fu1,fv1,ftra1 + o ,inb1 + o ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 + o ,da1,phi1,mp1) + endif + + if (iflag_con.eq.4) then + CALL cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + o ,iflag1 + o ,precip1,cbmf1 + o ,ft1,fq1,fu1,fv1 + o ,Ma1,qcondc1 ) + endif + + ENDIF ! ncum>0 + +9999 continue + + return + end + +!================================================================== + SUBROUTINE cv_flag + implicit none + +#include "cvflag.h" + +c -- si .TRUE., on rend la gravite plus explicite et eventuellement +c differente de 10.0 dans convect3: + cvflag_grav = .TRUE. + + return + end + +!================================================================== + SUBROUTINE cv_thermo(iflag_con) + implicit none + +c------------------------------------------------------------- +c Set thermodynamical constants for convectL +c------------------------------------------------------------- + +#include "YOMCST.h" +#include "cvthermo.h" + + integer iflag_con + + +c original set from convect: + if (iflag_con.eq.4) then + cpd=1005.7 + cpv=1870.0 + cl=4190.0 + rrv=461.5 + rrd=287.04 + lv0=2.501E6 + g=9.8 + t0=273.15 + grav=g + else + +c constants consistent with LMDZ: + cpd = RCPD + cpv = RCPV + cl = RCW + rrv = RV + rrd = RD + lv0 = RLVTT + g = RG ! not used in convect3 +c ori t0 = RTT + t0 = 273.15 ! convect3 (RTT=273.16) +c maf grav= 10. ! implicitely or explicitely used in convect3 + grav= g ! implicitely or explicitely used in convect3 + endif + + rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?) + + clmcpv=cl-cpv + clmcpd=cl-cpd + cpdmcp=cpd-cpv + cpvmcpd=cpv-cpd + cpvmcl=cl-cpv ! for convect3 + eps=rrd/rrv + epsi=1.0/eps + epsim1=epsi-1.0 +c ginv=1.0/g + ginv=1.0/grav + hrd=0.5*rrd + + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv_routines.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv_routines.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cv_routines.F (revision 1634) @@ -0,0 +1,1762 @@ +! +! $Id$ +! + SUBROUTINE cv_param(nd) + implicit none + +c------------------------------------------------------------ +c Set parameters for convectL +c (includes microphysical parameters and parameters that +c control the rate of approach to quasi-equilibrium) +c------------------------------------------------------------ + +C *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) *** +C *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- *** +C *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO *** +C *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY *** +C *** BETWEEN 0 C AND TLCRIT) *** +C *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT *** +C *** FORMULATION *** +C *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT *** +C *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE *** +C *** OF CLOUD *** +C *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN *** +C *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW *** +C *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF RAIN *** +C *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION *** +C *** OF SNOW *** +C *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM *** +C *** TRANSPORT *** +C *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION *** +C *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC *** +C *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF *** +C *** APPROACH TO QUASI-EQUILIBRIUM *** +C *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) *** +C *** (DAMP MUST BE LESS THAN 1) *** + +#include "cvparam.h" + integer nd + CHARACTER (LEN=20) :: modname='cv_routines' + CHARACTER (LEN=80) :: abort_message + +c noff: integer limit for convection (nd-noff) +c minorig: First level of convection + + noff = 2 + minorig = 2 + + nl=nd-noff + nlp=nl+1 + nlm=nl-1 + + elcrit=0.0011 + tlcrit=-55.0 + entp=1.5 + sigs=0.12 + sigd=0.05 + omtrain=50.0 + omtsnow=5.5 + coeffr=1.0 + coeffs=0.8 + dtmax=0.9 +c + cu=0.70 +c + betad=10.0 +c + damp=0.1 + alpha=0.2 +c + delta=0.01 ! cld +c + return + end + + SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph + : ,lv,cpn,tv,gz,h,hm) + implicit none + +!===================================================================== +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!===================================================================== + +c inputs: + integer len, nd, ndp1 + real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1) + +c outputs: + real lv(len,nd), cpn(len,nd), tv(len,nd) + real gz(len,nd), h(len,nd), hm(len,nd) + +c local variables: + integer k, i + real cpx(len,nd) + +#include "cvthermo.h" +#include "cvparam.h" + + + do 110 k=1,nlp + do 100 i=1,len + lv(i,k)= lv0-clmcpv*(t(i,k)-t0) + cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k) + cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k) + tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1) + 100 continue + 110 continue +c +c gz = phi at the full levels (same as p). +c + do 120 i=1,len + gz(i,1)=0.0 + 120 continue + do 140 k=2,nlp + do 130 i=1,len + gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k)) + & *(p(i,k-1)-p(i,k))/ph(i,k) + 130 continue + 140 continue +c +c h = phi + cpT (dry static energy). +c hm = phi + cp(T-Tbase)+Lq +c + do 170 k=1,nlp + do 160 i=1,len + h(i,k)=gz(i,k)+cpn(i,k)*t(i,k) + hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz + : ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl) + implicit none + +C================================================================ +C Purpose: CONVECTIVE FEED +C================================================================ + +#include "cvparam.h" + +c inputs: + integer len, nd + real t(len,nd), q(len,nd), qs(len,nd), p(len,nd) + real hm(len,nd), gz(len,nd) + +c outputs: + integer iflag(len), nk(len), icb(len), icbmax + real tnk(len), qnk(len), gznk(len), plcl(len) + +c local variables: + integer i, k + integer ihmin(len) + real work(len) + real pnk(len), qsnk(len), rh(len), chi(len) + +!------------------------------------------------------------------- +! --- Find level of minimum moist static energy +! --- If level of minimum moist static energy coincides with +! --- or is lower than minimum allowable parcel origin level, +! --- set iflag to 6. +!------------------------------------------------------------------- + + do 180 i=1,len + work(i)=1.0e12 + ihmin(i)=nl + 180 continue + do 200 k=2,nlp + do 190 i=1,len + if((hm(i,k).lt.work(i)).and. + & (hm(i,k).lt.hm(i,k-1)))then + work(i)=hm(i,k) + ihmin(i)=k + endif + 190 continue + 200 continue + do 210 i=1,len + ihmin(i)=min(ihmin(i),nlm) + if(ihmin(i).le.minorig)then + iflag(i)=6 + endif + 210 continue +c +!------------------------------------------------------------------- +! --- Find that model level below the level of minimum moist static +! --- energy that has the maximum value of moist static energy +!------------------------------------------------------------------- + + do 220 i=1,len + work(i)=hm(i,minorig) + nk(i)=minorig + 220 continue + do 240 k=minorig+1,nl + do 230 i=1,len + if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then + work(i)=hm(i,k) + nk(i)=k + endif + 230 continue + 240 continue +!------------------------------------------------------------------- +! --- Check whether parcel level temperature and specific humidity +! --- are reasonable +!------------------------------------------------------------------- + do 250 i=1,len + if(((t(i,nk(i)).lt.250.0).or. + & (q(i,nk(i)).le.0.0).or. + & (p(i,ihmin(i)).lt.400.0)).and. + & (iflag(i).eq.0))iflag(i)=7 + 250 continue +!------------------------------------------------------------------- +! --- Calculate lifted condensation level of air at parcel origin level +! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980) +!------------------------------------------------------------------- + do 260 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + pnk(i)=p(i,nk(i)) + qsnk(i)=qs(i,nk(i)) +c + rh(i)=qnk(i)/qsnk(i) + rh(i)=min(1.0,rh(i)) + chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i)) + plcl(i)=pnk(i)*(rh(i)**chi(i)) + if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0)) + & .and.(iflag(i).eq.0))iflag(i)=8 + 260 continue +!------------------------------------------------------------------- +! --- Calculate first level above lcl (=icb) +!------------------------------------------------------------------- + do 270 i=1,len + icb(i)=nlm + 270 continue +c + do 290 k=minorig,nl + do 280 i=1,len + if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i))) + & icb(i)=min(icb(i),k) + 280 continue + 290 continue +c + do 300 i=1,len + if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9 + 300 continue +c +c Compute icbmax. +c + icbmax=2 + do 310 i=1,len + icbmax=max(icbmax,icb(i)) + 310 continue + + return + end + + SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax + : ,tp,tvp,clw) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer len, nd + integer nk(len), icb(len), icbmax + real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd) + real p(len,nd) + +c outputs: + real tp(len,nd), tvp(len,nd), clw(len,nd) + +c local variables: + integer i, k + real tg, qg, alv, s, ahg, tc, denom, es, rg + real ah0(len), cpp(len) + real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len) + +!------------------------------------------------------------------- +! --- Calculates the lifted parcel virtual temperature at nk, +! --- the actual temperature, and the adiabatic +! --- liquid water content. The procedure is to solve the equation. +! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +!------------------------------------------------------------------- + + do 320 i=1,len + tnk(i)=t(i,nk(i)) + qnk(i)=q(i,nk(i)) + gznk(i)=gz(i,nk(i)) + ticb(i)=t(i,icb(i)) + gzicb(i)=gz(i,icb(i)) + 320 continue +c +c *** Calculate certain parcel quantities, including static energy *** +c + do 330 i=1,len + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i) + cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv + 330 continue +c +c *** Calculate lifted parcel quantities below cloud base *** +c + do 350 k=minorig,icbmax-1 + do 340 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) + 340 continue + 350 continue +c +c *** Find lifted parcel quantities above cloud base *** +c + do 360 i=1,len + tg=ticb(i) + qg=qs(i,icb(i)) + alv=lv0-clmcpv*(ticb(i)-t0) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + end if + qg=eps*es/(p(i,icb(i))-es*(1.-eps)) +c + alv=lv0-clmcpv*(ticb(i)-273.15) + tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i) + & -gz(i,icb(i))-alv*qg)/cpd + clw(i,icb(i))=qnk(i)-qg + clw(i,icb(i))=max(0.0,clw(i,icb(i))) + rg=qg/(1.-qnk(i)) + tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi) + 360 continue +c + do 380 k=minorig,icbmax + do 370 i=1,len + tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i) + 370 continue + 380 continue +c + return + end + + SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag) + implicit none + +!------------------------------------------------------------------- +! --- Test for instability. +! --- If there was no convection at last time step and parcel +! --- is stable at icb, then set iflag to 4. +!------------------------------------------------------------------- + +#include "cvparam.h" + +c inputs: + integer len, nd, icb(len) + real cbmf(len), tv(len,nd), tvp(len,nd) + +c outputs: + integer iflag(len) ! also an input + +c local variables: + integer i + + + do 390 i=1,len + if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and. + & (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4 + 390 continue + + return + end + + SUBROUTINE cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + implicit none + +#include "cvparam.h" + +c inputs: + integer len,ncum,nd,nloc + integer iflag1(len),nk1(len),icb1(len) + 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) + real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd) + real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd) + real tvp1(len,nd),clw1(len,nd) + +c outputs: + integer iflag(nloc),nk(nloc),icb(nloc) + real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc) + real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd) + real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd) + real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd) + real tvp(nloc,nd),clw(nloc,nd) + real dph(nloc,nd) + +c local variables: + integer i,k,nn + CHARACTER (LEN=20) :: modname='cv_compress' + CHARACTER (LEN=80) :: abort_message + + include 'iniprint.h' + + + do 110 k=1,nl+1 + nn=0 + do 100 i=1,len + if(iflag1(i).eq.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) + endif + 100 continue + 110 continue + + if (nn.ne.ncum) then + write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + endif + + nn=0 + do 150 i=1,len + if(iflag1(i).eq.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) + endif + 150 continue + + do 170 k=1,nl + do 160 i=1,ncum + dph(i,k)=ph(i,k)-ph(i,k+1) + 160 continue + 170 continue + + return + end + + SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac) + implicit none + +C--------------------------------------------------------------------- +C Purpose: +C FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +C & +C COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +C FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +C & +C FIND THE LEVEL OF NEUTRAL BUOYANCY +C--------------------------------------------------------------------- + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), nk(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd) + real p(nloc,nd), dph(nloc,nd) + real tnk(nloc), qnk(nloc), gznk(nloc) + real lv(nloc,nd), tv(nloc,nd), h(nloc,nd) + +c outputs: + integer inb(nloc), inb1(nloc) + real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd) + real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd) + real frac(nloc) + +c local variables: + integer i, k + real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit + real by, defrac + real ah0(nloc), cape(nloc), capem(nloc), byp(nloc) + logical lcape(nloc) + +!===================================================================== +! --- SOME INITIALIZATIONS +!===================================================================== + + do 170 k=1,nl + do 160 i=1,ncum + ep(i,k)=0.0 + sigp(i,k)=sigs + 160 continue + 170 continue + +!===================================================================== +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +!===================================================================== +c +c --- The procedure is to solve the equation. +c cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk. +c +c *** Calculate certain parcel quantities, including static energy *** +c +c + do 240 i=1,ncum + ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + & +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i) + 240 continue +c +c +c *** Find lifted parcel quantities above cloud base *** +c +c + do 300 k=minorig+1,nl + do 290 i=1,ncum + if(k.ge.(icb(i)+1))then + tg=t(i,k) + qg=qs(i,k) + alv=lv0-clmcpv*(t(i,k)-t0) +c +c First iteration. +c + s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c +c Second iteration. +c + s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k)) + s=1./s + ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k) + tg=tg+s*(ah0(i)-ahg) + tg=max(tg,35.0) + tc=tg-t0 + denom=243.5+tc + if(tc.ge.0.0)then + es=6.112*exp(17.67*tc/denom) + else + es=exp(23.33086-6111.72784/tg+0.15215*log(tg)) + endif + qg=eps*es/(p(i,k)-es*(1.-eps)) +c + alv=lv0-clmcpv*(t(i,k)-t0) +c print*,'cpd dans convect2 ',cpd +c print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd' +c print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd + tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd +c if (.not.cpd.gt.1000.) then +c print*,'CPD=',cpd +c stop +c endif + clw(i,k)=qnk(i)-qg + clw(i,k)=max(0.0,clw(i,k)) + rg=qg/(1.-qnk(i)) + tvp(i,k)=tp(i,k)*(1.+rg*epsi) + endif + 290 continue + 300 continue +c +!===================================================================== +! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF +! --- PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) +!===================================================================== +c + do 320 k=minorig+1,nl + do 310 i=1,ncum + if(k.ge.(nk(i)+1))then + tca=tp(i,k)-t0 + if(tca.ge.0.0)then + elacrit=elcrit + else + elacrit=elcrit*(1.0-tca/tlcrit) + endif + elacrit=max(elacrit,0.0) + ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8) + ep(i,k)=max(ep(i,k),0.0 ) + ep(i,k)=min(ep(i,k),1.0 ) + sigp(i,k)=sigs + endif + 310 continue + 320 continue +c +!===================================================================== +! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL +! --- VIRTUAL TEMPERATURE +!===================================================================== +c + do 340 k=minorig+1,nl + do 330 i=1,ncum + if(k.ge.(icb(i)+1))then + tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k)) +c print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)' +c print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k) + endif + 330 continue + 340 continue + do 350 i=1,ncum + tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd + 350 continue +c +c===================================================================== +c --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S +c --- HIGHEST LEVEL OF NEUTRAL BUOYANCY +c --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) +c===================================================================== +c + do 510 i=1,ncum + cape(i)=0.0 + capem(i)=0.0 + inb(i)=icb(i)+1 + inb1(i)=inb(i) + 510 continue +c +c Originial Code +c +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl) +c cape(i)=capem(i)+byp +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c K Emanuel fix +c +c call zilch(byp,ncum) +c do 530 k=minorig+1,nl-1 +c do 520 i=1,ncum +c if(k.ge.(icb(i)+1))then +c by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) +c cape(i)=cape(i)+by +c if(by.ge.0.0)inb1(i)=k+1 +c if(cape(i).gt.0.0)then +c inb(i)=k+1 +c capem(i)=cape(i) +c byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) +c endif +c endif +c520 continue +c530 continue +c do 540 i=1,ncum +c inb(i)=max(inb(i),inb1(i)) +c cape(i)=capem(i)+byp(i) +c defrac=capem(i)-cape(i) +c defrac=max(defrac,0.001) +c frac(i)=-cape(i)/defrac +c frac(i)=min(frac(i),1.0) +c frac(i)=max(frac(i),0.0) +c540 continue +c +c J Teixeira fix +c + call zilch(byp,ncum) + do 515 i=1,ncum + lcape(i)=.true. + 515 continue + do 530 k=minorig+1,nl-1 + do 520 i=1,ncum + if(cape(i).lt.0.0)lcape(i)=.false. + if((k.ge.(icb(i)+1)).and.lcape(i))then + by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k) + byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1) + cape(i)=cape(i)+by + if(by.ge.0.0)inb1(i)=k+1 + if(cape(i).gt.0.0)then + inb(i)=k+1 + capem(i)=cape(i) + endif + endif + 520 continue + 530 continue + do 540 i=1,ncum + cape(i)=capem(i)+byp(i) + defrac=capem(i)-cape(i) + defrac=max(defrac,0.001) + frac(i)=-cape(i)/defrac + frac(i)=min(frac(i),1.0) + frac(i)=max(frac(i),0.0) + 540 continue +c +c===================================================================== +c --- CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL +c===================================================================== +c +c initialization: + do i=1,ncum*nlp + hp(i,1)=h(i,1) + enddo + + do 600 k=minorig+1,nl + do 590 i=1,ncum + if((k.ge.icb(i)).and.(k.le.inb(i)))then + hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k) + endif + 590 continue + 600 continue +c + return + end +c + SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + : ,iflag,cbmf) + implicit none + +c inputs: + integer ncum, nd, nloc + integer nk(nloc), icb(nloc) + real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd) + real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent... + real plcl(nloc), cpn(nloc,nd) + +c outputs: + integer iflag(nloc) + real cbmf(nloc) ! also an input + +c local variables: + integer i, k, icbmax + real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc) + real work(nloc) + +#include "cvthermo.h" +#include "cvparam.h" + +c------------------------------------------------------------------- +c Compute icbmax. +c------------------------------------------------------------------- + + icbmax=2 + do 230 i=1,ncum + icbmax=max(icbmax,icb(i)) + 230 continue + +c===================================================================== +c --- CALCULATE CLOUD BASE MASS FLUX +c===================================================================== +c +c tvpplcl = parcel temperature lifted adiabatically from level +c icb-1 to the LCL. +c tvaplcl = virtual temperature at the LCL. +c + do 610 i=1,ncum + dtpbl(i)=0.0 + tvpplcl(i)=tvp(i,icb(i)-1) + & -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i)) + & /(cpn(i,icb(i)-1)*p(i,icb(i)-1)) + tvaplcl(i)=tv(i,icb(i)) + & +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i))) + & /(p(i,icb(i))-p(i,icb(i)+1)) + 610 continue + +c------------------------------------------------------------------- +c --- Interpolate difference between lifted parcel and +c --- environmental temperatures to lifted condensation level +c------------------------------------------------------------------- +c +c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1). +c + do 630 k=minorig,icbmax + do 620 i=1,ncum + if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then + dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k) + endif + 620 continue + 630 continue + do 640 i=1,ncum + dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i))) + dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i) + 640 continue +c +c------------------------------------------------------------------- +c --- Adjust cloud base mass flux +c------------------------------------------------------------------- +c + do 650 i=1,ncum + work(i)=cbmf(i) + cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i)) + if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then + iflag(i)=3 + endif + 650 continue + + return + end + + SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1 + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + : ,m,ment,qent,uent,vent,nent,sij,elij) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc) + real cbmf(nloc), qnk(nloc) + real ph(nloc,nd+1) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd) + real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd) + real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd) + +c outputs: + integer nent(nloc,nd) + real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd) + real uent(nloc,nd,nd), vent(nloc,nd,nd) + real sij(nloc,nd,nd), elij(nloc,nd,nd) + +c local variables: + integer i, j, k, ij + integer num1, num2 + real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp + real alt, qp1, smid, sjmin, sjmax, delp, delm + real work(nloc), asij(nloc), smin(nloc), scrit(nloc) + real bsum(nloc,nd) + logical lwork(nloc) + +c===================================================================== +c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS +c===================================================================== +c + do 360 i=1,ncum*nlp + nent(i,1)=0 + m(i,1)=0.0 + 360 continue +c + do 400 k=1,nlp + do 390 j=1,nlp + do 385 i=1,ncum + qent(i,k,j)=q(i,j) + uent(i,k,j)=u(i,j) + vent(i,k,j)=v(i,j) + elij(i,k,j)=0.0 + ment(i,k,j)=0.0 + sij(i,k,j)=0.0 + 385 continue + 390 continue + 400 continue +c +c------------------------------------------------------------------- +c --- Calculate rates of mixing, m(i) +c------------------------------------------------------------------- +c + call zilch(work,ncum) +c + do 670 j=minorig+1,nl + do 660 i=1,ncum + if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then + k=min(j,inb1(i)) + dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + & +entp*0.04*(ph(i,k)-ph(i,k+1)) + work(i)=work(i)+dbo + m(i,j)=cbmf(i)*dbo + endif + 660 continue + 670 continue + do 690 k=minorig+1,nl + do 680 i=1,ncum + if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then + m(i,k)=m(i,k)/work(i) + endif + 680 continue + 690 continue +c +c +c===================================================================== +c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING +c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING +c --- FRACTION (sij) +c===================================================================== +c +c + do 750 i=minorig+1,nl + do 710 j=minorig+1,nl + do 700 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij)) + & .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then + qti=qnk(ij)-ep(ij,i)*clw(ij,i) + bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j) + & /(rrv*t(ij,j)*t(ij,j)*cpd) + anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j)) + denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j) + dei=denom + if(abs(dei).lt.0.01)dei=0.01 + sij(ij,i,j)=anum/dei + sij(ij,i,i)=1.0 + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem/bf2 + cwat=clw(ij,j)*(1.-ep(ij,j)) + stemp=sij(ij,i,j) + if((stemp.lt.0.0.or.stemp.gt.1.0.or. + 1 altem.gt.cwat).and.j.gt.i)then + anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2) + denom=denom+lv(ij,j)*(q(ij,i)-qti) + if(abs(denom).lt.0.01)denom=0.01 + sij(ij,i,j)=anum/denom + altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j) + altem=altem-(bf2-1.)*cwat + endif + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + qent(ij,i,j)=sij(ij,i,j)*q(ij,i) + & +(1.-sij(ij,i,j))*qti + uent(ij,i,j)=sij(ij,i,j)*u(ij,i) + & +(1.-sij(ij,i,j))*u(ij,nk(ij)) + vent(ij,i,j)=sij(ij,i,j)*v(ij,i) + & +(1.-sij(ij,i,j))*v(ij,nk(ij)) + elij(ij,i,j)=altem + elij(ij,i,j)=max(0.0,elij(ij,i,j)) + ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j)) + nent(ij,i)=nent(ij,i)+1 + endif + sij(ij,i,j)=max(0.0,sij(ij,i,j)) + sij(ij,i,j)=min(1.0,sij(ij,i,j)) + endif + 700 continue + 710 continue +c +c *** If no air can entrain at level i assume that updraft detrains *** +c *** at that level and calculate detrained air flux and properties *** +c + do 740 ij=1,ncum + if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij)) + & .and.(nent(ij,i).eq.0))then + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 740 continue + 750 continue +c + do 770 i=1,ncum + sij(i,inb(i),inb(i))=1.0 + 770 continue +c +c===================================================================== +c --- NORMALIZE ENTRAINED AIR MASS FLUXES +c --- TO REPRESENT EQUAL PROBABILITIES OF MIXING +c===================================================================== +c + call zilch(bsum,ncum*nlp) + do 780 ij=1,ncum + lwork(ij)=.false. + 780 continue + do 789 i=minorig+1,nl +c + num1=0 + do 779 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1 + 779 continue + if(num1.le.0)go to 789 +c + do 781 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then + lwork(ij)=(nent(ij,i).ne.0) + qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i)) + denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1) + if(abs(denom).lt.0.01)denom=0.01 + scrit(ij)=anum/denom + alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1) + if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0 + asij(ij)=0.0 + smin(ij)=1.0 + endif + 781 continue + do 783 j=minorig,nl +c + num2=0 + do 778 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))num2=num2+1 + 778 continue + if(num2.le.0)go to 783 +c + do 782 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then + if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then + if(j.gt.i)then + smid=min(sij(ij,i,j),scrit(ij)) + sjmax=smid + sjmin=smid + if(smid.lt.smin(ij) + & .and.sij(ij,i,j+1).lt.smid)then + smin(ij)=smid + sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij)) + sjmin=max(sij(ij,i,j-1),sij(ij,i,j)) + sjmin=min(sjmin,scrit(ij)) + endif + else + sjmax=max(sij(ij,i,j+1),scrit(ij)) + smid=max(sij(ij,i,j),scrit(ij)) + sjmin=0.0 + if(j.gt.1)sjmin=sij(ij,i,j-1) + sjmin=max(sjmin,scrit(ij)) + endif + delp=abs(sjmax-smid) + delm=abs(sjmin-smid) + asij(ij)=asij(ij)+(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + ment(ij,i,j)=ment(ij,i,j)*(delp+delm) + & *(ph(ij,j)-ph(ij,j+1)) + endif + endif + 782 continue + 783 continue + do 784 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then + asij(ij)=max(1.0e-21,asij(ij)) + asij(ij)=1.0/asij(ij) + bsum(ij,i)=0.0 + endif + 784 continue + do 786 j=minorig,nl+1 + do 785 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(j.ge.icb(ij)).and.(j.le.inb(ij)) + & .and.lwork(ij))then + ment(ij,i,j)=ment(ij,i,j)*asij(ij) + bsum(ij,i)=bsum(ij,i)+ment(ij,i,j) + endif + 785 continue + 786 continue + do 787 ij=1,ncum + if((i.ge.icb(ij)+1).and.(i.le.inb(ij)) + & .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then + nent(ij,i)=0 + ment(ij,i,i)=m(ij,i) + qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i) + uent(ij,i,i)=u(ij,nk(ij)) + vent(ij,i,i)=v(ij,nk(ij)) + elij(ij,i,i)=clw(ij,i) + sij(ij,i,i)=1.0 + endif + 787 continue + 789 continue +c + return + end + + SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + : ,iflag,mp,qp,up,vp,wt,water,evap) + implicit none + + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs: + integer ncum, nd, nloc + integer inb(nloc) + real t(nloc,nd), q(nloc,nd), qs(nloc,nd) + real gz(nloc,nd), u(nloc,nd), v(nloc,nd) + real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd) + real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd) + real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd) + +c outputs: + integer iflag(nloc) ! also an input + real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd) + real water(nloc,nd), evap(nloc,nd), wt(nloc,nd) + +c local variables: + integer i,j,k,ij,num1 + integer jtt(nloc) + real awat, coeff, qsm, afac, sigt, b6, c6, revap + real dhdp, fac, qstm, rat + real wdtrain(nloc) + logical lwork(nloc) + +c===================================================================== +c --- PRECIPITATING DOWNDRAFT CALCULATION +c===================================================================== +c +c Initializations: +c + do i = 1, ncum + do k = 1, nl+1 + wt(i,k) = omtsnow + mp(i,k) = 0.0 + evap(i,k) = 0.0 + water(i,k) = 0.0 + enddo + enddo + + do 420 i=1,ncum + qp(i,1)=q(i,1) + up(i,1)=u(i,1) + vp(i,1)=v(i,1) + 420 continue + + do 440 k=2,nl+1 + do 430 i=1,ncum + qp(i,k)=q(i,k-1) + up(i,k)=u(i,k-1) + vp(i,k)=v(i,k-1) + 430 continue + 440 continue + + +c *** Check whether ep(inb)=0, if so, skip precipitating *** +c *** downdraft calculation *** +c +c +c *** Integrate liquid water equation to find condensed water *** +c *** and condensed water flux *** +c +c + do 890 i=1,ncum + jtt(i)=2 + if(ep(i,inb(i)).le.0.0001)iflag(i)=2 + if(iflag(i).eq.0)then + lwork(i)=.true. + else + lwork(i)=.false. + endif + 890 continue +c +c *** Begin downdraft loop *** +c +c + call zilch(wdtrain,ncum) + do 899 i=nl+1,1,-1 +c + num1=0 + do 879 ij=1,ncum + if((i.le.inb(ij)).and.lwork(ij))num1=num1+1 + 879 continue + if(num1.le.0)go to 899 +c +c +c *** Calculate detrained precipitation *** +c + do 891 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i) + endif + 891 continue +c + if(i.gt.1)then + do 893 j=1,i-1 + do 892 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(0.0,awat) + wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i) + endif + 892 continue + 893 continue + endif +c +c *** Find rain water and evaporation using provisional *** +c *** estimates of qp(i)and qp(i-1) *** +c +c +c *** Value of terminal velocity and coeffecient of evaporation for snow *** +c + do 894 ij=1,ncum + if((i.le.inb(ij)).and.(lwork(ij)))then + coeff=coeffs + wt(ij,i)=omtsnow +c +c *** Value of terminal velocity and coeffecient of evaporation for rain *** +c + if(t(ij,i).gt.273.0)then + coeff=coeffr + wt(ij,i)=omtrain + endif + qsm=0.5*(q(ij,i)+qp(ij,i+1)) + afac=coeff*ph(ij,i)*(qs(ij,i)-qsm) + & /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i)) + afac=max(afac,0.0) + sigt=sigp(ij,i) + sigt=max(0.0,sigt) + sigt=min(1.0,sigt) + b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i) + c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i) + revap=0.5*(-b6+sqrt(b6*b6+4.*c6)) + evap(ij,i)=sigt*afac*revap + water(ij,i)=revap*revap +c +c *** Calculate precipitating downdraft mass flux under *** +c *** hydrostatic approximation *** +c + if(i.gt.1)then + dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i)) + dhdp=max(dhdp,10.0) + mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp + mp(ij,i)=max(mp(ij,i),0.0) +c +c *** Add small amount of inertia to downdraft *** +c + fac=20.0/(ph(ij,i-1)-ph(ij,i)) + mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac) +c +c *** Force mp to decrease linearly to zero *** +c *** between about 950 mb and the surface *** +c + if(p(ij,i).gt.(0.949*p(ij,1)))then + jtt(ij)=max(jtt(ij),i) + mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i)) + & /(p(ij,1)-p(ij,jtt(ij))) + endif + endif +c +c *** Find mixing ratio of precipitating downdraft *** +c + if(i.ne.inb(ij))then + if(i.eq.1)then + qstm=qs(ij,1) + else + qstm=qs(ij,i-1) + endif + if(mp(ij,i).gt.mp(ij,i+1))then + rat=mp(ij,i+1)/mp(ij,i) + qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv* + & sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i)) + up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat) + vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat) + else + if(mp(ij,i+1).gt.0.0)then + qp(ij,i)=(gz(ij,i+1)-gz(ij,i) + & +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1) + & *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i))) + & /(lv(ij,i)+t(ij,i)*(cl-cpd)) + up(ij,i)=up(ij,i+1) + vp(ij,i)=vp(ij,i+1) + endif + endif + qp(ij,i)=min(qp(ij,i),qstm) + qp(ij,i)=max(qp(ij,i),0.0) + endif + endif + 894 continue + 899 continue +c + return + end + + SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,u,v,gz,p,ph,h,hp,lv,cpn + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + implicit none + +#include "cvthermo.h" +#include "cvparam.h" + +c inputs + integer ncum, nd, nloc + integer nk(nloc), icb(nloc), inb(nloc) + integer nent(nloc,nd) + real delt + real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd) + real gz(nloc,nd) + real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd) + real hp(nloc,nd), lv(nloc,nd) + real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc) + real m(nloc,nd), mp(nloc,nd), qp(nloc,nd) + real up(nloc,nd), vp(nloc,nd) + real wt(nloc,nd), water(nloc,nd), evap(nloc,nd) + real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd) + real uent(nloc,nd,nd), vent(nloc,nd,nd) + real tv(nloc,nd), tvp(nloc,nd) + +c outputs + integer iflag(nloc) ! also an input + real cbmf(nloc) ! also an input + real wd(nloc), tprime(nloc), qprime(nloc) + real precip(nloc) + real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd) + real Ma(nloc,nd) + real qcondc(nloc,nd) + +c local variables + integer i,j,ij,k,num1 + real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti + real work(nloc), am(nloc),amp1(nloc),ad(nloc) + real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd) + real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld + real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd) ! cld + + +c -- initializations: + + delti = 1.0/delt + + do 160 i=1,ncum + precip(i)=0.0 + wd(i)=0.0 + tprime(i)=0.0 + qprime(i)=0.0 + do 170 k=1,nl+1 + ft(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + fq(i,k)=0.0 + lvcp(i,k)=lv(i,k)/cpn(i,k) + qcondc(i,k)=0.0 ! cld + qcond(i,k)=0.0 ! cld + nqcond(i,k)=0.0 ! cld + 170 continue + 160 continue + +c +c *** Calculate surface precipitation in mm/day *** +c + do 1190 i=1,ncum + if(iflag(i).le.1)then +cc precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000. +cc & /(rowl*g) +cc precip(i)=precip(i)*delt/86400. + precip(i) = wt(i,1)*sigd*water(i,1)*86400/g + endif + 1190 continue +c +c +c *** Calculate downdraft velocity scale and surface temperature and *** +c *** water vapor fluctuations *** +c + do i=1,ncum + wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i)) + : /(sigd*p(i,icb(i))) + qprime(i)=0.5*(qp(i,1)-q(i,1)) + tprime(i)=lv0*qprime(i)/cpd + enddo +c +c *** Calculate tendencies of lowest level potential temperature *** +c *** and mixing ratio *** +c + do 1200 i=1,ncum + work(i)=0.01/(ph(i,1)-ph(i,2)) + am(i)=0.0 + 1200 continue + do 1220 k=2,nl + do 1210 i=1,ncum + if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then + am(i)=am(i)+m(i,k) + endif + 1210 continue + 1220 continue + do 1240 i=1,ncum + if((g*work(i)*am(i)).ge.delti)iflag(i)=1 + ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1) + & +(gz(i,2)-gz(i,1))/cpn(i,1)) + ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1) + ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2) + & -t(i,1))*work(i)/cpn(i,1) + fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))* + & work(i)+sigd*evap(i,1) + fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i) + fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1)) + & +am(i)*(u(i,2)-u(i,1))) + fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1)) + & +am(i)*(v(i,2)-v(i,1))) + 1240 continue + do 1260 j=2,nl + do 1250 i=1,ncum + if(j.le.inb(i))then + fq(i,1)=fq(i,1) + & +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1)) + fu(i,1)=fu(i,1) + & +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1)) + fv(i,1)=fv(i,1) + & +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1)) + endif + 1250 continue + 1260 continue +c +c *** Calculate tendencies of potential temperature and mixing ratio *** +c *** at levels above the lowest level *** +c +c *** First find the net saturated updraft and downdraft mass fluxes *** +c *** through each level *** +c + do 1500 i=2,nl+1 +c + num1=0 + do 1265 ij=1,ncum + if(i.le.inb(ij))num1=num1+1 + 1265 continue + if(num1.le.0)go to 1500 +c + call zilch(amp1,ncum) + call zilch(ad,ncum) +c + do 1280 k=i+1,nl+1 + do 1270 ij=1,ncum + if((i.ge.nk(ij)).and.(i.le.inb(ij)) + & .and.(k.le.(inb(ij)+1)))then + amp1(ij)=amp1(ij)+m(ij,k) + endif + 1270 continue + 1280 continue +c + do 1310 k=1,i + do 1300 j=i+1,nl+1 + do 1290 ij=1,ncum + if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then + amp1(ij)=amp1(ij)+ment(ij,k,j) + endif + 1290 continue + 1300 continue + 1310 continue + do 1340 k=1,i-1 + do 1330 j=i,nl+1 + do 1320 ij=1,ncum + if((i.le.inb(ij)).and.(j.le.inb(ij)))then + ad(ij)=ad(ij)+ment(ij,j,k) + endif + 1320 continue + 1330 continue + 1340 continue +c + do 1350 ij=1,ncum + if(i.le.inb(ij))then + dpinv=0.01/(ph(ij,i)-ph(ij,i+1)) + cpinv=1.0/cpn(ij,i) +c + ft(ij,i)=ft(ij,i) + & +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i) + & +(gz(ij,i+1)-gz(ij,i))*cpinv) + & -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) + & -sigd*lvcp(ij,i)*evap(ij,i) + ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+ + & t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv + ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)* + & (t(ij,i+1)-t(ij,i))*dpinv*cpinv + fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))- + & ad(ij)*(q(ij,i)-q(ij,i-1))) + fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))- + & ad(ij)*(u(ij,i)-u(ij,i-1))) + fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))- + & ad(ij)*(v(ij,i)-v(ij,i-1))) + endif + 1350 continue + do 1370 k=1,i-1 + do 1360 ij=1,ncum + if(i.le.inb(ij))then + awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i) + awat=max(awat,0.0) + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) +c (saturated updrafts resulting from mixing) ! cld + qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + endif + 1360 continue + 1370 continue + do 1390 k=i,nl+1 + do 1380 ij=1,ncum + if((i.le.inb(ij)).and.(k.le.inb(ij)))then + fq(ij,i)=fq(ij,i) + & +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i)) + fu(ij,i)=fu(ij,i) + & +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i)) + fv(ij,i)=fv(ij,i) + & +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i)) + endif + 1380 continue + 1390 continue + do 1400 ij=1,ncum + if(i.le.inb(ij))then + 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 + fu(ij,i)=fu(ij,i) + & +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)* + & (up(ij,i)-u(ij,i-1)))*dpinv + fv(ij,i)=fv(ij,i) + & +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)* + & (vp(ij,i)-v(ij,i-1)))*dpinv +C (saturated downdrafts resulting from mixing) ! cld + do k=i+1,inb(ij) ! cld + qcond(ij,i)=qcond(ij,i)+elij(ij,k,i) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + enddo ! cld +C (particular case: no detraining level is found) ! cld + if (nent(ij,i).eq.0) then ! cld + qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld + nqcond(ij,i)=nqcond(ij,i)+1. ! cld + endif ! cld + if (nqcond(ij,i).ne.0.) then ! cld + qcond(ij,i)=qcond(ij,i)/nqcond(ij,i) ! cld + endif ! cld + endif + 1400 continue + 1500 continue +c +c *** Adjust tendencies at top of convection layer to reflect *** +c *** actual position of the level zero cape *** +c + do 503 ij=1,ncum + fqold=fq(ij,inb(ij)) + fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij)) + fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1) + & +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij)) + & /lv(ij,inb(ij)-1) + ftold=ft(ij,inb(ij)) + ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij)) + ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1) + & +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij)) + & /cpn(ij,inb(ij)-1) + fuold=fu(ij,inb(ij)) + fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij)) + fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1) + & +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + fvold=fv(ij,inb(ij)) + fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij)) + fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1) + & +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/ + 1 (ph(ij,inb(ij)-1)-ph(ij,inb(ij)))) + 503 continue +c +c *** Very slightly adjust tendencies to force exact *** +c *** enthalpy, momentum and tracer conservation *** +c + do 682 ij=1,ncum + ents(ij)=0.0 + uav(ij)=0.0 + vav(ij)=0.0 + do 681 i=1,inb(ij) + ents(ij)=ents(ij) + & +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1)) + uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1)) + vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1)) + 681 continue + 682 continue + do 683 ij=1,ncum + ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1)) + 683 continue + do 642 ij=1,ncum + do 641 i=1,inb(ij) + ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i) + fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij)) + fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij)) + 641 continue + 642 continue +c + do 1810 k=1,nl+1 + do 1800 i=1,ncum + if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10 + 1800 continue + 1810 continue +c +c + do 1900 i=1,ncum + if(iflag(i).gt.2)then + precip(i)=0.0 + cbmf(i)=0.0 + endif + 1900 continue + do 1920 k=1,nl + do 1910 i=1,ncum + if(iflag(i).gt.2)then + ft(i,k)=0.0 + fq(i,k)=0.0 + fu(i,k)=0.0 + fv(i,k)=0.0 + qcondc(i,k)=0.0 ! cld + endif + 1910 continue + 1920 continue + + do k=1,nl+1 + do i=1,ncum + Ma(i,k) = 0. + enddo + enddo + do k=nl,1,-1 + do i=1,ncum + Ma(i,k) = Ma(i,k+1)+m(i,k) + enddo + enddo + +c +c *** diagnose the in-cloud mixing ratio *** ! cld +c *** of condensed water *** ! cld +c ! cld + DO ij=1,ncum ! cld + do i=1,nd ! cld + mac(ij,i)=0.0 ! cld + wa(ij,i)=0.0 ! cld + siga(ij,i)=0.0 ! cld + enddo ! cld + do i=nk(ij),inb(ij) ! cld + do k=i+1,inb(ij)+1 ! cld + mac(ij,i)=mac(ij,i)+m(ij,k) ! cld + enddo ! cld + enddo ! cld + do i=icb(ij),inb(ij)-1 ! cld + ax(ij,i)=0. ! cld + do j=icb(ij),i ! cld + ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j)) ! cld + : *(ph(ij,j)-ph(ij,j+1))/p(ij,j) ! cld + enddo ! cld + if (ax(ij,i).gt.0.0) then ! cld + wa(ij,i)=sqrt(2.*ax(ij,i)) ! cld + endif ! cld + enddo ! cld + do i=1,nl ! cld + if (wa(ij,i).gt.0.0) ! cld + : siga(ij,i)=mac(ij,i)/wa(ij,i) ! cld + : *rrd*tvp(ij,i)/p(ij,i)/100./delta ! cld + siga(ij,i) = min(siga(ij,i),1.0) ! cld + qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i)) ! cld + : + (1.-siga(ij,i))*qcond(ij,i) ! cld + enddo ! cld + ENDDO ! cld + + return + end + + SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + : ,iflag1 + : ,precip1,cbmf1 + : ,ft1,fq1,fu1,fv1 + : ,Ma1,qcondc1 + : ) + implicit none + +#include "cvparam.h" + +c inputs: + integer len, ncum, nd, nloc + integer idcum(nloc) + integer iflag(nloc) + real precip(nloc), cbmf(nloc) + real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd) + real Ma(nloc,nd) + real qcondc(nloc,nd) !cld + +c outputs: + integer iflag1(len) + real precip1(len), cbmf1(len) + real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd) + real Ma1(len,nd) + real qcondc1(len,nd) !cld + +c local variables: + integer i,k + + do 2000 i=1,ncum + precip1(idcum(i))=precip(i) + cbmf1(idcum(i))=cbmf(i) + iflag1(idcum(i))=iflag(i) + 2000 continue + + do 2020 k=1,nl + do 2010 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) + 2010 continue + 2020 continue + + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cva_driver.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cva_driver.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cva_driver.F (revision 1634) @@ -0,0 +1,964 @@ +! +! $Id$ +! + SUBROUTINE cva_driver(len,nd,ndp1,ntra,nloc, + & iflag_con,iflag_mix, + & iflag_clos,delt, + & t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake, + & u1,v1,tra1, + & p1,ph1, + & ALE1,ALP1, + & sig1feed1,sig2feed1,wght1, + o iflag1,ft1,fq1,fu1,fv1,ftra1, + & precip1,kbas1,ktop1, + & cbmf1,plcl1,plfc1,wbeff1, + & sig1,w01, !input/output + & ptop21,sigd1, + & Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01, + & qcondc1,wd1, + & cape1,cin1,tvp1, + & ftd1,fqd1, + & Plim11,Plim21,asupmax1,supmax01,asupmaxmin1 + & ,lalim_conv) +*************************************************************** +* * +* CV_DRIVER * +* * +* * +* written by : Sandrine Bony-Lena , 17/05/2003, 11.19.41 * +* modified by : * +*************************************************************** +*************************************************************** +C + USE dimphy + implicit none +C +C.............................START PROLOGUE............................ +C +C PARAMETERS: +C Name Type Usage Description +C ---------- ---------- ------- ---------------------------- +C +C len Integer Input first (i) dimension +C nd Integer Input vertical (k) dimension +C ndp1 Integer Input nd + 1 +C ntra Integer Input number of tracors +C iflag_con Integer Input version of convect (3/4) +C iflag_mix Integer Input version of mixing (0/1/2) +C iflag_clos Integer Input version of closure (0/1) +C delt Real Input time step +C t1 Real Input temperature (sat draught envt) +C q1 Real Input specific hum (sat draught envt) +C qs1 Real Input sat specific hum (sat draught envt) +C t1_wake Real Input temperature (unsat draught envt) +C q1_wake Real Input specific hum(unsat draught envt) +C qs1_wake Real Input sat specific hum(unsat draughts envt) +C s1_wake Real Input fractionnal area covered by wakes +C u1 Real Input u-wind +C v1 Real Input v-wind +C tra1 Real Input tracors +C p1 Real Input full level pressure +C ph1 Real Input half level pressure +C ALE1 Real Input Available lifting Energy +C ALP1 Real Input Available lifting Power +C sig1feed1 Real Input sigma coord at lower bound of feeding layer +C sig2feed1 Real Input sigma coord at upper bound of feeding layer +C wght1 Real Input weight density determining the feeding mixture +C iflag1 Integer Output flag for Emanuel conditions +C ft1 Real Output temp tend +C fq1 Real Output spec hum tend +C fu1 Real Output u-wind tend +C fv1 Real Output v-wind tend +C ftra1 Real Output tracor tend +C precip1 Real Output precipitation +C kbas1 Integer Output cloud base level +C ktop1 Integer Output cloud top level +C cbmf1 Real Output cloud base mass flux +C sig1 Real In/Out section adiabatic updraft +C w01 Real In/Out vertical velocity within adiab updraft +C ptop21 Real In/Out top of entraining zone +C Ma1 Real Output mass flux adiabatic updraft +C mip1 Real Output mass flux shed by the adiabatic updraft +C Vprecip1 Real Output vertical profile of precipitations +C upwd1 Real Output total upward mass flux (adiab+mixed) +C dnwd1 Real Output saturated downward mass flux (mixed) +C dnwd01 Real Output unsaturated downward mass flux +C qcondc1 Real Output in-cld mixing ratio of condensed water +C wd1 Real Output downdraft velocity scale for sfc fluxes +C cape1 Real Output CAPE +C cin1 Real Output CIN +C tvp1 Real Output adiab lifted parcell virt temp +C ftd1 Real Output precip temp tend +C fqt1 Real Output precip spec hum tend +C Plim11 Real Output +C Plim21 Real Output +C asupmax1 Real Output +C supmax01 Real Output +C asupmaxmin1 Real Output +C S. Bony, Mar 2002: +C * Several modules corresponding to different physical processes +C * Several versions of convect may be used: +C - iflag_con=3: version lmd (previously named convect3) +C - iflag_con=4: version 4.3b (vect. version, previously convect1/2) +C + tard: - iflag_con=5: version lmd with ice (previously named convectg) +C S. Bony, Oct 2002: +C * Vectorization of convect3 (ie version lmd) +C +C..............................END PROLOGUE............................. +c +c +#include "dimensions.h" +ccccc#include "dimphy.h" + include 'iniprint.h' + +c +c Input + integer len + integer nd + integer ndp1 + integer ntra + integer iflag_con + integer iflag_mix + integer iflag_clos + real delt + real t1(len,nd) + real q1(len,nd) + real qs1(len,nd) + real t1_wake(len,nd) + real q1_wake(len,nd) + real qs1_wake(len,nd) + real s1_wake(len) + real u1(len,nd) + real v1(len,nd) + real tra1(len,nd,ntra) + real p1(len,nd) + real ph1(len,ndp1) + real ALE1(len) + real ALP1(len) + real sig1feed1 ! pressure at lower bound of feeding layer + real sig2feed1 ! pressure at upper bound of feeding layer + real wght1(nd) ! weight density determining the feeding mixture +c +c Output + integer iflag1(len) + real ft1(len,nd) + real fq1(len,nd) + real fu1(len,nd) + real fv1(len,nd) + real ftra1(len,nd,ntra) + real precip1(len) + integer kbas1(len) + integer ktop1(len) + real cbmf1(len) + real plcl1(klon) + real plfc1(klon) + real wbeff1(klon) + real sig1(len,klev) !input/output + real w01(len,klev) !input/output + real ptop21(len) + real sigd1(len) + real Ma1(len,nd) + real mip1(len,nd) +! real Vprecip1(len,nd) + real Vprecip1(len,nd+1) + real upwd1(len,nd) + real dnwd1(len,nd) + real dnwd01(len,nd) + real qcondc1(len,nd) ! cld + real wd1(len) ! gust + real cape1(len) + real cin1(len) + real tvp1(len,nd) +c + real ftd1(len,nd) + real fqd1(len,nd) + real Plim11(len) + real Plim21(len) + real asupmax1(len,nd) + real supmax01(len) + real asupmaxmin1(len) + integer lalim_conv(len) +!------------------------------------------------------------------- +! --- ARGUMENTS +!------------------------------------------------------------------- +! --- On input: +! +! t: Array of absolute temperature (K) of dimension ND, with first +! index corresponding to lowest model level. Note that this array +! will be altered by the subroutine if dry convective adjustment +! occurs and if IPBL is not equal to 0. +! +! q: Array of specific humidity (gm/gm) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! qs: Array of saturation specific humidity of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! t_wake: Array of absolute temperature (K), seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! +! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! Must be defined at same grid levels as T. +! +!qs_wake: Array of saturation specific humidity, seen by unsaturated draughts, +! of dimension ND, with first index corresponding to lowest model level. +! Must be defined at same grid levels as T. +! +!s_wake: Array of fractionnal area occupied by the wakes. +! +! u: Array of zonal wind velocity (m/s) of dimension ND, witth first +! index corresponding with the lowest model level. Defined at +! same levels as T. Note that this array will be altered if +! dry convective adjustment occurs and if IPBL is not equal to 0. +! +! v: Same as u but for meridional velocity. +! +! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA), +! where NTRA is the number of different tracers. If no +! convective tracer transport is needed, define a dummy +! input array of dimension (ND,1). Tracers are defined at +! same vertical levels as T. Note that this array will be altered +! if dry convective adjustment occurs and if IPBL is not equal to 0. +! +! p: Array of pressure (mb) of dimension ND, with first +! index corresponding to lowest model level. Must be defined +! at same grid levels as T. +! +! ph: Array of pressure (mb) of dimension ND+1, with first index +! corresponding to lowest level. These pressures are defined at +! levels intermediate between those of P, T, Q and QS. The first +! value of PH should be greater than (i.e. at a lower level than) +! the first value of the array P. +! +! ALE: Available lifting Energy +! +! ALP: Available lifting Power +! +! nl: The maximum number of levels to which convection can penetrate, plus 1. +! NL MUST be less than or equal to ND-1. +! +! delt: The model time step (sec) between calls to CONVECT +! +!---------------------------------------------------------------------------- +! --- On Output: +! +! iflag: An output integer whose value denotes the following: +! VALUE INTERPRETATION +! ----- -------------- +! 0 Moist convection occurs. +! 1 Moist convection occurs, but a CFL condition +! on the subsidence warming is violated. This +! does not cause the scheme to terminate. +! 2 Moist convection, but no precip because ep(inb) lt 0.0001 +! 3 No moist convection because new cbmf is 0 and old cbmf is 0. +! 4 No moist convection; atmosphere is not +! unstable +! 6 No moist convection because ihmin le minorig. +! 7 No moist convection because unreasonable +! parcel level temperature or specific humidity. +! 8 No moist convection: lifted condensation +! level is above the 200 mb level. +! 9 No moist convection: cloud base is higher +! then the level NL-1. +! +! ft: Array of temperature tendency (K/s) of dimension ND, defined at same +! grid levels as T, Q, QS and P. +! +! fq: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fu: Array of forcing of zonal velocity (m/s^2) of dimension ND, +! defined at same grid levels as T. +! +! fv: Same as FU, but for forcing of meridional velocity. +! +! ftra: Array of forcing of tracer content, in tracer mixing ratio per +! second, defined at same levels as T. Dimensioned (ND,NTRA). +! +! precip: Scalar convective precipitation rate (mm/day). +! +! wd: A convective downdraft velocity scale. For use in surface +! flux parameterizations. See convect.ps file for details. +! +! tprime: A convective downdraft temperature perturbation scale (K). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! qprime: A convective downdraft specific humidity +! perturbation scale (gm/gm). +! For use in surface flux parameterizations. See convect.ps +! file for details. +! +! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST +! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT +! ITS NEXT CALL. That is, the value of CBMF must be "remembered" +! by the calling program between calls to CONVECT. +! +! det: Array of detrainment mass flux of dimension ND. +! +! ftd: Array of temperature tendency due to precipitations (K/s) of dimension ND, +! defined at same grid levels as T, Q, QS and P. +! +! fqd: Array of specific humidity tendencies due to precipitations ((gm/gm)/s) +! of dimension ND, defined at same grid levels as T, Q, QS and P. +! +!------------------------------------------------------------------- +c +c Local arrays +c + + integer i,k,n,il,j + integer nword1,nword2,nword3,nword4 + integer icbmax + integer nk1(klon) + integer icb1(klon) + integer icbs1(klon) + + logical ok_inhib ! True => possible inhibition of convection by dryness + logical, save :: debut=.true. +c$OMP THREADPRIVATE(debut) + + real tnk1(klon) + real thnk1(klon) + real qnk1(klon) + real gznk1(klon) + real pnk1(klon) + real qsnk1(klon) + real unk1(klon) + real vnk1(klon) + real cpnk1(klon) + real hnk1(klon) + real pbase1(klon) + real buoybase1(klon) + + real lv1(klon,klev) ,lv1_wake(klon,klev) + real cpn1(klon,klev),cpn1_wake(klon,klev) + real tv1(klon,klev) ,tv1_wake(klon,klev) + real gz1(klon,klev) ,gz1_wake(klon,klev) + real hm1(klon,klev) ,hm1_wake(klon,klev) + real h1(klon,klev) ,h1_wake(klon,klev) + real tp1(klon,klev) + real clw1(klon,klev) + real th1(klon,klev) ,th1_wake(klon,klev) +c + real bid(klon,klev) ! dummy array +c + integer ncum +c + integer j1feed(klon) + integer j2feed(klon) + real p1feed1(len) ! pressure at lower bound of feeding layer + real p2feed1(len) ! pressure at upper bound of feeding layer + real wghti1(len,nd) ! weights of the feeding layers +c +c (local) compressed fields: +c + integer nloc +c parameter (nloc=klon) ! pour l'instant + + integer idcum(nloc) + integer iflag(nloc),nk(nloc),icb(nloc) + integer nent(nloc,klev) + integer icbs(nloc) + integer inb(nloc), inbis(nloc) + + real cbmf(nloc),plcl(nloc),plfc(nloc),wbeff(nloc) + real t(nloc,klev),q(nloc,klev),qs(nloc,klev) + real t_wake(nloc,klev),q_wake(nloc,klev),qs_wake(nloc,klev) + real s_wake(nloc) + real u(nloc,klev),v(nloc,klev) + real gz(nloc,klev),h(nloc,klev) ,hm(nloc,klev) + real h_wake(nloc,klev),hm_wake(nloc,klev) + real lv(nloc,klev) ,cpn(nloc,klev) + real lv_wake(nloc,klev),cpn_wake(nloc,klev) + real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev) ,tp(nloc,klev) + real tv_wake(nloc,klev) + real clw(nloc,klev) + real dph(nloc,klev) + real pbase(nloc), buoybase(nloc), th(nloc,klev) + real th_wake(nloc,klev) + real tvp(nloc,klev) + real sig(nloc,klev), w0(nloc,klev), ptop2(nloc) + real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev) + real frac(nloc), buoy(nloc,klev) + real cape(nloc) + real cin(nloc) + real m(nloc,klev) + real ment(nloc,klev,klev), sij(nloc,klev,klev) + real qent(nloc,klev,klev) + real hent(nloc,klev,klev) + real uent(nloc,klev,klev), vent(nloc,klev,klev) + real ments(nloc,klev,klev), qents(nloc,klev,klev) + real elij(nloc,klev,klev) + real supmax(nloc,klev) + real ale(nloc),alp(nloc),coef_clos(nloc) + real sigd(nloc) +! real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev) +! real wt(nloc,klev), water(nloc,klev), evap(nloc,klev) +! real b(nloc,klev), sigd(nloc) +! save mp,qp,up,vp,wt,water,evap,b + real, save, allocatable :: mp(:,:),qp(:,:),up(:,:),vp(:,:) + real, save, allocatable :: wt(:,:),water(:,:),evap(:,:), b(:,:) +c$OMP THREADPRIVATE(mp,qp,up,vp,wt,water,evap,b) + real ft(nloc,klev), fq(nloc,klev) + real ftd(nloc,klev), fqd(nloc,klev) + real fu(nloc,klev), fv(nloc,klev) + real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev) + real Ma(nloc,klev), mip(nloc,klev), tls(nloc,klev) + real tps(nloc,klev), qprime(nloc), tprime(nloc) + real precip(nloc) +! real Vprecip(nloc,klev) + real Vprecip(nloc,klev+1) + real tra(nloc,klev,ntra), trap(nloc,klev,ntra) + real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra) + real qcondc(nloc,klev) ! cld + real wd(nloc) ! gust + real Plim1(nloc),Plim2(nloc) + real asupmax(nloc,klev) + real supmax0(nloc) + real asupmaxmin(nloc) +c + real tnk(nloc),qnk(nloc),gznk(nloc) + real wghti(nloc,nd) + real hnk(nloc),unk(nloc),vnk(nloc) + logical, save :: first=.true. +c$OMP THREADPRIVATE(first) + CHARACTER (LEN=20) :: modname='cva_driver' + CHARACTER (LEN=80) :: abort_message + +c +! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,klev) +! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,klev) + +!------------------------------------------------------------------- +! --- SET CONSTANTS AND PARAMETERS +!------------------------------------------------------------------- + + if (first) then + allocate(mp(nloc,klev), qp(nloc,klev), up(nloc,klev)) + allocate(vp(nloc,klev), wt(nloc,klev), water(nloc,klev)) + allocate(evap(nloc,klev), b(nloc,klev)) + first=.false. + endif +c -- set simulation flags: +c (common cvflag) + + CALL cv_flag + +c -- set thermodynamical constants: +c (common cvthermo) + + CALL cv_thermo(iflag_con) + +c -- set convect parameters +c +c includes microphysical parameters and parameters that +c control the rate of approach to quasi-equilibrium) +c (common cvparam) + + if (iflag_con.eq.3) then + CALL cv3_param(nd,delt) + + endif + + if (iflag_con.eq.4) then + CALL cv_param(nd) + endif + +!--------------------------------------------------------------------- +! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS +!--------------------------------------------------------------------- + nword1=len + nword2=len*nd + nword3=len*nd*ntra + nword4=len*nd*nd + +! call izilch(iflag1 ,nword1) +! call zilch(iflag1 ,nword1) + do i=1,len + iflag1(i)=0 + ktop1(i)=0 + kbas1(i)=0 + enddo + call zilch(ft1 ,nword2) + call zilch(fq1 ,nword2) + call zilch(fu1 ,nword2) + call zilch(fv1 ,nword2) + call zilch(ftra1 ,nword3) + call zilch(precip1 ,nword1) +! call izilch(kbas1 ,nword1) +! call zilch(kbas1 ,nword1) +! call izilch(ktop1 ,nword1) +! call zilch(ktop1 ,nword1) + call zilch(cbmf1 ,nword1) + call zilch(ptop21 ,nword1) + sigd1=0. + call zilch(Ma1 ,nword2) + call zilch(mip1 ,nword2) +! call zilch(Vprecip1,nword2) + Vprecip1=0. + call zilch(upwd1 ,nword2) + call zilch(dnwd1 ,nword2) + call zilch(dnwd01 ,nword2) + call zilch(qcondc1 ,nword2) +!test +! call zilch(qcondc ,nword2) + call zilch(wd1 ,nword1) + call zilch(cape1 ,nword1) + call zilch(cin1 ,nword1) + call zilch(tvp1 ,nword2) + call zilch(ftd1 ,nword2) + call zilch(fqd1 ,nword2) + call zilch(Plim11 ,nword1) + call zilch(Plim21 ,nword1) + call zilch(asupmax1,nword2) + call zilch(supmax01,nword1) + call zilch(asupmaxmin1,nword1) +c + DO il = 1,len + cin1(il) = -100000. + cape1(il) = -1. + ENDDO +c + if (iflag_con.eq.3) then + do il=1,len + sig1(il,nd)=sig1(il,nd)+1. + sig1(il,nd)=amin1(sig1(il,nd),12.1) + enddo + endif + +!--------------------------------------------------------------------- +! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS +!--------------------------------------------------------------------- +! + do il = 1,nloc + coef_clos(il)=1. + enddo + +!-------------------------------------------------------------------- +! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY +!-------------------------------------------------------------------- + + if (iflag_con.eq.3) then + + if (debut) THEN + print*,'Emanuel version 3 nouvelle' + endif +! print*,'t1, q1 ',t1,q1 + CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1 ! nd->na + o ,lv1,cpn1,tv1,gz1,h1,hm1,th1) + +c + CALL cv3_prelim(len,nd,ndp1,t1_wake,q1_wake,p1,ph1 ! nd->na + o ,lv1_wake,cpn1_wake,tv1_wake,gz1_wake + o ,h1_wake,bid,th1_wake) + + endif +c + if (iflag_con.eq.4) then + print*,'Emanuel version 4 ' + CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1 + o ,lv1,cpn1,tv1,gz1,h1,hm1) + endif + +!-------------------------------------------------------------------- +! --- CONVECTIVE FEED +!-------------------------------------------------------------------- +! +! compute feeding layer potential temperature and mixing ratio : +! +! get bounds of feeding layer +! +c test niveaux couche alimentation KE + if(sig1feed1.eq.sig2feed1) then + write(lunout,*)'impossible de choisir sig1feed=sig2feed' + write(lunout,*)'changer la valeur de sig2feed dans physiq.def' + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + endif +c + do i=1,len + p1feed1(i)=sig1feed1*ph1(i,1) + p2feed1(i)=sig2feed1*ph1(i,1) +ctest maf +c p1feed1(i)=ph1(i,1) +c p2feed1(i)=ph1(i,2) +c p2feed1(i)=ph1(i,3) +ctestCR: on prend la couche alim des thermiques +c p2feed1(i)=ph1(i,lalim_conv(i)+1) +c print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2) + end do +! + if (iflag_con.eq.3) then + endif + do i=1,len +! print*,'avant cv3_feed plim',p1feed1(i),p2feed1(i) + enddo + if (iflag_con.eq.3) then + +c print*, 'IFLAG1 avant cv3_feed' +c print*,'len,nd',len,nd +c write(*,'(64i1)') iflag1(2:klon-1) + + CALL cv3_feed(len,nd,t1,q1,u1,v1,p1,ph1,hm1,gz1 ! nd->na + i ,p1feed1,p2feed1,wght1 + o ,wghti1,tnk1,thnk1,qnk1,qsnk1,unk1,vnk1 + o ,cpnk1,hnk1,nk1,icb1,icbmax,iflag1,gznk1,plcl1) + endif + +c print*, 'IFLAG1 apres cv3_feed' +c print*,'len,nd',len,nd +c write(*,'(64i1)') iflag1(2:klon-1) + + if (iflag_con.eq.4) then + CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1 + o ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1) + endif +c +! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1) +c +!-------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part +! (up through ICB for convect4, up through ICB+1 for convect3) +! Calculates the lifted parcel virtual temperature at nk, the +! actual temperature, and the adiabatic liquid water content. +!-------------------------------------------------------------------- + + if (iflag_con.eq.3) then + + CALL cv3_undilute1(len,nd,t1,qs1,gz1,plcl1,p1,icb1,tnk1,qnk1 ! nd->na + o ,gznk1,tp1,tvp1,clw1,icbs1) + endif + + + if (iflag_con.eq.4) then + CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax + : ,tp1,tvp1,clw1) + endif +c +!------------------------------------------------------------------- +! --- TRIGGERING +!------------------------------------------------------------------- +c +! print *,' avant triggering, iflag_con ',iflag_con +c + if (iflag_con.eq.3) then + + CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1,thnk1 ! nd->na + o ,pbase1,buoybase1,iflag1,sig1,w01) + + +c print*, 'IFLAG1 apres cv3_triger' +c print*,'len,nd',len,nd +c write(*,'(64i1)') iflag1(2:klon-1) + +c call dump2d(iim,jjm-1,sig1(2) + endif + + if (iflag_con.eq.4) then + CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1) + endif +c +c +!===================================================================== +! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY +!===================================================================== + + ncum=0 + do 400 i=1,len + if(iflag1(i).eq.0)then + ncum=ncum+1 + idcum(ncum)=i + endif + 400 continue +c +! print*,'klon, ncum = ',len,ncum +c + IF (ncum.gt.0) THEN + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- COMPRESS THE FIELDS +! (-> vectorization over convective gridpoints) +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (iflag_con.eq.3) then +! print*,'ncum tv1 ',ncum,tv1 +! print*,'tvp1 ',tvp1 + CALL cv3a_compress( len,nloc,ncum,nd,ntra + : ,iflag1,nk1,icb1,icbs1 + : ,plcl1,tnk1,qnk1,gznk1,hnk1,unk1,vnk1 + : ,wghti1,pbase1,buoybase1 + : ,t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake + : ,u1,v1,gz1,th1,th1_wake + : ,tra1 + : ,h1 ,lv1 ,cpn1 ,p1,ph1,tv1 ,tp1,tvp1,clw1 + : ,h1_wake,lv1_wake,cpn1_wake ,tv1_wake + : ,sig1,w01,ptop21 + : ,Ale1,Alp1 + o ,iflag,nk,icb,icbs + o ,plcl,tnk,qnk,gznk,hnk,unk,vnk + o ,wghti,pbase,buoybase + o ,t,q,qs,t_wake,q_wake,qs_wake,s_wake + o ,u,v,gz,th,th_wake + o ,tra + o ,h ,lv ,cpn ,p,ph,tv ,tp,tvp,clw + o ,h_wake,lv_wake,cpn_wake ,tv_wake + o ,sig,w0,ptop2 + o ,Ale,Alp ) + +! print*,'tv ',tv +! print*,'tvp ',tvp + + endif + + if (iflag_con.eq.4) then + CALL cv_compress( len,nloc,ncum,nd + : ,iflag1,nk1,icb1 + : ,cbmf1,plcl1,tnk1,qnk1,gznk1 + : ,t1,q1,qs1,u1,v1,gz1 + : ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 + o ,iflag,nk,icb + o ,cbmf,plcl,tnk,qnk,gznk + o ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw + o ,dph ) + endif + +!------------------------------------------------------------------- +! --- UNDILUTE (ADIABATIC) UPDRAFT / second part : +! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES +! --- & +! --- COMPUTE THE PRECIPITATION EFFICIENCIES AND THE +! --- FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD +! --- & +! --- FIND THE LEVEL OF NEUTRAL BUOYANCY +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk !na->nd + : ,tnk,qnk,gznk,hnk,t,q,qs,gz + : ,p,h,tv,lv,pbase,buoybase,plcl + o ,inb,tp,tvp,clw,hp,ep,sigp,buoy) + + endif + + if (iflag_con.eq.4) then + CALL cv_undilute2(nloc,ncum,nd,icb,nk + : ,tnk,qnk,gznk,t,q,qs,gz + : ,p,dph,h,tv,lv + o ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac) + endif +c +!------------------------------------------------------------------- +! --- MIXING(1) (if iflag_mix .ge. 1) +!------------------------------------------------------------------- + IF (iflag_con .eq. 3) THEN + IF (iflag_mix .ge. 1 ) THEN + CALL zilch(supmax,nloc*klev) + CALL cv3p_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb ! na->nd + : ,ph,t,q,qs,u,v,tra,h,lv,qnk + : ,unk,vnk,hp,tv,tvp,ep,clw,sig + : ,ment,qent,hent,uent,vent,nent + : ,sij,elij,supmax,ments,qents,traent) +! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd) + + ELSE + CALL zilch(supmax,nloc*klev) + ENDIF + ENDIF +!------------------------------------------------------------------- +! --- CLOSURE +!------------------------------------------------------------------- + +c + if (iflag_con.eq.3) then + IF (iflag_clos .eq. 0) THEN + CALL cv3_closure(nloc,ncum,nd,icb,inb ! na->nd + : ,pbase,p,ph,tv,buoy + o ,sig,w0,cape,m,iflag) + ENDIF +c + ok_inhib = iflag_mix .EQ. 2 +c + IF (iflag_clos .eq. 1) THEN + print *,' pas d appel cv3p_closure' +cc CALL cv3p_closure(nloc,ncum,nd,icb,inb ! na->nd +cc : ,pbase,plcl,p,ph,tv,tvp,buoy +cc : ,supmax +cc o ,sig,w0,ptop2,cape,cin,m) + ENDIF + IF (iflag_clos .eq. 2) THEN + CALL cv3p1_closure(nloc,ncum,nd,icb,inb ! na->nd + : ,pbase,plcl,p,ph,tv,tvp,buoy + : ,supmax,ok_inhib,Ale,Alp + o ,sig,w0,ptop2,cape,cin,m,iflag,coef_clos + : ,Plim1,Plim2,asupmax,supmax0 + : ,asupmaxmin,cbmf,plfc,wbeff) + + print *,'cv3p1_closure-> plfc,wbeff ', plfc(1),wbeff(1) + ENDIF + endif ! iflag_con.eq.3 + + if (iflag_con.eq.4) then + CALL cv_closure(nloc,ncum,nd,nk,icb + : ,tv,tvp,p,ph,dph,plcl,cpn + o ,iflag,cbmf) + endif +c +! print *,'cv_closure-> cape ',cape(1) +c +!------------------------------------------------------------------- +! --- MIXING(2) +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + IF (iflag_mix.eq.0) THEN + CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb ! na->nd + : ,ph,t,q,qs,u,v,tra,h,lv,qnk + : ,unk,vnk,hp,tv,tvp,ep,clw,m,sig + o ,ment,qent,uent,vent,nent,sij,elij,ments,qents,traent) + CALL zilch(hent,nloc*klev*klev) + ELSE + CALL cv3_mixscale(nloc,ncum,nd,ment,m) + if (debut) THEN + print *,' cv3_mixscale-> ' + endif !(debut) THEN + ENDIF + endif + + if (iflag_con.eq.4) then + CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis + : ,ph,t,q,qs,u,v,h,lv,qnk + : ,hp,tv,tvp,ep,clw,cbmf + o ,m,ment,qent,uent,vent,nent,sij,elij) + endif +c + if (debut) THEN + print *,' cv_mixing ->' + endif !(debut) THEN +c do i = 1,klev +c print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,klev) +c enddo +c +!------------------------------------------------------------------- +! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS +!------------------------------------------------------------------- + if (iflag_con.eq.3) then + if (debut) THEN + print *,' cva_driver -> cv3_unsat ' + endif !(debut) THEN + + CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb,iflag ! na->nd + : ,t_wake,q_wake,qs_wake,gz,u,v,tra,p,ph + : ,th_wake,tv_wake,lv_wake,cpn_wake + : ,ep,sigp,clw + : ,m,ment,elij,delt,plcl,coef_clos + o ,mp,qp,up,vp,trap,wt,water,evap,b,sigd) + endif + + if (iflag_con.eq.4) then + CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph + : ,h,lv,ep,sigp,clw,m,ment,elij + o ,iflag,mp,qp,up,vp,wt,water,evap) + endif +c + if (debut) THEN + print *,'cv_unsat-> ' + endif !(debut) THEN +! +c print *,'cv_unsat-> mp ',mp +c print *,'cv_unsat-> water ',water +!------------------------------------------------------------------- +! --- YIELD +! (tendencies, precipitation, variables of interface with other +! processes, etc) +!------------------------------------------------------------------- + + if (iflag_con.eq.3) then + + CALL cv3_yield(nloc,ncum,nd,nd,ntra ! na->nd + : ,icb,inb,delt + : ,t,q,t_wake,q_wake,s_wake,u,v,tra + : ,gz,p,ph,h,hp,lv,cpn,th,th_wake + : ,ep,clw,m,tp,mp,qp,up,vp,trap + : ,wt,water,evap,b,sigd + : ,ment,qent,hent,iflag_mix,uent,vent + : ,nent,elij,traent,sig + : ,tv,tvp,wghti + : ,iflag,precip,Vprecip,ft,fq,fu,fv,ftra + : ,cbmf,upwd,dnwd,dnwd0,ma,mip + : ,tls,tps,qcondc,wd + : ,ftd,fqd) + endif +c + if (debut) THEN + print *,' cv3_yield -> fqd(1) = ',fqd(1,1) + endif !(debut) THEN +c + if (iflag_con.eq.4) then + CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt + : ,t,q,u,v + : ,gz,p,ph,h,hp,lv,cpn + : ,ep,clw,frac,m,mp,qp,up,vp + : ,wt,water,evap + : ,ment,qent,uent,vent,nent,elij + : ,tv,tvp + o ,iflag,wd,qprime,tprime + o ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc) + endif + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! --- UNCOMPRESS THE FIELDS +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + + if (iflag_con.eq.3) then + CALL cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum + : ,iflag,icb,inb + : ,precip,cbmf,plcl,plfc,wbeff,sig,w0,ptop2 + : ,ft,fq,fu,fv,ftra + : ,sigd,Ma,mip,Vprecip,upwd,dnwd,dnwd0 + ; ,qcondc,wd,cape,cin + : ,tvp + : ,ftd,fqd + : ,Plim1,Plim2,asupmax,supmax0 + : ,asupmaxmin + o ,iflag1,kbas1,ktop1 + o ,precip1,cbmf1,plcl1,plfc1,wbeff1,sig1,w01,ptop21 + o ,ft1,fq1,fu1,fv1,ftra1 + o ,sigd1,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01 + o ,qcondc1,wd1,cape1,cin1 + o ,tvp1 + o ,ftd1,fqd1 + o ,Plim11,Plim21,asupmax1,supmax01 + o ,asupmaxmin1) + endif + + if (iflag_con.eq.4) then + CALL cv_uncompress(nloc,len,ncum,nd,idcum + : ,iflag + : ,precip,cbmf + : ,ft,fq,fu,fv + : ,Ma,qcondc + o ,iflag1 + o ,precip1,cbmf1 + o ,ft1,fq1,fu1,fv1 + o ,Ma1,qcondc1 ) + endif + + ENDIF ! ncum>0 +c + if (debut) THEN + print *,' cv_compress -> ' + debut=.FALSE. + endif !(debut) THEN +c + +9999 continue + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvflag.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvflag.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvflag.h (revision 1634) @@ -0,0 +1,7 @@ +! +! $Header$ +! + logical cvflag_grav + + COMMON /cvflag/ cvflag_grav +c$OMP THREADPRIVATE(/cvflag/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvltr.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvltr.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvltr.F90 (revision 1634) @@ -0,0 +1,164 @@ +! +! $Id $ +! +SUBROUTINE cvltr(pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx) + USE dimphy + IMPLICIT NONE +!===================================================================== +! Objet : convection des traceurs / KE +! Auteurs: M-A Filiberti and J-Y Grandpeix +!===================================================================== + + include "YOMCST.h" + include "YOECUMF.h" + +! Entree + REAL,INTENT(IN) :: pdtime + REAL,DIMENSION(klon,klev),INTENT(IN) :: da + REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi + REAL,DIMENSION(klon,klev),INTENT(IN) :: mp + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le milieu de chaque couche + REAL,DIMENSION(klon,klev),INTENT(IN) :: x ! q de traceur (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(IN) :: upd ! saturated updraft mass flux + REAL,DIMENSION(klon,klev),INTENT(IN) :: dnd ! saturated downdraft mass flux + +! Sortie + REAL,DIMENSION(klon,klev),INTENT(OUT) :: dx ! tendance de traceur (bas en haut) + +! Variables locales +! REAL,DIMENSION(klon,klev) :: zed + REAL,DIMENSION(klon,klev,klev) :: zmd + REAL,DIMENSION(klon,klev,klev) :: za + REAL,DIMENSION(klon,klev) :: zmfd,zmfa + REAL,DIMENSION(klon,klev) :: zmfp,zmfu + INTEGER :: i,k,j + REAL :: pdtimeRG + +! ========================================= +! calcul des tendances liees au downdraft +! ========================================= +!cdir collapse + DO j=1,klev + DO i=1,klon +! zed(i,j)=0. + zmfd(i,j)=0. + zmfa(i,j)=0. + zmfu(i,j)=0. + zmfp(i,j)=0. + END DO + END DO +!cdir collapse + DO k=1,klev + DO j=1,klev + DO i=1,klon + zmd(i,j,k)=0. + za (i,j,k)=0. + END DO + END DO + END DO +! entrainement +! DO k=1,klev-1 +! DO i=1,klon +! zed(i,k)=max(0.,mp(i,k)-mp(i,k+1)) +! END DO +! END DO + +! calcul de la matrice d echange +! matrice de distribution de la masse entrainee en k + + DO k=1,klev-1 + DO i=1,klon + zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1)) + END DO + END DO + DO k=2,klev + DO j=k-1,1,-1 + DO i=1,klon + if(mp(i,j+1).ne.0) then + zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) + ENDif + END DO + END DO + END DO + DO k=1,klev + DO j=1,klev-1 + DO i=1,klon + za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k)) + END DO + END DO + END DO +! +! rajout du terme lie a l ascendance induite +! + DO j=2,klev + DO i=1,klon + za(i,j,j-1)=za(i,j,j-1)+mp(i,j) + END DO + END DO +! +! tendances +! + DO k=1,klev + DO j=1,klev + DO i=1,klon + zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k)-x(i,j)) + END DO + END DO + END DO +! +! ========================================= +! calcul des tendances liees aux flux satures +! ========================================= + DO j=1,klev + DO i=1,klon + zmfa(i,j)=da(i,j)*(x(i,1)-x(i,j)) + END DO + END DO + DO k=1,klev + DO j=1,klev + DO i=1,klon + zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k)-x(i,j)) + END DO + END DO + END DO + DO j=1,klev-1 + DO i=1,klon + zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1)-x(i,j)) + END DO + END DO + DO j=2,klev + DO i=1,klon + zmfu(i,j)=zmfu(i,j)+min(0.,upd(i,j)+dnd(i,j))*(x(i,j)-x(i,j-1)) + END DO + END DO + +! ========================================= +! calcul final des tendances +! ========================================= + DO k=1, klev + DO i=1, klon + dx(i,k)=paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + pdtimeRG=pdtime*RG +!cdir collapse + DO k=1, klev + DO i=1, klon + dx(i,k)=(zmfd(i,k)+zmfu(i,k) & + +zmfa(i,k)+zmfp(i,k))*pdtimeRG/dx(i,k) + ! print*,'dx',k,dx(i,k) + ENDDO + ENDDO + +! test de conservation du traceur +! conserv=0. +! DO k=1, klev +! DO i=1, klon +! conserv=conserv+dx(i,k)* & +! (paprs(i,k)-paprs(i,k+1))/RG +! ENDDO +! ENDDO +! print *,'conserv',conserv + +END SUBROUTINE cvltr Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvparam.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvparam.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvparam.h (revision 1634) @@ -0,0 +1,29 @@ +! +! $Header$ +! +c------------------------------------------------------------ +c Parameters for convectL: +c (includes - microphysical parameters, +c - parameters that control the rate of approach +c to quasi-equilibrium) +c - noff & minorig (previously in input of convect1) +c------------------------------------------------------------ + + integer noff, minorig, nl, nlp, nlm + real elcrit, tlcrit + real entp + real sigs, sigd + real omtrain, omtsnow, coeffr, coeffs + real dtmax + real cu + real betad + real alpha, damp + real delta + + COMMON /cvparam/ noff, minorig, nl, nlp, nlm + : ,elcrit, tlcrit + : ,entp, sigs, sigd + : ,omtrain, omtsnow, coeffr, coeffs + : ,dtmax, cu, betad, alpha, damp, delta + +c$OMP THREADPRIVATE(/cvparam/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvthermo.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvthermo.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/cvthermo.h (revision 1634) @@ -0,0 +1,16 @@ +! +! $Header$ +! +c Thermodynamical constants for convectL: + + real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0 + real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl + real eps, epsi, epsim1 + real ginv, hrd + real grav + + COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0 + : ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl + : ,eps, epsi, epsim1, ginv, hrd, grav + +c$OMP THREADPRIVATE(/cvthermo/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/diagphy.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/diagphy.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/diagphy.F (revision 1634) @@ -0,0 +1,415 @@ +! +! $Header$ +! + SUBROUTINE diagphy(airephy,tit,iprt + $ , tops, topl, sols, soll, sens + $ , evap, rain_fall, snow_fall, ts + $ , d_etp_tot, d_qt_tot, d_ec_tot + $ , fs_bound, fq_bound) +C====================================================================== +C +C Purpose: +C Compute the thermal flux and the watter mass flux at the atmosphere +c boundaries. Print them and also the atmospheric enthalpy change and +C the atmospheric mass change. +C +C Arguments: +C airephy-------input-R- grid area +C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15) +C iprt--------input-I- PRINT level ( <=0 : no PRINT) +C tops(klon)--input-R- SW rad. at TOA (W/m2), positive up. +C topl(klon)--input-R- LW rad. at TOA (W/m2), positive down +C sols(klon)--input-R- Net SW flux above surface (W/m2), positive up +C (i.e. -1 * flux absorbed by the surface) +C soll(klon)--input-R- Net LW flux above surface (W/m2), positive up +C (i.e. flux emited - flux absorbed by the surface) +C sens(klon)--input-R- Sensible Flux at surface (W/m2), positive down +C evap(klon)--input-R- Evaporation + sublimation watter vapour mass flux +C (kg/m2/s), positive up +C rain_fall(klon) +C --input-R- Liquid watter mass flux (kg/m2/s), positive down +C snow_fall(klon) +C --input-R- Solid watter mass flux (kg/m2/s), positive down +C ts(klon)----input-R- Surface temperature (K) +C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy +C change (W/m2) +C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass +C change (kg/m2/s) +C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy +C change (W/m2) +C +C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2) +C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s) +C +C J.L. Dufresne, July 2002 +C Version prise sur ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd +C le 25 Novembre 2002. +C====================================================================== +C + use dimphy + implicit none + +#include "dimensions.h" +ccccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C +C Input variables + real airephy(klon) + CHARACTER*15 tit + INTEGER iprt + real tops(klon),topl(klon),sols(klon),soll(klon) + real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon) + REAL ts(klon) + REAL d_etp_tot, d_qt_tot, d_ec_tot +c Output variables + REAL fs_bound, fq_bound +C +C Local variables + real stops,stopl,ssols,ssoll + real ssens,sfront,slat + real airetot, zcpvap, zcwat, zcice + REAL rain_fall_tot, snow_fall_tot, evap_tot +C + integer i +C + integer pas + save pas + data pas/0/ +c$OMP THREADPRIVATE(pas) +C + pas=pas+1 + stops=0. + stopl=0. + ssols=0. + ssoll=0. + ssens=0. + sfront = 0. + evap_tot = 0. + rain_fall_tot = 0. + snow_fall_tot = 0. + airetot=0. +C +C Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de +C la glace, on travaille par difference a la chaleur specifique de l' +c air sec. En effet, comme on travaille a niveau de pression donne, +C toute variation de la masse d'un constituant est totalement +c compense par une variation de masse d'air. +C + zcpvap=RCPV-RCPD + zcwat=RCW-RCPD + zcice=RCS-RCPD +C + do i=1,klon + stops=stops+tops(i)*airephy(i) + stopl=stopl+topl(i)*airephy(i) + ssols=ssols+sols(i)*airephy(i) + ssoll=ssoll+soll(i)*airephy(i) + ssens=ssens+sens(i)*airephy(i) + sfront = sfront + $ + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice + $ ) *ts(i) *airephy(i) + evap_tot = evap_tot + evap(i)*airephy(i) + rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i) + snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i) + airetot=airetot+airephy(i) + enddo + stops=stops/airetot + stopl=stopl/airetot + ssols=ssols/airetot + ssoll=ssoll/airetot + ssens=ssens/airetot + sfront = sfront/airetot + evap_tot = evap_tot /airetot + rain_fall_tot = rain_fall_tot/airetot + snow_fall_tot = snow_fall_tot/airetot +C + slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot +C Heat flux at atm. boundaries + fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront + $ + slat +C Watter flux at atm. boundaries + fq_bound = evap_tot - rain_fall_tot -snow_fall_tot +C + IF (iprt.ge.1) write(6,6666) + $ tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot +C + IF (iprt.ge.1) write(6,6668) + $ tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound +C + IF (iprt.ge.2) write(6,6667) + $ tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot + $ ,rain_fall_tot+snow_fall_tot + + return + + 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5)) + 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5)) + 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5)) + + end + +C====================================================================== + SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime + e ,t,q,ql,qs,u,v,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la physique. Suppose que les niveau de +c pression entre couche ne varie pas entre 2 appels. +C +C Plusieurs de ces diagnostics peuvent etre fait en parallele: les +c bilans sont sauvegardes dans des tableaux indices. On parlera +C "d'indice de diagnostic" +c +C +c====================================================================== +C Arguments: +C airephy-------input-R- grid area +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +c t--------input-R- temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c qs-------input-R- solid watter (kg/kg) +c u--------input-R- vitesse u +c v--------input-R- vitesse v +c paprs----input-R- pression a intercouche (Pa) +c pplay----input-R- pression au milieu de couche (Pa) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_qs------output-R- same, for the solid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C other (COMMON...) +C RCPD, RCPV, .... +C +C J.L. Dufresne, July 2002 +c====================================================================== + + USE dimphy + IMPLICIT NONE +C +#include "dimensions.h" +cccccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +C +c Input variables + real airephy(klon) + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev) + REAL u(klon,klev), v(klon,klev) + REAL paprs(klon,klev+1), pplay(klon,klev) +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL zairm(klon,klev) ! layer air mass (kg/m2) + REAL zqw_col(klon) + REAL zql_col(klon) + REAL zqs_col(klon) + REAL zec_col(klon) + REAL zh_dair_col(klon) + REAL zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +c$OMP THREADPRIVATE(pas) +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre +c$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre) +c$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre) +c====================================================================== +C + DO k = 1, klev + DO i = 1, klon +C layer air mass + zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG + ENDDO + END DO +C +C Reset variables + DO i = 1, klon + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, klev + DO i = 1, klon +C Watter mass + zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k) +C Air enthalpy + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*q(i,k)*zairm(i,k)*t(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*ql(i,k)*zairm(i,k)*t(i,k) + $ - RLVTT*ql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*qs(i,k)*zairm(i,k)*t(i,k) + $ - RLSTT*qs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,klon + qw_tot = qw_tot + zqw_col(i)*airephy(i) + ql_tot = ql_tot + zql_col(i)*airephy(i) + qs_tot = qs_tot + zqs_col(i)*airephy(i) + ec_tot = ec_tot + zec_col(i)*airephy(i) + h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i) + h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i) + h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i) + h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i) + airetot=airetot+airephy(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Phys. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/dimphy.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/dimphy.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/dimphy.F90 (revision 1634) @@ -0,0 +1,40 @@ +MODULE dimphy + + INTEGER,SAVE :: klon + INTEGER,SAVE :: kdlon + INTEGER,SAVE :: kfdia + INTEGER,SAVE :: kidia + INTEGER,SAVE :: klev + INTEGER,SAVE :: klevp1 + INTEGER,SAVE :: klevm1 + INTEGER,SAVE :: kflev + +!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon) + REAL,save,allocatable,dimension(:) :: zmasq +!$OMP THREADPRIVATE(zmasq) + +CONTAINS + + SUBROUTINE Init_dimphy(klon0,klev0) + IMPLICIT NONE + + INTEGER, INTENT(in) :: klon0 + INTEGER, INTENT(in) :: klev0 + + klon=klon0 + + kdlon=klon + kidia=1 + kfdia=klon +!$OMP MASTER + klev=klev0 + klevp1=klev+1 + klevm1=klev-1 + kflev=klev +!$OMP END MASTER + ALLOCATE(zmasq(klon)) + + END SUBROUTINE Init_dimphy + + +END MODULE dimphy Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/dimsoil.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/dimsoil.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/dimsoil.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER nsoilmx + PARAMETER (nsoilmx=11) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ecribin.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ecribin.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ecribin.F (revision 1634) @@ -0,0 +1,104 @@ +! +! $Header$ +! + SUBROUTINE ecribins(unit,pz) + USE dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon) +c +c local: +c ------ + INTEGER i,j, ig + REAL zz(iim +1,jjm+1) +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO i=1,iim +1 + zz(i,1)=pz(1) + zz(i,jjm+1)=pz(klon) + ENDDO +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig),1,zz(1,j),1) + zz(iim+1,j)=zz(1,j) + ENDDO +c----------------------------------------------------------------------- +#ifdef VPP + CALL ecriture(unit,zz,(iim+1)*(jjm+1)) +#else + WRITE(unit) zz +#endif +c + + RETURN + END + SUBROUTINE ecribina(unit,pz) + USE dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon,klev) +c +c local: +c ------ + INTEGER i,j,ilay,ig + REAL zz(iim+1,jjm+1,llm) +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO ilay=1,llm +c traitement des poles + DO i=1,iim +1 + zz(i,1,ilay)=pz(1,ilay) + zz(i,jjm+1,ilay)=pz(klon,ilay) + ENDDO +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1) + zz(iim+1,j,ilay)=zz(1,j,ilay) + ENDDO + ENDDO +c----------------------------------------------------------------------- + DO ilay = 1, llm +#ifdef VPP + CALL ecriture(unit, zz(1,1,ilay), (iim+1)*(jjm+1)) +#else + WRITE(unit) ((zz(i,j,ilay),i=1,iim +1),j=1,jjm+1) +#endif + ENDDO +c + RETURN + END +#ifdef VPP +@OPTIONS NODOUBLE + SUBROUTINE ecriture(nunit, r8, n) + INTEGER nunit, n, i + REAL(KIND=8) r8(n) + REAL r4(n) + DO i = 1, n + r4(i) = r8(i) + ENDDO + WRITE(nunit)r4 + RETURN + END +#endif Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ecrireg.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ecrireg.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ecrireg.F (revision 1634) @@ -0,0 +1,121 @@ +! +! $Header$ +! + SUBROUTINE ecriregs(unit,pz) + use dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +#include "regdim.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon) +c +c local: +c ------ + INTEGER i,j, ig + REAL zz(iim,jjm+1) + INTEGER nleng + PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1) + . *(j_fin-j_deb+1)) + REAL zzz(nleng) +c +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO i=1,iim + zz(i,1)=pz(1) + zz(i,jjm+1)=pz(klon) + ENDDO +c +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig),1,zz(1,j),1) + ENDDO +c----------------------------------------------------------------------- + ig = 0 + DO j = j_deb, j_fin + DO i=i1_deb,i1_fin + ig = ig + 1 + zzz(ig) = zz(i,j) + ENDDO + DO i=i2_deb,i2_fin + ig = ig + 1 + zzz(ig) = zz(i,j) + ENDDO + ENDDO +#ifdef VPP + CALL ecriture(unit,zzz,nleng) +#else + WRITE(unit) zzz +#endif + RETURN + END + SUBROUTINE ecrirega(unit,pz) + USE dimphy + IMPLICIT none +c----------------------------------------------------------------------- +#include "dimensions.h" +cccc#include "dimphy.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +#include "regdim.h" +c +c arguments: +c ---------- + INTEGER unit + REAL pz(klon,klev) +c +c local: +c ------ + INTEGER i,j,ilay,ig + REAL zz(iim,jjm+1,llm) + INTEGER nleng + PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1) + . *(j_fin-j_deb+1)) + REAL zzz(nleng) +c----------------------------------------------------------------------- +c passage a la grille dynamique: +c ------------------------------ + DO ilay=1,llm +c traitement des poles + DO i=1,iim + zz(i,1,ilay)=pz(1,ilay) + zz(i,jjm+1,ilay)=pz(klon,ilay) + ENDDO +c traitement des point normaux + DO j=2,jjm + ig=2+(j-2)*iim + CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1) + ENDDO + ENDDO +c----------------------------------------------------------------------- + DO ilay = 1, llm + ig = 0 + DO j = j_deb, j_fin + DO i=i1_deb,i1_fin + ig = ig + 1 + zzz(ig) = zz(i,j,ilay) + ENDDO + DO i=i2_deb,i2_fin + ig = ig + 1 + zzz(ig) = zz(i,j,ilay) + ENDDO + ENDDO +#ifdef VPP + CALL ecriture(unit,zzz,nleng) +#else + WRITE(unit) zzz +#endif + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp.F90 (revision 1634) @@ -0,0 +1,621 @@ +! +! $Id$ +! +! +SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,ptconv,ratqs, & + d_t, d_q, d_ql, rneb, radliq, rain, snow, & + pfrac_impa, pfrac_nucl, pfrac_1nucl, & + frac_impa, frac_nucl, & + prfl, psfl, rhcl, zqta, fraca, & + ztv, zpspsk, ztla, zthl, iflag_cldcon) + + ! + USE dimphy + IMPLICIT none + !====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) + ! Date: le 20 mars 1995 + ! Objet: condensation et precipitation stratiforme. + ! schema de nuage + !====================================================================== + !====================================================================== + !ym include "dimensions.h" + !ym include "dimphy.h" + include "YOMCST.h" + include "tracstoke.h" + include "fisrtilp.h" + include "iniprint.h" + + ! + ! Arguments: + ! + REAL dtime ! intervalle du temps (s) + REAL paprs(klon,klev+1) ! pression a inter-couche + REAL pplay(klon,klev) ! pression au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL d_t(klon,klev) ! incrementation de la temperature (K) + REAL d_q(klon,klev) ! incrementation de la vapeur d'eau + REAL d_ql(klon,klev) ! incrementation de l'eau liquide + REAL rneb(klon,klev) ! fraction nuageuse + REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements + REAL rhcl(klon,klev) ! humidite relative en ciel clair + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) + REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) + REAL ztv(klon,klev) + REAL zqta(klon,klev),fraca(klon,klev) + REAL sigma1(klon,klev),sigma2(klon,klev) + REAL qltot(klon,klev),ctot(klon,klev) + REAL zpspsk(klon,klev),ztla(klon,klev) + REAL zthl(klon,klev) + + logical lognormale(klon) + + !AA + ! Coeffients de fraction lessivee : pour OFF-LINE + ! + REAL pfrac_nucl(klon,klev) + REAL pfrac_1nucl(klon,klev) + REAL pfrac_impa(klon,klev) + ! + ! Fraction d'aerosols lessivee par impaction et par nucleation + ! POur ON-LINE + ! + REAL frac_impa(klon,klev) + REAL frac_nucl(klon,klev) + real zct ,zcl + !AA + ! + ! Options du programme: + ! + REAL seuil_neb ! un nuage existe vraiment au-dela + PARAMETER (seuil_neb=0.001) + + INTEGER ninter ! sous-intervals pour la precipitation + INTEGER ncoreczq + INTEGER iflag_cldcon + PARAMETER (ninter=5) + LOGICAL evap_prec ! evaporation de la pluie + PARAMETER (evap_prec=.TRUE.) + REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur + logical ptconv(klon,klev) ! determine la largeur de distribution de vapeur + + real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon) + real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon) + real erf + REAL qcloud(klon) + ! + LOGICAL cpartiel ! condensation partielle + PARAMETER (cpartiel=.TRUE.) + REAL t_coup + PARAMETER (t_coup=234.0) + ! + ! Variables locales: + ! + INTEGER i, k, n, kk + REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5 + REAL zrfl(klon), zrfln(klon), zqev, zqevt + REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq + REAL ztglace, zt(klon) + INTEGER nexpo ! exponentiel pour glace/eau + REAL zdz(klon),zrho(klon),ztot , zrhol(klon) + REAL zchau ,zfroi ,zfice(klon),zneb(klon) + ! + LOGICAL appel1er + SAVE appel1er + !$OMP THREADPRIVATE(appel1er) + ! + !--------------------------------------------------------------- + ! + !AA Variables traceurs: + !AA Provisoire !!! Parametres alpha du lessivage + !AA A priori on a 4 scavenging # possibles + ! + REAL a_tr_sca(4) + save a_tr_sca + !$OMP THREADPRIVATE(a_tr_sca) + ! + ! Variables intermediaires + ! + REAL zalpha_tr + REAL zfrac_lessi + REAL zprec_cond(klon) + !AA + REAL zmair, zcpair, zcpeau + ! Pour la conversion eau-neige + REAL zlh_solid(klon), zm_solid + !IM + !ym INTEGER klevm1 + !--------------------------------------------------------------- + ! + ! Fonctions en ligne: + ! + REAL fallvs,fallvc ! vitesse de chute pour crystaux de glace + REAL zzz + include "YOETHF.h" + include "FCTTRE.h" + fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con + fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc + ! + DATA appel1er /.TRUE./ + !ym + zdelq=0.0 + + if (prt_level>9)write(lunout,*)'NUAGES4 A. JAM' + IF (appel1er) THEN + ! + PRINT*, 'fisrtilp, ninter:', ninter + PRINT*, 'fisrtilp, evap_prec:', evap_prec + PRINT*, 'fisrtilp, cpartiel:', cpartiel + IF (ABS(dtime/REAL(ninter)-360.0).GT.0.001) THEN + PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime + PRINT*, 'Je prefere un sous-intervalle de 6 minutes' + ! CALL abort + ENDIF + appel1er = .FALSE. + ! + !AA initialiation provisoire + a_tr_sca(1) = -0.5 + a_tr_sca(2) = -0.5 + a_tr_sca(3) = -0.5 + a_tr_sca(4) = -0.5 + ! + !AA Initialisation a 1 des coefs des fractions lessivees + ! + !cdir collapse + DO k = 1, klev + DO i = 1, klon + pfrac_nucl(i,k)=1. + pfrac_1nucl(i,k)=1. + pfrac_impa(i,k)=1. + ENDDO + ENDDO + + ENDIF ! test sur appel1er + ! + !MAf Initialisation a 0 de zoliq + ! DO i = 1, klon + ! zoliq(i)=0. + ! ENDDO + ! Determiner les nuages froids par leur temperature + ! nexpo regle la raideur de la transition eau liquide / eau glace. + ! + ztglace = RTT - 15.0 + nexpo = 6 + !cc nexpo = 1 + ! + ! Initialiser les sorties: + ! + !cdir collapse + DO k = 1, klev+1 + DO i = 1, klon + prfl(i,k) = 0.0 + psfl(i,k) = 0.0 + ENDDO + ENDDO + + !cdir collapse + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + radliq(i,k) = 0.0 + frac_nucl(i,k) = 1. + frac_impa(i,k) = 1. + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + zoliq(i)=0. + ! ENDDO + ! + ! Initialiser le flux de precipitation a zero + ! + ! DO i = 1, klon + zrfl(i) = 0.0 + zneb(i) = seuil_neb + ENDDO + ! + ! + !AA Pour plus de securite + + zalpha_tr = 0. + zfrac_lessi = 0. + + !AA---------------------------------------------------------- + ! + ncoreczq=0 + ! Boucle verticale (du haut vers le bas) + ! + !IM : klevm1 + !ym klevm1=klev-1 + DO k = klev, 1, -1 + ! + !AA---------------------------------------------------------- + ! + DO i = 1, klon + zt(i)=t(i,k) + zq(i)=q(i,k) + ENDDO + ! + ! Calculer la varition de temp. de l'air du a la chaleur sensible + ! transporter par la pluie. + ! Il resterait a rajouter cet effet de la chaleur sensible sur les + ! flux de surface, du a la diff. de temp. entre le 1er niveau et la + ! surface. + ! + IF(k.LE.klevm1) THEN + DO i = 1, klon + !IM + zmair=(paprs(i,k)-paprs(i,k+1))/RG + zcpair=RCPD*(1.0+RVTMP2*zq(i)) + zcpeau=RCPD*RVTMP2 + zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau & + + zmair*zcpair*zt(i) ) & + / (zmair*zcpair + zrfl(i)*dtime*zcpeau) + ! C WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1)) + ENDDO + ENDIF + ! + ! + ! Calculer l'evaporation de la precipitation + ! + + + IF (evap_prec) THEN + DO i = 1, klon + IF (zrfl(i) .GT.0.) THEN + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i))) + zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i)=MIN(0.5,zqs(i)) + zcor=1./(1.-RETV*zqs(i)) + zqs(i)=zqs(i)*zcor + ELSE + IF (zt(i) .LT. t_coup) THEN + zqs(i) = qsats(zt(i)) / pplay(i,k) + ELSE + zqs(i) = qsatl(zt(i)) / pplay(i,k) + ENDIF + ENDIF + zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) ) + zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) & + * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) & + * RG*dtime/(paprs(i,k)-paprs(i,k+1)) + zqev = MIN (zqev, zqevt) + zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) & + /RG/dtime + + ! pour la glace, on ré-évapore toute la précip dans la + ! couche du dessous + ! la glace venant de la couche du dessus est simplement + ! dans la couche du dessous. + + IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0. + + zq(i) = zq(i) - (zrfln(i)-zrfl(i)) & + * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + zt(i) = zt(i) + (zrfln(i)-zrfl(i)) & + * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime & + * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) + zrfl(i) = zrfln(i) + ENDIF + ENDDO + ENDIF + ! + ! Calculer Qs et L/Cp*dQs/dT: + ! + IF (thermcep) THEN + DO i = 1, klon + zdelta = MAX(0.,SIGN(1.,RTT-zt(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i)) + zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i) = MIN(0.5,zqs(i)) + zcor = 1./(1.-RETV*zqs(i)) + zqs(i) = zqs(i)*zcor + zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor) + ENDDO + ELSE + DO i = 1, klon + IF (zt(i).LT.t_coup) THEN + zqs(i) = qsats(zt(i))/pplay(i,k) + zdqs(i) = dqsats(zt(i),zqs(i)) + ELSE + zqs(i) = qsatl(zt(i))/pplay(i,k) + zdqs(i) = dqsatl(zt(i),zqs(i)) + ENDIF + ENDDO + ENDIF + ! + ! Determiner la condensation partielle et calculer la quantite + ! de l'eau condensee: + ! + + IF (cpartiel) THEN + + ! print*,'Dans partiel k=',k + ! + ! Calcul de l'eau condensee et de la fraction nuageuse et de l'eau + ! nuageuse a partir des PDF de Sandrine Bony. + ! rneb : fraction nuageuse + ! zqn : eau totale dans le nuage + ! zcond : eau condensee moyenne dans la maille. + ! on prend en compte le réchauffement qui diminue la partie + ! condensee + ! + ! Version avec les raqts + + if (iflag_pdf.eq.0) then + + do i=1,klon + zdelq = min(ratqs(i,k),0.99) * zq(i) + rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq) + zqn(i) = (zq(i)+zdelq+zqs(i))/2.0 + enddo + + else + ! + ! Version avec les nouvelles PDFs. + do i=1,klon + if(zq(i).lt.1.e-15) then + ncoreczq=ncoreczq+1 + zq(i)=1.e-15 + endif + enddo + + if (iflag_cldcon>=5) then + + call cloudth(klon,klev,k,ztv, & + zq,zqta,fraca, & + qcloud,ctot,zpspsk,paprs,ztla,zthl, & + ratqs,zqs,t) + + do i=1,klon + rneb(i,k)=ctot(i,k) + zqn(i)=qcloud(i) + enddo + + endif + + if (iflag_cldcon <= 4) then + lognormale = .true. + elseif (iflag_cldcon >= 6) then + ! lognormale en l'absence des thermiques + lognormale = fraca(:,k) < 1e-10 + else + ! Dans le cas iflag_cldcon=5, on prend systématiquement la + ! bi-gaussienne + lognormale = .false. + end if + + do i=1,klon + if (lognormale(i)) then + zpdf_sig(i)=ratqs(i,k)*zq(i) + zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2)) + zpdf_delta(i)=log(zq(i)/zqs(i)) + zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.)) + zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.)) + zpdf_e1(i)=zpdf_a(i)-zpdf_b(i) + zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i)) + zpdf_e1(i)=1.-erf(zpdf_e1(i)) + zpdf_e2(i)=zpdf_a(i)+zpdf_b(i) + zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i)) + zpdf_e2(i)=1.-erf(zpdf_e2(i)) + endif + enddo + + do i=1,klon + if (lognormale(i)) then + if (zpdf_e1(i).lt.1.e-10) then + rneb(i,k)=0. + zqn(i)=zqs(i) + else + rneb(i,k)=0.5*zpdf_e1(i) + zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i) + endif + endif + + enddo + + + endif ! iflag_pdf + + DO i=1,klon + IF (rneb(i,k) .LE. 0.0) THEN + zqn(i) = 0.0 + rneb(i,k) = 0.0 + zcond(i) = 0.0 + rhcl(i,k)=zq(i)/zqs(i) + ELSE IF (rneb(i,k) .GE. 1.0) THEN + zqn(i) = zq(i) + rneb(i,k) = 1.0 + zcond(i) = MAX(0.0,zqn(i)-zqs(i)) + rhcl(i,k)=1.0 + ELSE + zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k) + rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i) + ENDIF + ENDDO + ! do i=1,klon + ! IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0 + ! IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i) + ! rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k))) + !c zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i)) + !c On ne divise pas par 1+zdqs pour forcer a avoir l'eau predite par + !c la convection. + !c ATTENTION !!! Il va falloir verifier tout ca. + ! zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k) + !c print*,'ZDQS ',zdqs(i) + !c--Olivier + ! rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i) + ! IF (rneb(i,k) .LE. 0.0) rhcl(i,k)=zq(i)/zqs(i) + ! IF (rneb(i,k) .GE. 1.0) rhcl(i,k)=1.0 + !c--fin + ! ENDDO + ELSE + DO i = 1, klon + IF (zq(i).GT.zqs(i)) THEN + rneb(i,k) = 1.0 + ELSE + rneb(i,k) = 0.0 + ENDIF + zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i)) + ENDDO + ENDIF + ! + DO i = 1, klon + zq(i) = zq(i) - zcond(i) + ! zt(i) = zt(i) + zcond(i) * RLVTT/RCPD + zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) + ENDDO + ! + ! Partager l'eau condensee en precipitation et eau liquide nuageuse + ! + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zoliq(i) = zcond(i) + zrho(i) = pplay(i,k) / zt(i) / RD + zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG) + zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace) + zfice(i) = MIN(MAX(zfice(i),0.0),1.0) + zfice(i) = zfice(i)**nexpo + zneb(i) = MAX(rneb(i,k), seuil_neb) + radliq(i,k) = zoliq(i)/REAL(ninter+1) + ENDIF + ENDDO + ! + DO n = 1, ninter + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zrhol(i) = zrho(i) * zoliq(i) / zneb(i) + + IF (zneb(i).EQ.seuil_neb) THEN + ztot = 0.0 + ELSE + ! quantite d'eau a eliminer: zchau + ! meme chose pour la glace: zfroi + if (ptconv(i,k)) then + zcl =cld_lc_con + zct =1./cld_tau_con + zfroi = dtime/REAL(ninter)/zdz(i)*zoliq(i) & + *fallvc(zrhol(i)) * zfice(i) + else + zcl =cld_lc_lsc + zct =1./cld_tau_lsc + zfroi = dtime/REAL(ninter)/zdz(i)*zoliq(i) & + *fallvs(zrhol(i)) * zfice(i) + endif + zchau = zct *dtime/REAL(ninter) * zoliq(i) & + *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl )**2)) *(1.-zfice(i)) + ztot = zchau + zfroi + ztot = MAX(ztot ,0.0) + ENDIF + ztot = MIN(ztot,zoliq(i)) + zoliq(i) = MAX(zoliq(i)-ztot , 0.0) + radliq(i,k) = radliq(i,k) + zoliq(i)/REAL(ninter+1) + ENDIF + ENDDO + ENDDO + ! + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + d_ql(i,k) = zoliq(i) + zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0) & + * (paprs(i,k)-paprs(i,k+1))/(RG*dtime) + ENDIF + IF (zt(i).LT.RTT) THEN + psfl(i,k)=zrfl(i) + ELSE + prfl(i,k)=zrfl(i) + ENDIF + ENDDO + ! + ! Calculer les tendances de q et de t: + ! + DO i = 1, klon + d_q(i,k) = zq(i) - q(i,k) + d_t(i,k) = zt(i) - t(i,k) + ENDDO + ! + !AA--------------- Calcul du lessivage stratiforme ------------- + + DO i = 1,klon + ! + zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0) & + * (paprs(i,k)-paprs(i,k+1))/RG + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN + !AA lessivage nucleation LMD5 dans la couche elle-meme + if (t(i,k) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(3) + else + zalpha_tr = a_tr_sca(4) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi + ! + ! nucleation avec un facteur -1 au lieu de -0.5 + zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i)) + pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + ENDIF + ! + ENDDO ! boucle sur i + ! + !AA Lessivage par impaction dans les couches en-dessous + DO kk = k-1, 1, -1 + DO i = 1, klon + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN + if (t(i,kk) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(1) + else + zalpha_tr = a_tr_sca(2) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi) + frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi + ENDIF + ENDDO + ENDDO + ! + !AA---------------------------------------------------------- + ! FIN DE BOUCLE SUR K + end DO + ! + !AA----------------------------------------------------------- + ! + ! Pluie ou neige au sol selon la temperature de la 1ere couche + ! + DO i = 1, klon + IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN + snow(i) = zrfl(i) + zlh_solid(i) = RLSTT-RLVTT + ELSE + rain(i) = zrfl(i) + zlh_solid(i) = 0. + ENDIF + ENDDO + ! + ! For energy conservation : when snow is present, the solification + ! latent heat is considered. + DO k = 1, klev + DO i = 1, klon + zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k))) + zmair=(paprs(i,k)-paprs(i,k+1))/RG + zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime + d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair) + END DO + END DO + ! + + if (ncoreczq>0) then + print*,'WARNING : ZQ dans fisrtilp ',ncoreczq,' val < 1.e-15.' + endif + +END SUBROUTINE fisrtilp Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp.h (revision 1634) @@ -0,0 +1,28 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez n'utiliser que des ! pour les commentaires +! et bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! + REAL cld_lc_lsc,cld_lc_con + REAL cld_tau_lsc,cld_tau_con + REAL ffallv_lsc,ffallv_con + REAL coef_eva + LOGICAL reevap_ice + INTEGER iflag_pdf + + common/comfisrtilp/ & + & cld_lc_lsc & + & ,cld_lc_con & + & ,cld_tau_lsc & + & ,cld_tau_con & + & ,ffallv_lsc & + & ,ffallv_con & + & ,coef_eva & + & ,reevap_ice & + & ,iflag_pdf + +!$OMP THREADPRIVATE(/comfisrtilp/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp_tr.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp_tr.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fisrtilp_tr.F (revision 1634) @@ -0,0 +1,435 @@ +! +! $Id$ +! +c + SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,ratqs, + s d_t, d_q, d_ql, rneb, radliq, rain, snow, + s pfrac_impa, pfrac_nucl, pfrac_1nucl, + s frac_impa, frac_nucl, + s prfl, psfl, + s RHcl) ! relative humidity in clear sky (needed for aer optical properties; aeropt.F) + +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c Date: le 20 mars 1995 +c Objet: condensation et precipitation stratiforme. +c schema de nuage +c====================================================================== +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "tracstoke.h" +c +c Arguments: +c + REAL dtime ! intervalle du temps (s) + REAL paprs(klon,klev+1) ! pression a inter-couche + REAL pplay(klon,klev) ! pression au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (kg/kg) + REAL d_t(klon,klev) ! incrementation de la temperature (K) + REAL d_q(klon,klev) ! incrementation de la vapeur d'eau + REAL d_ql(klon,klev) ! incrementation de l'eau liquide + REAL rneb(klon,klev) ! fraction nuageuse + REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements + REAL rain(klon) ! pluies (mm/s) + REAL snow(klon) ! neige (mm/s) + REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) + REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) + +Cjq For aerosol opt properties needed (see aeropt.F) + REAL RHcl(klon,klev) + +cAA +c Coeffients de fraction lessivee : pour OFF-LINE +c + REAL pfrac_nucl(klon,klev) + REAL pfrac_1nucl(klon,klev) + REAL pfrac_impa(klon,klev) +c +c Fraction d'aerosols lessivee par impaction et par nucleation +c POur ON-LINE +c + REAL frac_impa(klon,klev) + REAL frac_nucl(klon,klev) +cAA +c +c Options du programme: +c + REAL seuil_neb ! un nuage existe vraiment au-dela + PARAMETER (seuil_neb=0.001) + REAL ct ! inverse du temps pour qu'un nuage precipite + PARAMETER (ct=1./1800.) + REAL cl ! seuil de precipitation + PARAMETER (cl=2.6e-4) +ccc PARAMETER (cl=2.3e-4) +ccc PARAMETER (cl=2.0e-4) + INTEGER ninter ! sous-intervals pour la precipitation + PARAMETER (ninter=5) + LOGICAL evap_prec ! evaporation de la pluie + PARAMETER (evap_prec=.TRUE.) + REAL coef_eva + PARAMETER (coef_eva=2.0E-05) + LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur + REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur + PARAMETER (calcrat=.TRUE.) + REAL zx_min, rat_max + PARAMETER (zx_min=1.0, rat_max=0.01) + REAL zx_max, rat_min + PARAMETER (zx_max=0.1, rat_min=0.3) + REAL zx +c + LOGICAL cpartiel ! condensation partielle + PARAMETER (cpartiel=.TRUE.) + REAL t_coup + PARAMETER (t_coup=234.0) +c +c Variables locales: +c + INTEGER i, k, n, kk + REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5 + REAL zrfl(klon), zrfln(klon), zqev, zqevt + REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq + REAL ztglace, zt(klon) + INTEGER nexpo ! exponentiel pour glace/eau + REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon) + REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon) +c + LOGICAL appel1er + SAVE appel1er +c$OMP THREADPRIVATE(appel1er) +c +c--------------------------------------------------------------- +c +cAA Variables traceurs: +cAA Provisoire !!! Parametres alpha du lessivage +cAA A priori on a 4 scavenging # possibles +c + REAL a_tr_sca(4) + save a_tr_sca +c$OMP THREADPRIVATE(a_tr_sca) +c +c Variables intermediaires +c + REAL zalpha_tr + REAL zfrac_lessi + REAL zprec_cond(klon) +cAA +c--------------------------------------------------------------- +c +c Fonctions en ligne: +c + REAL fallv ! vitesse de chute pour crystaux de glace + REAL zzz +#include "YOETHF.h" +#include "FCTTRE.h" + fallv (zzz) = 3.29/2.0 * ((zzz)**0.16) +ccc fallv (zzz) = 3.29/3.0 * ((zzz)**0.16) +ccc fallv (zzz) = 3.29 * ((zzz)**0.16) +c + DATA appel1er /.TRUE./ +c + IF (appel1er) THEN +c + PRINT*, 'fisrtilp, calcrat:', calcrat + PRINT*, 'fisrtilp, ninter:', ninter + PRINT*, 'fisrtilp, evap_prec:', evap_prec + PRINT*, 'fisrtilp, cpartiel:', cpartiel + IF (ABS(dtime/REAL(ninter)-360.0).GT.0.001) THEN + PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime + PRINT*, 'Je prefere un sous-intervalle de 6 minutes' + CALL abort + ENDIF + appel1er = .FALSE. +c +cAA initialiation provisoire + a_tr_sca(1) = -0.5 + a_tr_sca(2) = -0.5 + a_tr_sca(3) = -0.5 + a_tr_sca(4) = -0.5 +c +cAA Initialisation a 1 des coefs des fractions lessivees +c + DO k = 1, klev + DO i = 1, klon + pfrac_nucl(i,k)=1. + pfrac_1nucl(i,k)=1. + pfrac_impa(i,k)=1. + ENDDO + ENDDO + + ENDIF ! test sur appel1er +c +cMAf Initialisation a 0 de zoliq + DO i = 1, klon + zoliq(i)=0. + ENDDO +c Determiner les nuages froids par leur temperature +c + ztglace = RTT - 15.0 + nexpo = 6 +ccc nexpo = 1 +c +c Initialiser les sorties: +c + DO k = 1, klev+1 + DO i = 1, klon + prfl(i,k) = 0.0 + psfl(i,k) = 0.0 + ENDDO + ENDDO + + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_q(i,k) = 0.0 + d_ql(i,k) = 0.0 + rneb(i,k) = 0.0 + radliq(i,k) = 0.0 + frac_nucl(i,k) = 1. + frac_impa(i,k) = 1. + ENDDO + ENDDO + DO i = 1, klon + rain(i) = 0.0 + snow(i) = 0.0 + ENDDO +c +c Initialiser le flux de precipitation a zero +c + DO i = 1, klon + zrfl(i) = 0.0 + zneb(i) = seuil_neb + ENDDO +c +c +cAA Pour plus de securite + + zalpha_tr = 0. + zfrac_lessi = 0. + +cAA---------------------------------------------------------- +c +c Boucle verticale (du haut vers le bas) +c + DO 9999 k = klev, 1, -1 +c +cAA---------------------------------------------------------- +c + DO i = 1, klon + zt(i)=t(i,k) + zq(i)=q(i,k) + ENDDO +c +c Calculer l'evaporation de la precipitation +c + IF (evap_prec) THEN + DO i = 1, klon + IF (zrfl(i) .GT.0.) THEN + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-zt(i))) + zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i)=MIN(0.5,zqs(i)) + zcor=1./(1.-RETV*zqs(i)) + zqs(i)=zqs(i)*zcor + ELSE + IF (zt(i) .LT. t_coup) THEN + zqs(i) = qsats(zt(i)) / pplay(i,k) + ELSE + zqs(i) = qsatl(zt(i)) / pplay(i,k) + ENDIF + ENDIF + zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) ) + zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) + . * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG + zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) + . * RG*dtime/(paprs(i,k)-paprs(i,k+1)) + zqev = MIN (zqev, zqevt) + zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) + . /RG/dtime + zq(i) = zq(i) - (zrfln(i)-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + zt(i) = zt(i) + (zrfln(i)-zrfl(i)) + . * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime + . * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) + zrfl(i) = zrfln(i) + ENDIF + ENDDO + ENDIF +c +c Calculer Qs et L/Cp*dQs/dT: +c + IF (thermcep) THEN + DO i = 1, klon + zdelta = MAX(0.,SIGN(1.,RTT-zt(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i)) + zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k) + zqs(i) = MIN(0.5,zqs(i)) + zcor = 1./(1.-RETV*zqs(i)) + zqs(i) = zqs(i)*zcor + zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor) + ENDDO + ELSE + DO i = 1, klon + IF (zt(i).LT.t_coup) THEN + zqs(i) = qsats(zt(i))/pplay(i,k) + zdqs(i) = dqsats(zt(i),zqs(i)) + ELSE + zqs(i) = qsatl(zt(i))/pplay(i,k) + zdqs(i) = dqsatl(zt(i),zqs(i)) + ENDIF + ENDDO + ENDIF +c +c Determiner la condensation partielle et calculer la quantite +c de l'eau condensee: +c + IF (cpartiel) THEN + DO i = 1, klon +c + zdelq = ratqs(i,k) * zq(i) + rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq) + zqn(i) = (zq(i)+zdelq+zqs(i))/2.0 + IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0 + IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i) + rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k))) + zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i)) + +c--Olivier + RHcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i) + IF (rneb(i,k) .LE. 0.0) RHcl(i,k)=zq(i)/zqs(i) + IF (rneb(i,k) .GE. 1.0) RHcl(i,k)=1.0 +c--fin + + ENDDO + ELSE + DO i = 1, klon + IF (zq(i).GT.zqs(i)) THEN + rneb(i,k) = 1.0 + ELSE + rneb(i,k) = 0.0 + ENDIF + zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i)) + ENDDO + ENDIF +c + DO i = 1, klon + zq(i) = zq(i) - zcond(i) + zt(i) = zt(i) + zcond(i) * RLVTT/RCPD + ENDDO +c +c Partager l'eau condensee en precipitation et eau liquide nuageuse +c + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zoliq(i) = zcond(i) + zrho(i) = pplay(i,k) / zt(i) / RD + zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG) + zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace) + zfice(i) = MIN(MAX(zfice(i),0.0),1.0) + zfice(i) = zfice(i)**nexpo + zneb(i) = MAX(rneb(i,k), seuil_neb) + radliq(i,k) = zoliq(i)/REAL(ninter+1) + ENDIF + ENDDO +c + DO n = 1, ninter + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + zchau(i) = ct*dtime/REAL(ninter) * zoliq(i) + . * (1.0-EXP(-(zoliq(i)/zneb(i)/cl)**2)) *(1.-zfice(i)) + zrhol(i) = zrho(i) * zoliq(i) / zneb(i) + zfroi(i) = dtime/REAL(ninter)/zdz(i)*zoliq(i) + . *fallv(zrhol(i)) * zfice(i) + ztot(i) = zchau(i) + zfroi(i) + IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0 + ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i)) + zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0) + radliq(i,k) = radliq(i,k) + zoliq(i)/REAL(ninter+1) + ENDIF + ENDDO + ENDDO +c + DO i = 1, klon + IF (rneb(i,k).GT.0.0) THEN + d_ql(i,k) = zoliq(i) + zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0) + . * (paprs(i,k)-paprs(i,k+1))/(RG*dtime) + ENDIF + IF (zt(i).LT.RTT) THEN + psfl(i,k)=zrfl(i) + ELSE + prfl(i,k)=zrfl(i) + ENDIF + ENDDO +c +c Calculer les tendances de q et de t: +c + DO i = 1, klon + d_q(i,k) = zq(i) - q(i,k) + d_t(i,k) = zt(i) - t(i,k) + ENDDO +c +cAA--------------- Calcul du lessivage stratiforme ------------- + + DO i = 1,klon +c + zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0) + . * (paprs(i,k)-paprs(i,k+1))/RG + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN +cAA lessivage nucleation LMD5 dans la couche elle-meme + if (t(i,k) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(3) + else + zalpha_tr = a_tr_sca(4) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi +c +c nucleation avec un facteur -1 au lieu de -0.5 + zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i)) + pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi) + ENDIF +c + ENDDO ! boucle sur i +c +cAA Lessivage par impaction dans les couches en-dessous + DO kk = k-1, 1, -1 + DO i = 1, klon + IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN + if (t(i,kk) .GE. ztglace) THEN + zalpha_tr = a_tr_sca(1) + else + zalpha_tr = a_tr_sca(2) + endif + zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i)) + pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi) + frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi + ENDIF + ENDDO + ENDDO +c +cAA---------------------------------------------------------- +c FIN DE BOUCLE SUR K + 9999 CONTINUE +c +cAA----------------------------------------------------------- +c +c Pluie ou neige au sol selon la temperature de la 1ere couche +c + DO i = 1, klon + IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN + snow(i) = zrfl(i) + ELSE + rain(i) = zrfl(i) + ENDIF + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/flxtr.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/flxtr.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/flxtr.F (revision 1634) @@ -0,0 +1,207 @@ +! +! $Header$ +! + SUBROUTINE flxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d, + . pt,pplay,paprs,kcbot,kctop,kdtop,x,dx) + USE dimphy + IMPLICIT NONE +c===================================================================== +c Objet : Melange convectif de traceurs a partir des flux de masse +c Date : 13/12/1996 -- 13/01/97 +c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD), +c Brinkop et Sausen (1996) et Boucher et al. (1996). +c ATTENTION : meme si cette routine se veut la plus generale possible, +c elle a herite de certaines notations et conventions du +c schema de Tiedtke (1993). +c --En particulier, les couches sont numerotees de haut en bas !!! +c Ceci est valable pour les flux, kcbot, kctop et kdtop +c mais pas pour les entrees x, pplay, paprs !!!! +c --Un schema amont est choisi pour calculer les flux pour s'assurer +c de la positivite des valeurs de traceurs, cela implique des eqs +c differentes pour les flux de traceurs montants et descendants. +c --pmfu est positif, pmfd est negatif +c --Tous les flux d'entrainements et de detrainements sont positifs +c contrairement au schema de Tiedtke d'ou les changements de signe!!!! +c===================================================================== +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOECUMF.h" +c + REAL pdtime +c--les flux sont definis au 1/2 niveaux +c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls + REAL pmfu(klon,klev) ! flux de masse dans le panache montant + REAL pmfd(klon,klev) ! flux de masse dans le panache descendant + REAL pen_u(klon,klev) ! flux entraine dans le panache montant + REAL pde_u(klon,klev) ! flux detraine dans le panache montant + REAL pen_d(klon,klev) ! flux entraine dans le panache descendant + REAL pde_d(klon,klev) ! flux detraine dans le panache descendant +c--idem mais en variables locales + REAL zpen_u(klon,klev) + REAL zpde_u(klon,klev) + REAL zpen_d(klon,klev) + REAL zpde_d(klon,klev) +c + REAL pplay(klon,klev) ! pression aux couches (bas en haut) + REAL pap(klon,klev) ! pression aux couches (haut en bas) + REAL pt(klon,klev) ! temperature aux couches (bas en haut) + REAL zt(klon,klev) ! temperature aux couches (haut en bas) + REAL paprs(klon,klev+1) ! pression aux 1/2 couches (bas en haut) + REAL paph(klon,klev+1) ! pression aux 1/2 couches (haut en bas) + INTEGER kcbot(klon) ! niveau de base de la convection + INTEGER kctop(klon) ! niveau du sommet de la convection +1 + INTEGER kdtop(klon) ! niveau de sommet du panache descendant + REAL x(klon,klev) ! q de traceur (bas en haut) + REAL zx(klon,klev) ! q de traceur (haut en bas) + REAL dx(klon,klev) ! tendance de traceur (bas en haut) +c +c--variables locales +c--les flux de x sont definis aux 1/2 niveaux +c--xu et xd sont definis aux niveaux complets + REAL xu(klon,klev) ! q de traceurs dans le panache montant + REAL xd(klon,klev) ! q de traceurs dans le panache descendant + REAL xe(klon,klev) ! q de traceurs dans l'environnement + REAL zmfux(klon,klev+1) ! flux de x dans le panache montant + REAL zmfdx(klon,klev+1) ! flux de x dans le panache descendant + REAL zmfex(klon,klev+1) ! flux de x dans l'environnement + INTEGER i, k + REAL zmfmin + PARAMETER (zmfmin=1.E-10) +c +c On remet les taux d'entrainement et de detrainement dans le panache +c descendant a des valeurs positives. +c On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la +c conservation de la masse soit realisee a chaque niveau dans les 2 +c panaches. + DO k=1, klev + DO i=1, klon + zpen_u(i,k)= pen_u(i,k) + zpde_u(i,k)= pde_u(i,k) + ENDDO + ENDDO +c + DO k=1, klev-1 + DO i=1, klon + zpen_d(i,k)=-pen_d(i,k+1) + zpde_d(i,k)=-pde_d(i,k+1) + ENDDO + ENDDO +c + DO i=1, klon + zpen_d(i,klev) = 0.0 + zpde_d(i,klev) = -pmfd(i,klev) +c Correction 03 11 97 +c zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i)) + IF (kdtop(i).EQ.klev+1) THEN + zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1) + ELSE + zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i)) + ENDIF + + zpde_u(i,kctop(i)-2) = pmfu(i,kctop(i)-1) + zpen_u(i,klev) = pmfu(i,klev) + ENDDO +c + DO i=1, klon + DO k=kcbot(i), klev-1 + zpen_u(i,k) = pmfu(i,k) - pmfu(i,k+1) + ENDDO + ENDDO +c +c conversion des sens de notations bas-haut et haut-bas +c + DO k=1, klev+1 + DO i=1, klon + paph(i,klev+2-k)=paprs(i,k) + ENDDO + ENDDO +c + DO i=1, klon + DO k=1, klev + pap(i,klev+1-k)=pplay(i,k) + zt(i,klev+1-k) =pt(i,k) + zx(i,klev+1-k) =x(i,k) + ENDDO + ENDDO +c +c--initialisations des flux de traceurs aux extremites de la colonne +c + DO i=1, klon + zmfux(i,klev+1) = 0.0 + zmfdx(i,1) = 0.0 + zmfex(i,1) = 0.0 + ENDDO +c +c--calcul des flux dans le panache montant +c + DO k=klev, 1, -1 + DO i=1, klon + IF (k.GE.kcbot(i)) THEN + xu(i,k)=zx(i,k) + zmfux(i,k)=pmfu(i,k)*xu(i,k) + ELSE + zmfux(i,k)= (zmfux(i,k+1) + zpen_u(i,k)*zx(i,k) ) / + . (1.+zpde_u(i,k)/MAX(zmfmin,pmfu(i,k))) + xu(i,k)=zmfux(i,k)/MAX(zmfmin,pmfu(i,k)) + ENDIF + ENDDO + ENDDO +c +c--calcul des flux dans le panache descendant +c + DO k=1, klev-1 + DO i=1, klon + IF (k.LE.kdtop(i)-1) THEN + xd(i,k)=( zx(i,k)+xu(i,k) ) / 2. + zmfdx(i,k+1)=pmfd(i,k+1)*xd(i,k) + ELSE + zmfdx(i,k+1)= (zmfdx(i,k) - zpen_d(i,k)*zx(i,k) ) / + . (1.-zpde_d(i,k)/MIN(-zmfmin,pmfd(i,k+1))) + xd(i,k)=zmfdx(i,k+1)/MIN(-zmfmin,pmfd(i,k+1)) + ENDIF + ENDDO + ENDDO + DO i=1, klon + zmfdx(i,klev+1) = 0.0 + xd(i,klev) = (zpen_d(i,klev)*zx(i,klev) - zmfdx(i,klev)) / + . MAX(zmfmin,zpde_d(i,klev)) + ENDDO +c +c--introduction du flux de retour dans l'environnement +c + DO k=1, klev-1 + DO i=1, klon + IF (k.LE.kctop(i)-3) THEN + xe(i,k)= zx(i,k) + zmfex(i,k+1)=-(pmfu(i,k+1)+pmfd(i,k+1))*xe(i,k) + ELSE + zmfex(i,k+1)= (zmfex(i,k) - + . (zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i,k))) / + . (1.-(zpen_d(i,k)+zpen_u(i,k))/ + . MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) ) + xe(i,k)=zmfex(i,k+1)/MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) + ENDIF + ENDDO + ENDDO + DO i=1, klon + zmfex(i,klev+1) = 0.0 + xe(i,klev) = (zpde_u(i,klev)*xu(i,klev) + + . zpde_d(i,klev)*xd(i,klev) -zmfex(i,klev)) / + . MAX(zmfmin,zpen_u(i,klev)+zpen_d(i,klev)) + ENDDO +c +c--calcul final des tendances +c + DO k=1 , klev + DO i=1, klon + dx(i,klev+1-k) = RG/(paph(i,k+1)-paph(i,k))*pdtime* + . ( zmfux(i,k+1) - zmfux(i,k) + + . zmfdx(i,k+1) - zmfdx(i,k) + + . zmfex(i,k+1) - zmfex(i,k) ) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fonte_neige_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fonte_neige_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/fonte_neige_mod.F90 (revision 1634) @@ -0,0 +1,350 @@ +! +! $Header$ +! +MODULE fonte_neige_mod +! +! This module will treat the process of snow, melting, accumulating, calving, in +! case of simplified soil model. +! +!**************************************************************************************** + USE dimphy, ONLY : klon + + IMPLICIT NONE + SAVE + +! run_off_ter and run_off_lic are the runoff at the compressed grid knon for +! land and land-ice respectively +! Note: run_off_lic is used in mod_landice and therfore not private + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE :: run_off_ter + !$OMP THREADPRIVATE(run_off_ter) + REAL, ALLOCATABLE, DIMENSION(:) :: run_off_lic + !$OMP THREADPRIVATE(run_off_lic) + +! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE :: run_off_lic_0 + !$OMP THREADPRIVATE(run_off_lic_0) + + REAL, PRIVATE :: tau_calv + !$OMP THREADPRIVATE(tau_calv) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: ffonte_global + !$OMP THREADPRIVATE(ffonte_global) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: fqfonte_global + !$OMP THREADPRIVATE(fqfonte_global) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE :: fqcalving_global + !$OMP THREADPRIVATE(fqcalving_global) + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_init(restart_runoff) + +! This subroutine allocates and initialize variables in the module. +! The variable run_off_lic_0 is initialized to the field read from +! restart file. The other variables are initialized to zero. +! + INCLUDE "indicesol.h" +!**************************************************************************************** +! Input argument + REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff + +! Local variables + INTEGER :: error + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'fonte_neige_init' + + +!**************************************************************************************** +! Allocate run-off at landice and initilize with field read from restart +! +!**************************************************************************************** + + ALLOCATE(run_off_lic_0(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_lic' + CALL abort_gcm(modname,abort_message,1) + ENDIF + run_off_lic_0(:) = restart_runoff(:) + +!**************************************************************************************** +! Allocate other variables and initilize to zero +! +!**************************************************************************************** + ALLOCATE(run_off_ter(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_ter' + CALL abort_gcm(modname,abort_message,1) + ENDIF + run_off_ter(:) = 0. + + ALLOCATE(run_off_lic(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation run_off_lic' + CALL abort_gcm(modname,abort_message,1) + ENDIF + run_off_lic(:) = 0. + + ALLOCATE(ffonte_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation ffonte_global' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ffonte_global(:,:) = 0.0 + + ALLOCATE(fqfonte_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fqfonte_global' + CALL abort_gcm(modname,abort_message,1) + ENDIF + fqfonte_global(:,:) = 0.0 + + ALLOCATE(fqcalving_global(klon,nbsrf)) + IF (error /= 0) THEN + abort_message='Pb allocation fqcalving_global' + CALL abort_gcm(modname,abort_message,1) + ENDIF + fqcalving_global(:,:) = 0.0 + +!**************************************************************************************** +! Read tau_calv +! +!**************************************************************************************** + CALL conf_interface(tau_calv) + + + END SUBROUTINE fonte_neige_init +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) + +! Routine de traitement de la fonte de la neige dans le cas du traitement +! de sol simplifie! +! LF 03/2001 +! input: +! knon nombre de points a traiter +! nisurf surface a traiter +! knindex index des mailles valables pour surface a traiter +! dtime +! tsurf temperature de surface +! precip_rain precipitations liquides +! precip_snow precipitations solides +! +! input/output: +! snow champs hauteur de neige +! qsol hauteur d'eau contenu dans le sol +! tsurf_new temperature au sol +! evap +! + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" + INCLUDE "YOETHF.h" + INCLUDE "YOMCST.h" + INCLUDE "FCTTRE.h" + INCLUDE "clesphys.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, INTENT(IN) :: nisurf + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL , INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain + REAL, DIMENSION(klon), INTENT(IN) :: precip_snow + +! Input/Output variables +!**************************************************************************************** + + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(INOUT) :: evap + +! Local variables +!**************************************************************************************** + + INTEGER :: i, j + REAL :: fq_fonte + REAL :: coeff_rel + REAL, PARAMETER :: snow_max=3000. + REAL, PARAMETER :: max_eau_sol = 150.0 +!! PB temporaire en attendant mieux pour le modele de neige +! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15) + REAL, PARAMETER :: chasno = 3.334E+05/(2.3867E+06*0.15) +!IM cf JLD/ GKtest + REAL, PARAMETER :: chaice = 3.334E+05/(2.3867E+06*0.15) +! fin GKtest + REAL, DIMENSION(klon) :: ffonte + REAL, DIMENSION(klon) :: fqcalving, fqfonte + REAL, DIMENSION(klon) :: d_ts + REAL, DIMENSION(klon) :: bil_eau_s, snow_evap + + LOGICAL :: neige_fond + +!**************************************************************************************** +! Start calculation +! - Initialization +! +!**************************************************************************************** + coeff_rel = dtime/(tau_calv * rday) + + bil_eau_s(:) = 0. + +!**************************************************************************************** +! - Increment snow due to precipitation and evaporation +! - Calculate the water balance due to precipitation and evaporation (bil_eau_s) +! +!**************************************************************************************** + WHERE (precip_snow > 0.) + snow = snow + (precip_snow * dtime) + END WHERE + + snow_evap = 0. + WHERE (evap > 0. ) + snow_evap = MIN (snow / dtime, evap) + snow = snow - snow_evap * dtime + snow = MAX(0.0, snow) + END WHERE + + bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime + + +!**************************************************************************************** +! - Calculate melting snow +! - Calculate calving and decrement snow, if there are to much snow +! - Update temperature at surface +! +!**************************************************************************************** + + ffonte(:) = 0.0 + fqcalving(:) = 0.0 + fqfonte(:) = 0.0 + DO i = 1, knon + ! Y'a-t-il fonte de neige? + neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) & + .AND. tsurf_new(i) >= RTT) + IF (neige_fond) THEN + fq_fonte = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i)) + ffonte(i) = fq_fonte * RLMLT/dtime + fqfonte(i) = fq_fonte/dtime + snow(i) = MAX(0., snow(i) - fq_fonte) + bil_eau_s(i) = bil_eau_s(i) + fq_fonte + tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno + +!IM cf JLD OK +!IM cf JLD/ GKtest fonte aussi pour la glace + IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN + fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0) + ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime + IF ( ok_lic_melt ) THEN + fqfonte(i) = fqfonte(i) + fq_fonte/dtime + bil_eau_s(i) = bil_eau_s(i) + fq_fonte + ENDIF + tsurf_new(i) = RTT + ENDIF + d_ts(i) = tsurf_new(i) - tsurf(i) + ENDIF + + ! s'il y a une hauteur trop importante de neige, elle s'coule + fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime + snow(i)=MIN(snow(i),snow_max) + END DO + + + IF (nisurf == is_ter) THEN + DO i = 1, knon + qsol(i) = qsol(i) + bil_eau_s(i) + run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0) + qsol(i) = MIN(qsol(i), max_eau_sol) + END DO + ELSE IF (nisurf == is_lic) THEN + DO i = 1, knon + j = knindex(i) + run_off_lic(i) = (coeff_rel * fqcalving(i)) + & + (1. - coeff_rel) * run_off_lic_0(j) + run_off_lic_0(j) = run_off_lic(i) + run_off_lic(i) = run_off_lic(i) + fqfonte(i) + precip_rain(i) + END DO + ENDIF + +!**************************************************************************************** +! Save ffonte, fqfonte and fqcalving in global arrays for each +! sub-surface separately +! +!**************************************************************************************** + DO i = 1, knon + ffonte_global(knindex(i),nisurf) = ffonte(i) + fqfonte_global(knindex(i),nisurf) = fqfonte(i) + fqcalving_global(knindex(i),nisurf) = fqcalving(i) + ENDDO + + END SUBROUTINE fonte_neige +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_final(restart_runoff) +! +! This subroutine returns run_off_lic_0 for later writing to restart file. +! +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff + +!**************************************************************************************** +! Set the output variables + restart_runoff(:) = run_off_lic_0(:) + +! Deallocation of all varaibles in the module +! DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, & +! fqfonte_global, fqcalving_global) + + IF (ALLOCATED(run_off_lic_0)) DEALLOCATE(run_off_lic_0) + IF (ALLOCATED(run_off_ter)) DEALLOCATE(run_off_ter) + IF (ALLOCATED(run_off_lic)) DEALLOCATE(run_off_lic) + IF (ALLOCATED(ffonte_global)) DEALLOCATE(ffonte_global) + IF (ALLOCATED(fqfonte_global)) DEALLOCATE(fqfonte_global) + IF (ALLOCATED(fqcalving_global)) DEALLOCATE(fqcalving_global) + + END SUBROUTINE fonte_neige_final +! +!**************************************************************************************** +! + SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, & + fqfonte_out, ffonte_out) + +! Cumulate ffonte, fqfonte and fqcalving respectively for +! all type of surfaces according to their fraction. +! +! This routine is called from physiq.F before histwrite. + + INCLUDE "indicesol.h" +!**************************************************************************************** + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + + REAL, DIMENSION(klon), INTENT(OUT) :: fqcalving_out + REAL, DIMENSION(klon), INTENT(OUT) :: fqfonte_out + REAL, DIMENSION(klon), INTENT(OUT) :: ffonte_out + + INTEGER :: nisurf +!**************************************************************************************** + + ffonte_out(:) = 0.0 + fqfonte_out(:) = 0.0 + fqcalving_out(:) = 0.0 + + DO nisurf = 1, nbsrf + ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf) + fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf) + fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf) + ENDDO + + END SUBROUTINE fonte_neige_get_vars +! +!**************************************************************************************** +! +END MODULE fonte_neige_mod + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/geo2atm.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/geo2atm.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/geo2atm.F90 (revision 1634) @@ -0,0 +1,53 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/geo2atm.F90,v 1.1 2008-12-05 17:56:40 lsce Exp $ +! +SUBROUTINE geo2atm(im, jm, px, py, pz, plon, plat, pu, pv, pr) + USE dimphy + USE mod_phys_lmdz_para + + IMPLICIT NONE + INCLUDE 'dimensions.h' + INCLUDE 'YOMCST.h' + +! Change wind coordinates from cartesian geocentric to local spherical +! NB! Fonctionne probablement uniquement en MPI seul (sans OpenMP) +! + INTEGER, INTENT (IN) :: im, jm + REAL, DIMENSION (im,jm), INTENT(IN) :: px, py, pz + REAL, DIMENSION (im,jm), INTENT(IN) :: plon, plat + REAL, DIMENSION (im,jm), INTENT(OUT) :: pu, pv, pr + + REAL :: rad + + + rad = rpi / 180.0E0 + + pu(:,:) = & + - px(:,:) * SIN(rad * plon(:,:)) & + + py(:,:) * COS(rad * plon(:,:)) + + pv(:,:) = & + - px(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:)) & + - py(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:)) & + + pz(:,:) * COS(rad * plat(:,:)) + + pr(:,:) = & + + px(:,:) * COS(rad * plat(:,:)) * COS(rad * plon(:,:)) & + + py(:,:) * COS(rad * plat(:,:)) * SIN(rad * plon(:,:)) & + + pz(:,:) * SIN(rad * plat(:,:)) + + ! Value at North Pole + IF (is_north_pole) THEN + pu(:, 1) = -px (1,1) + pv(:, 1) = -py (1,1) + pr(:, 1) = 0.0 + ENDIF + + ! Value at South Pole + IF (is_south_pole) THEN + pu(:,jm) = -px (1,jm) + pv(:,jm) = -py (1,jm) + pr(:,jm) = 0.0 + ENDIF + +END SUBROUTINE geo2atm Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/global_mean.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/global_mean.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/global_mean.F90 (revision 1634) @@ -0,0 +1,63 @@ + subroutine global_mean(field,airephy,laire,mfield) +! +! I.Musat: 05.2011 +! calcul moyenne globale d'un champ pondere par l'aire de la maille +! (laire=.TRUE.) ou somme globale du champ (laire=.FALSE.) +! + USE dimphy + USE mod_phys_lmdz_para, only: is_sequential + USE mod_phys_lmdz_transfert_para, only: reduce_sum + use mod_phys_lmdz_mpi_data, only: is_mpi_root + USE ioipsl + implicit none + + real,dimension(klon),intent(in) :: field + real,dimension(klon),intent(in) :: airephy + LOGICAL, intent(in) :: laire + REAL, intent(out) :: mfield + REAL :: airetot ! Total area the earth + REAL :: sumtmp + INTEGER :: i + + if (is_sequential) then + + airetot = 0. + sumtmp = 0. + DO i=1, klon + airetot = airetot + airephy(i) + sumtmp = sumtmp + field(i) + END DO + if (laire) THEN + if(airetot.NE.0.) THEN + mfield=sumtmp/airetot + endif + else + mfield=sumtmp + endif + + else + + CALL reduce_sum(SUM(airephy),airetot) + CALL reduce_sum(SUM(field),sumtmp) + +!$OMP MASTER + if (is_mpi_root) THEN + if (laire) THEN +! print*,'gmean airetot=',airetot + if(airetot.NE.0.) THEN + mfield=sumtmp/airetot +! else +! mfield=sumtmp + endif + else + mfield=sumtmp + endif + +! print*,'gmean sumtmp mfield=',sumtmp,mfield + + endif !(is_mpi_root) THEN +!$OMP END MASTER + + endif + + end subroutine global_mean Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/haut2bas.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/haut2bas.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/haut2bas.F (revision 1634) @@ -0,0 +1,19 @@ +! +! $Header$ +! + SUBROUTINE haut2bas(klon, klev, varB2H, varH2B) + IMPLICIT NONE +c + INTEGER klon, klev + REAL varB2H(klon, klev), varH2B(klon, klev) + INTEGER i, k, kinv +c + DO k=1,klev + kinv=klev-k+1 + DO i=1,klon + varH2B(i,k)=varB2H(i,kinv) + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hbtm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hbtm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hbtm.F (revision 1634) @@ -0,0 +1,777 @@ +! +! $Header$ +! + + SUBROUTINE HBTM(knon, paprs, pplay, + . t2m,t10m,q2m,q10m,ustar, + . flux_t,flux_q,u,v,t,q, + . pblh,cape,EauLiq,ctei,pblT, + . therm,trmb1,trmb2,trmb3,plcl) + USE dimphy + IMPLICIT none + +c*************************************************************** +c* * +c* HBTM2 D'apres Holstag&Boville et Troen&Mahrt * +c* JAS 47 BLM * +c* Algorithme These Anne Mathieu * +c* Critere d'Entrainement Peter Duynkerke (JAS 50) * +c* written by : Anne MATHIEU & Alain LAHELLEC, 22/11/99 * +c* features : implem. exces Mathieu * +c*************************************************************** +c* mods : decembre 99 passage th a niveau plus bas. voir fixer * +c* la prise du th a z/Lambda = -.2 (max Ray) * +c* Autre algo : entrainement ~ Theta+v =cste mais comment=>The?* +c* on peut fixer q a .7qsat(cf non adiab)=>T2 et The2 * +c* voir aussi //KE pblh = niveau The_e ou l = env. * +c*************************************************************** +c* fin therm a la HBTM passage a forme Mathieu 12/09/2001 * +c*************************************************************** +c* +c +c +cAM Fev 2003 +c Adaptation a LMDZ version couplee +c +c Pour le moment on fait passer en argument les grdeurs de surface : +c flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms +c on garde la possibilite de changer si besoin est (jusqu'a present la +c forme de HB avec le 1er niveau modele etait conservee) +c +c +c +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + REAL RLvCp, REPS +c Arguments: +c + INTEGER knon ! nombre de points a calculer +cAM + REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m + REAL q2m(klon), q10m(klon) ! q a 2 et 10m + REAL ustar(klon) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL flux_t(klon,klev), flux_q(klon,klev) ! Flux + REAL u(klon,klev) ! vitesse U (m/s) + REAL v(klon,klev) ! vitesse V (m/s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! vapeur d'eau (kg/kg) +cAM REAL cd_h(klon) ! coefficient de friction au sol pour chaleur +cAM REAL cd_m(klon) ! coefficient de friction au sol pour vitesse +c + INTEGER isommet +cum PARAMETER (isommet=klev) ! limite max sommet pbl + REAL vk + PARAMETER (vk=0.35) ! Von Karman => passer a .41 ! cf U.Olgstrom + REAL ricr + PARAMETER (ricr=0.4) + REAL fak + PARAMETER (fak=8.5) ! b calcul du Prandtl et de dTetas + REAL fakn + PARAMETER (fakn=7.2) ! a + REAL onet + PARAMETER (onet=1.0/3.0) + REAL t_coup + PARAMETER(t_coup=273.15) + REAL zkmin + PARAMETER (zkmin=0.01) + REAL betam + PARAMETER (betam=15.0) ! pour Phim / h dans la S.L stable + REAL betah + PARAMETER (betah=15.0) + REAL betas + PARAMETER (betas=5.0) ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1 + REAL sffrac + PARAMETER (sffrac=0.1) ! S.L. = z/h < .1 + REAL binm + PARAMETER (binm=betam*sffrac) + REAL binh + PARAMETER (binh=betah*sffrac) + REAL ccon + PARAMETER (ccon=fak*sffrac*vk) +c + REAL q_star,t_star + REAL b1,b2,b212,b2sr ! Lambert correlations T' q' avec T* q* + PARAMETER (b1=70.,b2=20.) +c + REAL z(klon,klev) +cAM REAL pcfm(klon,klev), pcfh(klon,klev) +cAM + REAL zref + PARAMETER (zref=2.) ! Niveau de ref a 2m peut eventuellement +c etre choisi a 10m +cMA +c + INTEGER i, k, j + REAL zxt +cAM REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy +cAM REAL zx_alf1, zx_alf2 ! parametres pour extrapolation + REAL khfs(klon) ! surface kinematic heat flux [mK/s] + REAL kqfs(klon) ! sfc kinematic constituent flux [m/s] + REAL heatv(klon) ! surface virtual heat flux + REAL rhino(klon,klev) ! bulk Richardon no. mais en Theta_v + LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx) + LOGICAL stblev(klon) ! stable pbl with levels within pbl + LOGICAL unslev(klon) ! unstbl pbl with levels within pbl + LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr + LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr + LOGICAL check(klon) ! True=>chk if Richardson no.>critcal + LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega + REAL pblh(klon) + REAL pblT(klon) + REAL plcl(klon) +cAM REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m] +cAM REAL cgq(klon,2:klev) ! counter-gradient term for constituents +cAM REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux) + REAL obklen(klon) ! Monin-Obukhov lengh +cAM REAL ztvd, ztvu, + REAL zdu2 + REAL therm(klon) ! thermal virtual temperature excess + REAL trmb1(klon),trmb2(klon),trmb3(klon) +C Algorithme thermique + REAL s(klon,klev) ! [P/Po]^Kappa milieux couches + REAL Th_th(klon) ! potential temperature of thermal + REAL The_th(klon) ! equivalent potential temperature of thermal + REAL qT_th(klon) ! total water of thermal + REAL Tbef(klon) ! T thermique niveau precedent + REAL qsatbef(klon) + LOGICAL Zsat(klon) ! le thermique est sature + REAL Cape(klon) ! Cape du thermique + REAL Kape(klon) ! Cape locale + REAL EauLiq(klon) ! Eau liqu integr du thermique + REAL ctei(klon) ! Critere d'instab d'entrainmt des nuages de CL + REAL the1,the2,aa,bb,zthvd,zthvu,xintpos,qqsat +cIM 091204 BEG + REAL a1,a2,a3 +cIM 091204 END + REAL xhis,rnum,denom,th1,th2,thv1,thv2,ql2 + REAL dqsat_dt,qsat2,qT1,q2,t1,t2,xnull,delt_the + REAL delt_qt,delt_2,quadsat,spblh,reduc +c + REAL phiminv(klon) ! inverse phi function for momentum + REAL phihinv(klon) ! inverse phi function for heat + REAL wm(klon) ! turbulent velocity scale for momentum + REAL fak1(klon) ! k*ustar*pblh + REAL fak2(klon) ! k*wm*pblh + REAL fak3(klon) ! fakn*wstr/wm + REAL pblk(klon) ! level eddy diffusivity for momentum + REAL pr(klon) ! Prandtl number for eddy diffusivities + REAL zl(klon) ! zmzp / Obukhov length + REAL zh(klon) ! zmzp / pblh + REAL zzh(klon) ! (1-(zmzp/pblh))**2 + REAL wstr(klon) ! w*, convective velocity scale + REAL zm(klon) ! current level height + REAL zp(klon) ! current level height + one level up + REAL zcor, zdelta, zcvm5 +cAM REAL zxqs + REAL fac, pblmin, zmzp, term +c +#include "YOETHF.h" +#include "FCTTRE.h" + + + +! initialisations (Anne) + isommet=klev + th_th(:) = 0. + q_star = 0 + t_star = 0 + + + b212=sqrt(b1*b2) + b2sr=sqrt(b2) +c +C ============================================================ +C Fonctions thermo implicites +C ============================================================ +c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c Tetens : pression partielle de vap d'eau e_sat(T) +c ================================================= +C++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE +C++ avec : +C++ Tf = 273.16 K (Temp de fusion de la glace) +C++ r2 = 611.14 Pa +C++ r3 = 17.269 (liquide) 21.875 (solide) adim +C++ r4 = 35.86 7.66 Kelvin +C++ q_sat = eps*e_sat/(p-(1-eps)*e_sat) +C++ deriv� : +C++ ========= +C++ r3*(Tf-r4)*q_sat(T,p) +C++ d_qsat_dT = -------------------------------- +C++ (T-r4)^2*( 1-(1-eps)*e_sat(T)/p ) +c++ pour zcvm5=Lv, c'est FOEDE +c++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat +C ------------------------------------------------------------------ +c +c Initialisation + RLvCp = RLVTT/RCPD + REPS = RD/RV + +c +c DO i = 1, klon +c pcfh(i,1) = cd_h(i) +c pcfm(i,1) = cd_m(i) +c ENDDO +c DO k = 2, klev +c DO i = 1, klon +c pcfh(i,k) = zkmin +c pcfm(i,k) = zkmin +c cgs(i,k) = 0.0 +c cgh(i,k) = 0.0 +c cgq(i,k) = 0.0 +c ENDDO +c ENDDO +c +c Calculer les hauteurs de chaque couche +c (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g) +c pourquoi ne pas utiliser Phi/RG ? + DO i = 1, knon + z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) / RG + s(i,1) = (pplay(i,1)/paprs(i,1))**RKappa + ENDDO +c s(k) = [pplay(k)/ps]^kappa +c + + + + + + + + + pplay <-> s(k) t dp=pplay(k-1)-pplay(k) +c +c ----------------- paprs <-> sig(k) +c +c + + + + + + + + + pplay <-> s(k-1) +c +c +c + + + + + + + + + pplay <-> s(1) t dp=paprs-pplay z(1) +c +c ----------------- paprs <-> sig(1) +c + DO k = 2, klev + DO i = 1, knon + z(i,k) = z(i,k-1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) / RG + s(i,k) = (pplay(i,k)/paprs(i,1))**RKappa + ENDDO + ENDDO +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c +++ Determination des grandeurs de surface +++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + DO i = 1, knon +cAM IF (thermcep) THEN +cAM zdelta=MAX(0.,SIGN(1.,RTT-tsol(i))) +c zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta +c zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1)) +cAM zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1) +cAM zxqs=MIN(0.5,zxqs) +cAM zcor=1./(1.-retv*zxqs) +cAM zxqs=zxqs*zcor +cAM ELSE +cAM IF (tsol(i).LT.t_coup) THEN +cAM zxqs = qsats(tsol(i)) / paprs(i,1) +cAM ELSE +cAM zxqs = qsatl(tsol(i)) / paprs(i,1) +cAM ENDIF +cAM ENDIF +c niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref du thermique +cAM zx_alf1 = 1.0 +cAM zx_alf2 = 1.0 - zx_alf1 +cAM zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1))) +cAM . *(1.+RETV*q(i,1))*zx_alf1 +cAM . + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2))) +cAM . *(1.+RETV*q(i,2))*zx_alf2 +cAM zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2 +cAM zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2 +cAM zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2 +cAM +cAMAM zxu = u10m(i) +cAMAM zxv = v10m(i) +cAMAM zxmod = 1.0+SQRT(zxu**2+zxv**2) +cAM Niveau de ref choisi a 2m + zxt = t2m(i) + +c *************************************************** +c attention, il doit s'agir de +c ;Calcul de tcls virtuel et de w'theta'virtuel +c ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +c tcls=tcls*(1+.608*qcls) +c +c ;Pour avoir w'theta', +c ; il faut diviser par ro.Cp +c Cp=Cpd*(1+0.84*qcls) +c fcs=fcs/(ro_surf*Cp) +c ;On transforme w'theta' en w'thetav' +c Lv=(2.501-0.00237*(tcls-273.15))*1.E6 +c xle=xle/(ro_surf*Lv) +c fcsv=fcs+.608*xle*tcls +c *************************************************** +cAM khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i) +cAM kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i) +cAM +cdif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i) +cAM calcule de Ro = paprs(i,1)/Rd zxt +cAM convention >0 vers le bas ds lmdz + khfs(i) = - flux_t(i,1)*zxt*Rd / (RCPD*paprs(i,1)) + kqfs(i) = - flux_q(i,1)*zxt*Rd / (paprs(i,1)) +cAM verifier que khfs et kqfs sont bien de la forme w'l' + heatv(i) = khfs(i) + 0.608*zxt*kqfs(i) +c a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv +cAM heatv(i) = khfs(i) +cAM ustar est en entree +cAM taux = zxu *zxmod*cd_m(i) +cAM tauy = zxv *zxmod*cd_m(i) +cAM ustar(i) = SQRT(taux**2+tauy**2) +cAM ustar(i) = MAX(SQRT(ustar(i)),0.01) +c Theta et qT du thermique sans exces (interpolin vers surf) +c chgt de niveau du thermique (jeudi 30/12/1999) +c (interpolation lineaire avant integration phi_h) +cAM qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i)) +cAM qT_th(i) = max(qT_th(i),q(i,1)) + qT_th(i) = q2m(i) +cn The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul +cn reste a regler convention P) pour Theta +c The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i)) +c - + RLvCp*qT_th(i) +cAM Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i)) + Th_th(i) = t2m(i) + ENDDO +c + DO i = 1, knon + rhino(i,1) = 0.0 ! Global Richardson + check(i) = .TRUE. + pblh(i) = z(i,1) ! on initialise pblh a l'altitude du 1er niveau + plcl(i) = 6000. +c Lambda = -u*^3 / (alpha.g.kvon. + obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i)) + trmb1(i) = 0. + trmb2(i) = 0. + trmb3(i) = 0. + ENDDO + +C +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C PBL height calculation: +C Search for level of pbl. Scan upward until the Richardson number between +C the first level and the current level exceeds the "critical" value. +C (bonne idee Nu de separer le Ric et l'exces de temp du thermique) +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + fac = 100.0 + DO k = 2, isommet + DO i = 1, knon + IF (check(i)) THEN +! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ? +ctest zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = u(i,k)**2+v(i,k)**2 + zdu2 = max(zdu2,1.0e-20) +c Theta_v environnement + zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k)) +c +c therm Theta_v sans exces (avec hypothese fausse de H&B, sinon, +c passer par Theta_e et virpot) +c zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1)) +cAM zthvu = Th_th(i)*(1.+RETV*q(i,1)) + zthvu = Th_th(i)*(1.+RETV*qT_th(i)) +c Le Ri par Theta_v +cAM rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu) +cAM . /(zdu2*0.5*(zthvd+zthvu)) +cAM On a nveau de ref a 2m ??? + rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu) + . /(zdu2*0.5*(zthvd+zthvu)) +c + IF (rhino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k)) +c test04 + pblh(i) = pblh(i) + 100. + pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) * + . (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1)) + check(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO + +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C Improve estimate of pbl height for the unstable points. +C Find unstable points (sensible heat flux is upward): +C + DO i = 1, knon + IF (heatv(i) .GT. 0.) THEN + unstbl(i) = .TRUE. + check(i) = .TRUE. + ELSE + unstbl(i) = .FALSE. + check(i) = .FALSE. + ENDIF + ENDDO +C +C For the unstable case, compute velocity scale and the +C convective temperature excess: +C + DO i = 1, knon + IF (check(i)) THEN + phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet +c *************************************************** +c Wm ? et W* ? c'est la formule pour z/h < .1 +c ;Calcul de w* ;; +c ;;;;;;;;;;;;;;;; +c w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h) +c ;; CALCUL DE wm ;; +c ;;;;;;;;;;;;;;;;;; +c ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m +c ; On prend svt couche de surface=0.1*h mais on ne connait pas h +c ;;;;;;;;;;;Dans la couche de surface +c if (z(ind) le 20) then begin +c Phim=(1.-15.*(z(ind)/L))^(-1/3.) +c wm=u_star/Phim +c ;;;;;;;;;;;En dehors de la couche de surface +c endif else if (z(ind) gt 20) then begin +c wm=(u_star^3+c1*w_star^3)^(1/3.) +c endif +c *************************************************** + wm(i)= ustar(i)*phiminv(i) +c====================================================================== +cvaleurs de Dominique Lambert de la campagne SEMAPHORE : +c = 100.T*^2; = 20.q*^2 a 10m +c = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2; +c et dTetavS = sqrt() ainsi calculee. +c avec : T*=_s/w* et q*=/w* +c !!! on peut donc utiliser w* pour les fluctuations <-> Lambert +c(leur corellation pourrait dependre de beta par ex) +c if fcsv(i,j) gt 0 then begin +c dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$ +c (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$ +c 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j)) +c dqs=b2*(xle(i,j)/wm(i,j))^2 +c theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs) +c q_s(i,j)=q_10(i,j)+sqrt(dqs) +c endif else begin +c Theta_s(i,j)=thetav_10(i,j) +c q_s(i,j)=q_10(i,j) +c endelse +c====================================================================== +c +cHBTM therm(i) = heatv(i)*fak/wm(i) +c forme Mathieu : + q_star = kqfs(i)/wm(i) + t_star = khfs(i)/wm(i) +cIM 091204 BEG + IF(1.EQ.0) THEN + IF(t_star.LT.0..OR.q_star.LT.0.) THEN + print*,'i t_star q_star khfs kqfs wm',i,t_star,q_star, + $ khfs(i),kqfs(i),wm(i) + ENDIF + ENDIF +cIM 091204 END +cAM Nveau cde ref 2m => +cAM therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2 +cAM + + (RETV*T(i,1))**2*b2*q_star**2 +cAM + + 2.*RETV*T(i,1)*b212*q_star*t_star +cAM + ) +cIM 091204 BEG + a1=b1*(1.+2.*RETV*qT_th(i))*t_star**2 + a2=(RETV*Th_th(i))**2*b2*q_star*q_star + a3=2.*RETV*Th_th(i)*b212*q_star*t_star + aa=a1+a2+a3 + IF(1.EQ.0) THEN + IF (aa.LT.0.) THEN + print*,'i a1 a2 a3 aa',i,a1,a2,a3,aa + print*,'i qT_th Th_th t_star q_star RETV b1 b2 b212', + $ i,qT_th(i),Th_th(i),t_star,q_star,RETV,b1,b2,b212 + ENDIF + ENDIF +cIM 091204 END + therm(i) = sqrt( b1*(1.+2.*RETV*qT_th(i))*t_star**2 + + + (RETV*Th_th(i))**2*b2*q_star*q_star +cIM 101204 + + 2.*RETV*Th_th(i)*b212*q_star*t_star + + + max(0.,2.*RETV*Th_th(i)*b212*q_star*t_star) + + ) +c +c Theta et qT du thermique (forme H&B) avec exces +c (attention, on ajoute therm(i) qui est virtuelle ...) +c pourquoi pas sqrt(b1)*t_star ? +c dqs = b2sr*kqfs(i)/wm(i) + qT_th(i) = qT_th(i) + b2sr*q_star +cnew on differre le calcul de Theta_e +c The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i) +c ou: The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i) + rhino(i,1) = 0.0 + ENDIF + ENDDO +C +c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C ++ Improve pblh estimate for unstable conditions using the +++++++ +C ++ convective temperature excess : +++++++ +c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C + DO k = 2, isommet + DO i = 1, knon + IF (check(i)) THEN +ctest zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = u(i,k)**2+v(i,k)**2 + zdu2 = max(zdu2,1.0e-20) +c Theta_v environnement + zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k)) +c +c et therm Theta_v (avec hypothese de constance de H&B, +c zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1)) + zthvu = Th_th(i)*(1.+RETV*qT_th(i)) + therm(i) + +c +c Le Ri par Theta_v +cAM Niveau de ref 2m +cAM rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu) +cAM . /(zdu2*0.5*(zthvd+zthvu)) + rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu) + . /(zdu2*0.5*(zthvd+zthvu)) +c +c + IF (rhino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k)) +c test04 + pblh(i) = pblh(i) + 100. + pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) * + . (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1)) + check(i) = .FALSE. +cIM 170305 BEG + IF(1.EQ.0) THEN +c debug print -120;34 -34- 58 et 0;26 wamp + if (i.eq.950.or.i.eq.192.or.i.eq.624.or.i.eq.118) then + print*,' i,Th_th,Therm,qT :',i,Th_th(i),therm(i),qT_th(i) + q_star = kqfs(i)/wm(i) + t_star = khfs(i)/wm(i) + print*,'q* t*, b1,b2,b212 ',q_star,t_star + - , b1*(1.+2.*RETV*qT_th(i))*t_star**2 + - , (RETV*Th_th(i))**2*b2*q_star**2 + - , 2.*RETV*Th_th(i)*b212*q_star*t_star + print*,'zdu2 ,100.*ustar(i)**2',zdu2 ,fac*ustar(i)**2 + endif + ENDIF !(1.EQ.0) THEN +cIM 170305 END +c q_star = kqfs(i)/wm(i) +c t_star = khfs(i)/wm(i) +c trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2 +c trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2 +c Omega now trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star + ENDIF + ENDIF + ENDDO + ENDDO +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C PBL height must be greater than some minimum mechanical mixing depth +C Several investigators have proposed minimum mechanical mixing depth +C relationships as a function of the local friction velocity, u*. We +C make use of a linear relationship of the form h = c u* where c=700. +C The scaling arguments that give rise to this relationship most often +C represent the coefficient c as some constant over the local coriolis +C parameter. Here we make use of the experimental results of Koracin +C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f +C where f was evaluated at 39.5 N and 52 N. Thus we use a typical mid +C latitude value for f so that c = 0.07/f = 700. +C + DO i = 1, knon + pblmin = 700.0*ustar(i) + pblh(i) = MAX(pblh(i),pblmin) +c par exemple : + pblT(i) = t(i,2) + (t(i,3)-t(i,2)) * + . (pblh(i)-z(i,2))/(z(i,3)-z(i,2)) + ENDDO + +C ******************************************************************** +C pblh is now available; do preparation for diffusivity calculation : +C ******************************************************************** + DO i = 1, knon + check(i) = .TRUE. + Zsat(i) = .FALSE. +c omegafl utilise pour prolongement CAPE + omegafl(i) = .FALSE. + Cape(i) = 0. + Kape(i) = 0. + EauLiq(i) = 0. + CTEI(i) = 0. + pblk(i) = 0.0 + fak1(i) = ustar(i)*pblh(i)*vk +C +C Do additional preparation for unstable cases only, set temperature +C and moisture perturbations depending on stability. +C *** Rq: les formule sont prises dans leur forme CS *** + IF (unstbl(i)) THEN +cAM Niveau de ref du thermique +cAM zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) +cAM . *(1.+RETV*q(i,1)) + zxt=(Th_th(i)-zref*0.5*RG/RCPD/(1.+RVTMP2*qT_th(i))) + . *(1.+RETV*qT_th(i)) + phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet + phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i)) + wm(i) = ustar(i)*phiminv(i) + fak2(i) = wm(i)*pblh(i)*vk + wstr(i) = (heatv(i)*RG*pblh(i)/zxt)**onet + fak3(i) = fakn*wstr(i)/wm(i) + ENDIF +c Computes Theta_e for thermal (all cases : to be modified) +c attention ajout therm(i) = virtuelle + The_th(i) = Th_th(i) + therm(i) + RLvCp*qT_th(i) +c ou: The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i) + ENDDO + +C Main level loop to compute the diffusivities and +C counter-gradient terms: +C + DO 1000 k = 2, isommet +C +C Find levels within boundary layer: +C + DO i = 1, knon + unslev(i) = .FALSE. + stblev(i) = .FALSE. + zm(i) = z(i,k-1) + zp(i) = z(i,k) + IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i) + IF (zm(i) .LT. pblh(i)) THEN + zmzp = 0.5*(zm(i) + zp(i)) +C debug +c if (i.EQ.1864) then +c print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i) +c endif + + zh(i) = zmzp/pblh(i) + zl(i) = zmzp/obklen(i) + zzh(i) = 0. + IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2 +C +C stblev for points zm < plbh and stable and neutral +C unslev for points zm < plbh and unstable +C + IF (unstbl(i)) THEN + unslev(i) = .TRUE. + ELSE + stblev(i) = .TRUE. + ENDIF + ENDIF + ENDDO +c print*,'fin calcul niveaux' +C +C Stable and neutral points; set diffusivities; counter-gradient +C terms zero for stable case: +C + DO i = 1, knon + IF (stblev(i)) THEN + IF (zl(i).LE.1.) THEN + pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i)) + ELSE + pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i)) + ENDIF +c pcfm(i,k) = pblk(i) +c pcfh(i,k) = pcfm(i,k) + ENDIF + ENDDO +C +C unssrf, unstable within surface layer of pbl +C unsout, unstable within outer layer of pbl +C + DO i = 1, knon + unssrf(i) = .FALSE. + unsout(i) = .FALSE. + IF (unslev(i)) THEN + IF (zh(i).lt.sffrac) THEN + unssrf(i) = .TRUE. + ELSE + unsout(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C +C Unstable for surface layer; counter-gradient terms zero +C + DO i = 1, knon + IF (unssrf(i)) THEN + term = (1. - betam*zl(i))**onet + pblk(i) = fak1(i)*zh(i)*zzh(i)*term + pr(i) = term/sqrt(1. - betah*zl(i)) + ENDIF + ENDDO +c print*,'fin counter-gradient terms zero' +C +C Unstable for outer layer; counter-gradient terms non-zero: +C + DO i = 1, knon + IF (unsout(i)) THEN + pblk(i) = fak2(i)*zh(i)*zzh(i) +c cgs(i,k) = fak3(i)/(pblh(i)*wm(i)) +c cgh(i,k) = khfs(i)*cgs(i,k) + pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak +c cgq(i,k) = kqfs(i)*cgs(i,k) + ENDIF + ENDDO +c print*,'fin counter-gradient terms non zero' +C +C For all unstable layers, compute diffusivities and ctrgrad ter m +C +c DO i = 1, knon +c IF (unslev(i)) THEN +c pcfm(i,k) = pblk(i) +c pcfh(i,k) = pblk(i)/pr(i) +c etc cf original +c ENDIF +c ENDDO +C +C For all layers, compute integral info and CTEI +C + DO i = 1, knon + if (check(i).or.omegafl(i)) then + if (.not.Zsat(i)) then +c Th2 = The_th(i) - RLvCp*qT_th(i) + Th2 = Th_th(i) + T2 = Th2*s(i,k) +c thermodyn functions + zdelta=MAX(0.,SIGN(1.,RTT-T2)) + qqsat= r2es * FOEEW(T2,zdelta)/pplay(i,k) + qqsat=MIN(0.5,qqsat) + zcor=1./(1.-retv*qqsat) + qqsat=qqsat*zcor +c + if (qqsat.lt.qT_th(i)) then +c on calcule lcl + if (k.eq.2) then + plcl(i) = z(i,k) + else + plcl(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (qT_th(i)-qsatbef(i))/(qsatbef(i)-qqsat) + endif + Zsat(i) = .true. + Tbef(i) = T2 + endif +c + qsatbef(i) = qqsat ! bug dans la version orig ??? + endif +camn ???? cette ligne a deja ete faite normalement ? + endif +c print*,'hbtm2 i,k=',i,k + ENDDO + 1000 continue ! end of level loop +cIM 170305 BEG + IF(1.EQ.0) THEN + print*,'hbtm2 ok' + ENDIF !(1.EQ.0) THEN +cIM 170305 END + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hgardfou.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hgardfou.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hgardfou.F (revision 1634) @@ -0,0 +1,134 @@ +! +! $Id$ + SUBROUTINE hgardfou (t,tsol,text) + use dimphy + use phys_state_var_mod + IMPLICIT none +c====================================================================== +c Verifier la temperature +c====================================================================== +#include "dimensions.h" +#include "YOMCST.h" +#include "indicesol.h" + REAL t(klon,klev), tsol(klon,nbsrf) + CHARACTER*(*) text + character (len=20) :: modname = 'hgardfou' + character (len=80) :: abort_message +C + INTEGER i, k, nsrf + REAL zt(klon) + INTEGER jadrs(klon), jbad + LOGICAL ok +c + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ +c$OMP THREADPRIVATE(firstcall) + + IF (firstcall) THEN + PRINT*, 'hgardfou garantit la temperature dans [100,370] K' + firstcall = .FALSE. +c DO i = 1, klon +c print*,'i=',i,'rlon=',rlon(i),'rlat=',rlat(i) +c ENDDO +c + ENDIF +c + ok = .TRUE. + DO k = 1, klev + DO i = 1, klon + zt(i) = t(i,k) + ENDDO +#ifdef CRAY + CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i) > 370.) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,k,temperature,lon,lat,pourc ter,oce,lic,sic =', + $ jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)), + $ (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf) + ENDDO + ENDIF +#ifdef CRAY + CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon +! IF (zt(i).LT.100.0) THEN + IF (zt(i).LT.50.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,k,temperature,lon,lat,pourc ter,oce,lic,sic =', + $ jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)), + $ (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf) + ENDDO + ENDIF + ENDDO +c + DO nsrf = 1, nbsrf + DO i = 1, klon + zt(i) = tsol(i,nsrf) + ENDDO +#ifdef CRAY + CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon + IF (zt(i).GT.370.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,nsrf,temperature,lon,lat,pourc ter,oce,lic,sic =' + $ ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)) + $ ,pctsrf(jadrs(i),nsrf) + ENDDO + ENDIF +#ifdef CRAY + CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad) +#else + jbad = 0 + DO i = 1, klon +! IF (zt(i).LT.100.0) THEN + IF (zt(i).LT.50.0) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO +#endif + IF (jbad .GT. 0) THEN + ok = .FALSE. + DO i = 1, jbad + PRINT *,'i,nsrf,temperature,lon,lat,pourc ter,oce,lic,sic =' + $ ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)) + $ ,pctsrf(jadrs(i),nsrf) + ENDDO + ENDIF + ENDDO +c + IF (.NOT. ok) THEN + abort_message= 'hgardfou s arrete '//text + CALL abort_gcm (modname,abort_message,1) + ENDIF + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hines_gwd.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hines_gwd.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hines_gwd.F (revision 1634) @@ -0,0 +1,2080 @@ +! +! $Id$ +! + SUBROUTINE HINES_GWD(NLON,NLEV,DTIME,paphm1x, papm1x, + I rlat,tx,ux,vx, + O zustrhi,zvstrhi, + O d_t_hin, d_u_hin, d_v_hin) + +C ######################################################################## +C Parametrization of the momentum flux deposition due to a broad band +C spectrum of gravity waves, following Hines (1997a,b), as coded by +C McLANDRESS (1995). Modified by McFARLANE and MANZINI (1995-1997) +C MAECHAM model stand alone version +C ######################################################################## +C +C + USE dimphy + implicit none + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOEGWD.h" +#include "YOMCST.h" + + INTEGER NAZMTH + PARAMETER(NAZMTH=8) + +C INPUT ARGUMENTS. +C ----- ---------- +C +C - 2D +C PAPHM1 : HALF LEVEL PRESSURE (T-DT) +C PAPM1 : FULL LEVEL PRESSURE (T-DT) +C PTM1 : TEMPERATURE (T-DT) +C PUM1 : ZONAL WIND (T-DT) +C PVM1 : MERIDIONAL WIND (T-DT) +C + +C REFERENCE. +C ---------- +C SEE MODEL DOCUMENTATION +C +C AUTHOR. +C ------- +C +C N. MCFARLANE DKRZ-HAMBURG MAY 1995 +C STAND ALONE E. MANZINI MPI-HAMBURG FEBRUARY 1997 +C +C BASED ON A COMBINATION OF THE OROGRAPHIC SCHEME BY N.MCFARLANE 1987 +C AND THE HINES SCHEME AS CODED BY C. MCLANDRESS 1995. +C +C +C +cym INTEGER KLEVM1 +C + REAL PAPHM1(klon,klev+1), PAPM1(klon,KLEV) + REAL PTM1(klon,KLEV), PUM1(klon,KLEV), PVM1(klon,KLEV) + REAL PRFLUX(klon) +C1 +C1 +C1 + REAL RLAT(klon),COSLAT(KLON) +C + REAL TH(klon,KLEV), + 2 UTENDGW(klon,KLEV), VTENDGW(klon,KLEV), + 3 PRESSG(klon), + 4 UHS(klon,KLEV), VHS(klon,KLEV), ZPR(klon) + +C * VERTICAL POSITIONING ARRAYS. + + REAL SGJ(klon,KLEV), SHJ(klon,KLEV), + 1 SHXKJ(klon,KLEV), DSGJ(klon,KLEV) + +C * LOGICAL SWITCHES TO CONTROL ROOF DRAG, ENVELOP GW DRAG AND +C * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG. +C * LOZPR IS TRUE FOR ZPR ENHANCEMENT + + +C * WORK ARRAYS. + + REAL M_ALPHA(klon,KLEV,NAZMTH), V_ALPHA(klon,KLEV,NAZMTH), + 1 SIGMA_ALPHA(klon,KLEV,NAZMTH), + 1 SIGSQH_ALPHA(klon,KLEV,NAZMTH), + 2 DRAG_U(klon,KLEV), DRAG_V(klon,KLEV), FLUX_U(klon,KLEV), + 3 FLUX_V(klon,KLEV), HEAT(klon,KLEV), DIFFCO(klon,KLEV), + 4 BVFREQ(klon,KLEV), DENSITY(klon,KLEV), SIGMA_T(klon,KLEV), + 5 VISC_MOL(klon,KLEV), ALT(klon,KLEV), + 6 SIGSQMCW(klon,KLEV,NAZMTH), + 6 SIGMATM(klon,KLEV), + 7 AK_ALPHA(klon,NAZMTH), K_ALPHA(klon,NAZMTH), + 8 MMIN_ALPHA(klon,NAZMTH), I_ALPHA(klon,NAZMTH), + 9 RMSWIND(klon), BVFBOT(klon), DENSBOT(klon) + REAL SMOOTHR1(klon,KLEV), SMOOTHR2(klon,KLEV) + REAL SIGALPMC(klon,KLEV,NAZMTH) + REAL F2MOD(klon,KLEV) + +C * THES ARE THE INPUT PARAMETERS FOR HINES ROUTINE AND +C * ARE SPECIFIED IN ROUTINE HINES_SETUP. SINCE THIS IS CALLED +C * ONLY AT FIRST CALL TO THIS ROUTINE THESE VARIABLES MUST BE SAVED +C * FOR USE AT SUBSEQUENT CALLS. THIS CAN BE AVOIDED BY CALLING +C * HINES_SETUP IN MAIN PROGRAM AND PASSING THE PARAMETERS AS +C * SUBROUTINE ARGUEMENTS. +C + + REAL RMSCON + INTEGER NMESSG, IPRINT, ILRMS + INTEGER IFL +C + INTEGER NAZ,ICUTOFF,NSMAX,IHEATCAL + REAL SLOPE,F1,F2,F3,F5,F6,KSTAR(KLON),ALT_CUTOFF,SMCO +C +C PROVIDED AS INPUT +C + integer nlon,nlev + + real dtime + real paphm1x(nlon,nlev+1), papm1x(nlon,nlev) + real ux(nlon,nlev), vx(nlon,nlev), tx(nlon,nlev) +c +c VARIABLES FOR OUTPUT +c + + real d_t_hin(nlon,nlev),d_u_hin(nlon,nlev),d_v_hin(nlon,nlev) + real zustrhi(nlon),zvstrhi(nlon) + +C +C * LOGICAL SWITCHES TO CONTROL PRECIP ENHANCEMENT AND +C * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG. +C * LOZPR IS TRUE FOR ZPR ENHANCEMENT +C + LOGICAL LOZPR, LORMS(klon) +C +C LOCAL PARAMETERS TO MAKE THINGS WORK (TEMPORARY VARIABLE) + + REAL RHOH2O,ZPCONS,RGOCP,ZLAT,DTTDSF,RATIO,HSCAL + INTEGER I,J,L,JL,JK,LE,LREF,LREFP,LEVBOT +C +C DATA PARAMETERS NEEDED, EXPLAINED LATER + + REAL V0,VMIN,DMPSCAL,TAUFAC,HMIN,APIBT,CPART,FCRIT + REAL PCRIT,PCONS + INTEGER IPLEV,IERROR + +C +C +C PRINT *,' IT IS STARTED HINES GOING ON...' +C +C +C +C +C* COMPUTATIONAL CONSTANTS. +C ------------- ---------- +C +C + d_t_hin(:,:)=0. + + RHOH2O=1000. + ZPCONS = (1000.*86400.)/RHOH2O +cym KLEVM1=KLEV-1 +C + + do jl=kidia,kfdia + PAPHM1(JL,1) = paphm1x(JL,klev+1) + do jk=1,klev + le=klev+1-jk + PAPHM1(JL,JK+1) = paphm1x(JL,le) + PAPM1(JL,JK) = papm1x(JL,le) + PTM1(JL,JK) = tx(JL,le) + PUM1(JL,JK) = ux(JL,le) + PVM1(JL,JK) = vx(JL,le) + enddo + enddo +C + 100 CONTINUE +C +C Define constants and arrays needed for the ccc/mam gwd scheme +C *Constants: + + RGOCP=RD/RCPD + LREFP=KLEV-1 + LREF=KLEV-2 +C1 +C1 *Arrays +C1 + DO 2101 JK=1,KLEV + DO 2102 JL=KIDIA,KFDIA + SHJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1) + SGJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1) + DSGJ(JL,JK)=(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))/PAPHM1(JL,klev+1) + SHXKJ(JL,JK)=(PAPM1(JL,JK)/PAPHM1(JL,klev+1))**RGOCP + TH(JL,JK)= PTM1(JL,JK) + 2102 CONTINUE + 2101 CONTINUE + +CC + DO 211 JL=KIDIA,KFDIA + PRESSG(JL)=PAPHM1(JL,klev+1) + 211 CONTINUE +C +C + DO 301 JL=KIDIA,KFDIA + PRFLUX(JL) = 0.0 + ZPR(JL)=ZPCONS*PRFLUX(JL) + ZLAT=(RLAT(JL)/180.)*RPI + COSLAT(Jl)=COS(ZLAT) + 301 CONTINUE +C +C + 400 CONTINUE +C +C +C +C +*/######################################################################### +*/ +*/ +C +C * AUG. 14/95 - C. MCLANDRESS. +C * SEP. 95 N. MCFARLANE. +C +C * THIS ROUTINE CALCULATES THE HORIZONTAL WIND TENDENCIES +C * DUE TO MCFARLANE'S OROGRAPHIC GW DRAG SCHEME, HINES' +C * DOPPLER SPREAD SCHEME FOR "EXTROWAVES" AND ADDS ON +C * ROOF DRAG. IT IS BASED ON THE ROUTINE GWDFLX8. +C +C * LREFP IS THE INDEX OF THE MODEL LEVEL BELOW THE REFERENCE LEVEL +C * I/O ARRAYS PASSED FROM MAIN. +C * (PRESSG = SURFACE PRESSURE) +C +C +C +C +C * CONSTANTS VALUES DEFINED IN DATA STATEMENT ARE : +C * VMIN = MIMINUM WIND IN THE DIRECTION OF REFERENCE LEVEL +C * WIND BEFORE WE CONSIDER BREAKING TO HAVE OCCURED. +C * DMPSCAL = DAMPING TIME FOR GW DRAG IN SECONDS. +C * TAUFAC = 1/(LENGTH SCALE). +C * HMIN = MIMINUM ENVELOPE HEIGHT REQUIRED TO PRODUCE GW DRAG. +C * V0 = VALUE OF WIND THAT APPROXIMATES ZERO. + + + DATA VMIN / 5.0 /, V0 / 1.E-10 /, + 1 TAUFAC/ 5.E-6 /, HMIN / 40000. /, + 3 DMPSCAL / 6.5E+6 /, APIBT / 1.5708 /, + 4 CPART / 0.7 /, FCRIT / 1. / + +C * HINES EXTROWAVE GWD CONSTANTS DEFINED IN DATA STATEMENT ARE: +C * RMSCON = ROOT MEAN SQUARE GRAVITY WAVE WIND AT LOWEST LEVEL (M/S). +C * NMESSG = UNIT NUMBER FOR PRINTED MESSAGES. +C * IPRINT = 1 TO DO PRINT OUT SOME HINES ARRAYS. +C * IFL = FIRST CALL FLAG TO HINES_SETUP ("SAVE" IT) +C * PCRIT = CRITICAL VALUE OF ZPR (MM/D) +C * IPLEV = LEVEL OF APPLICATION OF PRCIT +C * PCONS = FACTOR OF ZPR ENHANCEMENT +C + + DATA PCRIT / 5. /, PCONS / 4.75 / + + IPLEV = LREFP-1 +C + DATA RMSCON / 1.00 / + 1 IPRINT / 2 /, NMESSG / 6 / + DATA IFL / 0 / +C + LOZPR = .FALSE. +C +C----------------------------------------------------------------------- +C +C +C +C * SET ERROR FLAG + + IERROR = 0 + +C * SPECIFY VARIOUS PARAMETERS FOR HINES ROUTINE AT VERY FIRST CALL. +C * (NOTE THAT ARRAY K_ALPHA IS SPECIFIED SO MAKE SURE THAT +C * IT IS NOT OVERWRITTEN LATER ON). +C + CALL HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR, + 1 ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL, + 2 K_ALPHA,IERROR,NMESSG,klon,NAZMTH,COSLAT) + IF (IERROR.NE.0) GO TO 999 +C +C * START GWD CALCULATIONS. + + LREF = LREFP-1 + +C + DO 105 J=1,NAZMTH + DO 105 L=1,KLEV + DO 105 I=kidia,klon + SIGSQMCW(I,L,J) = 0. + 105 CONTINUE +c + + +C * INITIALIZE NECESSARY ARRAYS. +C + DO 120 L=1,KLEV + DO 120 I=KIDIA,KFDIA + UTENDGW(I,L) = 0. + VTENDGW(I,L) = 0. + + UHS(I,L) = 0. + VHS(I,L) = 0. + + 120 CONTINUE +C +C * IF USING HINES SCHEME THEN CALCULATE B V FREQUENCY AT ALL POINTS +C * AND SMOOTH BVFREQ. + + DO 130 L=2,KLEV + DO 130 I=KIDIA,KFDIA + DTTDSF=(TH(I,L)/SHXKJ(I,L)-TH(I,L-1)/ + 1 SHXKJ(I,L-1))/(SHJ(I,L)-SHJ(I,L-1)) + DTTDSF=MIN(DTTDSF, -5./SGJ(I,L)) + BVFREQ(I,L)=SQRT(-DTTDSF*SGJ(I,L)*(SGJ(I,L)**RGOCP)/RD) + 1 *RG/PTM1(I,L) + 130 CONTINUE + DO 135 L=1,KLEV + DO 135 I=KIDIA,KFDIA + IF(L.EQ.1) THEN + BVFREQ(I,L) = BVFREQ(I,L+1) + ENDIF + IF(L.GT.1) THEN + RATIO=5.*LOG(SGJ(I,L)/SGJ(I,L-1)) + BVFREQ(I,L) = (BVFREQ(I,L-1) + RATIO*BVFREQ(I,L)) + 1 /(1.+RATIO) + ENDIF + 135 CONTINUE +C +C + 300 CONTINUE + +C * CALCULATE GW DRAG DUE TO HINES' EXTROWAVES +C * SET MOLECULAR VISCOSITY TO A VERY SMALL VALUE. +C * IF THE MODEL TOP IS GREATER THAN 100 KM THEN THE ACTUAL +C * VISCOSITY COEFFICIENT COULD BE SPECIFIED HERE. + + DO 310 L=1,KLEV + DO 310 I=KIDIA,KFDIA + VISC_MOL(I,L) = 1.5E-5 + DRAG_U(I,L) = 0. + DRAG_V(I,L) = 0. + FLUX_U(I,L) = 0. + FLUX_V(I,L) = 0. + HEAT(I,L) = 0. + DIFFCO(I,L) = 0. + 310 CONTINUE + +C * ALTITUDE AND DENSITY AT BOTTOM. + + DO 330 I=KIDIA,KFDIA + HSCAL = RD * PTM1(I,KLEV) / RG + DENSITY(I,KLEV) = SGJ(I,KLEV) * PRESSG(I) / (RG*HSCAL) + ALT(I,KLEV) = 0. + 330 CONTINUE + +C * ALTITUDE AND DENSITY AT REMAINING LEVELS. + + DO 340 L=KLEV-1,1,-1 + DO 340 I=KIDIA,KFDIA + HSCAL = RD * PTM1(I,L) / RG + ALT(I,L) = ALT(I,L+1) + HSCAL * DSGJ(I,L) / SGJ(I,L) + DENSITY(I,L) = SGJ(I,L) * PRESSG(I) / (RG*HSCAL) + 340 CONTINUE + +C +C * INITIALIZE SWITCHES FOR HINES GWD CALCULATION +C + ILRMS = 0 +C + DO 345 I=KIDIA,KFDIA + LORMS(I) = .FALSE. + 345 CONTINUE +C +C +C * DEFILE BOTTOM LAUNCH LEVEL +C + LEVBOT = IPLEV +C +C * BACKGROUND WIND MINUS VALUE AT BOTTOM LAUNCH LEVEL. +C + DO 351 L=1,LEVBOT + DO 351 I=KIDIA,KFDIA + UHS(I,L) = PUM1(I,L) - PUM1(I,LEVBOT) + VHS(I,L) = PVM1(I,L) - PVM1(I,LEVBOT) + 351 CONTINUE +C +C * SPECIFY ROOT MEAN SQUARE WIND AT BOTTOM LAUNCH LEVEL. +C + DO 355 I=KIDIA,KFDIA + RMSWIND(I) = RMSCON + 355 CONTINUE + + IF (LOZPR) THEN + DO 350 I=KIDIA,KFDIA + IF (ZPR(I) .GT. PCRIT) THEN + RMSWIND(I) = RMSCON + > +( (ZPR(I)-PCRIT)/ZPR(I) )*PCONS + ENDIF + 350 CONTINUE + ENDIF +C + DO 356 I=KIDIA,KFDIA + IF (RMSWIND(I) .GT. 0.0) THEN + ILRMS = ILRMS+1 + LORMS(I) = .TRUE. + ENDIF + 356 CONTINUE +C +C * CALCULATE GWD (NOTE THAT DIFFUSION COEFFICIENT AND +C * HEATING RATE ONLY CALCULATED IF IHEATCAL = 1). +C + IF ( ILRMS.GT.0 ) THEN +C + CALL HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V, + 1 UHS,VHS,BVFREQ,DENSITY,VISC_MOL,ALT, + 2 RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA, + 3 SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA, + 4 MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSBOT,BVFBOT, + 5 1,IHEATCAL,ICUTOFF,IPRINT,NSMAX, + 6 SMCO,ALT_CUTOFF,KSTAR,SLOPE, + 7 F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM, + 8 KIDIA,klon,1,LEVBOT,KLON,KLEV,NAZMTH, + 9 LORMS,SMOOTHR1,SMOOTHR2, + 9 SIGALPMC,F2MOD) + +C * ADD ON HINES' GWD TENDENCIES TO OROGRAPHIC TENDENCIES AND +C * APPLY HINES' GW DRAG ON (UROW,VROW) WORK ARRAYS. + + DO 360 L=1,KLEV + DO 360 I=KIDIA,KFDIA + UTENDGW(I,L) = UTENDGW(I,L) + DRAG_U(I,L) + VTENDGW(I,L) = VTENDGW(I,L) + DRAG_V(I,L) + 360 CONTINUE +C + +C * END OF HINES CALCULATIONS. +C + ENDIF +C + 500 CONTINUE + + +C----------------------------------------------------------------------- +C + do jl=kidia,kfdia + zustrhi(jl)=FLUX_U(jl,1) + zvstrhi(jl)=FLUX_v(jl,1) + do jk=1,klev + le=klev-jk+1 + d_u_hin(jl,JK) = UTENDGW(jl,le) * dtime + d_v_hin(jl,JK) = VTENDGW(jl,le) * dtime + enddo + enddo + +c PRINT *,'UTENDGW:',UTENDGW + +C PRINT *,' HINES HAS BEEN COMPLETED (LONG ISNT IT...)' + + RETURN + 999 CONTINUE + +C * IF ERROR DETECTED THEN ABORT. + + WRITE (NMESSG,6000) + WRITE (NMESSG,6010) IERROR + 6000 FORMAT (/' EXECUTION ABORTED IN GWDOREXV') + 6010 FORMAT (' ERROR FLAG =',I4) + +C + RETURN + END +*/ +*/ + + + SUBROUTINE HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V, + 1 VEL_U,VEL_V,BVFREQ,DENSITY,VISC_MOL,ALT, + 2 RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA, + 3 SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA, + 4 MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSB,BVFB, + 5 IORDER,IHEATCAL,ICUTOFF,IPRINT,NSMAX, + 6 SMCO,ALT_CUTOFF,KSTAR,SLOPE, + 7 F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM, + 8 IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH, + 9 LORMS,SMOOTHR1,SMOOTHR2, + 9 SIGALPMC,F2MOD) + + implicit none +C +C Main routine for Hines' "extrowave" gravity wave parameterization based +C on Hines' Doppler spread theory. This routine calculates zonal +C and meridional components of gravity wave drag, heating rates +C and diffusion coefficient on a longitude by altitude grid. +C No "mythical" lower boundary region calculation is made so it +C is assumed that lowest level winds are weak (i.e, approximately zero). +C +C Aug. 13/95 - C. McLandress +C SEPT. /95 - N.McFarlane +C +C Modifications: +C +C Output arguements: +C +C * DRAG_U = zonal component of gravity wave drag (m/s^2). +C * DRAG_V = meridional component of gravity wave drag (m/s^2). +C * HEAT = gravity wave heating (K/sec). +C * DIFFCO = diffusion coefficient (m^2/sec) +C * FLUX_U = zonal component of vertical momentum flux (Pascals) +C * FLUX_V = meridional component of vertical momentum flux (Pascals) +C +C Input arguements: +C +C * VEL_U = background zonal wind component (m/s). +C * VEL_V = background meridional wind component (m/s). +C * BVFREQ = background Brunt Vassala frequency (radians/sec). +C * DENSITY = background density (kg/m^3) +C * VISC_MOL = molecular viscosity (m^2/s) +C * ALT = altitude of momentum, density, buoyancy levels (m) +C * (NOTE: levels ordered so that ALT(I,1) > ALT(I,2), etc.) +C * RMSWIND = root mean square gravity wave wind at lowest level (m/s). +C * K_ALPHA = horizontal wavenumber of each azimuth (1/m). +C * IORDER = 1 means vertical levels are indexed from top down +C * (i.e., highest level indexed 1 and lowest level NLEVS); +C * .NE. 1 highest level is index NLEVS. +C * IHEATCAL = 1 to calculate heating rates and diffusion coefficient. +C * IPRINT = 1 to print out various arrays. +C * ICUTOFF = 1 to exponentially damp GWD, heating and diffusion +C * arrays above ALT_CUTOFF; otherwise arrays not modified. +C * ALT_CUTOFF = altitude in meters above which exponential decay applied. +C * SMCO = smoothing factor used to smooth cutoff vertical +C * wavenumbers and total rms winds in vertical direction +C * before calculating drag or heating +C * (SMCO >= 1 ==> 1:SMCO:1 stencil used). +C * NSMAX = number of times smoother applied ( >= 1), +C * = 0 means no smoothing performed. +C * KSTAR = typical gravity wave horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum +C * (SLOPE must equal 1., 1.5 or 2.). +C * F1 to F6 = Hines's fudge factors (F4 not needed since used for +C * vertical flux of vertical momentum). +C * NAZ = actual number of horizontal azimuths used. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = index of first level for drag calculation. +C * LEV2 = index of last level for drag calculation +C * (i.e., LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C Work arrays. +C +C * M_ALPHA = cutoff vertical wavenumber (1/m). +C * V_ALPHA = wind component at each azimuth (m/s) and if IHEATCAL=1 +C * holds vertical derivative of cutoff wavenumber. +C * SIGMA_ALPHA = total rms wind in each azimuth (m/s). +C * SIGSQH_ALPHA = portion of wind variance from waves having wave +C * normals in the alpha azimuth (m/s). +C * SIGMA_T = total rms horizontal wind (m/s). +C * AK_ALPHA = spectral amplitude factor at each azimuth +C * (i.e.,{AjKj}) in m^4/s^2. +C * I_ALPHA = Hines' integral. +C * MMIN_ALPHA = minimum value of cutoff wavenumber. +C * DENSB = background density at bottom level. +C * BVFB = buoyancy frequency at bottom level and +C * work array for ICUTOFF = 1. +C +C * LORMS = .TRUE. for drag computation +C + INTEGER NAZ, NLONS, NLEVS, NAZMTH, IL1, IL2, LEV1, LEV2 + INTEGER ICUTOFF, NSMAX, IORDER, IHEATCAL, IPRINT + REAL KSTAR(NLONS), F1, F2, F3, F5, F6, SLOPE + REAL ALT_CUTOFF, SMCO + REAL DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS) + REAL HEAT(NLONS,NLEVS), DIFFCO(NLONS,NLEVS) + REAL FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS) + REAL VEL_U(NLONS,NLEVS), VEL_V(NLONS,NLEVS) + REAL BVFREQ(NLONS,NLEVS), DENSITY(NLONS,NLEVS) + REAL VISC_MOL(NLONS,NLEVS), ALT(NLONS,NLEVS) + REAL RMSWIND(NLONS), BVFB(NLONS), DENSB(NLONS) + REAL SIGMA_T(NLONS,NLEVS), SIGSQMCW(NLONS,NLEVS,NAZMTH) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH), SIGMATM(NLONS,NLEVS) + REAL SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH), V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH) + REAL MMIN_ALPHA(NLONS,NAZMTH) , I_ALPHA(NLONS,NAZMTH) + REAL SMOOTHR1(NLONS,NLEVS), SMOOTHR2(NLONS,NLEVS) + REAL SIGALPMC(NLONS,NLEVS,NAZMTH) + REAL F2MOD(NLONS,NLEVS) +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER LEVBOT, LEVTOP, I, N, L, LEV1P, LEV2M + INTEGER ILPRT1, ILPRT2 +C----------------------------------------------------------------------- +C +C PRINT *,' IN HINES_EXTRO0' + LEV1P = LEV1 + 1 + LEV2M = LEV2 - 1 +C +C Index of lowest altitude level (bottom of drag calculation). +C + LEVBOT = LEV2 + LEVTOP = LEV1 + IF (IORDER.NE.1) THEN + write(6,1) + 1 format(2x,' error: IORDER NOT ONE! ') + END IF +C +C Buoyancy and density at bottom level. +C + DO 10 I = IL1,IL2 + BVFB(I) = BVFREQ(I,LEVBOT) + DENSB(I) = DENSITY(I,LEVBOT) + 10 CONTINUE +C +C initialize some variables +C + DO 20 N = 1,NAZ + DO 20 L=LEV1,LEV2 + DO 20 I=IL1,IL2 + M_ALPHA(I,L,N) = 0.0 + 20 CONTINUE + DO 21 L=LEV1,LEV2 + DO 21 I=IL1,IL2 + SIGMA_T(I,L) = 0.0 + 21 CONTINUE + DO 22 N = 1,NAZ + DO 22 I=IL1,IL2 + I_ALPHA(I,N) = 0.0 + 22 CONTINUE +C +C Compute azimuthal wind components from zonal and meridional winds. +C + CALL HINES_WIND ( V_ALPHA, + ^ VEL_U, VEL_V, NAZ, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH ) +C +C Calculate cutoff vertical wavenumber and velocity variances. +C + CALL HINES_WAVNUM ( M_ALPHA, SIGMA_ALPHA, SIGSQH_ALPHA, SIGMA_T, + ^ AK_ALPHA, V_ALPHA, VISC_MOL, DENSITY, DENSB, + ^ BVFREQ, BVFB, RMSWIND, I_ALPHA, MMIN_ALPHA, + ^ KSTAR, SLOPE, F1, F2, F3, NAZ, LEVBOT, + ^ LEVTOP,IL1,IL2,NLONS,NLEVS,NAZMTH, SIGSQMCW, + ^ SIGMATM,LORMS,SIGALPMC,F2MOD) +C +C Smooth cutoff wavenumbers and total rms velocity in the vertical +C direction NSMAX times, using FLUX_U as temporary work array. +C + IF (NSMAX.GT.0) THEN + DO 80 N = 1,NAZ + DO 81 L=LEV1,LEV2 + DO 81 I=IL1,IL2 + SMOOTHR1(I,L) = M_ALPHA(I,L,N) + 81 CONTINUE + CALL VERT_SMOOTH (SMOOTHR1, + ^ SMOOTHR2, SMCO, NSMAX, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + DO 83 L=LEV1,LEV2 + DO 83 I=IL1,IL2 + M_ALPHA(I,L,N) = SMOOTHR1(I,L) + 83 CONTINUE + 80 CONTINUE + CALL VERT_SMOOTH ( SIGMA_T, + ^ SMOOTHR2, SMCO, NSMAX, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + END IF +C +C Calculate zonal and meridional components of the +C momentum flux and drag. +C + CALL HINES_FLUX ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, + ^ ALT, DENSITY, DENSB, M_ALPHA, + ^ AK_ALPHA, K_ALPHA, SLOPE, NAZ, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH, + ^ LORMS) +C +C Cutoff drag above ALT_CUTOFF, using BVFB as temporary work array. +C + IF (ICUTOFF.EQ.1) THEN + CALL HINES_EXP ( DRAG_U, + ^ BVFB, ALT, ALT_CUTOFF, IORDER, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + CALL HINES_EXP ( DRAG_V, + ^ BVFB, ALT, ALT_CUTOFF, IORDER, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS ) + END IF +C +C Print out various arrays for diagnostic purposes. +C + IF (IPRINT.EQ.1) THEN + ILPRT1 = 15 + ILPRT2 = 16 + CALL HINES_PRINT ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, ALT, + ^ SIGMA_T, SIGMA_ALPHA, V_ALPHA, M_ALPHA, + ^ 1, 1, 6, ILPRT1, ILPRT2, LEV1, LEV2, + ^ NAZ, NLONS, NLEVS, NAZMTH) + END IF +C +C If not calculating heating rate and diffusion coefficient then finished. +C + IF (IHEATCAL.NE.1) RETURN +C +C Calculate vertical derivative of cutoff wavenumber (store +C in array V_ALPHA) using centered differences at interior gridpoints +C and one-sided differences at first and last levels. +C + DO 130 N = 1,NAZ + DO 100 L = LEV1P,LEV2M + DO 90 I = IL1,IL2 + V_ALPHA(I,L,N) = ( M_ALPHA(I,L+1,N) - M_ALPHA(I,L-1,N) ) + ^ / ( ALT(I,L+1) - ALT(I,L-1) ) + 90 CONTINUE + 100 CONTINUE + DO 110 I = IL1,IL2 + V_ALPHA(I,LEV1,N) = ( M_ALPHA(I,LEV1P,N) - M_ALPHA(I,LEV1,N) ) + ^ / ( ALT(I,LEV1P) - ALT(I,LEV1) ) + 110 CONTINUE + DO 120 I = IL1,IL2 + V_ALPHA(I,LEV2,N) = ( M_ALPHA(I,LEV2,N) - M_ALPHA(I,LEV2M,N) ) + ^ / ( ALT(I,LEV2) - ALT(I,LEV2M) ) + 120 CONTINUE + 130 CONTINUE +C +C Heating rate and diffusion coefficient. +C + CALL HINES_HEAT ( HEAT, DIFFCO, + ^ M_ALPHA, V_ALPHA, AK_ALPHA, K_ALPHA, + ^ BVFREQ, DENSITY, DENSB, SIGMA_T, VISC_MOL, + ^ KSTAR, SLOPE, F2, F3, F5, F6, NAZ, + ^ IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH) +C +C Finished. +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_WAVNUM (M_ALPHA,SIGMA_ALPHA,SIGSQH_ALPHA,SIGMA_T, + 1 AK_ALPHA,V_ALPHA,VISC_MOL,DENSITY,DENSB, + 2 BVFREQ,BVFB,RMS_WIND,I_ALPHA,MMIN_ALPHA, + 3 KSTAR,SLOPE,F1,F2,F3,NAZ,LEVBOT,LEVTOP, + 4 IL1,IL2,NLONS,NLEVS,NAZMTH,SIGSQMCW, + 5 SIGMATM,LORMS,SIGALPMC,F2MOD) +C +C This routine calculates the cutoff vertical wavenumber and velocity +C variances on a longitude by altitude grid for the Hines' Doppler +C spread gravity wave drag parameterization scheme. +C NOTE: (1) only values of four or eight can be used for # azimuths (NAZ). +C (2) only values of 1.0, 1.5 or 2.0 can be used for slope (SLOPE). +C +C Aug. 10/95 - C. McLandress +C +C Output arguements: +C +C * M_ALPHA = cutoff wavenumber at each azimuth (1/m). +C * SIGMA_ALPHA = total rms wind in each azimuth (m/s). +C * SIGSQH_ALPHA = portion of wind variance from waves having wave +C * normals in the alpha azimuth (m/s). +C * SIGMA_T = total rms horizontal wind (m/s). +C * AK_ALPHA = spectral amplitude factor at each azimuth +C * (i.e.,{AjKj}) in m^4/s^2. +C +C Input arguements: +C +C * V_ALPHA = wind component at each azimuth (m/s). +C * VISC_MOL = molecular viscosity (m^2/s) +C * DENSITY = background density (kg/m^3). +C * DENSB = background density at model bottom (kg/m^3). +C * BVFREQ = background Brunt Vassala frequency (radians/sec). +C * BVFB = background Brunt Vassala frequency at model bottom. +C * RMS_WIND = root mean square gravity wave wind at lowest level (m/s). +C * KSTAR = typical gravity wave horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum +C * (SLOPE = 1., 1.5 or 2.). +C * F1,F2,F3 = Hines's fudge factors. +C * NAZ = actual number of horizontal azimuths used (4 or 8). +C * LEVBOT = index of lowest vertical level. +C * LEVTOP = index of highest vertical level +C * (NOTE: if LEVTOP < LEVBOT then level index +C * increases from top down). +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C * LORMS = .TRUE. for drag computation +C +C Input work arrays: +C +C * I_ALPHA = Hines' integral at a single level. +C * MMIN_ALPHA = minimum value of cutoff wavenumber. +C + INTEGER NAZ, LEVBOT, LEVTOP, IL1, IL2, NLONS, NLEVS, NAZMTH + REAL SLOPE, KSTAR(NLONS), F1, F2, F3 + REAL M_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGALPMC(NLONS,NLEVS,NAZMTH) + REAL SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGSQMCW(NLONS,NLEVS,NAZMTH) + REAL SIGMA_T(NLONS,NLEVS) + REAL SIGMATM(NLONS,NLEVS) + REAL AK_ALPHA(NLONS,NAZMTH) + REAL V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL VISC_MOL(NLONS,NLEVS) + REAL F2MOD(NLONS,NLEVS) + REAL DENSITY(NLONS,NLEVS), DENSB(NLONS) + REAL BVFREQ(NLONS,NLEVS), BVFB(NLONS), RMS_WIND(NLONS) + REAL I_ALPHA(NLONS,NAZMTH), MMIN_ALPHA(NLONS,NAZMTH) +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER I, L, N, LSTART, LEND, LINCR, LBELOW + REAL M_SUB_M_TURB, M_SUB_M_MOL, M_TRIAL + REAL VISC, VISC_MIN, AZFAC, SP1 + +cc REAL N_OVER_M(1000), SIGFAC(1000) + + REAL N_OVER_M(NLONS), SIGFAC(NLONS) + DATA VISC_MIN / 1.E-10 / +C----------------------------------------------------------------------- +C + +C PRINT *,'IN HINES_WAVNUM' + SP1 = SLOPE + 1. +C +C Indices of levels to process. +C + IF (LEVBOT.GT.LEVTOP) THEN + LSTART = LEVBOT - 1 + LEND = LEVTOP + LINCR = -1 + ELSE + write(6,1) + 1 format(2x,' error: IORDER NOT ONE! ') + END IF +C +C Use horizontal isotropy to calculate azimuthal variances at bottom level. +C + AZFAC = 1. / REAL(NAZ) + DO 20 N = 1,NAZ + DO 10 I = IL1,IL2 + SIGSQH_ALPHA(I,LEVBOT,N) = AZFAC * RMS_WIND(I)**2 + 10 CONTINUE + 20 CONTINUE +C +C Velocity variances at bottom level. +C + CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, + ^ SIGSQH_ALPHA, NAZ, LEVBOT, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH) +c + CALL HINES_SIGMA ( SIGMATM, SIGALPMC, + ^ SIGSQMCW, NAZ, LEVBOT, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH) +C +C Calculate cutoff wavenumber and spectral amplitude factor +C at bottom level where it is assumed that background winds vanish +C and also initialize minimum value of cutoff wavnumber. +C + DO 40 N = 1,NAZ + DO 30 I = IL1,IL2 + IF (LORMS(I)) THEN + M_ALPHA(I,LEVBOT,N) = BVFB(I) / + ^ ( F1 * SIGMA_ALPHA(I,LEVBOT,N) + ^ + F2 * SIGMA_T(I,LEVBOT) ) + AK_ALPHA(I,N) = SIGSQH_ALPHA(I,LEVBOT,N) + ^ / ( M_ALPHA(I,LEVBOT,N)**SP1 / SP1 ) + MMIN_ALPHA(I,N) = M_ALPHA(I,LEVBOT,N) + ENDIF + 30 CONTINUE + 40 CONTINUE +C +C Calculate quantities from the bottom upwards, +C starting one level above bottom. +C + DO 150 L = LSTART,LEND,LINCR +C +C Level beneath present level. +C + LBELOW = L - LINCR +C +C Calculate N/m_M where m_M is maximum permissible value of the vertical +C wavenumber (i.e., m > m_M are obliterated) and N is buoyancy frequency. +C m_M is taken as the smaller of the instability-induced +C wavenumber (M_SUB_M_TURB) and that imposed by molecular viscosity +C (M_SUB_M_MOL). Since variance at this level is not yet known +C use value at level below. +C + DO 50 I = IL1,IL2 + IF (LORMS(I)) THEN +c + F2MFAC=SIGMATM(I,LBELOW)**2 + F2MOD(I,LBELOW) =1.+ 2.*F2MFAC + ^ / ( F2MFAC+SIGMA_T(I,LBELOW)**2 ) +c + VISC = AMAX1 ( VISC_MOL(I,L), VISC_MIN ) + M_SUB_M_TURB = BVFREQ(I,L) + ^ / ( F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW)) + M_SUB_M_MOL = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3 + IF (M_SUB_M_TURB .LT. M_SUB_M_MOL) THEN + N_OVER_M(I) = F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW) + ELSE + N_OVER_M(I) = BVFREQ(I,L) / M_SUB_M_MOL + END IF + ENDIF + 50 CONTINUE +C +C Calculate cutoff wavenumber at this level. +C + DO 70 N = 1,NAZ + DO 60 I = IL1,IL2 + IF (LORMS(I)) THEN +C +C Calculate trial value (since variance at this level is not yet known +C use value at level below). If trial value is negative or if it exceeds +C minimum value (not permitted) then set it to minimum value. +C + M_TRIAL = BVFB(I) / ( F1 * ( SIGMA_ALPHA(I,LBELOW,N)+ + ^ SIGALPMC(I,LBELOW,N)) + N_OVER_M(I) + V_ALPHA(I,L,N) ) + IF (M_TRIAL.LE.0. .OR. M_TRIAL.GT.MMIN_ALPHA(I,N)) THEN + M_TRIAL = MMIN_ALPHA(I,N) + END IF + M_ALPHA(I,L,N) = M_TRIAL +C +C Reset minimum value of cutoff wavenumber if necessary. +C + IF (M_ALPHA(I,L,N) .LT. MMIN_ALPHA(I,N)) THEN + MMIN_ALPHA(I,N) = M_ALPHA(I,L,N) + END IF +C + ENDIF + 60 CONTINUE + 70 CONTINUE +C +C Calculate the Hines integral at this level. +C + CALL HINES_INTGRL ( I_ALPHA, + ^ V_ALPHA, M_ALPHA, BVFB, SLOPE, NAZ, + ^ L, IL1, IL2, NLONS, NLEVS, NAZMTH, + ^ LORMS ) + +C +C Calculate the velocity variances at this level. +C + DO 80 I = IL1,IL2 + SIGFAC(I) = DENSB(I) / DENSITY(I,L) + ^ * BVFREQ(I,L) / BVFB(I) + 80 CONTINUE + DO 100 N = 1,NAZ + DO 90 I = IL1,IL2 + SIGSQH_ALPHA(I,L,N) = SIGFAC(I) * AK_ALPHA(I,N) + ^ * I_ALPHA(I,N) + 90 CONTINUE + 100 CONTINUE + CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, + ^ SIGSQH_ALPHA, NAZ, L, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH ) +c + CALL HINES_SIGMA ( SIGMATM, SIGALPMC, + ^ SIGSQMCW, NAZ, L, + ^ IL1, IL2, NLONS, NLEVS, NAZMTH ) +C +C End of level loop. +C + 150 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_WIND (V_ALPHA,VEL_U,VEL_V, + 1 NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH) +C +C This routine calculates the azimuthal horizontal background wind components +C on a longitude by altitude grid for the case of 4 or 8 azimuths for +C the Hines' Doppler spread GWD parameterization scheme. +C +C Aug. 7/95 - C. McLandress +C +C Output arguement: +C +C * V_ALPHA = background wind component at each azimuth (m/s). +C * (note: first azimuth is in eastward direction +C * and rotate in counterclockwise direction.) +C +C Input arguements: +C +C * VEL_U = background zonal wind component (m/s). +C * VEL_V = background meridional wind component (m/s). +C * NAZ = actual number of horizontal azimuths used (must be 4 or 8). +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C Constants in DATA statements. +C +C * COS45 = cosine of 45 degrees. +C * UMIN = minimum allowable value for zonal or meridional +C * wind component (m/s). +C +C Subroutine arguements. +C + INTEGER NAZ, IL1, IL2, LEV1, LEV2 + INTEGER NLONS, NLEVS, NAZMTH + REAL V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL VEL_U(NLONS,NLEVS), VEL_V(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER I, L + REAL U, V, COS45, UMIN +C + DATA COS45 / 0.7071068 / + DATA UMIN / 0.001 / +C----------------------------------------------------------------------- +C +C Case with 4 azimuths. +C + +C PRINT *,'IN HINES_WIND' + IF (NAZ.EQ.4) THEN + DO 20 L = LEV1,LEV2 + DO 10 I = IL1,IL2 + U = VEL_U(I,L) + V = VEL_V(I,L) + IF (ABS(U) .LT. UMIN) U = UMIN + IF (ABS(V) .LT. UMIN) V = UMIN + V_ALPHA(I,L,1) = U + V_ALPHA(I,L,2) = V + V_ALPHA(I,L,3) = - U + V_ALPHA(I,L,4) = - V + 10 CONTINUE + 20 CONTINUE + END IF +C +C Case with 8 azimuths. +C + IF (NAZ.EQ.8) THEN + DO 40 L = LEV1,LEV2 + DO 30 I = IL1,IL2 + U = VEL_U(I,L) + V = VEL_V(I,L) + IF (ABS(U) .LT. UMIN) U = UMIN + IF (ABS(V) .LT. UMIN) V = UMIN + V_ALPHA(I,L,1) = U + V_ALPHA(I,L,2) = COS45 * ( V + U ) + V_ALPHA(I,L,3) = V + V_ALPHA(I,L,4) = COS45 * ( V - U ) + V_ALPHA(I,L,5) = - U + V_ALPHA(I,L,6) = - V_ALPHA(I,L,2) + V_ALPHA(I,L,7) = - V + V_ALPHA(I,L,8) = - V_ALPHA(I,L,4) + 30 CONTINUE + 40 CONTINUE + END IF +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_FLUX (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,DENSITY, + 1 DENSB,M_ALPHA,AK_ALPHA,K_ALPHA,SLOPE, + 2 NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH, + 3 LORMS) +C +C Calculate zonal and meridional components of the vertical flux +C of horizontal momentum and corresponding wave drag (force per unit mass) +C on a longitude by altitude grid for the Hines' Doppler spread +C GWD parameterization scheme. +C NOTE: only 4 or 8 azimuths can be used. +C +C Aug. 6/95 - C. McLandress +C +C Output arguements: +C +C * FLUX_U = zonal component of vertical momentum flux (Pascals) +C * FLUX_V = meridional component of vertical momentum flux (Pascals) +C * DRAG_U = zonal component of drag (m/s^2). +C * DRAG_V = meridional component of drag (m/s^2). +C +C Input arguements: +C +C * ALT = altitudes (m). +C * DENSITY = background density (kg/m^3). +C * DENSB = background density at bottom level (kg/m^3). +C * M_ALPHA = cutoff vertical wavenumber (1/m). +C * AK_ALPHA = spectral amplitude factor (i.e., {AjKj} in m^4/s^2). +C * K_ALPHA = horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum. +C * NAZ = actual number of horizontal azimuths used (must be 4 or 8). +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C * LORMS = .TRUE. for drag computation +C +C Constant in DATA statement. +C +C * COS45 = cosine of 45 degrees. +C +C Subroutine arguements. +C + INTEGER NAZ, IL1, IL2, LEV1, LEV2 + INTEGER NLONS, NLEVS, NAZMTH + REAL SLOPE + REAL FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS) + REAL DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS) + REAL ALT(NLONS,NLEVS), DENSITY(NLONS,NLEVS), DENSB(NLONS) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH) + REAL AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH) +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER I, L, LEV1P, LEV2M + REAL COS45, PROD2, PROD4, PROD6, PROD8, DENDZ, DENDZ2 + DATA COS45 / 0.7071068 / +C----------------------------------------------------------------------- +C + LEV1P = LEV1 + 1 + LEV2M = LEV2 - 1 + LEV2P = LEV2 + 1 +C +C Sum over azimuths for case where SLOPE = 1. +C + IF (SLOPE.EQ.1.) THEN +C +C Case with 4 azimuths. +C + IF (NAZ.EQ.4) THEN + DO 20 L = LEV1,LEV2 + DO 10 I = IL1,IL2 + FLUX_U(I,L) = AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1) + ^ - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3) + FLUX_V(I,L) = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2) + ^ - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4) + 10 CONTINUE + 20 CONTINUE + END IF +C +C Case with 8 azimuths. +C + IF (NAZ.EQ.8) THEN + DO 40 L = LEV1,LEV2 + DO 30 I = IL1,IL2 + PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2) + PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4) + PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6) + PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8) + FLUX_U(I,L) = + ^ AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1) + ^ - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5) + ^ + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 ) + FLUX_V(I,L) = + ^ AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3) + ^ - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7) + ^ + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 ) + 30 CONTINUE + 40 CONTINUE + END IF +C + END IF +C +C Sum over azimuths for case where SLOPE not equal to 1. +C + IF (SLOPE.NE.1.) THEN +C +C Case with 4 azimuths. +C + IF (NAZ.EQ.4) THEN + DO 60 L = LEV1,LEV2 + DO 50 I = IL1,IL2 + FLUX_U(I,L) = + ^ AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE + ^ - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE + FLUX_V(I,L) = + ^ AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE + ^ - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE + 50 CONTINUE + 60 CONTINUE + END IF +C +C Case with 8 azimuths. +C + IF (NAZ.EQ.8) THEN + DO 80 L = LEV1,LEV2 + DO 70 I = IL1,IL2 + PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE + PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE + PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)**SLOPE + PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)**SLOPE + FLUX_U(I,L) = + ^ AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE + ^ - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)**SLOPE + ^ + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 ) + FLUX_V(I,L) = + ^ AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE + ^ - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)**SLOPE + ^ + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 ) + 70 CONTINUE + 80 CONTINUE + END IF +C + END IF +C +C Calculate flux from sum. +C + DO 100 L = LEV1,LEV2 + DO 90 I = IL1,IL2 + FLUX_U(I,L) = FLUX_U(I,L) * DENSB(I) / SLOPE + FLUX_V(I,L) = FLUX_V(I,L) * DENSB(I) / SLOPE + 90 CONTINUE + 100 CONTINUE +C +C Calculate drag at intermediate levels using centered differences +C + DO 120 L = LEV1P,LEV2M + DO 110 I = IL1,IL2 + IF (LORMS(I)) THEN +ccc DENDZ2 = DENSITY(I,L) * ( ALT(I,L+1) - ALT(I,L-1) ) + DENDZ2 = DENSITY(I,L) * ( ALT(I,L-1) - ALT(I,L) ) +ccc DRAG_U(I,L) = - ( FLUX_U(I,L+1) - FLUX_U(I,L-1) ) / DENDZ2 + DRAG_U(I,L) = - ( FLUX_U(I,L-1) - FLUX_U(I,L) ) / DENDZ2 +ccc DRAG_V(I,L) = - ( FLUX_V(I,L+1) - FLUX_V(I,L-1) ) / DENDZ2 + DRAG_V(I,L) = - ( FLUX_V(I,L-1) - FLUX_V(I,L) ) / DENDZ2 + + ENDIF + 110 CONTINUE + 120 CONTINUE +C +C Drag at first and last levels using one-side differences. +C + DO 130 I = IL1,IL2 + IF (LORMS(I)) THEN + DENDZ = DENSITY(I,LEV1) * ( ALT(I,LEV1) - ALT(I,LEV1P) ) + DRAG_U(I,LEV1) = FLUX_U(I,LEV1) / DENDZ + DRAG_V(I,LEV1) = FLUX_V(I,LEV1) / DENDZ + ENDIF + 130 CONTINUE + DO 140 I = IL1,IL2 + IF (LORMS(I)) THEN + DENDZ = DENSITY(I,LEV2) * ( ALT(I,LEV2M) - ALT(I,LEV2) ) + DRAG_U(I,LEV2) = - ( FLUX_U(I,LEV2M) - FLUX_U(I,LEV2) ) / DENDZ + DRAG_V(I,LEV2) = - ( FLUX_V(I,LEV2M) - FLUX_V(I,LEV2) ) / DENDZ + ENDIF + 140 CONTINUE + IF (NLEVS .GT. LEV2) THEN + DO 150 I = IL1,IL2 + IF (LORMS(I)) THEN + DENDZ = DENSITY(I,LEV2P) * ( ALT(I,LEV2) - ALT(I,LEV2P) ) + DRAG_U(I,LEV2P) = - FLUX_U(I,LEV2) / DENDZ + DRAG_V(I,LEV2P) = - FLUX_V(I,LEV2) / DENDZ + ENDIF +150 CONTINUE + ENDIF +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_HEAT (HEAT,DIFFCO,M_ALPHA,DMDZ_ALPHA, + 1 AK_ALPHA,K_ALPHA,BVFREQ,DENSITY,DENSB, + 2 SIGMA_T,VISC_MOL,KSTAR,SLOPE,F2,F3,F5,F6, + 3 NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH) +C +C This routine calculates the gravity wave induced heating and +C diffusion coefficient on a longitude by altitude grid for +C the Hines' Doppler spread gravity wave drag parameterization scheme. +C +C Aug. 6/95 - C. McLandress +C +C Output arguements: +C +C * HEAT = gravity wave heating (K/sec). +C * DIFFCO = diffusion coefficient (m^2/sec) +C +C Input arguements: +C +C * M_ALPHA = cutoff vertical wavenumber (1/m). +C * DMDZ_ALPHA = vertical derivative of cutoff wavenumber. +C * AK_ALPHA = spectral amplitude factor of each azimuth +C (i.e., {AjKj} in m^4/s^2). +C * K_ALPHA = horizontal wavenumber of each azimuth (1/m). +C * BVFREQ = background Brunt Vassala frequency (rad/sec). +C * DENSITY = background density (kg/m^3). +C * DENSB = background density at bottom level (kg/m^3). +C * SIGMA_T = total rms horizontal wind (m/s). +C * VISC_MOL = molecular viscosity (m^2/s). +C * KSTAR = typical gravity wave horizontal wavenumber (1/m). +C * SLOPE = slope of incident vertical wavenumber spectrum. +C * F2,F3,F5,F6 = Hines's fudge factors. +C * NAZ = actual number of horizontal azimuths used. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C + INTEGER NAZ, IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH + REAL KSTAR(NLONS), SLOPE, F2, F3, F5, F6 + REAL HEAT(NLONS,NLEVS), DIFFCO(NLONS,NLEVS) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH), DMDZ_ALPHA(NLONS,NLEVS,NAZMTH) + REAL AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH) + REAL BVFREQ(NLONS,NLEVS), DENSITY(NLONS,NLEVS), DENSB(NLONS) + REAL SIGMA_T(NLONS,NLEVS), VISC_MOL(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER I, L, N + REAL M_SUB_M_TURB, M_SUB_M_MOL, M_SUB_M, HEATNG + REAL VISC, VISC_MIN, CPGAS, SM1 +C +C specific heat at constant pressure +C + DATA CPGAS / 1004. / +C +C minimum permissible viscosity +C + DATA VISC_MIN / 1.E-10 / +C----------------------------------------------------------------------- +C +C Initialize heating array. +C + DO 20 L = 1,NLEVS + DO 10 I = 1,NLONS + HEAT(I,L) = 0. + 10 CONTINUE + 20 CONTINUE +C +C Perform sum over azimuths for case where SLOPE = 1. +C + IF (SLOPE.EQ.1.) THEN + DO 50 N = 1,NAZ + DO 40 L = LEV1,LEV2 + DO 30 I = IL1,IL2 + HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) + ^ * DMDZ_ALPHA(I,L,N) + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +C +C Perform sum over azimuths for case where SLOPE not 1. +C + IF (SLOPE.NE.1.) THEN + SM1 = SLOPE - 1. + DO 80 N = 1,NAZ + DO 70 L = LEV1,LEV2 + DO 60 I = IL1,IL2 + HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) + ^ * M_ALPHA(I,L,N)**SM1 * DMDZ_ALPHA(I,L,N) + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + END IF +C +C Heating and diffusion. +C + DO 100 L = LEV1,LEV2 + DO 90 I = IL1,IL2 +C +C Maximum permissible value of cutoff wavenumber is the smaller +C of the instability-induced wavenumber (M_SUB_M_TURB) and +C that imposed by molecular viscosity (M_SUB_M_MOL). +C + VISC = AMAX1 ( VISC_MOL(I,L), VISC_MIN ) + M_SUB_M_TURB = BVFREQ(I,L) / ( F2 * SIGMA_T(I,L) ) + M_SUB_M_MOL = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3 + M_SUB_M = AMIN1 ( M_SUB_M_TURB, M_SUB_M_MOL ) +C + HEATNG = - HEAT(I,L) * F5 * BVFREQ(I,L) / M_SUB_M + ^ * DENSB(I) / DENSITY(I,L) + DIFFCO(I,L) = F6 * HEATNG**0.33333333 / M_SUB_M**1.33333333 + HEAT(I,L) = HEATNG / CPGAS +C + 90 CONTINUE + 100 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_SIGMA (SIGMA_T,SIGMA_ALPHA,SIGSQH_ALPHA, + 1 NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH) +C +C This routine calculates the total rms and azimuthal rms horizontal +C velocities at a given level on a longitude by altitude grid for +C the Hines' Doppler spread GWD parameterization scheme. +C NOTE: only four or eight azimuths can be used. +C +C Aug. 7/95 - C. McLandress +C +C Output arguements: +C +C * SIGMA_T = total rms horizontal wind (m/s). +C * SIGMA_ALPHA = total rms wind in each azimuth (m/s). +C +C Input arguements: +C +C * SIGSQH_ALPHA = portion of wind variance from waves having wave +C * normals in the alpha azimuth (m/s). +C * NAZ = actual number of horizontal azimuths used (must be 4 or 8). +C * LEV = altitude level to process. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C Subroutine arguements. +C + INTEGER LEV, NAZ, IL1, IL2 + INTEGER NLONS, NLEVS, NAZMTH + REAL SIGMA_T(NLONS,NLEVS) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH) + REAL SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH) +C +C Internal variables. +C + INTEGER I, N + REAL SUM_EVEN, SUM_ODD +C----------------------------------------------------------------------- +C +C Calculate azimuthal rms velocity for the 4 azimuth case. +C + IF (NAZ.EQ.4) THEN + DO 10 I = IL1,IL2 + SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1) + ^ + SIGSQH_ALPHA(I,LEV,3) ) + SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2) + ^ + SIGSQH_ALPHA(I,LEV,4) ) + SIGMA_ALPHA(I,LEV,3) = SIGMA_ALPHA(I,LEV,1) + SIGMA_ALPHA(I,LEV,4) = SIGMA_ALPHA(I,LEV,2) + 10 CONTINUE + END IF +C +C Calculate azimuthal rms velocity for the 8 azimuth case. +C + IF (NAZ.EQ.8) THEN + DO 20 I = IL1,IL2 + SUM_ODD = ( SIGSQH_ALPHA(I,LEV,1) + ^ + SIGSQH_ALPHA(I,LEV,3) + ^ + SIGSQH_ALPHA(I,LEV,5) + ^ + SIGSQH_ALPHA(I,LEV,7) ) / 2. + SUM_EVEN = ( SIGSQH_ALPHA(I,LEV,2) + ^ + SIGSQH_ALPHA(I,LEV,4) + ^ + SIGSQH_ALPHA(I,LEV,6) + ^ + SIGSQH_ALPHA(I,LEV,8) ) / 2. + SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1) + ^ + SIGSQH_ALPHA(I,LEV,5) + SUM_EVEN ) + SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2) + ^ + SIGSQH_ALPHA(I,LEV,6) + SUM_ODD ) + SIGMA_ALPHA(I,LEV,3) = SQRT ( SIGSQH_ALPHA(I,LEV,3) + ^ + SIGSQH_ALPHA(I,LEV,7) + SUM_EVEN ) + SIGMA_ALPHA(I,LEV,4) = SQRT ( SIGSQH_ALPHA(I,LEV,4) + ^ + SIGSQH_ALPHA(I,LEV,8) + SUM_ODD ) + SIGMA_ALPHA(I,LEV,5) = SIGMA_ALPHA(I,LEV,1) + SIGMA_ALPHA(I,LEV,6) = SIGMA_ALPHA(I,LEV,2) + SIGMA_ALPHA(I,LEV,7) = SIGMA_ALPHA(I,LEV,3) + SIGMA_ALPHA(I,LEV,8) = SIGMA_ALPHA(I,LEV,4) + 20 CONTINUE + END IF +C +C Calculate total rms velocity. +C + DO 50 I = IL1,IL2 + SIGMA_T(I,LEV) = 0. + 50 CONTINUE + DO 70 N = 1,NAZ + DO 60 I = IL1,IL2 + SIGMA_T(I,LEV) = SIGMA_T(I,LEV) + SIGSQH_ALPHA(I,LEV,N) + 60 CONTINUE + 70 CONTINUE + DO 80 I = IL1,IL2 + SIGMA_T(I,LEV) = SQRT ( SIGMA_T(I,LEV) ) + 80 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_INTGRL (I_ALPHA,V_ALPHA,M_ALPHA,BVFB,SLOPE, + 1 NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH, + 2 LORMS) +C +C This routine calculates the vertical wavenumber integral +C for a single vertical level at each azimuth on a longitude grid +C for the Hines' Doppler spread GWD parameterization scheme. +C NOTE: (1) only spectral slopes of 1, 1.5 or 2 are permitted. +C (2) the integral is written in terms of the product QM +C which by construction is always less than 1. Series +C solutions are used for small |QM| and analytical solutions +C for remaining values. +C +C Aug. 8/95 - C. McLandress +C +C Output arguement: +C +C * I_ALPHA = Hines' integral. +C +C Input arguements: +C +C * V_ALPHA = azimuthal wind component (m/s). +C * M_ALPHA = azimuthal cutoff vertical wavenumber (1/m). +C * BVFB = background Brunt Vassala frequency at model bottom. +C * SLOPE = slope of initial vertical wavenumber spectrum +C * (must use SLOPE = 1., 1.5 or 2.) +C * NAZ = actual number of horizontal azimuths used. +C * LEV = altitude level to process. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C +C * LORMS = .TRUE. for drag computation +C +C Constants in DATA statements: +C +C * QMIN = minimum value of Q_ALPHA (avoids indeterminant form of integral) +C * QM_MIN = minimum value of Q_ALPHA * M_ALPHA (used to avoid numerical +C * problems). +C + INTEGER LEV, NAZ, IL1, IL2, NLONS, NLEVS, NAZMTH + REAL I_ALPHA(NLONS,NAZMTH) + REAL V_ALPHA(NLONS,NLEVS,NAZMTH) + REAL M_ALPHA(NLONS,NLEVS,NAZMTH) + REAL BVFB(NLONS), SLOPE +C + LOGICAL LORMS(NLONS) +C +C Internal variables. +C + INTEGER I, N + REAL Q_ALPHA, QM, SQRTQM, Q_MIN, QM_MIN +C + DATA Q_MIN / 1.0 /, QM_MIN / 0.01 / +C----------------------------------------------------------------------- +C +C For integer value SLOPE = 1. +C + IF (SLOPE .EQ. 1.) THEN +C + DO 20 N = 1,NAZ + DO 10 I = IL1,IL2 + IF (LORMS(I)) THEN +C + Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I) + QM = Q_ALPHA * M_ALPHA(I,LEV,N) +C +C If |QM| is small then use first 4 terms series of Taylor series +C expansion of integral in order to avoid indeterminate form of integral, +C otherwise use analytical form of integral. +C + IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN) THEN + IF (Q_ALPHA .EQ. 0.) THEN + I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2 / 2. + ELSE + I_ALPHA(I,N) = ( QM**2/2. + QM**3/3. + QM**4/4. + ^ + QM**5/5. ) / Q_ALPHA**2 + END IF + ELSE + I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM ) / Q_ALPHA**2 + END IF +C + ENDIF + 10 CONTINUE + 20 CONTINUE +C + END IF +C +C For integer value SLOPE = 2. +C + IF (SLOPE .EQ. 2.) THEN +C + DO 40 N = 1,NAZ + DO 30 I = IL1,IL2 + IF (LORMS(I)) THEN +C + Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I) + QM = Q_ALPHA * M_ALPHA(I,LEV,N) +C +C If |QM| is small then use first 4 terms series of Taylor series +C expansion of integral in order to avoid indeterminate form of integral, +C otherwise use analytical form of integral. +C + IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN) THEN + IF (Q_ALPHA .EQ. 0.) THEN + I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**3 / 3. + ELSE + I_ALPHA(I,N) = ( QM**3/3. + QM**4/4. + QM**5/5. + ^ + QM**6/6. ) / Q_ALPHA**3 + END IF + ELSE + I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM + QM**2/2.) + ^ / Q_ALPHA**3 + END IF +C + ENDIF + 30 CONTINUE + 40 CONTINUE +C + END IF +C +C For real value SLOPE = 1.5 +C + IF (SLOPE .EQ. 1.5) THEN +C + DO 60 N = 1,NAZ + DO 50 I = IL1,IL2 + IF (LORMS(I)) THEN +C + Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I) + QM = Q_ALPHA * M_ALPHA(I,LEV,N) +C +C If |QM| is small then use first 4 terms series of Taylor series +C expansion of integral in order to avoid indeterminate form of integral, +C otherwise use analytical form of integral. +C + IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN) THEN + IF (Q_ALPHA .EQ. 0.) THEN + I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2.5 / 2.5 + ELSE + I_ALPHA(I,N) = ( QM/2.5 + QM**2/3.5 + ^ + QM**3/4.5 + QM**4/5.5 ) + ^ * M_ALPHA(I,LEV,N)**1.5 / Q_ALPHA + END IF + ELSE + QM = ABS(QM) + SQRTQM = SQRT(QM) + IF (Q_ALPHA .GE. 0.) THEN + I_ALPHA(I,N) = ( ALOG( (1.+SQRTQM)/(1.-SQRTQM) ) + ^ -2.*SQRTQM*(1.+QM/3.) ) / Q_ALPHA**2.5 + ELSE + I_ALPHA(I,N) = 2. * ( ATAN(SQRTQM) + SQRTQM*(QM/3.-1.) ) + ^ / ABS(Q_ALPHA)**2.5 + END IF + END IF +C + ENDIF + 50 CONTINUE + 60 CONTINUE +C + END IF +C +C If integral is negative (which in principal should not happen) then +C print a message and some info since execution will abort when calculating +C the variances. +C +c DO 80 N = 1,NAZ +c DO 70 I = IL1,IL2 +c IF (I_ALPHA(I,N).LT.0.) THEN +c WRITE (6,*) +c WRITE (6,*) '******************************' +c WRITE (6,*) 'Hines integral I_ALPHA < 0 ' +c WRITE (6,*) ' longitude I=',I +c WRITE (6,*) ' azimuth N=',N +c WRITE (6,*) ' level LEV=',LEV +c WRITE (6,*) ' I_ALPHA =',I_ALPHA(I,N) +c WRITE (6,*) ' V_ALPHA =',V_ALPHA(I,LEV,N) +c WRITE (6,*) ' M_ALPHA =',M_ALPHA(I,LEV,N) +c WRITE (6,*) ' Q_ALPHA =',V_ALPHA(I,LEV,N) / BVFB(I) +c WRITE (6,*) ' QM =',V_ALPHA(I,LEV,N) / BVFB(I) +c ^ * M_ALPHA(I,LEV,N) +c WRITE (6,*) '******************************' +c END IF +c 70 CONTINUE +c 80 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR, + 1 ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL, + 2 K_ALPHA,IERROR,NMESSG,NLONS,NAZMTH,COSLAT) +C +C This routine specifies various parameters needed for the +C the Hines' Doppler spread gravity wave drag parameterization scheme. +C +C Aug. 8/95 - C. McLandress +C +C Output arguements: +C +C * NAZ = actual number of horizontal azimuths used +C * (code set up presently for only NAZ = 4 or 8). +C * SLOPE = slope of incident vertical wavenumber spectrum +C * (code set up presently for SLOPE 1., 1.5 or 2.). +C * F1 = "fudge factor" used in calculation of trial value of +C * azimuthal cutoff wavenumber M_ALPHA (1.2 <= F1 <= 1.9). +C * F2 = "fudge factor" used in calculation of maximum +C * permissible instabiliy-induced cutoff wavenumber +C * M_SUB_M_TURB (0.1 <= F2 <= 1.4). +C * F3 = "fudge factor" used in calculation of maximum +C * permissible molecular viscosity-induced cutoff wavenumber +C * M_SUB_M_MOL (0.1 <= F2 <= 1.4). +C * F5 = "fudge factor" used in calculation of heating rate +C * (1 <= F5 <= 3). +C * F6 = "fudge factor" used in calculation of turbulent +C * diffusivity coefficient. +C * KSTAR = typical gravity wave horizontal wavenumber (1/m) +C * used in calculation of M_SUB_M_TURB. +C * ICUTOFF = 1 to exponentially damp off GWD, heating and diffusion +C * arrays above ALT_CUTOFF; otherwise arrays not modified. +C * ALT_CUTOFF = altitude in meters above which exponential decay applied. +C * SMCO = smoother used to smooth cutoff vertical wavenumbers +C * and total rms winds before calculating drag or heating. +C * (==> a 1:SMCO:1 stencil used; SMCO >= 1.). +C * NSMAX = number of times smoother applied ( >= 1), +C * = 0 means no smoothing performed. +C * IHEATCAL = 1 to calculate heating rates and diffusion coefficient. +C * = 0 means only drag and flux calculated. +C * K_ALPHA = horizontal wavenumber of each azimuth (1/m) which +C * is set here to KSTAR. +C * IERROR = error flag. +C * = 0 no errors. +C * = 10 ==> NAZ > NAZMTH +C * = 20 ==> invalid number of azimuths (NAZ must be 4 or 8). +C * = 30 ==> invalid slope (SLOPE must be 1., 1.5 or 2.). +C * = 40 ==> invalid smoother (SMCO must be >= 1.) +C +C Input arguements: +C +C * NMESSG = output unit number where messages to be printed. +C * NLONS = number of longitudes. +C * NAZMTH = azimuthal array dimension (NAZMTH >= NAZ). +C + INTEGER NAZ, NLONS, NAZMTH, IHEATCAL, ICUTOFF + INTEGER NMESSG, NSMAX, IERROR + REAL KSTAR(NLONS), SLOPE, F1, F2, F3, F5, F6, ALT_CUTOFF, SMCO + REAL K_ALPHA(NLONS,NAZMTH),COSLAT(NLONS) + REAL KSMIN, KSMAX +C +C Internal variables. +C + INTEGER I, N +C----------------------------------------------------------------------- +C +C Specify constants. +C + NAZ = 8 + SLOPE = 1. + F1 = 1.5 + F2 = 0.3 + F3 = 1.0 + F5 = 3.0 + F6 = 1.0 + KSMIN = 1.E-5 + KSMAX = 1.E-4 + DO I=1,NLONS + KSTAR(I) = KSMIN/( COSLAT(I)+(KSMIN/KSMAX) ) + ENDDO + ICUTOFF = 1 + ALT_CUTOFF = 105.E3 + SMCO = 2.0 +c SMCO = 1.0 + NSMAX = 5 +c NSMAX = 2 + IHEATCAL = 0 +C +C Print information to output file. +C +c WRITE (NMESSG,6000) +c 6000 FORMAT (/' Subroutine HINES_SETUP:') +c WRITE (NMESSG,*) ' SLOPE = ', SLOPE +c WRITE (NMESSG,*) ' NAZ = ', NAZ +c WRITE (NMESSG,*) ' F1,F2,F3 = ', F1, F2, F3 +c WRITE (NMESSG,*) ' F5,F6 = ', F5, F6 +c WRITE (NMESSG,*) ' KSTAR = ', KSTAR +c > ,' COSLAT = ', COSLAT +c IF (ICUTOFF .EQ. 1) THEN +c WRITE (NMESSG,*) ' Drag exponentially damped above ', +c & ALT_CUTOFF/1.E3 +c END IF +c IF (NSMAX.LT.1 ) THEN +c WRITE (NMESSG,*) ' No smoothing of cutoff wavenumbers, etc' +c ELSE +c WRITE (NMESSG,*) ' Cutoff wavenumbers and sig_t smoothed:' +c WRITE (NMESSG,*) ' SMCO =', SMCO +c WRITE (NMESSG,*) ' NSMAX =', NSMAX +c END IF +C +C Check that things are setup correctly and log error if not +C + IERROR = 0 + IF (NAZ .GT. NAZMTH) IERROR = 10 + IF (NAZ.NE.4 .AND. NAZ.NE.8) IERROR = 20 + IF (SLOPE.NE.1. .AND. SLOPE.NE.1.5 .AND. SLOPE.NE.2.) IERROR = 30 + IF (SMCO .LT. 1.) IERROR = 40 +C +C Use single value for azimuthal-dependent horizontal wavenumber. +C + DO 20 N = 1,NAZ + DO 10 I = 1,NLONS + K_ALPHA(I,N) = KSTAR(I) + 10 CONTINUE + 20 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_PRINT (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,SIGMA_T, + 1 SIGMA_ALPHA,V_ALPHA,M_ALPHA, + 2 IU_PRINT,IV_PRINT,NMESSG, + 3 ILPRT1,ILPRT2,LEVPRT1,LEVPRT2, + 4 NAZ,NLONS,NLEVS,NAZMTH) +C +C Print out altitude profiles of various quantities from +C Hines' Doppler spread gravity wave drag parameterization scheme. +C (NOTE: only for NAZ = 4 or 8). +C +C Aug. 8/95 - C. McLandress +C +C Input arguements: +C +C * IU_PRINT = 1 to print out values in east-west direction. +C * IV_PRINT = 1 to print out values in north-south direction. +C * NMESSG = unit number for printed output. +C * ILPRT1 = first longitudinal index to print. +C * ILPRT2 = last longitudinal index to print. +C * LEVPRT1 = first altitude level to print. +C * LEVPRT2 = last altitude level to print. +C + INTEGER NAZ, ILPRT1, ILPRT2, LEVPRT1, LEVPRT2 + INTEGER NLONS, NLEVS, NAZMTH + INTEGER IU_PRINT, IV_PRINT, NMESSG + REAL FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS) + REAL DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS) + REAL ALT(NLONS,NLEVS), SIGMA_T(NLONS,NLEVS) + REAL SIGMA_ALPHA(NLONS,NLEVS,NAZMTH) + REAL V_ALPHA(NLONS,NLEVS,NAZMTH), M_ALPHA(NLONS,NLEVS,NAZMTH) +C +C Internal variables. +C + INTEGER N_EAST, N_WEST, N_NORTH, N_SOUTH + INTEGER I, L +C----------------------------------------------------------------------- +C +C Azimuthal indices of cardinal directions. +C + N_EAST = 1 + IF (NAZ.EQ.4) THEN + N_WEST = 3 + N_NORTH = 2 + N_SOUTH = 4 + ELSE IF (NAZ.EQ.8) THEN + N_WEST = 5 + N_NORTH = 3 + N_SOUTH = 7 + END IF +C +C Print out values for range of longitudes. +C + DO 100 I = ILPRT1,ILPRT2 +C +C Print east-west wind, sigmas, cutoff wavenumbers, flux and drag. +C + IF (IU_PRINT.EQ.1) THEN + WRITE (NMESSG,*) + WRITE (NMESSG,6001) I + WRITE (NMESSG,6005) + 6001 FORMAT ( 'Hines GW (east-west) at longitude I =',I3) + 6005 FORMAT (15x,' U ',2x,'sig_E',2x,'sig_T',3x,'m_E', + & 4x,'m_W',4x,'fluxU',5x,'gwdU') + DO 10 L = LEVPRT1,LEVPRT2 + WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_EAST), + & SIGMA_ALPHA(I,L,N_EAST), SIGMA_T(I,L), + & M_ALPHA(I,L,N_EAST)*1.E3, + & M_ALPHA(I,L,N_WEST)*1.E3, + & FLUX_U(I,L)*1.E5, DRAG_U(I,L)*24.*3600. + 10 CONTINUE + 6701 FORMAT (' z=',f7.2,1x,3f7.1,2f7.3,f9.4,f9.3) + END IF +C +C Print north-south winds, sigmas, cutoff wavenumbers, flux and drag. +C + IF (IV_PRINT.EQ.1) THEN + WRITE(NMESSG,*) + WRITE(NMESSG,6002) I + 6002 FORMAT ( 'Hines GW (north-south) at longitude I =',I3) + WRITE(NMESSG,6006) + 6006 FORMAT (15x,' V ',2x,'sig_N',2x,'sig_T',3x,'m_N', + & 4x,'m_S',4x,'fluxV',5x,'gwdV') + DO 20 L = LEVPRT1,LEVPRT2 + WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_NORTH), + & SIGMA_ALPHA(I,L,N_NORTH), SIGMA_T(I,L), + & M_ALPHA(I,L,N_NORTH)*1.E3, + & M_ALPHA(I,L,N_SOUTH)*1.E3, + & FLUX_V(I,L)*1.E5, DRAG_V(I,L)*24.*3600. + 20 CONTINUE + END IF +C + 100 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE HINES_EXP (DATA,DATA_ZMAX,ALT,ALT_EXP,IORDER, + 1 IL1,IL2,LEV1,LEV2,NLONS,NLEVS) +C +C This routine exponentially damps a longitude by altitude array +C of data above a specified altitude. +C +C Aug. 13/95 - C. McLandress +C +C Output arguements: +C +C * DATA = modified data array. +C +C Input arguements: +C +C * DATA = original data array. +C * ALT = altitudes. +C * ALT_EXP = altitude above which exponential decay applied. +C * IORDER = 1 means vertical levels are indexed from top down +C * (i.e., highest level indexed 1 and lowest level NLEVS); +C * .NE. 1 highest level is index NLEVS. +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical +C +C Input work arrays: +C +C * DATA_ZMAX = data values just above altitude ALT_EXP. +C + INTEGER IORDER, IL1, IL2, LEV1, LEV2, NLONS, NLEVS + REAL ALT_EXP + REAL DATA(NLONS,NLEVS), DATA_ZMAX(NLONS), ALT(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER LEVBOT, LEVTOP, LINCR, I, L + REAL HSCALE + DATA HSCALE / 5.E3 / +C----------------------------------------------------------------------- +C +C Index of lowest altitude level (bottom of drag calculation). +C + LEVBOT = LEV2 + LEVTOP = LEV1 + LINCR = 1 + IF (IORDER.NE.1) THEN + LEVBOT = LEV1 + LEVTOP = LEV2 + LINCR = -1 + END IF +C +C Data values at first level above ALT_EXP. +C + DO 20 I = IL1,IL2 + DO 10 L = LEVTOP,LEVBOT,LINCR + IF (ALT(I,L) .GE. ALT_EXP) THEN + DATA_ZMAX(I) = DATA(I,L) + END IF + 10 CONTINUE + 20 CONTINUE +C +C Exponentially damp field above ALT_EXP to model top at L=1. +C + DO 40 L = 1,LEV2 + DO 30 I = IL1,IL2 + IF (ALT(I,L) .GE. ALT_EXP) THEN + DATA(I,L) = DATA_ZMAX(I) * EXP( (ALT_EXP-ALT(I,L))/HSCALE ) + END IF + 30 CONTINUE + 40 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + SUBROUTINE VERT_SMOOTH (DATA,WORK,COEFF,NSMOOTH, + 1 IL1,IL2,LEV1,LEV2,NLONS,NLEVS) +C +C Smooth a longitude by altitude array in the vertical over a +C specified number of levels using a three point smoother. +C +C NOTE: input array DATA is modified on output! +C +C Aug. 3/95 - C. McLandress +C +C Output arguement: +C +C * DATA = smoothed array (on output). +C +C Input arguements: +C +C * DATA = unsmoothed array of data (on input). +C * WORK = work array of same dimension as DATA. +C * COEFF = smoothing coefficient for a 1:COEFF:1 stencil. +C * (e.g., COEFF = 2 will result in a smoother which +C * weights the level L gridpoint by two and the two +C * adjecent levels (L+1 and L-1) by one). +C * NSMOOTH = number of times to smooth in vertical. +C * (e.g., NSMOOTH=1 means smoothed only once, +C * NSMOOTH=2 means smoothing repeated twice, etc.) +C * IL1 = first longitudinal index to use (IL1 >= 1). +C * IL2 = last longitudinal index to use (IL1 <= IL2 <= NLONS). +C * LEV1 = first altitude level to use (LEV1 >=1). +C * LEV2 = last altitude level to use (LEV1 < LEV2 <= NLEVS). +C * NLONS = number of longitudes. +C * NLEVS = number of vertical levels. +C +C Subroutine arguements. +C + INTEGER NSMOOTH, IL1, IL2, LEV1, LEV2, NLONS, NLEVS + REAL COEFF + REAL DATA(NLONS,NLEVS), WORK(NLONS,NLEVS) +C +C Internal variables. +C + INTEGER I, L, NS, LEV1P, LEV2M + REAL SUM_WTS +C----------------------------------------------------------------------- +C +C Calculate sum of weights. +C + SUM_WTS = COEFF + 2. +C + LEV1P = LEV1 + 1 + LEV2M = LEV2 - 1 +C +C Smooth NSMOOTH times +C + DO 50 NS = 1,NSMOOTH +C +C Copy data into work array. +C + DO 20 L = LEV1,LEV2 + DO 10 I = IL1,IL2 + WORK(I,L) = DATA(I,L) + 10 CONTINUE + 20 CONTINUE +C +C Smooth array WORK in vertical direction and put into DATA. +C + DO 40 L = LEV1P,LEV2M + DO 30 I = IL1,IL2 + DATA(I,L) = ( WORK(I,L+1) + COEFF*WORK(I,L) + WORK(I,L-1) ) + & / SUM_WTS + 30 CONTINUE + 40 CONTINUE +C + 50 CONTINUE +C + RETURN +C----------------------------------------------------------------------- + END + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/histo_o500_pctau.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/histo_o500_pctau.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/histo_o500_pctau.F (revision 1634) @@ -0,0 +1,67 @@ +! +! $Header$ +! + SUBROUTINE histo_o500_pctau(nbreg,pct_ocean,w,histo,histoW,nhisto) + USE dimphy + IMPLICIT none + + INTEGER :: ij, k, l, nw + INTEGER :: nreg, nbreg +cym#include "dimensions.h" +cym#include "dimphy.h" + INTEGER, PARAMETER :: kmax=8, lmax=8 + INTEGER, PARAMETER :: kmaxm1=kmax-1, lmaxm1=lmax-1 + INTEGER, PARAMETER :: iwmax=40 + + INTEGER, dimension(klon) :: iw + REAL, dimension(klon) :: w + REAL, PARAMETER :: wmin=-200., pas_w=10. + REAL, dimension(kmaxm1,lmaxm1,iwmax,nbreg) :: histoW, nhisto + REAL, dimension(klon,kmaxm1,lmaxm1) :: histo + +! LOGICAL, dimension(klon,nbreg) :: pct_ocean + INTEGER, dimension(klon,nbreg) :: pct_ocean + +! initialisation + histoW(:,:,:,:)=0. + nhisto(:,:,:,:)=0. +! +!calcul de l'histogramme de chaque regime dynamique + DO nreg=1, nbreg + DO ij=1, klon + iw(ij) = int((w(ij)-wmin)/pas_w) +1 +c IF(pct_ocean(ij,nreg)) THEN +c IF(pct_ocean(ij,nreg).EQ.1) THEN + IF(iw(ij).GE.1.AND.iw(ij).LE.iwmax) THEN + DO l=1, lmaxm1 + DO k=1, kmaxm1 + IF(histo(ij,k,l).GT.0.) THEN + histoW(k,l,iw(ij),nreg) = histoW(k,l,iw(ij),nreg) + & + histo(ij,k,l)*pct_ocean(ij,nreg) + nhisto(k,l,iw(ij),nreg)= nhisto(k,l,iw(ij),nreg) + + & pct_ocean(ij,nreg) + ENDIF + ENDDO !k + ENDDO !l +c ELSE IF (iw(ij).LE.0.OR.iw(ij).GT.iwmax) THEN !iw +c PRINT*,'ij,iw=',ij,iw(ij) + ENDIF !iw +c ENDIF !pct_ocean + ENDDO !ij +!normalisation + DO nw=1, iwmax + DO l=1, lmaxm1 + DO k=1, kmaxm1 + IF(nhisto(k,l,nw,nreg).NE.0.) THEN + histoW(k,l,nw,nreg) = 100.*histoW(k,l,nw,nreg) + & /nhisto(k,l,nw,nreg) +c PRINT*,'k,l,nw,nreg,histoW',k,l,nw,nreg, +c & histoW(k,l,nw,nreg) + ENDIF + ENDDO !k + ENDDO !l + ENDDO !nw + ENDDO !nreg + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/homogene.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/homogene.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/homogene.F (revision 1634) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE homogene(paprs, q, dq, u,v, du, dv) + USE dimphy + IMPLICIT NONE +c============================================================== +c Schema ad hoc du melange vertical pour les vitesses u et v, +c a appliquer apres le schema de convection (fiajc et fiajh). +c +c paprs:input, pression demi-couche (inter-couche) +c q: input, vapeur d'eau (kg/kg) +c dq: input, incrementation de vapeur d'eau (de la convection) +c u: input, vitesse u +c v: input, vitesse v +c +c du: output, incrementation pour u +c dv: output, incrementation pour v +c============================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +c + REAL paprs(klon,klev+1) + REAL q(klon,klev), dq(klon,klev) + REAL u(klon,klev), du(klon,klev) + REAL v(klon,klev), dv(klon,klev) +c + REAL zm_dq(klon) ! quantite totale de l'eau deplacee + REAL zm_q(klon) ! quantite totale de la vapeur d'eau + REAL zm_u(klon) ! moyenne de u (brassage parfait et total) + REAL zm_v(klon) ! moyenne de v (brassage parfait et total) + REAL z_frac(klon) ! fraction du brassage parfait et total + REAL zm_dp(klon) +c + REAL zx + INTEGER i, k + REAL frac_max + PARAMETER (frac_max=0.1) + REAL seuil + PARAMETER (seuil=1.0e-10) + LOGICAL faisrien + PARAMETER (faisrien=.true.) +c + DO k = 1, klev + DO i = 1, klon + du(i,k) = 0.0 + dv(i,k) = 0.0 + ENDDO + ENDDO +c + IF (faisrien) RETURN +c + DO i = 1, klon + zm_dq(i)=0. + zm_q(i) =0. + zm_u(i)=0. + zm_v(i)=0. + zm_dp(i)=0. + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (ABS(dq(i,k)).GT.seuil) THEN + zx = paprs(i,k) - paprs(i,k+1) + zm_dq(i) = zm_dq(i) + ABS(dq(i,k))*zx + zm_q(i) = zm_q(i) + q(i,k)*zx + zm_dp(i) = zm_dp(i) + zx + zm_u(i) = zm_u(i) + u(i,k)*zx + zm_v(i) = zm_v(i) + v(i,k)*zx + ENDIF + ENDDO + ENDDO +c +c Hypothese principale: apres la convection, la vitesse de chaque +c couche est composee de deux parties: celle (1-z_frac) de la vitesse +c original et celle (z_frac) de la vitesse moyenne qui serait la +c vitesse de chaque couche si le brassage etait parfait et total. +c La fraction du brassage est calculee par le rapport entre la quantite +c totale de la vapeur d'eau deplacee (ou condensee) et la quantite +c totale de la vapeur d'eau. Et cette fraction est limitee a frac_max +c (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995). +c + DO i = 1, klon + IF (zm_dp(i).GE.1.0E-15 .AND. zm_q(i).GE.1.0E-15) THEN + z_frac(i)=MIN(frac_max,zm_dq(i)/zm_q(i)) + zm_u(i)=zm_u(i)/zm_dp(i) + zm_v(i)=zm_v(i)/zm_dp(i) + ENDIF + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (zm_dp(i).GE.1.e-15 .AND. zm_q(i).GE.1.e-15 + . .AND. ABS(dq(i,k)).GT.seuil) THEN + du(i,k) = u(i,k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i,k) + dv(i,k) = v(i,k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i,k) + ENDIF + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hydrol.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hydrol.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/hydrol.F (revision 1634) @@ -0,0 +1,121 @@ +! +! $Header$ +! +c +c + SUBROUTINE hydrol(dtime,pctsrf,rain_fall,snow_fall,evap, + . agesno, tsol,qsol,snow,runoff) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c date: 19940414 +c====================================================================== +c +c Traitement de l'hydrologie du sol +c --------------------------------- +c rain_fall: taux de pluie +c snow_fall: taux de neige +c agesno: age de la neige +c evap: taux d'evaporation +c tsol: temperature du sol +c qsol: humidite du sol +c snow: couverture neigeuse +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "indicesol.h" +c + REAL chasno ! epaisseur du sol: 0.15 m + PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15)) + REAL mx_eau_sol + PARAMETER (mx_eau_sol=150.0) +c + REAL dtime + REAL pctsrf(klon,nbsrf) + REAL snow(klon,nbsrf), tsol(klon,nbsrf), qsol(klon,nbsrf) + REAL snow_fall(klon), rain_fall(klon), evap(klon) + REAL runoff(klon), agesno(klon) +C + INTEGER i, is + REAL subli, fsno +C----------------------------------------------------------------------- + DO 99999 i = 1, klon +c + runoff(i) = 0.0 +c + is = is_ter + snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is) + IF (pctsrf(i,is) .GT. epsfra) THEN + subli = MIN(evap(i)*dtime,snow(i,is)) + snow(i,is) = snow(i,is) - subli + fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is)) + snow(i,is) = snow(i,is) - fsno + tsol(i,is) = tsol(i,is) - fsno*chasno + qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime + . + subli + fsno + qsol(i,is) = MAX(qsol(i,is),0.0) + runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0) + . * pctsrf(i,is) + qsol(i,is) = MIN(qsol(i,is),mx_eau_sol) +ccc ELSE +ccc snow(i,is) = 0.0 +ccc qsol(i,is) = 0.0 +ccc tsol(i,is) = 0.0 + ENDIF +c + is = is_lic + snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is) + IF (pctsrf(i,is) .GT. epsfra) THEN + subli = MIN(evap(i)*dtime,snow(i,is)) + snow(i,is) = snow(i,is) - subli + fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is)) + snow(i,is) = snow(i,is) - fsno + tsol(i,is) = tsol(i,is) - fsno*chasno + qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime + . + subli + fsno + qsol(i,is) = MAX(qsol(i,is),0.0) + runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0) + . * pctsrf(i,is) + qsol(i,is) = MIN(qsol(i,is),mx_eau_sol) +c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de +c la fonte) (Laurent Li, le 14mars98): +cIM cf GK tsol(i,is) = MIN(tsol(i,is),RTT-1.8) +cIM cf GK : la glace fond a 0C, non pas a -1.8 + tsol(i,is) = MIN(tsol(i,is),RTT) +c +ccc ELSE +ccc snow(i,is) = 0.0 +ccc qsol(i,is) = 0.0 +ccc tsol(i,is) = 0.0 + ENDIF +c + is = is_sic + qsol(i,is) = 0.0 + snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is) + IF (pctsrf(i,is) .GT. epsfra) THEN + subli = MIN(evap(i)*dtime,snow(i,is)) + snow(i,is) = snow(i,is) - subli + fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is)) + snow(i,is) = snow(i,is) - fsno + tsol(i,is) = tsol(i,is) - fsno*chasno +c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de +c la fonte) (Laurent Li, le 14mars98): +cIM cf GK tsol(i,is) = MIN(tsol(i,is),RTT-1.8) +cIM cf GK : la glace fond a 0C, non pas a -1.8 + tsol(i,is) = MIN(tsol(i,is),RTT) +c +ccc ELSE +ccc snow(i,is) = 0.0 +ccc tsol(i,is) = 0.0 + ENDIF +c + agesno(i) = (agesno(i)+ (1.-agesno(i)/50.)*dtime/86400.) + . * EXP(-1.*MAX(0.0,snow_fall(i))*dtime/0.3) + agesno(i) = MAX(agesno(i),0.0) +c +99999 CONTINUE +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/indicesol.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/indicesol.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/indicesol.h (revision 1634) @@ -0,0 +1,29 @@ +! +! $Header$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! + INTEGER nbsrf + PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille +! + INTEGER is_oce + PARAMETER (is_oce=3) ! ocean + INTEGER is_sic + PARAMETER (is_sic=4) ! glace de mer + INTEGER is_ter + PARAMETER (is_ter=1) ! terre + INTEGER is_lic + PARAMETER (is_lic=2) ! glacier continental +! + REAL epsfra + PARAMETER (epsfra=1.0E-05) +! + CHARACTER(len=3) clnsurf(nbsrf) + DATA clnsurf/'ter', 'lic', 'oce', 'sic'/ + SAVE clnsurf +!$OMP THREADPRIVATE(clnsurf) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_bilKP_ave.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_bilKP_ave.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_bilKP_ave.h (revision 1634) @@ -0,0 +1,259 @@ +c +c $Id$ +c + IF (ok_journe) THEN +c + zsto = dtime + zout = ecrit_day + typeval=tave +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=REAL(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym write(*,*)'zx_lon = ',zx_lon(:,1) +cym write(*,*)'zx_lat = ',zx_lat(1,:) +cym CALL histbeg("histbilKP_ave", iim,zx_lon(:,1), jjmp1, +cym . zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_bilKPave) + CALL histbeg_phy("histbilKP_ave", itau_phy, zjulian, dtime, + . nhori, nid_bilKPave) + + write(*,*)'Journee ', itau_phy, zjulian + CALL histvert(nid_bilKPave, "presnivs", + . "Vertical levels","mb", + . klev, presnivs/100., nvert) +c +c +c Champs 3D: +c + CALL histdef(nid_bilKPave,"ue", + . "Zonal energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"ve", + . "Merid energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"uq", + . "Zonal humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"vq", + . "Merid humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c +c Champs 3D: +c + CALL histdef(nid_bilKPave,"temp", + . "Air temperature","K", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"ovap", + . "Specific humidity","Kg/Kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"geop", + . "Geopotential height","m", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"vitu", + . "Zonal wind","m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"vitv", + . "Meridional wind","m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "vitw", + . "Vertical wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "pres", + . "Inter-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "play", + . "Mean-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "oliq", + . "Liquid water content", + . "kg/kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtdyn", + . "Dynamics dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dqdyn", + . "Dynamics dQ", "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtcon", + . "Convection dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "ducon", + . "Convection du", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dvcon", + . "Convection dv", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dqcon", + . "Convection dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtlsc", + . "Condensation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dqlsc", + . "Condensation dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dtvdf", + . "Boundary-layer dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dqvdf", + . "Boundary-layer dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dtajs", + . "Ajustement sec dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dqajs", + . "Ajustement sec dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dteva", + . "Reevaporation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dqeva", + . "Reevaporation dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) + +c + CALL histdef(nid_bilKPave, "dtswr", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtsw0", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtlwr", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dtlw0", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"duvdf", + . "Boundary-layer dU","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave,"dvvdf", + . "Boundary-layer dV","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN + CALL histdef(nid_bilKPave, "duoli", + . "Orography dU", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPave, "dvoli", + . "Orography dV", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + ENDIF + ENDIF +C + CALL histdef(nid_bilKPave, "duphy", + . "Physiq dU","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dvphy", + . "Physiq dV","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dtphy", + . "Physiq dT","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dqphy", + . "Physiq dQ","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPave, "dqlphy", + . "Physiq dQl","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C +C + CALL histend(nid_bilKPave) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF ! fin de test sur ok_journe Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_bilKP_ins.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_bilKP_ins.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_bilKP_ins.h (revision 1634) @@ -0,0 +1,326 @@ +c +c $Id$ +c + IF (ok_journe) THEN +c + zsto = dtime + zout = dtime + typeval=tinst +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=REAL(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym write(*,*)'zx_lon = ',zx_lon(:,1) +cym write(*,*)'zx_lat = ',zx_lat(1,:) +c +cIM 280405 BEG +c +cIM cf. AM 081204 BEG region + imin_ins=1 + imax_ins=iim + jmin_ins=1 + jmax_ins=jjmp1 +cym do i=1,iim-1 +cym if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i +cym if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1 +cym enddo +cym do j=1,jjmp1 +cym if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j +cym if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j +cym enddo +c + print*,'On stoke le fichier bilKP instantanne sur ', + s imin_ins,imax_ins,jmin_ins,jmax_ins + print*,'On stoke le fichier bilKP instantanne sur ', + s zx_lon(imin_ins,1),zx_lon(imax_ins,1), + s zx_lat(1,jmin_ins),zx_lat(1,jmax_ins) +cIM cf. AM 081204 END region +c +cIM 280405 END +c +cym IF(1.EQ.0) THEN +cym CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), jjmp1, +cym . zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_bilKPins) + ENDIF +c +cIM 280405 BEG +c +cIM cf. AM 081204 BEG region +cym CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), +cym . jjmp1,zx_lat(1,:), +cym . imin_ins,imax_ins-imin_ins+1, +cym . jmin_ins,jmax_ins-jmin_ins+1, +cym . itau_phy, zjulian, dtime, +cym . nhori, nid_bilKPins) + CALL histbeg_phy("histbilKP_ins", itau_phy, zjulian, dtime, + . nhori, nid_bilKPins) +cIM 081204 END +c +cIM 280405 END +c + write(*,*)'Journee ', itau_phy, zjulian + CALL histvert(nid_bilKPins, "presnivs", + . "Vertical levels","mb", + . klev, presnivs/100., nvert) +c +c Champs 3D: +c + CALL histdef(nid_bilKPins,"ue", + . "Zonal energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"ve", + . "Merid energy transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"uq", + . "Zonal humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"vq", + . "Merid humidity transport","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c +c Champs 3D: +c + CALL histdef(nid_bilKPins, "temp", + . "Air temperature", "K", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"ovap", + . "Specific humidity","Kg/Kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"geop", + . "Geopotential height", "m", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"vitu", + . "Zonal wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"vitv", + . "Meridional wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "vitw", + . "Vertical wind", "m/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "pres", + . "Inter-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "play", + . "Mean-Layer Air pressure", + . "Pa", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "oliq", + . "Liquid water content", + . "kg/kg", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtdyn", + . "Dynamics dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dqdyn", + . "Dynamics dQ", "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtcon", + . "Convection dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "ducon", + . "Convection du", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dvcon", + . "Convection dv", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqcon", + . "Convection dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtlsc", + . "Condensation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqlsc", + . "Condensation dQ","Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dtvdf", + . "Boundary-layer dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dqvdf", + . "Boundary-layer dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dtajs", + . "Ajustement sec dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqajs", + . "Ajustement sec dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dteva", + . "Reevaporation dT","K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dqeva", + . "Reevaporation dQ", + . "Kg/Kg/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) + +c + CALL histdef(nid_bilKPins, "dtswr", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtsw0", + . "SW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtlwr", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dtlw0", + . "LW radiation dT", "K/s", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"duvdf", + . "Boundary-layer dU","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins,"dvvdf", + . "Boundary-layer dV","m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN + CALL histdef(nid_bilKPins, "duoli", + . "Orography dU", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "dvoli", + . "Orography dV", "m/s2", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +c + ENDIF + ENDIF +C + CALL histdef(nid_bilKPins, "duphy", + . "Physiq dU","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dvphy", + . "Physiq dV","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dtphy", + . "Physiq dT","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dqphy", + . "Physiq dQ","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +C + CALL histdef(nid_bilKPins, "dqlphy", + . "Physiq dQl","-", + . iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, + . typeval, zsto,zout) +cIM 280405 BEG +c +c Champs 2D: +c +c u850, v850 +c DO k=1, nlevSTD + DO k=1, 12 +c + IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k) + IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k) +c + IF(bb2.EQ."850") THEN +c + CALL histdef(nid_bilKPins, "u"//bb2, + . "Zonal wind "//bb2//"mb","m/s", + . iim,jjphy_nb,nhori, 1,1,1, -99, 32, + . typeval, zsto,zout) +c + CALL histdef(nid_bilKPins, "v"//bb2, + . "Meridional wind "//bb2//"mb","m/s", + . iim,jjphy_nb,nhori, 1,1,1, -99, 32, + . typeval, zsto,zout) +c + ENDIF !(bb2.EQ."850") +c + ENDDO !k=1, 12 +c +cIM 280405 END +c + CALL histend(nid_bilKPins) +c + ndex2d = 0 + ndex3d = 0 +c + ENDIF ! fin de test sur ok_journe Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_coord_REGDYN.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_coord_REGDYN.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_coord_REGDYN.h (revision 1634) @@ -0,0 +1,81 @@ +c +c $Header$ +c + nsrf=3 + DO nreg=1, nbregdyn + DO i=1, klon + +c IF (debut) THEN + IF(rlon(i).LT.0.) THEN + rlonPOS(i)=rlon(i)+360. + ELSE + rlonPOS(i)=rlon(i) + ENDIF +c ENDIF + + pct_ocean(i,nreg)=0 + +c test si c'est 1 point d'ocean + IF(pctsrf(i,nsrf).EQ.1.) THEN + + IF(nreg.EQ.1) THEN + +c TROP + IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN + pct_ocean(i,nreg)=1 + ENDIF + +c PACIFIQUE NORD + ELSEIF(nreg.EQ.2) THEN + IF(rlat(i).GE.40.AND.rlat(i).LE.60.) THEN + IF(rlonPOS(i).GE.160..AND.rlonPOS(i).LE.235.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF +c CALIFORNIE ST-CU + ELSEIF(nreg.EQ.3) THEN + IF(rlonPOS(i).GE.220..AND.rlonPOS(i).LE.250.) THEN + IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF +c HAWAI + ELSEIF(nreg.EQ.4) THEN + IF(rlonPOS(i).GE.180..AND.rlonPOS(i).LE.220.) THEN + IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF +c WARM POOL + ELSEIF(nreg.EQ.5) THEN + IF(rlonPOS(i).GE.70..AND.rlonPOS(i).LE.150.) THEN + IF(rlat(i).GE.-5.AND.rlat(i).LE.20.) THEN + pct_ocean(i,nreg)=1 + ENDIF + ENDIF + ENDIF !nbregdyn +c TROP +c IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN +c pct_ocean(i)=.TRUE. +c WRITE(*,*) 'pct_ocean =',i, rlon(i), rlat(i) +c ENDIF !lon +c ENDIF !lat + + ENDIF !pctsrf + ENDDO !klon + ENDDO !nbregdyn +cIM 190504 ENDIF !ok_regdyn + +cIM somme de toutes les nhistoW BEG + IF (debut) THEN + DO nreg = 1, nbregdyn + DO k = 1, kmaxm1 + DO l = 1, lmaxm1 + DO iw = 1, iwmax + nhistoWt(k,l,iw,nreg)=0. + ENDDO !iw + ENDDO !l + ENDDO !k + ENDDO !nreg + ENDIF !(debut) THEN +cIM 190504 BEG Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histISCCP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histISCCP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histISCCP.h (revision 1634) @@ -0,0 +1,277 @@ +! +! $Id$ +! + IF (ok_isccp) THEN +c +c$OMP MASTER + ndex2d = 0 + ndex3d = 0 +c +c pour les champs instantannes, il faut mettre la meme valeur pour +c zout et zsto. +c dtime est passe par ailleurs a histbeg +c zstophy = frequence de stockage des champs tous les pdt physiques +c zout = frequence d'ecriture des champs +cIM 300505 zstophy = dtime +c appel du simulateur toutes les 3heures +!IM on lit la frequence d'appel dans physiq.def +! zcals(1) = dtime *6. !toutes les 3h (en s) + zcals(1) = freq_ISCCP !toutes les freq_ISCCP secondes + DO n=1, napisccp + zcalh(n) = zcals(n)/3600. !stoutes les Xh (en heures) + ENDDO !n +c +c ecriture 8 fois par jour +c zout = dtime * REAL(NINT(86400./dtime*ecrit_isccp)) +c ecriture toutes les 2h (12 fois par jour) +c zout = dtime * 4. +c ecriture toutes les 1/2 h (48 fois par jour) +c zout = dtime +c +c IF(freqout_isccp.EQ.1.) THEN +c ecriture jounaliere +!IM on ecrit les resultats du simulateur ISCCP toutes les +! ecrit_ISCCP secondes zout_isccp(1) = ecrit_day !(en s) + zout_isccp(1) = ecrit_ISCCP !(en s) +c ecriture mensuelle +c zout = dtime * ecrit_mth !(en s) + DO n=1, napisccp + zoutj(n)=zout_isccp(n)/86400. !(en jours) +c +c le nombre de sous-colonnes ncol : ncol=(100.*zcalh)/zoutd + ncol(n)=NINT((100.*zcalh(n))/zoutj(n)) + IF(ncol(n).GT.ncolmx) THEN + PRINT*,'Warning: Augmenter le nombre colonnes du simulateur' + PRINT*,' ISCCP ncol=', ncol,' ncolmx=',ncolmx +c PRINT*,'n ncol',n,ncol(n) + CALL abort + ENDIF +c + DO l=1, ncol(n) + vertlev(l,n)=REAL(l) + ENDDO !ncol +c + ENDDO !n + +c PRINT*, 'La frequence de sortie ISCCP est de ', ecrit_isccp +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c write(*,*)'ISCCP ', itau_phy, zjulian +c +c +c definition coordonnees lon,lat en globale +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +c +cIM BEG region +cym Desole dans un premier temps le mode region ne marchera pas +cym Il faudra voir dans un second temps pour l'implementer +cym Mais cela posera des problemes au niveau de la reconstruction + + imin_ins=1 + imax_ins=iim + jmin_ins=1 + jmax_ins=jjmp1 +cym do i=1,iim-1 +cym if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i +cym if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1 +cym enddo +cym do j=1,jjmp1 +cym if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j +cym if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j +cym enddo +c + print*,'On stoke le fichier histISCCP sur ', + s imin_ins,imax_ins,jmin_ins,jmax_ins +cym print*,'On stoke le fichier histISCCP instantanne sur ', +cym s zx_lon(imin_ins,1),zx_lon(imax_ins,1), +cym s zx_lat(1,jmin_ins),zx_lat(1,jmax_ins) +cIM END region +c + IF(1.EQ.0) THEN +cym CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),jjmp1,zx_lat(1,:), +cym . 1, iim, 1, jjmp1, +cym . itau_phy, zjulian, dtime, +cym . nhori, nid_isccp) + CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime, + . nhori, nid_isccp) + ENDIF !(1.EQ.0) THEN +c +cym CALL histbeg("histISCCP.nc", iim,zx_lon(:,1), +cym . jjmp1,zx_lat(1,:), +cym . imin_ins,imax_ins-imin_ins+1, +cym . jmin_ins,jmax_ins-jmin_ins+1, +cym . itau_phy, zjulian, dtime, +cym . nhori, nid_isccp) + + CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime, + . nhori, nid_isccp) +c + IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN + CALL histvert(nid_isccp, "cldtopres","Cloud Top Pressure","mb", + . lmaxm1, cldtopres, nvert,'down') + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN + CALL histvert(nid_isccp,"cldtopres3","Cloud Top Pressure","mb", + . lmax3, cldtopres3, nvert3,'down') + ENDIF + DO n=1, napisccp + CALL histvert(nid_isccp, "Nbcol"//verticaxe(n), + . "Nb of Column"//verticaxe(n),"1", + . ncol(n), vertlev(:,n), nvlev(n),'up') + ENDDO +c + IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN +c +c variables a ecrire +c + DO n=1, napisccp +c + DO k=1, kmaxm1 + CALL histdef(nid_isccp, "cldISCCP_"//taulev(k)//verticaxe(n), + . "LMDZ ISCCP cld", "%", + . iim, jj_nb,nhori,lmaxm1,1,lmaxm1,nvert,32, + . "ave(X)", zcals(n),zout_isccp(n)) + ENDDO +c + CALL histdef(nid_isccp, "nsunlit"//verticaxe(n), + . "Nb of calls with sunlit ", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "meantaucld"//verticaxe(n), + . "ISCCP mean cloud optical thickness", "1", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + ENDDO +c + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN +c + DO n=1, napisccp +c +c print*,'n=',n,' avant histdef(..LMDZ ISCCP cld' +c + DO k=1, kmaxm1 + DO l=1, lmaxm1 +c + CALL histdef(nid_isccp, pclev(l)//taulev(k)//verticaxe(n), + . "LMDZ ISCCP cld "//cnameisccp(l,k), "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + ENDDO + ENDDO +c +c print*,'n=',n,' avant histdef(..Nb of calls sunlit' + CALL histdef(nid_isccp, "nsunlit"//verticaxe(n), + . "Nb of calls with sunlit ", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "meantaucld"//verticaxe(n), + . "ISCCP mean cloud optical thickness", "1", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c +c 9types de nuages ISCCP-D2 + CALL histdef(nid_isccp, "cirr", + . "Cirrus lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "cist", + . "CiSt lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "deep", + . "Deep lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "alcu", + . "AlCu lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "alst", + . "AlSt lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "nist", + . "NiSt lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "cumu", + . "Cumu lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "stcu", + . "StCu lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "stra", + . "Stra lk ISCCP-D2", "%", + . iim, jj_nb,nhori,1,1,1,-99,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c +c 3_epaisseurs_optiques x3_pressions_au_sommet_des_nuages types de nuages + CALL histdef(nid_isccp, "thin", + . "Opt. thin ISCCP-D2 like clouds", "%", + . iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "mid", + . "Opt. intermediate ISCCP-D2 like clouds", "%", + . iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c + CALL histdef(nid_isccp, "thick", + . "Opt. thick ISCCP-D2 like clouds", "%", + . iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32, + . "ave(X)", zcals(n),zout_isccp(n)) +c +c IF(1.EQ.0) THEN +c IF(n.EQ.3) THEN +c IF(n.EQ.1) THEN +c +cIM 070905 BEG + IF(1.EQ.0) THEN + print*,'n=',n,' avant histdef(..boxptop axe' +cIM verif boxptop + CALL histdef(nid_isccp,"boxptop"//verticaxe(n), + . "Boxptop axe"//verticaxe(n), "mb", + . iim, jj_nb,nhori, + . ncol(n),1,ncol(n),nvlev(n),32, +cIM . ncolmx,1,ncolmx,nvlev,32, +cIM . "inst(X)",dtime,dtime) + . "ave(X)",zcals(n),zout_isccp(n)) + ENDIF !(1.EQ.0) THEN +cIM 070905 END +c ENDIF !(n.EQ.3) THEN +c ENDIF !(1.EQ.0) THEN +c +c print*,'n=',n,' avant histdef(..seed axe' + CALL histdef(nid_isccp, "seed"//verticaxe(n), + . "seed axe"//verticaxe(n), "-", + . iim, jj_nb,nhori,1,1,1,-99,32, +cIM . "inst(X)", dtime,dtime) + . "ave(X)", zcals(n),zout_isccp(n)) +c + ENDDO !n + ENDIF + CALL histend(nid_isccp) +c +c$OMP END MASTER + ENDIF ! ok_isccp Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histREGDYN.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histREGDYN.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histREGDYN.h (revision 1634) @@ -0,0 +1,127 @@ +! +! $Header$ +! + + IF (ok_regdyn) THEN + + if (is_sequential) then +c +cIM PRINT*, 'La frequence de sortie REGDYN est de ', ecrit_mth +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +c axe vertical pour les differents niveaux des histogrammes + DO iw=1, iwmax + zx_o500(iw)=wmin+(iw-1./2.)*pas_w + ENDDO + + CALL histbeg("histREGDYN", kmaxm1,zx_tau, lmaxm1,zx_pc, + . 1,kmaxm1,1,lmaxm1, itau_phy, zjulian, dtime, + . nhoriRD, nid_regdyn) + + CALL histvert(nid_regdyn, "omeganivs", "Omega levels", + . "mb/day", + . iwmax, zx_o500, komega) +c +c pour les champs instantannes, il faut mettre la meme valeur pour +c zout et zsto. +c dtime est passe par ailleurs a histbeg +c +c zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn)) +c zsto = zout +c print*,'zout,zsto=',zout,zsto +c +c stockage a chaque pas de temps de la physique +c + zstophy = dtime +cIM 020904 zstophy = dtime * nbapp_isccp + +c ecriture mensuelle +c + zout = dtime * ecrit_mth +cIM 020904 +c zout = dtime * ecrit_day +c zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn)) + +c +c Champs 3D: +c +c TROP + CALL histdef(nid_regdyn, "hw1", "Tropics Histogram ", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh1", "Nb of pixels Tropics Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht1", + & "Total Nb pixels Tropics Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c +c PAN + CALL histdef(nid_regdyn, "hw2", "North Pacific Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh2", "Nb of pixels North Pacific", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht2", + & "Total Nb pixels North Pacific Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c CAL + CALL histdef(nid_regdyn, "hw3", "California Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh3", + & "Nb of pixels California Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht3", + & "Total Nb pixels California Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c HAW + CALL histdef(nid_regdyn, "hw4", "Hawai Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh4", "Nb of pixels Hawai Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht4", + & "Total Nb pixels Hawai Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c WAP + CALL histdef(nid_regdyn, "hw5", "Warm Pool Histogram", "%", + & kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, + & "ave(X)", zstophy,zout) + + CALL histdef(nid_regdyn, "nh5", "Nb of pixels Warm Pool Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + + CALL histdef(nid_regdyn, "nht5", + & "Total Nb pixels Warm Pool Histo", + & "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, + & 32,"ave(X)", zstophy,zout) +c + CALL histend(nid_regdyn) + + endif ! is_sequential + + endif ! ok_regdyn Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histdayNMC.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histdayNMC.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histdayNMC.h (revision 1634) @@ -0,0 +1,140 @@ +! +! $Header$ +! +c$OMP MASTER + IF (ok_histNMC(2)) THEN +c + zstophy = dtime + zstohf = ecrit_hf + zstomth = ecrit_mth + zout = freq_outNMC(2) +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_daynmc) + + CALL histbeg_phy("histdayNMC",itau_phy, zjulian, dtime, + . nhori, nid_daynmc) +c + IF(lev_histdayNMC.EQ.nlevSTD) THEN + CALL histvert(nid_daynmc, "plev", "pressure", "Pa", + . nlevSTD, rlevSTD, nvert,"down") + ELSE IF(lev_histdayNMC.EQ.nlevSTD8) THEN + CALL histvert(nid_daynmc, "plev", "pressure", "Pa", + . nlevSTD8, rlevSTD8, nvert,"down") + ENDIF +c +cIM Astuce MAF: remplacer inst par ave pour les variables NMC pour avoir +cIM le time_counter et les bounds +c +ccc Champs 3D interpolles sur des niveaux de pression du NMC +ccc +c +c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh +c sur les niveaux du NMC et on somme & moyenne +c toutes les freq_moyNMC secondes par des routines undefSTD et +c moy_undefSTD pour eliminer les valeurs "undef" +c de la moyenne mensuelle +c ======> le "inst(X)" ci-dessous est par consequence factice ! +c + IF(lev_histdayNMC.EQ.nlevSTD) THEN + CALL histdef(nid_daynmc, "tnondef", + . "Valeurs non-definies","-", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "ta", + . "Air temperature","K", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "zg", + . "Geopotential height", "m", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "hus", + . "Specific humidity","1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "hur", + . "Relative humidity", "%", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "ua", + . "Eastward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "va", + . "Northward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "wap", + . "Lagrangian tendency of air pressure","Pa s-1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + ELSE IF(lev_histdayNMC.EQ.nlevSTD8) THEN +c + CALL histdef(nid_daynmc, "tnondef", + . "Valeurs non-definies","-", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "ta", + . "Air temperature","K", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "zg", + . "Geopotential height", "m", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "hus", + . "Specific humidity","1", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "hur", + . "Relative humidity", "%", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "ua", + . "Eastward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "va", + . "Northward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_daynmc, "wap", + . "Lagrangian tendency of air pressure","Pa s-1", + . iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32, + . "ave(X)", zout,zout) +c + ENDIF +c + CALL histend(nid_daynmc) +c + ENDIF !(ok_histNMC(2)) THEN +c$OMP END MASTER Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histday_seri.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histday_seri.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histday_seri.h (revision 1634) @@ -0,0 +1,131 @@ +c +c $Id$ +c +cym Ne fonctionnera pas en mode parallele + IF (is_sequential) THEN + + IF (type_run.EQ."AMIP") THEN +c + zstophy = dtime + zout = ecrit_day +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjmp1) = rlon(i+1) + ENDDO + DO ll=1,klev + znivsig(ll)=REAL(ll) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +c + imin_debut=1 + nbpti=1 + jmin_debut=1 + nbptj=1 +c + CALL histbeg("histday_seri.nc", + . iim,zx_lon(:,1), jjmp1,zx_lat(1,:), + . imin_debut,nbpti,jmin_debut,nbptj, + . itau_phy, zjulian, dtime, + . nhori, nid_day_seri) +c + CALL histvert(nid_day_seri, "presnivs", + . "Vertical levels","mb", + . klev, presnivs/100., nvert) +c + CALL histdef(nid_day_seri, "bilTOA", + . "Net radiation at model top", "W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "bils", + . "Net downward energy flux at surface","W/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "ecin", + . "Total kinetic energy (per unit area)","J/m2", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +cIM 151004 BEG + IF(1.EQ.0) THEN +c + CALL histdef(nid_day_seri, "momang", + . "Total relative angular momentum (per unit area)", + . "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "frictor", + . "Friction torque (per unit area)", "N/m", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "mountor", + . "Mountain torque (per unit area)", "N/m", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + ENDIF !(1.EQ.0) THEN +c + CALL histdef(nid_day_seri, "momang", + . "Axial angular momentum (per unit area)", + . "kg/s", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "torsfc", + . "Total surface torque (including mountain torque)", "N/m", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +cIM 151004 END +c + CALL histdef(nid_day_seri, "tamv", + . "Temperature (mass-weighted vert. ave)", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "psol", + . "Surface pressure", "Pa", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_day_seri, "evap", + . "Evaporation and sublimation (per unit area)", + . "kg/(m2*s)", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +c call histdef(nid_day_seri, +c . "SnowFrac", +c . "Snow-covered area ", "%", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "ave(X)", zstophy,zout) +c +c CALL histdef(nid_day_seri, "snow_depth", +cIM 080904 . "Snow Depth (water equivalent)", "m", +cIM 191104 . "Snow Depth (water equivalent)", "kg/m2", +c . "Snow Mass", "kg/m2", +c . iim,jjmp1,nhori, 1,1,1, -99, 32, +c . "ave(X)", zstophy,zout) +c + call histdef(nid_day_seri, + . "tsol_"//clnsurf(is_oce), + . "SST over open (ice-free) ocean ", "K", + . iim,jjmp1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c +c================================================================= +c + CALL histend(nid_day_seri) +c +c================================================================= + ENDIF ! fin de test sur type_run.EQ.AMIP + + ENDIF ! is_sequential Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histhf3d.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histhf3d.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histhf3d.h (revision 1634) @@ -0,0 +1,51 @@ +c $Header$ +c +c sorties hf 3d +c + zstohf = ecrit_hf + zout = ecrit_hf +c +c PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) + +cccIM CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat, +cym CALL histbeg("histhf3d", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_hf3d) + CALL histbeg_phy("histhf3d", itau_phy, zjulian, dtime, + . nhori, nid_hf3d) + + CALL histvert(nid_hf3d, "presnivs", "Vertical levels", "mb", + . klev, presnivs/100., nvert) +c +c Champs 3D: +c + CALL histdef(nid_hf3d, "temp", "Air temperature", "K", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histdef(nid_hf3d, "ovap", "Specific humidity", "kg/kg", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histdef(nid_hf3d, "vitu", "Zonal wind", "m/s", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histdef(nid_hf3d, "vitv", "Meridional wind", "m/s", + . iim,jj_nb,nhori, klev,1,klev,nvert, 32, + . "ave(X)", zstohf,zout) +c + CALL histend(nid_hf3d) +c Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histhfNMC.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histhfNMC.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histhfNMC.h (revision 1634) @@ -0,0 +1,152 @@ +! +! $Header$ +! +c$OMP MASTER +c + IF (ok_histNMC(3)) THEN +c + zstophy = dtime + zstohf = ecrit_hf + zstomth = ecrit_mth +c zout = 6 * 3600. + zout = freq_outNMC(3) +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=float(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_hfnmc) + + CALL histbeg_phy("histhfNMC",itau_phy, zjulian, dtime, + . nhori, nid_hfnmc) +c + CALL histvert(nid_hfnmc, "plev", "pressure", "Pa", + . nlevSTD3, rlevSTD3, nvert,"down") +c +cIM Astuce MAF: remplacer inst par ave pour les variables NMC pour avoir +cIM le time_counter et les bounds +c +ccc +ccc Champs 3D interpolles sur des niveaux de pression du NMC +ccc +c +c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh +c sur les niveaux du NMC et on somme & moyenne +c toutes les freq_moyNMC secondes par des routines undefSTD et +c moy_undefSTD pour eliminer les valeurs "undef" +c de la moyenne mensuelle +c ======> le "inst(X)" ci-dessous est par consequence factice ! +c + CALL histdef(nid_hfnmc, "tnondef", + . "Valeurs non-definies","-", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "ta", + . "Air temperature","K", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "zg", + . "Geopotential height", "m", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "hus", + . "Specific humidity","1", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "hur", + . "Relative humidity", "%", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "ua", + . "Eastward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "va", + . "Northward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "wap", + . "Lagrangian tendency of air pressure","Pa s-1", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "psbg", + . "Pressure sfce below ground","%", + . iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "uv", + . "uv ", + . "m2/s2",iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "vq", + . "vq ", + . "m/s * (kg/kg)",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "vT", + . "vT ", + . "mK/s",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "wq", + . "wq ", + . "(Pa/s)*(kg/kg)",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "vphi", + . "vphi ", + . "m2/s",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "wT", + . "wT ", + . "K*Pa/s",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "uxu", + . "u2 ", + . "m2/s2",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "vxv", + . "v2 ", + . "m2/s2",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_hfnmc, "TxT", + . "T2 ", + . "K2",iim,jj_nb,nhori, + . nlevSTD3,1,nlevSTD3, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histend(nid_hfnmc) +c + ENDIF !(ok_histNMC(2)) THEN +c +c$OMP END MASTER Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histmthNMC.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histmthNMC.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histmthNMC.h (revision 1634) @@ -0,0 +1,162 @@ +! +! $Id$ +! +c$OMP MASTER +c + IF (ok_histNMC(1)) THEN +c + zout = freq_outNMC(1) +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon) +cym DO i = 1, iim +cym zx_lon(i,1) = rlon(i+1) +cym zx_lon(i,jjmp1) = rlon(i+1) +cym ENDDO + DO ll=1,klev + znivsig(ll)=REAL(ll) + ENDDO +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat) +cym CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:), +cym . 1,iim,1,jjmp1, itau_phy, zjulian, dtime, +cym . nhori, nid_mthnmc) + + CALL histbeg_phy("histmthNMC",itau_phy, zjulian, dtime, + . nhori, nid_mthnmc) +c + CALL histvert(nid_mthnmc, "plev", "pressure", "Pa", + . nlevSTD, rlevSTD, nvert,"down") +c +cIM Astuce MAF: remplacer inst par ave pour les variables NMC pour avoir +cIM le time_counter et les bounds +cIM +ccc Champs 3D interpolles sur des niveaux de pression du NMC +ccc +c +c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh +c sur les niveaux du NMC et on somme & moyenne +c toutes les freq_moyNMC secondes par des routines undefSTD et +c moy_undefSTD pour eliminer les valeurs "undef" +c de la moyenne mensuelle +c ======> le "inst(X)" ci-dessous est par consequence factice ! +c +c + CALL histdef(nid_mthnmc, "tnondef", + . "Valeurs non-definies","-", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "ta", + . "Air temperature","K", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "zg", + . "Geopotential height", "m", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "hus", + . "Specific humidity","1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "hur", + . "Relative humidity", "%", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "ua", + . "Eastward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "va", + . "Northward wind","m s-1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "wap", + . "Lagrangian tendency of air pressure","Pa s-1", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "psbg", + . "Pressure sfce below ground","%", + . iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "uv", + . "uv ", + . "m2/s2",iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "vq", + . "vq ", + . "m/s * (kg/kg)",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "vT", + . "vT ", + . "mK/s",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "wq", + . "wq ", + . "(Pa/s)*(kg/kg)",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "vphi", + . "vphi ", + . "m2/s",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "wT", + . "wT ", + . "K*Pa/s",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "uxu", + . "u2 ", + . "m2/s2",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "vxv", + . "v2 ", + . "m2/s2",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "TxT", + . "T2 ", + . "K2",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + CALL histdef(nid_mthnmc, "tro3", + . "Ozone mole fraction", + . "1e-9",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) +c + if (read_climoz == 2) THEN + CALL histdef(nid_mthnmc, "tro3_daylight", + . "Daylight ozone mole fraction", + . "1e-9",iim,jj_nb,nhori, + . nlevSTD,1,nlevSTD, nvert, 32, + . "ave(X)", zout,zout) + endif +c + CALL histend(nid_mthnmc) +c + ENDIF !(ok_histNMC(1)) THEN +c +c$OMP END MASTER Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histrac.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histrac.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_histrac.h (revision 1634) @@ -0,0 +1,127 @@ +! +! $Id $ +! + IF (ecrit_tra>0. .AND. config_inca == 'none') THEN +!$OMP MASTER + CALL ymds2ju(annee_ref, 1, day_ref, 0.0, zjulian) + CALL histbeg_phy("histrac", itau_phy, zjulian, pdtphys,nhori, nid_tra) + CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",klev, presnivs, nvert) + + zsto = pdtphys + zout = ecrit_tra + CALL histdef(nid_tra, "phis", "Surface geop. height", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32,"once", zsto,zout) + CALL histdef(nid_tra, "aire", "Grid area", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32,"once", zsto,zout) + CALL histdef(nid_tra, "zmasse", "column density of air in cell", & + "kg m-2", iim, jj_nb, nhori, klev, 1, klev, nvert, 32, "ave(X)", & + zsto,zout) + +!TRACEURS +!---------------- + DO it = 1,nbtr + iiq = niadv(it+2) + +! CONCENTRATIONS + CALL histdef(nid_tra, tname(iiq), ttext(iiq), "U/kga", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32,"ave(X)", zsto,zout) + +! TD LESSIVAGE + IF (lessivage .AND. aerosol(it)) THEN + CALL histdef(nid_tra, "fl"//tname(iiq),"Flux "//ttext(iiq), & + "U/m2/s",iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + END IF + +! TD THERMIQUES + IF (iflag_thermals.gt.0) THEN + CALL histdef(nid_tra, "d_tr_th_"//tname(iiq), & + "tendance thermique"// ttext(iiq), "?", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + ENDIF + +! TD CONVECTION + IF (iflag_con.GE.2) THEN + CALL histdef(nid_tra, "d_tr_cv_"//tname(iiq), & + "tendance convection"// ttext(iiq), "?", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + ENDIF + +! TD COUCHE-LIMITE + CALL histdef(nid_tra, "d_tr_cl_"//tname(iiq), & + "tendance couche limite"// ttext(iiq), "?", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + ENDDO +!--------------- +! +! VENT (niveau 1) + CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + +! TEMPERATURE DU SOL + CALL histdef(nid_tra, "ftsol1", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "ftsol2", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "ftsol3", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst", zout,zout) + CALL histdef(nid_tra, "ftsol4", "temper sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + +! NATURE DU SOL + CALL histdef(nid_tra, "psrf1", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "psrf2", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "psrf3", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "psrf4", "nature sol", "-", & + iim,jj_nb,nhori, 1,1,1, -99, 32, & + "inst(X)", zout,zout) +! DIVERS + CALL histdef(nid_tra, "pplay", "pressure","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "T", "temperature","K", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "inst(X)", zout,zout) + CALL histdef(nid_tra, "mfu", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "mfd", "flux u decen","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "en_u", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "en_d", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "de_d", "flux u mont","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "de_u", "flux u decen","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + CALL histdef(nid_tra, "coefh", "turbulent coef","-", & + iim,jj_nb,nhori, klev,1,klev,nvert, 32, & + "ave(X)", zsto,zout) + + CALL histend(nid_tra) +!$OMP END MASTER + END IF ! ecrit_tra>0. .AND. config_inca == 'none' + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_paramLMDZ_phy.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_paramLMDZ_phy.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_paramLMDZ_phy.h (revision 1634) @@ -0,0 +1,133 @@ +cIM Implemente en modes sequentiel et parallele + + CALL gather(rlat,rlat_glo) + CALL bcast(rlat_glo) + CALL gather(rlon,rlon_glo) + CALL bcast(rlon_glo) + +c$OMP MASTER + if (is_mpi_root) then +c + zstophy = dtime + zout = mth_len*un_jour +c + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon) + if (iim.gt.1) then + DO i = 1, iim + zx_lon(i,1) = rlon_glo(i+1) + zx_lon(i,jjmp1) = rlon_glo(i+1) + ENDDO + endif + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat) +c + CALL histbeg("paramLMDZ_phy.nc", + . np,zx_lon(np:np,1), np,zx_lat(1,np:np), + . 1,1,1,1, + . itau_phy, zjulian, dtime, + . nhori, nid_ctesGCM) +c + CALL histdef(nid_ctesGCM, "R_ecc", + . "Excentricite","-", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "R_peri", + . "Equinoxe","-", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "R_incl", + . "Inclinaison","deg", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "solaire", + . "Constante solaire","W/m2", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "co2_ppm", + . "Concentration du CO2", "ppm", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "CH4_ppb", + . "Concentration du CH4", "ppb", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "N2O_ppb", + . "Concentration du N2O", "ppb", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "CFC11_ppt", + . "Concentration du CFC11", "ppt", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "CFC12_ppt", + . "Concentration du CFC12", "ppt", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave(X)", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "bils", + . "Surface total heat flux", "W m-2", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "evap", + . "Evaporation", "kg m-2 s-1", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "evap_land", + . "Land evaporation", "kg m-2 s-1", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "flat", + . "Latent heat flux", "W m-2", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "nettop0", + . "Clear sky net downward radiatif flux at TOA", + . "W m-2", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "nettop", + . "Net downward radiatif flux at TOA", "W m-2", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "precip", + . "Total precipitation (liq+sol)", "kg m-2 s-1", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "tsol", + . "Surface temperature", "K", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "t2m", + . "Temperature at 2m", "K", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c + CALL histdef(nid_ctesGCM, "prw", + . "Precipitable water", "kg m-2", + . 1,1,nhori, 1,1,1, -99, 32, + . "ave", zstophy,zout) +c================================================================= +c + CALL histend(nid_ctesGCM) + + endif !(is_mpi_root) +c$OMP END MASTER +c================================================================= Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_undefSTD.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_undefSTD.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_undefSTD.F (revision 1634) @@ -0,0 +1,86 @@ +! +! $Id$ +! + + SUBROUTINE ini_undefSTD(itap, + $ freq_outNMC) + USE dimphy + USE phys_state_var_mod ! Variables sauvegardees de la physique + IMPLICIT none +c +c==================================================================== +c +c I. Musat : 09.2004 +c +c Initialisation - a des frequences differentes : +c +c 1) des variables moyennees sur la journee "day" ou sur le mois "mth" +c calculees a partir des valeurs "instantannees" de la physique +c +c 2) des variables moyennes mensuelles "NMC" calculees a partir des val. +c toutes les 6 heures +c +c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps +c ! de la physique +c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps +c ! de la physique +c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures +c +c NB: mettre "inst(X)" dans le write_hist*NMC.h ! +c==================================================================== +c +cym #include "dimensions.h" +cym integer jjmp1 +cym parameter (jjmp1=jjm+1-1/jjm) +cym #include "dimphy.h" +c variables Input/Output +c INTEGER nlevSTD, klevSTD, itap + INTEGER itap +c PARAMETER(klevSTD=17) +c REAL dtime +c +c variables locales +c INTEGER i, k, nout, n + INTEGER i, k, n +c PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC + REAL freq_outNMC(nout) +c +c variables Output +c REAL tnondef(klon,klevSTD,nout) +c REAL tsumSTD(klon,klevSTD,nout) +c + DO n=1, nout +c +c initialisation variables en debut de la journee ou du mois +c + IF(MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.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. + ENDDO !i + ENDDO !k +c + ENDIF !MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.1. +c + ENDDO !n +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_wake.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_wake.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ini_wake.F (revision 1634) @@ -0,0 +1,84 @@ +! +! $Id$ +! + SUBROUTINE INI_WAKE(wape,fip,it_wape_prescr, + : wape_prescr, fip_prescr, alp_bl_prescr, ale_bl_prescr) +*************************************************************** +* * +* INI_WAKE : variables d'initialisation de la poche * +* froide, necessaires au declenchement * +* de la convection. * +* * +* * +*************************************************************** +c Arguments +c ========= +c Input +c ----- +c wape : valeur de l'energie potentielle de la poche (WAPE) +c dans l'etat initial +c fip : valeur de la puissance incidente sur le front (FIP) +c dans l'etat initial +c Output +c ------ +c it_wape_prescr : nombre de pas de temps pendant lesquels la WAPE +c doit etre imposee. +c wape_prescr : valeur prescrite de la WAPE. +c fip_prescr : valeur prescrite de la FIP. +c ale_bl_prescr : valeur prescrite de la Ale de PBL. +c alp_bl_prescr : valeur prescrite de la Alp de PBL. +c +c Variables internes +c ================== +c it = nbre de pas de temps lu +c w = WAPE lue +c f = FIP lue +c alebl = Ale de PBL lue +c alpbl = Alp de PBL lue +c + include 'iniprint.h' +cdeclarations + real ale_bl_prescr + real alp_bl_prescr + real it + +! FH A mettre si besoin dans physiq.def +! FH : voir avec JYG + it=0. + w=4. + f=0.1 + alebl=4. + alpbl=0.1 +c +cCR: on rajoute ale et alp de la PBL precrits + open (99,file='ini_wake_param.data',form='formatted', + s status='old',err=902) + read (99,*) it + read (99,*) w + read (99,*) f + read (99,*,end=901) alebl + read (99,*,end=901) alpbl +901 close (99) +902 continue +c + write(lunout,*)' it,wape ',it,wape + it_wape_prescr = it + if (w .lt. 0) then + wape_prescr = wape + fip_prescr = fip + else + wape_prescr = w + fip_prescr = f + endif +c + write(lunout,*)' alebl, alpbl ',alebl,alpbl + ale_bl_prescr=alebl + alp_bl_prescr=alpbl + print *,'Initialisation de la poche : WAPE, FIP imposees =' + $ ,wape_prescr, fip_prescr + print *, ' pendant ',it_wape_prescr,' steps' +c + print *,'Initialisation de la BL: ALP, ALE imposees =' + $ ,alp_bl_prescr, ale_bl_prescr + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/inifis.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/inifis.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/inifis.F (revision 1634) @@ -0,0 +1,83 @@ +! +! $Id$ +! + SUBROUTINE inifis(ngrid,nlayer, + $ punjours, + $ pdayref,ptimestep, + $ plat,plon,parea, + $ prad,pg,pr,pcpp) + USE dimphy + IMPLICIT NONE +c +c======================================================================= +c +c subject: +c -------- +c +c Initialisation for the physical parametrisations of the LMD +c martian atmospheric general circulation modele. +c +c author: Frederic Hourdin 15 / 10 /93 +c ------- +c +c arguments: +c ---------- +c +c input: +c ------ +c +c ngrid Size of the horizontal grid. +c All internal loops are performed on that grid. +c nlayer Number of vertical layers. +c pdayref Day of reference for the simulation +c firstcall True at the first call +c lastcall True at the last call +c pday Number of days counted from the North. Spring +c equinoxe. +c +c======================================================================= +c +c----------------------------------------------------------------------- +c declarations: +c ------------- + +cym#include "dimensions.h" +cym#include "dimphy.h" + + INCLUDE 'iniprint.h' + REAL prad,pg,pr,pcpp,punjours + + INTEGER ngrid,nlayer + REAL plat(ngrid),plon(ngrid),parea(klon) + INTEGER pdayref + + REAL ptimestep + CHARACTER (LEN=20) :: modname='inifis' + CHARACTER (LEN=80) :: abort_message + + + IF (nlayer.NE.klev) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'nlayer = ',nlayer + PRINT*,'klev = ',klev + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + ENDIF + + IF (ngrid.NE.klon) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'ngrid = ',ngrid + PRINT*,'klon = ',klon + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + ENDIF + + RETURN +9999 continue + abort_message = 'Cette version demande les fichier rnatur.dat + & et surf.def' + CALL abort_gcm (modname,abort_message,1) + + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniorbit.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniorbit.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniorbit.F (revision 1634) @@ -0,0 +1,104 @@ + SUBROUTINE iniorbit + $ (paphelie,pperiheli,pyear_day,pperi_day,pobliq) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: +c ------- +c Frederic Hourdin 22 Fevrier 1991 +c +c Objet: +c ------ +c Initialisation du sous programme orbite qui calcule +c a une date donnee de l'annee de duree year_day commencant +c a l'equinoxe de printemps et dont le perihelie se situe +c a la date peri_day, la distance au soleil et la declinaison. +c +c Interface: +c ---------- +c - Doit etre appele avant d'utiliser orbite. +c - initialise une partie du common planete.h +c +c Arguments: +c ---------- +c +c Input: +c ------ +c aphelie \ aphelie et perihelie de l'orbite +c periheli / en millions de kilometres. +c +c======================================================================= + +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "planete.h" +#include "YOMCST.h" + +c Arguments: +c ---------- + + REAL paphelie,pperiheli,pyear_day,pperi_day,pobliq + +c Local: +c ------ + + REAL zxref,zanom,zz,zx0,zdx, pi + INTEGER iter + +c----------------------------------------------------------------------- + + pi=2.*asin(1.) + + aphelie =paphelie + periheli=pperiheli + year_day=pyear_day + obliquit=pobliq + peri_day=pperi_day + + PRINT*,'Perihelie en Mkm ',periheli + PRINT*,'Aphelie en Mkm ',aphelie + PRINT*,'obliquite en degres :',obliquit + PRINT*,'Jours dans l annee : ',year_day + PRINT*,'Date perihelie : ',peri_day + unitastr=149.597870 + e_elips=(aphelie-periheli)/(periheli+aphelie) + p_elips=0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr + + print*,'e_elips',e_elips + print*,'p_elips',p_elips + +c----------------------------------------------------------------------- +c calcul de l'angle polaire et de la distance au soleil : +c ------------------------------------------------------- + +c calcul de l'zanomalie moyenne + + zz=(year_day-pperi_day)/year_day + zanom=2.*pi*(zz-nint(zz)) + zxref=abs(zanom) + PRINT*,'zanom ',zanom + +c resolution de l'equation horaire zx0 - e * sin (zx0) = zxref +c methode de Newton + + zx0=zxref+R_ecc*sin(zxref) + DO 110 iter=1,100 + zdx=-(zx0-R_ecc*sin(zx0)-zxref)/(1.-R_ecc*cos(zx0)) + if(abs(zdx).le.(1.e-12)) goto 120 + zx0=zx0+zdx +110 continue +120 continue + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + PRINT*,'zx0 ',zx0 + +c zteta est la longitude solaire + + timeperi=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.)) + PRINT*,'longitude solaire du perihelie timeperi = ',timeperi + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniphysiq.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniphysiq.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniphysiq.F (revision 1634) @@ -0,0 +1,107 @@ +! +! $Id$ +! +c +c + SUBROUTINE iniphysiq(ngrid,nlayer, + $ punjours, + $ pdayref,ptimestep, + $ plat,plon,parea,pcu,pcv, + $ prad,pg,pr,pcpp) + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE comgeomphy + + IMPLICIT NONE +c +c======================================================================= +c +c subject: +c -------- +c +c Initialisation for the physical parametrisations of the LMD +c martian atmospheric general circulation modele. +c +c author: Frederic Hourdin 15 / 10 /93 +c ------- +c +c arguments: +c ---------- +c +c input: +c ------ +c +c ngrid Size of the horizontal grid. +c All internal loops are performed on that grid. +c nlayer Number of vertical layers. +c pdayref Day of reference for the simulation +c firstcall True at the first call +c lastcall True at the last call +c pday Number of days counted from the North. Spring +c equinoxe. +c +c======================================================================= +c +c----------------------------------------------------------------------- +c declarations: +c ------------- + +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "comgeomphy.h" +#include "YOMCST.h" + REAL prad,pg,pr,pcpp,punjours + + INTEGER ngrid,nlayer + REAL plat(ngrid),plon(ngrid),parea(klon_glo) + REAL pcu(klon_glo),pcv(klon_glo) + INTEGER pdayref + INTEGER :: ibegin,iend,offset + + REAL ptimestep + CHARACTER (LEN=20) :: modname='iniphysiq' + CHARACTER (LEN=80) :: abort_message + + IF (nlayer.NE.klev) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'nlayer = ',nlayer + PRINT*,'klev = ',klev + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + ENDIF + + IF (ngrid.NE.klon_glo) THEN + PRINT*,'STOP in inifis' + PRINT*,'Probleme de dimensions :' + PRINT*,'ngrid = ',ngrid + PRINT*,'klon = ',klon_glo + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + ENDIF +c$OMP PARALLEL PRIVATE(ibegin,iend) +c$OMP+ SHARED(parea,pcu,pcv,plon,plat) + + offset=klon_mpi_begin-1 + airephy(1:klon_omp)=parea(offset+klon_omp_begin: + & offset+klon_omp_end) + cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end) + cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end) + rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end) + rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end) + + call suphel + +c$OMP END PARALLEL + + print*,'ATTENTION !!! TRAVAILLER SUR INIPHYSIQ' + print*,'CONTROLE DES LATITUDES, LONGITUDES, PARAMETRES ...' + + RETURN +9999 CONTINUE + abort_message ='Cette version demande les fichier rnatur.dat + & et surf.def' + CALL abort_gcm (modname,abort_message,1) + + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniradia.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniradia.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iniradia.F (revision 1634) @@ -0,0 +1,32 @@ + SUBROUTINE iniradia (klon,klev,pres) + + IMPLICIT none +c====================================================================== +c +c Auteur(s) MP Lefebvre date: 20080827 +c +c Objet: initialise le rayonnement RRTM +c====================================================================== +c Arguments: +c +c klon----input-I-nombre de points horizontaux +c klev----input-I-nombre de couches verticales +c pres----input-R-pression pour chaque inter-couche (en Pa) +c====================================================================== +c + INTEGER klon + INTEGER klev + REAL pres(klev+1) + +! CALL suphel ! initialiser constantes et parametres phys. +! print*,'Physiq: apres suphel ' +! CALL SUINIT(klon,klev) +! print*,'iniradia: apres suinit ' +! calcul des niveaux de pression de reference au bord des couches pour +! l'intialisation des aerosols. Momentannement, on passe un point de +! grille du profil de pression. +! CALL SURAYOLMD(pres(klev+1)) ! initialiser le rayonnement RRTM +! print*,'iniradia: apres surayolmd ' + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/inistats.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/inistats.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/inistats.F (revision 1634) @@ -0,0 +1,133 @@ + subroutine inistats(ierr) + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comvert.h" +#include "comconst.h" +#include "statto.h" +#include "netcdf.inc" + + integer,intent(out) :: ierr + integer :: nid + integer :: l,nsteppd + real, dimension(llm) :: sig_s + integer :: idim_lat,idim_lon,idim_llm,idim_llmp1,idim_time + real, dimension(istime) :: lt + integer :: nvarid + real, dimension(llm) :: pseudoalt + + write (*,*) + write (*,*) ' || STATS ||' + write (*,*) + write (*,*) 'daysec',daysec + write (*,*) 'dtphys',dtphys + nsteppd=nint(daysec/dtphys) + write (*,*) 'nsteppd=',nsteppd + if (abs(float(nsteppd)-daysec/dtphys).gt.1.e-8*daysec) + & stop'Dans Instat: 1jour .ne. n pas physiques' + + if(mod(nsteppd,istime).ne.0) + & stop'Dans Instat: 1jour .ne. n*istime pas physiques' + + istats=nsteppd/istime + write (*,*) 'istats=',istats + write (*,*) 'Storing ',istime,'times per day' + write (*,*) 'thus every ',istats,'physical timestep ' + write (*,*) + + do l= 1, llm + sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2. + pseudoalt(l)=log(preff/presnivs(l))*8. + enddo + + ierr = NF_CREATE("stats.nc",NF_CLOBBER,nid) + if (ierr.ne.NF_NOERR) then + write (*,*) NF_STRERROR(ierr) + stop "" + endif + + ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_lat) + ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_lon) + ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm) + ierr = NF_DEF_DIM (nid, "llmp1", llm+1, idim_llmp1) + ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_time) + + ierr = NF_ENDDEF(nid) + call def_var_stats(nid,"Time","Time", + & "hours since 0000-00-0 00:00:00",1, + & idim_time,nvarid,ierr) +! Time is initialised later by mkstats subroutine + + call def_var_stats(nid,"latitude","latitude", + & "degrees_north",1,idim_lat,nvarid,ierr) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180) +#endif + call def_var_stats(nid,"longitude","East longitude", + & "degrees_east",1,idim_lon,nvarid,ierr) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180) +#endif + +! Niveaux verticaux, aps et bps + ierr = NF_REDEF (nid) +! presnivs +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs", NF_DOUBLE, 1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs", NF_FLOAT, 1,idim_llm,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",15, + & "Vertical levels") + ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"Pa") + ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',4,"down") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid, + & presnivs(1:llm)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid, + & presnivs(1:llm)) +#endif +! Pseudo alts +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"altitude", NF_DOUBLE, 1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"altitude", NF_FLOAT, 1,idim_llm,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",8,"altitude") + ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km") + ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt) +#endif +! call def_var_stats(nid,"aps","hybrid pressure at midlayers"," ", +! & 1,idim_llm,nvarid,ierr) +!#ifdef NC_DOUBLE +! ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps) +!#else +! ierr = NF_PUT_VAR_REAL (nid,nvarid,aps) +!#endif + +! call def_var_stats(nid,"bps","hybrid sigma at midlayers"," ", +! & 1,idim_llm,nvarid,ierr) +!#ifdef NC_DOUBLE +! ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps) +!#else +! ierr = NF_PUT_VAR_REAL (nid,nvarid,bps) +!#endif + + ierr=NF_CLOSE(nid) + + end subroutine inistats + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/init_be.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/init_be.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/init_be.F90 (revision 1634) @@ -0,0 +1,510 @@ +!$Id $ + +SUBROUTINE init_be(pctsrf,masktr,tautr,vdeptr,scavtr,srcbe) + + USE dimphy + USE comgeomphy + USE infotrac, ONLY : nbtr + + IMPLICIT NONE +!===================================================================== +! Objet : prescription d'une source de Beryllium 7 +! pour 19 niveaux verticaux +! (d'apres le diagramme de Lal and Peters, 1967) +! +! +! written by : O. Coindreau (CEA/LDG) 05/2005 +! last modified by : A. Jamelot (LMD/CEA) 04/03/2009 +!===================================================================== + + INCLUDE "YOMCST.h" + INCLUDE "YOECUMF.h" + INCLUDE "indicesol.h" + +! +! Input Arguments +! + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf !Pourcentage de sol (f(nature du sol)) +! +! Output Arguments +! + REAL,DIMENSION(klon),INTENT(OUT) :: masktr ! Masque de l'echange avec la surface (possible => 1 ) + REAL,INTENT(OUT) :: tautr ! Constante de decroissance radioactive + REAL,INTENT(OUT) :: vdeptr ! Vitesse de depot sec dans la couche Brownienne + REAL,INTENT(OUT) :: scavtr ! Coefficient de lessivage + REAL,DIMENSION(klon,klev),INTENT(OUT) :: srcbe ! source volumique de 7Be +! +! Local Variables +! + REAL,DIMENSION(klon) :: rlatgeo ! latitudes geomagnetiques de la grille + REAL :: glt ! latitude du pole geomagnetique + REAL :: glg ! longitude du pole geomagnetique + REAL :: latgeo,qcos + INTEGER :: k,i + + WRITE(*,*)'PASSAGE init_be ...' + +! Source actuellement definie pour klev = 19 et klev >= 39 + IF (klev /= 19 .AND. klev<39) CALL abort_gcm("init_be","Source du be7 necessite klev=19 ou klev>=39",1) +! +! Definition des constantes +! ------------------------- + tautr = 6645000. + vdeptr = 1.E-3 + scavtr = 0.5 + + WRITE(*,*) '-------------- SOURCE DE BERYLLIUM ------------------- ' + WRITE(*,*)'Decroissance (s): ', tautr + WRITE(*,*)'Vitesse de depot sec: ',vdeptr + WRITE(*,*)'Facteur de lessivage: ',scavtr + + DO i = 1,klon + masktr(i) = 0. + IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i) = 1. + END DO + +! Premiers niveaux: source nulle +! ------------------------------ + DO k = 1,6 + DO i = 1,klon + srcbe(i,k) = 0. + END DO + END DO +! +! Pour les autres niveaux: +! 1-passer des coordonnees geographiques a la latitude geomagnetique +! 2-prescrire la source de Be (en 10exp5 at/g/s) dans ce repere +! 3-mettre la source de Be ds la bonne unite (en at/kgA/s) +! + glt=78.5*rpi/180. + glg=69.0*rpi/180. + + DO i = 1,klon + qcos=sin(glt)*sin(rlatd(i)) + qcos=qcos+cos(glt)*cos(rlatd(i))*cos(rlond(i)+glg) + IF ( qcos .LT. -1.) qcos = -1. + IF ( qcos .GT. 1.) qcos = 1. + rlatgeo(i)=rpi/2.-acos(qcos) + ENDDO + +!=========================== +! Cas 19 niveaux verticaux +!=========================== + IF (klev.eq.19) then + DO k = 1,klev + DO i = 1,klon + latgeo=(180./rpi)*abs(rlatgeo(i)) + IF ( k .EQ. 1 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.1 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 2 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.12 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.1 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.09 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 3 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.14 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 4 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.175 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09 + END IF + IF ( k .EQ. 5 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.28 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.26 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.23 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.175 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.14 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12 + END IF + IF ( k .EQ. 6 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.56 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.49 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.42 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.28 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.26 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.245 + END IF + IF ( k .EQ. 7 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=1.05 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.875 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.7 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.52 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.44 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.385 + END IF + IF ( k .EQ. 8 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=2. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.8 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.8 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.75 + END IF + IF ( k .EQ. 9 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=4. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=3. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.8 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4 + END IF + IF ( k .EQ. 10 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=8.5 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3. + END IF + IF ( k .EQ. 11 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=17. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=15. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=11. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=8. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=5. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4. + END IF + IF ( k .EQ. 12 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=25. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + IF ( k .EQ. 13 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=33. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=32. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8. + END IF + IF ( k .EQ. 14 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=48. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=26. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=17.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 15 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=58. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=57. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=38. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 16 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=70. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=65. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.5 + END IF + IF ( k .GE. 17 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=80. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + END DO + END DO + END IF ! fin de 19 niveaux verticaux + +!================================ +! Cas 39 niveaux verticaux +!================================ + IF (klev .ge. 39) then + DO k = 1,klev + DO i = 1,klon + latgeo=(180./rpi)*abs(rlatgeo(i)) + IF ( k .LE. 4 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 5 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.1 + IF (latgeo.GE.20.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 6 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.14 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07 + END IF + IF ( k .EQ. 7 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09 + END IF + IF ( k .EQ. 8 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.175 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.1 + END IF + IF ( k .EQ. 9 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.245 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.21 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.175 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.14 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.12 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12 + END IF + IF ( k .EQ. 10 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.31 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.28 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.245 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.21 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.16 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.14 + END IF + IF ( k .EQ. 11 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.35 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.3 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.3 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.2 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.18 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.16 + END IF + IF ( k .EQ. 12 ) THEN + IF (latgeo.GE.40.0) srcbe(i,k)=0.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.4 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.35 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.3 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.25 + END IF + IF ( k .EQ. 13 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=0.8 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.7 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.6 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.4 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.35 + END IF + IF ( k .EQ. 14 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=1.2 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.75 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.6 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.4 + END IF + IF ( k .EQ. 15 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=1.75 + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=1.8 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.6 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.4 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.9 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.75 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.65 + END IF + IF ( k .EQ. 16 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=3. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=2.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.8 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.2 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.9 + END IF + IF ( k .EQ. 17 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=4. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=2.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.6 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4 + END IF + IF ( k .EQ. 18 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=7. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=6. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=4.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=3.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=2. + END IF + IF ( k .EQ. 19 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=8.5 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3. + END IF + IF ( k .EQ. 20 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=12.5 + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=12. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=8. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=6. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.5 + END IF + IF ( k .EQ. 21 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=16. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=13. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=10. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=7.5 + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4. + END IF + IF ( k .EQ. 22 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=20. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=17.5 + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=12.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=9. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=6. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.5 + END IF + IF ( k .EQ. 23 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=25. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6. + END IF + IF ( k .EQ. 24 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=28. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=26. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=18. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + IF ( k .EQ. 25 ) THEN + IF (latgeo.GE.50.0) srcbe(i,k)=33. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=28. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.5 + END IF + IF ( k .EQ. 26 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=38. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=36. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6. + END IF + IF ( k .EQ. 27 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=46. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=44. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 28 ) THEN + IF (latgeo.GE.60.0) srcbe(i,k)=53. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=37. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 29 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=58. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=56. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10. + END IF + IF ( k .EQ. 30 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=65. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=9. + END IF + IF ( k .EQ. 31 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=70. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=62. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=21. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.6 + END IF + IF ( k .EQ. 32 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=80. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=46. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5 + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8. + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.4 + END IF + IF ( k .GE. 33 ) THEN + IF (latgeo.GE.70.0) srcbe(i,k)=80. + IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70. + IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45. + IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27. + IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15. + IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10. + IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.6 + IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7. + END IF + END DO + END DO + END IF ! fin de 39 niveaux verticaux + + +!==================================== +! Conversion de la source en U/s/kgA +!==================================== + DO k = 1,klev + DO i = 1,klon + ! La source est at/min/m3 -> at/s/kgA + ! avec une masse volumique de l'air = 1.295 kg/m3 + ! 1/(60*1.295) = 0.01287 + srcbe(i,k)=srcbe(i,k)*0.01287 + ! La source est at/min/m3 -> at/s/m3 + ! srcbe(i,k)=srcbe(i,k)*0.0166667 + END DO + END DO + +END SUBROUTINE init_be Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/init_phys_lmdz.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/init_phys_lmdz.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/init_phys_lmdz.F90 (revision 1634) @@ -0,0 +1,23 @@ +! +!$Header$ +! +SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nb_proc,distrib) + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE dimphy, ONLY : Init_dimphy + IMPLICIT NONE + + INTEGER,INTENT(in) :: iim + INTEGER,INTENT(in) :: jjp1 + INTEGER,INTENT(in) :: llm + INTEGER,INTENT(in) :: nb_proc + INTEGER,INTENT(in) :: distrib(0:nb_proc-1) + + + CALL Init_grid_phy_lmdz(iim,jjp1,llm) + CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib) +!$OMP PARALLEL + CALL Init_dimphy(klon_omp,nbp_lev) +!$OMP END PARALLEL + +END SUBROUTINE Init_Phys_lmdz Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/initphysto.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/initphysto.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/initphysto.F90 (revision 1634) @@ -0,0 +1,216 @@ +! +! $Id$ +! +SUBROUTINE initphysto(infile,tstep,t_ops,t_wrt,fileid) + + USE dimphy + USE mod_phys_lmdz_para + USE IOIPSL + USE iophy + USE control_mod + + IMPLICIT NONE + +! +! Routine d'initialisation des ecritures des fichiers histoires LMDZ +! au format IOIPSL +! +! Appels succesifs des routines: histbeg +! histhori +! histver +! histdef +! histend +! +! Entree: +! +! infile: nom du fichier histoire a creer +! day0,anne0: date de reference +! tstep: duree du pas de temps en seconde +! t_ops: frequence de l'operation pour IOIPSL +! t_wrt: frequence d'ecriture sur le fichier +! +! Sortie: +! fileid: ID du fichier netcdf cree +! +! L. Fairhead, LMD, 03/99 +! +! ===================================================================== +! +! Declarations + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comgeom.h" + INCLUDE "temps.h" + INCLUDE "logic.h" + INCLUDE "description.h" + INCLUDE "serre.h" + INCLUDE "indicesol.h" + +! Arguments + CHARACTER(len=*), INTENT(IN) :: infile + REAL, INTENT(IN) :: tstep + REAL, INTENT(IN) :: t_ops + REAL, INTENT(IN) :: t_wrt + INTEGER, INTENT(OUT) :: fileid + +! Variables locales + INTEGER nhoriid, i + INTEGER l,k + REAL nivsigs(llm) + INTEGER tau0 + REAL zjulian + INTEGER iq + INTEGER uhoriid, vhoriid, thoriid, zvertiid + INTEGER ii,jj + INTEGER zan, idayref + LOGICAL ok_sync + REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1) + CHARACTER(len=12) :: nvar + +! Initialisations +! + pi = 4. * ATAN (1.) + ok_sync= .TRUE. +! +! Appel a histbeg: creation du fichier netcdf et initialisations diverses +! + + zan = annee_ref + idayref = day_ref + CALL ymds2ju(zan, 1, idayref, 0.0, zjulian) + tau0 = 0 + + CALL histbeg_phy(infile,tau0, zjulian, tstep, & + nhoriid, fileid) + +!$OMP MASTER +! Appel a histvert pour la grille verticale +! + DO l=1,llm + nivsigs(l)=REAL(l) + ENDDO + + CALL histvert(fileid, 'sig_s', 'Niveaux sigma', & + 'sigma_level', & + llm, nivsigs, zvertiid) +! +! Appels a histdef pour la definition des variables a sauvegarder +! + CALL histdef(fileid, "phis", "Surface geop. height", "-", & + iim,jj_nb,nhoriid, 1,1,1, -99, 32, & + "once", t_ops, t_wrt) + + CALL histdef(fileid, "aire", "Grid area", "-", & + iim,jj_nb,nhoriid, 1,1,1, -99, 32, & + "once", t_ops, t_wrt) + + CALL histdef(fileid, "longitudes", "longitudes", "-", & + iim,jj_nb,nhoriid, 1,1,1, -99, 32, & + "once", t_ops, t_wrt) + + CALL histdef(fileid, "latitudes", "latitudes", "-", & + iim,jj_nb,nhoriid, 1,1,1, -99, 32, & + "once", t_ops, t_wrt) +! T + CALL histdef(fileid, 't', 'Temperature', 'K', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) +! mfu + CALL histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt) +! mfd + CALL histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) +! en_u + CALL histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt) +! de_u + CALL histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt) +! en_d + CALL histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt) +! de_d + CALL histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) +! coefh + CALL histdef(fileid, "coefh", " ", " ", iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, "inst(X)", t_ops, t_wrt) +! fm_th + CALL histdef(fileid, "fm_th", " ", " ",iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, "inst(X)", t_ops, t_wrt) +! en_th + CALL histdef(fileid, "en_th", " ", " ",iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, "inst(X)", t_ops, t_wrt) +! frac_impa + CALL histdef(fileid, 'frac_impa', ' ', ' ',iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt) +! frac_nucl + CALL histdef(fileid, 'frac_nucl', ' ', ' ',iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt) +! pyu1 + CALL histdef(fileid, "pyu1", " ", " ", iim,jj_nb,nhoriid, & + 1,1,1, -99, 32, "inst(X)", t_ops, t_wrt) +! pyv1 + CALL histdef(fileid, "pyv1", " ", " ", iim,jj_nb,nhoriid, & + 1,1,1, -99, 32,"inst(X)", t_ops, t_wrt) +! ftsol1 + CALL histdef(fileid, "ftsol1", " ", " ",iim, jj_nb, nhoriid, & + 1, 1,1, -99,32, "inst(X)", t_ops, t_wrt) +! ftsol2 + CALL histdef(fileid, "ftsol2", " ", " ",iim, jj_nb, nhoriid, & + 1, 1,1, -99,32, "inst(X)", t_ops, t_wrt) +! ftsol3 + CALL histdef(fileid, "ftsol3", " ", " ", iim, jj_nb, nhoriid, & + 1, 1,1, -99,32, "inst(X)", t_ops, t_wrt) +! ftsol4 + CALL histdef(fileid, "ftsol4", " ", " ",iim, jj_nb, nhoriid, & + 1, 1,1, -99, 32, "inst(X)", t_ops, t_wrt) +! psrf1 + CALL histdef(fileid, "psrf1", " ", " ",iim, jj_nb, nhoriid, & + 1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt) +! psrf2 + CALL histdef(fileid, "psrf2", " ", " ",iim, jj_nb, nhoriid, & + 1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt) +! psrf3 + CALL histdef(fileid, "psrf3", " ", " ",iim, jj_nb, nhoriid, & + 1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt) +! psrf4 + CALL histdef(fileid, "psrf4", " ", " ", iim, jj_nb, nhoriid, & + 1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt) +! sh + CALL histdef(fileid, 'sh', '', '', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) +! da + CALL histdef(fileid, 'da', '', '', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) +! mp + CALL histdef(fileid, 'mp', '', '', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) +! upwd + CALL histdef(fileid, 'upwd', '', '', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) +! dnwd + CALL histdef(fileid, 'dnwd', '', '', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) + +! phi + DO k=1,llm + IF (k<10) THEN + WRITE(nvar,'(i1)') k + ELSE IF (k<100) THEN + WRITE(nvar,'(i2)') k + ELSE + WRITE(nvar,'(i3)') k + END IF + nvar='phi_lev'//trim(nvar) + + CALL histdef(fileid, nvar, '', '', iim, jj_nb, nhoriid, & + llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt) + END DO + + CALL histend(fileid) + IF (ok_sync) CALL histsync +!$OMP END MASTER + +END SUBROUTINE initphysto Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/initrrnpb.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/initrrnpb.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/initrrnpb.F90 (revision 1634) @@ -0,0 +1,96 @@ +! +! $Id$ +! +SUBROUTINE initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr) + USE dimphy + USE infotrac, ONLY : nbtr + USE traclmdz_mod, ONLY : id_rn, id_pb + IMPLICIT NONE +!====================================================================== +! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94 +! Objet: initialisation des constantes des traceurs +! id_rn : identificateur du traceur radon +! id_pb : identificateur du traceur plomb +!====================================================================== +! Arguments: +! nbtr.............. nombre de vrais traceurs (sans l'eau) +! ftsol....input-R- Temperature du sol (Kelvin) +! pctsrf...input-R- Nature de sol (pourcentage de sol) +! masktr...output-R- Masque reservoir de sol traceur (1 = reservoir) +! fshtr....output-R- Flux surfacique de production dans le reservoir de sol +! hsoltr...output-R- Epaisseur equivalente du reservoir de sol +! tautr....output-R- Constante de decroissance radioactive du traceur +! vdeptr...output-R- Vitesse de depot sec dans la couche Brownienne +! scavtr...output-R- Coefficient de lessivage +!====================================================================== + INCLUDE "indicesol.h" +!====================================================================== + + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol + REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: masktr + REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: fshtr + REAL,DIMENSION(nbtr),INTENT(OUT) :: hsoltr + REAL,DIMENSION(nbtr),INTENT(OUT) :: tautr + REAL,DIMENSION(nbtr),INTENT(OUT) :: vdeptr + REAL,DIMENSION(nbtr),INTENT(OUT) :: scavtr + INTEGER :: i, it + REAL :: s + + CHARACTER (LEN=20) :: modname='initrrnpb' + CHARACTER (LEN=80) :: abort_message + +! +! Radon it = id_rn +!---------------- + IF (id_rn /= 0) THEN + it = id_rn + s = 1.E4 ! Source: atome par m2 + hsoltr(it) = 0.1 ! Hauteur equivalente du reservoir : + ! 1 m * porosite 0.1 + tautr(it) = 4.765E5 ! Decroissance du radon, secondes + vdeptr(it) = 0. ! Pas de depot sec pour le radon + scavtr(it) = 0. ! Pas de lessivage pour le radon + + WRITE(*,*)'-------------- SOURCE DU RADON ------------------------ ' + WRITE(*,*)'it = ',it + WRITE(*,*)'Source : ', s + WRITE(*,*)'Hauteur equivalente du reservoir de sol: ',hsoltr(it) + WRITE(*,*)'Decroissance (s): ', tautr(it) + WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) + WRITE(*,*)'Facteur de lessivage: ',scavtr(it) + + DO i = 1,klon + masktr(i,it) = 0. + IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1. + fshtr(i,it) = s * masktr(i,it) + END DO + + END IF ! id_rn /= 0 + +! +! 210Pb it = id_pb +!---------------- + IF (id_pb /= 0) THEN + it = id_pb + s = 0. ! Pas de source + hsoltr(it) = 10. ! Hauteur equivalente du reservoir + ! a partir duquel le depot Brownien a lieu + tautr(it) = 1.028E9 ! Decroissance du Pb210, secondes + vdeptr(it) = 1.E-3 ! 1 mm/s pour le 210Pb + scavtr(it) = .5 ! Lessivage du Pb210 + DO i = 1,klon + masktr(i,it) = 1. ! Le depot sec peut avoir lieu partout + fshtr(i,it) = s * masktr(i,it) + END DO + WRITE(*,*)'-------------- SOURCE DU PLOMB ------------------------ ' + WRITE(*,*)'it = ',it + WRITE(*,*)'Source : ', s + WRITE(*,*)'Hauteur equivalente du reservoir : ',hsoltr(it) + WRITE(*,*)'Decroissance (s): ', tautr(it) + WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) + WRITE(*,*)'Facteur de lessivage: ',scavtr(it) + + END IF + +END SUBROUTINE initrrnpb Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/interfoce_lim.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/interfoce_lim.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/interfoce_lim.F90 (revision 1634) @@ -0,0 +1,289 @@ +! +! $Header$ +! +SUBROUTINE interfoce_lim(itime, dtime, jour, & + knon, knindex, & + debut, & + lmt_sst_p, pctsrf_new_p) + + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "netcdf.inc" + +! Cette routine sert d'interface entre le modele atmospherique et un fichier +! de conditions aux limites +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps courant +! dtime pas de temps de la physique (en s) +! jour jour a lire dans l'annee +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points dans le domaine a traiter +! knindex index des points de la surface a traiter +! klon taille de la grille +! debut logical: 1er appel a la physique (initialisation) +! +! output: +! lmt_sst_p SST lues dans le fichier de CL +! pctsrf_new-p sous-maille fractionnelle +! + + +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: jour + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon_loc), INTENT(IN) :: knindex + REAL , INTENT(IN) :: dtime + LOGICAL, INTENT(IN) :: debut + +! Parametres de sortie +!**************************************************************************************** + REAL, INTENT(OUT), DIMENSION(klon_loc) :: lmt_sst_p + REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p + + +! Variables locales avec l'attribut SAVE +!**************************************************************************************** +! frequence de lecture des conditions limites (en pas de physique) + INTEGER,SAVE :: lmt_pas + !$OMP THREADPRIVATE(lmt_pas) +! pour indiquer que le jour a lire est deja lu pour une surface precedente + LOGICAL,SAVE :: deja_lu + !$OMP THREADPRIVATE(deja_lu) + INTEGER,SAVE :: jour_lu + !$OMP THREADPRIVATE(jour_lu) + CHARACTER (len = 20),SAVE :: fich ='limit.nc' + !$OMP THREADPRIVATE(fich) + LOGICAL, SAVE :: newlmt = .TRUE. + !$OMP THREADPRIVATE(newlmt) + LOGICAL, SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + REAL, ALLOCATABLE , SAVE, DIMENSION(:) :: sst_lu_p + !$OMP THREADPRIVATE(sst_lu_p) + REAL, ALLOCATABLE , SAVE, DIMENSION(:,:) :: pct_tmp_p + !$OMP THREADPRIVATE(pct_tmp_p) + +! Variables locales +!**************************************************************************************** + INTEGER :: nid, nvarid + INTEGER :: ii + INTEGER :: ierr + INTEGER, DIMENSION(2) :: start, epais + CHARACTER (len = 20) :: modname = 'interfoce_lim' + CHARACTER (len = 80) :: abort_message + REAL, DIMENSION(klon_glo,nbsrf) :: pctsrf_new + REAL, DIMENSION(klon_glo,nbsrf) :: pct_tmp + REAL, DIMENSION(klon_glo) :: sst_lu + REAL, DIMENSION(klon_glo) :: nat_lu +! +! Fin declaration +!**************************************************************************************** + +!**************************************************************************************** +! Start calculation +! +!**************************************************************************************** + IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN + lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour + jour_lu = jour - 1 + ALLOCATE(sst_lu_p(klon_loc)) + ALLOCATE(pct_tmp_p(klon_loc,nbsrf)) + ENDIF + + IF ((jour - jour_lu) /= 0) deja_lu = .FALSE. + + IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu + IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime + +!**************************************************************************************** +! Ouverture et lecture du fichier pour le master process si c'est le bon moment +! +!**************************************************************************************** +! Tester d'abord si c'est le moment de lire le fichier + IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN + +!$OMP MASTER + IF (is_mpi_root) THEN + + fich = TRIM(fich) + ierr = NF_OPEN (fich, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + abort_message = 'Pb d''ouverture du fichier de conditions aux limites' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + ! La tranche de donnees a lire: + + start(1) = 1 + start(2) = jour + epais(1) = klon_glo + epais(2) = 1 + + IF (newlmt) THEN + ! + ! Fraction "ocean" + ! + ierr = NF_INQ_VARID(nid, 'FOCE', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ! Fraction "glace de mer" + ! + ierr = NF_INQ_VARID(nid, 'FSIC', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ! Fraction "terre" + ! + ierr = NF_INQ_VARID(nid, 'FTER', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ! Fraction "glacier terre" + ! + ierr = NF_INQ_VARID(nid, 'FLIC', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic)) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic)) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ! + ELSE ! on en est toujours a rnatur + ! + ierr = NF_INQ_VARID(nid, 'NAT', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF +! +! Remplissage des fractions de surface +! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice +! + pct_tmp = 0.0 + DO ii = 1, klon_glo + pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1. + ENDDO + +! +! On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire +! + pctsrf_new = pct_tmp + pctsrf_new (:,2)= pct_tmp (:,1) + pctsrf_new (:,1)= pct_tmp (:,2) + pct_tmp = pctsrf_new + ENDIF ! fin test sur newlmt +! +! Lecture SST +! + ierr = NF_INQ_VARID(nid, 'SST', nvarid) + IF (ierr /= NF_NOERR) THEN + abort_message = 'Le champ est absent' + CALL abort_gcm(modname,abort_message,1) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu) +#else + ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu) +#endif + IF (ierr /= NF_NOERR) THEN + abort_message = 'Lecture echouee pour ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + +!**************************************************************************************** +! Fin de lecture, fermeture de fichier +! +!**************************************************************************************** + ierr = NF_CLOSE(nid) + ENDIF ! is_mpi_root + +!$OMP END MASTER +!$OMP BARRIER + + +!**************************************************************************************** +! Distribue les variables sur tous les processus +! +!**************************************************************************************** + CALL Scatter(sst_lu,sst_lu_p) + CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce)) + CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic)) + deja_lu = .TRUE. + jour_lu = jour + ENDIF + +!**************************************************************************************** +! Recopie des variables dans les champs de sortie +! +!**************************************************************************************** + lmt_sst_p = 999999999. + + DO ii = 1, knon + lmt_sst_p(ii) = sst_lu_p(knindex(ii)) + ENDDO + + DO ii=1,klon_loc + pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce) + pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic) + ENDDO + + +END SUBROUTINE interfoce_lim Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iophy.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iophy.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iophy.F90 (revision 1634) @@ -0,0 +1,444 @@ +! +! $Header$ +! +module iophy + +! abd REAL,private,allocatable,dimension(:),save :: io_lat +! abd REAL,private,allocatable,dimension(:),save :: io_lon + REAL,allocatable,dimension(:),save :: io_lat + REAL,allocatable,dimension(:),save :: io_lon + INTEGER, save :: phys_domain_id + INTEGER, save :: npstn + INTEGER, allocatable, dimension(:), save :: nptabij + + INTERFACE histwrite_phy + MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy + END INTERFACE + + INTERFACE histbeg_phy_all + MODULE PROCEDURE histbeg_phy,histbeg_phy_points + END INTERFACE + + +contains + + subroutine init_iophy_new(rlat,rlon) + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE ioipsl + implicit none + include 'dimensions.h' + real,dimension(klon),intent(in) :: rlon + real,dimension(klon),intent(in) :: rlat + + REAL,dimension(klon_glo) :: rlat_glo + REAL,dimension(klon_glo) :: rlon_glo + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + INTEGER :: i + + CALL gather(rlat,rlat_glo) + CALL bcast(rlat_glo) + CALL gather(rlon,rlon_glo) + CALL bcast(rlon_glo) + +!$OMP MASTER + ALLOCATE(io_lat(jjm+1-1/iim)) + io_lat(1)=rlat_glo(1) + io_lat(jjm+1-1/iim)=rlat_glo(klon_glo) + IF (iim > 1) then + DO i=2,jjm + io_lat(i)=rlat_glo(2+(i-2)*iim) + ENDDO + ENDIF + + ALLOCATE(io_lon(iim)) + io_lon(:)=rlon_glo(2-1/iim:iim+1-1/iim) + + ddid=(/ 1,2 /) + dsg=(/ iim, jjm+1-1/iim /) + dsl=(/ iim, jj_nb /) + dpf=(/ 1,jj_begin /) + dpl=(/ iim, jj_end /) + dhs=(/ ii_begin-1,0 /) + if (mpi_rank==mpi_size-1) then + dhe=(/0,0/) + else + dhe=(/ iim-ii_end,0 /) + endif + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & + 'APPLE',phys_domain_id) + +!$OMP END MASTER + + end subroutine init_iophy_new + + subroutine init_iophy(lat,lon) + USE dimphy + USE mod_phys_lmdz_para + use ioipsl + implicit none + include 'dimensions.h' + real,dimension(iim),intent(in) :: lon + real,dimension(jjm+1-1/iim),intent(in) :: lat + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + +!$OMP MASTER + allocate(io_lat(jjm+1-1/iim)) + io_lat(:)=lat(:) + allocate(io_lon(iim)) + io_lon(:)=lon(:) + + ddid=(/ 1,2 /) + dsg=(/ iim, jjm+1-1/iim /) + dsl=(/ iim, jj_nb /) + dpf=(/ 1,jj_begin /) + dpl=(/ iim, jj_end /) + dhs=(/ ii_begin-1,0 /) + if (mpi_rank==mpi_size-1) then + dhe=(/0,0/) + else + dhe=(/ iim-ii_end,0 /) + endif + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, & + 'APPLE',phys_domain_id) + +!$OMP END MASTER + + end subroutine init_iophy + + subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day) + USE dimphy + USE mod_phys_lmdz_para + use ioipsl + use write_field + implicit none + include 'dimensions.h' + + character*(*), intent(IN) :: name + integer, intent(in) :: itau0 + real,intent(in) :: zjulian + real,intent(in) :: dtime + integer,intent(out) :: nhori + integer,intent(out) :: nid_day + +!$OMP MASTER + if (is_sequential) then + call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), & + 1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day) + else + call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), & + 1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id) + endif +!$OMP END MASTER + + end subroutine histbeg_phy + + subroutine histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, & + plon,plat,plon_bounds,plat_bounds, & + nname,itau0,zjulian,dtime,nnhori,nnid_day) + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + use ioipsl + use write_field + implicit none + include 'dimensions.h' + + real,dimension(klon),intent(in) :: rlon + real,dimension(klon),intent(in) :: rlat + integer, intent(in) :: itau0 + real,intent(in) :: zjulian + real,intent(in) :: dtime + integer, intent(in) :: pim + integer, intent(out) :: nnhori + character(len=20), intent(in) :: nname + INTEGER, intent(out) :: nnid_day + integer :: i + REAL,dimension(klon_glo) :: rlat_glo + REAL,dimension(klon_glo) :: rlon_glo + INTEGER, DIMENSION(pim), intent(in) :: tabij + REAL,dimension(pim), intent(in) :: plat, plon + INTEGER,dimension(pim), intent(in) :: ipt, jpt + REAL,dimension(pim,2), intent(out) :: plat_bounds, plon_bounds + + INTEGER, SAVE :: tabprocbeg, tabprocend +!$OMP THREADPRIVATE(tabprocbeg, tabprocend) + INTEGER :: ip + INTEGER, PARAMETER :: nip=1 + INTEGER :: npproc + REAL, allocatable, dimension(:) :: npplat, npplon + REAL, allocatable, dimension(:,:) :: npplat_bounds, npplon_bounds + INTEGER, PARAMETER :: jjmp1=jjm+1-1/jjm + REAL, dimension(iim,jjmp1) :: zx_lon, zx_lat + + CALL gather(rlat,rlat_glo) + CALL bcast(rlat_glo) + CALL gather(rlon,rlon_glo) + CALL bcast(rlon_glo) + +!$OMP MASTER + DO i=1,pim + +! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i) + + plon_bounds(i,1)=rlon_glo(tabij(i)-1) + plon_bounds(i,2)=rlon_glo(tabij(i)+1) + if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN + if(rlon_glo(tabij(i)).GE.0.) THEN + plon_bounds(i,2)=-1*plon_bounds(i,2) + endif + endif + if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN + if(rlon_glo(tabij(i)).LE.0.) THEN + plon_bounds(i,2)=-1*plon_bounds(i,2) + endif + endif +! + IF ( tabij(i).LE.iim) THEN + plat_bounds(i,1)=rlat_glo(tabij(i)) + ELSE + plat_bounds(i,1)=rlat_glo(tabij(i)-iim) + ENDIF + plat_bounds(i,2)=rlat_glo(tabij(i)+iim) +! +! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2) +! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2) +! + ENDDO + if (is_sequential) then + + npstn=pim + IF(.NOT. ALLOCATED(nptabij)) THEN + ALLOCATE(nptabij(pim)) + ENDIF + DO i=1,pim + nptabij(i)=tabij(i) + ENDDO + + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon) + if (iim.gt.1) then + DO i = 1, iim + zx_lon(i,1) = rlon_glo(i+1) + zx_lon(i,jjmp1) = rlon_glo(i+1) + ENDDO + endif + CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat) + + DO i=1,pim +! print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i) + + plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i)) + plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i)) + + if (ipt(i).EQ.1) then + plon_bounds(i,1)=zx_lon(iim,jpt(i)) + plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i)) + endif + + if (ipt(i).EQ.iim) then + plon_bounds(i,2)=360.+zx_lon(1,jpt(i)) + endif + + plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1) + plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1) + + if (jpt(i).EQ.1) then + plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001 + plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001 + endif + + if (jpt(i).EQ.jjmp1) then + plat_bounds(i,1)=zx_lat(ipt(i),jjmp1)+0.001 + plat_bounds(i,2)=zx_lat(ipt(i),jjmp1)-0.001 + endif +! +! print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2) +! print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2) +! + ENDDO +! print*,'iophy is_sequential nname, nnhori, nnid_day=',trim(nname),nnhori,nnid_day + call histbeg(nname,pim,plon,plon_bounds, & + plat,plat_bounds, & + itau0, zjulian, dtime, nnhori, nnid_day) + else + npproc=0 + DO ip=1, pim + tabprocbeg=klon_mpi_begin + tabprocend=klon_mpi_end + IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN + npproc=npproc+1 + npstn=npproc + ENDIF + ENDDO +! print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn + IF(.NOT. ALLOCATED(nptabij)) THEN + ALLOCATE(nptabij(npstn)) + ALLOCATE(npplon(npstn), npplat(npstn)) + ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2)) + ENDIF + npproc=0 + DO ip=1, pim + IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN + npproc=npproc+1 + nptabij(npproc)=tabij(ip) +! print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, & +! plon(ip),plat(ip),tabij(ip) + npplon(npproc)=plon(ip) + npplat(npproc)=plat(ip) + npplon_bounds(npproc,1)=plon_bounds(ip,1) + npplon_bounds(npproc,2)=plon_bounds(ip,2) + npplat_bounds(npproc,1)=plat_bounds(ip,1) + npplat_bounds(npproc,2)=plat_bounds(ip,2) +!!! +!!! print qui sert a reordonner les points stations selon l'ordre CFMIP +!!! ne pas enlever + print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip) +!!! + ENDIF + ENDDO + call histbeg(nname,npstn,npplon,npplon_bounds, & + npplat,npplat_bounds, & + itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id) + endif +!$OMP END MASTER + + end subroutine histbeg_phy_points + + subroutine histwrite2d_phy(nid,lpoint,name,itau,field) + USE dimphy + USE mod_phys_lmdz_para + USE ioipsl + implicit none + include 'dimensions.h' + + integer,intent(in) :: nid + logical,intent(in) :: lpoint + character*(*), intent(IN) :: name + integer, intent(in) :: itau + real,dimension(:),intent(in) :: field + REAL,dimension(klon_mpi) :: buffer_omp + INTEGER, allocatable, dimension(:) :: index2d + REAL :: Field2d(iim,jj_nb) + + integer :: ip + real,allocatable,dimension(:) :: fieldok + + IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first dimension not equal to klon',1) + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,Field2d) + if(.NOT.lpoint) THEN + ALLOCATE(index2d(iim*jj_nb)) + ALLOCATE(fieldok(iim*jj_nb)) + CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d) + else + ALLOCATE(fieldok(npstn)) + ALLOCATE(index2d(npstn)) + + if(is_sequential) then +! klon_mpi_begin=1 +! klon_mpi_end=klon + DO ip=1, npstn + fieldok(ip)=buffer_omp(nptabij(ip)) + ENDDO + else + DO ip=1, npstn +! print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip) + IF(nptabij(ip).GE.klon_mpi_begin.AND. & + nptabij(ip).LE.klon_mpi_end) THEN + fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1) + ENDIF + ENDDO + endif + CALL histwrite(nid,name,itau,fieldok,npstn,index2d) +! + endif + deallocate(index2d) + deallocate(fieldok) +!$OMP END MASTER + end subroutine histwrite2d_phy + + subroutine histwrite3d_phy(nid,lpoint,name,itau,field) + USE dimphy + USE mod_phys_lmdz_para + + use ioipsl + implicit none + include 'dimensions.h' + + integer,intent(in) :: nid + logical,intent(in) :: lpoint + character*(*), intent(IN) :: name + integer, intent(in) :: itau + real,dimension(:,:),intent(in) :: field ! --> field(klon,:) + REAL,dimension(klon_mpi,size(field,2)) :: buffer_omp + REAL :: Field3d(iim,jj_nb,size(field,2)) + INTEGER :: ip, n, nlev + INTEGER, ALLOCATABLE, dimension(:) :: index3d + real,allocatable, dimension(:,:) :: fieldok + + IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first dimension not equal to klon',1) + nlev=size(field,2) + +! print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn + +! DO ip=1, npstn +! print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip) +! ENDDO + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,field3d) + if(.NOT.lpoint) THEN + ALLOCATE(index3d(iim*jj_nb*nlev)) + ALLOCATE(fieldok(iim*jj_nb,nlev)) + CALL histwrite(nid,name,itau,Field3d,iim*jj_nb*nlev,index3d) + else + nlev=size(field,2) + ALLOCATE(index3d(npstn*nlev)) + ALLOCATE(fieldok(npstn,nlev)) + + if(is_sequential) then +! klon_mpi_begin=1 +! klon_mpi_end=klon + DO n=1, nlev + DO ip=1, npstn + fieldok(ip,n)=buffer_omp(nptabij(ip),n) + ENDDO + ENDDO + else + DO n=1, nlev + DO ip=1, npstn + IF(nptabij(ip).GE.klon_mpi_begin.AND. & + nptabij(ip).LE.klon_mpi_end) THEN + fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n) + ENDIF + ENDDO + ENDDO + endif + CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d) + endif + deallocate(index3d) + deallocate(fieldok) +!$OMP END MASTER + end subroutine histwrite3d_phy + +end module iophy Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iostart.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iostart.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/iostart.F90 (revision 1634) @@ -0,0 +1,494 @@ +MODULE iostart + +PRIVATE + INTEGER,SAVE :: nid_start + INTEGER,SAVE :: nid_restart + + INTEGER,SAVE :: idim1,idim2,idim3,idim4 + INTEGER,PARAMETER :: length=100 + + INTERFACE get_field + MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3 + END INTERFACE get_field + + INTERFACE get_var + MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3 + END INTERFACE get_var + + INTERFACE put_field + MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3 + END INTERFACE put_field + + INTERFACE put_var + MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3 + END INTERFACE put_var + + PUBLIC get_field,get_var,put_field,put_var + PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy + +CONTAINS + + SUBROUTINE Open_startphy(filename) + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: filename + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start) + IF (ierr.NE.NF90_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//filename + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + ENDIF + + END SUBROUTINE Open_startphy + + SUBROUTINE Close_startphy + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CLOSE (nid_start) + ENDIF + + END SUBROUTINE close_startphy + + + FUNCTION Inquire_Field(Field_name) + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: Field_name + LOGICAL :: inquire_field + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr=NF90_INQ_VARID(nid_start,Field_name,varid) + IF (ierr==NF90_NOERR) THEN + Inquire_field=.TRUE. + ELSE + Inquire_field=.FALSE. + ENDIF + ENDIF + + CALL bcast(Inquire_field) + + END FUNCTION Inquire_Field + + + SUBROUTINE Get_Field_r1(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,1,found) + ELSE + CALL Get_field_rgen(field_name,field,1) + ENDIF + + END SUBROUTINE Get_Field_r1 + + SUBROUTINE Get_Field_r2(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:,:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,size(field,2),found) + ELSE + CALL Get_field_rgen(field_name,field,size(field,2)) + ENDIF + + + END SUBROUTINE Get_Field_r2 + + SUBROUTINE Get_Field_r3(field_name,field,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: Field_name + REAL,INTENT(INOUT) :: Field(:,:,:) + LOGICAL,INTENT(OUT),OPTIONAL :: found + + IF (PRESENT(found)) THEN + CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found) + ELSE + CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3)) + ENDIF + + END SUBROUTINE Get_Field_r3 + + SUBROUTINE Get_field_rgen(field_name,field,field_size,found) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: Field_name + INTEGER :: field_size + REAL :: field(klon,field_size) + LOGICAL,OPTIONAL :: found + + REAL :: field_glo(klon_glo,field_size) + LOGICAL :: tmp_found + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + + ierr=NF90_INQ_VARID(nid_start,Field_name,varid) + + IF (ierr==NF90_NOERR) THEN + CALL body(field_glo) + tmp_found=.TRUE. + ELSE + tmp_found=.FALSE. + ENDIF + + ENDIF + + CALL bcast(tmp_found) + + IF (tmp_found) THEN + CALL scatter(field_glo,field) + ENDIF + + IF (PRESENT(found)) THEN + found=tmp_found + ELSE + IF (.NOT. tmp_found) THEN + PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent' + CALL abort + ENDIF + ENDIF + + + CONTAINS + + SUBROUTINE body(field_glo) + REAL :: field_glo(klon_glo*field_size) + ierr=NF90_GET_VAR(nid_start,varid,field_glo) + IF (ierr/=NF90_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>' + CALL abort + ENDIF + + END SUBROUTINE body + + END SUBROUTINE Get_field_rgen + + + SUBROUTINE get_var_r0(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + REAL :: varout(1) + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,varout,size(varout),found) + ELSE + CALL Get_var_rgen(var_name,varout,size(varout)) + ENDIF + var=varout(1) + + END SUBROUTINE get_var_r0 + + SUBROUTINE get_var_r1(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var(:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r1 + + SUBROUTINE get_var_r2(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(OUT) :: var(:,:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r2 + + SUBROUTINE get_var_r3(var_name,var,found) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + REAL,INTENT(INOUT) :: var(:,:,:) + LOGICAL,OPTIONAL,INTENT(OUT) :: found + + IF (PRESENT(found)) THEN + CALL Get_var_rgen(var_name,var,size(var),found) + ELSE + CALL Get_var_rgen(var_name,var,size(var)) + ENDIF + + END SUBROUTINE get_var_r3 + + SUBROUTINE Get_var_rgen(var_name,var,var_size,found) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*) :: var_name + INTEGER :: var_size + REAL :: var(var_size) + LOGICAL,OPTIONAL :: found + + LOGICAL :: tmp_found + INTEGER :: varid + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + + ierr=NF90_INQ_VARID(nid_start,var_name,varid) + + IF (ierr==NF90_NOERR) THEN + ierr=NF90_GET_VAR(nid_start,varid,var) + IF (ierr/=NF90_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>' + CALL abort + ENDIF + tmp_found=.TRUE. + ELSE + tmp_found=.FALSE. + ENDIF + + ENDIF + + CALL bcast(tmp_found) + + IF (tmp_found) THEN + CALL bcast(var) + ENDIF + + IF (PRESENT(found)) THEN + found=tmp_found + ELSE + IF (.NOT. tmp_found) THEN + PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente' + CALL abort + ENDIF + ENDIF + + END SUBROUTINE Get_var_rgen + + + SUBROUTINE open_restartphy(filename) + USE netcdf + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE dimphy + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: filename + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart) + IF (ierr/=NF90_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//filename + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + + ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique") + + ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1) + ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2) + ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3) + ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4) + + ierr = NF90_ENDDEF(nid_restart) + ENDIF + + END SUBROUTINE open_restartphy + + SUBROUTINE close_restartphy + USE netcdf + USE mod_phys_lmdz_para + IMPLICIT NONE + INTEGER :: ierr + + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_CLOSE (nid_restart) + ENDIF + + END SUBROUTINE close_restartphy + + + SUBROUTINE put_field_r1(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:) + + CALL put_field_rgen(field_name,title,field,1) + + END SUBROUTINE put_field_r1 + + SUBROUTINE put_field_r2(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:,:) + + CALL put_field_rgen(field_name,title,field,size(field,2)) + + END SUBROUTINE put_field_r2 + + SUBROUTINE put_field_r3(field_name,title,field) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: field(:,:,:) + + CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3)) + + END SUBROUTINE put_field_r3 + + SUBROUTINE put_field_rgen(field_name,title,field,field_size) + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: field_name + CHARACTER(LEN=*),INTENT(IN) :: title + INTEGER,INTENT(IN) :: field_size + REAL,INTENT(IN) :: field(klon,field_size) + + REAL :: field_glo(klon_glo,field_size) + INTEGER :: ierr + INTEGER :: nvarid + INTEGER :: idim + + + CALL gather(field,field_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + + IF (field_size==1) THEN + idim=idim2 + ELSE IF (field_size==klev) THEN + idim=idim3 + ELSE IF (field_size==klevp1) THEN + idim=idim4 + ELSE + PRINT *, "erreur phyredem : probleme de dimension" + CALL ABORT + ENDIF + + ierr = NF90_REDEF (nid_restart) +#ifdef NC_DOUBLE + ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid) +#else + ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid) +#endif + IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) + ierr = NF90_ENDDEF(nid_restart) + ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/))) + ENDIF + + END SUBROUTINE put_field_rgen + + SUBROUTINE put_var_r0(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var + REAL :: varin(1) + + varin(1)=var + + CALL put_var_rgen(var_name,title,varin,size(varin)) + + END SUBROUTINE put_var_r0 + + + SUBROUTINE put_var_r1(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r1 + + SUBROUTINE put_var_r2(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:,:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r2 + + SUBROUTINE put_var_r3(var_name,title,var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + REAL,INTENT(IN) :: var(:,:,:) + + CALL put_var_rgen(var_name,title,var,size(var)) + + END SUBROUTINE put_var_r3 + + SUBROUTINE put_var_rgen(var_name,title,var,var_size) + USE netcdf + USE dimphy + USE mod_phys_lmdz_para + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(IN) :: var_name + CHARACTER(LEN=*),INTENT(IN) :: title + INTEGER,INTENT(IN) :: var_size + REAL,INTENT(IN) :: var(var_size) + + INTEGER :: ierr + INTEGER :: nvarid + + IF (is_mpi_root .AND. is_omp_root) THEN + + IF (var_size/=length) THEN + PRINT *, "erreur phyredem : probleme de dimension" + CALL abort + ENDIF + + ierr = NF90_REDEF (nid_restart) + +#ifdef NC_DOUBLE + ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid) +#else + ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid) +#endif + IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) + ierr = NF90_ENDDEF(nid_restart) + + ierr = NF90_PUT_VAR(nid_restart,nvarid,var) + + ENDIF + + END SUBROUTINE put_var_rgen + +END MODULE iostart Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/isccp_cloud_types.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/isccp_cloud_types.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/isccp_cloud_types.F (revision 1634) @@ -0,0 +1,1668 @@ +! +! $Id $ +! + SUBROUTINE ISCCP_CLOUD_TYPES( + & debug, + & debugcol, + & npoints, + & sunlit, + & nlev, + & ncol, + & seed, + & pfull, + & phalf, + & qv, + & cc, + & conv, + & dtau_s, + & dtau_c, + & top_height, + & overlap, + & tautab, + & invtau, + & skt, + & emsfc_lw, + & at,dem_s,dem_c, + & fq_isccp, + & totalcldarea, + & meanptop, + & meantaucld, + & boxtau, + & boxptop + &) + + +! Copyright Steve Klein and Mark Webb 2002 - all rights reserved. +! +! This code is available without charge with the following conditions: +! +! 1. The code is available for scientific purposes and is not for +! commercial use. +! 2. Any improvements you make to the code should be made available +! to the to the authors for incorporation into a future release. +! 3. The code should not be used in any way that brings the authors +! or their employers into disrepute. + + implicit none + +! NOTE: the maximum number of levels and columns is set by +! the following parameter statement + + INTEGER ncolprint + +! ----- +! Input +! ----- + + INTEGER npoints ! number of model points in the horizontal +c PARAMETER(npoints=6722) + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER sunlit(npoints) ! 1 for day points, 0 for night time + + INTEGER seed(npoints) ! seed value for random number generator +c ! ( see Numerical Recipes Chapter 7) +c ! It is recommended that the seed is set +c ! to a different value for each model +c ! gridbox it is called on, as it is +c ! possible that the choice of the samec +c ! seed value every time may introduce some +c ! statistical bias in the results, particularly +c ! for low values of NCOL. +c + REAL pfull(npoints,nlev) ! pressure of full model levels (Pascals) +c ! pfull(npoints,1) is top level of model +c ! pfull(npoints,nlev) is bottom level of model + + REAL phalf(npoints,nlev+1) ! pressure of half model levels (Pascals) +c ! phalf(npoints,1) is top of model +c ! phalf(npoints,nlev+1) is the surface pressure + + REAL qv(npoints,nlev) ! water vapor specific humidity (kg vapor/ kg air) +c ! on full model levels + + REAL cc(npoints,nlev) ! input cloud cover in each model level (fraction) +c ! NOTE: This is the HORIZONTAL area of each +c ! grid box covered by clouds + + REAL conv(npoints,nlev) ! input convective cloud cover in each model level (fraction) +c ! NOTE: This is the HORIZONTAL area of each +c ! grid box covered by convective clouds + + REAL dtau_s(npoints,nlev) ! mean 0.67 micron optical depth of stratiform +c ! clouds in each model level +c ! NOTE: this the cloud optical depth of only the +c ! cloudy part of the grid box, it is not weighted +c ! with the 0 cloud optical depth of the clear +c ! part of the grid box + + REAL dtau_c(npoints,nlev) ! mean 0.67 micron optical depth of convective +c ! clouds in each +c ! model level. Same note applies as in dtau_s. + + INTEGER overlap ! overlap type + +! 1=max + +! 2=rand +! 3=max/rand + + INTEGER top_height ! 1 = adjust top height using both a computed +c ! infrared brightness temperature and the visible +c ! optical depth to adjust cloud top pressure. Note +c ! that this calculation is most appropriate to compare +c ! to ISCCP data during sunlit hours. +c ! 2 = do not adjust top height, that is cloud top +c ! pressure is the actual cloud top pressure +c ! in the model +c ! 3 = adjust top height using only the computed +c ! infrared brightness temperature. Note that this +c ! calculation is most appropriate to compare to ISCCP +c ! IR only algortihm (i.e. you can compare to nighttime +c ! ISCCP data with this option) + + REAL tautab(0:255) ! ISCCP table for converting count value to +c ! optical thickness + + INTEGER invtau(-20:45000) ! ISCCP table for converting optical thickness +c ! to count value +! +! The following input variables are used only if top_height = 1 or top_height = 3 +! + REAL skt(npoints) ! skin Temperature (K) + REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL at(npoints,nlev) ! temperature in each model level (K) + REAL dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform +c ! clouds in each +c ! model level. Same note applies as in dtau_s. + REAL dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective +c ! clouds in each +c ! model level. Same note applies as in dtau_s. +cIM reg.dyn BEG + REAL t1, t2 +! REAL w(npoints) !vertical wind at 500 hPa +! LOGICAL pct_ocean(npoints) !TRUE if oceanic point, FALSE otherway +! INTEGER iw(npoints) , nw +! REAL wmin, pas_w +! INTEGER k, l, iwmx +! PARAMETER(wmin=-100.,pas_w=10.,iwmx=30) +! REAL fq_dynreg(7,7,iwmx) +! REAL nfq_dynreg(7,7,iwmx) +! LOGICAL pctj(7,7,iwmx) +cIM reg.dyn END +! ------ +! Output +! ------ + + REAL fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by +c ! each of the 49 ISCCP D level cloud types + + REAL totalcldarea(npoints) ! the fraction of model grid box columns +c ! with cloud somewhere in them. This should +c ! equal the sum over all entries of fq_isccp + + +c ! The following three means are averages over the cloudy areas only. If no +c ! clouds are in grid box all three quantities should equal zero. + + REAL meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging +c ! in cloud top pressure. + + REAL meantaucld(npoints) ! mean optical thickness +c ! linear averaging in albedo performed. + + REAL boxtau(npoints,ncol) ! optical thickness in each column + + REAL boxptop(npoints,ncol) ! cloud top pressure (mb) in each column + + +! +! ------ +! Working variables added when program updated to mimic Mark Webb's PV-Wave code +! ------ + + REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into +c ! Equivalent of BOX in original version, but +c ! indexed by column then row, rather than +c ! by row then column + + REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction) +c ! with extra layer of zeroes on top +c ! in this version this just contains the values input +c ! from cc but with an extra level + REAL cca(npoints,nlev) ! convective cloud cover in each model level (fraction) +c ! from conv + + REAL threshold(npoints,ncol) ! pointer to position in gridbox + REAL maxocc(npoints,ncol) ! Flag for max overlapped conv cld + REAL maxosc(npoints,ncol) ! Flag for max overlapped strat cld + + REAL boxpos(npoints,ncol) ! ordered pointer to position in gridbox + + REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold +c ! is chosen + + REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave +c ! emissivity in part of +c ! gridbox under consideration + + REAL ran(npoints) ! vector of random numbers + REAL ptrop(npoints) + REAL attrop(npoints) + REAL attropmin (npoints) + REAL atmax(npoints) + REAL atmin(npoints) + REAL btcmin(npoints) + REAL transmax(npoints) + + INTEGER i,j,ilev,ibox,itrop(npoints) + INTEGER ipres(npoints) + INTEGER itau(npoints),ilev2 + INTEGER acc(nlev,ncol) + INTEGER match(npoints,nlev-1) + INTEGER nmatch(npoints) + INTEGER levmatch(npoints,ncol) + +c !variables needed for water vapor continuum absorption + real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) + real taumin(npoints) + real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 + real press(npoints), dpress(npoints), atmden(npoints) + real rvh20(npoints), wk(npoints), rhoave(npoints) + real rh20s(npoints), rfrgn(npoints) + real tmpexp(npoints),tauwv(npoints) + + character*1 cchar(6),cchar_realtops(6) + integer icycle + REAL tau(npoints,ncol) + LOGICAL box_cloudy(npoints,ncol) + REAL tb(npoints,ncol) + REAL ptop(npoints,ncol) + REAL emcld(npoints,ncol) + REAL fluxtop(npoints,ncol) + REAL trans_layers_above(npoints,ncol) + real isccp_taumin,fluxtopinit(npoints),tauir(npoints) + real meanalbedocld(npoints) + REAL albedocld(npoints,ncol) + real boxarea + integer debug ! set to non-zero value to print out inputs +c ! with step debug + integer debugcol ! set to non-zero value to print out column +c ! decomposition with step debugcol + + integer index1(npoints),num1,jj + real rec2p13,tauchk + + character*10 ftn09 + + DATA isccp_taumin / 0.3 / + DATA cchar / ' ','-','1','+','I','+'/ + DATA cchar_realtops / ' ',' ','1','1','I','I'/ + + tauchk = -1.*log(0.9999999) + rec2p13=1./2.13 + + ncolprint=0 + +cIM +c PRINT*,' isccp_cloud_types npoints=',npoints +c +c if ( debug.ne.0 ) then +c j=1 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(a10)') 'debug=' +c write(6,'(8I10)') debug +c write(6,'(a10)') 'debugcol=' +c write(6,'(8I10)') debugcol +c write(6,'(a10)') 'npoints=' +c write(6,'(8I10)') npoints +c write(6,'(a10)') 'nlev=' +c write(6,'(8I10)') nlev +c write(6,'(a10)') 'ncol=' +c write(6,'(8I10)') ncol +c write(6,'(a10)') 'top_height=' +c write(6,'(8I10)') top_height +c write(6,'(a10)') 'overlap=' +c write(6,'(8I10)') overlap +c write(6,'(a10)') 'emsfc_lw=' +c write(6,'(8f10.2)') emsfc_lw +c write(6,'(a10)') 'tautab=' +c write(6,'(8f10.2)') tautab +c write(6,'(a10)') 'invtau(1:100)=' +c write(6,'(8i10)') (invtau(i),i=1,100) +c do j=1,npoints,debug +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(a10)') 'sunlit=' +c write(6,'(8I10)') sunlit(j) +c write(6,'(a10)') 'seed=' +c write(6,'(8I10)') seed(j) +c write(6,'(a10)') 'pfull=' +c write(6,'(8f10.2)') (pfull(j,i),i=1,nlev) +c write(6,'(a10)') 'phalf=' +c write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1) +c write(6,'(a10)') 'qv=' +c write(6,'(8f10.3)') (qv(j,i),i=1,nlev) +c write(6,'(a10)') 'cc=' +c write(6,'(8f10.3)') (cc(j,i),i=1,nlev) +c write(6,'(a10)') 'conv=' +c write(6,'(8f10.2)') (conv(j,i),i=1,nlev) +c write(6,'(a10)') 'dtau_s=' +c write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev) +c write(6,'(a10)') 'dtau_c=' +c write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev) +c write(6,'(a10)') 'skt=' +c write(6,'(8f10.2)') skt(j) +c write(6,'(a10)') 'at=' +c write(6,'(8f10.2)') (at(j,i),i=1,nlev) +c write(6,'(a10)') 'dem_s=' +c write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev) +c write(6,'(a10)') 'dem_c=' +c write(6,'(8f10.2)') (dem_c(j,i),i=1,nlev) +c enddo +c endif + +! ---------------------------------------------------! + +! assign 2d tca array using 1d input array cc + + do j=1,npoints + tca(j,0)=0 + enddo + + do ilev=1,nlev + do j=1,npoints + tca(j,ilev)=cc(j,ilev) + enddo + enddo + +! assign 2d cca array using 1d input array conv + + do ilev=1,nlev +cIM pas besoin do ibox=1,ncol + do j=1,npoints + cca(j,ilev)=conv(j,ilev) + enddo +cIM enddo + enddo + +cIM +! do j=1, iwmx +! do l=1, 7 +! do k=1, 7 +! fq_dynreg(k,l,j) =0. +! nfq_dynreg(k,l,j) =0. +! enddo !k +! enddo !l +! enddo !j +cIM +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'seed:' +c write (6,'(I3.2)') seed(j) + +c write (6,'(a)') 'tca_pp_rev:' +c write (6,'(8f5.2)') +c & ((tca(j,ilev)), +c & ilev=1,nlev) + +c write (6,'(a)') 'cca_pp_rev:' +c write (6,'(8f5.2)') +c & ((cca(j,ilev),ibox=1,ncolprint),ilev=1,nlev) +c enddo +c endif + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + do j=1,npoints + ptrop(j)=5000. + atmin(j) = 400. + attropmin(j) = 400. + atmax(j) = 0. + attrop(j) = 120. + itrop(j) = 1 + enddo + + do 12 ilev=1,nlev + do j=1,npoints + if (pfull(j,ilev) .lt. 40000. .and. + & pfull(j,ilev) .gt. 5000. .and. + & at(j,ilev) .lt. attropmin(j)) then + ptrop(j) = pfull(j,ilev) + attropmin(j) = at(j,ilev) + attrop(j) = attropmin(j) + itrop(j)=ilev + end if + if (at(j,ilev) .gt. atmax(j)) atmax(j)=at(j,ilev) + if (at(j,ilev) .lt. atmin(j)) atmin(j)=at(j,ilev) + enddo +12 continue + + end if + +! -----------------------------------------------------! + +! ---------------------------------------------------! + +cIM +c do 13 ilev=1,nlev +cnum1=0 +c do j=1,npoints +c if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) ' error = cloud fraction less than zero' +c write(6,*) ' or ' +c write(6,*) ' error = cloud fraction greater than 1' +c write(6,*) 'value at point ',j,' is ',cc(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo +cnum1=0 +c do j=1,npoints +c if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = convective cloud fraction less than zero' +c write(6,*) ' or ' +c write(6,*) +c & ' error = convective cloud fraction greater than 1' +c write(6,*) 'value at point ',j,' is ',conv(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo + +cnum1=0 +c do j=1,npoints +c if (dtau_s(j,ilev) .lt. 0.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = stratiform cloud opt. depth less than zero' +c write(6,*) 'value at point ',j,' is ',dtau_s(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo +cnum1=0 +c do j=1,npoints +c if (dtau_c(j,ilev) .lt. 0.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = convective cloud opt. depth less than zero' +c write(6,*) 'value at point ',j,' is ',dtau_c(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo + +cnum1=0 +c do j=1,npoints +c if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = stratiform cloud emissivity less than zero' +c write(6,*)'or' +c write(6,*) +c & ' error = stratiform cloud emissivity greater than 1' +c write(6,*) 'value at point ',j,' is ',dem_s(j,ilev) +c write(6,*) 'level ',ilev +c STOP +c enddo + +cnum1=0 +c do j=1,npoints +c if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then +c num1=num1+1 +c index1(num1)=j +c end if +c enddo +c do jj=1,num1 +c j=index1(jj) +c write(6,*) +c & ' error = convective cloud emissivity less than zero' +c write(6,*)'or' +c write(6,*) +c & ' error = convective cloud emissivity greater than 1' +c write (6,*) +c & 'j=',j,'ilev=',ilev,'dem_c(j,ilev) =',dem_c(j,ilev) +c STOP +c enddo +c13 continue + + + do ibox=1,ncol + do j=1,npoints + boxpos(j,ibox)=(ibox-.5)/ncol + enddo + enddo + +! ---------------------------------------------------! +! Initialise working variables +! ---------------------------------------------------! + +! Initialised frac_out to zero + + do ilev=1,nlev + do ibox=1,ncol + do j=1,npoints + frac_out(j,ibox,ilev)=0.0 + enddo + enddo + enddo + +cIM +c if (ncolprint.ne.0) then +c write (6,'(a)') 'frac_out_pp_rev:' +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(8f5.2)') +c & ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev) + +c enddo +c write (6,'(a)') 'ncol:' +c write (6,'(I3)') ncol +c endif +c if (ncolprint.ne.0) then +c write (6,'(a)') 'last_frac_pp:' +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(8f5.2)') (tca(j,0)) +c enddo +c endif + +! ---------------------------------------------------! +! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS +! frac_out is the array that contains the information +! where 0 is no cloud, 1 is a stratiform cloud and 2 is a +! convective cloud + + !loop over vertical levels + DO 200 ilev = 1,nlev + +! Initialise threshold + + IF (ilev.eq.1) then + ! If max overlap + IF (overlap.eq.1) then + ! select pixels spread evenly + ! across the gridbox + DO ibox=1,ncol + do j=1,npoints + threshold(j,ibox)=boxpos(j,ibox) + enddo + enddo + ELSE + DO ibox=1,ncol + call ran0_vec(npoints,seed,ran) + ! select random pixels from the non-convective + ! part the gridbox ( some will be converted into + ! convective pixels below ) + do j=1,npoints + threshold(j,ibox)= + & cca(j,ilev)+(1-cca(j,ilev))*ran(j) + enddo + enddo + ENDIF +cIM +c IF (ncolprint.ne.0) then +c write (6,'(a)') 'threshold_nsf2:' +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) +c enddo +c ENDIF + ENDIF + +c IF (ncolprint.ne.0) then +c write (6,'(a)') 'ilev:' +c write (6,'(I2)') ilev +c ENDIF + + DO ibox=1,ncol + + ! All versions + do j=1,npoints + if (boxpos(j,ibox).le.cca(j,ilev)) then +cIM REAL maxocc(j,ibox) = 1 + maxocc(j,ibox) = 1.0 + else +cIM REAL maxocc(j,ibox) = 0 + maxocc(j,ibox) = 0.0 + end if + enddo + + ! Max overlap + if (overlap.eq.1) then + do j=1,npoints + threshold_min(j,ibox)=cca(j,ilev) +cIM REAL maxosc(j,ibox)=1 + maxosc(j,ibox)=1.0 + enddo + endif + + ! Random overlap + if (overlap.eq.2) then + do j=1,npoints + threshold_min(j,ibox)=cca(j,ilev) +cIM REAL maxosc(j,ibox)=0 + maxosc(j,ibox)=0.0 + enddo + endif + + ! Max/Random overlap + if (overlap.eq.3) then + do j=1,npoints + threshold_min(j,ibox)=max(cca(j,ilev), + & min(tca(j,ilev-1),tca(j,ilev))) + if (threshold(j,ibox) + & .lt.min(tca(j,ilev-1),tca(j,ilev)) + & .and.(threshold(j,ibox).gt.cca(j,ilev))) then +cIM REAL maxosc(j,ibox)= 1 + maxosc(j,ibox)= 1.0 + else +cIM REAL maxosc(j,ibox)= 0 + maxosc(j,ibox)= 0.0 + end if + enddo + endif + + ! Reset threshold + call ran0_vec(npoints,seed,ran) + + do j=1,npoints + threshold(j,ibox)= + !if max overlapped conv cloud + & maxocc(j,ibox) * ( + & boxpos(j,ibox) + & ) + + !else + & (1-maxocc(j,ibox)) * ( + !if max overlapped strat cloud + & (maxosc(j,ibox)) * ( + !threshold=boxpos + & threshold(j,ibox) + & ) + + !else + & (1-maxosc(j,ibox)) * ( + !threshold_min=random[thrmin,1] + & threshold_min(j,ibox)+ + & (1-threshold_min(j,ibox))*ran(j) + & ) + & ) + enddo + + ENDDO ! ibox + +! Fill frac_out with 1's where tca is greater than the threshold + + DO ibox=1,ncol + do j=1,npoints + if (tca(j,ilev).gt.threshold(j,ibox)) then +cIM REAL frac_out(j,ibox,ilev)=1 + frac_out(j,ibox,ilev)=1.0 + else +cIM REAL frac_out(j,ibox,ilev)=0 + frac_out(j,ibox,ilev)=0.0 + end if + enddo + ENDDO + +! Code to partition boxes into startiform and convective parts +! goes here + + DO ibox=1,ncol + do j=1,npoints + if (threshold(j,ibox).le.cca(j,ilev)) then + ! = 2 IF threshold le cca(j) +cIM REAL frac_out(j,ibox,ilev) = 2 + frac_out(j,ibox,ilev) = 2.0 + else + ! = the same IF NOT threshold le cca(j) + frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev) + end if + enddo + ENDDO + +! Set last_frac to tca at this level, so as to be tca +! from last level next time round + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'last_frac:' +c write (6,'(8f5.2)') (tca(j,ilev-1)) + +c write (6,'(a)') 'cca:' +c write (6,'(8f5.2)') (cca(j,ilev),ibox=1,ncolprint) + +c write (6,'(a)') 'max_overlap_cc:' +c write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'max_overlap_sc:' +c write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'threshold_min_nsf2:' +c write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'threshold_nsf2:' +c write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'frac_out_pp_rev:' +c write (6,'(8f5.2)') +c & ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev) +c enddo +c endif + +200 CONTINUE !loop over nlev + +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and +! put into vector tau + + !initialize tau and albedocld to zero + do 15 ibox=1,ncol + do j=1,npoints + tau(j,ibox)=0. + albedocld(j,ibox)=0. + boxtau(j,ibox)=0. + boxptop(j,ibox)=0. + box_cloudy(j,ibox)=.false. + enddo +15 continue + + !compute total cloud optical depth for each column + do ilev=1,nlev + !increment tau for each of the boxes + do ibox=1,ncol + do j=1,npoints +cIM REAL if (frac_out(j,ibox,ilev).eq.1) then + if (frac_out(j,ibox,ilev).eq.1.0) then + tau(j,ibox)=tau(j,ibox) + & + dtau_s(j,ilev) + endif +cIM REAL if (frac_out(j,ibox,ilev).eq.2) then + if (frac_out(j,ibox,ilev).eq.2.0) then + tau(j,ibox)=tau(j,ibox) + & + dtau_c(j,ilev) + end if + enddo + enddo ! ibox + enddo ! ilev +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(i2,1X,8(f7.2,1X))') +c & ilev, +c & (tau(j,ibox),ibox=1,ncolprint) +c enddo +c endif +! +! ---------------------------------------------------! + + + +! +! ---------------------------------------------------! +! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES +! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE +! +! again this is only done if top_height = 1 or 3 +! +! fluxtop is the 10.5 micron radiance at the top of the +! atmosphere +! trans_layers_above is the total transmissivity in the layers +! above the current layer +! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear +! sky versions of these quantities. + + if (top_height .eq. 1 .or. top_height .eq. 3) then + + + !---------------------------------------------------------------------- + ! + ! DO CLEAR SKY RADIANCE CALCULATION FIRST + ! + !compute water vapor continuum emissivity + !this treatment follows Schwarkzopf and Ramasamy + !JGR 1999,vol 104, pages 9467-9499. + !the emissivity is calculated at a wavenumber of 955 cm-1, + !or 10.47 microns + wtmair = 28.9644 + wtmh20 = 18.01534 + Navo = 6.023E+23 + grav = 9.806650E+02 + pstd = 1.013250E+06 + t0 = 296. +cIM +c if (ncolprint .ne. 0) +c & write(6,*) 'ilev pw (kg/m2) tauwv(j) dem_wv' + do 125 ilev=1,nlev + do j=1,npoints + !press and dpress are dyne/cm2 = Pascals *10 + press(j) = pfull(j,ilev)*10. + dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10 + !atmden = g/cm2 = kg/m2 / 10 + atmden(j) = dpress(j)/grav + rvh20(j) = qv(j,ilev)*wtmair/wtmh20 + wk(j) = rvh20(j)*Navo*atmden(j)/wtmair + rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev)) + rh20s(j) = rvh20(j)*rhoave(j) + rfrgn(j) = rhoave(j)-rh20s(j) + tmpexp(j) = exp(-0.02*(at(j,ilev)-t0)) + tauwv(j) = wk(j)*1.e-20*( + & (0.0224697*rh20s(j)*tmpexp(j)) + + & (3.41817e-7*rfrgn(j)) )*0.98 + dem_wv(j,ilev) = 1. - exp( -1. * tauwv(j)) + enddo +cIM +c if (ncolprint .ne. 0) then +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write(6,'(i2,1X,3(f8.3,3X))') ilev, +c & qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.), +c & tauwv(j),dem_wv(j,ilev) +c enddo +c endif +125 continue + + !initialize variables + do j=1,npoints + fluxtop_clrsky(j) = 0. + trans_layers_above_clrsky(j)=1. + enddo + + do ilev=1,nlev + do j=1,npoints + + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + & + dem_wv(j,ilev)*bb(j)*trans_layers_above_clrsky(j) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above_clrsky(j)= + & trans_layers_above_clrsky(j)*(1.-dem_wv(j,ilev)) + + + enddo +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'ilev:' +c write (6,'(I2)') ilev + +c write (6,'(a)') +c & 'emiss_layer,100.*bb(j),100.*f,total_trans:' +c write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j), +c & 100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j) +c enddo +c endif + + enddo !loop over level + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + + fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw * bb(j) + & * trans_layers_above_clrsky(j) + enddo + +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'id:' +c write (6,'(a)') 'surface' + +c write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:' +c write (6,'(4(f7.2,1X))') emsfc_lw,100.*bb(j), +c & 100.*fluxtop_clrsky(j), +c & trans_layers_above_clrsky(j) +c enddo +c endif + + + ! + ! END OF CLEAR SKY CALCULATION + ! + !---------------------------------------------------------------- + + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'ts:' +c write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint) + +c write (6,'(a)') 'ta_rev:' +c write (6,'(8f7.2)') +c & ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev) + +c enddo +c endif + !loop over columns + do ibox=1,ncol + do j=1,npoints + fluxtop(j,ibox)=0. + trans_layers_above(j,ibox)=1. + enddo + enddo + + do ilev=1,nlev + do j=1,npoints + ! Black body emission at temperature of the layer + + bb(j)=1 / ( exp(1307.27/at(j,ilev)) - 1. ) + !bb(j)= 5.67e-8*at(j,ilev)**4 + enddo + + do ibox=1,ncol + do j=1,npoints + + ! emissivity for point in this layer +cIM REAL if (frac_out(j,ibox,ilev).eq.1) then + if (frac_out(j,ibox,ilev).eq.1.0) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_s(j,ilev)) ) +cIM REAL else if (frac_out(j,ibox,ilev).eq.2) then + else if (frac_out(j,ibox,ilev).eq.2.0) then + dem(j,ibox)= 1. - + & ( (1. - dem_wv(j,ilev)) * (1. - dem_c(j,ilev)) ) + else + dem(j,ibox)= dem_wv(j,ilev) + end if + + + ! increase TOA flux by flux emitted from layer + ! times total transmittance in layers above + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + dem(j,ibox) * bb(j) + & * trans_layers_above(j,ibox) + + ! update trans_layers_above with transmissivity + ! from this layer for next time around loop + + trans_layers_above(j,ibox)= + & trans_layers_above(j,ibox)*(1.-dem(j,ibox)) + + enddo ! j + enddo ! ibox + +cIM +c if (ncolprint.ne.0) then +c do j=1,npoints,1000 +c write (6,'(a)') 'ilev:' +c write (6,'(I2)') ilev + +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'emiss_layer:' +c write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') '100.*bb(j):' +c write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + +c write (6,'(a)') '100.*f:' +c write (6,'(8f7.2)') +c & (100.*fluxtop(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_trans:' +c write (6,'(8f7.2)') +c & (trans_layers_above(j,ibox),ibox=1,ncolprint) +c enddo +c endif + + enddo ! ilev + + + do j=1,npoints + !add in surface emission + bb(j)=1/( exp(1307.27/skt(j)) - 1. ) + !bb(j)=5.67e-8*skt(j)**4 + end do + + do ibox=1,ncol + do j=1,npoints + + !add in surface emission + + fluxtop(j,ibox) = fluxtop(j,ibox) + & + emsfc_lw * bb(j) + & * trans_layers_above(j,ibox) + + end do + end do + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints ,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j +c write (6,'(a)') 'id:' +c write (6,'(a)') 'surface' + +c write (6,'(a)') 'emiss_layer:' +c write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint) + +c write (6,'(a)') '100.*bb(j):' +c write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint) + +c write (6,'(a)') '100.*f:' +c write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) +c end do +c endif + + !now that you have the top of atmosphere radiance account + !for ISCCP procedures to determine cloud top temperature + + !account for partially transmitting cloud recompute flux + !ISCCP would see assuming a single layer cloud + !note choice here of 2.13, as it is primarily ice + !clouds which have partial emissivity and need the + !adjustment performed in this section + ! + !If it turns out that the cloud brightness temperature + !is greater than 260K, then the liquid cloud conversion + !factor of 2.56 is used. + ! + !Note that this is discussed on pages 85-87 of + !the ISCCP D level documentation (Rossow et al. 1996) + + do j=1,npoints + !compute minimum brightness temperature and optical depth + btcmin(j) = 1. / ( exp(1307.27/(attrop(j)-5.)) - 1. ) + enddo + do ibox=1,ncol + do j=1,npoints + transmax(j) = (fluxtop(j,ibox)-btcmin(j)) + & /(fluxtop_clrsky(j)-btcmin(j)) + !note that the initial setting of tauir(j) is needed so that + !tauir(j) has a realistic value should the next if block be + !bypassed + tauir(j) = tau(j,ibox) * rec2p13 + taumin(j) = -1. * log(max(min(transmax(j),0.9999999),0.001)) + + enddo + + if (top_height .eq. 1) then + do j=1,npoints + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + fluxtopinit(j) = fluxtop(j,ibox) + tauir(j) = tau(j,ibox) *rec2p13 + endif + enddo + do icycle=1,2 + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + if (transmax(j) .gt. 0.001 .and. + & transmax(j) .le. 0.9999999) then + emcld(j,ibox) = 1. - exp(-1. * tauir(j) ) + fluxtop(j,ibox) = fluxtopinit(j) - + & ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) + fluxtop(j,ibox)=max(1.E-06, + & (fluxtop(j,ibox)/emcld(j,ibox))) + tb(j,ibox)= 1307.27 + & / (log(1. + (1./fluxtop(j,ibox)))) + if (tb(j,ibox) .gt. 260.) then + tauir(j) = tau(j,ibox) / 2.56 + end if + end if + end if + enddo + enddo + + endif + + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk )) then + !cloudy box + tb(j,ibox)= 1307.27/ (log(1. + (1./fluxtop(j,ibox)))) + if (top_height.eq.1.and.tauir(j).lt.taumin(j)) then + tb(j,ibox) = attrop(j) - 5. + tau(j,ibox) = 2.13*taumin(j) + end if + else + !clear sky brightness temperature + tb(j,ibox) = 1307.27/(log(1.+(1./fluxtop_clrsky(j)))) + end if + enddo ! j + enddo ! ibox + +cIM +c if (ncolprint.ne.0) then + +c do j=1,npoints,1000 +c write(6,'(a10)') 'j=' +c write(6,'(8I10)') j + +c write (6,'(a)') 'attrop:' +c write (6,'(8f7.2)') (attrop(j)) + +c write (6,'(a)') 'btcmin:' +c write (6,'(8f7.2)') (btcmin(j)) + +c write (6,'(a)') 'fluxtop_clrsky*100:' +c write (6,'(8f7.2)') +c & (100.*fluxtop_clrsky(j)) + +c write (6,'(a)') '100.*f_adj:' +c write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'transmax:' +c write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'tau:' +c write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'emcld:' +c write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_trans:' +c write (6,'(8f7.2)') +c & (trans_layers_above(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_emiss:' +c write (6,'(8f7.2)') +c & (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'total_trans:' +c write (6,'(8f7.2)') +c & (trans_layers_above(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'ppout:' +c write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) +c enddo ! j +c endif + + end if + +! ---------------------------------------------------! + +! +! ---------------------------------------------------! +! DETERMINE CLOUD TOP PRESSURE +! +! again the 2 methods differ according to whether +! or not you use the physical cloud top pressure (top_height = 2) +! or the radiatively determined cloud top pressure (top_height = 1 or 3) +! + + !compute cloud top pressure + do 30 ibox=1,ncol + !segregate according to optical thickness + if (top_height .eq. 1 .or. top_height .eq. 3) then + !find level whose temperature + !most closely matches brightness temperature + do j=1,npoints + nmatch(j)=0 + enddo + do 29 ilev=1,nlev-1 +!cdir nodep + do j=1,npoints + if ((at(j,ilev) .ge. tb(j,ibox) .and. + & at(j,ilev+1) .lt. tb(j,ibox)) .or. + & (at(j,ilev) .le. tb(j,ibox) .and. + & at(j,ilev+1) .gt. tb(j,ibox))) then + + nmatch(j)=nmatch(j)+1 + if(abs(at(j,ilev)-tb(j,ibox)) .lt. + & abs(at(j,ilev+1)-tb(j,ibox))) then + match(j,nmatch(j))=ilev + else + match(j,nmatch(j))=ilev+1 + end if + end if + enddo +29 continue + + do j=1,npoints + if (nmatch(j) .ge. 1) then + ptop(j,ibox)=pfull(j,match(j,nmatch(j))) + levmatch(j,ibox)=match(j,nmatch(j)) + else + if (tb(j,ibox) .lt. atmin(j)) then + ptop(j,ibox)=ptrop(j) + levmatch(j,ibox)=itrop(j) + end if + if (tb(j,ibox) .gt. atmax(j)) then + ptop(j,ibox)=pfull(j,nlev) + levmatch(j,ibox)=nlev + end if + end if + enddo ! j + + else ! if (top_height .eq. 1 .or. top_height .eq. 3) + + do j=1,npoints + ptop(j,ibox)=0. + enddo + do ilev=1,nlev + do j=1,npoints + if ((ptop(j,ibox) .eq. 0. ) +cIM & .and.(frac_out(j,ibox,ilev) .ne. 0)) then + & .and.(frac_out(j,ibox,ilev) .ne. 0.0)) then + ptop(j,ibox)=pfull(j,ilev) + levmatch(j,ibox)=ilev + end if + end do + end do + end if + + do j=1,npoints + if (tau(j,ibox) .le. (tauchk )) then + ptop(j,ibox)=0. + levmatch(j,ibox)=0 + endif + enddo + +30 continue + +! +! +! ---------------------------------------------------! + + +! +! ---------------------------------------------------! +! DETERMINE ISCCP CLOUD TYPE FREQUENCIES +! +! Now that ptop and tau have been determined, +! determine amount of each of the 49 ISCCP cloud +! types +! +! Also compute grid box mean cloud top pressure and +! optical thickness. The mean cloud top pressure and +! optical thickness are averages over the cloudy +! area only. The mean cloud top pressure is a linear +! average of the cloud top pressures. The mean cloud +! optical thickness is computed by converting optical +! thickness to an albedo, averaging in albedo units, +! then converting the average albedo back to a mean +! optical thickness. +! + + !compute isccp frequencies + + !reset frequencies + do 38 ilev=1,7 + do 38 ilev2=1,7 + do j=1,npoints ! + fq_isccp(j,ilev,ilev2)=0. + enddo +38 continue + + !reset variables need for averaging cloud properties + do j=1,npoints + totalcldarea(j) = 0. + meanalbedocld(j) = 0. + meanptop(j) = 0. + meantaucld(j) = 0. + enddo ! j + + boxarea = 1./real(ncol) + + !determine optical depth category +cIM do 39 j=1,npoints +cIM do ibox=1,ncol + do 39 ibox=1,ncol + do j=1,npoints + +cIM +c CALL CPU_time(t1) +cIM + + if (tau(j,ibox) .gt. (tauchk ) + & .and. ptop(j,ibox) .gt. 0.) then + box_cloudy(j,ibox)=.true. + endif + +cIM +c CALL CPU_time(t2) +c print*,'IF tau t2 - t1',t2 - t1 + +c CALL CPU_time(t1) +cIM + + if (box_cloudy(j,ibox)) then + + ! totalcldarea always diagnosed day or night + totalcldarea(j) = totalcldarea(j) + boxarea + + if (sunlit(j).eq.1) then + + ! tau diagnostics only with sunlight + + boxtau(j,ibox) = tau(j,ibox) + + !convert optical thickness to albedo + albedocld(j,ibox) + & =real(invtau(min(nint(100.*tau(j,ibox)),45000))) + + !contribute to averaging + meanalbedocld(j) = meanalbedocld(j) + & +albedocld(j,ibox)*boxarea + + endif + + endif + +cIM +c CALL CPU_time(t2) +c print*,'IF box_cloudy t2 - t1',t2 - t1 + +c CALL CPU_time(t1) +cIM BEG +cIM !convert ptop to millibars + ptop(j,ibox)=ptop(j,ibox) / 100. + +cIM !save for output cloud top pressure and optical thickness + boxptop(j,ibox) = ptop(j,ibox) +cIM END + +cIM BEG + !reset itau(j), ipres(j) + itau(j) = 0 + ipres(j) = 0 + + if (tau(j,ibox) .lt. isccp_taumin) then + itau(j)=1 + else if (tau(j,ibox) .ge. isccp_taumin + & + & .and. tau(j,ibox) .lt. 1.3) then + itau(j)=2 + else if (tau(j,ibox) .ge. 1.3 + & .and. tau(j,ibox) .lt. 3.6) then + itau(j)=3 + else if (tau(j,ibox) .ge. 3.6 + & .and. tau(j,ibox) .lt. 9.4) then + itau(j)=4 + else if (tau(j,ibox) .ge. 9.4 + & .and. tau(j,ibox) .lt. 23.) then + itau(j)=5 + else if (tau(j,ibox) .ge. 23. + & .and. tau(j,ibox) .lt. 60.) then + itau(j)=6 + else if (tau(j,ibox) .ge. 60.) then + itau(j)=7 + end if + + !determine cloud top pressure category + if ( ptop(j,ibox) .gt. 0. + & .and.ptop(j,ibox) .lt. 180.) then + ipres(j)=1 + else if(ptop(j,ibox) .ge. 180. + & .and.ptop(j,ibox) .lt. 310.) then + ipres(j)=2 + else if(ptop(j,ibox) .ge. 310. + & .and.ptop(j,ibox) .lt. 440.) then + ipres(j)=3 + else if(ptop(j,ibox) .ge. 440. + & .and.ptop(j,ibox) .lt. 560.) then + ipres(j)=4 + else if(ptop(j,ibox) .ge. 560. + & .and.ptop(j,ibox) .lt. 680.) then + ipres(j)=5 + else if(ptop(j,ibox) .ge. 680. + & .and.ptop(j,ibox) .lt. 800.) then + ipres(j)=6 + else if(ptop(j,ibox) .ge. 800.) then + ipres(j)=7 + end if +cIM END + + if (sunlit(j).eq.1 .or. top_height .eq. 3) then + +cIM !convert ptop to millibars +cIM ptop(j,ibox)=ptop(j,ibox) / 100. + +cIM !save for output cloud top pressure and optical thickness +cIM boxptop(j,ibox) = ptop(j,ibox) + + if (box_cloudy(j,ibox)) then + + meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea + +cIM !reset itau(j), ipres(j) +cIM itau(j) = 0 +cIM ipres(j) = 0 + +c if (tau(j,ibox) .lt. isccp_taumin) then +c itau(j)=1 +c else if (tau(j,ibox) .ge. isccp_taumin +c & +c & .and. tau(j,ibox) .lt. 1.3) then +c itau(j)=2 +c else if (tau(j,ibox) .ge. 1.3 +c & .and. tau(j,ibox) .lt. 3.6) then +c itau(j)=3 +c else if (tau(j,ibox) .ge. 3.6 +c & .and. tau(j,ibox) .lt. 9.4) then +c itau(j)=4 +c else if (tau(j,ibox) .ge. 9.4 +c & .and. tau(j,ibox) .lt. 23.) then +c itau(j)=5 +c else if (tau(j,ibox) .ge. 23. +c & .and. tau(j,ibox) .lt. 60.) then +c itau(j)=6 +c else if (tau(j,ibox) .ge. 60.) then +c itau(j)=7 +c end if + +c !determine cloud top pressure category +c if ( ptop(j,ibox) .gt. 0. +c & .and.ptop(j,ibox) .lt. 180.) then +c ipres(j)=1 +c else if(ptop(j,ibox) .ge. 180. +c & .and.ptop(j,ibox) .lt. 310.) then +c ipres(j)=2 +c else if(ptop(j,ibox) .ge. 310. +c & .and.ptop(j,ibox) .lt. 440.) then +c ipres(j)=3 +c else if(ptop(j,ibox) .ge. 440. +c & .and.ptop(j,ibox) .lt. 560.) then +c ipres(j)=4 +c else if(ptop(j,ibox) .ge. 560. +c & .and.ptop(j,ibox) .lt. 680.) then +c ipres(j)=5 +c else if(ptop(j,ibox) .ge. 680. +c & .and.ptop(j,ibox) .lt. 800.) then +c ipres(j)=6 +c else if(ptop(j,ibox) .ge. 800.) then +c ipres(j)=7 +c end if + + !update frequencies + if(ipres(j) .gt. 0.and.itau(j) .gt. 0) then + fq_isccp(j,itau(j),ipres(j))= + & fq_isccp(j,itau(j),ipres(j))+ boxarea + end if + +cIM calcul stats regime dynamique BEG +! iw(j) = int((w(j)-wmin)/pas_w) +1 +! pctj(itau(j),ipres(j),iw(j))=.FALSE. +! !update frequencies W500 +! if (pct_ocean(j)) then +! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then +! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then +c print*,' ISCCP iw=',iw(j),j +! fq_dynreg(itau(j),ipres(j),iw(j))= +! & fq_dynreg(itau(j),ipres(j),iw(j))+ +! & boxarea +c & fq_isccp(j,itau(j),ipres(j)) +! pctj(itau(j),ipres(j),iw(j))=.TRUE. +c nfq_dynreg(itau(j),ipres(j),iw(j))= +c & nfq_dynreg(itau(j),ipres(j),iw(j))+1. +! end if +! end if +! end if +cIM calcul stats regime dynamique END + end if !IM boxcloudy + + end if !IM sunlit + +cIM +c CALL CPU_time(t2) +c print*,'IF sunlit boxcloudy t2 - t1',t2 - t1 +cIM + enddo !IM ibox/j + + +cIM ajout stats s/ W500 BEG +cIM ajout stats s/ W500 END + +c if(j.EQ.6722) then +c print*,' ISCCP',w(j),iw(j),ipres(j),itau(j) +c endif + +! if (pct_ocean(j)) then +! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then +! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then +! if(pctj(itau(j),ipres(j),iw(j))) THEN +! nfq_dynreg(itau(j),ipres(j),iw(j))= +! & nfq_dynreg(itau(j),ipres(j),iw(j))+1. +c if(itau(j).EQ.4.AND.ipres(j).EQ.2.AND. +c & iw(j).EQ.10) then +c PRINT*,' isccp AVANT', +c & nfq_dynreg(itau(j),ipres(j),iw(j)), +c & fq_dynreg(itau(j),ipres(j),iw(j)) +c endif +! endif +! endif +! endif +! endif +39 continue !IM j/ibox + + !compute mean cloud properties + do j=1,npoints + if (totalcldarea(j) .gt. 0.) then + meanptop(j) = meanptop(j) / totalcldarea(j) + if (sunlit(j).eq.1) then + meanalbedocld(j)=meanalbedocld(j) / totalcldarea(j) + meantaucld(j)=tautab(min(255,max(1,nint(meanalbedocld(j))))) + end if + end if + enddo ! j +! +cIM ajout stats s/ W500 BEG +! do nw = 1, iwmx +! do l = 1, 7 +! do k = 1, 7 +! if (nfq_dynreg(k,l,nw).GT.0.) then +! fq_dynreg(k,l,nw) = fq_dynreg(k,l,nw)/nfq_dynreg(k,l,nw) +c if(k.EQ.4.AND.l.EQ.2.AND.nw.EQ.10) then +c print*,' isccp APRES',nfq_dynreg(k,l,nw), +c & fq_dynreg(k,l,nw) +c endif +! else +! if(fq_dynreg(k,l,nw).NE.0.) then +! print*,'nfq_dynreg = 0 tau,pc,nw',k,l,nw,fq_dynreg(k,l,nw) +! endif +c fq_dynreg(k,l,nw) = -1.E+20 +c nfq_dynreg(k,l,nw) = 1.E+20 +! end if +! enddo !k +! enddo !l +! enddo !nw +cIM ajout stats s/ W500 END +! ---------------------------------------------------! + +! ---------------------------------------------------! +! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM +! +!cIM +c if (debugcol.ne.0) then +! +c do j=1,npoints,debugcol + +c !produce character output +c do ilev=1,nlev +c do ibox=1,ncol +c acc(ilev,ibox)=0 +c enddo +c enddo + +c do ilev=1,nlev +c do ibox=1,ncol +c acc(ilev,ibox)=frac_out(j,ibox,ilev)*2 +c if (levmatch(j,ibox) .eq. ilev) +c & acc(ilev,ibox)=acc(ilev,ibox)+1 +c enddo +c enddo + + !print test + +c write(ftn09,11) j +c11 format('ftn09.',i4.4) +c open(9, FILE=ftn09, FORM='FORMATTED') + +c write(9,'(a1)') ' ' +c write(9,'(10i5)') +c & (ilev,ilev=5,nlev,5) +c write(9,'(a1)') ' ' + +c do ibox=1,ncol +c write(9,'(40(a1),1x,40(a1))') +c & (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) +c & ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) +c end do +c close(9) +c +cIM +c if (ncolprint.ne.0) then +c write(6,'(a1)') ' ' +c write(6,'(a2,1X,5(a7,1X),a50)') +c & 'ilev', +c & 'pfull','at', +c & 'cc*100','dem_s','dtau_s', +c & 'cchar' + +! do 4012 ilev=1,nlev +! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint) +! write(6,'(i2,1X,5(f7.2,1X),50(a1))') +! & ilev, +! & pfull(j,ilev)/100.,at(j,ilev), +! & cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev) +! & ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint) +!4012 continue +c write (6,'(a)') 'skt(j):' +c write (6,'(8f7.2)') skt(j) + +c write (6,'(8I7)') (ibox,ibox=1,ncolprint) + +c write (6,'(a)') 'tau:' +c write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'tb:' +c write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint) + +c write (6,'(a)') 'ptop:' +c write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint) +c endif + +c enddo + +c end if + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/limit_read_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/limit_read_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/limit_read_mod.F90 (revision 1634) @@ -0,0 +1,337 @@ +! +! $Header$ +! +MODULE limit_read_mod +! +! This module reads the fichier "limit.nc" containing fields for surface forcing. +! +! Module subroutines : +! limit_read_frac : call limit_read_tot and return the fractions +! limit_read_rug_alb : return rugosity and albedo, if coupled ocean call limit_read_tot first +! limit_read_sst : return sea ice temperature +! limit_read_tot : read limit.nc and store the fields in local modules variables +! + IMPLICIT NONE + + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE, PRIVATE :: pctsrf +!$OMP THREADPRIVATE(pctsrf) + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: rugos +!$OMP THREADPRIVATE(rugos) + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: albedo +!$OMP THREADPRIVATE(albedo) + REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE :: sst +!$OMP THREADPRIVATE(sst) + LOGICAL,SAVE :: read_continents=.FALSE. +!$OMP THREADPRIVATE(read_continents) + +CONTAINS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! Public subroutines : +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_frac(itime, dtime, jour, pctsrf_new, is_modified) +! +! This subroutine is called from "change_srf_frac" for case of +! ocean=force or from ocean_slab_frac for ocean=slab. +! The fraction for all sub-surfaces at actual time step is returned. + + USE dimphy + INCLUDE "indicesol.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! time step + INTEGER, INTENT(IN) :: jour ! current day + REAL , INTENT(IN) :: dtime ! length of time step + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,nbsrf), INTENT(OUT) :: pctsrf_new ! sub surface fractions + LOGICAL, INTENT(OUT) :: is_modified ! true if pctsrf is modified at this time step + +! End declaration +!**************************************************************************************** + +! 1) Read file limit.nc + CALL limit_read_tot(itime, dtime, jour, is_modified) + +! 2) Return the fraction read in limit_read_tot + pctsrf_new(:,:) = pctsrf(:,:) + + END SUBROUTINE limit_read_frac + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_rug_alb(itime, dtime, jour, & + knon, knindex, & + rugos_out, alb_out) +! +! This subroutine is called from surf_land_bucket. +! The flag "ok_veget" must can not be true. If coupled run, "ocean=couple" +! then this routine will call limit_read_tot. +! + USE dimphy + USE surface_data + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + INTEGER, INTENT(IN) :: knon ! nomber of points on compressed grid + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex ! grid point number for compressed grid +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: rugos_out + REAL, DIMENSION(klon), INTENT(OUT) :: alb_out + +! Local variables +!**************************************************************************************** + INTEGER :: i + LOGICAL :: is_modified +!**************************************************************************************** + + IF (type_ocean == 'couple') THEN + ! limit.nc has not yet been read. Do it now! + CALL limit_read_tot(itime, dtime, jour, is_modified) + END IF + + DO i=1,knon + rugos_out(i) = rugos(knindex(i)) + alb_out(i) = albedo(knindex(i)) + END DO + + END SUBROUTINE limit_read_rug_alb + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_sst(knon, knindex, sst_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) :: sst_out + + INTEGER :: i + + DO i = 1, knon + sst_out(i) = sst(knindex(i)) + END DO + + END SUBROUTINE limit_read_sst + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! Private subroutine : +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE limit_read_tot(itime, dtime, jour, is_modified) +! +! Read everything needed from limit.nc +! +! 0) Initialize +! 1) Open the file limit.nc, if it is time +! 2) Read fraction, if not type_ocean=couple +! 3) Read sea surface temperature, if not type_ocean=couple +! 4) Read albedo and rugosity for land surface, only in case of no vegetation model +! 5) Close file and distribuate variables to all processus + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE surface_data, ONLY : type_ocean, ok_veget + USE netcdf + + IMPLICIT NONE + + INCLUDE "indicesol.h" + +! In- and ouput arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + + LOGICAL, INTENT(OUT) :: is_modified ! true if pctsrf is modified at this time step + +! Locals variables with attribute SAVE +!**************************************************************************************** +! frequence de lecture des conditions limites (en pas de physique) + INTEGER,SAVE :: lmt_pas +!$OMP THREADPRIVATE(lmt_pas) + LOGICAL, SAVE :: first_call=.TRUE. +!$OMP THREADPRIVATE(first_call) +! Locals variables +!**************************************************************************************** + INTEGER :: nid, nvarid + INTEGER :: ii, ierr + INTEGER, DIMENSION(2) :: start, epais + REAL, DIMENSION(klon_glo,nbsrf) :: pct_glo ! fraction at global grid + REAL, DIMENSION(klon_glo) :: sst_glo ! sea-surface temperature at global grid + REAL, DIMENSION(klon_glo) :: rug_glo ! rugosity at global grid + REAL, DIMENSION(klon_glo) :: alb_glo ! albedo at global grid + CHARACTER(len=20) :: modname='limit_read_mod' + +! End declaration +!**************************************************************************************** + +!**************************************************************************************** +! 0) Initialization +! +!**************************************************************************************** + IF (first_call) THEN + ! calculate number of time steps for one day + lmt_pas = NINT(86400./dtime * 1.0) + + ! Allocate module save variables + IF ( type_ocean /= 'couple' ) THEN + ALLOCATE(pctsrf(klon,nbsrf), sst(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname, 'PB in allocating pctsrf and sst',1) + END IF + + IF ( .NOT. ok_veget ) THEN + ALLOCATE(rugos(klon), albedo(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm(modname, 'PB in allocating rugos and albedo',1) + END IF + + first_call=.FALSE. + ENDIF + +!**************************************************************************************** +! 1) Open the file limit.nc if it is the right moment to read, once a day. +! The file is read only by the master thread of the master mpi process(is_mpi_root) +! +!**************************************************************************************** + + is_modified = .FALSE. + IF (MOD(itime-1, lmt_pas) == 0) THEN ! time to read + is_modified = .TRUE. +!$OMP MASTER ! Only master thread + IF (is_mpi_root) THEN ! Only master processus + + ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,& + 'Pb d''ouverture du fichier de conditions aux limites',1) + + ! La tranche de donnees a lire: + start(1) = 1 + start(2) = jour + epais(1) = klon_glo + epais(2) = 1 + + +!**************************************************************************************** +! 2) Read fraction if not type_ocean=couple +! +!**************************************************************************************** + + IF ( type_ocean /= 'couple') THEN +! +! Ocean fraction + ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname, 'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_oce),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ' ,1) +! +! Sea-ice fraction + ierr = NF90_INQ_VARID(nid, 'FSIC', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_sic),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ' ,1) + + +! Read land and continentals fraction only if asked for + IF (read_continents .OR. itime == 1) THEN +! +! Land fraction + ierr = NF90_INQ_VARID(nid, 'FTER', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_ter),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) +! +! Continentale ice fraction + ierr = NF90_INQ_VARID(nid, 'FLIC', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_lic),start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) + END IF + + END IF ! type_ocean /= couple + +!**************************************************************************************** +! 3) Read sea-surface temperature, if not coupled ocean +! +!**************************************************************************************** + IF ( type_ocean /= 'couple') THEN + + ierr = NF90_INQ_VARID(nid, 'SST', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,sst_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) + + END IF + +!**************************************************************************************** +! 4) Read albedo and rugosity for land surface, only in case of no vegetation model +! +!**************************************************************************************** + + IF (.NOT. ok_veget) THEN +! +! Read albedo + ierr = NF90_INQ_VARID(nid, 'ALB', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,alb_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) +! +! Read rugosity + ierr = NF90_INQ_VARID(nid, 'RUG', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ est absent',1) + + ierr = NF90_GET_VAR(nid,nvarid,rug_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour ',1) + + END IF + +!**************************************************************************************** +! 5) Close file and distribuate variables to all processus +! +!**************************************************************************************** + ierr = NF90_CLOSE(nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Pb when closing file', 1) + ENDIF ! is_mpi_root + +!$OMP END MASTER +!$OMP BARRIER + + IF ( type_ocean /= 'couple') THEN + CALL Scatter(sst_glo,sst) + CALL Scatter(pct_glo(:,is_oce),pctsrf(:,is_oce)) + CALL Scatter(pct_glo(:,is_sic),pctsrf(:,is_sic)) + IF (read_continents .OR. itime == 1) THEN + CALL Scatter(pct_glo(:,is_ter),pctsrf(:,is_ter)) + CALL Scatter(pct_glo(:,is_lic),pctsrf(:,is_lic)) + END IF + END IF + + IF (.NOT. ok_veget) THEN + CALL Scatter(alb_glo, albedo) + CALL Scatter(rug_glo, rugos) + END IF + + ENDIF ! time to read + + END SUBROUTINE limit_read_tot + + +END MODULE limit_read_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/limit_slab.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/limit_slab.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/limit_slab.F90 (revision 1634) @@ -0,0 +1,122 @@ +! $Header$ + +SUBROUTINE limit_slab(itime, dtime, jour, lmt_bils, lmt_foce, diff_sst) + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE netcdf + + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "clesphys.h" + INCLUDE "dimensions.h" + +! In- and ouput arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils, lmt_foce, diff_sst + +! Locals variables with attribute SAVE +!**************************************************************************************** + REAL, DIMENSION(:), ALLOCATABLE, SAVE :: bils_save, foce_save +!$OMP THREADPRIVATE(bils_save, foce_save) + +! Locals variables +!**************************************************************************************** + INTEGER :: lmt_pas + INTEGER :: nvarid, nid, ierr, i + INTEGER, DIMENSION(2) :: start, epais + REAL, DIMENSION(klon_glo):: bils_glo, foce_glo, sst_l_glo, sst_lp1_glo, diff_sst_glo + CHARACTER (len = 20) :: modname = 'limit_slab' + +! End declaration +!**************************************************************************************** + + ! calculate number of time steps for one day + lmt_pas = NINT(86400./dtime) + + IF (MOD(itime-1, lmt_pas) == 0) THEN ! time to read + !$OMP MASTER ! Only master thread + IF (is_mpi_root) THEN ! Only master processus + print*,'in limit_slab time to read, itime=',itime + + ierr = NF90_OPEN ('limit_slab.nc', NF90_NOWRITE, nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,& + 'Pb in opening file limit_slab.nc',1) + + ! La tranche de donnees a lire: + start(1) = 1 + start(2) = jour + epais(1) = klon_glo + epais(2) = 1 + +!**************************************************************************************** +! 2) Read bils and ocean fraction +! +!**************************************************************************************** +! +! Read bils_glo + ierr = NF90_INQ_VARID(nid, 'BILS_OCE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable is abstent',1) + + ierr = NF90_GET_VAR(nid,nvarid,bils_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of failed',1) +! +! Read foce_glo + ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable is abstent',1) + + ierr = NF90_GET_VAR(nid,nvarid,foce_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of failed',1) +! +! Read sst_glo for this day + ierr = NF90_INQ_VARID(nid, 'SST', nvarid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable is abstent',1) + + ierr = NF90_GET_VAR(nid,nvarid,sst_l_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of failed',1) + +! Read sst_glo for one day ahead + start(2) = jour + 1 + IF (start(2) > 360) start(2)=1 + ierr = NF90_GET_VAR(nid,nvarid,sst_lp1_glo,start,epais) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of day+1 failed',1) + +! Calculate difference in temperature between this day and one ahead + DO i=1, klon_glo-1 + diff_sst_glo(i) = sst_lp1_glo(i) - sst_l_glo(i) + END DO + diff_sst_glo(klon_glo) = sst_lp1_glo(klon_glo) - sst_l_glo(1) + +!**************************************************************************************** +! 5) Close file and distribuate variables to all processus +! +!**************************************************************************************** + ierr = NF90_CLOSE(nid) + IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Pb when closing file', 1) + ENDIF ! is_mpi_root + +!$OMP END MASTER + + IF (.NOT. ALLOCATED(bils_save)) THEN + ALLOCATE(bils_save(klon), foce_save(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('limit_slab', 'pb in allocation',1) + END IF + + CALL Scatter(bils_glo, bils_save) + CALL Scatter(foce_glo, foce_save) + CALL Scatter(diff_sst_glo, diff_sst) + + ELSE ! not time to read + diff_sst(:) = 0. + ENDIF ! time to read + + lmt_bils(:) = bils_save(:) + lmt_foce(:) = foce_save(:) + +END SUBROUTINE limit_slab Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/lnblnk1.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/lnblnk1.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/lnblnk1.F (revision 1634) @@ -0,0 +1,47 @@ +! +! $Header$ +! + INTEGER FUNCTION lnblnk1 (letter) + +C-------------------------------------------------------- +C Fonction qui determine la longeur d'un string sans les +C blancs qui suivent. Le critere pour determiner la fin du +C string est, trois blancs de suite +C--------------------------------------------------------- +C ARGUMENTS +C +++++++++ +C letter: CHARACTER*xxx (xxx < imax) +C le string dont on determine la longuer +C lnblnk1: INTEGER +C le nombre de characteres +C +C PARAMETER +C +++++++++ +C imax : INTEGER +C le nombre maximale de character que peut contenir le string +C a traiter + + IMPLICIT NONE + INTEGER i,imax + PARAMETER (imax = 256) +c CHARACTER*256 letter + CHARACTER*4 letter + + i=0 + +10 i=i+1 +c IF (letter(i:i+1) . EQ . ' ') THEN + IF (letter(i:i) . EQ . ' ') THEN +c print*,'i=',i,'letter(i:i+1)=',letter(i:i+1) +c print*,'i=',i + GOTO 20 + ELSE + GOTO 10 + ENDIF + +20 lnblnk1=i-1 +c PRINT*,'lnblnk1=',lnblnk1 + + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/minmaxqfi.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/minmaxqfi.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/minmaxqfi.F90 (revision 1634) @@ -0,0 +1,33 @@ +! +! $Id$ +! +SUBROUTINE minmaxqfi(zq,qmin,qmax,comment) + USE dimphy + IMPLICIT NONE + +! Entrees + REAL,DIMENSION(klon,klev), INTENT(IN) :: zq + REAL,INTENT(IN) :: qmin,qmax + CHARACTER(LEN=*),INTENT(IN) :: comment + +! Local + INTEGER,DIMENSION(klon) :: jadrs + INTEGER :: i, jbad, k + + DO k = 1, klev + jbad = 0 + DO i = 1, klon + IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN + jbad = jbad + 1 + jadrs(jbad) = i + ENDIF + ENDDO + IF (jbad.GT.0) THEN + WRITE(*,*)comment + DO i = 1, jbad + WRITE(*,*) "i,k,q=", jadrs(i),k,zq(jadrs(i),k) + ENDDO + ENDIF + ENDDO + +END SUBROUTINE minmaxqfi Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mkstat.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mkstat.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mkstat.F90 (revision 1634) @@ -0,0 +1,164 @@ +subroutine mkstats(ierr) + + +! +! This program writes a stats.nc file from sums and sums of squares +! to means and standard deviations and also writes netcdf style +! file so that the data can be viewed easily. The data file is +! overwritten in place. +! SRL 21 May 1996 +! Yann W. july 2003 + + +implicit none + +#include "dimensions.h" +#include "statto.h" +#include "netcdf.inc" + +integer,parameter :: iip1=iim+1 +integer,parameter :: jjp1=jjm+1 +integer :: ierr,nid,nbvar,i,ndims,lt,nvarid +integer, dimension(4) :: id,varid,start,size +integer, dimension(5) :: dimids +character (len=50) :: name,nameout,units,title +real, dimension(iip1,jjp1,llm) :: sum3d,square3d,mean3d,sd3d +real, dimension(iip1,jjp1) :: sum2d,square2d,mean2d,sd2d +real, dimension(istime) :: time +real, dimension(jjp1) :: lat +real, dimension(iip1) :: lon +real, dimension(llm) :: alt +logical :: lcopy=.true. +!integer :: latid,lonid,altid,timeid +integer :: meanid,sdid +!integer, dimension(4) :: dimout + +! Incrementation of count for the last step, which is not done in wstats +count(istime)=count(istime)+1 + +ierr = NF_OPEN("stats.nc",NF_WRITE,nid) + +! We catch the id of dimensions of the stats file + +ierr= NF_INQ_DIMID(nid,"latitude",id(1)) +ierr= NF_INQ_DIMID(nid,"longitude",id(2)) +ierr= NF_INQ_DIMID(nid,"altitude",id(3)) +ierr= NF_INQ_DIMID(nid,"Time",id(4)) + +ierr= NF_INQ_VARID(nid,"latitude",varid(1)) +ierr= NF_INQ_VARID(nid,"longitude",varid(2)) +ierr= NF_INQ_VARID(nid,"altitude",varid(3)) +ierr= NF_INQ_VARID(nid,"Time",varid(4)) + +! Time initialisation + +do i=1,istime + time(i)=i*24./istime +#ifdef NC_DOUBLE + ierr= NF_PUT_VARA_DOUBLE(nid,varid(4),i,1,time(i)) +#else + ierr= NF_PUT_VARA_REAL(nid,varid(4),i,1,time(i)) +#endif +enddo + +! We catche the values of the variables + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid,varid(1),lat) + ierr = NF_GET_VAR_DOUBLE(nid,varid(2),lon) + ierr = NF_GET_VAR_DOUBLE(nid,varid(3),alt) +#else + ierr = NF_GET_VAR_REAL(nid,varid(1),lat) + ierr = NF_GET_VAR_REAL(nid,varid(2),lon) + ierr = NF_GET_VAR_REAL(nid,varid(3),alt) +#endif + +! We catch the number of variables in the stats file +ierr = NF_INQ_NVARS(nid,nbvar) + +! to catche the "real" number of variables (without the "additionnal variables") +nbvar=(nbvar-4)/2 + +do i=1,nbvar + varid=(i-1)*2+5 + + ! What's the variable's name? + ierr=NF_INQ_VARNAME(nid,varid,name) + write(*,*) "OK variable ",name + ! Its units? + units=" " + ierr=NF_GET_ATT_TEXT(nid,varid,"units",units) + ! Its title? + title=" " + ierr=NF_GET_ATT_TEXT(nid,varid,"title",title) + ! Its number of dimensions? + ierr=NF_INQ_VARNDIMS(nid,varid,ndims) + ! Its values? + + if(ndims==4) then ! lat, lon, alt & time + +! dimout(1)=lonid +! dimout(2)=latid +! dimout(3)=altid +! dimout(4)=timeid + + size=(/iip1,jjp1,llm,1/) + do lt=1,istime + start=(/1,1,1,lt/) + ! Extraction of the "source" variables +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum3d) + ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square3d) +#else + ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum3d) + ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square3d) +#endif + ! Calculation of these variables + mean3d=sum3d/count(lt) + sd3d=sqrt(max(0.,square3d/count(lt)-mean3d**2)) + ! Writing of the variables +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean3d) + ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd3d) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean3d) + ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd3d) +#endif + enddo + + else if (ndims.eq.3) then + +! dimout(1)=lonid +! dimout(2)=latid +! dimout(3)=timeid + + size=(/iip1,jjp1,1,0/) + do lt=1,istime + start=(/1,1,lt,0/) + ! Extraction of the "source" variables +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum2d) + ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square2d) +#else + ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum2d) + ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square2d) +#endif + ! Calculation of these variables + mean2d=sum2d/count(lt) + sd2d=sqrt(max(0.,square2d/count(lt)-mean2d**2)) + ! Writing of the variables +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean2d) + ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd2d) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean2d) + ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd2d) +#endif + enddo + + endif +enddo + +ierr= NF_CLOSE(nid) + +end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_grid_phy_lmdz.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_grid_phy_lmdz.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_grid_phy_lmdz.F90 (revision 1634) @@ -0,0 +1,447 @@ +! +!$Header$ +! +MODULE mod_grid_phy_lmdz + INTEGER,SAVE :: nbp_lon ! == iim + INTEGER,SAVE :: nbp_lat ! == jjmp1 + INTEGER,SAVE :: nbp_lev ! == llm + INTEGER,SAVE :: klon_glo + + INTERFACE grid1dTo2d_glo + MODULE PROCEDURE grid1dTo2d_glo_i,grid1dTo2d_glo_i1,grid1dTo2d_glo_i2,grid1dTo2d_glo_i3, & + grid1dTo2d_glo_r,grid1dTo2d_glo_r1,grid1dTo2d_glo_r2,grid1dTo2d_glo_r3, & + grid1dTo2d_glo_l,grid1dTo2d_glo_l1,grid1dTo2d_glo_l2,grid1dTo2d_glo_l3 + END INTERFACE + + INTERFACE grid2dTo1d_glo + MODULE PROCEDURE grid2dTo1d_glo_i,grid2dTo1d_glo_i1,grid2dTo1d_glo_i2,grid2dTo1d_glo_i3, & + grid2dTo1d_glo_r,grid2dTo1d_glo_r1,grid2dTo1d_glo_r2,grid2dTo1d_glo_r3, & + grid2dTo1d_glo_l,grid2dTo1d_glo_l1,grid2dTo1d_glo_l2,grid2dTo1d_glo_l3 + END INTERFACE + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! SUBROUTINE grid1dTo2d !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + SUBROUTINE Init_grid_phy_lmdz(iim,jjp1,llm) + IMPLICIT NONE + INTEGER, INTENT(in) :: iim + INTEGER, INTENT(in) :: jjp1 + INTEGER, INTENT(in) :: llm + + nbp_lon=iim + nbp_lat=jjp1 + nbp_lev=llm + klon_glo=(iim*jjp1)-2*(iim-1) + + END SUBROUTINE Init_grid_phy_lmdz + + + SUBROUTINE grid1dTo2d_glo_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_glo_i + + + SUBROUTINE grid1dTo2d_glo_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_glo_i1 + + SUBROUTINE grid1dTo2d_glo_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_glo_i2 + + SUBROUTINE grid1dTo2d_glo_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_glo_i3 + + + SUBROUTINE grid1dTo2d_glo_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_glo_r + + + SUBROUTINE grid1dTo2d_glo_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_glo_r1 + + SUBROUTINE grid1dTo2d_glo_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_glo_r2 + + SUBROUTINE grid1dTo2d_glo_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_glo_r3 + + + + SUBROUTINE grid1dTo2d_glo_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_glo_l + + + SUBROUTINE grid1dTo2d_glo_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_glo_l1 + + SUBROUTINE grid1dTo2d_glo_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_glo_l2 + + SUBROUTINE grid1dTo2d_glo_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_glo_l3 + + SUBROUTINE grid2dTo1d_glo_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_glo_i + + + SUBROUTINE grid2dTo1d_glo_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_glo_i1 + + SUBROUTINE grid2dTo1d_glo_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_glo_i2 + + SUBROUTINE grid2dTo1d_glo_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_glo_i3 + + + + + SUBROUTINE grid2dTo1d_glo_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_glo_r + + + SUBROUTINE grid2dTo1d_glo_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_glo_r1 + + SUBROUTINE grid2dTo1d_glo_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_glo_r2 + + SUBROUTINE grid2dTo1d_glo_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_glo_r3 + + + + SUBROUTINE grid2dTo1d_glo_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_glo_l + + + SUBROUTINE grid2dTo1d_glo_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_glo_l1 + + SUBROUTINE grid2dTo1d_glo_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_glo_l2 + + SUBROUTINE grid2dTo1d_glo_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_glo_l3 + +END MODULE mod_grid_phy_lmdz + + + + SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(klon_glo,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + Offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon + VarOut(ij,i)=VarIn(klon_glo,i) + ENDDO + ENDDO + + END SUBROUTINE grid1dTo2d_glo_igen + + + SUBROUTINE grid1dTo2d_glo_rgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + Offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon + VarOut(ij,i)=VarIn(klon_glo,i) + ENDDO + ENDDO + + END SUBROUTINE grid1dTo2d_glo_rgen + + SUBROUTINE grid1dTo2d_glo_lgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + Offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + + + DO i=1,dimsize + DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon + VarOut(ij,i)=VarIn(klon_glo,i) + ENDDO + ENDDO + + END SUBROUTINE grid1dTo2d_glo_lgen + + + SUBROUTINE grid2dTo1d_glo_igen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + + END SUBROUTINE grid2dTo1d_glo_igen + + SUBROUTINE grid2dTo1d_glo_rgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + + END SUBROUTINE grid2dTo1d_glo_rgen + + SUBROUTINE grid2dTo1d_glo_lgen(VarIn,VarOut,dimsize) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_glo + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + + END SUBROUTINE grid2dTo1d_glo_lgen Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_mpi_data.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_mpi_data.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_mpi_data.F90 (revision 1634) @@ -0,0 +1,203 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_mpi_data + USE mod_const_mpi + + INTEGER,SAVE :: ii_begin + INTEGER,SAVE :: ii_end + INTEGER,SAVE :: jj_begin + INTEGER,SAVE :: jj_end + INTEGER,SAVE :: jj_nb + INTEGER,SAVE :: ij_begin + INTEGER,SAVE :: ij_end + INTEGER,SAVE :: ij_nb + INTEGER,SAVE :: klon_mpi_begin + INTEGER,SAVE :: klon_mpi_end + INTEGER,SAVE :: klon_mpi + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_nb + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_end + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_end + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_nb + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_end + + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_nb + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_begin + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_end + + + INTEGER,SAVE :: mpi_rank + INTEGER,SAVE :: mpi_size + INTEGER,SAVE :: mpi_root + LOGICAL,SAVE :: is_mpi_root + LOGICAL,SAVE :: is_using_mpi + + + LOGICAL,SAVE :: is_north_pole + LOGICAL,SAVE :: is_south_pole + INTEGER,SAVE :: COMM_LMDZ_PHY + +CONTAINS + + SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib) + USE mod_const_mpi, ONLY : COMM_LMDZ + IMPLICIT NONE + INTEGER,INTENT(in) :: iim + INTEGER,INTENT(in) :: jjp1 + INTEGER,INTENT(in) :: nb_proc + INTEGER,INTENT(in) :: distrib(0:nb_proc-1) + + INTEGER :: ierr + INTEGER :: klon_glo + INTEGER :: i + +#ifdef CPP_MPI + is_using_mpi=.TRUE. +#else + is_using_mpi=.FALSE. +#endif + + if (iim.eq.1) then + klon_glo=1 + else + klon_glo=iim*(jjp1-2)+2 + endif + + COMM_LMDZ_PHY=COMM_LMDZ + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr) + CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr) +#endif + ELSE + mpi_size=1 + mpi_rank=0 + ENDIF + + IF (mpi_rank == 0) THEN + mpi_root = 0 + is_mpi_root = .true. + ENDIF + + IF (mpi_rank == 0) THEN + is_north_pole = .TRUE. + ELSE + is_north_pole = .FALSE. + ENDIF + + IF (mpi_rank == mpi_size-1) THEN + is_south_pole = .TRUE. + ELSE + is_south_pole = .FALSE. + ENDIF + + ALLOCATE(jj_para_nb(0:mpi_size-1)) + ALLOCATE(jj_para_begin(0:mpi_size-1)) + ALLOCATE(jj_para_end(0:mpi_size-1)) + + ALLOCATE(ij_para_nb(0:mpi_size-1)) + ALLOCATE(ij_para_begin(0:mpi_size-1)) + ALLOCATE(ij_para_end(0:mpi_size-1)) + + ALLOCATE(ii_para_begin(0:mpi_size-1)) + ALLOCATE(ii_para_end(0:mpi_size-1)) + + ALLOCATE(klon_mpi_para_nb(0:mpi_size-1)) + ALLOCATE(klon_mpi_para_begin(0:mpi_size-1)) + ALLOCATE(klon_mpi_para_end(0:mpi_size-1)) + + + klon_mpi_para_nb(0:mpi_size-1)=distrib(0:nb_proc-1) + + DO i=0,mpi_size-1 + IF (i==0) THEN + klon_mpi_para_begin(i)=1 + ELSE + klon_mpi_para_begin(i)=klon_mpi_para_end(i-1)+1 + ENDIF + klon_mpi_para_end(i)=klon_mpi_para_begin(i)+klon_mpi_para_nb(i)-1 + ENDDO + + + DO i=0,mpi_size-1 + + IF (i==0) THEN + ij_para_begin(i) = 1 + ELSE + ij_para_begin(i) = klon_mpi_para_begin(i)+iim-1 + ENDIF + + jj_para_begin(i) = (ij_para_begin(i)-1)/iim + 1 + ii_para_begin(i) = MOD(ij_para_begin(i)-1,iim) + 1 + + + ij_para_end(i) = klon_mpi_para_end(i)+iim-1 + jj_para_end(i) = (ij_para_end(i)-1)/iim + 1 + ii_para_end(i) = MOD(ij_para_end(i)-1,iim) + 1 + + + ij_para_nb(i) = ij_para_end(i)-ij_para_begin(i)+1 + jj_para_nb(i) = jj_para_end(i)-jj_para_begin(i)+1 + + ENDDO + + ii_begin = ii_para_begin(mpi_rank) + ii_end = ii_para_end(mpi_rank) + jj_begin = jj_para_begin(mpi_rank) + jj_end = jj_para_end(mpi_rank) + jj_nb = jj_para_nb(mpi_rank) + ij_begin = ij_para_begin(mpi_rank) + ij_end = ij_para_end(mpi_rank) + ij_nb = ij_para_nb(mpi_rank) + klon_mpi_begin = klon_mpi_para_begin(mpi_rank) + klon_mpi_end = klon_mpi_para_end(mpi_rank) + klon_mpi = klon_mpi_para_nb(mpi_rank) + + CALL Print_module_data + + END SUBROUTINE Init_phys_lmdz_mpi_data + + SUBROUTINE print_module_data + IMPLICIT NONE + + + PRINT *, 'ii_begin =', ii_begin + PRINT *, 'ii_end =', ii_end + PRINT *, 'jj_begin =',jj_begin + PRINT *, 'jj_end =', jj_end + PRINT *, 'jj_nb =', jj_nb + PRINT *, 'ij_begin =', ij_begin + PRINT *, 'ij_end =', ij_end + PRINT *, 'ij_nb =', ij_nb + PRINT *, 'klon_mpi_begin =', klon_mpi_begin + PRINT *, 'klon_mpi_end =', klon_mpi_end + PRINT *, 'klon_mpi =', klon_mpi + PRINT *, 'jj_para_nb =', jj_para_nb + PRINT *, 'jj_para_begin =', jj_para_begin + PRINT *, 'jj_para_end =', jj_para_end + PRINT *, 'ii_para_begin =', ii_para_begin + PRINT *, 'ii_para_end =', ii_para_end + PRINT *, 'ij_para_nb =', ij_para_nb + PRINT *, 'ij_para_begin =', ij_para_begin + PRINT *, 'ij_para_end =', ij_para_end + PRINT *, 'klon_mpi_para_nb =', klon_mpi_para_nb + PRINT *, 'klon_mpi_para_begin =', klon_mpi_para_begin + PRINT *, 'klon_mpi_para_end =', klon_mpi_para_end + PRINT *, 'mpi_rank =', mpi_rank + PRINT *, 'mpi_size =', mpi_size + PRINT *, 'mpi_root =', mpi_root + PRINT *, 'is_mpi_root =', is_mpi_root + PRINT *, 'is_north_pole =', is_north_pole + PRINT *, 'is_south_pole =', is_south_pole + PRINT *, 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY + + END SUBROUTINE print_module_data + +END MODULE mod_phys_lmdz_mpi_data Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90 (revision 1634) @@ -0,0 +1,1902 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_mpi_transfert + + + INTERFACE bcast_mpi + MODULE PROCEDURE bcast_mpi_c, & + bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, & + bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, & + bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4 + END INTERFACE + + INTERFACE scatter_mpi + MODULE PROCEDURE scatter_mpi_i,scatter_mpi_i1,scatter_mpi_i2,scatter_mpi_i3, & + scatter_mpi_r,scatter_mpi_r1,scatter_mpi_r2,scatter_mpi_r3, & + scatter_mpi_l,scatter_mpi_l1,scatter_mpi_l2,scatter_mpi_l3 + END INTERFACE + + + INTERFACE gather_mpi + MODULE PROCEDURE gather_mpi_i,gather_mpi_i1,gather_mpi_i2,gather_mpi_i3, & + gather_mpi_r,gather_mpi_r1,gather_mpi_r2,gather_mpi_r3, & + gather_mpi_l,gather_mpi_l1,gather_mpi_l2,gather_mpi_l3 + END INTERFACE + + INTERFACE scatter2D_mpi + MODULE PROCEDURE scatter2D_mpi_i,scatter2D_mpi_i1,scatter2D_mpi_i2,scatter2D_mpi_i3, & + scatter2D_mpi_r,scatter2D_mpi_r1,scatter2D_mpi_r2,scatter2D_mpi_r3, & + scatter2D_mpi_l,scatter2D_mpi_l1,scatter2D_mpi_l2,scatter2D_mpi_l3 + END INTERFACE + + INTERFACE gather2D_mpi + MODULE PROCEDURE gather2D_mpi_i,gather2D_mpi_i1,gather2D_mpi_i2,gather2D_mpi_i3, & + gather2D_mpi_r,gather2D_mpi_r1,gather2D_mpi_r2,gather2D_mpi_r3, & + gather2D_mpi_l,gather2D_mpi_l1,gather2D_mpi_l2,gather2D_mpi_l3 + END INTERFACE + + INTERFACE reduce_sum_mpi + MODULE PROCEDURE reduce_sum_mpi_i,reduce_sum_mpi_i1,reduce_sum_mpi_i2,reduce_sum_mpi_i3,reduce_sum_mpi_i4, & + reduce_sum_mpi_r,reduce_sum_mpi_r1,reduce_sum_mpi_r2,reduce_sum_mpi_r3,reduce_sum_mpi_r4 + END INTERFACE + + INTERFACE grid1dTo2d_mpi + MODULE PROCEDURE grid1dTo2d_mpi_i,grid1dTo2d_mpi_i1,grid1dTo2d_mpi_i2,grid1dTo2d_mpi_i3, & + grid1dTo2d_mpi_r,grid1dTo2d_mpi_r1,grid1dTo2d_mpi_r2,grid1dTo2d_mpi_r3, & + grid1dTo2d_mpi_l,grid1dTo2d_mpi_l1,grid1dTo2d_mpi_l2,grid1dTo2d_mpi_l3 + END INTERFACE + + INTERFACE grid2dTo1d_mpi + MODULE PROCEDURE grid2dTo1d_mpi_i,grid2dTo1d_mpi_i1,grid2dTo1d_mpi_i2,grid2dTo1d_mpi_i3, & + grid2dTo1d_mpi_r,grid2dTo1d_mpi_r1,grid2dTo1d_mpi_r2,grid2dTo1d_mpi_r3, & + grid2dTo1d_mpi_l,grid2dTo1d_mpi_l1,grid2dTo1d_mpi_l2,grid2dTo1d_mpi_l3 + END INTERFACE + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Broadcast --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! -- Les chaine de charactère -- !! + + SUBROUTINE bcast_mpi_c(var1) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(INOUT) :: Var1 + + CALL bcast_mpi_cgen(Var1,len(Var1)) + + END SUBROUTINE bcast_mpi_c + +!! -- Les entiers -- !! + + SUBROUTINE bcast_mpi_i(var) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var + + INTEGER :: var_tmp(1) + + IF (is_mpi_root) var_tmp(1)=var + CALL bcast_mpi_igen(Var_tmp,1) + var=var_tmp(1) + + END SUBROUTINE bcast_mpi_i + + SUBROUTINE bcast_mpi_i1(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i1 + + SUBROUTINE bcast_mpi_i2(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i2 + + SUBROUTINE bcast_mpi_i3(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i3 + + SUBROUTINE bcast_mpi_i4(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:,:) + + CALL bcast_mpi_igen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_i4 + + +!! -- Les reels -- !! + + SUBROUTINE bcast_mpi_r(var) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var + REAL :: var_tmp(1) + + IF (is_mpi_root) var_tmp(1)=var + CALL bcast_mpi_rgen(Var_tmp,1) + var=var_tmp(1) + + END SUBROUTINE bcast_mpi_r + + SUBROUTINE bcast_mpi_r1(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r1 + + SUBROUTINE bcast_mpi_r2(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r2 + + SUBROUTINE bcast_mpi_r3(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r3 + + SUBROUTINE bcast_mpi_r4(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL bcast_mpi_rgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_r4 + +!! -- Les booleans -- !! + + SUBROUTINE bcast_mpi_l(var) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var + LOGICAL :: var_tmp(1) + + IF (is_mpi_root) var_tmp(1)=var + CALL bcast_mpi_lgen(Var_tmp,1) + var=var_tmp(1) + + END SUBROUTINE bcast_mpi_l + + SUBROUTINE bcast_mpi_l1(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l1 + + SUBROUTINE bcast_mpi_l2(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l2 + + SUBROUTINE bcast_mpi_l3(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l3 + + SUBROUTINE bcast_mpi_l4(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL bcast_mpi_lgen(Var,size(Var)) + + END SUBROUTINE bcast_mpi_l4 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter_mpi_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,1) + + END SUBROUTINE scatter_mpi_i + + SUBROUTINE scatter_mpi_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)) + + END SUBROUTINE scatter_mpi_i1 + + SUBROUTINE scatter_mpi_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)) + + END SUBROUTINE scatter_mpi_i2 + + SUBROUTINE scatter_mpi_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4)) + + END SUBROUTINE scatter_mpi_i3 + + + SUBROUTINE scatter_mpi_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,1) + + END SUBROUTINE scatter_mpi_r + + SUBROUTINE scatter_mpi_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)) + + END SUBROUTINE scatter_mpi_r1 + + SUBROUTINE scatter_mpi_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)) + + END SUBROUTINE scatter_mpi_r2 + + SUBROUTINE scatter_mpi_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4)) + + END SUBROUTINE scatter_mpi_r3 + + + SUBROUTINE scatter_mpi_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,1) + + END SUBROUTINE scatter_mpi_l + + SUBROUTINE scatter_mpi_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)) + + END SUBROUTINE scatter_mpi_l1 + + SUBROUTINE scatter_mpi_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)) + + END SUBROUTINE scatter_mpi_l2 + + SUBROUTINE scatter_mpi_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4)) + + END SUBROUTINE scatter_mpi_l3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!! --> Les entiers + + SUBROUTINE gather_mpi_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,1) + + END SUBROUTINE gather_mpi_i + + +!!!!! + + SUBROUTINE gather_mpi_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)) + + END SUBROUTINE gather_mpi_i1 + +!!!!! + + SUBROUTINE gather_mpi_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)) + + END SUBROUTINE gather_mpi_i2 + +!!!!! + + SUBROUTINE gather_mpi_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4)) + + END SUBROUTINE gather_mpi_i3 + +!!!!! --> Les reels + + SUBROUTINE gather_mpi_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,1) + + END SUBROUTINE gather_mpi_r + +!!!!! + + SUBROUTINE gather_mpi_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)) + + END SUBROUTINE gather_mpi_r1 + +!!!!! + + SUBROUTINE gather_mpi_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)) + + END SUBROUTINE gather_mpi_r2 + +!!!!! + + SUBROUTINE gather_mpi_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4)) + + END SUBROUTINE gather_mpi_r3 + +!!!!! --> Les booleen + + SUBROUTINE gather_mpi_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,1) + + END SUBROUTINE gather_mpi_l + +!!!!! + + SUBROUTINE gather_mpi_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)) + + END SUBROUTINE gather_mpi_l1 + +!!!!! + + SUBROUTINE gather_mpi_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)) + + END SUBROUTINE gather_mpi_l2 + +!!!!! + + SUBROUTINE gather_mpi_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4)) + + END SUBROUTINE gather_mpi_l3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter2D_mpi_i(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(klon_glo) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i + + SUBROUTINE scatter2D_mpi_i1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + INTEGER,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i1 + + SUBROUTINE scatter2D_mpi_i2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i2 + + SUBROUTINE scatter2D_mpi_i3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_i3 + + + + SUBROUTINE scatter2D_mpi_r(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(klon_glo) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_R + + + SUBROUTINE scatter2D_mpi_r1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_r1 + + + SUBROUTINE scatter2D_mpi_r2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_r2 + + SUBROUTINE scatter2D_mpi_r3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_r3 + + + SUBROUTINE scatter2D_mpi_l(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL,DIMENSION(klon_glo) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l + + + SUBROUTINE scatter2D_mpi_l1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l1 + + + SUBROUTINE scatter2D_mpi_l2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL, DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l2 + + SUBROUTINE scatter2D_mpi_l3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp + + CALL grid2dTo1d_glo(VarIn,Var_tmp) + CALL scatter_mpi(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_mpi_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE gather2D_mpi_i(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i + + SUBROUTINE gather2D_mpi_i1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i1 + + SUBROUTINE gather2D_mpi_i2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i2 + + SUBROUTINE gather2D_mpi_i3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_i3 + + + + SUBROUTINE gather2D_mpi_r(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_glo) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r + + SUBROUTINE gather2D_mpi_r1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r1 + + SUBROUTINE gather2D_mpi_r2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r2 + + SUBROUTINE gather2D_mpi_r3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_r3 + + + + SUBROUTINE gather2D_mpi_l(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l + + SUBROUTINE gather2D_mpi_l1(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l1 + + SUBROUTINE gather2D_mpi_l2(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l2 + + SUBROUTINE gather2D_mpi_l3(VarIn, VarOut) + USE mod_grid_phy_lmdz + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp + + CALL gather_mpi(VarIn,Var_tmp) + CALL grid1dTo2d_glo(Var_tmp,VarOut) + + END SUBROUTINE gather2D_mpi_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des reduce_sum --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE reduce_sum_mpi_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN) :: VarIn + INTEGER,INTENT(OUT) :: VarOut + INTEGER :: VarIn_tmp(1) + INTEGER :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL reduce_sum_mpi_igen(VarIn_tmp,Varout_tmp,1) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_mpi_i + + SUBROUTINE reduce_sum_mpi_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i1 + + SUBROUTINE reduce_sum_mpi_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i2 + + SUBROUTINE reduce_sum_mpi_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i3 + + SUBROUTINE reduce_sum_mpi_i4(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_i4 + + + SUBROUTINE reduce_sum_mpi_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN) :: VarIn + REAL,INTENT(OUT) :: VarOut + REAL :: VarIn_tmp(1) + REAL :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL reduce_sum_mpi_rgen(VarIn_tmp,Varout_tmp,1) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_mpi_r + + SUBROUTINE reduce_sum_mpi_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r1 + + SUBROUTINE reduce_sum_mpi_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r2 + + SUBROUTINE reduce_sum_mpi_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r3 + + SUBROUTINE reduce_sum_mpi_r4(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn)) + + END SUBROUTINE reduce_sum_mpi_r4 + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! SUBROUTINE grid1dTo2d !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + SUBROUTINE grid1dTo2d_mpi_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_mpi_i + + + SUBROUTINE grid1dTo2d_mpi_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_mpi_i1 + + SUBROUTINE grid1dTo2d_mpi_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_mpi_i2 + + SUBROUTINE grid1dTo2d_mpi_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_mpi_i3 + + + SUBROUTINE grid1dTo2d_mpi_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_mpi_r + + + SUBROUTINE grid1dTo2d_mpi_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_mpi_r1 + + SUBROUTINE grid1dTo2d_mpi_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_mpi_r2 + + SUBROUTINE grid1dTo2d_mpi_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_mpi_r3 + + + + SUBROUTINE grid1dTo2d_mpi_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid1dTo2d_mpi_l + + + SUBROUTINE grid1dTo2d_mpi_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)) + + END SUBROUTINE grid1dTo2d_mpi_l1 + + SUBROUTINE grid1dTo2d_mpi_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)) + + END SUBROUTINE grid1dTo2d_mpi_l2 + + SUBROUTINE grid1dTo2d_mpi_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid1dTo2d_mpi_l3 + + + SUBROUTINE grid2dTo1d_mpi_i(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_mpi_i + + + SUBROUTINE grid2dTo1d_mpi_i1(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_mpi_i1 + + SUBROUTINE grid2dTo1d_mpi_i2(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_mpi_i2 + + SUBROUTINE grid2dTo1d_mpi_i3(VarIn,VarOut) + IMPLICIT NONE + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_mpi_i3 + + + + + SUBROUTINE grid2dTo1d_mpi_r(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_mpi_r + + + SUBROUTINE grid2dTo1d_mpi_r1(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_mpi_r1 + + SUBROUTINE grid2dTo1d_mpi_r2(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_mpi_r2 + + SUBROUTINE grid2dTo1d_mpi_r3(VarIn,VarOut) + IMPLICIT NONE + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_mpi_r3 + + + + SUBROUTINE grid2dTo1d_mpi_l(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,1) + + END SUBROUTINE grid2dTo1d_mpi_l + + + SUBROUTINE grid2dTo1d_mpi_l1(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)) + + END SUBROUTINE grid2dTo1d_mpi_l1 + + + + SUBROUTINE grid2dTo1d_mpi_l2(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)) + + END SUBROUTINE grid2dTo1d_mpi_l2 + + + SUBROUTINE grid2dTo1d_mpi_l3(VarIn,VarOut) + IMPLICIT NONE + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5)) + + END SUBROUTINE grid2dTo1d_mpi_l3 + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE bcast_mpi_cgen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + CHARACTER(LEN=*),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_cgen + + + + SUBROUTINE bcast_mpi_igen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_igen + + + + + SUBROUTINE bcast_mpi_rgen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + REAL,DIMENSION(nb),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_rgen + + + + + SUBROUTINE bcast_mpi_lgen(var,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + IMPLICIT NONE + + LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var + INTEGER,INTENT(IN) :: nb + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + + IF (.not.is_using_mpi) RETURN + +#ifdef CPP_MPI + CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE bcast_mpi_lgen + + + + SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + DO i=1,dimsize + VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i) + Index=Index+nb + ENDDO + ENDDO + ENDIF + +#ifdef CPP_MPI + CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize, & + MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE scatter_mpi_igen + + SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + REAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + DO i=1,dimsize + VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i) + Index=Index+nb + ENDDO + ENDDO + ENDIF + +#ifdef CPP_MPI + CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize, & + MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr) + +#endif + + END SUBROUTINE scatter_mpi_rgen + + + SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + DO i=1,dimsize + VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i) + Index=Index+nb + ENDDO + ENDDO + ENDIF + +#ifdef CPP_MPI + CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize, & + MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE scatter_mpi_lgen + + + + + SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + Index=Index+nb*dimsize + ENDDO + + ENDIF + +#ifdef CPP_MPI + CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs, & + MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + DO i=1,dimsize + VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1) + Index=Index+nb + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gather_mpi_igen + + SUBROUTINE gather_mpi_rgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + REAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + Index=Index+nb*dimsize + ENDDO + ENDIF + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + +#ifdef CPP_MPI + CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs, & + MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + DO i=1,dimsize + VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1) + Index=Index+nb + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gather_mpi_rgen + + SUBROUTINE gather_mpi_lgen(VarIn, VarOut, dimsize) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(0:mpi_size-1) :: displs + INTEGER,DIMENSION(0:mpi_size-1) :: counts + LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp + INTEGER :: nb,i,index,rank + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:,:)=VarIn(:,:) + RETURN + ENDIF + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + displs(rank)=Index-1 + counts(rank)=nb*dimsize + Index=Index+nb*dimsize + ENDDO + ENDIF + + +#ifdef CPP_MPI + CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs, & + MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr) +#endif + + IF (is_mpi_root) THEN + Index=1 + DO rank=0,mpi_size-1 + nb=klon_mpi_para_nb(rank) + DO i=1,dimsize + VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1) + Index=Index+nb + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gather_mpi_lgen + + + + SUBROUTINE reduce_sum_mpi_igen(VarIn,VarOut,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn + INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut + INTEGER,INTENT(IN) :: nb + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:)=VarIn(:) + RETURN + ENDIF + + +#ifdef CPP_MPI + CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE reduce_sum_mpi_igen + + SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb) + USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root + USE mod_grid_phy_lmdz + + IMPLICIT NONE + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + REAL,DIMENSION(nb),INTENT(IN) :: VarIn + REAL,DIMENSION(nb),INTENT(OUT) :: VarOut + INTEGER,INTENT(IN) :: nb + INTEGER :: ierr + + IF (.not.is_using_mpi) THEN + VarOut(:)=VarIn(:) + RETURN + ENDIF + +#ifdef CPP_MPI + CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr) +#endif + + END SUBROUTINE reduce_sum_mpi_rgen + + + + SUBROUTINE grid1dTo2d_mpi_igen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(klon_mpi,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + VarOut(1:nbp_lon,:)=0 + VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0 + + offset=ii_begin + IF (is_north_pole) Offset=nbp_lon + + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + IF (is_north_pole) THEN + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + ENDIF + + IF (is_south_pole) THEN + DO i=1,dimsize + DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb + VarOut(ij,i)=VarIn(klon_mpi,i) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE grid1dTo2d_mpi_igen + + + SUBROUTINE grid1dTo2d_mpi_rgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + VarOut(1:nbp_lon,:)=0 + VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0 + + offset=ii_begin + IF (is_north_pole) Offset=nbp_lon + + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + IF (is_north_pole) THEN + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + ENDIF + + IF (is_south_pole) THEN + DO i=1,dimsize + DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb + VarOut(ij,i)=VarIn(klon_mpi,i) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE grid1dTo2d_mpi_rgen + + + + SUBROUTINE grid1dTo2d_mpi_lgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize) :: VarOut + INTEGER :: i,ij,Offset + + + VarOut(1:nbp_lon,:)=.FALSE. + VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=.FALSE. + + offset=ii_begin + IF (is_north_pole) Offset=nbp_lon + + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij+offset-1,i)=VarIn(ij,i) + ENDDO + ENDDO + + + IF (is_north_pole) THEN + DO i=1,dimsize + DO ij=1,nbp_lon + VarOut(ij,i)=VarIn(1,i) + ENDDO + ENDDO + ENDIF + + IF (is_south_pole) THEN + DO i=1,dimsize + DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb + VarOut(ij,i)=VarIn(klon_mpi,i) + ENDDO + ENDDO + ENDIF + + END SUBROUTINE grid1dTo2d_mpi_lgen + + + + + SUBROUTINE grid2dTo1d_mpi_igen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=ii_begin + IF (is_north_pole) offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + IF (is_north_pole) THEN + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + ENDIF + + + END SUBROUTINE grid2dTo1d_mpi_igen + + + + SUBROUTINE grid2dTo1d_mpi_rgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=ii_begin + IF (is_north_pole) offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + IF (is_north_pole) THEN + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + ENDIF + + + END SUBROUTINE grid2dTo1d_mpi_rgen + + + SUBROUTINE grid2dTo1d_mpi_lgen(VarIn,VarOut,dimsize) + USE mod_phys_lmdz_mpi_data + USE mod_grid_phy_lmdz + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER :: i,ij,offset + + offset=ii_begin + IF (is_north_pole) offset=nbp_lon + + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=VarIn(ij+offset-1,i) + ENDDO + ENDDO + + IF (is_north_pole) THEN + DO i=1,dimsize + VarOut(1,i)=VarIn(1,i) + ENDDO + ENDIF + + + END SUBROUTINE grid2dTo1d_mpi_lgen + +END MODULE mod_phys_lmdz_mpi_transfert Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_omp_data.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_omp_data.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_omp_data.F90 (revision 1634) @@ -0,0 +1,108 @@ +! +!$Id$ +! +MODULE mod_phys_lmdz_omp_data + + INTEGER,SAVE :: omp_size + INTEGER,SAVE :: omp_rank + LOGICAL,SAVE :: is_omp_root + LOGICAL,SAVE :: is_using_omp + + INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb + INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_begin + INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_end + + INTEGER,SAVE :: klon_omp + INTEGER,SAVE :: klon_omp_begin + INTEGER,SAVE :: klon_omp_end +!$OMP THREADPRIVATE(omp_rank,klon_omp,is_omp_root,klon_omp_begin,klon_omp_end) + +CONTAINS + + SUBROUTINE Init_phys_lmdz_omp_data(klon_mpi) + USE dimphy + IMPLICIT NONE + INTEGER, INTENT(in) :: klon_mpi + + INTEGER :: i + + CHARACTER (LEN=20) :: modname='Init_phys_lmdz_omp_data' + CHARACTER (LEN=80) :: abort_message + + +#ifdef CPP_OMP + INTEGER :: OMP_GET_NUM_THREADS + EXTERNAL OMP_GET_NUM_THREADS + INTEGER :: OMP_GET_THREAD_NUM + EXTERNAL OMP_GET_THREAD_NUM +#endif + +#ifdef CPP_OMP +!$OMP MASTER + is_using_omp=.TRUE. + omp_size=OMP_GET_NUM_THREADS() +!$OMP END MASTER + omp_rank=OMP_GET_THREAD_NUM() +#else + is_using_omp=.FALSE. + omp_size=1 + omp_rank=0 +#endif + + is_omp_root=.FALSE. +!$OMP MASTER + IF (omp_rank==0) THEN + is_omp_root=.TRUE. + ELSE + abort_message = 'ANORMAL : OMP_MASTER /= 0' + CALL abort_gcm (modname,abort_message,1) + ENDIF +!$OMP END MASTER + + +!$OMP MASTER + ALLOCATE(klon_omp_para_nb(0:omp_size-1)) + ALLOCATE(klon_omp_para_begin(0:omp_size-1)) + ALLOCATE(klon_omp_para_end(0:omp_size-1)) + + DO i=0,omp_size-1 + klon_omp_para_nb(i)=klon_mpi/omp_size + IF (i TASK ',omp_rank + PRINT *,'omp_size =',omp_size + PRINT *,'omp_rank =',omp_rank + PRINT *,'is_omp_root =',is_omp_root + PRINT *,'klon_omp_para_nb =',klon_omp_para_nb + PRINT *,'klon_omp_para_begin =',klon_omp_para_begin + PRINT *,'klon_omp_para_end =',klon_omp_para_end + PRINT *,'klon_omp =',klon_omp + PRINT *,'klon_omp_begin =',klon_omp_begin + PRINT *,'klon_omp_end =',klon_omp_end +!$OMP END CRITICAL + + END SUBROUTINE Print_module_data +END MODULE mod_phys_lmdz_omp_data Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_omp_transfert.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_omp_transfert.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_omp_transfert.F90 (revision 1634) @@ -0,0 +1,1057 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_omp_transfert + + PRIVATE + + INTEGER,PARAMETER :: grow_factor=1.5 + INTEGER,PARAMETER :: size_min=1024 + + CHARACTER(LEN=size_min),SAVE :: buffer_c +! INTEGER,SAVE :: size_c=0 + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: buffer_i + INTEGER,SAVE :: size_i=0 + REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: buffer_r + INTEGER,SAVE :: size_r=0 + LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: buffer_l + INTEGER,SAVE :: size_l=0 + + + + + INTERFACE bcast_omp + MODULE PROCEDURE bcast_omp_c, & + bcast_omp_i,bcast_omp_i1,bcast_omp_i2,bcast_omp_i3,bcast_omp_i4, & + bcast_omp_r,bcast_omp_r1,bcast_omp_r2,bcast_omp_r3,bcast_omp_r4, & + bcast_omp_l,bcast_omp_l1,bcast_omp_l2,bcast_omp_l3,bcast_omp_l4 + END INTERFACE + + INTERFACE scatter_omp + MODULE PROCEDURE scatter_omp_i,scatter_omp_i1,scatter_omp_i2,scatter_omp_i3, & + scatter_omp_r,scatter_omp_r1,scatter_omp_r2,scatter_omp_r3, & + scatter_omp_l,scatter_omp_l1,scatter_omp_l2,scatter_omp_l3 + END INTERFACE + + + INTERFACE gather_omp + MODULE PROCEDURE gather_omp_i,gather_omp_i1,gather_omp_i2,gather_omp_i3, & + gather_omp_r,gather_omp_r1,gather_omp_r2,gather_omp_r3, & + gather_omp_l,gather_omp_l1,gather_omp_l2,gather_omp_l3 + END INTERFACE + + + INTERFACE reduce_sum_omp + MODULE PROCEDURE reduce_sum_omp_i,reduce_sum_omp_i1,reduce_sum_omp_i2,reduce_sum_omp_i3,reduce_sum_omp_i4, & + reduce_sum_omp_r,reduce_sum_omp_r1,reduce_sum_omp_r2,reduce_sum_omp_r3,reduce_sum_omp_r4 + END INTERFACE + + + PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp + +CONTAINS + + SUBROUTINE check_buffer_i(buff_size) + IMPLICIT NONE + INTEGER :: buff_size + +!$OMP BARRIER +!$OMP MASTER + IF (buff_size>size_i) THEN + IF (ALLOCATED(buffer_i)) DEALLOCATE(buffer_i) + size_i=MAX(size_min,INT(grow_factor*buff_size)) + ALLOCATE(buffer_i(size_i)) + ENDIF +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE check_buffer_i + + SUBROUTINE check_buffer_r(buff_size) + IMPLICIT NONE + INTEGER :: buff_size + +!$OMP BARRIER +!$OMP MASTER + IF (buff_size>size_r) THEN + IF (ALLOCATED(buffer_r)) DEALLOCATE(buffer_r) + size_r=MAX(size_min,INT(grow_factor*buff_size)) + ALLOCATE(buffer_r(size_r)) + ENDIF +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE check_buffer_r + + SUBROUTINE check_buffer_l(buff_size) + IMPLICIT NONE + INTEGER :: buff_size + +!$OMP BARRIER +!$OMP MASTER + IF (buff_size>size_l) THEN + IF (ALLOCATED(buffer_l)) DEALLOCATE(buffer_l) + size_l=MAX(size_min,INT(grow_factor*buff_size)) + ALLOCATE(buffer_l(size_l)) + ENDIF +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE check_buffer_l + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Broadcast --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! -- Les chaine de charactère -- !! + + SUBROUTINE bcast_omp_c(var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(INOUT) :: Var + + CALL bcast_omp_cgen(Var,len(Var),buffer_c) + + END SUBROUTINE bcast_omp_c + +!! -- Les entiers -- !! + + SUBROUTINE bcast_omp_i(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var + INTEGER :: Var_tmp(1) + + Var_tmp(1)=Var + CALL check_buffer_i(1) + CALL bcast_omp_igen(Var_tmp,1,buffer_i) + Var=Var_tmp(1) + + END SUBROUTINE bcast_omp_i + + + SUBROUTINE bcast_omp_i1(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i1 + + + SUBROUTINE bcast_omp_i2(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i2 + + + SUBROUTINE bcast_omp_i3(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i3 + + + SUBROUTINE bcast_omp_i4(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:,:) + + CALL check_buffer_i(size(Var)) + CALL bcast_omp_igen(Var,size(Var),buffer_i) + + END SUBROUTINE bcast_omp_i4 + + +!! -- Les reels -- !! + + SUBROUTINE bcast_omp_r(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var + REAL :: Var_tmp(1) + + Var_tmp(1)=Var + CALL check_buffer_r(1) + CALL bcast_omp_rgen(Var_tmp,1,buffer_r) + Var=Var_tmp(1) + + END SUBROUTINE bcast_omp_r + + + SUBROUTINE bcast_omp_r1(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r1 + + + SUBROUTINE bcast_omp_r2(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r2 + + + SUBROUTINE bcast_omp_r3(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r3 + + + SUBROUTINE bcast_omp_r4(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL check_buffer_r(size(Var)) + CALL bcast_omp_rgen(Var,size(Var),buffer_r) + + END SUBROUTINE bcast_omp_r4 + + +!! -- Les booleans -- !! + + SUBROUTINE bcast_omp_l(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var + LOGICAL :: Var_tmp(1) + + Var_tmp(1)=Var + CALL check_buffer_l(1) + CALL bcast_omp_lgen(Var_tmp,1,buffer_l) + Var=Var_tmp(1) + + END SUBROUTINE bcast_omp_l + + + SUBROUTINE bcast_omp_l1(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l1 + + + SUBROUTINE bcast_omp_l2(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l2 + + + SUBROUTINE bcast_omp_l3(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l3 + + + SUBROUTINE bcast_omp_l4(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) + + CALL check_buffer_l(size(Var)) + CALL bcast_omp_lgen(Var,size(Var),buffer_l) + + END SUBROUTINE bcast_omp_l4 + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter_omp_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,1,buffer_i) + + END SUBROUTINE scatter_omp_i + + + SUBROUTINE scatter_omp_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),buffer_i) + + END SUBROUTINE scatter_omp_i1 + + + SUBROUTINE scatter_omp_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_i) + + END SUBROUTINE scatter_omp_i2 + + + SUBROUTINE scatter_omp_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_i) + + END SUBROUTINE scatter_omp_i3 + + + + + SUBROUTINE scatter_omp_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,1,buffer_r) + + END SUBROUTINE scatter_omp_r + + + SUBROUTINE scatter_omp_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),buffer_r) + + END SUBROUTINE scatter_omp_r1 + + + SUBROUTINE scatter_omp_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_r) + + END SUBROUTINE scatter_omp_r2 + + + SUBROUTINE scatter_omp_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_r) + + END SUBROUTINE scatter_omp_r3 + + + + SUBROUTINE scatter_omp_l(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,1,buffer_l) + + END SUBROUTINE scatter_omp_l + + + SUBROUTINE scatter_omp_l1(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),buffer_l) + + END SUBROUTINE scatter_omp_l1 + + + SUBROUTINE scatter_omp_l2(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_l) + + END SUBROUTINE scatter_omp_l2 + + + SUBROUTINE scatter_omp_l3(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarIn)) + CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_l) + + END SUBROUTINE scatter_omp_l3 + + + SUBROUTINE gather_omp_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,1,buffer_i) + + END SUBROUTINE gather_omp_i + + + SUBROUTINE gather_omp_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),buffer_i) + + END SUBROUTINE gather_omp_i1 + + + SUBROUTINE gather_omp_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_i) + + END SUBROUTINE gather_omp_i2 + + + SUBROUTINE gather_omp_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarOut)) + CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_i) + + END SUBROUTINE gather_omp_i3 + + + + SUBROUTINE gather_omp_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,1,buffer_r) + + END SUBROUTINE gather_omp_r + + + SUBROUTINE gather_omp_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),buffer_r) + + END SUBROUTINE gather_omp_r1 + + + SUBROUTINE gather_omp_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_r) + + END SUBROUTINE gather_omp_r2 + + + SUBROUTINE gather_omp_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarOut)) + CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_r) + + END SUBROUTINE gather_omp_r3 + + + SUBROUTINE gather_omp_l(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,1,buffer_l) + + END SUBROUTINE gather_omp_l + + + SUBROUTINE gather_omp_l1(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),buffer_l) + + END SUBROUTINE gather_omp_l1 + + + SUBROUTINE gather_omp_l2(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_l) + + END SUBROUTINE gather_omp_l2 + + + SUBROUTINE gather_omp_l3(VarIn, VarOut) + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_l(size(VarOut)) + CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_l) + + END SUBROUTINE gather_omp_l3 + + + + + SUBROUTINE reduce_sum_omp_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: VarIn + INTEGER,INTENT(OUT) :: VarOut + INTEGER :: VarIn_tmp(1) + INTEGER :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL Check_buffer_i(1) + CALL reduce_sum_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_omp_i + + SUBROUTINE reduce_sum_omp_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i1 + + + SUBROUTINE reduce_sum_omp_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i2 + + + SUBROUTINE reduce_sum_omp_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i3 + + + SUBROUTINE reduce_sum_omp_i4(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_i(size(VarIn)) + CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) + + END SUBROUTINE reduce_sum_omp_i4 + + + SUBROUTINE reduce_sum_omp_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN) :: VarIn + REAL,INTENT(OUT) :: VarOut + REAL :: VarIn_tmp(1) + REAL :: VarOut_tmp(1) + + VarIn_tmp(1)=VarIn + CALL Check_buffer_r(1) + CALL reduce_sum_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r) + VarOut=VarOut_tmp(1) + + END SUBROUTINE reduce_sum_omp_r + + SUBROUTINE reduce_sum_omp_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r1 + + + SUBROUTINE reduce_sum_omp_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r2 + + + SUBROUTINE reduce_sum_omp_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r3 + + + SUBROUTINE reduce_sum_omp_r4(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + CALL Check_buffer_r(size(VarIn)) + CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) + + END SUBROUTINE reduce_sum_omp_r4 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! LES ROUTINES GENERIQUES ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE bcast_omp_cgen(Var,Nb,Buff) + IMPLICIT NONE + + CHARACTER(LEN=*),INTENT(INOUT) :: Var + CHARACTER(LEN=*),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + Buff=Var + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var=Buff + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_cgen + + + + SUBROUTINE bcast_omp_igen(Var,Nb,Buff) + IMPLICIT NONE + + INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var + INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + DO i=1,Nb + Buff(i)=Var(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var(i)=Buff(i) + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_igen + + + SUBROUTINE bcast_omp_rgen(Var,Nb,Buff) + IMPLICIT NONE + + REAL,DIMENSION(Nb),INTENT(INOUT) :: Var + REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + DO i=1,Nb + Buff(i)=Var(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var(i)=Buff(i) + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_rgen + + SUBROUTINE bcast_omp_lgen(Var,Nb,Buff) + IMPLICIT NONE + + LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var + LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff + INTEGER,INTENT(IN) :: Nb + + INTEGER :: i + + !$OMP MASTER + DO i=1,Nb + Buff(i)=Var(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,Nb + Var(i)=Buff(i) + ENDDO + !$OMP BARRIER + + END SUBROUTINE bcast_omp_lgen + + + SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut + INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + Buff(ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,dimsize + DO ij=1,klon_omp + VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + END SUBROUTINE scatter_omp_igen + + + SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut + REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + Buff(ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,dimsize + DO ij=1,klon_omp + VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + END SUBROUTINE scatter_omp_rgen + + + SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut + LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + Buff(ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + DO i=1,dimsize + DO ij=1,klon_omp + VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + END SUBROUTINE scatter_omp_lgen + + + + + + SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + DO i=1,dimsize + DO ij=1,klon_omp + Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=Buff(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE gather_omp_igen + + + SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + DO i=1,dimsize + DO ij=1,klon_omp + Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=Buff(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE gather_omp_rgen + + + SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff) + USE mod_phys_lmdz_omp_data + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut + LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff + + INTEGER :: i,ij + + DO i=1,dimsize + DO ij=1,klon_omp + Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i) + ENDDO + ENDDO + !$OMP BARRIER + + + !$OMP MASTER + DO i=1,dimsize + DO ij=1,klon_mpi + VarOut(ij,i)=Buff(ij,i) + ENDDO + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE gather_omp_lgen + + + SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut + INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff + + INTEGER :: i + + !$OMP MASTER + Buff(:)=0 + !$OMP END MASTER + !$OMP BARRIER + + !$OMP CRITICAL + DO i=1,dimsize + Buff(i)=Buff(i)+VarIn(i) + ENDDO + !$OMP END CRITICAL + !$OMP BARRIER + + !$OMP MASTER + DO i=1,dimsize + VarOut(i)=Buff(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE reduce_sum_omp_igen + + SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: dimsize + REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn + REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut + REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff + + INTEGER :: i + + !$OMP MASTER + Buff(:)=0 + !$OMP END MASTER + !$OMP BARRIER + + !$OMP CRITICAL + DO i=1,dimsize + Buff(i)=Buff(i)+VarIn(i) + ENDDO + !$OMP END CRITICAL + !$OMP BARRIER + + !$OMP MASTER + DO i=1,dimsize + VarOut(i)=Buff(i) + ENDDO + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE reduce_sum_omp_rgen + +END MODULE mod_phys_lmdz_omp_transfert Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_para.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_para.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_para.F90 (revision 1634) @@ -0,0 +1,112 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_para + USE mod_phys_lmdz_transfert_para + USE mod_phys_lmdz_mpi_data + USE mod_phys_lmdz_omp_data + + INTEGER,SAVE :: klon_loc + LOGICAL,SAVE :: is_sequential + LOGICAL,SAVE :: is_parallel + LOGICAL,SAVE :: is_master + +!$OMP THREADPRIVATE(klon_loc,is_master) + +CONTAINS + + SUBROUTINE Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib) + IMPLICIT NONE + INTEGER,INTENT(in) :: iim + INTEGER,INTENT(in) :: jjp1 + INTEGER,INTENT(in) :: nb_proc + INTEGER,INTENT(in) :: distrib(0:nb_proc-1) + + CALL Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib) +!$OMP PARALLEL + CALL Init_phys_lmdz_omp_data(klon_mpi) + klon_loc=klon_omp + IF (is_mpi_root .AND. is_omp_root) THEN + is_master=.TRUE. + ELSE + is_master=.FALSE. + ENDIF + CALL Test_transfert +!$OMP END PARALLEL + IF (is_using_mpi .OR. is_using_omp) THEN + is_sequential=.FALSE. + is_parallel=.TRUE. + ELSE + is_sequential=.TRUE. + is_parallel=.FALSE. + ENDIF + + END SUBROUTINE Init_phys_lmdz_para + + SUBROUTINE Test_transfert + USE mod_grid_phy_lmdz + IMPLICIT NONE + + REAL :: Test_Field1d_glo(klon_glo,nbp_lev) + REAL :: tmp1d_glo(klon_glo,nbp_lev) + REAL :: Test_Field2d_glo(nbp_lon,nbp_lat,nbp_lev) + REAL :: tmp2d_glo(nbp_lon,nbp_lat,nbp_lev) + REAL :: Test_Field1d_loc(klon_loc,nbp_lev) + REAL :: Test_Field2d_loc(nbp_lon,jj_nb,nbp_lev) + REAL :: CheckSum + + INTEGER :: i,l + + Test_Field1d_glo = 0. + Test_Field2d_glo = 0. + Test_Field1d_loc = 0. + Test_Field2d_loc = 0. + + IF (is_mpi_root) THEN +!$OMP MASTER + DO l=1,nbp_lev + DO i=1,klon_glo +! Test_Field1d_glo(i,l)=MOD(i,10)+10*(l-1) + Test_Field1d_glo(i,l)=1 + ENDDO + ENDDO +!$OMP END MASTER + ENDIF + + CALL Scatter(Test_Field1d_glo,Test_Field1d_loc) + CALL Gather(Test_Field1d_loc,tmp1d_glo) + + IF (is_mpi_root) THEN +!$OMP MASTER + Checksum=sum(Test_Field1d_glo-tmp1d_glo) + PRINT *, "------> Checksum =",Checksum," MUST BE 0" +!$OMP END MASTER + ENDIF + + CALL grid1dTo2d_glo(Test_Field1d_glo,Test_Field2d_glo) + CALL scatter2D(Test_Field2d_glo,Test_Field1d_loc) + CALL gather2d(Test_Field1d_loc,Test_Field2d_glo) + CALL grid2dTo1d_glo(Test_Field2d_glo,tmp1d_glo) + + IF (is_mpi_root) THEN +!$OMP MASTER + Checksum=sum(Test_Field1d_glo-tmp1d_glo) + PRINT *, "------> Checksum =",Checksum," MUST BE 0" +!$OMP END MASTER + ENDIF + + CALL bcast(Test_Field1d_glo) + CALL reduce_sum(Test_Field1d_glo,tmp1d_glo) + + IF (is_mpi_root) THEN +!$OMP MASTER + Checksum=sum(Test_Field1d_glo*omp_size*mpi_size-tmp1d_glo) + PRINT *, "------> Checksum =",Checksum," MUST BE 0" +!$OMP END MASTER + ENDIF + + + END SUBROUTINE Test_transfert + +END MODULE mod_phys_lmdz_para + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_transfert_para.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_transfert_para.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_phys_lmdz_transfert_para.F90 (revision 1634) @@ -0,0 +1,1275 @@ +! +!$Header$ +! +MODULE mod_phys_lmdz_transfert_para + + USE mod_phys_lmdz_mpi_transfert + USE mod_phys_lmdz_omp_transfert + + + + INTERFACE bcast + MODULE PROCEDURE bcast_c, & + bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, & + bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, & + bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4 + END INTERFACE + + INTERFACE scatter + MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, & + scatter_r,scatter_r1,scatter_r2,scatter_r3, & + scatter_l,scatter_l1,scatter_l2,scatter_l3 + END INTERFACE + + + INTERFACE gather + MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, & + gather_r,gather_r1,gather_r2,gather_r3, & + gather_l,gather_l1,gather_l2,gather_l3 + END INTERFACE + + INTERFACE scatter2D + MODULE PROCEDURE scatter2D_i,scatter2D_i1,scatter2D_i2,scatter2D_i3, & + scatter2D_r,scatter2D_r1,scatter2D_r2,scatter2D_r3, & + scatter2D_l,scatter2D_l1,scatter2D_l2,scatter2D_l3 + END INTERFACE + + INTERFACE gather2D + MODULE PROCEDURE gather2D_i,gather2D_i1,gather2D_i2,gather2D_i3, & + gather2D_r,gather2D_r1,gather2D_r2,gather2D_r3, & + gather2D_l,gather2D_l1,gather2D_l2,gather2D_l3 + END INTERFACE + + INTERFACE reduce_sum + MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, & + reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4 + END INTERFACE + + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Broadcast --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! -- Les chaine de charactère -- !! + + SUBROUTINE bcast_c(var) + IMPLICIT NONE + CHARACTER(LEN=*),INTENT(INOUT) :: Var + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_c + +!! -- Les entiers -- !! + + SUBROUTINE bcast_i(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i + + SUBROUTINE bcast_i1(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i1 + + + SUBROUTINE bcast_i2(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i2 + + + SUBROUTINE bcast_i3(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i3 + + + SUBROUTINE bcast_i4(var) + IMPLICIT NONE + INTEGER,INTENT(INOUT) :: Var(:,:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_i4 + + +!! -- Les reels -- !! + + SUBROUTINE bcast_r(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r + + SUBROUTINE bcast_r1(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r1 + + + SUBROUTINE bcast_r2(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r2 + + + SUBROUTINE bcast_r3(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r3 + + + SUBROUTINE bcast_r4(var) + IMPLICIT NONE + REAL,INTENT(INOUT) :: Var(:,:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_r4 + + +!! -- Les booleens -- !! + + SUBROUTINE bcast_l(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l + + SUBROUTINE bcast_l1(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l1 + + + SUBROUTINE bcast_l2(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l2 + + + SUBROUTINE bcast_l3(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l3 + + + SUBROUTINE bcast_l4(var) + IMPLICIT NONE + LOGICAL,INTENT(INOUT) :: Var(:,:,:,:) + +!$OMP MASTER + CALL bcast_mpi(Var) +!$OMP END MASTER + CALL bcast_omp(Var) + + END SUBROUTINE bcast_l4 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE scatter_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_i + + + SUBROUTINE scatter_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_i1 + + + SUBROUTINE scatter_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_i2 + + + SUBROUTINE scatter_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter_i3 + + + SUBROUTINE scatter_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_r + + + SUBROUTINE scatter_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_r1 + + + SUBROUTINE scatter_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_r2 + + + SUBROUTINE scatter_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter_r3 + + + + SUBROUTINE scatter_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_l + + + SUBROUTINE scatter_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_l1 + + + SUBROUTINE scatter_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,Varout) + + END SUBROUTINE scatter_l2 + + + SUBROUTINE scatter_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter_l3 + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!! --> Les entiers + + SUBROUTINE gather_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER, DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,Varout) +!$OMP END MASTER + + END SUBROUTINE gather_i + + + SUBROUTINE gather_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,Varout) +!$OMP END MASTER + + END SUBROUTINE gather_i1 + + + SUBROUTINE gather_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_i2 + + + SUBROUTINE gather_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_i3 + + +!!!!! --> Les reels + + SUBROUTINE gather_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL, DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r + + + SUBROUTINE gather_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r1 + + + SUBROUTINE gather_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r2 + + + SUBROUTINE gather_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_r3 + + +!!!!! --> Les booleens + + SUBROUTINE gather_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l + + + SUBROUTINE gather_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l1 + + + SUBROUTINE gather_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l2 + + + SUBROUTINE gather_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Scatter2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!!!!! --> Les entiers + + SUBROUTINE scatter2D_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i + + + SUBROUTINE scatter2D_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i1 + + + SUBROUTINE scatter2D_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i2 + + + SUBROUTINE scatter2D_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_i3 + + +!!!!! --> Les reels + + SUBROUTINE scatter2D_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r + + + SUBROUTINE scatter2D_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r1 + + + SUBROUTINE scatter2D_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r2 + + + SUBROUTINE scatter2D_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_r3 + + +!!!!! --> Les booleens + + + SUBROUTINE scatter2D_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l + + + SUBROUTINE scatter2D_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l1 + + + SUBROUTINE scatter2D_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l2 + + + SUBROUTINE scatter2D_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp + +!$OMP MASTER + CALL scatter2D_mpi(VarIn,Var_tmp) +!$OMP END MASTER + CALL scatter_omp(Var_tmp,VarOut) + + END SUBROUTINE scatter2D_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des Gather2D --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!! --> Les entiers + + SUBROUTINE gather2D_i(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i + + + SUBROUTINE gather2D_i1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i1 + + + SUBROUTINE gather2D_i2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i2 + + + SUBROUTINE gather2D_i3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_i3 + + +!!!!! --> Les reels + + SUBROUTINE gather2D_r(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r + + + SUBROUTINE gather2D_r1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r1 + + + SUBROUTINE gather2D_r2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r2 + + + SUBROUTINE gather2D_r3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_r3 + + +!!!!! --> Les booleens + + SUBROUTINE gather2D_l(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l + + + SUBROUTINE gather2D_l1(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l1 + + + SUBROUTINE gather2D_l2(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l2 + + + SUBROUTINE gather2D_l3(VarIn, VarOut) + USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi + IMPLICIT NONE + + LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut + + LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL gather_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL gather2D_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE gather2D_l3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition des reduce_sum --> 4D !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Les entiers + + SUBROUTINE reduce_sum_i(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN) :: VarIn + INTEGER,INTENT(OUT) :: VarOut + + INTEGER :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i + + + SUBROUTINE reduce_sum_i1(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i1 + + + SUBROUTINE reduce_sum_i2(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i2 + + + SUBROUTINE reduce_sum_i3(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i3 + + + SUBROUTINE reduce_sum_i4(VarIn, VarOut) + IMPLICIT NONE + + INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_i4 + + +! Les reels + + SUBROUTINE reduce_sum_r(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN) :: VarIn + REAL,INTENT(OUT) :: VarOut + + REAL :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r + + + SUBROUTINE reduce_sum_r1(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r1 + + + SUBROUTINE reduce_sum_r2(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r2 + + + SUBROUTINE reduce_sum_r3(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r3 + + + SUBROUTINE reduce_sum_r4(VarIn, VarOut) + IMPLICIT NONE + + REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn + REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut + + REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp + + CALL reduce_sum_omp(VarIn,Var_tmp) +!$OMP MASTER + CALL reduce_sum_mpi(Var_tmp,VarOut) +!$OMP END MASTER + + END SUBROUTINE reduce_sum_r4 + + +END MODULE mod_phys_lmdz_transfert_para + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_surf_para.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_surf_para.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_surf_para.F90 (revision 1634) @@ -0,0 +1,350 @@ +MODULE mod_surf_para + IMPLICIT NONE + + INTERFACE gather_surf + MODULE PROCEDURE gather_surf_i,gather_surf_r + END INTERFACE gather_surf + + INTERFACE gather_surf_omp + MODULE PROCEDURE gather_surf_omp_i,gather_surf_omp_r + END INTERFACE gather_surf_omp + + INTERFACE gather_surf_mpi + MODULE PROCEDURE gather_surf_mpi_i,gather_surf_mpi_r + END INTERFACE gather_surf_mpi + + INTERFACE scatter_surf + MODULE PROCEDURE scatter_surf_i,scatter_surf_r + END INTERFACE scatter_surf + + INTERFACE scatter_surf_omp + MODULE PROCEDURE scatter_surf_omp_i,scatter_surf_omp_r + END INTERFACE scatter_surf_omp + + INTERFACE scatter_surf_mpi + MODULE PROCEDURE scatter_surf_mpi_i,scatter_surf_mpi_r + END INTERFACE scatter_surf_mpi + + + INTEGER,SAVE :: knon_omp + INTEGER,SAVE :: knon_omp_begin + INTEGER,SAVE :: knon_omp_end +!$OMP THREADPRIVATE(knon_omp,knon_omp_begin,knon_omp_end) + INTEGER,ALLOCATABLE,SAVE :: knon_omp_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_omp_begin_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_omp_end_para(:) + + INTEGER,SAVE :: knon_mpi + INTEGER,ALLOCATABLE,SAVE :: knon_mpi_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_mpi_begin_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_mpi_end_para(:) + + INTEGER,SAVE :: knon_glo + INTEGER,SAVE,ALLOCATABLE :: knon_glo_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_glo_begin_para(:) + INTEGER,ALLOCATABLE,SAVE :: knon_glo_end_para(:) + + +CONTAINS + + SUBROUTINE Init_surf_para(knon) + USE mod_phys_lmdz_para, mpi_rank_root=>mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: knon + INTEGER :: i,ierr + + knon_omp=knon + IF (is_omp_root) THEN + ALLOCATE(knon_omp_para(0:omp_size-1)) + ALLOCATE(knon_omp_begin_para(0:omp_size-1)) + ALLOCATE(knon_omp_end_para(0:omp_size-1)) + ENDIF +!$OMP BARRIER + knon_omp_para(omp_rank)=knon +!$OMP BARRIER + IF (is_omp_root) THEN + knon_omp_begin_para(0)=1 + knon_omp_end_para(0)=knon_omp_para(0) + DO i=1,omp_size-1 + knon_omp_begin_para(i)=knon_omp_end_para(i-1)+1 + knon_omp_end_para(i)=knon_omp_begin_para(i)+knon_omp_para(i)-1 + ENDDO + ENDIF +!$OMP BARRIER + knon_omp_begin=knon_omp_begin_para(omp_rank) + knon_omp_end=knon_omp_end_para(omp_rank) +!$OMP BARRIER + IF (is_omp_root) THEN + knon_mpi=sum(knon_omp_para) + ALLOCATE(knon_mpi_para(0:mpi_size-1)) + ALLOCATE(knon_mpi_begin_para(0:mpi_size-1)) + ALLOCATE(knon_mpi_end_para(0:mpi_size-1)) + + ALLOCATE(knon_glo_para(0:mpi_size*omp_size-1)) + ALLOCATE(knon_glo_begin_para(0:mpi_size*omp_size-1)) + ALLOCATE(knon_glo_end_para(0:mpi_size*omp_size-1)) + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_ALLGather(knon_mpi,1,MPI_INTEGER,knon_mpi_para,1,MPI_INTEGER,COMM_LMDZ_PHY,ierr) + CALL MPI_ALLGather(knon_omp_para,omp_size,MPI_INTEGER,knon_glo_para,omp_size,MPI_INTEGER,COMM_LMDZ_PHY,ierr) +#endif + ELSE + knon_mpi_para(:)=knon_mpi + knon_glo_para(:)=knon_omp_para(:) + ENDIF + + knon_glo=sum(knon_mpi_para(:)) + + knon_mpi_begin_para(0)=1 + knon_mpi_end_para(0)=knon_mpi_para(0) + DO i=1,mpi_size-1 + knon_mpi_begin_para(i)=knon_mpi_end_para(i-1)+1 + knon_mpi_end_para(i)=knon_mpi_begin_para(i)+knon_mpi_para(i)-1 + ENDDO + + knon_glo_begin_para(0)=1 + knon_glo_end_para(0)=knon_glo_para(0) + DO i=1,mpi_size*omp_size-1 + knon_glo_begin_para(i)=knon_glo_end_para(i-1)+1 + knon_glo_end_para(i)= knon_glo_begin_para(i)+knon_glo_para(i)-1 + ENDDO + ENDIF +!$OMP BARRIER + + END SUBROUTINE Init_surf_para + + + SUBROUTINE Finalize_surf_para + USE mod_phys_lmdz_para + +!$OMP BARRIER + IF (is_omp_root) THEN + DEALLOCATE(knon_omp_para) + DEALLOCATE(knon_omp_begin_para) + DEALLOCATE(knon_omp_end_para) + DEALLOCATE(knon_mpi_para) + DEALLOCATE(knon_mpi_begin_para) + DEALLOCATE(knon_mpi_end_para) + DEALLOCATE(knon_glo_para) + DEALLOCATE(knon_glo_begin_para) + DEALLOCATE(knon_glo_end_para) + ENDIF + + END SUBROUTINE Finalize_surf_para + + + SUBROUTINE gather_surf_i(FieldIn, FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: FieldTmp(knon_mpi) + + CALL gather_surf_omp_i(FieldIn,FieldTmp) + IF (is_omp_root) CALL gather_surf_mpi_i(FieldTmp,FieldOut) + + END SUBROUTINE gather_surf_i + + + SUBROUTINE gather_surf_omp_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + + INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) +!$OMP BARRIER + Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:) +!$OMP BARRIER + IF (is_omp_root) FieldOut(:)=Field_tmp(:) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE gather_surf_omp_i + + + SUBROUTINE gather_surf_mpi_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_INTEGER, & + FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE gather_surf_mpi_i + + + + + + SUBROUTINE gather_surf_r(FieldIn, FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + REAL :: FieldTmp(knon_mpi) + + CALL gather_surf_omp_r(FieldIn,FieldTmp) + IF (is_omp_root) CALL gather_surf_mpi_r(FieldTmp,FieldOut) + + END SUBROUTINE gather_surf_r + + + SUBROUTINE gather_surf_omp_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + + REAL,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) +!$OMP BARRIER + Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:) +!$OMP BARRIER + IF (is_omp_root) FieldOut(:)=Field_tmp(:) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE gather_surf_omp_r + + + SUBROUTINE gather_surf_mpi_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + REAL :: FieldIn(:) + REAL :: FieldOut(:) + REAL :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_REAL_LMDZ, & + FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_REAL_LMDZ, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE gather_surf_mpi_r + + + + + SUBROUTINE scatter_surf_i(FieldIn, FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: FieldTmp(knon_mpi) + + IF (is_omp_root) CALL scatter_surf_mpi_i(FieldIn,FieldTmp) + CALL scatter_surf_omp_i(FieldTmp,FieldOut) + + END SUBROUTINE scatter_surf_i + + + SUBROUTINE scatter_surf_omp_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + + INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) + IF (is_omp_root) Field_tmp(:)=FieldIn(:) +!$OMP BARRIER + FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE scatter_surf_omp_i + + + SUBROUTINE scatter_surf_mpi_i(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: FieldIn(:) + INTEGER :: FieldOut(:) + INTEGER :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, & + FieldOut,knon_mpi,MPI_INTEGER, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE scatter_surf_mpi_i + + + + SUBROUTINE scatter_surf_r(FieldIn, FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + REAL :: FieldTmp(knon_mpi) + + IF (is_omp_root) CALL scatter_surf_mpi_r(FieldIn,FieldTmp) + CALL scatter_surf_omp_r(FieldTmp,FieldOut) + + END SUBROUTINE scatter_surf_r + + + SUBROUTINE scatter_surf_omp_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para + REAL :: FieldIn(:) + REAL :: FieldOut(:) + + INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:) + + IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi)) + IF (is_omp_root) Field_tmp(:)=FieldIn(:) +!$OMP BARRIER + FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end) +!$OMP BARRIER + IF (is_omp_root) DEALLOCATE(Field_tmp) + + END SUBROUTINE scatter_surf_omp_r + + + SUBROUTINE scatter_surf_mpi_r(FieldIn,FieldOut) + USE mod_phys_lmdz_para, mpi_rank_root => mpi_root +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + REAL :: FieldIn(:) + REAL :: FieldOut(:) + INTEGER :: ierr + + IF (is_using_mpi) THEN +#ifdef CPP_MPI + CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, & + FieldOut,knon_mpi,MPI_INTEGER, & + mpi_rank_root,COMM_LMDZ_PHY,ierr) +#endif + ELSE + FieldOut(:)=FieldIn(:) + ENDIF + + END SUBROUTINE scatter_surf_mpi_r + +END MODULE mod_surf_para Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_synchro_omp.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_synchro_omp.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/mod_synchro_omp.F90 (revision 1634) @@ -0,0 +1,34 @@ +MODULE mod_synchro_omp + + LOGICAL,SAVE,ALLOCATABLE :: flag_omp(:) + +CONTAINS + + SUBROUTINE Init_synchro_omp + USE mod_phys_lmdz_para + IMPLICIT NONE + + IF (is_omp_root) THEN + ALLOCATE(flag_omp(0:omp_size-1)) + flag_omp(:)=.FALSE. + ENDIF +!$OMP BARRIER + + END SUBROUTINE Init_Synchro_omp + + SUBROUTINE Synchro_omp + USE mod_phys_lmdz_para + IMPLICIT NONE + + flag_omp(omp_rank)=.TRUE. +!$OMP BARRIER + DO WHILE (.NOT. ALL(flag_omp)) +!$OMP BARRIER + ENDDO +!$OMP BARRIER + flag_omp(omp_rank)=.FALSE. +!$OMP BARRIER + + END SUBROUTINE Synchro_omp + +END MODULE mod_synchro_omp Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/moy_undefSTD.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/moy_undefSTD.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/moy_undefSTD.F (revision 1634) @@ -0,0 +1,126 @@ +! +! $Id$ +! + SUBROUTINE moy_undefSTD(itap,freq_outNMC,freq_moyNMC) + USE netcdf + USE dimphy + USE phys_state_var_mod ! Variables sauvegardees de la physique + IMPLICIT none +c +c==================================================================== +c +c I. Musat : 09.2004 +c +c Moyenne - a des frequences differentes - des valeurs bien definies +c (.NE.missing_val) des variables interpolees a un niveau de +c pression. +c 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees +c tous les pas de temps de la physique +c +c 2) les variables de type "NMC" (nout=3) sont calculees a partir +c des valeurs instantannees toutes les 6 heures +c +c +c NB: mettre "inst(X)" dans le write_hist*NMC.h ! +c==================================================================== +cym#include "dimensions.h" +cym integer jjmp1 +cym parameter (jjmp1=jjm+1-1/jjm) +cym#include "dimphy.h" +c +c +c variables Input +c INTEGER nlevSTD, klevSTD, itap +c PARAMETER(klevSTD=17) + INTEGER itap +c +c variables locales +c INTEGER i, k, nout, n +c PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC + INTEGER i, k, n +c REAL dtime, freq_outNMC(nout), freq_moyNMC(nout) + REAL freq_outNMC(nout), freq_moyNMC(nout) +c +c variables Output +c REAL tnondef(klon,klevSTD,nout) +c REAL tsumSTD(klon,klevSTD,nout) +c + REAL missing_val +c + missing_val=nf90_fill_real +c + DO n=1, nout +c +c calcul 1 fois par jour +c + IF(MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.0) THEN +c + DO k=1, nlevSTD + DO i=1, klon + IF(tnondef(i,k,n).NE.(freq_moyNMC(n))) THEN + tsumSTD(i,k,n)=tsumSTD(i,k,n)/ + $ (freq_moyNMC(n)-tnondef(i,k,n)) +cIM BEG + 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)) +cIM END + ELSE + tsumSTD(i,k,n)=missing_val + usumSTD(i,k,n)=missing_val + vsumSTD(i,k,n)=missing_val + wsumSTD(i,k,n)=missing_val + phisumSTD(i,k,n)=missing_val + qsumSTD(i,k,n)=missing_val + rhsumSTD(i,k,n)=missing_val + uvsumSTD(i,k,n)=missing_val + vqsumSTD(i,k,n)=missing_val + vTsumSTD(i,k,n)=missing_val + wqsumSTD(i,k,n)=missing_val + vphisumSTD(i,k,n)=missing_val + wTsumSTD(i,k,n)=missing_val + u2sumSTD(i,k,n)=missing_val + v2sumSTD(i,k,n)=missing_val + T2sumSTD(i,k,n)=missing_val + O3sumSTD(i,k,n)=missing_val + O3daysumSTD(i,k,n)=missing_val + ENDIF !tnondef(i,k,n).NE.(freq_moyNMC(n)) + ENDDO !i + ENDDO !k + ENDIF !MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.0 +c + ENDDO !n +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/moyglo_aire.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/moyglo_aire.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/moyglo_aire.F (revision 1634) @@ -0,0 +1,161 @@ +! +! $Header$ +! + SUBROUTINE moyglo_pondaire(nhori, champ, aire, + . ok_msk, msk, moyglo) +c + USE dimphy + IMPLICIT none +c +c ================================================================== +c I. Musat, 07.2004 +c +c Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque +c +c moyenne = Somme_(champ* aire)/Somme_aire +c +c ================================================================== +c +#include "dimensions.h" +cym#include "dimphy.h" + INTEGER i, nhori + REAL champ(klon), aire(klon), msk(klon) + LOGICAL ok_msk + REAL moyglo +c +c var locale + REAL airetot +c +c PRINT*,'moyglo_pondaire nhori',nhori +c + airetot=0. + moyglo=0. +c + IF(ok_msk) THEN + DO i=1, nhori +c IF(msk(i).EQ.1.) THEN + IF(msk(i).GT.0.) THEN +c +c aire totale + airetot=airetot+aire(i)*msk(i) +c +c ponderation par la masse + moyglo=moyglo+champ(i)* aire(i)*msk(i) + ENDIF + ENDDO +c + ELSE !ok_msk + DO i=1, nhori +c +c aire totale + airetot=airetot+aire(i) +c +c ponderation par la masse + moyglo=moyglo+champ(i)* aire(i) + ENDDO +c + ENDIF +c +c moyenne ponderee par l'aire + moyglo=moyglo/airetot +c + RETURN + END +c + SUBROUTINE moyglo_pondaima(nhori, nvert, champ, + . aire, pbord, moyglo) + USE dimphy + IMPLICIT none +c ================================================================== +c I. Musat, 07.2004 +c +c Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire +c totale avec ou sans masque +c +c moyenne = Somme_(champ* masse_dair)/Somme_aire +c +c ================================================================== +#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + INTEGER i, k, nhori, nvert + REAL champ(klon,klev), aire(klon) + REAL pbord(klon,klev+1) + REAL moyglo +c +c var locale + REAL airetot +c +c PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert +c +c ponderation par la masse + moyglo=0. + DO k=1, nvert + DO i=1, nhori + moyglo=moyglo+ + . champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i) + ENDDO + ENDDO +c +c aire totale + airetot=0. + DO i=1, nhori + airetot=airetot+aire(i) + ENDDO +c +c moyenne par mettre carre avec ponderation par la masse + moyglo=moyglo/airetot +c + RETURN + END +c + SUBROUTINE moyglo_pondmass(nhori, nvert, champ, + . aire, pbord, moyglo) + USE dimphy + IMPLICIT none +c ================================================================== +c I. Musat, 07.2004 +c +c Calcul moyenne globale ponderee par la masse d'air, divisee par la +c masse totale d'air, avec ou sans masque +c +c moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair) +c +c ================================================================== +#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" + INTEGER i, k, nhori, nvert + REAL champ(klon,klev), aire(klon) + REAL pbord(klon,klev+1) + REAL moyglo +c +c var locale + REAL massetot +c +c PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert +c +c ponderation par la masse + moyglo=0. + DO k=1, nvert + DO i=1, nhori + moyglo=moyglo+ + . champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i) + ENDDO + ENDDO +c +c masse totale + massetot=0. + DO k=1, nvert + DO i=1, nhori + massetot=massetot+ + . (pbord(i,k)-pbord(i,k+1))/RG*aire(i) + ENDDO + ENDDO +c +c moyenne par mettre carre avec ponderation par la masse + moyglo=moyglo/massetot +c + RETURN + END +c Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/newmicro.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/newmicro.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/newmicro.F (revision 1634) @@ -0,0 +1,717 @@ +! $Id$ + + + +! + SUBROUTINE newmicro (paprs, pplay,ok_newmicro, + . t, pqlwp, pclc, pcltau, pclemi, + . pch, pcl, pcm, pct, pctlwp, + s xflwp, xfiwp, xflwc, xfiwc, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl, reliq, reice) + + USE dimphy + USE phys_local_var_mod, only: scdnc,cldncl,reffclwtop,lcc, + . reffclws,reffclwc,cldnvi,lcc3d, + . lcc3dcon,lcc3dstra + USE phys_state_var_mod, only: rnebcon,clwcon + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910 +c Objet: Calculer epaisseur optique et emmissivite des nuages +c====================================================================== +c Arguments: +c t-------input-R-temperature +c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg) +c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1) +c +c ok_aie--input-L-apply aerosol indirect effect or not +c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3] +c mass_solu_aero_pi--input-R-dito, pre-industrial value +c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land) +c bl95_b1-input-R-a parameter, may be varied for tests ( -"- ) +c +c cldtaupi-output-R-pre-industrial value of cloud optical thickness, +c needed for the diagnostics of the aerosol indirect +c radiative forcing (see radlwsw) +c re------output-R-Cloud droplet effective radius multiplied by fl [um] +c fl------output-R-Denominator to re, introduced to avoid problems in +c the averaging of the output. fl is the fraction of liquid +c water clouds within a grid cell +c pcltau--output-R-epaisseur optique des nuages +c pclemi--output-R-emissivite des nuages (0 a 1) +c====================================================================== +C +#include "YOMCST.h" +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "nuage.h" +cIM cf. CR: include pour NOVLP et ZEPSEC +#include "radepsi.h" +#include "radopt.h" +c choix de l'hypothese de recouvrememnt nuageuse + LOGICAL RANDOM,MAXIMUM_RANDOM,MAXIMUM + parameter (RANDOM=.FALSE., MAXIMUM_RANDOM=.TRUE., MAXIMUM=.FALSE.) + LOGICAL, SAVE :: FIRST=.TRUE. +!$OMP THREADPRIVATE(FIRST) +c Hypoyhese de recouvrement : MAXIMUM_RANDOM + INTEGER flag_max + REAL phase3d(klon, klev),dh(klon, klev),pdel(klon, klev), + . zrho(klon, klev) + REAL tcc(klon), ftmp(klon), lcc_integrat(klon), height(klon) + REAL thres_tau,thres_neb + PARAMETER (thres_tau=0.3, thres_neb=0.001) + REAL t_tmp + REAL gravit + PARAMETER (gravit=9.80616) !m/s2 + REAL pqlwpcon(klon, klev), pqlwpstra(klon, klev) +c + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) +c + REAL pclc(klon,klev) + REAL pqlwp(klon,klev) + REAL pcltau(klon,klev), pclemi(klon,klev) +c + REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon) +c + LOGICAL lo +c +!!Abderr modif JL mail du 19.01.2011 18:31 +! REAL cetahb, cetamb +! PARAMETER (cetahb = 0.45, cetamb = 0.80) +! Remplacer +!cetahb*paprs(i,1) par prmhc +!cetamb*paprs(i,1) par prlmc + REAL prmhc ! Pressure between medium and high level cloud + REAL prlmc ! Pressure between low and medium level cloud + PARAMETER (prmhc = 440.*100., prlmc = 680.*100.) + +C + INTEGER i, k +cIM: 091003 REAL zflwp, zradef, zfice, zmsac + REAL zflwp(klon), zradef, zfice, zmsac +cIM: 091003 rajout + REAL xflwp(klon), xfiwp(klon) + REAL xflwc(klon,klev), xfiwc(klon,klev) +c + REAL radius, rad_chaud +cc PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0) +ccc PARAMETER (rad_chaud=15.0, rad_froid=35.0) +c sintex initial PARAMETER (rad_chaud=10.0, rad_froid=30.0) + REAL coef, coef_froi, coef_chau + PARAMETER (coef_chau=0.13, coef_froi=0.09) + REAL seuil_neb + PARAMETER (seuil_neb=0.001) + INTEGER nexpo ! exponentiel pour glace/eau + PARAMETER (nexpo=6) +ccc PARAMETER (nexpo=1) + +c -- sb: + logical ok_newmicro +c parameter (ok_newmicro=.FALSE.) +cIM: 091003 real rel, tc, rei, zfiwp + real rel, tc, rei, zfiwp(klon) + real k_liq, k_ice0, k_ice, DF + parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g + parameter (DF=1.66) ! diffusivity factor +c sb -- +cjq for the aerosol indirect effect +cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003 +cjq + LOGICAL ok_aie ! Apply AIE or not? + LOGICAL ok_a1lwpdep ! a1 LWP dependent? + + REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols [ug m-3] + REAL mass_solu_aero_pi(klon, klev) ! - " - (pre-industrial value) + REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3] + REAL re(klon, klev) ! cloud droplet effective radius [um] + REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value) + REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value) + + REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell) + + REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula + + REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag +cjq-end +cIM cf. CR:parametres supplementaires + REAL zclear(klon) + REAL zcloud(klon) + REAL zcloudh(klon) + REAL zcloudm(klon) + REAL zcloudl(klon) + + +c ************************** +c * * +c * DEBUT PARTIE OPTIMISEE * +c * * +c ************************** + + REAL diff_paprs(klon, klev), zfice1, zfice2(klon, klev) + REAL rad_chaud_tab(klon, klev), zflwp_var, zfiwp_var + REAL d_rei_dt + +! Abderrahmane oct 2009 + Real reliq(klon, klev), reice(klon, klev) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH : 2011/05/24 +! +! rei = ( rei_max - rei_min ) * T(°C) / 81.4 + rei_max +! to be used for a temperature in celcius T(°C) < 0 +! rei=rei_min for T(°C) < -81.4 +! +! Calcul de la pente de la relation entre rayon effective des cristaux +! et la température. +! Pour retrouver les résultats numériques de la version d'origine, +! on impose 0.71 quand on est proche de 0.71 + + d_rei_dt=(rei_max-rei_min)/81.4 + if (abs(d_rei_dt-0.71)<1.e-4) d_rei_dt=0.71 +! print*,'d_rei_dT ',d_rei_dt,rei_min,rei_max +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c Calculer l'epaisseur optique et l'emmissivite des nuages +c +c IM inversion des DO + xflwp = 0.d0 + xfiwp = 0.d0 + xflwc = 0.d0 + xfiwc = 0.d0 + +! Initialisation + reliq=0. + reice=0. + + DO k = 1, klev + DO i = 1, klon + diff_paprs(i,k) = (paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + + IF (ok_newmicro) THEN + + + DO k = 1, klev + DO i = 1, klon +c zfice2(i,k) = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + zfice2(i,k) = 1.0 - (t(i,k)-t_glace_min) / + & (t_glace_max-t_glace_min) + zfice2(i,k) = MIN(MAX(zfice2(i,k),0.0),1.0) +c IM Total Liquid/Ice water content + xflwc(i,k) = (1.-zfice2(i,k))*pqlwp(i,k) + xfiwc(i,k) = zfice2(i,k)*pqlwp(i,k) +c IM In-Cloud Liquid/Ice water content +c xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)/pclc(i,k) +c xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)/pclc(i,k) + ENDDO + ENDDO + + IF (ok_aie) THEN + DO k = 1, klev + DO i = 1, klon + ! Formula "D" of Boucher and Lohmann, Tellus, 1995 + ! + cdnc(i,k) = 10.**(bl95_b0+bl95_b1* + & log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3 + ! Cloud droplet number concentration (CDNC) is restricted + ! to be within [20, 1000 cm^3] + ! + cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k))) + ! + ! + cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1* + & log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.)) + & *1.e6 !-m-3 + cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k))) + ENDDO + ENDDO + DO k = 1, klev + DO i = 1, klon +! rad_chaud_tab(i,k) = +! & MAX(1.1e6 +! & *((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k))) +! & /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.),5.) + rad_chaud_tab(i,k) = + & 1.1 + & *((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k))) + & /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.) + rad_chaud_tab(i,k) = MAX(rad_chaud_tab(i,k) * 1e6, 5.) + ENDDO + ENDDO + ELSE + DO k = 1, MIN(3,klev) + DO i = 1, klon + rad_chaud_tab(i,k) = rad_chau2 + ENDDO + ENDDO + DO k = MIN(3,klev)+1, klev + DO i = 1, klon + rad_chaud_tab(i,k) = rad_chau1 + ENDDO + ENDDO + + ENDIF + + DO k = 1, klev +! IF(.not.ok_aie) THEN + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 +! ENDIF + DO i = 1, klon + IF (pclc(i,k) .LE. seuil_neb) THEN + +c -- effective cloud droplet radius (microns): + +c for liquid water clouds: + ! For output diagnostics + ! + ! Cloud droplet effective radius [um] + ! + ! we multiply here with f * xl (fraction of liquid water + ! clouds in the grid cell) to avoid problems in the + ! averaging of the output. + ! In the output of IOIPSL, derive the real cloud droplet + ! effective radius as re/fl + ! + + fl(i,k) = seuil_neb*(1.-zfice2(i,k)) + re(i,k) = rad_chaud_tab(i,k)*fl(i,k) + + rel = 0. + rei = 0. + pclc(i,k) = 0.0 + pcltau(i,k) = 0.0 + pclemi(i,k) = 0.0 + cldtaupi(i,k) = 0.0 + ELSE + +c -- liquid/ice cloud water paths: + + zflwp_var= 1000.*(1.-zfice2(i,k))*pqlwp(i,k)/pclc(i,k) + & *diff_paprs(i,k) + zfiwp_var= 1000.*zfice2(i,k)*pqlwp(i,k)/pclc(i,k) + & *diff_paprs(i,k) + +c -- effective cloud droplet radius (microns): + +c for liquid water clouds: + + IF (ok_aie) THEN + radius = + & 1.1 + & *((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k))) + & /(4./3.*RPI*1000.*cdnc_pi(i,k)))**(1./3.) + radius = MAX(radius*1e6, 5.) + + tc = t(i,k)-273.15 + rei = d_rei_dt*tc + rei_max + if (tc.le.-81.4) rei = rei_min + if (zflwp_var.eq.0.) radius = 1. + if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. + cldtaupi(i,k) = 3.0/2.0 * zflwp_var / radius + & + zfiwp_var * (3.448e-03 + 2.431/rei) + + ENDIF ! ok_aie + ! For output diagnostics + ! + ! Cloud droplet effective radius [um] + ! + ! we multiply here with f * xl (fraction of liquid water + ! clouds in the grid cell) to avoid problems in the + ! averaging of the output. + ! In the output of IOIPSL, derive the real cloud droplet + ! effective radius as re/fl + ! + + fl(i,k) = pclc(i,k)*(1.-zfice2(i,k)) + re(i,k) = rad_chaud_tab(i,k)*fl(i,k) + + rel = rad_chaud_tab(i,k) +c for ice clouds: as a function of the ambiant temperature +c [formula used by Iacobellis and Somerville (2000), with an +c asymptotical value of 3.5 microns at T<-81.4 C added to be +c consistent with observations of Heymsfield et al. 1986]: +c 2011/05/24 : rei_min = 3.5 becomes a free parameter as well as rei_max=61.29 + tc = t(i,k)-273.15 + rei = d_rei_dt*tc + rei_max + if (tc.le.-81.4) rei = rei_min +c -- cloud optical thickness : + +c [for liquid clouds, traditional formula, +c for ice clouds, Ebert & Curry (1992)] + + if (zflwp_var.eq.0.) rel = 1. + if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. + pcltau(i,k) = 3.0/2.0 * ( zflwp_var/rel ) + & + zfiwp_var * (3.448e-03 + 2.431/rei) +c -- cloud infrared emissivity: + +c [the broadband infrared absorption coefficient is parameterized +c as a function of the effective cld droplet radius] + +c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995): + k_ice = k_ice0 + 1.0/rei + + pclemi(i,k) = 1.0 + & - EXP( -coef_chau*zflwp_var - DF*k_ice*zfiwp_var) + + ENDIF + reliq(i,k)=rel + reice(i,k)=rei +! if (i.eq.1) then +! print*,'Dans newmicro rel, rei :',rel, rei +! print*,'Dans newmicro reliq, reice :', +! $ reliq(i,k),reice(i,k) +! endif + + ENDDO + ENDDO + + DO k = 1, klev + DO i = 1, klon + xflwp(i) = xflwp(i)+ xflwc(i,k) * diff_paprs(i,k) + xfiwp(i) = xfiwp(i)+ xfiwc(i,k) * diff_paprs(i,k) + ENDDO + ENDDO + + ELSE + DO k = 1, klev + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 + DO i = 1, klon + + IF (pclc(i,k) .LE. seuil_neb) THEN + + pclc(i,k) = 0.0 + pcltau(i,k) = 0.0 + pclemi(i,k) = 0.0 + cldtaupi(i,k) = 0.0 + + ELSE + + zflwp_var = 1000.*pqlwp(i,k)*diff_paprs(i,k) + & /pclc(i,k) + + zfice1 = MIN( + & MAX( 1.0 - (t(i,k)-t_glace_min) / + & (t_glace_max-t_glace_min),0.0),1.0)**nexpo + + radius = rad_chaud * (1.-zfice1) + rad_froid * zfice1 + coef = coef_chau * (1.-zfice1) + coef_froi * zfice1 + + pcltau(i,k) = 3.0 * zflwp_var / (2.0 * radius) + pclemi(i,k) = 1.0 - EXP( - coef * zflwp_var) + + ENDIF + + ENDDO + ENDDO + ENDIF + + IF (.NOT.ok_aie) THEN + DO k = 1, klev + DO i = 1, klon + cldtaupi(i,k)=pcltau(i,k) + ENDDO + ENDDO + ENDIF + +ccc DO k = 1, klev +ccc DO i = 1, klon +ccc t(i,k) = t(i,k) +ccc pclc(i,k) = MAX( 1.e-5 , pclc(i,k) ) +ccc lo = pclc(i,k) .GT. (2.*1.e-5) +ccc zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1)) +ccc . /(rg*pclc(i,k)) +ccc zradef = 10.0 + (1.-sigs(k))*45.0 +ccc pcltau(i,k) = 1.5 * zflwp / zradef +ccc zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0) +ccc zmsac = 0.13*(1.0-zfice) + 0.08*zfice +ccc pclemi(i,k) = 1.-EXP(-zmsac*zflwp) +ccc if (.NOT.lo) pclc(i,k) = 0.0 +ccc if (.NOT.lo) pcltau(i,k) = 0.0 +ccc if (.NOT.lo) pclemi(i,k) = 0.0 +ccc ENDDO +ccc ENDDO +ccccc print*, 'pas de nuage dans le rayonnement' +ccccc DO k = 1, klev +ccccc DO i = 1, klon +ccccc pclc(i,k) = 0.0 +ccccc pcltau(i,k) = 0.0 +ccccc pclemi(i,k) = 0.0 +ccccc ENDDO +ccccc ENDDO +C +C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS +C +c IM cf. CR:test: calcul prenant ou non en compte le recouvrement +c initialisations + DO i=1,klon + zclear(i)=1. + zcloud(i)=0. + zcloudh(i)=0. + zcloudm(i)=0. + zcloudl(i)=0. + pch(i)=1.0 + pcm(i) = 1.0 + pcl(i) = 1.0 + pctlwp(i) = 0.0 + ENDDO +C +cIM cf CR DO k=1,klev + DO k = klev, 1, -1 + DO i = 1, klon + pctlwp(i) = pctlwp(i) + & + pqlwp(i,k)*diff_paprs(i,k) + ENDDO + ENDDO +c IM cf. CR + IF (NOVLP.EQ.1) THEN + DO k = klev, 1, -1 + DO i = 1, klon + zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i))) + & /(1.-MIN(real(zcloud(i), kind=8),1.-ZEPSEC)) + pct(i)=1.-zclear(i) + IF (paprs(i,k).LT.prmhc) THEN + pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloudh(i))) + & /(1.-MIN(real(zcloudh(i), kind=8),1.-ZEPSEC)) + zcloudh(i)=pclc(i,k) + ELSE IF (paprs(i,k).GE.prmhc .AND. + & paprs(i,k).LT.prlmc) THEN + pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloudm(i))) + & /(1.-MIN(real(zcloudm(i), kind=8),1.-ZEPSEC)) + zcloudm(i)=pclc(i,k) + ELSE IF (paprs(i,k).GE.prlmc) THEN + pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloudl(i))) + & /(1.-MIN(real(zcloudl(i), kind=8),1.-ZEPSEC)) + zcloudl(i)=pclc(i,k) + endif + zcloud(i)=pclc(i,k) + ENDDO + ENDDO + ELSE IF (NOVLP.EQ.2) THEN + DO k = klev, 1, -1 + DO i = 1, klon + zcloud(i)=MAX(pclc(i,k),zcloud(i)) + pct(i)=zcloud(i) + IF (paprs(i,k).LT.prmhc) THEN + pch(i) = MIN(pclc(i,k),pch(i)) + ELSE IF (paprs(i,k).GE.prmhc .AND. + & paprs(i,k).LT.prlmc) THEN + pcm(i) = MIN(pclc(i,k),pcm(i)) + ELSE IF (paprs(i,k).GE.prlmc) THEN + pcl(i) = MIN(pclc(i,k),pcl(i)) + endif + ENDDO + ENDDO + ELSE IF (NOVLP.EQ.3) THEN + DO k = klev, 1, -1 + DO i = 1, klon + zclear(i)=zclear(i)*(1.-pclc(i,k)) + pct(i)=1-zclear(i) + IF (paprs(i,k).LT.prmhc) THEN + pch(i) = pch(i)*(1.0-pclc(i,k)) + ELSE IF (paprs(i,k).GE.prmhc .AND. + & paprs(i,k).LT.prlmc) THEN + pcm(i) = pcm(i)*(1.0-pclc(i,k)) + ELSE IF (paprs(i,k).GE.prlmc) THEN + pcl(i) = pcl(i)*(1.0-pclc(i,k)) + endif + ENDDO + ENDDO + ENDIF + +C + DO i = 1, klon +c IM cf. CR pct(i)=1.-pct(i) + pch(i)=1.-pch(i) + pcm(i)=1.-pcm(i) + pcl(i)=1.-pcl(i) + ENDDO + +c ======================================================== +! DIAGNOSTICS CALCULATION FOR CMIP5 PROTOCOL +c ======================================================== +!! change by Nicolas Yan (LSCE) +!! Cloud Droplet Number Concentration (CDNC) : 3D variable +!! Fractionnal cover by liquid water cloud (LCC3D) : 3D variable +!! Cloud Droplet Number Concentration at top of cloud (CLDNCL) : 2D variable +!! Droplet effective radius at top of cloud (REFFCLWTOP) : 2D variable +!! Fractionnal cover by liquid water at top of clouds (LCC) : 2D variable + IF (ok_newmicro) THEN + IF (ok_aie) THEN + DO k = 1, klev + DO i = 1, klon + phase3d(i,k)=1-zfice2(i,k) + IF (pclc(i,k) .LE. seuil_neb) THEN + lcc3d(i,k)=seuil_neb*phase3d(i,k) + ELSE + lcc3d(i,k)=pclc(i,k)*phase3d(i,k) + ENDIF + scdnc(i,k)=lcc3d(i,k)*cdnc(i,k) ! m-3 + ENDDO + ENDDO + + DO i=1,klon + lcc(i)=0. + reffclwtop(i)=0. + cldncl(i)=0. + IF(RANDOM .OR. MAXIMUM_RANDOM) tcc(i) = 1. + IF(MAXIMUM) tcc(i) = 0. + ENDDO + + + DO i=1,klon + DO k=klev-1,1,-1 !From TOA down + + + ! Test, if the cloud optical depth exceeds the necessary + ! threshold: + + IF (pcltau(i,k).GT.thres_tau .AND. pclc(i,k).GT.thres_neb) + . THEN + ! To calculate the right Temperature at cloud top, + ! interpolate it between layers: + t_tmp = t(i,k) + + . (paprs(i,k+1)-pplay(i,k))/(pplay(i,k+1)-pplay(i,k)) + . * ( t(i,k+1) - t(i,k) ) + + IF(MAXIMUM) THEN + IF(FIRST) THEN + write(*,*)'Hypothese de recouvrement: MAXIMUM' + FIRST=.FALSE. + ENDIF + flag_max= -1. + ftmp(i) = MAX(tcc(i),pclc(i,k)) + ENDIF + + IF(RANDOM) THEN + IF(FIRST) THEN + write(*,*)'Hypothese de recouvrement: RANDOM' + FIRST=.FALSE. + ENDIF + flag_max= 1. + ftmp(i) = tcc(i) * (1-pclc(i,k)) + ENDIF + + IF(MAXIMUM_RANDOM) THEN + IF(FIRST) THEN + write(*,*)'Hypothese de recouvrement: MAXIMUM_ + . RANDOM' + FIRST=.FALSE. + ENDIF + flag_max= 1. + ftmp(i) = tcc(i) * + . (1. - MAX(pclc(i,k),pclc(i,k+1))) / + . (1. - MIN(pclc(i,k+1),1.-thres_neb)) + ENDIF +c Effective radius of cloud droplet at top of cloud (m) + reffclwtop(i) = reffclwtop(i) + rad_chaud_tab(i,k) * + . 1.0E-06 * phase3d(i,k) * ( tcc(i) - ftmp(i))*flag_max +c CDNC at top of cloud (m-3) + cldncl(i) = cldncl(i) + cdnc(i,k) * phase3d(i,k) * + . (tcc(i) - ftmp(i))*flag_max +c Liquid Cloud Content at top of cloud + lcc(i) = lcc(i) + phase3d(i,k) * (tcc(i)-ftmp(i))* + . flag_max +c Total Cloud Content at top of cloud + tcc(i)=ftmp(i) + + ENDIF ! is there a visible, not-too-small cloud? + ENDDO ! loop over k + + IF(RANDOM .OR. MAXIMUM_RANDOM) tcc(i)=1.-tcc(i) + ENDDO ! loop over i + +!! Convective and Stratiform Cloud Droplet Effective Radius (REFFCLWC REFFCLWS) + DO i = 1, klon + DO k = 1, klev + pqlwpcon(i,k)=rnebcon(i,k)*clwcon(i,k) ! fraction eau liquide convective + pqlwpstra(i,k)=pclc(i,k)*phase3d(i,k)-pqlwpcon(i,k) ! fraction eau liquide stratiforme + IF (pqlwpstra(i,k) .LE. 0.0) pqlwpstra(i,k)=0.0 +! Convective Cloud Droplet Effective Radius (REFFCLWC) : variable 3D + reffclwc(i,k)=1.1 + & *((pqlwpcon(i,k)*pplay(i,k)/(RD * T(i,k))) + & /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.) + reffclwc(i,k) = MAX(reffclwc(i,k) * 1e6, 5.) + +! Stratiform Cloud Droplet Effective Radius (REFFCLWS) : variable 3D + IF ((pclc(i,k)-rnebcon(i,k)) .LE. seuil_neb) THEN ! tout sous la forme convective + reffclws(i,k)=0.0 + lcc3dstra(i,k)= 0.0 + ELSE + reffclws(i,k) = (pclc(i,k)*phase3d(i,k)* + & rad_chaud_tab(i,k)- + & pqlwpcon(i,k)*reffclwc(i,k)) + IF(reffclws(i,k) .LE. 0.0) reffclws(i,k)=0.0 + lcc3dstra(i,k)=pqlwpstra(i,k) + ENDIF +!Convertion from um to m + IF(rnebcon(i,k). LE. seuil_neb) THEN + reffclwc(i,k) = reffclwc(i,k)*seuil_neb*clwcon(i,k) + & *1.0E-06 + lcc3dcon(i,k)= seuil_neb*clwcon(i,k) + ELSE + reffclwc(i,k) = reffclwc(i,k)*pqlwpcon(i,k) + & *1.0E-06 + lcc3dcon(i,k) = pqlwpcon(i,k) + ENDIF + + reffclws(i,k) = reffclws(i,k)*1.0E-06 + + ENDDO !klev + ENDDO !klon + +!! Column Integrated Cloud Droplet Number (CLDNVI) : variable 2D + DO k = 1, klev + DO i = 1, klon + pdel(i,k) = paprs(i,k)-paprs(i,k+1) + zrho(i,k)=pplay(i,k)/t(i,k)/RD ! kg/m3 + dh(i,k)=pdel(i,k)/(gravit*zrho(i,k)) ! hauteur de chaque boite (m) + ENDDO + ENDDO +c + DO i = 1, klon + cldnvi(i)=0. + lcc_integrat(i)=0. + height(i)=0. + DO k = 1, klev + cldnvi(i)=cldnvi(i)+cdnc(i,k)*lcc3d(i,k)*dh(i,k) + lcc_integrat(i)=lcc_integrat(i)+lcc3d(i,k)*dh(i,k) + height(i)=height(i)+dh(i,k) + ENDDO ! klev + lcc_integrat(i)=lcc_integrat(i)/height(i) + IF (lcc_integrat(i) .LE. 1.0E-03) THEN + cldnvi(i)=cldnvi(i)*lcc(i)/seuil_neb + ELSE + cldnvi(i)=cldnvi(i)*lcc(i)/lcc_integrat(i) + ENDIF + ENDDO ! klon + + DO i = 1, klon + DO k = 1, klev + IF (scdnc(i,k) .LE. 0.0) scdnc(i,k)=0.0 + IF (reffclws(i,k) .LE. 0.0) reffclws(i,k)=0.0 + IF (reffclwc(i,k) .LE. 0.0) reffclwc(i,k)=0.0 + IF (lcc3d(i,k) .LE. 0.0) lcc3d(i,k)=0.0 + IF (lcc3dcon(i,k) .LE. 0.0) lcc3dcon(i,k)=0.0 + IF (lcc3dstra(i,k) .LE. 0.0) lcc3dstra(i,k)=0.0 + ENDDO + IF (reffclwtop(i) .LE. 0.0) reffclwtop(i)=0.0 + IF (cldncl(i) .LE. 0.0) cldncl(i)=0.0 + IF (cldnvi(i) .LE. 0.0) cldnvi(i)=0.0 + IF (lcc(i) .LE. 0.0) lcc(i)=0.0 + ENDDO + + ENDIF !ok_aie + ENDIF !ok newmicro +c +C + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nflxtr.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nflxtr.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nflxtr.F90 (revision 1634) @@ -0,0 +1,159 @@ +! +! $Id $ +! +SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,pplay,paprs,x,dx) + USE dimphy + IMPLICIT NONE +!===================================================================== +! Objet : Melange convectif de traceurs a partir des flux de masse +! Date : 13/12/1996 -- 13/01/97 +! Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD), +! Brinkop et Sausen (1996) et Boucher et al. (1996). +! ATTENTION : meme si cette routine se veut la plus generale possible, +! elle a herite de certaines notations et conventions du +! schema de Tiedtke (1993). +! 1. En particulier, les couches sont numerotees de haut en bas !!! +! Ceci est valable pour les flux +! mais pas pour les entrees x, pplay, paprs !!!! +! 2. pmfu est positif, pmfd est negatif +! 3. Tous les flux d'entrainements et de detrainements sont positifs +! contrairement au schema de Tiedtke d'ou les changements de signe!!!! +!===================================================================== +! + include "YOMCST.h" + include "YOECUMF.h" + + REAL,INTENT(IN) :: pdtime ! pdtphys +! +! les flux sont definis au 1/2 niveaux +! => pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls +! + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu ! flux de masse dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd ! flux de masse dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant + + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression aux couches (bas en haut) + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(IN) :: x ! q de traceur (bas en haut) + REAL,DIMENSION(klon,klev),INTENT(INOUT) :: dx ! tendance de traceur (bas en haut) + +! flux convectifs mais en variables locales + REAL,DIMENSION(klon,klev+1) :: zmfu ! copie de pmfu avec klev+1 = 0 + REAL,DIMENSION(klon,klev+1) :: zmfd ! copie de pmfd avec klev+1 = 0 + REAL,DIMENSION(klon,klev) :: zen_u + REAL,DIMENSION(klon,klev) :: zde_u + REAL,DIMENSION(klon,klev) :: zen_d + REAL,DIMENSION(klon,klev) :: zde_d + REAL :: zmfe + +! variables locales +! les flux de x sont definis aux 1/2 niveaux +! xu et xd sont definis aux niveaux complets + REAL,DIMENSION(klon,klev) :: xu ! q de traceurs dans le panache montant + REAL,DIMENSION(klon,klev) :: xd ! q de traceurs dans le panache descendant + REAL,DIMENSION(klon,klev+1) :: zmfux ! flux de x dans le panache montant + REAL,DIMENSION(klon,klev+1) :: zmfdx ! flux de x dans le panache descendant + REAL,DIMENSION(klon,klev+1) :: zmfex ! flux de x dans l'environnement + INTEGER :: i, k + REAL,PARAMETER :: zmfmin=1.E-10 + +! ============================================== +! Extension des flux UP et DN sur klev+1 niveaux +! ============================================== + DO k=1,klev + DO i=1,klon + zmfu(i,k)=pmfu(i,k) + zmfd(i,k)=pmfd(i,k) + ENDDO + ENDDO + DO i=1,klon + zmfu(i,klev+1)=0. + zmfd(i,klev+1)=0. + ENDDO +! ========================================== +! modif pour diagnostiquer les detrainements +! ========================================== +! on privilegie l'ajustement de l'entrainement dans l'ascendance. + + DO k=1, klev + DO i=1, klon + zen_d(i,k)=pen_d(i,k) + zde_u(i,k)=pde_u(i,k) + zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k) + zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k) + ENDDO + ENDDO +! ========================================= +! calcul des flux dans le panache montant +! ========================================= +! +! Dans la premiere couche, on prend q comme valeur de qu + + DO i=1, klon + zmfux(i,1)=0.0 + ENDDO + +! Autres couches + DO k=1,klev + DO i=1, klon + IF ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN + xu(i,k)=x(i,k) + ELSE + xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))/(zmfu(i,k+1)+zde_u(i,k)) + ENDIF + zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k) + ENDDO + ENDDO +! ========================================== +! calcul des flux dans le panache descendant +! ========================================== + + DO i=1, klon + zmfdx(i,klev+1)=0.0 + ENDDO + + DO k=klev,1,-1 + DO i=1, klon + IF ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN + xd(i,k)=x(i,k) + ELSE + xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k))/(zmfd(i,k)-zde_d(i,k)) + ENDIF + zmfdx(i,k)=zmfd(i,k)*xd(i,k) + ENDDO + ENDDO +! =================================================== +! introduction du flux de retour dans l'environnement +! =================================================== + + DO k=2, klev + DO i=1, klon + zmfe=-zmfu(i,k)-zmfd(i,k) + IF (zmfe.le.0.) then + zmfex(i,k)= zmfe*x(i,k) + ELSE + zmfex(i,k)= zmfe*x(i,k-1) + ENDIF + ENDDO + ENDDO + + DO i=1, klon + zmfex(i,1)=0. + zmfex(i,klev+1)=0. + ENDDO +! ========================== +! calcul final des tendances +! ========================== + DO k=1, klev + DO i=1, klon + dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime* & + ( zmfux(i,k) - zmfux(i,k+1) + & + zmfdx(i,k) - zmfdx(i,k+1) + & + zmfex(i,k) - zmfex(i,k+1) ) + ENDDO + ENDDO + +END SUBROUTINE nflxtr Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nonlocal.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nonlocal.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nonlocal.F (revision 1634) @@ -0,0 +1,415 @@ +! +! $Header$ +! +C====================================================================== + SUBROUTINE nonlocal(knon, paprs, pplay, + . tsol,beta,u,v,t,q, + . cd_h, cd_m, pcfh, pcfm, cgh, cgq) + USE dimphy + IMPLICIT none +c====================================================================== +c Laurent Li (LMD/CNRS), le 30 septembre 1998 +c Couche limite non-locale. Adaptation du code du CCM3. +c Code non teste, donc a ne pas utiliser. +c====================================================================== +c Nonlocal scheme that determines eddy diffusivities based on a +c diagnosed boundary layer height and a turbulent velocity scale. +c Also countergradient effects for heat and moisture are included. +c +c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993: +c Local versus nonlocal boundary-layer diffusion in a global climate +c model. J. of Climate, vol. 6, 1825-1842. +c====================================================================== +#include "YOMCST.h" +#include "iniprint.h" +c +c Arguments: +c + INTEGER knon ! nombre de points a calculer + REAL tsol(klon) ! temperature du sol (K) + REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1) + REAL paprs(klon,klev+1) ! pression a inter-couche (Pa) + REAL pplay(klon,klev) ! pression au milieu de couche (Pa) + REAL u(klon,klev) ! vitesse U (m/s) + REAL v(klon,klev) ! vitesse V (m/s) + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! vapeur d'eau (kg/kg) + REAL cd_h(klon) ! coefficient de friction au sol pour chaleur + REAL cd_m(klon) ! coefficient de friction au sol pour vitesse +c + INTEGER isommet + REAL vk + PARAMETER (vk=0.40) + REAL ricr + PARAMETER (ricr=0.4) + REAL fak + PARAMETER (fak=8.5) + REAL fakn + PARAMETER (fakn=7.2) + REAL onet + PARAMETER (onet=1.0/3.0) + REAL t_coup + PARAMETER(t_coup=273.15) + REAL zkmin + PARAMETER (zkmin=0.01) + REAL betam + PARAMETER (betam=15.0) + REAL betah + PARAMETER (betah=15.0) + REAL betas + PARAMETER (betas=5.0) + REAL sffrac + PARAMETER (sffrac=0.1) + REAL binm + PARAMETER (binm=betam*sffrac) + REAL binh + PARAMETER (binh=betah*sffrac) + REAL ccon + PARAMETER (ccon=fak*sffrac*vk) +c + REAL z(klon,klev) + REAL pcfm(klon,klev), pcfh(klon,klev) +c + INTEGER i, k + REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy + REAL zx_alf1, zx_alf2 ! parametres pour extrapolation + REAL khfs(klon) ! surface kinematic heat flux [mK/s] + REAL kqfs(klon) ! sfc kinematic constituent flux [m/s] + REAL heatv(klon) ! surface virtual heat flux + REAL ustar(klon) + REAL rino(klon,klev) ! bulk Richardon no. from level to ref lev + LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx) + LOGICAL stblev(klon) ! stable pbl with levels within pbl + LOGICAL unslev(klon) ! unstbl pbl with levels within pbl + LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr + LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr + LOGICAL check(klon) ! True=>chk if Richardson no.>critcal + REAL pblh(klon) + REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m] + REAL cgq(klon,2:klev) ! counter-gradient term for constituents + REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux) + REAL obklen(klon) + REAL ztvd, ztvu, zdu2 + REAL therm(klon) ! thermal virtual temperature excess + REAL phiminv(klon) ! inverse phi function for momentum + REAL phihinv(klon) ! inverse phi function for heat + REAL wm(klon) ! turbulent velocity scale for momentum + REAL fak1(klon) ! k*ustar*pblh + REAL fak2(klon) ! k*wm*pblh + REAL fak3(klon) ! fakn*wstr/wm + REAL pblk(klon) ! level eddy diffusivity for momentum + REAL pr(klon) ! Prandtl number for eddy diffusivities + REAL zl(klon) ! zmzp / Obukhov length + REAL zh(klon) ! zmzp / pblh + REAL zzh(klon) ! (1-(zmzp/pblh))**2 + REAL wstr(klon) ! w*, convective velocity scale + REAL zm(klon) ! current level height + REAL zp(klon) ! current level height + one level up + REAL zcor, zdelta, zcvm5, zxqs + REAL fac, pblmin, zmzp, term +c +#include "YOETHF.h" +#include "FCTTRE.h" +c +c Initialisation +c + isommet=klev + + DO i = 1, klon + pcfh(i,1) = cd_h(i) + pcfm(i,1) = cd_m(i) + ENDDO + DO k = 2, klev + DO i = 1, klon + pcfh(i,k) = zkmin + pcfm(i,k) = zkmin + cgs(i,k) = 0.0 + cgh(i,k) = 0.0 + cgq(i,k) = 0.0 + ENDDO + ENDDO +c +c Calculer les hauteurs de chaque couche +c + DO i = 1, knon + z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) + . * (paprs(i,1)-pplay(i,1)) / RG + ENDDO + DO k = 2, klev + DO i = 1, knon + z(i,k) = z(i,k-1) + . + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) + . * (pplay(i,k-1)-pplay(i,k)) / RG + ENDDO + ENDDO +c + DO i = 1, knon + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-tsol(i))) + zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta + zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1)) + zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1) + zxqs=MIN(0.5,zxqs) + zcor=1./(1.-retv*zxqs) + zxqs=zxqs*zcor + ELSE + IF (tsol(i).LT.t_coup) THEN + zxqs = qsats(tsol(i)) / paprs(i,1) + ELSE + zxqs = qsatl(tsol(i)) / paprs(i,1) + ENDIF + ENDIF + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1))*zx_alf1 + . + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2))) + . *(1.+RETV*q(i,2))*zx_alf2 + zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2 + zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2 + zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2 + zxmod = 1.0+SQRT(zxu**2+zxv**2) + khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i) + kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i) + heatv(i) = khfs(i) + 0.61*zxt*kqfs(i) + taux = zxu *zxmod*cd_m(i) + tauy = zxv *zxmod*cd_m(i) + ustar(i) = SQRT(taux**2+tauy**2) + ustar(i) = MAX(SQRT(ustar(i)),0.01) + ENDDO +c + DO i = 1, knon + rino(i,1) = 0.0 + check(i) = .TRUE. + pblh(i) = z(i,1) + obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i)) + ENDDO + +C +C PBL height calculation: +C Search for level of pbl. Scan upward until the Richardson number between +C the first level and the current level exceeds the "critical" value. +C + fac = 100.0 + DO k = 1, isommet + DO i = 1, knon + IF (check(i)) THEN + zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = max(zdu2,1.0e-20) + ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k))) + . *(1.+RETV*q(i,k)) + ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1)) + rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu) + . /(zdu2*0.5*(ztvd+ztvu)) + IF (rino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k)) + check(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO + +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C Improve estimate of pbl height for the unstable points. +C Find unstable points (sensible heat flux is upward): +C + DO i = 1, knon + IF (heatv(i) .GT. 0.) THEN + unstbl(i) = .TRUE. + check(i) = .TRUE. + ELSE + unstbl(i) = .FALSE. + check(i) = .FALSE. + ENDIF + ENDDO +C +C For the unstable case, compute velocity scale and the +C convective temperature excess: +C + DO i = 1, knon + IF (check(i)) THEN + phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet + wm(i)= ustar(i)*phiminv(i) + therm(i) = heatv(i)*fak/wm(i) + rino(i,1) = 0.0 + ENDIF + ENDDO +C +C Improve pblh estimate for unstable conditions using the +C convective temperature excess: +C + DO k = 1, isommet + DO i = 1, knon + IF (check(i)) THEN + zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2 + zdu2 = max(zdu2,1.0e-20) + ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k))) + . *(1.+RETV*q(i,k)) + ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1)) + rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu) + . /(zdu2*0.5*(ztvd+ztvu)) + IF (rino(i,k).GE.ricr) THEN + pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) * + . (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k)) + check(i) = .FALSE. + ENDIF + ENDIF + ENDDO + ENDDO +C +C Set pbl height to maximum value where computation exceeds number of +C layers allowed +C + DO i = 1, knon + if (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C Points for which pblh exceeds number of pbl layers allowed; +C set to maximum +C + DO i = 1, knon + IF (check(i)) pblh(i) = z(i,isommet) + ENDDO +C +C PBL height must be greater than some minimum mechanical mixing depth +C Several investigators have proposed minimum mechanical mixing depth +C relationships as a function of the local friction velocity, u*. We +C make use of a linear relationship of the form h = c u* where c=700. +C The scaling arguments that give rise to this relationship most often +C represent the coefficient c as some constant over the local coriolis +C parameter. Here we make use of the experimental results of Koracin +C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f +C where f was evaluated at 39.5 N and 52 N. Thus we use a typical mid +C latitude value for f so that c = 0.07/f = 700. +C + DO i = 1, knon + pblmin = 700.0*ustar(i) + pblh(i) = MAX(pblh(i),pblmin) + ENDDO +C +C pblh is now available; do preparation for diffusivity calculation: +C + DO i = 1, knon + pblk(i) = 0.0 + fak1(i) = ustar(i)*pblh(i)*vk +C +C Do additional preparation for unstable cases only, set temperature +C and moisture perturbations depending on stability. +C + IF (unstbl(i)) THEN + zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1))) + . *(1.+RETV*q(i,1)) + phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet + phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i)) + wm(i) = ustar(i)*phiminv(i) + fak2(i) = wm(i)*pblh(i)*vk + wstr(i) = (heatv(i)*RG*pblh(i)/zxt)**onet + fak3(i) = fakn*wstr(i)/wm(i) + ENDIF + ENDDO + +C Main level loop to compute the diffusivities and +C counter-gradient terms: +C + DO 1000 k = 2, isommet +C +C Find levels within boundary layer: +C + DO i = 1, knon + unslev(i) = .FALSE. + stblev(i) = .FALSE. + zm(i) = z(i,k-1) + zp(i) = z(i,k) + IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i) + IF (zm(i) .LT. pblh(i)) THEN + zmzp = 0.5*(zm(i) + zp(i)) + zh(i) = zmzp/pblh(i) + zl(i) = zmzp/obklen(i) + zzh(i) = 0. + IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2 +C +C stblev for points zm < plbh and stable and neutral +C unslev for points zm < plbh and unstable +C + IF (unstbl(i)) THEN + unslev(i) = .TRUE. + ELSE + stblev(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C +C Stable and neutral points; set diffusivities; counter-gradient +C terms zero for stable case: +C + DO i = 1, knon + IF (stblev(i)) THEN + IF (zl(i).LE.1.) THEN + pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i)) + ELSE + pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i)) + ENDIF + pcfm(i,k) = pblk(i) + pcfh(i,k) = pcfm(i,k) + ENDIF + ENDDO +C +C unssrf, unstable within surface layer of pbl +C unsout, unstable within outer layer of pbl +C + DO i = 1, knon + unssrf(i) = .FALSE. + unsout(i) = .FALSE. + IF (unslev(i)) THEN + IF (zh(i).lt.sffrac) THEN + unssrf(i) = .TRUE. + ELSE + unsout(i) = .TRUE. + ENDIF + ENDIF + ENDDO +C +C Unstable for surface layer; counter-gradient terms zero +C + DO i = 1, knon + IF (unssrf(i)) THEN + term = (1. - betam*zl(i))**onet + pblk(i) = fak1(i)*zh(i)*zzh(i)*term + pr(i) = term/sqrt(1. - betah*zl(i)) + ENDIF + ENDDO +C +C Unstable for outer layer; counter-gradient terms non-zero: +C + DO i = 1, knon + IF (unsout(i)) THEN + pblk(i) = fak2(i)*zh(i)*zzh(i) + cgs(i,k) = fak3(i)/(pblh(i)*wm(i)) + cgh(i,k) = khfs(i)*cgs(i,k) + pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak + cgq(i,k) = kqfs(i)*cgs(i,k) + ENDIF + ENDDO +C +C For all unstable layers, set diffusivities +C + DO i = 1, knon + IF (unslev(i)) THEN + pcfm(i,k) = pblk(i) + pcfh(i,k) = pblk(i)/pr(i) + ENDIF + ENDDO + 1000 continue ! end of level loop + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nuage.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nuage.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nuage.F (revision 1634) @@ -0,0 +1,408 @@ +! $Id$ +! + SUBROUTINE nuage (paprs, pplay, + . t, pqlwp, pclc, pcltau, pclemi, + . pch, pcl, pcm, pct, pctlwp, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910 +c Objet: Calculer epaisseur optique et emmissivite des nuages +c====================================================================== +c Arguments: +c t-------input-R-temperature +c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg) +c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1) +c ok_aie--input-L-apply aerosol indirect effect or not +c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3] +c mass_solu_aero_pi--input-R-dito, pre-industrial value +c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land) +c bl95_b1-input-R-a parameter, may be varied for tests ( -"- ) +c +c cldtaupi-output-R-pre-industrial value of cloud optical thickness, +c needed for the diagnostics of the aerosol indirect +c radiative forcing (see radlwsw) +c re------output-R-Cloud droplet effective radius multiplied by fl [um] +c fl------output-R-Denominator to re, introduced to avoid problems in +c the averaging of the output. fl is the fraction of liquid +c water clouds within a grid cell +c +c pcltau--output-R-epaisseur optique des nuages +c pclemi--output-R-emissivite des nuages (0 a 1) +c====================================================================== +C +#include "YOMCST.h" +c +cym#include "dimensions.h" +cym#include "dimphy.h" + REAL paprs(klon,klev+1), pplay(klon,klev) + REAL t(klon,klev) +c + REAL pclc(klon,klev) + REAL pqlwp(klon,klev) + REAL pcltau(klon,klev), pclemi(klon,klev) +c + REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon) +c + LOGICAL lo +c + REAL cetahb, cetamb + PARAMETER (cetahb = 0.45, cetamb = 0.80) +C + INTEGER i, k + REAL zflwp, zradef, zfice, zmsac +c + REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2 + PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0) +ccc PARAMETER (rad_chaud=15.0, rad_froid=35.0) +c sintex initial PARAMETER (rad_chaud=10.0, rad_froid=30.0) + REAL coef, coef_froi, coef_chau + PARAMETER (coef_chau=0.13, coef_froi=0.09) + REAL seuil_neb, t_glace + PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0) + INTEGER nexpo ! exponentiel pour glace/eau + PARAMETER (nexpo=6) + +cjq for the aerosol indirect effect +cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003 +cjq + LOGICAL ok_aie ! Apply AIE or not? + + REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols[ug m-3] + REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value + REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3] + REAL re(klon, klev) ! cloud droplet effective radius [um] + REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value) + REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value) + + REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell) + + REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula + + REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag +cjq-end + +ccc PARAMETER (nexpo=1) +c +c Calculer l'epaisseur optique et l'emmissivite des nuages +c + DO k = 1, klev + DO i = 1, klon + rad_chaud = rad_chau1 + IF (k.LE.3) rad_chaud = rad_chau2 + + pclc(i,k) = MAX(pclc(i,k), seuil_neb) + zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k) + . *(paprs(i,k)-paprs(i,k+1)) + zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace) + zfice = MIN(MAX(zfice,0.0),1.0) + zfice = zfice**nexpo + + IF (ok_aie) THEN + ! Formula "D" of Boucher and Lohmann, Tellus, 1995 + ! + cdnc(i,k) = 10.**(bl95_b0+bl95_b1* + . log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3 + ! Cloud droplet number concentration (CDNC) is restricted + ! to be within [20, 1000 cm^3] + ! + cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k))) + cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1* + . log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3 + cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k))) + ! + ! + ! air density: pplay(i,k) / (RD * zT(i,k)) + ! factor 1.1: derive effective radius from volume-mean radius + ! factor 1000 is the water density + ! _chaud means that this is the CDR for liquid water clouds + ! + rad_chaud = + . 1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) ) + . / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.) + ! + ! Convert to um. CDR shall be at least 3 um. + ! + rad_chaud = MAX(rad_chaud*1.e6, 3.) + + ! For output diagnostics + ! + ! Cloud droplet effective radius [um] + ! + ! we multiply here with f * xl (fraction of liquid water + ! clouds in the grid cell) to avoid problems in the + ! averaging of the output. + ! In the output of IOIPSL, derive the real cloud droplet + ! effective radius as re/fl + ! + fl(i,k) = pclc(i,k)*(1.-zfice) + re(i,k) = rad_chaud*fl(i,k) + + ! Pre-industrial cloud opt thickness + ! + ! "radius" is calculated as rad_chaud above (plus the + ! ice cloud contribution) but using cdnc_pi instead of + ! cdnc. + radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k))) + . / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.), + . 3.) * (1.-zfice) + rad_froid * zfice + cldtaupi(i,k) = 3.0/2.0 * zflwp / radius + . + ENDIF ! ok_aie + + radius = rad_chaud * (1.-zfice) + rad_froid * zfice + coef = coef_chau * (1.-zfice) + coef_froi * zfice + pcltau(i,k) = 3.0/2.0 * zflwp / radius + pclemi(i,k) = 1.0 - EXP( - coef * zflwp) + lo = (pclc(i,k) .LE. seuil_neb) + IF (lo) pclc(i,k) = 0.0 + IF (lo) pcltau(i,k) = 0.0 + IF (lo) pclemi(i,k) = 0.0 + + IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k) + ENDDO + ENDDO +ccc DO k = 1, klev +ccc DO i = 1, klon +ccc t(i,k) = t(i,k) +ccc pclc(i,k) = MAX( 1.e-5 , pclc(i,k) ) +ccc lo = pclc(i,k) .GT. (2.*1.e-5) +ccc zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1)) +ccc . /(rg*pclc(i,k)) +ccc zradef = 10.0 + (1.-sigs(k))*45.0 +ccc pcltau(i,k) = 1.5 * zflwp / zradef +ccc zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0) +ccc zmsac = 0.13*(1.0-zfice) + 0.08*zfice +ccc pclemi(i,k) = 1.-EXP(-zmsac*zflwp) +ccc if (.NOT.lo) pclc(i,k) = 0.0 +ccc if (.NOT.lo) pcltau(i,k) = 0.0 +ccc if (.NOT.lo) pclemi(i,k) = 0.0 +ccc ENDDO +ccc ENDDO +cccccc print*, 'pas de nuage dans le rayonnement' +cccccc DO k = 1, klev +cccccc DO i = 1, klon +cccccc pclc(i,k) = 0.0 +cccccc pcltau(i,k) = 0.0 +cccccc pclemi(i,k) = 0.0 +cccccc ENDDO +cccccc ENDDO +C +C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS +C + DO i = 1, klon + pct(i)=1.0 + pch(i)=1.0 + pcm(i) = 1.0 + pcl(i) = 1.0 + pctlwp(i) = 0.0 + ENDDO +C + DO k = klev, 1, -1 + DO i = 1, klon + pctlwp(i) = pctlwp(i) + . + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG + pct(i) = pct(i)*(1.0-pclc(i,k)) + if (pplay(i,k).LE.cetahb*paprs(i,1)) + . pch(i) = pch(i)*(1.0-pclc(i,k)) + if (pplay(i,k).GT.cetahb*paprs(i,1) .AND. + . pplay(i,k).LE.cetamb*paprs(i,1)) + . pcm(i) = pcm(i)*(1.0-pclc(i,k)) + if (pplay(i,k).GT.cetamb*paprs(i,1)) + . pcl(i) = pcl(i)*(1.0-pclc(i,k)) + ENDDO + ENDDO +C + DO i = 1, klon + pct(i)=1.-pct(i) + pch(i)=1.-pch(i) + pcm(i)=1.-pcm(i) + pcl(i)=1.-pcl(i) + ENDDO +C + RETURN + END + SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop, + . diafra,dialiq) + use dimphy + IMPLICIT none +c +c Laurent Li (LMD/CNRS), le 12 octobre 1998 +c (adaptation du code ECMWF) +c +c Dans certains cas, le schema pronostique des nuages n'est +c pas suffisament performant. On a donc besoin de diagnostiquer +c ces nuages. Je dois avouer que c'est une frustration. +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments d'entree: + REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche + REAL pplay(klon,klev) ! pression (Pa) au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (Kg/Kg) + REAL rain(klon) ! pluie convective (kg/m2/s) + REAL snow(klon) ! neige convective (kg/m2/s) + INTEGER ktop(klon) ! sommet de la convection + INTEGER kbot(klon) ! bas de la convection +c +c Arguments de sortie: + REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee + REAL dialiq(klon,klev) ! eau liquide nuageuse +c +c Constantes ajustables: + REAL CANVA, CANVB, CANVH + PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4) + REAL CCA, CCB, CCC + PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8) + REAL CCFCT, CCSCAL + PARAMETER (CCFCT=0.400) + PARAMETER (CCSCAL=1.0E+11) + REAL CETAHB, CETAMB + PARAMETER (CETAHB=0.45, CETAMB=0.80) + REAL CCLWMR + PARAMETER (CCLWMR=1.E-04) + REAL ZEPSCR + PARAMETER (ZEPSCR=1.0E-10) +c +c Variables locales: + INTEGER i, k + REAL zcc(klon) +c +c Initialisation: +c + DO k = 1, klev + DO i = 1, klon + diafra(i,k) = 0.0 + dialiq(i,k) = 0.0 + ENDDO + ENDDO +c + DO i = 1, klon ! Calculer la fraction nuageuse + zcc(i) = 0.0 + IF((rain(i)+snow(i)).GT.0.) THEN + zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB + zcc(i)= MIN(CCC,MAX(0.0,zcc(i))) + ENDIF + ENDDO +c + DO i = 1, klon ! pour traiter les enclumes + diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT) + IF ((zcc(i).GE.CANVH) .AND. + . (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1))) + . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)), + . MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB))) + dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i)) + ENDDO +c + DO k = 1, klev ! nuages convectifs (sauf enclumes) + DO i = 1, klon + IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN + diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT) + dialiq(i,k)=CCLWMR*diafra(i,k) + ENDIF + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq) + use dimphy + IMPLICIT none +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments d'entree: + REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche + REAL pplay(klon,klev) ! pression (Pa) au milieu de couche + REAL t(klon,klev) ! temperature (K) + REAL q(klon,klev) ! humidite specifique (Kg/Kg) +c +c Arguments de sortie: + REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee + REAL dialiq(klon,klev) ! eau liquide nuageuse +c + REAL CETAMB + PARAMETER (CETAMB=0.80) + REAL CLOIA, CLOIB, CLOIC, CLOID + PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0) +ccc PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0) + REAL RGAMMAS + PARAMETER (RGAMMAS=0.05) + REAL CRHL + PARAMETER (CRHL=0.15) +ccc PARAMETER (CRHL=0.70) + REAL t_coup + PARAMETER (t_coup=234.0) +c +c Variables locales: + INTEGER i, k, kb, invb(klon) + REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp + REAL zdelta, zcor +c +c Fonctions thermodynamiques: +#include "YOETHF.h" +#include "FCTTRE.h" +c +c Initialisation: +c + DO k = 1, klev + DO i = 1, klon + diafra(i,k) = 0.0 + dialiq(i,k) = 0.0 + ENDDO + ENDDO +c + DO i = 1, klon + invb(i) = klev + zdthmin(i)=0.0 + ENDDO + + DO k = 2, klev/2-1 + DO i = 1, klon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) + . - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) + zdthdp = zdthdp * CLOIA + IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND. + . zdthdp.LT.zdthmin(i) ) THEN + zdthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO + + DO i = 1, klon + kb=invb(i) + IF (thermcep) THEN + zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb))) + zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb) + zqs=MIN(0.5,zqs) + zcor=1./(1.-RETV*zqs) + zqs=zqs*zcor + ELSE + IF (t(i,kb) .LT. t_coup) THEN + zqs = qsats(t(i,kb)) / pplay(i,kb) + ELSE + zqs = qsatl(t(i,kb)) / pplay(i,kb) + ENDIF + ENDIF + zcll = CLOIB * zdthmin(i) + CLOIC + zcll = MIN(1.0,MAX(0.0,zcll)) + zrhb= q(i,kb)/zqs + IF (zcll.GT.0.0.AND.zrhb.LT.CRHL) + . zcll=zcll*(1.-(CRHL-zrhb)*CLOID) + zcll=MIN(1.0,MAX(0.0,zcll)) + diafra(i,kb) = MAX(diafra(i,kb),zcll) + dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nuage.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nuage.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/nuage.h (revision 1634) @@ -0,0 +1,9 @@ +! +! $Id$ +! + REAL rad_froid, rad_chau1, rad_chau2, t_glace_max, t_glace_min + REAL rei_min,rei_max + + common /nuagecom/ rad_froid,rad_chau1, rad_chau2,t_glace_max, & + & t_glace_min,rei_min,rei_max +!$OMP THREADPRIVATE(/nuagecom/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/o3_chem_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/o3_chem_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/o3_chem_m.F90 (revision 1634) @@ -0,0 +1,172 @@ +! $Id$ +module o3_chem_m + + IMPLICIT none + + private o3_prod + +contains + + subroutine o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, rlat, rlon, q) + + ! This procedure evolves the ozone mass fraction through a time + ! step taking only chemistry into account. + + ! All the 2-dimensional arrays are on the partial "physics" grid. + ! Their shape is "(/klon, llm/)". + ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)". + + use assert_m, only: assert + use dimphy, only: klon + use regr_pr_comb_coefoz_m, only: c_Mob, a4_mass, a2, r_het_interm + + integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 + real, intent(in):: gmtime ! heure de la journée en fraction de jour + real, intent(in):: t_seri(:, :) ! (klon, llm) temperature, in K + + real, intent(in):: zmasse(:, :) ! (klon, llm) + ! (column-density of mass of air in a cell, in kg m-2) + ! "zmasse(:, k)" is for layer "k".) + + real, intent(in):: pdtphys ! time step for physics, in s + + REAL, intent(in):: rlat(:), rlon(:) + ! (longitude and latitude of each horizontal position, in degrees) + + real, intent(inout):: q(:, :) ! (klon, llm) mass fraction of ozone + ! "q(:, k)" is at middle of layer "k".) + + ! Variables local to the procedure: + include "dimensions.h" + include "comconst.h" + ! (for "pi") + integer k + + real c(klon, llm) + ! (constant term during a time step in the net mass production + ! rate of ozone by chemistry, per unit mass of air, in s-1) + ! "c(:, k)" is at middle of layer "k".) + + real b(klon, llm) + ! (coefficient of "q" in the net mass production + ! rate of ozone by chemistry, per unit mass of air, in s-1) + ! "b(:, k)" is at middle of layer "k".) + + real dq_o3_chem(klon, llm) + ! (variation of ozone mass fraction due to chemistry during a time step) + ! "dq_o3_chem(:, k)" is at middle of layer "k".) + + real earth_long + ! (longitude vraie de la Terre dans son orbite solaire, par + ! rapport au point vernal (21 mars), en degrés) + + real pmu0(klon) ! mean of cosine of solar zenith angle during "pdtphys" + real trash1 + real trash2(klon) + + !------------------------------------------------------------- + + call assert(klon == (/size(q, 1), size(t_seri, 1), size(zmasse, 1), & + size(rlat), size(rlon)/), "o3_chem klon") + call assert(llm == (/size(q, 2), size(t_seri, 2), size(zmasse, 2)/), & + "o3_chem llm") + + c = c_Mob + a4_mass * t_seri + + ! Compute coefficient "b": + + ! Heterogeneous chemistry is only at low temperature: + where (t_seri < 195.) + b = r_het_interm + elsewhere + b = 0. + end where + + ! Heterogeneous chemistry is only during daytime: + call orbite(real(julien), earth_long, trash1) + call zenang(earth_long, gmtime, pdtphys, rlat, rlon, pmu0, trash2) + forall (k = 1: llm) + where (pmu0 <= cos(87. / 180. * pi)) b(:, k) = 0. + end forall + + b = b + a2 + + ! Midpoint method: + + ! Trial step to the midpoint: + dq_o3_chem = o3_prod(q, zmasse, c, b) * pdtphys / 2 + ! "Real" step across the whole interval: + dq_o3_chem = o3_prod(q + dq_o3_chem, zmasse, c, b) * pdtphys + q = q + dq_o3_chem + + ! Confine the mass fraction: + q = min(max(q, 0.), .01) + + end subroutine o3_chem + + !************************************************* + + function o3_prod(q, zmasse, c, b) + + ! This function computes the production rate of ozone by chemistry. + + ! All the 2-dimensional arrays are on the partial "physics" grid. + ! Their shape is "(/klon, llm/)". + ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)". + + use regr_pr_comb_coefoz_m, only: a6_mass + use assert_m, only: assert + use dimphy, only: klon + + real, intent(in):: q(:, :) ! mass fraction of ozone + ! "q(:, k)" is at middle of layer "k".) + + real, intent(in):: zmasse(:, :) + ! (column-density of mass of air in a layer, in kg m-2) + ! ("zmasse(:, k)" is for layer "k".) + + real, intent(in):: c(:, :) + ! (constant term during a time step in the net mass production + ! rate of ozone by chemistry, per unit mass of air, in s-1) + ! "c(:, k)" is at middle of layer "k".) + + real, intent(in):: b(:, :) + ! (coefficient of "q" in the net mass production rate of ozone by + ! chemistry, per unit mass of air, in s-1) + ! ("b(:, k)" is at middle of layer "k".) + + include "dimensions.h" + + real o3_prod(klon, llm) + ! (net mass production rate of ozone by chemistry, per unit mass + ! of air, in s-1) + ! ("o3_prod(:, k)" is at middle of layer "k".) + + ! Variables local to the procedure: + + real sigma_mass(klon, llm) + ! (mass column-density of ozone above point, in kg m-2) + ! ("sigma_mass(:, k)" is at middle of layer "k".) + + integer k + + !------------------------------------------------------------------- + + call assert(klon == (/size(q, 1), size(zmasse, 1), size(c, 1), & + size(b, 1)/), "o3_prod 1") + call assert(llm == (/size(q, 2), size(zmasse, 2), size(c, 2), & + size(b, 2)/), "o3_prod 2") + + ! Compute the column-density above the base of layer + ! "k", and, as a first approximation, take it as column-density + ! above the middle of layer "k": + sigma_mass(:, llm) = zmasse(:, llm) * q(:, llm) ! top layer + do k = llm - 1, 1, -1 + sigma_mass(:, k) = sigma_mass(:, k+1) + zmasse(:, k) * q(:, k) + end do + + o3_prod = c + b * q + a6_mass * sigma_mass + + end function o3_prod + +end module o3_chem_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/o3cm.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/o3cm.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/o3cm.F (revision 1634) @@ -0,0 +1,66 @@ +! +! $Id$ +! + SUBROUTINE o3cm (amb, bmb, sortie, ntab) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Ce programme calcule le contenu en ozone "sortie" +c (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb) +c "ntab" est le nombre d'intervalles pour l'integration, sa +c valeur depend bien sur de l'epaisseur de la couche et de +c la precision qu'on souhaite a obtenir +c====================================================================== + REAL amb, bmb, sortie + INTEGER ntab +c====================================================================== + INTEGER n + REAL xtab(500), xa, xb, ya, yb, xincr +c====================================================================== + external mbtozm + CHARACTER (LEN=20) :: modname='' + CHARACTER (LEN=80) :: abort_message +c====================================================================== +c la fonction en ligne w(x) donne le profil de l'ozone en fonction +c de l'altitude (unite: cm.atm / km) +c (Green 1964, Appl. Opt. 3: 203-208) + REAL wp, xp, h, x, w, con + PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0) + w(x) = wp/h * EXP((x-xp)/h)/ (con+EXP((x-xp)/h))**2 +c====================================================================== + IF (ntab .GT. 499) THEN + abort_message = 'BIG ntab' + CALL abort_gcm (modname,abort_message,1) + ENDIF + xincr = (bmb-amb) / REAL(ntab) + xtab(1) = amb + DO n = 2, ntab + xtab(n) = xtab(n-1) + xincr + ENDDO + xtab(ntab+1) = bmb + sortie = 0.0 + DO n = 1, ntab + CALL mbtozm(xtab(n), xa) + CALL mbtozm(xtab(n+1), xb) + xa = xa / 1000. + xb = xb / 1000. + ya = w(xa) + yb = w(xb) + sortie = sortie + (ya+yb)/2.0 * ABS(xb-xa) + ENDDO + RETURN + END + SUBROUTINE mbtozm(rmb,zm) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) +c Objet: transformer une hauteur de mb (rmb) en metre (zm) +c====================================================================== + REAL rmb, zm +c====================================================================== + REAL gama, tzero, pzero, g, r + PARAMETER (gama=6.5e-3, tzero=288., pzero=1013.25) + PARAMETER (g=9.81, r=287.0) + zm = tzero/gama * ( 1.-(rmb/pzero)**(r*gama/g) ) + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/oasis.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/oasis.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/oasis.F90 (revision 1634) @@ -0,0 +1,457 @@ +! +MODULE oasis +! +! This module contains subroutines for initialization, sending and receiving +! towards the coupler OASIS3. It also contains some parameters for the coupling. +! +! This module should always be compiled. With the coupler OASIS3 available the cpp key +! CPP_COUPLE should be set and the entier of this file will then be compiled. +! In a forced mode CPP_COUPLE should not be defined and the compilation ends before +! the CONTAINS, without compiling the subroutines. +! + USE dimphy + USE mod_phys_lmdz_para + USE write_field_phy + +#ifdef CPP_COUPLE + USE mod_prism_proto + USE mod_prism_def_partition_proto + USE mod_prism_get_proto + USE mod_prism_put_proto +#endif + + IMPLICIT NONE + + ! Id for fields sent to ocean + INTEGER, PARAMETER :: ids_tauxxu = 1 + INTEGER, PARAMETER :: ids_tauyyu = 2 + INTEGER, PARAMETER :: ids_tauzzu = 3 + INTEGER, PARAMETER :: ids_tauxxv = 4 + INTEGER, PARAMETER :: ids_tauyyv = 5 + INTEGER, PARAMETER :: ids_tauzzv = 6 + INTEGER, PARAMETER :: ids_windsp = 7 + INTEGER, PARAMETER :: ids_shfice = 8 + INTEGER, PARAMETER :: ids_shfoce = 9 + INTEGER, PARAMETER :: ids_shftot = 10 + INTEGER, PARAMETER :: ids_nsfice = 11 + INTEGER, PARAMETER :: ids_nsfoce = 12 + INTEGER, PARAMETER :: ids_nsftot = 13 + INTEGER, PARAMETER :: ids_dflxdt = 14 + INTEGER, PARAMETER :: ids_totrai = 15 + INTEGER, PARAMETER :: ids_totsno = 16 + INTEGER, PARAMETER :: ids_toteva = 17 + INTEGER, PARAMETER :: ids_icevap = 18 + INTEGER, PARAMETER :: ids_ocevap = 19 + INTEGER, PARAMETER :: ids_calvin = 20 + INTEGER, PARAMETER :: ids_liqrun = 21 + INTEGER, PARAMETER :: ids_runcoa = 22 + INTEGER, PARAMETER :: ids_rivflu = 23 + INTEGER, PARAMETER :: ids_atmco2 = 24 + INTEGER, PARAMETER :: ids_taumod = 25 + INTEGER, PARAMETER :: maxsend = 25 ! Maximum number of fields to send + + ! Id for fields received from ocean + INTEGER, PARAMETER :: idr_sisutw = 1 + INTEGER, PARAMETER :: idr_icecov = 2 + INTEGER, PARAMETER :: idr_icealw = 3 + INTEGER, PARAMETER :: idr_icetem = 4 + INTEGER, PARAMETER :: idr_curenx = 5 + INTEGER, PARAMETER :: idr_cureny = 6 + INTEGER, PARAMETER :: idr_curenz = 7 + INTEGER, PARAMETER :: idr_oceco2 = 8 + INTEGER, PARAMETER :: maxrecv = 8 ! Maximum number of fields to receive + + + TYPE, PUBLIC :: FLD_CPL ! Type for coupling field information + CHARACTER(len = 8) :: name ! Name of the coupling field + LOGICAL :: action ! To be exchanged or not + INTEGER :: nid ! Id of the field + END TYPE FLD_CPL + + TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend ! Information for sending coupling fields + TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv ! Information for receiving coupling fields + + LOGICAL,SAVE :: cpl_current +!$OMP THREADPRIVATE(cpl_current) + +#ifdef CPP_COUPLE + +CONTAINS + + SUBROUTINE inicma +!************************************************************************************ +!**** *INICMA* - Initialize coupled mode communication for atmosphere +! and exchange some initial information with Oasis +! +! Rewrite to take the PRISM/psmile library into account +! LF 09/2003 +! + USE IOIPSL + USE surface_data, ONLY : version_ocean + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl + + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" + +! Local variables +!************************************************************************************ + INTEGER :: comp_id + INTEGER :: ierror, il_commlocal + INTEGER :: il_part_id + INTEGER, DIMENSION(3) :: ig_paral + INTEGER, DIMENSION(2) :: il_var_nodims + INTEGER, DIMENSION(4) :: il_var_actual_shape + INTEGER :: il_var_type + INTEGER :: jf + CHARACTER (len = 6) :: clmodnam + CHARACTER (len = 20) :: modname = 'inicma' + CHARACTER (len = 80) :: abort_message + LOGICAL :: cpl_current_omp + +!* 1. Initializations +! --------------- +!************************************************************************************ + WRITE(lunout,*) ' ' + WRITE(lunout,*) ' ' + WRITE(lunout,*) ' ROUTINE INICMA' + WRITE(lunout,*) ' **************' + WRITE(lunout,*) ' ' + WRITE(lunout,*) ' ' + +! +! Define the model name +! + clmodnam = 'lmdz.x' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp + + +!************************************************************************************ +! Define if coupling ocean currents or not +!************************************************************************************ +!$OMP MASTER + cpl_current_omp = .FALSE. + CALL getin('cpl_current', cpl_current_omp) +!$OMP END MASTER +!$OMP BARRIER + cpl_current = cpl_current_omp + WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current + +!************************************************************************************ +! Define coupling variables +!************************************************************************************ + +! Atmospheric variables to send + +!$OMP MASTER + infosend(:)%action = .FALSE. + + infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU' + infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU' + infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU' + infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV' + infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV' + infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV' + infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP' + infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE' + infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE' + infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT' + infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN' + + IF (version_ocean=='nemo') THEN + infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX' + infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX' + infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI' + infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO' + infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA' + infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP' + infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN' + infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD' + IF (carbon_cycle_cpl) THEN + infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2' + ENDIF + + ELSE IF (version_ocean=='opa8') THEN + infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE' + infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE' + infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE' + infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE' + infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU' + infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU' + infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA' + infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU' + ENDIF + +! Oceanic variables to receive + + inforecv(:)%action = .FALSE. + + inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW' + inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV' + inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW' + inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW' + + IF (cpl_current ) THEN + inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX' + inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY' + inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ' + ENDIF + + IF (carbon_cycle_cpl ) THEN + inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX' + ENDIF + +!************************************************************************************ +! Here we go: psmile initialisation +!************************************************************************************ + IF (is_sequential) THEN + CALL prism_init_comp_proto (comp_id, clmodnam, ierror) + + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Probleme init dans prism_init_comp ' + CALL abort_gcm(modname,abort_message,1) + ELSE + WRITE(lunout,*) 'inicma : init psmile ok ' + ENDIF + ENDIF + + CALL prism_get_localcomm_proto (il_commlocal, ierror) +!************************************************************************************ +! Domain decomposition +!************************************************************************************ + ig_paral(1) = 1 ! apple partition for // + ig_paral(2) = (jj_begin-1)*iim+ii_begin-1 ! offset + ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1 + + IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1 + WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3) + + ierror=PRISM_Ok + CALL prism_def_partition_proto (il_part_id, ig_paral, ierror) + + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Probleme dans prism_def_partition ' + CALL abort_gcm(modname,abort_message,1) + ELSE + WRITE(lunout,*) 'inicma : decomposition domaine psmile ok ' + ENDIF + + il_var_nodims(1) = 2 + il_var_nodims(2) = 1 + + il_var_actual_shape(1) = 1 + il_var_actual_shape(2) = iim + il_var_actual_shape(3) = 1 + il_var_actual_shape(4) = jjm+1 + + il_var_type = PRISM_Real + +!************************************************************************************ +! Oceanic Fields to receive +! Loop over all possible variables +!************************************************************************************ + DO jf=1, maxrecv + IF (inforecv(jf)%action) THEN + CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, & + il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, & + ierror) + IF (ierror .NE. PRISM_Ok) THEN + WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& + inforecv(jf)%name + abort_message=' Problem in call to prism_def_var_proto for fields to receive' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + +!************************************************************************************ +! Atmospheric Fields to send +! Loop over all possible variables +!************************************************************************************ + DO jf=1,maxsend + IF (infosend(jf)%action) THEN + CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, & + il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, & + ierror) + IF (ierror .NE. PRISM_Ok) THEN + WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',& + infosend(jf)%name + abort_message=' Problem in call to prism_def_var_proto for fields to send' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + +!************************************************************************************ +! End definition +!************************************************************************************ + CALL prism_enddef_proto(ierror) + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Problem in call to prism_endef_proto' + CALL abort_gcm(modname,abort_message,1) + ELSE + WRITE(lunout,*) 'inicma : endef psmile ok ' + ENDIF + +!$OMP END MASTER + + END SUBROUTINE inicma + +! +!************************************************************************************ +! + + SUBROUTINE fromcpl(ktime, tab_get) +! ====================================================================== +! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST +! and Sea-Ice provided by the coupler. Adaptation to psmile library +!====================================================================== +! + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" +! Input arguments +!************************************************************************************ + INTEGER, INTENT(IN) :: ktime + +! Output arguments +!************************************************************************************ + REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get + +! Local variables +!************************************************************************************ + INTEGER :: ierror, i + INTEGER :: istart,iend + CHARACTER (len = 20) :: modname = 'fromcpl' + CHARACTER (len = 80) :: abort_message + REAL, DIMENSION(iim*jj_nb) :: field + +!************************************************************************************ + WRITE (lunout,*) ' ' + WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime + WRITE (lunout,*) ' ' + + istart=ii_begin + IF (is_south_pole) THEN + iend=(jj_end-jj_begin)*iim+iim + ELSE + iend=(jj_end-jj_begin)*iim+ii_end + ENDIF + + DO i = 1, maxrecv + IF (inforecv(i)%action) THEN + field(:) = -99999. + CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror) + tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/)) + + IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. & + ierror.NE.PRISM_FromRest & + .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 + abort_message=' Problem in prism_get_proto ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + + + END SUBROUTINE fromcpl + +! +!************************************************************************************ +! + + SUBROUTINE intocpl(ktime, last, tab_put) +! ====================================================================== +! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the +! atmospheric coupling fields to the coupler with the psmile library. +! IF last time step, writes output fields to binary files. +! ====================================================================== +! +! + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" +! Input arguments +!************************************************************************************ + INTEGER, INTENT(IN) :: ktime + LOGICAL, INTENT(IN) :: last + REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put + +! Local variables +!************************************************************************************ + LOGICAL :: checkout + INTEGER :: istart,iend + INTEGER :: wstart,wend + INTEGER :: ierror, i + REAL, DIMENSION(iim*jj_nb) :: field + CHARACTER (len = 20),PARAMETER :: modname = 'intocpl' + CHARACTER (len = 80) :: abort_message + +!************************************************************************************ + checkout=.FALSE. + + WRITE(lunout,*) ' ' + WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime + WRITE(lunout,*) 'last = ', last + WRITE(lunout,*) + + + istart=ii_begin + IF (is_south_pole) THEN + iend=(jj_end-jj_begin)*iim+iim + ELSE + iend=(jj_end-jj_begin)*iim+ii_end + ENDIF + + IF (checkout) THEN + wstart=istart + wend=iend + IF (is_north_pole) wstart=istart+iim-1 + IF (is_south_pole) wend=iend-iim+1 + + DO i = 1, maxsend + IF (infosend(i)%action) THEN + field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/)) + CALL writefield_phy(infosend(i)%name,field(wstart:wend),1) + END IF + END DO + END IF + +!************************************************************************************ +! PRISM_PUT +!************************************************************************************ + + DO i = 1, maxsend + IF (infosend(i)%action) THEN + field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/)) + CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror) + + IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest & + .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. & + ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN + WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime + abort_message=' Problem in prism_put_proto ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + END DO + +!************************************************************************************ +! Finalize PSMILE for the case is_sequential, if parallel finalization is done +! from Finalize_parallel in dyn3dpar/parallel.F90 +!************************************************************************************ + + IF (last) THEN + IF (is_sequential) THEN + CALL prism_terminate_proto(ierror) + IF (ierror .NE. PRISM_Ok) THEN + abort_message=' Problem in prism_terminate_proto ' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + ENDIF + + + END SUBROUTINE intocpl + +#endif + +END MODULE oasis Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_cpl_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_cpl_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_cpl_mod.F90 (revision 1634) @@ -0,0 +1,324 @@ +! +MODULE ocean_cpl_mod +! +! This module is used both for the sub-surface ocean and sea-ice for the case of a +! coupled model configuration, ocean=couple. +! + + IMPLICIT NONE + PRIVATE + + PUBLIC :: ocean_cpl_init, ocean_cpl_noice, ocean_cpl_ice + +!**************************************************************************************** +! +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE ocean_cpl_init(dtime, rlon, rlat) +! +! Allocate fields for this module and initailize the module mod_cpl +! + USE dimphy, ONLY : klon + USE cpl_mod + +! Input arguments +!************************************************************************************* + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + +! Local variables +!************************************************************************************* + INTEGER :: error + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'ocean_cpl_init' + +! Initialize module cpl_init + CALL cpl_init(dtime, rlon, rlat) + + END SUBROUTINE ocean_cpl_init +! +!**************************************************************************************** +! + SUBROUTINE ocean_cpl_noice( & + swnet, lwnet, alb1, & + windsp, fder_old, & + itime, dtime, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + +! +! This subroutine treats the "open ocean", all grid points that are not entierly covered +! by ice. The subroutine first receives fields from coupler, then some calculations at +! surface is done and finally it sends some fields to the coupler. +! + USE dimphy, ONLY : klon + USE cpl_mod + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" +! +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: swnet + REAL, DIMENSION(klon), INTENT(IN) :: lwnet + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: windsp + REAL, DIMENSION(klon), INTENT(IN) :: fder_old + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + INTEGER :: i + INTEGER, DIMENSION(1) :: iloc + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: fder_new + REAL, DIMENSION(klon) :: tsurf_cpl + REAL, DIMENSION(klon) :: u0_cpl, v0_cpl + REAL, DIMENSION(klon) :: u1_lay, v1_lay + LOGICAL :: check=.FALSE. + +! End definitions +!**************************************************************************************** + + IF (check) WRITE(*,*)' Entering ocean_cpl_noice' + +!**************************************************************************************** +! Receive sea-surface temperature(tsurf_cpl) from coupler +! +!**************************************************************************************** + CALL cpl_receive_ocean_fields(knon, knindex, tsurf_cpl, u0_cpl, v0_cpl) + +!**************************************************************************************** +! Calculate fluxes at surface +! +!**************************************************************************************** + cal = 0. + beta = 1. + dif_grnd = 0. + agesno(:) = 0. + + DO i = 1, knon + u1_lay(i) = u1(i) - u0_cpl(i) + v1_lay(i) = v1(i) - v0_cpl(i) + END DO + + CALL calcul_fluxs(knon, is_oce, dtime, & + tsurf_cpl, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0_cpl, v0_cpl, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! Calculate fder : flux derivative (sensible and latente) +! +!**************************************************************************************** + fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:) + + iloc = MAXLOC(fder_new(1:klon)) + IF (check .AND. fder_new(iloc(1))> 0.) THEN + WRITE(*,*)'**** Debug fder****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1)) + WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), & + dflux_s(iloc(1)), dflux_l(iloc(1)) + ENDIF + +!**************************************************************************************** +! Send and cumulate fields to the coupler +! +!**************************************************************************************** + + CALL cpl_send_ocean_fields(itime, knon, knindex, & + swnet, lwnet, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1, windsp) + + + END SUBROUTINE ocean_cpl_noice +! +!**************************************************************************************** +! + SUBROUTINE ocean_cpl_ice( & + rlon, rlat, swnet, lwnet, alb1, & + fder_old, & + itime, dtime, knon, knindex, & + lafin, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, pctsrf, & + radsol, snow, qsurf, & + alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) +! +! This subroutine treats the ocean where there is ice. The subroutine first receives +! fields from coupler, then some calculations at surface is done and finally sends +! some fields to the coupler. +! + USE dimphy, ONLY : klon + USE cpl_mod + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet + REAL, DIMENSION(klon), INTENT(IN) :: lwnet + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: fder_old + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + INTEGER :: i + INTEGER, DIMENSION(1) :: iloc + LOGICAL :: check=.FALSE. + REAL, PARAMETER :: t_grnd=271.35 + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: tsurf_cpl, fder_new + REAL, DIMENSION(klon) :: alb_cpl + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + +! End definitions +!**************************************************************************************** + + IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon + +!**************************************************************************************** +! Receive ocean temperature(tsurf_cpl) and albedo(alb_new) from coupler +! +!**************************************************************************************** + + CALL cpl_receive_seaice_fields(knon, knindex, & + tsurf_cpl, alb_cpl, u0, v0) + + alb1_new(1:knon) = alb_cpl(1:knon) + alb2_new(1:knon) = alb_cpl(1:knon) + + +!**************************************************************************************** +! Calculate fluxes at surface +! +!**************************************************************************************** + cal = 0. + dif_grnd = 0. + beta = 1.0 + + DO i = 1, knon + u1_lay(i) = u1(i) - u0(i) + v1_lay(i) = v1(i) - v0(i) + END DO + + CALL calcul_fluxs(knon, is_sic, dtime, & + tsurf_cpl, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! Calculate fder : flux derivative (sensible and latente) +! +!**************************************************************************************** + fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:) + + iloc = MAXLOC(fder_new(1:klon)) + IF (check .AND. fder_new(iloc(1))> 0.) THEN + WRITE(*,*)'**** Debug fder ****' + WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1)) + WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), & + dflux_s(iloc(1)), dflux_l(iloc(1)) + ENDIF + +!**************************************************************************************** +! Send and cumulate fields to the coupler +! +!**************************************************************************************** + + CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, & + pctsrf, lafin, rlon, rlat, & + swnet, lwnet, fluxlat, fluxsens, & + precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1) + + + END SUBROUTINE ocean_cpl_ice +! +!**************************************************************************************** +! +END MODULE ocean_cpl_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_forced_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_forced_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_forced_mod.F90 (revision 1634) @@ -0,0 +1,270 @@ +! +MODULE ocean_forced_mod +! +! This module is used for both the sub-surfaces ocean and sea-ice for the case of a +! forced ocean, "ocean=force". +! + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE ocean_forced_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, & + temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) +! +! This subroutine treats the "open ocean", all grid points that are not entierly covered +! by ice. +! The routine receives data from climatologie file limit.nc and does some calculations at the +! surface. +! + USE dimphy + USE calcul_fluxs_mod + USE limit_read_mod + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno !? put to 0 in ocean + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: alb_neig, tsurf_lim, zx_sl + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + LOGICAL :: check=.FALSE. + +!**************************************************************************************** +! Start calculation +!**************************************************************************************** + IF (check) WRITE(*,*)' Entering ocean_forced_noice' + +!**************************************************************************************** +! 1) +! Read sea-surface temperature from file limit.nc +! +!**************************************************************************************** + CALL limit_read_sst(knon,knindex,tsurf_lim) + +!**************************************************************************************** +! 2) +! Flux calculation +! +!**************************************************************************************** +! Set some variables for calcul_fluxs + cal = 0. + beta = 1. + dif_grnd = 0. + alb_neig(:) = 0. + agesno(:) = 0. +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + +! Calcul de tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l and qsurf + CALL calcul_fluxs(knon, is_oce, dtime, & + tsurf_lim, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + + END SUBROUTINE ocean_forced_noice +! +!*************************************************************************************** +! + SUBROUTINE ocean_forced_ice( & + itime, dtime, jour, knon, knindex, & + tsurf_in, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, qsol, agesno, tsoil, & + qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) +! +! This subroutine treats the ocean where there is ice. +! The routine reads data from climatologie file and does flux calculations at the +! surface. +! + USE dimphy + USE calcul_fluxs_mod + USE surface_data, ONLY : calice, calsno, tau_gl + USE limit_read_mod + USE fonte_neige_mod, ONLY : fonte_neige + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + INCLUDE "clesphys.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + LOGICAL :: check=.FALSE. + INTEGER :: i + REAL :: zfra + REAL, PARAMETER :: t_grnd=271.35 + REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol + REAL, DIMENSION(klon) :: alb_neig, tsurf_tmp + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + +!**************************************************************************************** +! Start calculation +!**************************************************************************************** + IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon + +!**************************************************************************************** +! 1) +! Flux calculation : tsurf_new, evap, fluxlat, fluxsens, flux_u1, flux_v1 +! dflux_s, dflux_l and qsurf +!**************************************************************************************** + tsurf_tmp(:) = tsurf_in(:) + +! calculate the parameters cal, beta, capsol and dif_grnd + CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd) + + + IF (soil_model) THEN +! update tsoil and calculate soilcap and soilflux + CALL soil(dtime, is_sic, knon, snow, tsurf_tmp, tsoil,soilcap, soilflux) + cal(1:knon) = RCPD / soilcap(1:knon) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + dif_grnd = 1.0 / tau_gl + ELSE + dif_grnd = 1.0 / tau_gl + cal = RCPD * calice + WHERE (snow > 0.0) cal = RCPD * calsno + ENDIF + + beta = 1.0 +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + CALL calcul_fluxs(knon, is_sic, dtime, & + tsurf_tmp, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! 2) +! Calculations due to snow and runoff +! +!**************************************************************************************** + CALL fonte_neige( knon, is_sic, knindex, dtime, & + tsurf_tmp, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) + +! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno) +! + 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(:) + + END SUBROUTINE ocean_forced_ice +! +!**************************************************************************************** +! +END MODULE ocean_forced_mod + + + + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_slab_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_slab_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ocean_slab_mod.F90 (revision 1634) @@ -0,0 +1,162 @@ +! +MODULE ocean_slab_mod +! +! This module is used for both surface ocean and sea-ice when using the slab ocean, +! "ocean=slab". +! + IMPLICIT NONE + PRIVATE + PUBLIC :: ocean_slab_frac, ocean_slab_noice + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified) + + USE dimphy + USE limit_read_mod + USE surface_data + INCLUDE "indicesol.h" +! INCLUDE "clesphys.h" + +! Arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime ! numero du pas de temps courant + INTEGER, INTENT(IN) :: jour ! jour a lire dans l'annee + REAL , INTENT(IN) :: dtime ! pas de temps de la physique (en s) + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction + LOGICAL, INTENT(OUT) :: is_modified ! true if pctsrf is modified at this time step + +! Local variables +!**************************************************************************************** + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'ocean_slab_frac' + + + IF (version_ocean == 'sicOBS') THEN + CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified) + ELSE + abort_message='Ocean slab model without forced sea-ice fractions has to be rewritten!!!' + CALL abort_gcm(modname,abort_message,1) +! Here should sea-ice/ocean fraction either be calculated or returned if saved as a module varaiable +! (in the case the new fractions are calculated in ocean_slab_ice or ocean_slab_noice subroutines). + END IF + + END SUBROUTINE ocean_slab_frac +! +!**************************************************************************************** +! + SUBROUTINE ocean_slab_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, tsurf_in, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, lmt_bils) + + USE dimphy + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "iniprint.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + INTEGER, INTENT(IN) :: jour + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: radsol + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: lmt_bils_oce, lmt_foce, diff_sst + REAL, DIMENSION(klon) :: u0, v0 + REAL, DIMENSION(klon) :: u1_lay, v1_lay + REAL :: calc_bils_oce, deltat + REAL, PARAMETER :: cyang=50.0 * 4.228e+06 ! capacite calorifique volumetrique de l'eau J/(m2 K) + +!**************************************************************************************** +! 1) Flux calculation +! +!**************************************************************************************** + cal(:) = 0. + beta(:) = 1. + dif_grnd(:) = 0. + agesno(:) = 0. + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_oce, dtime, & + tsurf_in, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! - Flux calculation at first modele level for U and V + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! 2) Get global variables lmt_bils and lmt_foce from file limit_slab.nc +! +!**************************************************************************************** + CALL limit_slab(itime, dtime, jour, lmt_bils, lmt_foce, diff_sst) ! global pour un processus + + lmt_bils_oce(:) = 0. + WHERE (lmt_foce > 0.) + lmt_bils_oce = lmt_bils / lmt_foce ! global + END WHERE + +!**************************************************************************************** +! 3) Recalculate new temperature +! +!**************************************************************************************** + DO i = 1, knon + calc_bils_oce = radsol(i) + fluxsens(i) + fluxlat(i) + deltat = (calc_bils_oce - lmt_bils_oce(knindex(i)))*dtime/cyang +diff_sst(knindex(i)) + tsurf_new(i) = tsurf_in(i) + deltat + END DO + + END SUBROUTINE ocean_slab_noice +! +!**************************************************************************************** +! +END MODULE ocean_slab_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/open_climoz_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/open_climoz_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/open_climoz_m.F90 (revision 1634) @@ -0,0 +1,73 @@ +! $Id$ +module open_climoz_m + + implicit none + +contains + + subroutine open_climoz(ncid, press_in_edg) + + ! This procedure should be called once per "gcm" run, by a single + ! thread of each MPI process. + ! The root MPI process opens "climoz_LMDZ.nc", reads the pressure + ! levels and broadcasts them to the other processes. + + ! We assume that, in "climoz_LMDZ.nc", the pressure levels are in hPa + ! and in strictly ascending order. + + use netcdf95, only: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid + use netcdf, only: nf90_nowrite + + use mod_phys_lmdz_mpi_data, only: is_mpi_root + use mod_phys_lmdz_mpi_transfert, only: bcast_mpi ! broadcast + + integer, intent(out):: ncid ! of "climoz_LMDZ.nc", OpenMP shared + + real, pointer:: press_in_edg(:) + ! edges of pressure intervals for ozone climatology, in Pa, in strictly + ! ascending order, OpenMP shared + + ! Variables local to the procedure: + + real, pointer:: plev(:) + ! (pressure levels for ozone climatology, converted to Pa, in strictly + ! ascending order) + + integer varid ! for NetCDF + integer n_plev ! number of pressure levels in the input data + integer k + + !--------------------------------------- + + print *, "Call sequence information: open_climoz" + + if (is_mpi_root) then + call nf95_open("climoz_LMDZ.nc", nf90_nowrite, ncid) + + call nf95_inq_varid(ncid, "plev", varid) + call nf95_gw_var(ncid, varid, plev) + ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa: + plev = plev * 100. + n_plev = size(plev) + end if + + call bcast_mpi(n_plev) + if (.not. is_mpi_root) allocate(plev(n_plev)) + call bcast_mpi(plev) + + ! Compute edges of pressure intervals: + allocate(press_in_edg(n_plev + 1)) + if (is_mpi_root) then + press_in_edg(1) = 0. + ! We choose edges halfway in logarithm: + forall (k = 2:n_plev) press_in_edg(k) = sqrt(plev(k - 1) * plev(k)) + press_in_edg(n_plev + 1) = huge(0.) + ! (infinity, but any value guaranteed to be greater than the + ! surface pressure would do) + end if + call bcast_mpi(press_in_edg) + deallocate(plev) ! pointer + + end subroutine open_climoz + +end module open_climoz_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orbite.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orbite.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orbite.F (revision 1634) @@ -0,0 +1,325 @@ +! +! $Header$ +! +c====================================================================== + SUBROUTINE orbite(xjour,longi,dist) + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818 +c Objet: pour un jour donne, calculer la longitude vraie de la terre +c (par rapport au point vernal-21 mars) dans son orbite solaire +c calculer aussi la distance terre-soleil (unite astronomique) +c====================================================================== +c Arguments: +c xjour--INPUT--R- jour de l'annee a compter du 1er janvier +c longi--OUTPUT-R- longitude vraie en degres par rapport au point +c vernal (21 mars) en degres +c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne) + REAL xjour, longi, dist +c====================================================================== +#include "YOMCST.h" +C +C -- Variables dynamiques locales + REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv +C + pir = 4.0*ATAN(1.0) / 180.0 + xl=R_peri+180.0 + xllp=xl*pir + xee=R_ecc*R_ecc + xse=SQRT(1.0-xee) + xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp) + . - xee/4.0*(0.5+xse)*SIN(2.0*xllp) + . + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp) + xlam=2.0*xlam/pir + dlamm=xlam+(xjour-81.0) + anm=dlamm-xl + ranm=anm*pir + xee=xee*R_ecc + ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm) + . +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm) + . +13.0/12.0*xee*SIN(3.0*ranm) +c + anv=ranv/pir + longi=anv+xl +C + dist = (1-R_ecc*R_ecc) + . /(1+R_ecc*COS(pir*(longi-(R_peri+180.0)))) + RETURN + END +c====================================================================== + SUBROUTINE angle(longi, lati, frac, muzero) + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur +c du soleil (cosinus de l'angle zinithal) moyenne sur la journee +c====================================================================== +c Arguments: +c longi----INPUT-R- la longitude vraie de la terre dans son plan +c solaire a partir de l'equinoxe de printemps (degre) +c lati-----INPUT-R- la latitude d'un point sur la terre (degre) +c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee +c par 24 heures (unite en fraction de 0 a 1) +c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur +c la journee (0 a 1) +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" + REAL longi + REAL lati(klon), frac(klon), muzero(klon) +#include "YOMCST.h" + REAL lat, omega, lon_sun, lat_sun + REAL pi_local, incl + INTEGER i +c + pi_local = 4.0 * ATAN(1.0) + incl=R_incl * pi_local / 180. +c + lon_sun = longi * pi_local / 180.0 + lat_sun = ASIN (sin(lon_sun)*SIN(incl) ) +c + DO i = 1, klon + lat = lati(i) * pi_local / 180.0 +c + IF ( lat .GE. (pi_local/2.+lat_sun) + . .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN + omega = 0.0 ! nuit polaire + ELSE IF ( lat.GE.(pi_local/2.-lat_sun) + . .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN + omega = pi_local ! journee polaire + ELSE + omega = -TAN(lat)*TAN(lat_sun) + omega = ACOS (omega) + ENDIF +c + frac(i) = omega / pi_local +c + IF (omega .GT. 0.0) THEN + muzero(i) = SIN(lat)*SIN(lat_sun) + . + COS(lat)*COS(lat_sun)*SIN(omega) / omega + ELSE + muzero(i) = 0.0 + ENDIF + ENDDO +c + RETURN + END +c==================================================================== + SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long, + s pmu0,frac) + USE dimphy + IMPLICIT none +c============================================================= +c Auteur : O. Boucher (LMD/CNRS) +c d'apres les routines zenith et angle de Z.X. Li +c Objet : calculer les valeurs moyennes du cos de l'angle zenithal +c et l'ensoleillement moyen entre gmtime1 et gmtime2 +c connaissant la declinaison, la latitude et la longitude. +c Rque : Different de la routine angle en ce sens que zenang +c fournit des moyennes de pmu0 et non des valeurs +c instantanees, du coup frac prend toutes les valeurs +c entre 0 et 1. +c Date : premiere version le 13 decembre 1994 +c revu pour GCM le 30 septembre 1996 +c=============================================================== +c longi : la longitude vraie de la terre dans son plan +c solaire a partir de l'equinoxe de printemps (degre) +c gmtime : temps universel en fraction de jour +c pdtrad : pas de temps du rayonnement (secondes) +c lat------INPUT : latitude en degres +c long-----INPUT : longitude en degres +c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad +c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad +c================================================================ +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c================================================================ + real, intent(in):: longi, gmtime, pdtrad + real lat(klon), long(klon), pmu0(klon), frac(klon) +c================================================================ + integer i + real gmtime1, gmtime2 + real pi_local, deux_pi_local, incl + real omega1, omega2, omega +c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi. +c omega : heure en radian du coucher de soleil +c -omega est donc l'heure en radian de lever du soleil + real omegadeb, omegafin + real zfrac1, zfrac2, z1_mu, z2_mu + real lat_sun ! declinaison en radian + real lon_sun ! longitude solaire en radian + real latr ! latitude du pt de grille en radian +c================================================================ +c + pi_local = 4.0 * ATAN(1.0) + deux_pi_local = 2.0 * pi_local + incl=R_incl * pi_local / 180. +c + lon_sun = longi * pi_local / 180.0 + lat_sun = ASIN (SIN(lon_sun)*SIN(incl) ) +c + gmtime1=gmtime*86400. + gmtime2=gmtime*86400.+pdtrad +c + DO i = 1, klon +c + latr = lat(i) * pi_local / 180. +c +c--pose probleme quand lat=+/-90 degres +c +c omega = -TAN(latr)*TAN(lat_sun) +c omega = ACOS(omega) +c IF (latr.GE.(pi_local/2.+lat_sun) +c . .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN +c omega = 0.0 ! nuit polaire +c ENDIF +c IF (latr.GE.(pi_local/2.-lat_sun) +c . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN +c omega = pi_local ! journee polaire +c ENDIF +c +c--remplace par cela (le cas par defaut est different) +c + omega=0.0 !--nuit polaire + IF (latr.GE.(pi_local/2.-lat_sun) + . .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN + omega = pi_local ! journee polaire + ENDIF + IF (latr.LT.(pi_local/2.+lat_sun).AND. + . latr.GT.(-pi_local/2.+lat_sun).AND. + . latr.LT.(pi_local/2.-lat_sun).AND. + . latr.GT.(-pi_local/2.-lat_sun)) THEN + omega = -TAN(latr)*TAN(lat_sun) + omega = ACOS(omega) + ENDIF +c + omega1 = gmtime1 + long(i)*86400.0/360.0 + omega1 = omega1 / 86400.0*deux_pi_local + omega1 = MOD (omega1+deux_pi_local, deux_pi_local) + omega1 = omega1 - pi_local +c + omega2 = gmtime2 + long(i)*86400.0/360.0 + omega2 = omega2 / 86400.0*deux_pi_local + omega2 = MOD (omega2+deux_pi_local, deux_pi_local) + omega2 = omega2 - pi_local +c + IF (omega1.LE.omega2) THEN !--on est dans la meme journee locale +c + IF (omega2.LE.-omega .OR. omega1.GE.omega + . .OR. omega.LT.1e-5) THEN !--nuit + frac(i)=0.0 + pmu0(i)=0.0 + ELSE !--jour+nuit/jour + omegadeb=MAX(-omega,omega1) + omegafin=MIN(omega,omega2) + frac(i)=(omegafin-omegadeb)/(omega2-omega1) + pmu0(i)=SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) + ENDIF +c + ELSE !---omega1 GT omega2 -- a cheval sur deux journees +c +c-------------------entre omega1 et pi + IF (omega1.GE.omega) THEN !--nuit + zfrac1=0.0 + z1_mu =0.0 + ELSE !--jour+nuit + omegadeb=MAX(-omega,omega1) + omegafin=omega + zfrac1=omegafin-omegadeb + z1_mu =SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) + ENDIF +c---------------------entre -pi et omega2 + IF (omega2.LE.-omega) THEN !--nuit + zfrac2=0.0 + z2_mu =0.0 + ELSE !--jour+nuit + omegadeb=-omega + omegafin=MIN(omega,omega2) + zfrac2=omegafin-omegadeb + z2_mu =SIN(latr)*SIN(lat_sun) + + . COS(latr)*COS(lat_sun)* + . (SIN(omegafin)-SIN(omegadeb))/ + . (omegafin-omegadeb) +c + ENDIF +c-----------------------moyenne + frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1) + pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10) +c + ENDIF !---comparaison omega1 et omega2 +c + ENDDO +c + END +c=================================================================== + SUBROUTINE zenith (longi, gmtime, lat, long, + s pmu0, fract) + USE dimphy + IMPLICIT none +c +c Auteur(s): Z.X. Li (LMD/ENS) +c +c Objet: calculer le cosinus de l'angle zenithal du soleil en +c connaissant la declinaison du soleil, la latitude et la +c longitude du point sur la terre, et le temps universel +c +c Arguments d'entree: +c longi : declinaison du soleil (en degres) +c gmtime : temps universel en second qui varie entre 0 et 86400 +c lat : latitude en degres +c long : longitude en degres +c Arguments de sortie: +c pmu0 : cosinus de l'angle zenithal +c +c==================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c==================================================================== + REAL longi, gmtime + REAL lat(klon), long(klon), pmu0(klon), fract(klon) +c===================================================================== + INTEGER n + REAL zpi, zpir, omega, zgmtime + REAL incl, lat_sun, lon_sun +c---------------------------------------------------------------------- + zpi = 4.0*ATAN(1.0) + zpir = zpi / 180.0 + zgmtime=gmtime*86400. +c + incl=R_incl * zpir +c + lon_sun = longi * zpir + lat_sun = ASIN (SIN(lon_sun)*SIN(incl) ) +c +c--initialisation a la nuit +c + DO n =1, klon + pmu0(n)=0. + fract(n)=0.0 + ENDDO +c +c 1 degre en longitude = 240 secondes en temps +c + DO n = 1, klon + omega = zgmtime + long(n)*86400.0/360.0 + omega = omega / 86400.0 * 2.0 * zpi + omega = MOD(omega + 2.0 * zpi, 2.0 * zpi) + omega = omega - zpi + pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun) + . + cos(lat(n)*zpir) * cos(lat_sun) + . * cos(omega) + pmu0(n) = MAX (pmu0(n), 0.0) + IF (pmu0(n).GT.1.E-6) fract(n)=1.0 + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orografi.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orografi.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orografi.F (revision 1634) @@ -0,0 +1,1844 @@ +! +! $Id$ +! + SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay, + e pmea,pstd, psig, pgam, pthe,ppic,pval, + e kgwd,kdx,ktest, + e t, u, v, + s pulow, pvlow, pustr, pvstr, + s d_t, d_u, d_v) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Objet: Frottement de la montagne Interface +c====================================================================== +c Arguments: +c dtime---input-R- pas d'integration (s) +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c t-------input-R-temperature (K) +c u-------input-R-vitesse horizontale (m/s) +c v-------input-R-vitesse horizontale (m/s) +c +c d_t-----output-R-increment de la temperature +c d_u-----output-R-increment de la vitesse u +c d_v-----output-R-increment de la vitesse v +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon) + REAL ppic(nlon),pval(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) +c +c Variables locales: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c initialiser les variables de sortie (pour securite) +c + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + CALL orodrag(klon,klev,kgwd,kdx,ktest, + . dtime, + . papmh, papmf, zgeom, + . pt, pu, pv, + . pmea, pstd, psig, pgam, pthe, ppic,pval, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) +cIM BUG . +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + pvstr(i) = pvstr(i) +cIM BUG . +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE orodrag( nlon,nlev + i , kgwd, kdx, ktest + r , ptsphy + r , paphm1,papm1,pgeom1,ptm1,pum1,pvm1 + r , pmea, pstd, psig, pgamma, ptheta, ppic, pval +c outputs + r , pulow,pvlow + r , pvom,pvol,pte ) + + USE dimphy + implicit none + +c +c +c**** *gwdrag* - does the gravity wave parametrization. +c +c purpose. +c -------- +c +c this routine computes the physical tendencies of the +c prognostic variables u,v and t due to vertical transports by +c subgridscale orographically excited gravity waves +c +c** interface. +c ---------- +c called from *callpar*. +c +c the routine takes its input from the long-term storage: +c u,v,t and p at t-1. +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c implicit logical (l) +c +c method. +c ------- +c +c externals. +c ---------- + integer ismin, ismax + external ismin, ismax +c +c reference. +c ---------- +c +c author. +c ------- +c m.miller + b.ritter e.c.m.w.f. 15/06/86. +c +c f.lott + m. miller e.c.m.w.f. 22/11/94 +c----------------------------------------------------------------------- +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c +c +cym integer nlon, nlev, klevm1 + integer nlon, nlev + integer kgwd, jl, ilevp1, jk, ji + real zdelp, ztemp, zforc, ztend + real rover, zb, zc, zconb, zabsv + real zzd1, ratio, zbet, zust,zvst, zdis + real pte(nlon,nlev), + * pvol(nlon,nlev), + * pvom(nlon,nlev), + * pulow(klon), + * pvlow(klon) + real pum1(nlon,nlev), + * pvm1(nlon,nlev), + * ptm1(nlon,nlev), + * pmea(nlon),pstd(nlon),psig(nlon), + * pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon), + * pgeom1(nlon,nlev), + * papm1(nlon,nlev), + * paphm1(nlon,nlev+1) +c + integer kdx(nlon),ktest(nlon) +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ + integer isect(klon), + * icrit(klon), + * ikcrith(klon), + * ikenvh(klon), + * iknu(klon), + * iknu2(klon), + * ikcrit(klon), + * ikhlim(klon) +c + real ztau(klon,klev+1), + $ ztauf(klon,klev+1), + * zstab(klon,klev+1), + * zvph(klon,klev+1), + * zrho(klon,klev+1), + * zri(klon,klev+1), + * zpsi(klon,klev+1), + * zzdep(klon,klev) + real zdudt(klon), + * zdvdt(klon), + * zdtdt(klon), + * zdedt(klon), + * zvidis(klon), + * znu(klon), + * zd1(klon), + * zd2(klon), + * zdmod(klon) + real ztmst, ptsphy, zrtmst +c +c------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c +c ztmst=twodt +c if(nstep.eq.nstart) ztmst=0.5*twodt +cym klevm1=klev-1 + ztmst=ptsphy + zrtmst=1./ztmst +c ------------------------------------------------------------------ +c + 120 continue +c +c ------------------------------------------------------------------ +c +c* 1.3 check whether row contains point for printing +c --------------------------------------------- +c + 130 continue +c +c ------------------------------------------------------------------ +c +c* 2. precompute basic state variables. +c* ---------- ----- ----- ---------- +c* define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c + 200 continue +c +c +c + call orosetup + * ( nlon, ktest + * , ikcrit, ikcrith, icrit, ikenvh,iknu,iknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , zrho , zri , zstab , ztau , zvph , zpsi, zzdep + * , pulow, pvlow + * , ptheta,pgamma,pmea,ppic,pval,znu ,zd1, zd2, zdmod ) +c +c +c +c*********************************************************** +c +c +c* 3. compute low level stresses using subcritical and +c* supercritical forms.computes anisotropy coefficient +c* as measure of orographic twodimensionality. +c + 300 continue +c + call gwstress + * ( nlon , nlev + * , ktest , icrit, ikenvh, iknu + * , zrho , zstab, zvph , pstd, psig, pmea, ppic + * , ztau + * , pgeom1,zdmod) +c +c +c* 4. compute stress profile. +c* ------- ------ -------- +c + 400 continue +c +c + call gwprofil + * ( nlon , nlev + * , kgwd , kdx , ktest + * , ikcrith, icrit + * , paphm1, zrho , zstab , zvph + * , zri , ztau + * , zdmod , psig , pstd) +c +c +c* 5. compute tendencies. +c* ------------------- +c + 500 continue +c +c explicit solution at all levels for the gravity wave +c implicit solution for the blocked levels + + do 510 jl=kidia,kfdia + zvidis(jl)=0.0 + zdudt(jl)=0.0 + zdvdt(jl)=0.0 + zdtdt(jl)=0.0 + 510 continue +c + ilevp1=klev+1 +c +c + do 524 jk=1,klev +c +c +c do 523 jl=1,kgwd +c ji=kdx(jl) +c Modif vectorisation 02/04/2004 + do 523 ji=kidia,kfdia + if(ktest(ji).eq.1) then + + zdelp=paphm1(ji,jk+1)-paphm1(ji,jk) + ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp) + zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji) + zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji) +c +c controle des overshoots: +c + zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12 + ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12 + rover=0.25 + if(zforc.ge.rover*ztend)then + zdudt(ji)=rover*ztend/zforc*zdudt(ji) + zdvdt(ji)=rover*ztend/zforc*zdvdt(ji) + endif +c +c fin du controle des overshoots +c + if(jk.ge.ikenvh(ji)) then + zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2 + zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2 + zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji)) + zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. + zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2 + ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/ + * (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) + zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv +c +c simplement oppose au vent +c + zdudt(ji)=-pum1(ji,jk)/ztmst + zdvdt(ji)=-pvm1(ji,jk)/ztmst +c +c projection dans la direction de l'axe principal de l'orographie +cmod zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) +cmod * *cos(ptheta(ji)*rpi/180.)/ztmst +cmod zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.)) +cmod * *sin(ptheta(ji)*rpi/180.)/ztmst + zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet)) + zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet)) + end if + pvom(ji,jk)=zdudt(ji) + pvol(ji,jk)=zdvdt(ji) + zust=pum1(ji,jk)+ztmst*zdudt(ji) + zvst=pvm1(ji,jk)+ztmst*zdvdt(ji) + zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) + zdedt(ji)=zdis/ztmst + zvidis(ji)=zvidis(ji)+zdis*zdelp + zdtdt(ji)=zdedt(ji)/rcpd +c pte(ji,jk)=zdtdt(ji) +c +c ENCORE UN TRUC POUR EVITER LES EXPLOSIONS +c + pte(ji,jk)=0.0 + + endif + 523 continue + + 524 continue +c +c + return + end + SUBROUTINE orosetup + * ( nlon , ktest + * , kkcrit, kkcrith, kcrit + * , kkenvh, kknu , kknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , prho , pri , pstab , ptau , pvph ,ppsi, pzdep + * , pulow , pvlow + * , ptheta, pgamma, pmea, ppic, pval + * , pnu , pd1 , pd2 ,pdmod ) +c +c**** *gwsetup* +c +c purpose. +c -------- +c +c** interface. +c ---------- +c from *orodrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c see ecmwf research department documentation of the "i.f.s." +c +c author. +c ------- +c +c modifications. +c -------------- +c f.lott for the new-gwdrag scheme november 1993 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none +c + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon + integer jl, jk + real zdelp + + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon), + * ktest(nlon),kkenvh(nlon) + +c + real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev), + * pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev), + * prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1), + * ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1), + * pzdep(nlon,klev) + real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon), + * pd1(nlon),pd2(nlon),pdmod(nlon) + real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c +c + integer ilevm1, ilevm2, ilevh + real zcons1, zcons2,zcons3, zhgeo + real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind + real zstabm, zstabp, zrhom, zrhop, alpha + real zggeenv, zggeom1,zgvar + logical lo + logical ll1(klon,klev+1) + integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon), + * kentp(klon),ncount(klon) +c + real zhcrit(klon,klev),zvpf(klon,klev), + * zdp(klon,klev) + real znorm(klon),zb(klon),zc(klon), + * zulow(klon),zvlow(klon),znup(klon),znum(klon) +c +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c print *,' entree gwsetup' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c + ilevm1=klev-1 + ilevm2=klev-2 + ilevh =klev/3 +c + zcons1=1./rd +cold zcons2=g**2/cpd + zcons2=rg**2/rcpd +cold zcons3=1.5*api + zcons3=1.5*rpi +c +c +c ------------------------------------------------------------------ +c +c* 2. +c -------------- +c + 200 continue +c +c ------------------------------------------------------------------ +c +c* 2.1 define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c +c +c + do 2001 jl=kidia,kfdia + kknu(jl) =klev + kknu2(jl) =klev + kknub(jl) =klev + kknul(jl) =klev + pgamma(jl) =max(pgamma(jl),gtsec) + ll1(jl,klev+1)=.false. + 2001 continue +c +c Ajouter une initialisation (L. Li, le 23fev99): +c + do jk=klev,ilevh,-1 + do jl=kidia,kfdia + ll1(jl,jk)= .FALSE. + ENDDO + ENDDO +c +c* define top of low level flow +c ---------------------------- + do 2002 jk=klev,ilevh,-1 + do 2003 jl=kidia,kfdia + lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr + if(lo) then + kkcrit(jl)=jk + endif + zhcrit(jl,jk)=ppic(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu(jl)=ilevh + 2003 continue + 2002 continue + do 2004 jk=klev,ilevh,-1 + do 2005 jl=kidia,kfdia + zhcrit(jl,jk)=ppic(jl)-pval(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu2(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh + 2005 continue + 2004 continue + do 2006 jk=klev,ilevh,-1 + do 2007 jl=kidia,kfdia + zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl)) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknub(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknub(jl)=ilevh + 2007 continue + 2006 continue +c + do 2010 jl=kidia,kfdia + kknu(jl)=min(kknu(jl),nktopg) + kknu2(jl)=min(kknu2(jl),nktopg) + kknub(jl)=min(kknub(jl),nktopg) + kknul(jl)=klev + 2010 continue +c + + 210 continue +c +c +cc* initialize various arrays +c + do 2107 jl=kidia,kfdia + prho(jl,klev+1) =0.0 + pstab(jl,klev+1) =0.0 + pstab(jl,1) =0.0 + pri(jl,klev+1) =9999.0 + ppsi(jl,klev+1) =0.0 + pri(jl,1) =0.0 + pvph(jl,1) =0.0 + pulow(jl) =0.0 + pvlow(jl) =0.0 + zulow(jl) =0.0 + zvlow(jl) =0.0 + kkcrith(jl) =klev + kkenvh(jl) =klev + kentp(jl) =klev + kcrit(jl) =1 + ncount(jl) =0 + ll1(jl,klev+1) =.false. + 2107 continue +c +c* define low-level flow +c --------------------- +c + do 223 jk=klev,2,-1 + do 222 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* + * (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl,jk)=max(pstab(jl,jk),gssec) + endif + 222 continue + 223 continue +c +c******************************************************************** +c +c* define blocked flow +c ------------------- + do 2115 jk=klev,ilevh,-1 + do 2116 jl=kidia,kfdia + if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then + pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + end if + 2116 continue + 2115 continue + do 2110 jl=kidia,kfdia + pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) + pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl))) + znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + pvph(jl,klev+1)=znorm(jl) + 2110 continue +c +c******* setup orography axes and define plane of profiles ******* +c + do 2112 jl=kidia,kfdia + lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec) + if(lo) then + zu=pulow(jl)+2.*gvsec + else + zu=pulow(jl) + endif + zphi=atan(pvlow(jl)/zu) + ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi + zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2 + zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2 + pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) + pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1)) + pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2) + 2112 continue +c +c ************ define flow in plane of lowlevel stress ************* +c + do 213 jk=1,klev + do 212 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zvt1 =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk) + zvt2 =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk) + zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) + endif + ptau(jl,jk) =0.0 + pzdep(jl,jk) =0.0 + ppsi(jl,jk) =0.0 + ll1(jl,jk) =.false. + 212 continue + 213 continue + do 215 jk=2,klev + do 214 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+ + * (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1)) + * /zdp(jl,jk) + if(pvph(jl,jk).lt.gvsec) then + pvph(jl,jk)=gvsec + kcrit(jl)=jk + endif + endif + 214 continue + 215 continue +c +c +c* 2.2 brunt-vaisala frequency and density at half levels. +c + 220 continue +c + do 2211 jk=ilevh,klev + do 221 jl=kidia,kfdia + if(ktest(jl).eq.1) then + if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then + zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)* + * (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk) + pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec) + prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk) + * *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + endif + endif + 221 continue + 2211 continue +c + do 2212 jl=kidia,kfdia + pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl)) + * -papm1(jl,kknub(jl))) + prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl)) + * -papm1(jl,kknub(jl))) + zvar=pstd(jl) + 2212 continue +c +c* 2.3 mean flow richardson number. +c* and critical height for froude layer +c + 230 continue +c + do 232 jk=2,klev + do 231 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec) + pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk) + * /(rg*prho(jl,jk)*zdwind))**2 + pri(jl,jk)=max(pri(jl,jk),grcrit) + endif + 231 continue + 232 continue + +c +c +c* define top of 'envelope' layer +c ---------------------------- + + do 233 jl=kidia,kfdia + pnu (jl)=0.0 + znum(jl)=0.0 + 233 continue + + do 234 jk=2,klev-1 + do 234 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + if (jk.ge.kknub(jl)) then + + znum(jl)=pnu(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + pnu(jl) = pnu(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit) + * .and.(kkenvh(jl).eq.klev)) + * kkenvh(jl)=jk + + endif + + endif + + 234 continue + +c calculation of a dynamical mixing height for the breaking +c of gravity waves: + + + do 235 jl=kidia,kfdia + znup(jl)=0.0 + znum(jl)=0.0 + 235 continue + + do 236 jk=klev-1,2,-1 + do 236 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + znum(jl)=znup(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + znup(jl) = znup(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.) + * .and.(kkcrith(jl).eq.klev)) + * kkcrith(jl)=jk + + endif + + 236 continue + + do 237 jl=kidia,kfdia + kkcrith(jl)=min0(kkcrith(jl),kknu2(jl)) + kkcrith(jl)=max0(kkcrith(jl),ilevh*2) + 237 continue +c +c directional info for flow blocking ************************* +c + do 251 jk=ilevh,klev + do 252 jl=kidia,kfdia + if(jk.ge.kkenvh(jl)) then + lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec) + if(lo) then + zu=pum1(jl,jk)+2.*gvsec + else + zu=pum1(jl,jk) + endif + zphi=atan(pvm1(jl,jk)/zu) + ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi + end if + 252 continue + 251 continue +c forms the vertical 'leakiness' ************************** + + alpha=3. + + do 254 jk=ilevh,klev + do 253 jl=kidia,kfdia + if(jk.ge.kkenvh(jl)) then + zggeenv=amax1(1., + * (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.) + zggeom1=amax1(pgeom1(jl,jk),1.) + zgvar=amax1(pstd(jl)*rg,1.) +cmod pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar)) + pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl, jk))/ + * (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev)) + end if + 253 continue + 254 continue + + 260 continue + + return + end + SUBROUTINE gwstress + * ( nlon , nlev + * , ktest, kcrit, kkenvh + * , kknu + * , prho , pstab , pvph , pstd, psig + * , pmea , ppic , ptau + * , pgeom1 , pdmod ) +c +c**** *gwstress* +c +c purpose. +c -------- +c +c** interface. +c ---------- +c call *gwstress* from *gwdrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c see ecmwf research department documentation of the "i.f.s." +c +c author. +c ------- +c +c modifications. +c -------------- +c f. lott put the new gwd on ifs 22/11/93 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon, nlev + integer kcrit(nlon), + * ktest(nlon),kkenvh(nlon),kknu(nlon) +c + real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1), + * pvph(nlon,nlev+1), + * pgeom1(nlon,nlev),pstd(nlon) +c + real psig(nlon) + real pmea(nlon),ppic(nlon) + real pdmod(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ + integer jl + real zblock, zvar, zeff + logical lo +c +c----------------------------------------------------------------------- +c +c* 0.3 functions +c --------- +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c + 100 continue +c +c* 3.1 gravity wave stress. +c + 300 continue +c +c + do 301 jl=kidia,kfdia + if(ktest(jl).eq.1) then + +c effective mountain height above the blocked flow + + if(kkenvh(jl).eq.klev)then + zblock=0.0 + else + zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg + endif + + zvar=ppic(jl)-pmea(jl) + zeff=amax1(0.,zvar-zblock) + + ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2 + * /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1)) + +c too small value of stress or low level flow include critical level +c or low level flow: gravity wave stress nul. + + lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl)) + * .or.(pvph(jl,klev+1).lt.gvcrit) +c if(lo) ptau(jl,klev+1)=0.0 + + else + + ptau(jl,klev+1)=0.0 + + endif + + 301 continue +c + return + end + SUBROUTINE GWPROFIL + * ( NLON, NLEV + * , kgwd, kdx , ktest + * , KKCRITH, KCRIT + * , PAPHM1, PRHO , PSTAB , PVPH , PRI , PTAU + * , pdmod , psig , pvar) + +C**** *GWPROFIL* +C +C PURPOSE. +C -------- +C +C** INTERFACE. +C ---------- +C FROM *GWDRAG* +C +C EXPLICIT ARGUMENTS : +C -------------------- +C ==== INPUTS === +C ==== OUTPUTS === +C +C IMPLICIT ARGUMENTS : NONE +C -------------------- +C +C METHOD: +C ------- +C THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS: +C IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND +C AND THE TOP OF THE BLOCKED LAYER (KKENVH). +C IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE +C BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR +C NONLINEAR GRAVITY WAVE BREAKING. +C ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL +C LEVEL (KCRIT) OR WHEN IT BREAKS. +C +C +C +C EXTERNALS. +C ---------- +C +C +C REFERENCE. +C ---------- +C +C SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S." +C +C AUTHOR. +C ------- +C +C MODIFICATIONS. +C -------------- +C PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93) +C----------------------------------------------------------------------- + USE dimphy + implicit none +C + +C + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + integer nlon,nlev + INTEGER KKCRITH(NLON),KCRIT(NLON) + * ,kdx(nlon) , ktest(nlon) + +C + REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1), + * PRHO (NLON,NLEV+1), PVPH (NLON,NLEV+1), + * PRI (NLON,NLEV+1), PTAU(NLON,NLEV+1) + + REAL pdmod (NLON) , psig(NLON), + * pvar(NLON) + +C----------------------------------------------------------------------- +C +C* 0.2 LOCAL ARRAYS +C ------------ +C + integer ilevh, ji, kgwd, jl, jk + real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n + real zdelp, zdelpt + REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON) + REAL ZTAU (KLON,KLEV+1) +C +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C +c print *,' entree gwprofil' + 100 CONTINUE +C +C +C* COMPUTATIONAL CONSTANTS. +C ------------- ---------- +C + ilevh=KLEV/3 +C +c DO 400 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + DO 400 jl=kidia,kfdia + if (ktest(jl).eq.1) then + Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0) + ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1) + endif + 400 CONTINUE + +C + DO 430 JK=KLEV,2,-1 +C +C +C* 4.1 CONSTANT WAVE STRESS UNTIL TOP OF THE +C BLOCKING LAYER. + 410 CONTINUE +C +c DO 411 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 411 jl=kidia,kfdia + if (ktest(jl).eq.1) then + IF(JK.GT.KKCRITH(JL)) THEN + PTAU(JL,JK)=ZTAU(JL,KLEV+1) +C ENDIF +C IF(JK.EQ.KKCRITH(JL)) THEN + ELSE + PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1) + ENDIF + endif + 411 CONTINUE +C +C* 4.15 CONSTANT SHEAR STRESS UNTIL THE TOP OF THE +C LOW LEVEL FLOW LAYER. + 415 CONTINUE +C +C +C* 4.2 WAVE DISPLACEMENT AT NEXT LEVEL. +C + 420 CONTINUE +C +c DO 421 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 421 jl=kidia,kfdia + if(ktest(jl).eq.1) then + IF(JK.LT.KKCRITH(JL)) THEN + ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK) + * *zoro(jl) + ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec) + ENDIF + endif + 421 CONTINUE +C +C* 4.3 WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT +C* AND STRESS: BREAKING EVALUATION AND CRITICAL +C LEVEL +C + +c DO 431 ji=1,kgwd +c jl=Kdx(ji) +c Modif vectorisation 02/04/2004 + do 431 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + IF(JK.LT.KKCRITH(JL)) THEN + IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN + PTAU(JL,JK)=0.0 + ELSE + ZSQR=SQRT(PRI(JL,JK)) + ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK) + ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2 + IF(ZRIW.LT.GRCRIT) THEN + ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT + ZB=1./GRCRIT+2./ZSQR + ZALPHA=0.5*(-ZB+SQRT(ZDEL)) + ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK) + PTAU(JL,JK)=ZNORM(JL)*ZDZ2N + ELSE + PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK) + ENDIF + PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1)) + ENDIF + ENDIF + endif + 431 CONTINUE + + 430 CONTINUE + 440 CONTINUE + +C REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL + +c DO 530 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 530 jl=kidia,kfdia + if(ktest(jl).eq.1) then + ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL)) + ZTAU(JL,NSTRA)=PTAU(JL,NSTRA) + endif + 530 CONTINUE + + DO 531 JK=1,KLEV + +c DO 532 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 532 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + + IF(JK.GT.KKCRITH(JL))THEN + + ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1 ) + ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1 ) + PTAU(JL,JK)=ZTAU(JL,KLEV+1 ) + + . (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1 ) )* + . ZDELP/ZDELPT + + ENDIF + + endif + 532 CONTINUE + +C REORGANISATION IN THE STRATOSPHERE + +c DO 533 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 533 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + + IF(JK.LT.NSTRA)THEN + + ZDELP =PAPHM1(JL,NSTRA) + ZDELPT=PAPHM1(JL,JK) + PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP + + ENDIF + + endif + 533 CONTINUE + +C REORGANISATION IN THE TROPOSPHERE + +c DO 534 ji=1,kgwd +c jl=kdx(ji) +c Modif vectorisation 02/04/2004 + do 534 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + + IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN + + ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL)) + ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL)) + PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) + + * (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP + . /ZDELPT + + ENDIF + endif + 534 CONTINUE + + + 531 CONTINUE + + + RETURN + END + SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay, + e plat,pmea,pstd, ppic, + e ktest, + e t, u, v, + s pulow, pvlow, pustr, pvstr, + s d_t, d_u, d_v) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Objet: Frottement de la montagne Interface +c====================================================================== +c Arguments: +c dtime---input-R- pas d'integration (s) +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c t-------input-R-temperature (K) +c u-------input-R-vitesse horizontale (m/s) +c v-------input-R-vitesse horizontale (m/s) +c +c d_t-----output-R-increment de la temperature +c d_u-----output-R-increment de la vitesse u +c d_v-----output-R-increment de la vitesse v +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL plat(nlon),pmea(nlon) + REAL pstd(nlon) + REAL ppic(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, ktest(nlon) +c +c Variables locales: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c initialiser les variables de sortie (pour securite) +c + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + CALL OROLIFT(klon,klev,ktest, + . dtime, + . papmh, zgeom, + . pt, pu, pv, + . plat,pmea, pstd, ppic, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) +cIM BUG . +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + pvstr(i) = pvstr(i) +cIM BUG . +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k)) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG + ENDDO + ENDDO +c + RETURN + END + SUBROUTINE OROLIFT( NLON,NLEV + I , KTEST + R , PTSPHY + R , PAPHM1,PGEOM1,PTM1,PUM1,PVM1 + R , PLAT + R , PMEA, PVAROR, ppic +C OUTPUTS + R , PULOW,PVLOW + R , PVOM,PVOL,PTE ) + +C +C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT. +C +C PURPOSE. +C -------- +C +C** INTERFACE. +C ---------- +C CALLED FROM *lift_noro +C ---------- +C +C AUTHOR. +C ------- +C F.LOTT LMD 22/11/95 +C + USE dimphy + implicit none +C +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C +C + integer nlon, nlev + REAL PTE(NLON,NLEV), + * PVOL(NLON,NLEV), + * PVOM(NLON,NLEV), + * PULOW(NLON), + * PVLOW(NLON) + REAL PUM1(NLON,NLEV), + * PVM1(NLON,NLEV), + * PTM1(NLON,NLEV), + * PLAT(NLON),PMEA(NLON), + * PVAROR(NLON), + * ppic(NLON), + * PGEOM1(NLON,NLEV), + * PAPHM1(NLON,NLEV+1) +C + INTEGER KTEST(NLON) + real ptsphy +C----------------------------------------------------------------------- +C +C* 0.2 LOCAL ARRAYS +C ------------ + logical lifthigh +cym integer klevm1, jl, ilevh, jk + integer jl, ilevh, jk + real zcons1, ztmst, zrtmst,zpi, zhgeo + real zdelp, zslow, zsqua, zscav, zbet + INTEGER + * IKNUB(klon), + * IKNUL(klon) + LOGICAL LL1(KLON,KLEV+1) +C + REAL ZTAU(KLON,KLEV+1), + * ZTAV(KLON,KLEV+1), + * ZRHO(KLON,KLEV+1) + REAL ZDUDT(KLON), + * ZDVDT(KLON) + REAL ZHCRIT(KLON,KLEV) + CHARACTER (LEN=20) :: modname='orografi' + CHARACTER (LEN=80) :: abort_message +C----------------------------------------------------------------------- +C +C* 1.1 INITIALIZATIONS +C --------------- + + LIFTHIGH=.FALSE. + + IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)THEN + abort_message = 'pb dimension' + CALL abort_gcm (modname,abort_message,1) + ENDIF + ZCONS1=1./RD +cym KLEVM1=KLEV-1 + ZTMST=PTSPHY + ZRTMST=1./ZTMST + ZPI=ACOS(-1.) +C + DO 1001 JL=kidia,kfdia + ZRHO(JL,KLEV+1) =0.0 + PULOW(JL) =0.0 + PVLOW(JL) =0.0 + iknub(JL) =klev + iknul(JL) =klev + ilevh=klev/3 + ll1(jl,klev+1)=.false. + DO 1000 JK=1,KLEV + PVOM(JL,JK)=0.0 + PVOL(JL,JK)=0.0 + PTE (JL,JK)=0.0 + 1000 CONTINUE + 1001 CONTINUE + +C +C* 2.1 DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF +C* LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE +C* THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS. +C +C +C + DO 2006 JK=KLEV,1,-1 + DO 2007 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.) + ZHGEO=PGEOM1(JL,JK)/RG + ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK)) + IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN + iknub(JL)=JK + ENDIF + ENDIF + 2007 CONTINUE + 2006 CONTINUE +C + do 2010 jl=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + iknub(jl)=max(iknub(jl),klev/2) + iknul(jl)=max(iknul(jl),2*klev/3) + if(iknub(jl).gt.nktopg) iknub(jl)=nktopg + if(iknub(jl).eq.nktopg) iknul(jl)=klev + if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1 + ENDIF + 2010 continue + +C do 2011 jl=kidia,kfdia +C IF(KTEST(JL).EQ.1) THEN +C print *,' iknul= ',iknul(jl),' iknub=',iknub(jl) +C ENDIF +C2011 continue + +C PRINT *,' DANS OROLIFT: 2010' + + DO 223 JK=KLEV,2,-1 + DO 222 JL=kidia,kfdia + ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1)) + 222 CONTINUE + 223 CONTINUE +C PRINT *,' DANS OROLIFT: 223' + +C******************************************************************** +C +C* DEFINE LOW LEVEL FLOW +C ------------------- + DO 2115 JK=klev,1,-1 + DO 2116 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then + pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + zrho(JL,klev+1)=zrho(JL,klev+1) + * +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + end if + ENDIF + 2116 CONTINUE + 2115 CONTINUE + DO 2110 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl))) + pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl))) + zrho(JL,klev+1)=zrho(JL,klev+1) + * /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl))) + ENDIF + 2110 CONTINUE + + +200 CONTINUE + +C*********************************************************** +C +C* 3. COMPUTE MOUNTAIN LIFT +C + 300 CONTINUE +C + DO 301 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA* +C * (2*PVAROR(JL)+PMEA(JL))* + * 2*PVAROR(JL)* + * SIN(ZPI/180.*PLAT(JL))*PVLOW(JL) + ZTAV(JL,KLEV+1)= GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA* +C * (2*PVAROR(JL)+PMEA(JL))* + * 2*PVAROR(JL)* + * SIN(ZPI/180.*PLAT(JL))*PULOW(JL) + ELSE + ZTAU(JL,KLEV+1)=0.0 + ZTAV(JL,KLEV+1)=0.0 + ENDIF +301 CONTINUE + +C +C* 4. COMPUTE LIFT PROFILE +C* -------------------- +C + + 400 CONTINUE + + DO 401 JK=1,KLEV + DO 401 JL=kidia,kfdia + IF(KTEST(JL).EQ.1) THEN + ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1) + ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1) + ELSE + ZTAU(JL,JK)=0.0 + ZTAV(JL,JK)=0.0 + ENDIF +401 CONTINUE +C +C +C* 5. COMPUTE TENDENCIES. +C* ------------------- + IF(LIFTHIGH)THEN +C + 500 CONTINUE +C PRINT *,' DANS OROLIFT: 500' +C +C EXPLICIT SOLUTION AT ALL LEVELS +C + DO 524 JK=1,klev + DO 523 JL=KIDIA,KFDIA + IF(KTEST(JL).EQ.1) THEN + ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK) + ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP + ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP + ENDIF + 523 CONTINUE + 524 CONTINUE +C +C PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY +C + DO 530 JK=1,klev + DO 530 JL=KIDIA,KFDIA + IF(KTEST(JL).EQ.1) THEN + + ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2) + ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC) + ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK) + IF(ZSQUA.GT.GVSEC)THEN + PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2 + PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2 + ELSE + PVOM(JL,JK)=0.0 + PVOL(JL,JK)=0.0 + ENDIF + ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2) + IF(ZSQUA.LT.ZSLOW)THEN + PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK) + PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK) + ENDIF + + ENDIF +530 CONTINUE +C +C 6. LOW LEVEL LIFT, SEMI IMPLICIT: +C ---------------------------------- + + ELSE + + DO 601 JL=KIDIA,KFDIA + IF(KTEST(JL).EQ.1) THEN + DO JK=KLEV,IKNUB(JL),-1 + ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst* + * (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL, JK))/ + * (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV)) + ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2) + ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2) + PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET *ZDVDT(JL) + PVOL(JL,JK)= ZBET *ZDUDT(JL) + ZBET**2*ZDVDT(JL) + ENDDO + ENDIF + 601 CONTINUE + + ENDIF + + RETURN + END + + + SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay) + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz +c USE parallel +C +C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG +C +C PURPOSE. +C -------- +C INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE +C GRAVITY WAVE DRAG PARAMETRIZATION. +C +C** INTERFACE. +C ---------- +C CALL *SUGWD* FROM *SUPHEC* +C ----- ------ +C +C EXPLICIT ARGUMENTS : +C -------------------- +C PSIG : VERTICAL COORDINATE TABLE +C NLEV : NUMBER OF MODEL LEVELS +C +C IMPLICIT ARGUMENTS : +C -------------------- +C COMMON YOEGWD +C +C METHOD. +C ------- +C SEE DOCUMENTATION +C +C EXTERNALS. +C ---------- +C NONE +C +C REFERENCE. +C ---------- +C ECMWF Research Department documentation of the IFS +C +C AUTHOR. +C ------- +C MARTIN MILLER *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 90-01-01 +C ------------------------------------------------------------------ + implicit none +C +C ----------------------------------------------------------------- +#include "YOEGWD.h" +C ---------------------------------------------------------------- +C + integer nlon,nlev, jk + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) + real zpr,zstra,zsigt,zpm1r + REAL :: pplay_glo(klon_glo,nlev) + REAL :: paprs_glo(klon_glo,nlev+1) + +C +C* 1. SET THE VALUES OF THE PARAMETERS +C -------------------------------- +C + 100 CONTINUE +C + PRINT *,' DANS SUGWD NLEV=',NLEV + GHMAX=10000. +C + ZPR=100000. + ZSTRA=0.1 + ZSIGT=0.94 +cold ZPR=80000. +cold ZSIGT=0.85 +C + + CALL gather(pplay,pplay_glo) + CALL bcast(pplay_glo) + CALL gather(paprs,paprs_glo) + CALL bcast(paprs_glo) + + + DO 110 JK=1,NLEV + ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) + IF(ZPM1R.GE.ZSIGT)THEN + nktopg=JK + ENDIF + ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) + IF(ZPM1R.GE.ZSTRA)THEN + NSTRA=JK + ENDIF + 110 CONTINUE + + +c +c inversion car dans orodrag on compte les niveaux a l'envers + nktopg=nlev-nktopg+1 + nstra=nlev-nstra + print *,' DANS SUGWD nktopg=', nktopg + print *,' DANS SUGWD nstra=', nstra +C + GSIGCR=0.80 +C + GKDRAG=0.2 + GRAHILO=1. + GRCRIT=0.01 + GFRCRIT=1.0 + GKWAKE=0.50 +C + GKLIFT=0.50 + GVCRIT =0.0 +C +C +C ---------------------------------------------------------------- +C +C* 2. SET VALUES OF SECURITY PARAMETERS +C --------------------------------- +C + 200 CONTINUE +C + GVSEC=0.10 + GSSEC=1.E-12 +C + GTSEC=1.E-07 +C +C ---------------------------------------------------------------- +C + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orografi_strato.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orografi_strato.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/orografi_strato.F (revision 1634) @@ -0,0 +1,2060 @@ + SUBROUTINE drag_noro_strato (nlon,nlev,dtime,paprs,pplay, + e pmea,pstd, psig, pgam, pthe,ppic,pval, + e kgwd,kdx,ktest, + e t, u, v, + s pulow, pvlow, pustr, pvstr, + s d_t, d_u, d_v) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Object: Mountain drag interface. Made necessary because: +C 1. in the LMD-GCM Layers are from bottom to top, +C contrary to most European GCM. +c 2. the altitude above ground of each model layers +c needs to be known (variable zgeom) +c====================================================================== +c Explicit Arguments: +c ================== +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c dtime---input-R-Time-step (s) +c paprs---input-R-Pressure in semi layers (Pa) +c pplay---input-R-Pressure model-layers (Pa) +c t-------input-R-temperature (K) +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. + +c pulow, pvlow -output-R: Low-level wind +c pustr, pvstr -output-R: Surface stress due to SSO drag (Pa) +c +c d_t-----output-R: T increment +c d_u-----output-R: U increment +c d_v-----output-R: V increment +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c (iim+1)*(jjm+1) for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c +c zgeom-----R: Altitude of layer above ground +c pt, pu, pv --R: t u v from top to bottom +c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) +c papmf: pressure at model layer (from top to bottom) +c papmh: pressure at model 1/2 layer (from top to bottom) +c +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) + REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon) + REAL ppic(nlon),pval(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) +c +c LOCAL VARIABLES: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) + CHARACTER (LEN=20) :: modname='orografi_strato' + CHARACTER (LEN=80) :: abort_message +c +c INITIALIZE OUTPUT VARIABLES +c + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM) +C CALCULATE LAYERS HEIGHT ABOVE GROUND) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c CALL SSO DRAG ROUTINES +c + CALL orodrag_strato(klon,klev,kgwd,kdx,ktest, + . dtime, + . papmh, papmf, zgeom, + . pt, pu, pv, + . pmea, pstd, psig, pgam, pthe, ppic,pval, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C +C COMPUTE INCREMENTS AND STRESS FROM TENDENCIES + + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + pvstr(i) = pvstr(i) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + ENDDO + ENDDO +c + RETURN + END + + SUBROUTINE orodrag_strato( nlon,nlev + i , kgwd, kdx, ktest + r , ptsphy + r , paphm1,papm1,pgeom1,ptm1,pum1,pvm1 + r , pmea, pstd, psig, pgam, pthe, ppic, pval +c outputs + r , pulow,pvlow + r , pvom,pvol,pte ) + + USE dimphy + IMPLICIT NONE +c +c +c**** *orodrag* - does the SSO drag parametrization. +c +c purpose. +c -------- +c +c this routine computes the physical tendencies of the +c prognostic variables u,v and t due to vertical transports by +c subgridscale orographically excited gravity waves, and to +c low level blocked flow drag. +c +c** interface. +c ---------- +c called from *drag_noro*. +c +c the routine takes its input from the long-term storage: +c u,v,t and p at t-1. +c +c explicit arguments : +c -------------------- +c ==== inputs === +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) + + integer nlon,nlev,kgwd + real ptsphy + +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c +c pte -----output-R: T tendency +c pvom-----output-R: U tendency +c pvol-----output-R: V tendency +c +c +c Implicit Arguments: +c =================== +c +c klon-common-I: Number of points seen by the physics +c klev-common-I: Number of vertical layers +c +c method. +c ------- +c +c externals. +c ---------- + integer ismin, ismax + external ismin, ismax +c +c reference. +c ---------- +c +c author. +c ------- +c m.miller + b.ritter e.c.m.w.f. 15/06/86. +c +c f.lott + m. miller e.c.m.w.f. 22/11/94 +c----------------------------------------------------------------------- +c +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c +c + real pte(nlon,nlev), + * pvol(nlon,nlev), + * pvom(nlon,nlev), + * pulow(nlon), + * pvlow(nlon) + real pum1(nlon,nlev), + * pvm1(nlon,nlev), + * ptm1(nlon,nlev), + * pmea(nlon),pstd(nlon),psig(nlon), + * pgam(nlon),pthe(nlon),ppic(nlon),pval(nlon), + * pgeom1(nlon,nlev), + * papm1(nlon,nlev), + * paphm1(nlon,nlev+1) +c + integer kdx(nlon),ktest(nlon) +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ + integer isect(klon), + * icrit(klon), + * ikcrith(klon), + * ikenvh(klon), + * iknu(klon), + * iknu2(klon), + * ikcrit(klon), + * ikhlim(klon) +c + real ztau(klon,klev+1), + * zstab(klon,klev+1), + * zvph(klon,klev+1), + * zrho(klon,klev+1), + * zri(klon,klev+1), + * zpsi(klon,klev+1), + * zzdep(klon,klev) + real zdudt(klon), + * zdvdt(klon), + * zdtdt(klon), + * zdedt(klon), + * zvidis(klon), + * ztfr(klon), + * znu(klon), + * zd1(klon), + * zd2(klon), + * zdmod(klon) + + +c local quantities: + + integer jl,jk,ji + real ztmst,zdelp,ztemp,zforc,ztend,rover + real zb,zc,zconb,zabsv,zzd1,ratio,zbet,zust,zvst,zdis + +c +c------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c print *,' in orodrag' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c +c ztmst=twodt +c if(nstep.eq.nstart) ztmst=0.5*twodt + ztmst=ptsphy +c ------------------------------------------------------------------ +c + 120 continue +c +c ------------------------------------------------------------------ +c +c* 1.3 check whether row contains point for printing +c --------------------------------------------- +c + 130 continue +c +c ------------------------------------------------------------------ +c +c* 2. precompute basic state variables. +c* ---------- ----- ----- ---------- +c* define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c + + 200 continue +c +c +c + call orosetup_strato + * ( nlon, nlev , ktest + * , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , zrho , zri , zstab , ztau , zvph , zpsi, zzdep + * , pulow, pvlow + * , pthe,pgam,pmea,ppic,pval,znu ,zd1, zd2, zdmod ) + + +c +c +c +c*********************************************************** +c +c +c* 3. compute low level stresses using subcritical and +c* supercritical forms.computes anisotropy coefficient +c* as measure of orographic twodimensionality. +c + 300 continue +c + call gwstress_strato + * ( nlon , nlev + * , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu + * , zrho , zstab, zvph , pstd, psig, pmea, ppic, pval + * , ztfr , ztau + * , pgeom1,pgam,zd1,zd2,zdmod,znu) + +c +c +c* 4. compute stress profile including +c trapped waves, wave breaking, +c linear decay in stratosphere. +c + 400 continue +c +c + + call gwprofil_strato + * ( nlon , nlev + * , kgwd , kdx , ktest + * , ikcrit, ikcrith, icrit , ikenvh, iknu + * ,iknu2 , paphm1, zrho , zstab , ztfr , zvph + * , zri , ztau + + * , zdmod , znu , psig , pgam , pstd , ppic , pval) + +c +c* 5. Compute tendencies from waves stress profile. +c Compute low level blocked flow drag. +c* -------------------------------------------- +c + 500 continue + + +c +c explicit solution at all levels for the gravity wave +c implicit solution for the blocked levels + + do 510 jl=kidia,kfdia + zvidis(jl)=0.0 + zdudt(jl)=0.0 + zdvdt(jl)=0.0 + zdtdt(jl)=0.0 + 510 continue +c + + do 524 jk=1,klev +c + +C WAVE STRESS +C------------- +c +c + do 523 ji=kidia,kfdia + + if(ktest(ji).eq.1) then + + zdelp=paphm1(ji,jk+1)-paphm1(ji,jk) + ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp) + + zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji) + zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji) +c +c Control Overshoots +c + + if(jk.ge.nstra)then + rover=0.10 + if(abs(zdudt(ji)).gt.rover*abs(pum1(ji,jk))/ztmst) + C zdudt(ji)=rover*abs(pum1(ji,jk))/ztmst* + C zdudt(ji)/(abs(zdudt(ji))+1.E-10) + if(abs(zdvdt(ji)).gt.rover*abs(pvm1(ji,jk))/ztmst) + C zdvdt(ji)=rover*abs(pvm1(ji,jk))/ztmst* + C zdvdt(ji)/(abs(zdvdt(ji))+1.E-10) + endif + + rover=0.25 + zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2) + ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst + + if(zforc.ge.rover*ztend)then + zdudt(ji)=rover*ztend/zforc*zdudt(ji) + zdvdt(ji)=rover*ztend/zforc*zdvdt(ji) + endif +c +c BLOCKED FLOW DRAG: +C ----------------- +c + if(jk.gt.ikenvh(ji)) then + zb=1.0-0.18*pgam(ji)-0.04*pgam(ji)**2 + zc=0.48*pgam(ji)+0.3*pgam(ji)**2 + zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji)) + zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2. + zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2 + ratio=(cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji,jk))**2)/ + * (pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2) + zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv +c +c OPPOSED TO THE WIND +c + zdudt(ji)=-pum1(ji,jk)/ztmst + zdvdt(ji)=-pvm1(ji,jk)/ztmst +c +c PERPENDICULAR TO THE SSO MAIN AXIS: +C +cmod zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) +cmod * *cos(pthe(ji)*rpi/180.)/ztmst +cmod zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.) +cmod * +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.)) +cmod * *sin(pthe(ji)*rpi/180.)/ztmst +C + zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet)) + zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet)) + end if + pvom(ji,jk)=zdudt(ji) + pvol(ji,jk)=zdvdt(ji) + zust=pum1(ji,jk)+ztmst*zdudt(ji) + zvst=pvm1(ji,jk)+ztmst*zdvdt(ji) + zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2) + zdedt(ji)=zdis/ztmst + zvidis(ji)=zvidis(ji)+zdis*zdelp + zdtdt(ji)=zdedt(ji)/rcpd +c +c NO TENDENCIES ON TEMPERATURE ..... +c +c Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation +c + pte(ji,jk)=0.0 + + endif + + 523 continue + 524 continue +c +c + 501 continue + + return + end + SUBROUTINE orosetup_strato + * ( nlon , nlev , ktest + * , kkcrit, kkcrith, kcrit, ksect , kkhlim + * , kkenvh, kknu , kknu2 + * , paphm1, papm1 , pum1 , pvm1 , ptm1 , pgeom1, pstd + * , prho , pri , pstab , ptau , pvph ,ppsi, pzdep + * , pulow , pvlow + * , ptheta, pgam, pmea, ppic, pval + * , pnu , pd1 , pd2 ,pdmod ) +C +c**** *gwsetup* +c +c purpose. +c -------- +c SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME: +C DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND +C STRATIFICATION..... +c +c** interface. +c ---------- +c from *orodrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c ktest--input-I: Flags to indicate active points +c +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) + +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c kkcrit----I-: Security value for top of low level flow +c kcrit-----I-: Critical level +c ksect-----I-: Not used +c kkhlim----I-: Not used +c kkenvh----I-: Top of blocked flow layer +c kknu------I-: Layer that sees mountain peacks +c kknu2-----I-: Layer that sees mountain peacks above mountain mean +c kknub-----I-: Layer that sees mountain mean above valleys +c prho------R-: Density at 1/2 layers +c pri-------R-: Background Richardson Number, Wind shear measured along GW stress +c pstab-----R-: Brunt-Vaisala freq. at 1/2 layers +c pvph------R-: Wind in plan of GW stress, Half levels. +c ppsi------R-: Angle between low level wind and SS0 main axis. +c pd1-------R-| Compared the ratio of the stress +c pd2-------R-| that is along the wind to that Normal to it. +c pdi define the plane of low level stress +c compared to the low level wind. +c see p. 108 Lott & Miller (1997). +c pdmod-----R-: Norme of pdi + +c === local arrays === +c +c zvpf------R-: Wind projected in the plan of the low-level stress. + +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c see ecmwf research department documentation of the "i.f.s." +c +c author. +c ------- +c +c modifications. +c -------------- +c f.lott for the new-gwdrag scheme november 1993 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none +c + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon,nlev + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon), + * kkhlim(nlon),ktest(nlon),kkenvh(nlon) + +c + real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev), + * pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev), + * prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1), + * ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1), + * pzdep(nlon,klev) + real pulow(nlon),pvlow(nlon),ptheta(nlon),pgam(nlon),pnu(nlon), + * pd1(nlon),pd2(nlon),pdmod(nlon) + real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c +c + integer ilevh ,jl,jk + real zcons1,zcons2,zhgeo,zu,zphi + real zvt1,zvt2,zdwind,zwind,zdelp + real zstabm,zstabp,zrhom,zrhop + logical lo + logical ll1(klon,klev+1) + integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon), + * kentp(klon),ncount(klon) +c + real zhcrit(klon,klev),zvpf(klon,klev), + * zdp(klon,klev) + real znorm(klon),zb(klon),zc(klon), + * zulow(klon),zvlow(klon),znup(klon),znum(klon) +c +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c PRINT *,' in orosetup' + 100 continue +c +c ------------------------------------------------------------------ +c +c* 1.1 computational constants +c ----------------------- +c + 110 continue +c + ilevh =klev/3 +c + zcons1=1./rd + zcons2=rg**2/rcpd +c +c +c ------------------------------------------------------------------ +c +c* 2. +c -------------- +c + 200 continue +c +c ------------------------------------------------------------------ +c +c* 2.1 define low level wind, project winds in plane of +c* low level wind, determine sector in which to take +c* the variance and set indicator for critical levels. +c +c +c + do 2001 jl=kidia,kfdia + kknu(jl) =klev + kknu2(jl) =klev + kknub(jl) =klev + kknul(jl) =klev + pgam(jl) =max(pgam(jl),gtsec) + ll1(jl,klev+1)=.false. + 2001 continue +c +c Ajouter une initialisation (L. Li, le 23fev99): +c + do jk=klev,ilevh,-1 + do jl=kidia,kfdia + ll1(jl,jk)= .false. + ENDDO + ENDDO +c +c* define top of low level flow +c ---------------------------- + do 2002 jk=klev,ilevh,-1 + do 2003 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr + if(lo) then + kkcrit(jl)=jk + endif + zhcrit(jl,jk)=ppic(jl)-pval(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu(jl)=ilevh + endif + 2003 continue + 2002 continue + do 2004 jk=klev,ilevh,-1 + do 2005 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=ppic(jl)-pmea(jl) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknu2(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh + endif + 2005 continue + 2004 continue + do 2006 jk=klev,ilevh,-1 + do 2007 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=amin1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl)) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + kknub(jl)=jk + endif + if(.not.ll1(jl,ilevh))kknub(jl)=ilevh + endif + 2007 continue + 2006 continue +c + do 2010 jl=kidia,kfdia + if(ktest(jl).eq.1) then + kknu(jl)=min(kknu(jl),nktopg) + kknu2(jl)=min(kknu2(jl),nktopg) + kknub(jl)=min(kknub(jl),nktopg) + kknul(jl)=klev + endif + 2010 continue +c + 210 continue +c +cc* initialize various arrays +c + do 2107 jl=kidia,kfdia + prho(jl,klev+1) =0.0 +cym correction en attendant mieux + prho(jl,1) =0.0 + pstab(jl,klev+1) =0.0 + pstab(jl,1) =0.0 + pri(jl,klev+1) =9999.0 + ppsi(jl,klev+1) =0.0 + pri(jl,1) =0.0 + pvph(jl,1) =0.0 + pvph(jl,klev+1) =0.0 +cym correction en attendant mieux +cym pvph(jl,klev) =0.0 + pulow(jl) =0.0 + pvlow(jl) =0.0 + zulow(jl) =0.0 + zvlow(jl) =0.0 + kkcrith(jl) =klev + kkenvh(jl) =klev + kentp(jl) =klev + kcrit(jl) =1 + ncount(jl) =0 + ll1(jl,klev+1) =.false. + 2107 continue +c +c* define flow density and stratification (rho and N2) +c at semi layers. +c ------------------------------------------------------- +c + do 223 jk=klev,2,-1 + do 222 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* + * (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk)) + pstab(jl,jk)=max(pstab(jl,jk),gssec) + endif + 222 continue + 223 continue +c +c******************************************************************** +c +c* define Low level flow (between ground and peacks-valleys) +c --------------------------------------------------------- + do 2115 jk=klev,ilevh,-1 + do 2116 jl=kidia,kfdia + if(ktest(jl).eq.1) then + if(jk.ge.kknu2(jl).and.jk.le.kknul(jl)) then + pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pstab(jl,klev+1)=pstab(jl,klev+1) + c +pstab(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + prho(jl,klev+1)=prho(jl,klev+1) + c +prho(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + end if + endif + 2116 continue + 2115 continue + do 2110 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + pvph(jl,klev+1)=znorm(jl) + pstab(jl,klev+1)=pstab(jl,klev+1) + c /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + prho(jl,klev+1)=prho(jl,klev+1) + c /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl))) + endif + 2110 continue + +c +c******* setup orography orientation relative to the low level +C wind and define parameters of the Anisotropic wave stress. +c + do 2112 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec) + if(lo) then + zu=pulow(jl)+2.*gvsec + else + zu=pulow(jl) + endif + zphi=atan(pvlow(jl)/zu) + ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi + zb(jl)=1.-0.18*pgam(jl)-0.04*pgam(jl)**2 + zc(jl)=0.48*pgam(jl)+0.3*pgam(jl)**2 + pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2) + pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1)) + * *cos(ppsi(jl,klev+1)) + pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2) + endif + 2112 continue +c +c ************ projet flow in plane of lowlevel stress ************* +C ************ Find critical levels... ************* +c + do 213 jk=1,klev + do 212 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zvt1 =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk) + zvt2 =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk) + zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl)) + endif + ptau(jl,jk) =0.0 + pzdep(jl,jk) =0.0 + ppsi(jl,jk) =0.0 + ll1(jl,jk) =.false. + 212 continue + 213 continue + do 215 jk=2,klev + do 214 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1) + pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+ + * (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1)) + * /zdp(jl,jk) + if(pvph(jl,jk).lt.gvsec) then + pvph(jl,jk)=gvsec + kcrit(jl)=jk + endif + endif + 214 continue + 215 continue +c +c* 2.3 mean flow richardson number. +c + 230 continue +c + do 232 jk=2,klev + do 231 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec) + pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk) + * /(rg*prho(jl,jk)*zdwind))**2 + pri(jl,jk)=max(pri(jl,jk),grcrit) + endif + 231 continue + 232 continue + +c +c +c* define top of 'envelope' layer +c ---------------------------- + + do 233 jl=kidia,kfdia + pnu (jl)=0.0 + znum(jl)=0.0 + 233 continue + + do 234 jk=2,klev-1 + do 234 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + if (jk.ge.kknu2(jl)) then + + znum(jl)=pnu(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + pnu(jl) = pnu(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit) + * .and.(kkenvh(jl).eq.klev)) + * kkenvh(jl)=jk + + endif + + endif + + 234 continue + +c calculation of a dynamical mixing height for when the waves +C BREAK AT LOW LEVEL: The drag will be repartited over +C a depths that depends on waves vertical wavelength, +C not just between two adjacent model layers. +c of gravity waves: + + do 235 jl=kidia,kfdia + znup(jl)=0.0 + znum(jl)=0.0 + 235 continue + + do 236 jk=klev-1,2,-1 + do 236 jl=kidia,kfdia + + if(ktest(jl).eq.1) then + + znum(jl)=znup(jl) + zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ + * max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec) + zwind=max(sqrt(zwind**2),gvsec) + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zstabm=sqrt(max(pstab(jl,jk ),gssec)) + zstabp=sqrt(max(pstab(jl,jk+1),gssec)) + zrhom=prho(jl,jk ) + zrhop=prho(jl,jk+1) + znup(jl) = znup(jl) + (zdelp/rg)* + * ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind + if((znum(jl).le.rpi/4.).and.(znup(jl).gt.rpi/4.) + * .and.(kkcrith(jl).eq.klev)) + * kkcrith(jl)=jk + + endif + + 236 continue + + do 237 jl=kidia,kfdia + if(ktest(jl).eq.1) then + kkcrith(jl)=max0(kkcrith(jl),ilevh*2) + kkcrith(jl)=max0(kkcrith(jl),kknu(jl)) + if(kcrit(jl).ge.kkcrith(jl))kcrit(jl)=1 + endif + 237 continue +c +c directional info for flow blocking ************************* +c + do 251 jk=1,klev + do 252 jl=kidia,kfdia + if(ktest(jl).eq.1) then + lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec) + if(lo) then + zu=pum1(jl,jk)+2.*gvsec + else + zu=pum1(jl,jk) + endif + zphi=atan(pvm1(jl,jk)/zu) + ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi + endif + 252 continue + 251 continue + +c forms the vertical 'leakiness' ************************** + + do 254 jk=ilevh,klev + do 253 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pzdep(jl,jk)=0 + if(jk.ge.kkenvh(jl).and.kkenvh(jl).ne.klev) then + pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl) )-pgeom1(jl, jk))/ + * (pgeom1(jl,kkenvh(jl) )-pgeom1(jl,klev)) + end if + endif + 253 continue + 254 continue + + return + end + SUBROUTINE gwstress_strato + * ( nlon , nlev + * , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh + * , kknu + * , prho , pstab , pvph , pstd, psig + * , pmea , ppic , pval , ptfr , ptau + * , pgeom1 , pgamma , pd1 , pd2 , pdmod , pnu ) +c +c**** *gwstress* +c +c purpose. +c -------- +c Compute the surface stress due to Gravity Waves, according +c to the Phillips (1979) theory of 3-D flow above +c anisotropic elliptic ridges. + +C The stress is reduced two account for cut-off flow over +C hill. The flow only see that part of the ridge located +c above the blocked layer (see zeff). +c +c** interface. +c ---------- +c call *gwstress* from *gwdrag* +c +c explicit arguments : +c -------------------- +c ==== inputs === +c ==== outputs === +c +c implicit arguments : none +c -------------------- +c +c method. +c ------- +c +c +c externals. +c ---------- +c +c +c reference. +c ---------- +c +c LOTT and MILLER (1997) & LOTT (1999) +c +c author. +c ------- +c +c modifications. +c -------------- +c f. lott put the new gwd on ifs 22/11/93 +c +c----------------------------------------------------------------------- + USE dimphy + implicit none + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +c----------------------------------------------------------------------- +c +c* 0.1 arguments +c --------- +c + integer nlon,nlev + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon), + * kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon) +c + real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1), + * pvph(nlon,nlev+1),ptfr(nlon), + * pgeom1(nlon,nlev),pstd(nlon) +c + real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon) + real pmea(nlon),ppic(nlon),pval(nlon) + real pdmod(nlon) +c +c----------------------------------------------------------------------- +c +c* 0.2 local arrays +c ------------ +c zeff--real: effective height seen by the flow when there is blocking + + integer jl + real zeff +c +c----------------------------------------------------------------------- +c +c* 0.3 functions +c --------- +c ------------------------------------------------------------------ +c +c* 1. initialization +c -------------- +c +c PRINT *,' in gwstress' + 100 continue +c +c* 3.1 gravity wave stress. +c + 300 continue +c +c + do 301 jl=kidia,kfdia + if(ktest(jl).eq.1) then + +c effective mountain height above the blocked flow + + zeff=ppic(jl)-pval(jl) + if(kkenvh(jl).lt.klev)then + zeff=amin1(GFRCRIT*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1)) + c ,zeff) + endif + + + ptau(jl,klev+1)=gkdrag*prho(jl,klev+1) + * *psig(jl)*pdmod(jl)/4./pstd(jl) + * *pvph(jl,klev+1)*sqrt(pstab(jl,klev+1)) + * *zeff**2 + + +c too small value of stress or low level flow include critical level +c or low level flow: gravity wave stress nul. + +c lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl)) +c * .or.(pvph(jl,klev+1).lt.gvcrit) +c if(lo) ptau(jl,klev+1)=0.0 + +c print *,jl,ptau(jl,klev+1) + + else + + ptau(jl,klev+1)=0.0 + + endif + + 301 continue + +c write(21)(ptau(jl,klev+1),jl=kidia,kfdia) + + return + end + + subroutine gwprofil_strato + * ( nlon, nlev + * , kgwd ,kdx , ktest + * , kkcrit, kkcrith, kcrit , kkenvh, kknu,kknu2 + * , paphm1, prho , pstab , ptfr , pvph , pri , ptau + * , pdmod , pnu , psig ,pgamma, pstd, ppic,pval) + +C**** *gwprofil* +C +C purpose. +C -------- +C +C** interface. +C ---------- +C from *gwdrag* +C +C explicit arguments : +C -------------------- +C ==== inputs === +C +C ==== outputs === +C +C implicit arguments : none +C -------------------- +C +C method: +C ------- +C the stress profile for gravity waves is computed as follows: +C it decreases linearly with heights from the ground +C to the low-level indicated by kkcrith, +C to simulates lee waves or +C low-level gravity wave breaking. +C above it is constant, except when the waves encounter a critical +C level (kcrit) or when they break. +C The stress is also uniformly distributed above the level +C nstra. +C + USE dimphy + IMPLICIT NONE + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" + +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + integer nlon,nlev,kgwd + integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon) + * ,kdx(nlon),ktest(nlon) + * ,kkenvh(nlon),kknu(nlon),kknu2(nlon) +C + real paphm1(nlon,nlev+1), pstab(nlon,nlev+1), + * prho (nlon,nlev+1), pvph (nlon,nlev+1), + * pri (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1) + + real pdmod (nlon) , pnu (nlon) , psig(nlon), + * pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon) + +C----------------------------------------------------------------------- +C +C* 0.2 local arrays +C ------------ +C + integer jl,jk + real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt + + real zdz2 (klon,klev) , znorm(klon) , zoro(klon) + real ztau (klon,klev+1) +C +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C +C print *,' entree gwprofil' + 100 CONTINUE +C +C +C* COMPUTATIONAL CONSTANTS. +C ------------- ---------- +C + do 400 jl=kidia,kfdia + if(ktest(jl).eq.1)then + zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl) + ztau(jl,klev+1)=ptau(jl,klev+1) +c print *,jl,ptau(jl,klev+1) + ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1) + endif + 400 continue + +C + do 430 jk=klev+1,1,-1 +C +C +C* 4.1 constant shear stress until top of the +C low-level breaking/trapped layer + 410 CONTINUE +C + do 411 jl=kidia,kfdia + if(ktest(jl).eq.1)then + if(jk.gt.kkcrith(jl)) then + zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) + zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) + ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt* + c (ztau(jl,kkcrith(jl))-ztau(jl,klev+1)) + else + ptau(jl,jk)=ztau(jl,kkcrith(jl)) + endif + endif + 411 continue +C +C* 4.15 constant shear stress until the top of the +C low level flow layer. + 415 continue +C +C +C* 4.2 wave displacement at next level. +C + 420 continue +C + 430 continue + +C +C* 4.4 wave richardson number, new wave displacement +C* and stress: breaking evaluation and critical +C level +C + + do 440 jk=klev,1,-1 + + do 441 jl=kidia,kfdia + if(ktest(jl).eq.1)then + znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk) + zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl) + endif + 441 continue + + do 442 jl=kidia,kfdia + if(ktest(jl).eq.1)then + if(jk.lt.kkcrith(jl)) then + if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then + ptau(jl,jk)=0.0 + else + zsqr=sqrt(pri(jl,jk)) + zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk) + zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2 + if(zriw.lt.grcrit) then +C print *,' breaking!!!',ptau(jl,jk) + zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit + zb=1./grcrit+2./zsqr + zalpha=0.5*(-zb+sqrt(zdel)) + zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk) + ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl) + endif + + ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1)) + + endif + endif + endif + 442 continue + 440 continue + +C REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL + + do 530 jl=kidia,kfdia + if(ktest(jl).eq.1)then + ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1) + ztau(jl,nstra)=ptau(jl,nstra) + endif + 530 continue + + do 531 jk=1,klev + + do 532 jl=kidia,kfdia + if(ktest(jl).eq.1)then + + if(jk.gt.kkcrith(jl)-1)then + + zdelp=paphm1(jl,jk)-paphm1(jl,klev+1 ) + zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1 ) + ptau(jl,jk)=ztau(jl,klev+1 ) + + . (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1 ) )* + . zdelp/zdelpt + + endif + endif + + 532 continue + +C REORGANISATION AT THE MODEL TOP.... + + do 533 jl=kidia,kfdia + if(ktest(jl).eq.1)then + + if(jk.lt.nstra)then + + zdelp =paphm1(jl,nstra) + zdelpt=paphm1(jl,jk) + ptau(jl,jk)=ztau(jl,nstra)*zdelpt/zdelp +c ptau(jl,jk)=ztau(jl,nstra) + + endif + + endif + + 533 continue + + + 531 continue + + + 123 format(i4,1x,20(f6.3,1x)) + + + return + end + subroutine lift_noro_strato (nlon,nlev,dtime,paprs,pplay, + i plat,pmea,pstd, psig, pgam, pthe, ppic,pval, + i kgwd,kdx,ktest, + i t, u, v, + o pulow, pvlow, pustr, pvstr, + o d_t, d_u, d_v) +c + USE dimphy + implicit none +c====================================================================== +c Auteur(s): F.Lott (LMD/CNRS) date: 19950201 +c Object: Mountain lift interface (enhanced vortex stretching). +c Made necessary because: +C 1. in the LMD-GCM Layers are from bottom to top, +C contrary to most European GCM. +c 2. the altitude above ground of each model layers +c needs to be known (variable zgeom) +c====================================================================== +c Explicit Arguments: +c ================== +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c dtime---input-R-Time-step (s) +c paprs---input-R-Pressure in semi layers (Pa) +c pplay---input-R-Pressure model-layers (Pa) +c t-------input-R-temperature (K) +c u-------input-R-Horizontal wind (m/s) +c v-------input-R-Meridional wind (m/s) +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. + +c pulow, pvlow -output-R: Low-level wind +c pustr, pvstr -output-R: Surface stress due to SSO drag (Pa) +c +c d_t-----output-R: T increment +c d_u-----output-R: U increment +c d_v-----output-R: V increment +c +c Implicit Arguments: +c =================== +c +c iim--common-I: Number of longitude intervals +c jjm--common-I: Number of latitude intervals +c klon-common-I: Number of points seen by the physics +c (iim+1)*(jjm+1) for instance +c klev-common-I: Number of vertical layers +c====================================================================== +c Local Variables: +c ================ +c +c zgeom-----R: Altitude of layer above ground +c pt, pu, pv --R: t u v from top to bottom +c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) +c papmf: pressure at model layer (from top to bottom) +c papmh: pressure at model 1/2 layer (from top to bottom) +c +c====================================================================== + +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +c +c ARGUMENTS +c + INTEGER nlon,nlev + REAL dtime + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL plat(nlon),pmea(nlon) + REAL pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon) + REAL ppic(nlon),pval(nlon) + REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon) + REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev) + REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev) +c + INTEGER i, k, kgwd, kdx(nlon), ktest(nlon) +c +c Variables locales: +c + REAL zgeom(klon,klev) + REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev) + REAL pt(klon,klev), pu(klon,klev), pv(klon,klev) + REAL papmf(klon,klev),papmh(klon,klev+1) +c +c initialiser les variables de sortie (pour securite) +c + +c print *,'in lift_noro' + DO i = 1,klon + pulow(i) = 0.0 + pvlow(i) = 0.0 + pustr(i) = 0.0 + pvstr(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + pdudt(i,k)=0.0 + pdvdt(i,k)=0.0 + pdtdt(i,k)=0.0 + ENDDO + ENDDO +c +c preparer les variables d'entree (attention: l'ordre des niveaux +c verticaux augmente du haut vers le bas) +c + DO k = 1, klev + DO i = 1, klon + pt(i,k) = t(i,klev-k+1) + pu(i,k) = u(i,klev-k+1) + pv(i,k) = v(i,klev-k+1) + papmf(i,k) = pplay(i,klev-k+1) + ENDDO + ENDDO + DO k = 1, klev+1 + DO i = 1, klon + papmh(i,k) = paprs(i,klev-k+2) + ENDDO + ENDDO + DO i = 1, klon + zgeom(i,klev) = RD * pt(i,klev) + . * LOG(papmh(i,klev+1)/papmf(i,klev)) + ENDDO + DO k = klev-1, 1, -1 + DO i = 1, klon + zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0 + . * LOG(papmf(i,k+1)/papmf(i,k)) + ENDDO + ENDDO +c +c appeler la routine principale +c + + CALL OROLIFT_strato(klon,klev,kgwd,kdx,ktest, + . dtime, + . papmh, papmf, zgeom, + . pt, pu, pv, + . plat,pmea, pstd, psig, pgam, pthe, ppic,pval, + . pulow,pvlow, + . pdudt,pdvdt,pdtdt) +C + DO k = 1, klev + DO i = 1, klon + d_u(i,klev+1-k) = dtime*pdudt(i,k) + d_v(i,klev+1-k) = dtime*pdvdt(i,k) + d_t(i,klev+1-k) = dtime*pdtdt(i,k) + pustr(i) = pustr(i) + . +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + pvstr(i) = pvstr(i) + . +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg + ENDDO + ENDDO + +c print *,' out lift_noro' +c + RETURN + END + subroutine orolift_strato( nlon,nlev + I , kgwd, kdx, ktest + R , ptsphy + R , paphm1,papm1,pgeom1,ptm1,pum1,pvm1 + R , plat + R , pmea, pstd, psig, pgam, pthe,ppic,pval +C OUTPUTS + R , pulow,pvlow + R , pvom,pvol,pte ) + +C +C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT. +C +C PURPOSE. +C -------- +C this routine computes the physical tendencies of the +C prognostic variables u,v when enhanced vortex stretching +C is needed. +C +C** INTERFACE. +C ---------- +C CALLED FROM *lift_noro +c explicit arguments : +c -------------------- +c ==== inputs === +c nlon----input-I-Total number of horizontal points that get into physics +c nlev----input-I-Number of vertical levels +c +c kgwd- -input-I: Total nb of points where the orography schemes are active +c ktest--input-I: Flags to indicate active points +c kdx----input-I: Locate the physical location of an active point. +c ptsphy--input-R-Time-step (s) +c paphm1--input-R: pressure at model 1/2 layer +c papm1---input-R: pressure at model layer +c pgeom1--input-R: Altitude of layer above ground +c ptm1, pum1, pvm1--R-: t, u and v +c pmea----input-R-Mean Orography (m) +C pstd----input-R-SSO standard deviation (m) +c psig----input-R-SSO slope +c pgam----input-R-SSO Anisotropy +c pthe----input-R-SSO Angle +c ppic----input-R-SSO Peacks elevation (m) +c pval----input-R-SSO Valleys elevation (m) +c plat----input-R-Latitude (degree) +c +c ==== outputs === +c pulow, pvlow -output-R: Low-level wind +c +c pte -----output-R: T tendency +c pvom-----output-R: U tendency +c pvol-----output-R: V tendency +c +c +c Implicit Arguments: +c =================== +c +c klon-common-I: Number of points seen by the physics +c klev-common-I: Number of vertical layers +c + +C ---------- +C +C AUTHOR. +C ------- +C F.LOTT LMD 22/11/95 +C + USE dimphy + implicit none +C +C +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +#include "YOEGWD.h" +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C +C + integer nlon,nlev,kgwd + real ptsphy + real pte(nlon,nlev), + * pvol(nlon,nlev), + * pvom(nlon,nlev), + * pulow(nlon), + * pvlow(nlon) + real pum1(nlon,nlev), + * pvm1(nlon,nlev), + * ptm1(nlon,nlev), + * plat(nlon),pmea(nlon), + * pstd(nlon),psig(nlon),pgam(nlon), + * pthe(nlon),ppic(nlon),pval(nlon), + * pgeom1(nlon,nlev), + * papm1(nlon,nlev), + * paphm1(nlon,nlev+1) +C + INTEGER KDX(NLON),KTEST(NLON) +C----------------------------------------------------------------------- +C +C* 0.2 local arrays + + integer jl,ilevh,jk + real zhgeo,zdelp,zslow,zsqua,zscav,zbet +C ------------ + integer iknub(klon), + * iknul(klon) + logical ll1(klon,klev+1) +C + real ztau(klon,klev+1), + * ztav(klon,klev+1), + * zrho(klon,klev+1) + real zdudt(klon), + * zdvdt(klon) + real zhcrit(klon,klev) + + logical lifthigh + real zcons1,ztmst + CHARACTER (LEN=20) :: modname='orolift_strato' + CHARACTER (LEN=80) :: abort_message + + +C----------------------------------------------------------------------- +C +C* 1.1 initialisations +C --------------- + + lifthigh=.false. + + if(nlon.ne.klon.or.nlev.ne.klev) then + abort_message = 'pb dimension' + CALL abort_gcm (modname,abort_message,1) + ENDIF + zcons1=1./rd + ztmst=ptsphy +C + do 1001 jl=kidia,kfdia + zrho(jl,klev+1) =0.0 + pulow(jl) =0.0 + pvlow(jl) =0.0 + iknub(JL) =klev + iknul(JL) =klev + ilevh=klev/3 + ll1(jl,klev+1)=.false. + do 1000 jk=1,klev + pvom(jl,jk)=0.0 + pvol(jl,jk)=0.0 + pte (jl,jk)=0.0 + 1000 continue + 1001 continue + +C +C* 2.1 DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF +C* LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE +C* THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS. +C +C +C + do 2006 jk=klev,1,-1 + do 2007 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zhcrit(jl,jk)=amax1(ppic(jl)-pval(jl),100.) + zhgeo=pgeom1(jl,jk)/rg + ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk)) + if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then + iknub(jl)=jk + endif + endif + 2007 continue + 2006 continue +C + + do 2010 jl=kidia,kfdia + if(ktest(jl).eq.1) then + iknub(jl)=max(iknub(jl),klev/2) + iknul(jl)=max(iknul(jl),2*klev/3) + if(iknub(jl).gt.nktopg) iknub(jl)=nktopg + if(iknub(jl).eq.nktopg) iknul(jl)=klev + if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1 + endif + 2010 continue + + do 223 jk=klev,2,-1 + do 222 jl=kidia,kfdia + zrho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1)) + 222 continue + 223 continue +c print *,' dans orolift: 223' + +C******************************************************************** +C +c* define low level flow +C ------------------- + do 2115 jk=klev,1,-1 + do 2116 jl=kidia,kfdia + if(ktest(jl).eq.1) THEN + if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then + pulow(JL)=pulow(JL)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + pvlow(JL)=pvlow(JL)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + zrho(JL,klev+1)=zrho(JL,klev+1) + * +zrho(JL,JK)*(paphm1(jl,jk+1)-paphm1(jl,jk)) + endif + endif + 2116 continue + 2115 continue + do 2110 jl=kidia,kfdia + if(ktest(jl).eq.1) then + pulow(JL)=pulow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + pvlow(JL)=pvlow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + zrho(JL,klev+1)=zrho(Jl,klev+1) + * /(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl))) + endif + 2110 continue + + +200 continue + +C*********************************************************** +C +C* 3. COMPUTE MOUNTAIN LIFT +C + 300 continue +C + do 301 jl=kidia,kfdia + if(ktest(jl).eq.1) then + ztau(jl,klev+1)= - gklift*zrho(jl,klev+1)*2.*romega* +c * (2*pstd(jl)+pmea(jl))* + * 2*pstd(jl)* + * sin(rpi/180.*plat(jl))*pvlow(jl) + ztav(jl,klev+1)= gklift*zrho(jl,klev+1)*2.*romega* +c * (2*pstd(jl)+pmea(jl))* + * 2*pstd(jl)* + * sin(rpi/180.*plat(jl))*pulow(jl) + else + ztau(jl,klev+1)=0.0 + ztav(jl,klev+1)=0.0 + endif +301 continue + +C +C* 4. COMPUTE LIFT PROFILE +C* -------------------- +C + + 400 continue + + do 401 jk=1,klev + do 401 jl=kidia,kfdia + if(ktest(jl).eq.1) then + ztau(jl,jk)=ztau(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1) + ztav(jl,jk)=ztav(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1) + else + ztau(jl,jk)=0.0 + ztav(jl,jk)=0.0 + endif +401 continue +C +C +C* 5. COMPUTE TENDENCIES. +C* ------------------- + if(lifthigh)then +C + 500 continue +C +C EXPLICIT SOLUTION AT ALL LEVELS +C + do 524 jk=1,klev + do 523 jl=kidia,kfdia + if(ktest(jl).eq.1) then + zdelp=paphm1(jl,jk+1)-paphm1(jl,jk) + zdudt(jl)=-rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp + zdvdt(jl)=-rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp + endif + 523 continue + 524 continue +C +C PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY +C + do 530 jk=1,klev + do 530 jl=kidia,kfdia + if(ktest(jl).eq.1) then + + zslow=sqrt(pulow(jl)**2+pvlow(jl)**2) + zsqua=amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2),gvsec) + zscav=-zdudt(jl)*pvm1(jl,jk)+zdvdt(jl)*pum1(jl,jk) + if(zsqua.gt.gvsec)then + pvom(jl,jk)=-zscav*pvm1(jl,jk)/zsqua**2 + pvol(jl,jk)= zscav*pum1(jl,jk)/zsqua**2 + else + pvom(jl,jk)=0.0 + pvol(jl,jk)=0.0 + endif + zsqua=sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2) + if(zsqua.lt.zslow)then + pvom(jl,jk)=zsqua/zslow*pvom(jl,jk) + pvol(jl,jk)=zsqua/zslow*pvol(jl,jk) + endif + + endif +530 continue +C +C 6. LOW LEVEL LIFT, SEMI IMPLICIT: +C ---------------------------------- + + else + + do 601 jl=kidia,kfdia + if(ktest(jl).eq.1) then + do jk=klev,iknub(jl),-1 + zbet=gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst* + * (pgeom1(jl,iknub(jl)-1)-pgeom1(jl, jk))/ + * (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev)) + zdudt(jl)=-pum1(jl,jk)/ztmst/(1+zbet**2) + zdvdt(jl)=-pvm1(jl,jk)/ztmst/(1+zbet**2) + pvom(jl,jk)= zbet**2*zdudt(jl) - zbet *zdvdt(jl) + pvol(jl,jk)= zbet *zdudt(jl) + zbet**2*zdvdt(jl) + enddo + endif + 601 continue + + endif + +c print *,' out orolift' + + return + end + SUBROUTINE SUGWD_strato(NLON,NLEV,paprs,pplay) +C +C +C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG +C +C PURPOSE. +C -------- +C INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE +C GRAVITY WAVE DRAG PARAMETRIZATION. +C VERY IMPORTANT: +C ______________ +C THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE +C VARIOUS SSO SCHEMES +C +C** INTERFACE. +C ---------- +C CALL *SUGWD* FROM *SUPHEC* +C ----- ------ +C +C EXPLICIT ARGUMENTS : +C -------------------- +C PAPRS,PPLAY : Pressure at semi and full model levels +C NLEV : number of model levels +c NLON : number of points treated in the physics +C +C IMPLICIT ARGUMENTS : +C -------------------- +C COMMON YOEGWD +C-GFRCRIT-R: Critical Non-dimensional mountain Height +C (HNC in (1), LOTT 1999) +C-GKWAKE--R: Bluff-body drag coefficient for low level wake +C (Cd in (2), LOTT 1999) +C-GRCRIT--R: Critical Richardson Number +C (Ric, End of first column p791 of LOTT 1999) +C-GKDRAG--R: Gravity wave drag coefficient +C (G in (3), LOTT 1999) +C-GKLIFT--R: Mountain Lift coefficient +C (Cl in (4), LOTT 1999) +C-GHMAX---R: Not used +C-GRAHILO-R: Set-up the trapped waves fraction +C (Beta , End of first column, LOTT 1999) +C +C-GSIGCR--R: Security value for blocked flow depth +C-NKTOPG--I: Security value for blocked flow level +C-nstra----I: An estimate to qualify the upper levels of +C the model where one wants to impose strees +C profiles +C-GSSECC--R: Security min value for low-level B-V frequency +C-GTSEC---R: Security min value for anisotropy and GW stress. +C-GVSEC---R: Security min value for ulow +C +C +C METHOD. +C ------- +C SEE DOCUMENTATION +C +C EXTERNALS. +C ---------- +C NONE +C +C REFERENCE. +C ---------- +C Lott, 1999: Alleviation of stationary biases in a GCM through... +C Monthly Weather Review, 127, pp 788-801. +C +C AUTHOR. +C ------- +C FRANCOIS LOTT *LMD* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF) +C LAST: 99-07-09 (FRANCOIS LOTT,LMD) +C ------------------------------------------------------------------ + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + IMPLICIT NONE +C +C ----------------------------------------------------------------- +#include "YOEGWD.h" +C ---------------------------------------------------------------- +C +C ARGUMENTS + integer nlon,nlev + REAL paprs(nlon,nlev+1) + REAL pplay(nlon,nlev) +C + INTEGER JK + REAL ZPR,ZTOP,ZSIGT,ZPM1R + REAL :: pplay_glo(klon_glo,nlev) + REAL :: paprs_glo(klon_glo,nlev+1) + +C +C* 1. SET THE VALUES OF THE PARAMETERS +C -------------------------------- +C + 100 CONTINUE +C + PRINT *,' DANS SUGWD NLEV=',NLEV + GHMAX=10000. +C + ZPR=100000. + ZTOP=0.001 + ZSIGT=0.94 +cold ZPR=80000. +cold ZSIGT=0.85 +C + CALL gather(pplay,pplay_glo) + CALL bcast(pplay_glo) + CALL gather(paprs,paprs_glo) + CALL bcast(paprs_glo) + + DO 110 JK=1,NLEV + ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2+1,1) + IF(ZPM1R.GE.ZSIGT)THEN + nktopg=JK + ENDIF + ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2+1,1) + IF(ZPM1R.GE.ZTOP)THEN + nstra=JK + ENDIF + 110 CONTINUE +c +c inversion car dans orodrag on compte les niveaux a l'envers + nktopg=nlev-nktopg+1 + nstra=nlev-nstra + print *,' DANS SUGWD nktopg=', nktopg + print *,' DANS SUGWD nstra=', nstra +C + GSIGCR=0.80 +C + GKDRAG=0.1875 + GRAHILO=0.1 + GRCRIT=1.00 + GFRCRIT=1.00 + GKWAKE=0.50 +C + GKLIFT=0.25 + GVCRIT =0.1 + + WRITE(UNIT=6,FMT='('' *** SSO essential constants ***'')') + WRITE(UNIT=6,FMT='('' *** SPECIFIED IN SUGWD ***'')') + WRITE(UNIT=6,FMT='('' Gravity wave ct '',E13.7,'' '')')GKDRAG + WRITE(UNIT=6,FMT='('' Trapped/total wave dag '',E13.7,'' '')') + S GRAHILO + WRITE(UNIT=6,FMT='('' Critical Richardson = '',E13.7,'' '')') + S GRCRIT + WRITE(UNIT=6,FMT='('' Critical Froude'',e13.7)') GFRCRIT + WRITE(UNIT=6,FMT='('' Low level Wake bluff cte'',e13.7)') GKWAKE + WRITE(UNIT=6,FMT='('' Low level lift cte'',e13.7)') GKLIFT + +C +C +C ---------------------------------------------------------------- +C +C* 2. SET VALUES OF SECURITY PARAMETERS +C --------------------------------- +C + 200 CONTINUE +C + GVSEC=0.10 + GSSEC=0.0001 +C + GTSEC=0.00001 +C + RETURN + END + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ozonecm_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ozonecm_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ozonecm_m.F90 (revision 1634) @@ -0,0 +1,92 @@ +! $Header$ +module ozonecm_m + + IMPLICIT NONE + +contains + + function ozonecm(rlat, paprs, rjour) + + ! The ozone climatology is based on an analytic formula which fits the + ! Krueger and Mintzner (1976) profile, as well as the variations with + ! altitude and latitude of the maximum ozone concentrations and the total + ! column ozone concentration of Keating and Young (1986). The analytic + ! formula have been established by J.-F. Royer (CRNM, Meteo France), who + ! also provided us the code. + + ! A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the + ! 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976). + + ! Keating, G. M. and D. F. Young, 1985: Interim reference models for the + ! middle atmosphere, Handbook for MAP, vol. 16, 205-229. + + USE dimphy, only: klon, klev + use assert_m, only: assert + + REAL, INTENT (IN) :: rlat(:) ! (klon) + REAL, INTENT (IN) :: paprs(:, :) ! (klon,klev+1) + REAL, INTENT (IN) :: rjour + + REAL ozonecm(klon,klev) + ! "ozonecm(j, k)" is the column-density of ozone in cell "(j, k)", that is + ! between interface "k" and interface "k + 1", in kDU. + + ! Variables local to the procedure: + + REAL tozon ! equivalent pressure of ozone above interface "k", in Pa + real pi, pl + INTEGER i, k + + REAL field(klon,klev+1) + ! "field(:, k)" is the column-density of ozone between interface + ! "k" and the top of the atmosphere (interface "llm + 1"), in kDU. + + real, PARAMETER:: ps=101325. + REAL, parameter:: an = 360., zo3q3 = 4E-8 + REAL, parameter:: dobson_unit = 2.1415E-5 ! in kg m-2 + REAL gms, zslat, zsint, zcost, z, ppm, qpm, a + REAL asec, bsec, aprim, zo3a3 + + !---------------------------------------------------------- + + call assert((/size(rlat), size(paprs, 1)/) == klon, "ozonecm klon") + call assert(size(paprs, 2) == klev + 1, "ozonecm klev") + + pi = 4. * atan(1.) + DO k = 1, klev + DO i = 1, klon + zslat = sin(pi / 180. * rlat(i)) + zsint = sin(2 * pi * (rjour + 15.) / an) + zcost = cos(2 * pi * (rjour + 15.) / an) + z = 0.0531 + zsint * (-0.001595+0.009443*zslat) & + + zcost * (-0.001344-0.00346*zslat) & + + zslat**2 * (.056222 + zslat**2 & + * (-.037609+.012248*zsint+.00521*zcost+.008890*zslat)) + zo3a3 = zo3q3/ps/2. + z = z - zo3q3*ps + gms = z + ppm = 800. - (500.*zslat+150.*zcost)*zslat + qpm = 1.74E-5 - (7.5E-6*zslat+1.7E-6*zcost)*zslat + bsec = 2650. + 5000.*zslat**2 + a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.)) + a = a/(bsec**(3./2.)+ppm**(3./2.))**2 + aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a) + aprim = amax1(0., aprim) + asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.)) + asec = amax1(0.0, asec) + aprim = gms - asec/(1.+(bsec/ps)**(3./2.)) + pl = paprs(i, k) + tozon = aprim / (1. + 3. * (ppm / pl)**2) & + + asec / (1. + (bsec / pl)**(3./2.)) + zo3a3 * pl * pl + ! Convert from Pa to kDU: + field(i, k) = tozon / 9.81 / dobson_unit / 1e3 + END DO + END DO + + field(:,klev+1) = 0. + forall (k = 1: klev) ozonecm(:,k) = field(:,k) - field(:,k+1) + ozonecm = max(ozonecm, 1e-12) + + END function ozonecm + +end module ozonecm_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/pbl_surface_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/pbl_surface_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/pbl_surface_mod.F90 (revision 1634) @@ -0,0 +1,1404 @@ +! +! $Id$ +! +MODULE pbl_surface_mod +! +! Planetary Boundary Layer and Surface module +! +! This module manage the calculation of turbulent diffusion in the boundary layer +! and all interactions towards the differents sub-surfaces. +! +! + USE dimphy + USE mod_phys_lmdz_para, ONLY : mpi_size + USE ioipsl + USE surface_data, ONLY : type_ocean, ok_veget + USE surf_land_mod, ONLY : surf_land + USE surf_landice_mod, ONLY : surf_landice + USE surf_ocean_mod, ONLY : surf_ocean + USE surf_seaice_mod, ONLY : surf_seaice + USE cpl_mod, ONLY : gath2cpl + USE climb_hq_mod, ONLY : climb_hq_down, climb_hq_up + USE climb_wind_mod, ONLY : climb_wind_down, climb_wind_up + USE coef_diff_turb_mod, ONLY : coef_diff_turb + USE control_mod + + + IMPLICIT NONE + +! Declaration of variables saved in restart file + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: qsol ! water height in the soil (mm) + !$OMP THREADPRIVATE(qsol) + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: fder ! flux drift + !$OMP THREADPRIVATE(fder) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: snow ! snow at surface + !$OMP THREADPRIVATE(snow) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qsurf ! humidity at surface + !$OMP THREADPRIVATE(qsurf) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: evap ! evaporation at surface + !$OMP THREADPRIVATE(evap) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: rugos ! rugosity at surface (m) + !$OMP THREADPRIVATE(rugos) + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: agesno ! age of snow at surface + !$OMP THREADPRIVATE(agesno) + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: ftsoil ! soil temperature + !$OMP THREADPRIVATE(ftsoil) + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,& + evap_rst, rugos_rst, agesno_rst, ftsoil_rst) + +! This routine should be called after the restart file has been read. +! This routine initialize the restart variables and does some validation tests +! for the index of the different surfaces and tests the choice of type of ocean. + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "iniprint.h" + +! Input variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(IN) :: qsol_rst + REAL, DIMENSION(klon), INTENT(IN) :: fder_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: snow_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: qsurf_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: evap_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: rugos_rst + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: agesno_rst + REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(IN) :: ftsoil_rst + + +! Local variables +!**************************************************************************************** + INTEGER :: ierr + CHARACTER(len=80) :: abort_message + CHARACTER(len = 20) :: modname = 'pbl_surface_init' + + +!**************************************************************************************** +! Allocate and initialize module variables with fields read from restart file. +! +!**************************************************************************************** + ALLOCATE(qsol(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(fder(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(snow(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(qsurf(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(evap(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(rugos(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(agesno(klon,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + ALLOCATE(ftsoil(klon,nsoilmx,nbsrf), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1) + + + qsol(:) = qsol_rst(:) + fder(:) = fder_rst(:) + snow(:,:) = snow_rst(:,:) + qsurf(:,:) = qsurf_rst(:,:) + evap(:,:) = evap_rst(:,:) + rugos(:,:) = rugos_rst(:,:) + agesno(:,:) = agesno_rst(:,:) + ftsoil(:,:,:) = ftsoil_rst(:,:,:) + + +!**************************************************************************************** +! Test for sub-surface indices +! +!**************************************************************************************** + IF (is_ter /= 1) THEN + WRITE(lunout,*)" *** Warning ***" + WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter + WRITE(lunout,*)"or on doit commencer par les surfaces continentales" + abort_message="voir ci-dessus" + CALL abort_gcm(modname,abort_message,1) + ENDIF + + IF ( is_oce > is_sic ) THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)' Pour des raisons de sequencement dans le code' + WRITE(lunout,*)' l''ocean doit etre traite avant la banquise' + WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic + abort_message='voir ci-dessus' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + IF ( is_lic > is_sic ) THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)' Pour des raisons de sequencement dans le code' + WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer' + WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic + abort_message='voir ci-dessus' + CALL abort_gcm(modname,abort_message,1) + ENDIF + +!**************************************************************************************** +! Validation of ocean mode +! +!**************************************************************************************** + + IF (type_ocean /= 'slab ' .AND. type_ocean /= 'force ' .AND. type_ocean /= 'couple') THEN + WRITE(lunout,*)' *** Warning ***' + WRITE(lunout,*)'Option couplage pour l''ocean = ', type_ocean + abort_message='option pour l''ocean non valable' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + END SUBROUTINE pbl_surface_init +! +!**************************************************************************************** +! + + SUBROUTINE pbl_surface( & + dtime, date0, itap, jour, & + debut, lafin, & + rlon, rlat, rugoro, rmu0, & + rain_f, snow_f, solsw_m, sollw_m, & + t, q, u, v, & + pplay, paprs, pctsrf, & + ts, alb1, alb2, u10m, v10m, & + lwdown_m, cdragh, cdragm, zu1, zv1, & + alb1_m, alb2_m, zxsens, zxevap, & + zxtsol, zxfluxlat, zt2m, qsat2m, & + d_t, d_q, d_u, d_v, & + zcoefh, zcoefm, slab_wfbils, & + qsol_d, zq2m, s_pblh, s_plcl, & + s_capCL, s_oliqCL, s_cteiCL, s_pblT, & + s_therm, s_trmb1, s_trmb2, s_trmb3, & + zxrugs, zu10m, zv10m, fder_print, & + zxqsurf, rh2m, zxfluxu, zxfluxv, & + rugos_d, agesno_d, sollw, solsw, & + d_ts, evap_d, fluxlat, t2m, & + wfbils, wfbilo, flux_t, flux_u, flux_v,& + dflux_t, dflux_q, zxsnow, & + zxfluxt, zxfluxq, q2m, flux_q, tke ) +!**************************************************************************************** +! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +! Objet: interface de "couche limite" (diffusion verticale) +! +!AA REM: +!AA----- +!AA Tout ce qui a trait au traceurs est dans phytrac maintenant +!AA pour l'instant le calcul de la couche limite pour les traceurs +!AA se fait avec cltrac et ne tient pas compte de la differentiation +!AA des sous-fraction de sol. +!AA REM bis : +!AA---------- +!AA Pour pouvoir extraire les coefficient d'echanges et le vent +!AA dans la premiere couche, 3 champs supplementaires ont ete crees +!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs +!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir +!AA si les informations des subsurfaces doivent etre prises en compte +!AA il faudra sortir ces memes champs en leur ajoutant une dimension, +!AA c'est a dire nbsrf (nbre de subsurface). +! +! Arguments: +! +! dtime----input-R- interval du temps (secondes) +! itap-----input-I- numero du pas de temps +! date0----input-R- jour initial +! t--------input-R- temperature (K) +! q--------input-R- vapeur d'eau (kg/kg) +! u--------input-R- vitesse u +! v--------input-R- vitesse v +! ts-------input-R- temperature du sol (en Kelvin) +! paprs----input-R- pression a intercouche (Pa) +! pplay----input-R- pression au milieu de couche (Pa) +! rlat-----input-R- latitude en degree +! rugos----input-R- longeur de rugosite (en m) +! +! d_t------output-R- le changement pour "t" +! d_q------output-R- le changement pour "q" +! d_u------output-R- le changement pour "u" +! d_v------output-R- le changement pour "v" +! d_ts-----output-R- le changement pour "ts" +! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2) +! (orientation positive vers le bas) +! tke---input/output-R- tke (kg/m**2/s) +! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s) +! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal +! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal +! dflux_t--output-R- derive du flux sensible +! dflux_q--output-R- derive du flux latent +! zu1------output-R- le vent dans la premiere couche +! zv1------output-R- le vent dans la premiere couche +! trmb1----output-R- deep_cape +! trmb2----output-R- inhibition +! trmb3----output-R- Point Omega +! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL +! plcl-----output-R- Niveau de condensation +! pblh-----output-R- HCL +! pblT-----output-R- T au nveau HCL +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + INCLUDE "FCTTRE.h" + INCLUDE "clesphys.h" + INCLUDE "compbl.h" + INCLUDE "dimensions.h" + INCLUDE "YOETHF.h" + INCLUDE "temps.h" +! Input variables +!**************************************************************************************** + REAL, INTENT(IN) :: dtime ! time interval (s) + REAL, INTENT(IN) :: date0 ! initial day + INTEGER, INTENT(IN) :: itap ! time step + INTEGER, INTENT(IN) :: jour ! current day of the year + LOGICAL, INTENT(IN) :: debut ! true if first run step + LOGICAL, INTENT(IN) :: lafin ! true if last run step + REAL, DIMENSION(klon), INTENT(IN) :: rlon ! longitudes in degrees + REAL, DIMENSION(klon), INTENT(IN) :: rlat ! latitudes in degrees + REAL, DIMENSION(klon), INTENT(IN) :: rugoro ! rugosity length + REAL, DIMENSION(klon), INTENT(IN) :: rmu0 ! cosine of solar zenith angle + REAL, DIMENSION(klon), INTENT(IN) :: rain_f ! rain fall + REAL, DIMENSION(klon), INTENT(IN) :: snow_f ! snow fall + REAL, DIMENSION(klon), INTENT(IN) :: solsw_m ! net shortwave radiation at mean surface + REAL, DIMENSION(klon), INTENT(IN) :: sollw_m ! net longwave radiation at mean surface + REAL, DIMENSION(klon,klev), INTENT(IN) :: t ! temperature (K) + REAL, DIMENSION(klon,klev), INTENT(IN) :: q ! water vapour (kg/kg) + REAL, DIMENSION(klon,klev), INTENT(IN) :: u ! u speed + REAL, DIMENSION(klon,klev), INTENT(IN) :: v ! v speed + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! mid-layer pression (Pa) + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression between layers (Pa) + REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf ! sub-surface fraction + +! Input/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: ts ! temperature at surface (K) + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: alb2 ! albedo in near infra-red SW interval + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: u10m ! u speed at 10m + REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: v10m ! v speed at 10m + REAL, DIMENSION(klon, klev+1, nbsrf), INTENT(INOUT) :: tke + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: lwdown_m ! Downcoming longwave radiation + REAL, DIMENSION(klon), INTENT(OUT) :: cdragh ! drag coefficient for T and Q + REAL, DIMENSION(klon), INTENT(OUT) :: cdragm ! drag coefficient for wind + REAL, DIMENSION(klon), INTENT(OUT) :: zu1 ! u wind speed in first layer + REAL, DIMENSION(klon), INTENT(OUT) :: zv1 ! v wind speed in first layer + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_m ! mean albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_m ! mean albedo in near IR SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: zxsens ! sensible heat flux at surface with inversed sign + ! (=> positive sign upwards) + REAL, DIMENSION(klon), INTENT(OUT) :: zxevap ! water vapour flux at surface, positiv upwards + REAL, DIMENSION(klon), INTENT(OUT) :: zxtsol ! temperature at surface, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat ! latent flux, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zt2m ! temperature at 2m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: qsat2m + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t ! change in temperature + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_q ! change in water vapour + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_u ! change in u speed + REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_v ! change in v speed + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zcoefh ! coef for turbulent diffusion of T and Q, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zcoefm ! coef for turbulent diffusion of U and V (?), mean for each grid point + +! Output only for diagnostics + REAL, DIMENSION(klon), INTENT(OUT) :: slab_wfbils! heat balance at surface only for slab at ocean points + REAL, DIMENSION(klon), INTENT(OUT) :: qsol_d ! water height in the soil (mm) + REAL, DIMENSION(klon), INTENT(OUT) :: zq2m ! water vapour at 2m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh ! height of the planetary boundary layer(HPBL) + REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl ! condensation level + REAL, DIMENSION(klon), INTENT(OUT) :: s_capCL ! CAPE of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_oliqCL ! liquid water intergral of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_cteiCL ! cloud top instab. crit. of PBL + REAL, DIMENSION(klon), INTENT(OUT) :: s_pblT ! temperature at PBLH + REAL, DIMENSION(klon), INTENT(OUT) :: s_therm ! thermal virtual temperature excess + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb1 ! deep cape, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb2 ! inhibition, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb3 ! point Omega, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zxrugs ! rugosity at surface (m), mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zu10m ! u speed at 10m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: zv10m ! v speed at 10m, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: fder_print ! fder for printing (=fder(i) + dflux_t(i) + dflux_q(i)) + REAL, DIMENSION(klon), INTENT(OUT) :: zxqsurf ! humidity at surface, mean for each grid point + REAL, DIMENSION(klon), INTENT(OUT) :: rh2m ! relative humidity at 2m + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxu ! u wind tension, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxv ! v wind tension, mean for each grid point + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: rugos_d ! rugosity length (m) + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: agesno_d ! age of snow at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: solsw ! net shortwave radiation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: sollw ! net longwave radiation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: d_ts ! change in temperature at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: evap_d ! evaporation at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: fluxlat ! latent flux + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: t2m ! temperature at 2 meter height + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfbils ! heat balance at surface + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfbilo ! water balance at surface + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t ! sensible heat flux (CpT) J/m**2/s (W/m**2) + ! positve orientation downwards + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u ! u wind tension (kg m/s)/(m**2 s) or Pascal + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_v ! v wind tension (kg m/s)/(m**2 s) or Pascal + +! Output not needed + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_t ! change of sensible heat flux + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_q ! change of water vapour flux + REAL, DIMENSION(klon), INTENT(OUT) :: zxsnow ! snow at surface, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxt ! sensible heat flux, mean for each grid point + REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxq ! water vapour flux, mean for each grid point + REAL, DIMENSION(klon, nbsrf),INTENT(OUT) :: q2m ! water vapour at 2 meter height + REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q ! water vapour flux(latent flux) (kg/m**2/s) + + +! Local variables with attribute SAVE +!**************************************************************************************** + INTEGER, SAVE :: nhoridbg, nidbg ! variables for IOIPSL +!$OMP THREADPRIVATE(nhoridbg, nidbg) + LOGICAL, SAVE :: debugindex=.FALSE. +!$OMP THREADPRIVATE(debugindex) + LOGICAL, SAVE :: first_call=.TRUE. +!$OMP THREADPRIVATE(first_call) + CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf +!$OMP THREADPRIVATE(cl_surf) + +! Other local variables +!**************************************************************************************** + INTEGER :: i, k, nsrf + INTEGER :: knon, j + INTEGER :: idayref + INTEGER , DIMENSION(klon) :: ni + REAL :: zx_alf1, zx_alf2 !valeur ambiante par extrapola + REAL :: amn, amx + REAL :: f1 ! fraction de longeurs visibles parmi tout SW intervalle + REAL, DIMENSION(klon) :: r_co2_ppm ! taux CO2 atmosphere + REAL, DIMENSION(klon) :: yts, yrugos, ypct, yz0_new + REAL, DIMENSION(klon) :: yalb, yalb1, yalb2 + REAL, DIMENSION(klon) :: yu1, yv1 + REAL, DIMENSION(klon) :: ysnow, yqsurf, yagesno, yqsol + REAL, DIMENSION(klon) :: yrain_f, ysnow_f + REAL, DIMENSION(klon) :: ysolsw, ysollw + REAL, DIMENSION(klon) :: yfder + REAL, DIMENSION(klon) :: yrugoro + REAL, DIMENSION(klon) :: yfluxlat + REAL, DIMENSION(klon) :: y_d_ts + REAL, DIMENSION(klon) :: y_flux_t1, y_flux_q1 + REAL, DIMENSION(klon) :: y_dflux_t, y_dflux_q + REAL, DIMENSION(klon) :: y_flux_u1, y_flux_v1 + REAL, DIMENSION(klon) :: yt2m, yq2m, yu10m + REAL, DIMENSION(klon) :: yustar + REAL, DIMENSION(klon) :: ywindsp + REAL, DIMENSION(klon) :: yt10m, yq10m + REAL, DIMENSION(klon) :: ypblh + REAL, DIMENSION(klon) :: ylcl + REAL, DIMENSION(klon) :: ycapCL + REAL, DIMENSION(klon) :: yoliqCL + REAL, DIMENSION(klon) :: ycteiCL + REAL, DIMENSION(klon) :: ypblT + REAL, DIMENSION(klon) :: ytherm + REAL, DIMENSION(klon) :: ytrmb1 + REAL, DIMENSION(klon) :: ytrmb2 + REAL, DIMENSION(klon) :: ytrmb3 + REAL, DIMENSION(klon) :: uzon, vmer + REAL, DIMENSION(klon) :: tair1, qair1, tairsol + REAL, DIMENSION(klon) :: psfce, patm + REAL, DIMENSION(klon) :: qairsol, zgeo1 + REAL, DIMENSION(klon) :: rugo1 + REAL, DIMENSION(klon) :: yfluxsens + REAL, DIMENSION(klon) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon) :: ypsref + REAL, DIMENSION(klon) :: yevap, ytsurf_new, yalb1_new, yalb2_new + REAL, DIMENSION(klon) :: ztsol + REAL, DIMENSION(klon) :: alb_m ! mean albedo for whole SW interval + REAL, DIMENSION(klon,klev) :: y_d_t, y_d_q + REAL, DIMENSION(klon,klev) :: y_d_u, y_d_v + REAL, DIMENSION(klon,klev) :: y_flux_t, y_flux_q + REAL, DIMENSION(klon,klev) :: y_flux_u, y_flux_v + REAL, DIMENSION(klon,klev) :: ycoefh, ycoefm + REAL, DIMENSION(klon) :: ycdragh, ycdragm + REAL, DIMENSION(klon,klev) :: yu, yv + REAL, DIMENSION(klon,klev) :: yt, yq + REAL, DIMENSION(klon,klev) :: ypplay, ydelp + REAL, DIMENSION(klon,klev) :: delp + REAL, DIMENSION(klon,klev+1) :: ypaprs + REAL, DIMENSION(klon,klev+1) :: ytke + REAL, DIMENSION(klon,nsoilmx) :: ytsoil + CHARACTER(len=80) :: abort_message + CHARACTER(len=20) :: modname = 'pbl_surface' + LOGICAL, PARAMETER :: zxli=.FALSE. ! utiliser un jeu de fonctions simples + LOGICAL, PARAMETER :: check=.FALSE. + +! For debugging with IOIPSL + INTEGER, DIMENSION(iim*(jjm+1)) :: ndexbg + REAL :: zjulian + REAL, DIMENSION(klon) :: tabindx + REAL, DIMENSION(iim,jjm+1) :: zx_lon, zx_lat + REAL, DIMENSION(iim,jjm+1) :: debugtab + + + REAL, DIMENSION(klon,nbsrf) :: pblh ! height of the planetary boundary layer + REAL, DIMENSION(klon,nbsrf) :: plcl ! condensation level + REAL, DIMENSION(klon,nbsrf) :: capCL + REAL, DIMENSION(klon,nbsrf) :: oliqCL + REAL, DIMENSION(klon,nbsrf) :: cteiCL + REAL, DIMENSION(klon,nbsrf) :: pblT + REAL, DIMENSION(klon,nbsrf) :: therm + REAL, DIMENSION(klon,nbsrf) :: trmb1 ! deep cape + REAL, DIMENSION(klon,nbsrf) :: trmb2 ! inhibition + REAL, DIMENSION(klon,nbsrf) :: trmb3 ! point Omega + REAL, DIMENSION(klon,nbsrf) :: zx_rh2m, zx_qsat2m + REAL, DIMENSION(klon,nbsrf) :: zx_t1 + REAL, DIMENSION(klon, nbsrf) :: alb ! mean albedo for whole SW interval + REAL, DIMENSION(klon) :: ylwdown ! jg : temporary (ysollwdown) + + REAL :: zx_qs1, zcor1, zdelta1 + +!**************************************************************************************** +! Declarations specifiques pour le 1D. A reprendre + REAL :: fsens,flat + LOGICAL :: ok_flux_surf ! initialized during first_call below + COMMON /flux_arp/fsens,flat,ok_flux_surf +!**************************************************************************************** +! End of declarations +!**************************************************************************************** + + +!**************************************************************************************** +! 1) Initialisation and validation tests +! Only done first time entering this subroutine +! +!**************************************************************************************** + + IF (first_call) THEN + first_call=.FALSE. + + ! Initialize ok_flux_surf (for 1D model) + if (klon>1) ok_flux_surf=.FALSE. + + ! Initilize debug IO + IF (debugindex .AND. mpi_size==1) THEN + ! initialize IOIPSL output + idayref = day_ini + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon) + DO i = 1, iim + zx_lon(i,1) = rlon(i+1) + zx_lon(i,jjm+1) = rlon(i+1) + ENDDO + CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat) + CALL histbeg("sous_index", iim,zx_lon(:,1),jjm+1,zx_lat(1,:), & + 1,iim,1,jjm+1, & + itau_phy,zjulian,dtime,nhoridbg,nidbg) + ! no vertical axis + cl_surf(1)='ter' + cl_surf(2)='lic' + cl_surf(3)='oce' + cl_surf(4)='sic' + DO nsrf=1,nbsrf + CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim, & + jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) + END DO + + CALL histend(nidbg) + CALL histsync(nidbg) + + END IF + + ENDIF + +!**************************************************************************************** +! Force soil water content to qsol0 if qsol0>0 and VEGET=F (use bucket +! instead of ORCHIDEE) + IF (qsol0>0.) THEN + PRINT*,'WARNING : On impose qsol=',qsol0 + qsol(:)=qsol0 + ENDIF +!**************************************************************************************** + +!**************************************************************************************** +! 2) Initialization to zero +! Done for all local variables that will be compressed later +! and argument with INTENT(OUT) +!**************************************************************************************** + cdragh = 0.0 ; cdragm = 0.0 ; dflux_t = 0.0 ; dflux_q = 0.0 + ypct = 0.0 ; yts = 0.0 ; ysnow = 0.0 + zv1 = 0.0 ; yqsurf = 0.0 ; yalb1 = 0.0 ; yalb2 = 0.0 + yrain_f = 0.0 ; ysnow_f = 0.0 ; yfder = 0.0 ; ysolsw = 0.0 + ysollw = 0.0 ; yrugos = 0.0 ; yu1 = 0.0 + yv1 = 0.0 ; ypaprs = 0.0 ; ypplay = 0.0 + ydelp = 0.0 ; yu = 0.0 ; yv = 0.0 ; yt = 0.0 + yq = 0.0 ; y_dflux_t = 0.0 ; y_dflux_q = 0.0 + yrugoro = 0.0 ; ywindsp = 0.0 + d_ts = 0.0 ; yfluxlat=0.0 ; flux_t = 0.0 ; flux_q = 0.0 + flux_u = 0.0 ; flux_v = 0.0 ; d_t = 0.0 ; d_q = 0.0 + d_u = 0.0 ; d_v = 0.0 ; yqsol = 0.0 + ytherm = 0.0 ; ytke=0. + + zcoefh(:,:) = 0.0 + zcoefh(:,1) = 999999. ! zcoefh(:,k=1) should never be used + zcoefm(:,:) = 0.0 + zcoefm(:,1) = 999999. ! + ytsoil = 999999. + + rh2m(:) = 0. + qsat2m(:) = 0. +!**************************************************************************************** +! 3) - Calculate pressure thickness of each layer +! - Calculate the wind at first layer +! - Mean calculations of albedo +! - Calculate net radiance at sub-surface +!**************************************************************************************** + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + ENDDO + ENDDO + +!**************************************************************************************** +! Test for rugos........ from physiq.. A la fin plutot??? +! +!**************************************************************************************** + + zxrugs(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + rugos(i,nsrf) = MAX(rugos(i,nsrf),0.000015) + zxrugs(i) = zxrugs(i) + rugos(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO + +! Mean calculations of albedo +! +! Albedo at sub-surface +! * alb1 : albedo in visible SW interval +! * alb2 : albedo in near infrared SW interval +! * alb : mean albedo for whole SW interval +! +! Mean albedo for grid point +! * alb1_m : albedo in visible SW interval +! * alb2_m : albedo in near infrared SW interval +! * alb_m : mean albedo at whole SW interval + + alb1_m(:) = 0.0 + alb2_m(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + alb1_m(i) = alb1_m(i) + alb1(i,nsrf) * pctsrf(i,nsrf) + alb2_m(i) = alb2_m(i) + alb2(i,nsrf) * pctsrf(i,nsrf) + ENDDO + ENDDO + +! We here suppose the fraction f1 of incoming radiance of visible radiance +! as a fraction of all shortwave radiance + f1 = 0.5 +! f1 = 1 ! put f1=1 to recreate old calculations + + DO nsrf = 1, nbsrf + DO i = 1, klon + alb(i,nsrf) = f1*alb1(i,nsrf) + (1-f1)*alb2(i,nsrf) + ENDDO + ENDDO + + DO i = 1, klon + alb_m(i) = f1*alb1_m(i) + (1-f1)*alb2_m(i) + END DO + +! Calculation of mean temperature at surface grid points + ztsol(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO + +! Linear distrubution on sub-surface of long- and shortwave net radiance + DO nsrf = 1, nbsrf + DO i = 1, klon + sollw(i,nsrf) = sollw_m(i) + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ts(i,nsrf)) + solsw(i,nsrf) = solsw_m(i) * (1.-alb(i,nsrf)) / (1.-alb_m(i)) + ENDDO + ENDDO + + +! Downwelling longwave radiation at mean surface + lwdown_m(:) = 0.0 + DO i = 1, klon + lwdown_m(i) = sollw_m(i) + RSIGMA*ztsol(i)**4 + ENDDO + +!**************************************************************************************** +! 4) Loop over different surfaces +! +! Only points containing a fraction of the sub surface will be threated. +! +!**************************************************************************************** + + loop_nbsrf: DO nsrf = 1, nbsrf + +! Search for index(ni) and size(knon) of domaine to treat + ni(:) = 0 + knon = 0 + DO i = 1, klon + IF (pctsrf(i,nsrf) > 0.) THEN + knon = knon + 1 + ni(knon) = i + ENDIF + ENDDO + + ! write index, with IOIPSL + IF (debugindex .AND. mpi_size==1) THEN + tabindx(:)=0. + DO i=1,knon + tabindx(i)=REAL(i) + END DO + debugtab(:,:) = 0. + ndexbg(:) = 0 + CALL gath2cpl(tabindx,debugtab,knon,ni) + CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1), ndexbg) + ENDIF + +!**************************************************************************************** +! 5) Compress variables +! +!**************************************************************************************** + + DO j = 1, knon + i = ni(j) + ypct(j) = pctsrf(i,nsrf) + yts(j) = ts(i,nsrf) + ysnow(j) = snow(i,nsrf) + yqsurf(j) = qsurf(i,nsrf) + yalb(j) = alb(i,nsrf) + yalb1(j) = alb1(i,nsrf) + yalb2(j) = alb2(i,nsrf) + yrain_f(j) = rain_f(i) + ysnow_f(j) = snow_f(i) + yagesno(j) = agesno(i,nsrf) + yfder(j) = fder(i) + ysolsw(j) = solsw(i,nsrf) + ysollw(j) = sollw(i,nsrf) + yrugos(j) = rugos(i,nsrf) + yrugoro(j) = rugoro(i) + yu1(j) = u(i,1) + yv1(j) = v(i,1) + ypaprs(j,klev+1) = paprs(i,klev+1) + ywindsp(j) = SQRT(u10m(i,nsrf)**2 + v10m(i,nsrf)**2 ) + END DO + + DO k = 1, klev + DO j = 1, knon + i = ni(j) + ypaprs(j,k) = paprs(i,k) + ypplay(j,k) = pplay(i,k) + ydelp(j,k) = delp(i,k) + ytke(j,k) = tke(i,k,nsrf) + yu(j,k) = u(i,k) + yv(j,k) = v(i,k) + yt(j,k) = t(i,k) + yq(j,k) = q(i,k) + ENDDO + ENDDO + + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ytsoil(j,k) = ftsoil(i,k,nsrf) + END DO + END DO + + ! qsol(water height in soil) only for bucket continental model + IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN + DO j = 1, knon + i = ni(j) + yqsol(j) = qsol(i) + END DO + ENDIF + +!**************************************************************************************** +! 6a) Calculate coefficients for turbulent diffusion at surface, cdragh et cdragm. +! +!**************************************************************************************** + + CALL clcdrag( knon, nsrf, ypaprs, ypplay, & + yu(:,1), yv(:,1), yt(:,1), yq(:,1), & + yts, yqsurf, yrugos, & + ycdragm, ycdragh ) + +!**************************************************************************************** +! 6b) Calculate coefficients for turbulent diffusion in the atmosphere, ycoefm et ycoefm. +! +!**************************************************************************************** + + CALL coef_diff_turb(dtime, nsrf, knon, ni, & + ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, & + ycoefm, ycoefh, ytke) + +!**************************************************************************************** +! +! 8) "La descente" - "The downhill" +! +! climb_hq_down and climb_wind_down calculate the coefficients +! Ccoef_X et Dcoef_X for X=[H, Q, U, V]. +! Only the coefficients at surface for H and Q are returned. +! +!**************************************************************************************** + +! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q + CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, & + ydelp, yt, yq, dtime, & + AcoefH, AcoefQ, BcoefH, BcoefQ) + +! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V + CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv, & + AcoefU, AcoefV, BcoefU, BcoefV) + + +!**************************************************************************************** +! 9) Small calculations +! +!**************************************************************************************** + +! - Reference pressure is given the values at surface level + ypsref(:) = ypaprs(:,1) + +! - CO2 field on 2D grid to be sent to ORCHIDEE +! Transform to compressed field + IF (carbon_cycle_cpl) THEN + DO i=1,knon + r_co2_ppm(i) = co2_send(ni(i)) + END DO + ELSE + r_co2_ppm(:) = co2_ppm ! Constant field + END IF + +!**************************************************************************************** +! +! Calulate t2m and q2m for the case of calculation at land grid points +! t2m and q2m are needed as input to ORCHIDEE +! +!**************************************************************************************** + IF (nsrf == is_ter) THEN + + DO i = 1, knon + zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) & + * (ypaprs(i,1)-ypplay(i,1)) + END DO + + ! Calculate the temperature et relative humidity at 2m and the wind at 10m + CALL stdlevvar(klon, knon, is_ter, zxli, & + yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, & + yts, yqsurf, yrugos, ypaprs(:,1), ypplay(:,1), & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar) + + END IF + +!**************************************************************************************** +! +! 10) Switch selon current surface +! It is necessary to start with the continental surfaces because the ocean +! needs their run-off. +! +!**************************************************************************************** + SELECT CASE(nsrf) + + CASE(is_ter) + ! ylwdown : to be removed, calculation is now done at land surface in surf_land + ylwdown(:)=0.0 + DO i=1,knon + ylwdown(i)=lwdown_m(ni(i)) + END DO + CALL surf_land(itap, dtime, date0, jour, knon, ni,& + rlon, rlat, & + debut, lafin, ydelp(:,1), r_co2_ppm, ysolsw, ysollw, yalb, & + yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ylwdown, yq2m, yt2m, & + ysnow, yqsol, yagesno, ytsoil, & + yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, & + y_flux_u1, y_flux_v1 ) + + + CASE(is_lic) + CALL surf_landice(itap, dtime, knon, ni, & + ysolsw, ysollw, yts, ypplay(:,1), & + ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ysnow, yqsurf, yqsol, yagesno, & + ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + ytsurf_new, y_dflux_t, y_dflux_q, & + y_flux_u1, y_flux_v1) + + CASE(is_oce) + CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, & + yrugos, ywindsp, rmu0, yfder, yts, & + itap, dtime, jour, knon, ni, & + ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ysnow, yqsurf, yagesno, & + yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, & + y_flux_u1, y_flux_v1) + + CASE(is_sic) + CALL surf_seaice( & + rlon, rlat, ysolsw, ysollw, yalb1, yfder, & + itap, dtime, jour, knon, ni, & + lafin, & + yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ypsref, yu1, yv1, yrugoro, pctsrf, & + ysnow, yqsurf, yqsol, yagesno, ytsoil, & + yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, & + ytsurf_new, y_dflux_t, y_dflux_q, & + y_flux_u1, y_flux_v1) + + + CASE DEFAULT + WRITE(lunout,*) 'Surface index = ', nsrf + abort_message = 'Surface index not valid' + CALL abort_gcm(modname,abort_message,1) + END SELECT + + +!**************************************************************************************** +! 11) - Calcul the increment of surface temperature +! +!**************************************************************************************** + y_d_ts(1:knon) = ytsurf_new(1:knon) - yts(1:knon) + +!**************************************************************************************** +! +! 12) "La remontee" - "The uphill" +! +! The fluxes (y_flux_X) and tendancy (y_d_X) are calculated +! for X=H, Q, U and V, for all vertical levels. +! +!**************************************************************************************** +! H and Q + IF (ok_flux_surf) THEN + PRINT *,'pbl_surface: fsens flat RLVTT=',fsens,flat,RLVTT + y_flux_t1(:) = fsens + y_flux_q1(:) = flat/RLVTT + yfluxlat(:) = flat + ELSE + y_flux_t1(:) = yfluxsens(:) + y_flux_q1(:) = -yevap(:) + ENDIF + + CALL climb_hq_up(knon, dtime, yt, yq, & + y_flux_q1, y_flux_t1, ypaprs, ypplay, & + y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:)) + + + CALL climb_wind_up(knon, dtime, yu, yv, y_flux_u1, y_flux_v1, & + y_flux_u, y_flux_v, y_d_u, y_d_v) + + + DO j = 1, knon + y_dflux_t(j) = y_dflux_t(j) * ypct(j) + y_dflux_q(j) = y_dflux_q(j) * ypct(j) + ENDDO + +!**************************************************************************************** +! 13) Transform variables for output format : +! - Decompress +! - Multiply with pourcentage of current surface +! - Cumulate in global variable +! +!**************************************************************************************** + + tke(:,:,nsrf) = 0. + DO k = 1, klev + DO j = 1, knon + i = ni(j) + y_d_t(j,k) = y_d_t(j,k) * ypct(j) + y_d_q(j,k) = y_d_q(j,k) * ypct(j) + y_d_u(j,k) = y_d_u(j,k) * ypct(j) + y_d_v(j,k) = y_d_v(j,k) * ypct(j) + + flux_t(i,k,nsrf) = y_flux_t(j,k) + flux_q(i,k,nsrf) = y_flux_q(j,k) + flux_u(i,k,nsrf) = y_flux_u(j,k) + flux_v(i,k,nsrf) = y_flux_v(j,k) + + tke(i,k,nsrf) = ytke(j,k) + + ENDDO + ENDDO + + evap(:,nsrf) = - flux_q(:,1,nsrf) + + alb1(:, nsrf) = 0. + alb2(:, nsrf) = 0. + snow(:, nsrf) = 0. + qsurf(:, nsrf) = 0. + rugos(:, nsrf) = 0. + fluxlat(:,nsrf) = 0. + DO j = 1, knon + i = ni(j) + d_ts(i,nsrf) = y_d_ts(j) + alb1(i,nsrf) = yalb1_new(j) + alb2(i,nsrf) = yalb2_new(j) + snow(i,nsrf) = ysnow(j) + qsurf(i,nsrf) = yqsurf(j) + rugos(i,nsrf) = yz0_new(j) + fluxlat(i,nsrf) = yfluxlat(j) + agesno(i,nsrf) = yagesno(j) + cdragh(i) = cdragh(i) + ycdragh(j)*ypct(j) + cdragm(i) = cdragm(i) + ycdragm(j)*ypct(j) + dflux_t(i) = dflux_t(i) + y_dflux_t(j) + dflux_q(i) = dflux_q(i) + y_dflux_q(j) + END DO + + DO k = 2, klev + DO j = 1, knon + i = ni(j) + zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)*ypct(j) + zcoefm(i,k) = zcoefm(i,k) + ycoefm(j,k)*ypct(j) + END DO + END DO + + IF ( nsrf .EQ. is_ter ) THEN + DO j = 1, knon + i = ni(j) + qsol(i) = yqsol(j) + END DO + END IF + + ftsoil(:,:,nsrf) = 0. + DO k = 1, nsoilmx + DO j = 1, knon + i = ni(j) + ftsoil(i, k, nsrf) = ytsoil(j,k) + END DO + END DO + + + DO k = 1, klev + DO j = 1, knon + i = ni(j) + d_t(i,k) = d_t(i,k) + y_d_t(j,k) + d_q(i,k) = d_q(i,k) + y_d_q(j,k) + d_u(i,k) = d_u(i,k) + y_d_u(j,k) + d_v(i,k) = d_v(i,k) + y_d_v(j,k) + END DO + END DO + +!**************************************************************************************** +! 14) Calculate the temperature et relative humidity at 2m and the wind at 10m +! Call HBTM +! +!**************************************************************************************** + t2m(:,nsrf) = 0. + q2m(:,nsrf) = 0. + u10m(:,nsrf) = 0. + v10m(:,nsrf) = 0. + + pblh(:,nsrf) = 0. ! Hauteur de couche limite + plcl(:,nsrf) = 0. ! Niveau de condensation de la CLA + capCL(:,nsrf) = 0. ! CAPE de couche limite + oliqCL(:,nsrf) = 0. ! eau_liqu integree de couche limite + cteiCL(:,nsrf) = 0. ! cloud top instab. crit. couche limite + pblt(:,nsrf) = 0. ! T a la Hauteur de couche limite + therm(:,nsrf) = 0. + trmb1(:,nsrf) = 0. ! deep_cape + trmb2(:,nsrf) = 0. ! inhibition + trmb3(:,nsrf) = 0. ! Point Omega + +#undef T2m +#define T2m +#ifdef T2m +! Calculations of diagnostic t,q at 2m and u, v at 10m + + DO j=1, knon + i = ni(j) + uzon(j) = yu(j,1) + y_d_u(j,1) + vmer(j) = yv(j,1) + y_d_v(j,1) + tair1(j) = yt(j,1) + y_d_t(j,1) + qair1(j) = yq(j,1) + y_d_q(j,1) + zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) & + * (ypaprs(j,1)-ypplay(j,1)) + tairsol(j) = yts(j) + y_d_ts(j) + rugo1(j) = yrugos(j) + IF(nsrf.EQ.is_oce) THEN + rugo1(j) = rugos(i,nsrf) + ENDIF + psfce(j)=ypaprs(j,1) + patm(j)=ypplay(j,1) + qairsol(j) = yqsurf(j) + END DO + + +! Calculate the temperature et relative humidity at 2m and the wind at 10m + CALL stdlevvar(klon, knon, nsrf, zxli, & + uzon, vmer, tair1, qair1, zgeo1, & + tairsol, qairsol, rugo1, psfce, patm, & + yt2m, yq2m, yt10m, yq10m, yu10m, yustar) + + DO j=1, knon + i = ni(j) + t2m(i,nsrf)=yt2m(j) + q2m(i,nsrf)=yq2m(j) + + ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman + u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2) + v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2) + END DO + +!IM Calcule de l'humidite relative a 2m (rh2m) pour diagnostique +!IM Ajoute dependance type surface + IF (thermcep) THEN + DO j = 1, knon + i=ni(j) + zdelta1 = MAX(0.,SIGN(1., rtt-yt2m(j) )) + zx_qs1 = r2es * FOEEW(yt2m(j),zdelta1)/paprs(i,1) + zx_qs1 = MIN(0.5,zx_qs1) + zcor1 = 1./(1.-RETV*zx_qs1) + zx_qs1 = zx_qs1*zcor1 + + rh2m(i) = rh2m(i) + yq2m(j)/zx_qs1 * pctsrf(i,nsrf) + qsat2m(i) = qsat2m(i) + zx_qs1 * pctsrf(i,nsrf) + END DO + END IF + + CALL HBTM(knon, ypaprs, ypplay, & + yt2m,yt10m,yq2m,yq10m,yustar, & + y_flux_t,y_flux_q,yu,yv,yt,yq, & + ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, & + ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl) + + DO j=1, knon + i = ni(j) + pblh(i,nsrf) = ypblh(j) + plcl(i,nsrf) = ylcl(j) + capCL(i,nsrf) = ycapCL(j) + oliqCL(i,nsrf) = yoliqCL(j) + cteiCL(i,nsrf) = ycteiCL(j) + pblT(i,nsrf) = ypblT(j) + therm(i,nsrf) = ytherm(j) + trmb1(i,nsrf) = ytrmb1(j) + trmb2(i,nsrf) = ytrmb2(j) + trmb3(i,nsrf) = ytrmb3(j) + END DO + +#else +! T2m not defined +! No calculation + PRINT*,' Warning !!! No T2m calculation. Output is set to zero.' +#endif + +!**************************************************************************************** +! 15) End of loop over different surfaces +! +!**************************************************************************************** + END DO loop_nbsrf + +!**************************************************************************************** +! 16) Calculate the mean value over all sub-surfaces for som variables +! +!**************************************************************************************** + + zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0 + zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0 + DO nsrf = 1, nbsrf + DO k = 1, klev + DO i = 1, klon + zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf(i,nsrf) + zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf(i,nsrf) + END DO + END DO + END DO + + DO i = 1, klon + zxsens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol + zxevap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol + fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i) + ENDDO + +! +! Incrementer la temperature du sol +! + zxtsol(:) = 0.0 ; zxfluxlat(:) = 0.0 + zt2m(:) = 0.0 ; zq2m(:) = 0.0 + zu10m(:) = 0.0 ; zv10m(:) = 0.0 + s_pblh(:) = 0.0 ; s_plcl(:) = 0.0 + s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0 + s_cteiCL(:) = 0.0; s_pblT(:) = 0.0 + s_therm(:) = 0.0 ; s_trmb1(:) = 0.0 + s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0 + + + DO nsrf = 1, nbsrf + DO i = 1, klon + ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf) + + wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) & + + flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf(i,nsrf) + wfbilo(i,nsrf) = (evap(i,nsrf) - (rain_f(i) + snow_f(i))) * & + pctsrf(i,nsrf) + + zxtsol(i) = zxtsol(i) + ts(i,nsrf) * pctsrf(i,nsrf) + zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf(i,nsrf) + + zt2m(i) = zt2m(i) + t2m(i,nsrf) * pctsrf(i,nsrf) + zq2m(i) = zq2m(i) + q2m(i,nsrf) * pctsrf(i,nsrf) + zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf(i,nsrf) + zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf(i,nsrf) + + s_pblh(i) = s_pblh(i) + pblh(i,nsrf) * pctsrf(i,nsrf) + s_plcl(i) = s_plcl(i) + plcl(i,nsrf) * pctsrf(i,nsrf) + s_capCL(i) = s_capCL(i) + capCL(i,nsrf) * pctsrf(i,nsrf) + s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf(i,nsrf) + s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf(i,nsrf) + s_pblT(i) = s_pblT(i) + pblT(i,nsrf) * pctsrf(i,nsrf) + s_therm(i) = s_therm(i) + therm(i,nsrf) * pctsrf(i,nsrf) + s_trmb1(i) = s_trmb1(i) + trmb1(i,nsrf) * pctsrf(i,nsrf) + s_trmb2(i) = s_trmb2(i) + trmb2(i,nsrf) * pctsrf(i,nsrf) + s_trmb3(i) = s_trmb3(i) + trmb3(i,nsrf) * pctsrf(i,nsrf) + END DO + END DO + + IF (check) THEN + amn=MIN(ts(1,is_ter),1000.) + amx=MAX(ts(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ts(i,is_ter),amn) + amx=MAX(ts(i,is_ter),amx) + ENDDO + PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx + ENDIF + +!jg ? +!!$! +!!$! If a sub-surface does not exsist for a grid point, the mean value for all +!!$! sub-surfaces is distributed. +!!$! +!!$ DO nsrf = 1, nbsrf +!!$ DO i = 1, klon +!!$ IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN +!!$ ts(i,nsrf) = zxtsol(i) +!!$ t2m(i,nsrf) = zt2m(i) +!!$ q2m(i,nsrf) = zq2m(i) +!!$ u10m(i,nsrf) = zu10m(i) +!!$ v10m(i,nsrf) = zv10m(i) +!!$ +!!$! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour +!!$ pblh(i,nsrf) = s_pblh(i) +!!$ plcl(i,nsrf) = s_plcl(i) +!!$ capCL(i,nsrf) = s_capCL(i) +!!$ oliqCL(i,nsrf) = s_oliqCL(i) +!!$ cteiCL(i,nsrf) = s_cteiCL(i) +!!$ pblT(i,nsrf) = s_pblT(i) +!!$ therm(i,nsrf) = s_therm(i) +!!$ trmb1(i,nsrf) = s_trmb1(i) +!!$ trmb2(i,nsrf) = s_trmb2(i) +!!$ trmb3(i,nsrf) = s_trmb3(i) +!!$ ENDIF +!!$ ENDDO +!!$ ENDDO + + + DO i = 1, klon + fder(i) = - 4.0*RSIGMA*zxtsol(i)**3 + ENDDO + + zxqsurf(:) = 0.0 + zxsnow(:) = 0.0 + DO nsrf = 1, nbsrf + DO i = 1, klon + zxqsurf(i) = zxqsurf(i) + qsurf(i,nsrf) * pctsrf(i,nsrf) + zxsnow(i) = zxsnow(i) + snow(i,nsrf) * pctsrf(i,nsrf) + END DO + END DO + +! Premier niveau de vent sortie dans physiq.F + zu1(:) = u(:,1) + zv1(:) = v(:,1) + +! Some of the module declared variables are returned for printing in physiq.F + qsol_d(:) = qsol(:) + evap_d(:,:) = evap(:,:) + rugos_d(:,:) = rugos(:,:) + agesno_d(:,:) = agesno(:,:) + + + END SUBROUTINE pbl_surface +! +!**************************************************************************************** +! + SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, & + evap_rst, rugos_rst, agesno_rst, ftsoil_rst) + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + +! Ouput variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsol_rst + REAL, DIMENSION(klon), INTENT(OUT) :: fder_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: snow_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: qsurf_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: evap_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: rugos_rst + REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: agesno_rst + REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst + + +!**************************************************************************************** +! Return module variables for writing to restart file +! +!**************************************************************************************** + qsol_rst(:) = qsol(:) + fder_rst(:) = fder(:) + snow_rst(:,:) = snow(:,:) + qsurf_rst(:,:) = qsurf(:,:) + evap_rst(:,:) = evap(:,:) + rugos_rst(:,:) = rugos(:,:) + agesno_rst(:,:) = agesno(:,:) + ftsoil_rst(:,:,:) = ftsoil(:,:,:) + +!**************************************************************************************** +! Deallocate module variables +! +!**************************************************************************************** +! DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil) + IF (ALLOCATED(qsol)) DEALLOCATE(qsol) + IF (ALLOCATED(fder)) DEALLOCATE(fder) + IF (ALLOCATED(snow)) DEALLOCATE(snow) + IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf) + IF (ALLOCATED(evap)) DEALLOCATE(evap) + IF (ALLOCATED(rugos)) DEALLOCATE(rugos) + IF (ALLOCATED(agesno)) DEALLOCATE(agesno) + IF (ALLOCATED(ftsoil)) DEALLOCATE(ftsoil) + + END SUBROUTINE pbl_surface_final +! +!**************************************************************************************** +! + SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf, alb1, alb2, u10m, v10m, tke) + + ! Give default values where new fraction has appread + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "clesphys.h" + INCLUDE "compbl.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf_new, pctsrf_old + +! InOutput variables +!**************************************************************************************** + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb1, alb2 + REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m, v10m + REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: tke + +! Local variables +!**************************************************************************************** + INTEGER :: nsrf, nsrf_comp1, nsrf_comp2, nsrf_comp3, i + CHARACTER(len=80) :: abort_message + CHARACTER(len=20) :: modname = 'pbl_surface_newfrac' + INTEGER, DIMENSION(nbsrf) :: nfois=0, mfois=0, pfois=0 +! +! All at once !! +!**************************************************************************************** + + DO nsrf = 1, nbsrf + ! First decide complement sub-surfaces + SELECT CASE (nsrf) + CASE(is_oce) + nsrf_comp1=is_sic + nsrf_comp2=is_ter + nsrf_comp3=is_lic + CASE(is_sic) + nsrf_comp1=is_oce + nsrf_comp2=is_ter + nsrf_comp3=is_lic + CASE(is_ter) + nsrf_comp1=is_lic + nsrf_comp2=is_oce + nsrf_comp3=is_sic + CASE(is_lic) + nsrf_comp1=is_ter + nsrf_comp2=is_oce + nsrf_comp3=is_sic + END SELECT + + ! Initialize all new fractions + DO i=1, klon + IF (pctsrf_new(i,nsrf) > 0. .AND. pctsrf_old(i,nsrf) == 0.) THEN + + IF (pctsrf_old(i,nsrf_comp1) > 0.) THEN + ! Use the complement sub-surface, keeping the continents unchanged + qsurf(i,nsrf) = qsurf(i,nsrf_comp1) + evap(i,nsrf) = evap(i,nsrf_comp1) + rugos(i,nsrf) = rugos(i,nsrf_comp1) + tsurf(i,nsrf) = tsurf(i,nsrf_comp1) + alb1(i,nsrf) = alb1(i,nsrf_comp1) + alb2(i,nsrf) = alb2(i,nsrf_comp1) + u10m(i,nsrf) = u10m(i,nsrf_comp1) + v10m(i,nsrf) = v10m(i,nsrf_comp1) + if (iflag_pbl > 1) then + tke(i,:,nsrf) = tke(i,:,nsrf_comp1) + endif + mfois(nsrf) = mfois(nsrf) + 1 + ELSE + ! The continents have changed. The new fraction receives the mean sum of the existent fractions + qsurf(i,nsrf) = qsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + qsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + evap(i,nsrf) = evap(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + evap(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + rugos(i,nsrf) = rugos(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + rugos(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + tsurf(i,nsrf) = tsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + alb1(i,nsrf) = alb1(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb1(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + alb2(i,nsrf) = alb2(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb2(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + u10m(i,nsrf) = u10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + u10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + v10m(i,nsrf) = v10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + v10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3) + if (iflag_pbl > 1) then + tke(i,:,nsrf) = tke(i,:,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tke(i,:,nsrf_comp3)*pctsrf_old(i,nsrf_comp3) + endif + + ! Security abort. This option has never been tested. To test, comment the following line. +! abort_message='The fraction of the continents have changed!' +! CALL abort_gcm(modname,abort_message,1) + nfois(nsrf) = nfois(nsrf) + 1 + END IF + snow(i,nsrf) = 0. + agesno(i,nsrf) = 0. + ftsoil(i,:,nsrf) = tsurf(i,nsrf) + ELSE + pfois(nsrf) = pfois(nsrf)+ 1 + END IF + END DO + + END DO + + END SUBROUTINE pbl_surface_newfrac + +! +!**************************************************************************************** +! + +END MODULE pbl_surface_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyaqua.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyaqua.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyaqua.F (revision 1634) @@ -0,0 +1,774 @@ +! Routines complementaires pour la physique planetaire. + + + subroutine iniaqua(nlon,latfi,lonfi,iflag_phys) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Creation d'un etat initial et de conditions aux limites +! (resp startphy.nc et limit.nc) pour des configurations idealisees +! du modele LMDZ dans sa version terrestre. +! iflag_phys est un parametre qui controle +! iflag_phys = N +! de 100 a 199 : aqua planetes avec SST forcees +! N-100 determine le type de SSTs +! de 200 a 299 : terra planetes avec Ts calcule +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use comgeomphy + use dimphy + use surface_data, only : type_ocean,ok_veget + use pbl_surface_mod, only : pbl_surface_init + USE fonte_neige_mod, only : fonte_neige_init + use phys_state_var_mod + use control_mod + + + USE IOIPSL + IMPLICIT NONE + +#include "dimensions.h" +! #include "dimphy.h" +! #include "YOMCST.h" +#include "comconst.h" +#include "clesphys.h" +#include "dimsoil.h" +#include "indicesol.h" + + integer nlon,iflag_phys +cIM ajout latfi, lonfi + REAL, DIMENSION (nlon) :: lonfi, latfi + INTEGER type_profil,type_aqua + +c Ajouts initialisation des surfaces + REAL :: run_off_lic_0(nlon) + REAL :: qsolsrf(nlon,nbsrf),snsrf(nlon,nbsrf) + REAL :: frugs(nlon,nbsrf) + REAL :: agesno(nlon,nbsrf) + REAL :: tsoil(nlon,nsoilmx,nbsrf) + REAL :: tslab(nlon), seaice(nlon) + REAL evap(nlon,nbsrf),fder(nlon) + + + +c Arguments : +c ----------- + +! integer radpas + integer it,unit,i,k,itap + + real airefi,zcufi,zcvfi + + real rugos,albedo + REAL tsurf + REAL time,timestep,day,day0 + real qsol_f,qsol(nlon) + real rugsrel(nlon) +! real zmea(nlon),zstd(nlon),zsig(nlon) +! real zgam(nlon),zthe(nlon),zpic(nlon),zval(nlon) +! real rlon(nlon),rlat(nlon) + logical alb_ocean +! integer demih_pas + + integer day_ini + + CHARACTER*80 ans,file_forctl, file_fordat, file_start + character*100 file,var + character*2 cnbl + + REAL phy_nat(nlon,360) + REAL phy_alb(nlon,360) + REAL phy_sst(nlon,360) + REAL phy_bil(nlon,360) + REAL phy_rug(nlon,360) + REAL phy_ice(nlon,360) + REAL phy_fter(nlon,360) + REAL phy_foce(nlon,360) + REAL phy_fsic(nlon,360) + REAL phy_flic(nlon,360) + + integer, save:: read_climoz ! read ozone climatology + + +!------------------------------------------------------------------------- +! declaration pour l'appel a phyredem +!------------------------------------------------------------------------- + +! real pctsrf(nlon,nbsrf),ftsol(nlon,nbsrf) + real falbe(nlon,nbsrf),falblw(nlon,nbsrf) +! real pbl_tke(nlon,llm,nbsrf) +! real rain_fall(nlon),snow_fall(nlon) +! real solsw(nlon), sollw(nlon),radsol(nlon) +! real t_ancien(nlon,llm),q_ancien(nlon,llm),rnebcon(nlon,llm) +! real ratqs(nlon,llm) +! real clwcon(nlon,llm) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + +c----------------------------------------------------------------------- +c dynamial tendencies : +c --------------------- + + INTEGER l,ierr,aslun + + REAL longitude,latitude + REAL paire + + DATA latitude,longitude/48.,0./ + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! INITIALISATIONS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!----------------------------------------------------------------------- +! Initialisations des constantes +! ------------------------------- + + + type_aqua=iflag_phys/100 + type_profil=iflag_phys-type_aqua*100 + print*,'type_aqua, type_profil',type_aqua, type_profil + + if (klon.ne.nlon) stop'probleme de dimensions dans iniaqua' + call phys_state_var_init(read_climoz) + + + read_climoz=0 + day0=217. + day=day0 + it=0 + time=0. + +cIM ajout latfi, lonfi + rlatd=latfi + rlond=lonfi + rlat=rlatd*180./pi + rlon=rlond*180./pi + +!----------------------------------------------------------------------- +! initialisations de la physique +!----------------------------------------------------------------------- + + day_ini=dayref + airefi=1. + zcufi=1. + zcvfi=1. + nbapp_rad=24 + CALL getin('nbapp_rad',nbapp_rad) + +!--------------------------------------------------------------------- +c Creation des conditions aux limites: +c ------------------------------------ +! Initialisations des constantes +! Ajouter les manquants dans planete.def... (albedo etc) + co2_ppm=348. + CALL getin('co2_ppm',co2_ppm) + solaire=1365. + CALL getin('solaire',solaire) + radsol=0. + qsol_f=10. + CALL getin('albedo',albedo) + alb_ocean=.true. + CALL getin('alb_ocean',alb_ocean) + +c Conditions aux limites: +c ----------------------- + + qsol(:) = qsol_f + rugsrel = 0.0 ! (rugsrel = rugoro) + agesno = 50.0 +! Relief plat + zmea = 0. + zstd = 0. + zsig = 0. + zgam = 0. + zthe = 0. + zpic = 0. + zval = 0. + +! Une seule surface + pctsrf=0. + if (type_aqua==1) then + rugos=1.e-4 + albedo=0.19 + pctsrf(:,is_oce)=1. + else if (type_aqua==2) then + rugos=0.03 + albedo=0.1 + pctsrf(:,is_ter)=1. + endif + + CALL getin('rugos',rugos) + zmasq(:)=pctsrf(:,is_oce) + +! pctsrf_pot(:,is_oce) = 1. - zmasq(:) +! pctsrf_pot(:,is_sic) = 1. - zmasq(:) + +! Si alb_ocean on calcule un albedo oceanique moyen +! if (alb_ocean) then +! Voir pourquoi on avait ca. +! CALL ini_alb_oce(phy_alb) +! else + phy_alb(:,:) = albedo ! albedo land only (old value condsurf_jyg=0.3) +! endif !alb_ocean + + do i=1,360 +cIM Terraplanete phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2 +cIM ajout calcul profil sst selon le cas considere (cf. FBr) + + phy_nat(:,i) = 1.0 ! 0=ocean libre, 1=land, 2=glacier, 3=banquise + phy_bil(:,i) = 1.0 ! ne sert que pour les slab_ocean + phy_rug(:,i) = rugos ! longueur rugosite utilisee sur land only + phy_ice(:,i) = 0.0 ! fraction de glace (?) + phy_fter(:,i) = pctsrf(:,is_ter) ! fraction de glace (?) + phy_foce(:,i) = pctsrf(:,is_oce) ! fraction de glace (?) + phy_fsic(:,i) = pctsrf(:,is_sic) ! fraction de glace (?) + phy_flic(:,i) = pctsrf(:,is_lic) ! fraction de glace (?) + enddo +cIM calcul profil sst + call profil_sst(nlon, rlatd, type_profil, phy_sst) + + call writelim + s (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice, + s phy_fter,phy_foce,phy_flic,phy_fsic) + + +!--------------------------------------------------------------------- +c Ecriture de l'etat initial: +c --------------------------- + +C +C Ecriture etat initial physique +C + timestep = dtvr * FLOAT(iphysiq) + radpas = NINT (daysec/timestep/ FLOAT(nbapp_rad) ) + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + clesphy0(1) = FLOAT( iflag_con ) + clesphy0(2) = FLOAT( nbapp_rad ) +c IF( cycle_diurne ) clesphy0(3) = 1. + clesphy0(3)=1. ! cycle_diurne + clesphy0(4)=1. ! soil_model + clesphy0(5)=1. ! new_oliq + clesphy0(6)=0. ! ok_orodr + clesphy0(7)=0. ! ok_orolf + clesphy0(8)=0. ! ok_limitvrai + + +c======================================================================= +c Profils initiaux +c======================================================================= + +! On initialise les temperatures de surfaces comme les sst + do i=1,nlon + ftsol(i,:)=phy_sst(i,1) + tsoil(i,:,:)=phy_sst(i,1) + tslab(i)=phy_sst(i,1) + enddo + + falbe(:,:)=albedo + falblw(:,:)=albedo + rain_fall(:)=0. + snow_fall(:)=0. + solsw(:)=0. + sollw(:)=0. + radsol(:)=0. + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! intialisation bidon mais pas grave + t_ancien(:,:)=0. + q_ancien(:,:)=0. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + rnebcon=0. + ratqs=0. + clwcon=0. + pbl_tke=1.e-8 + +! variables supplementaires pour appel a plb_surface_init + fder(:)=0. + seaice(:)=0. + run_off_lic_0=0. + evap=0. + + +! Initialisations necessaires avant phyredem + type_ocean = "force" + call fonte_neige_init(run_off_lic_0) + qsolsrf(:,:)=qsol(1) ! humidite du sol des sous surface + snsrf(:,:)=0. ! couverture de neige des sous surface + frugs(:,:)=rugos ! couverture de neige des sous surface + + + call pbl_surface_init(qsol, fder, snsrf, qsolsrf, + . evap, frugs, agesno, tsoil) + + print*,'avant phyredem dans iniaqua' + + falb1=albedo + falb2=albedo + zmax0=0. + f0=0. + ema_work1=0. + ema_work2=0. + wake_deltat=0. + wake_deltaq=0. + wake_s=0. + wake_cstar=0. + wake_pe=0. + wake_fip=0. + fm_therm=0. + entr_therm=0. + detr_therm=0. + + + CALL phyredem ("startphy.nc") + + print*,'apres phyredem' + call phys_state_var_end + + return + end + + +c==================================================================== +c==================================================================== + SUBROUTINE zenang_an(cycle_diurne,gmtime,rlat,rlon,rmu0,fract) + USE dimphy + IMPLICIT none +c==================================================================== +c============================================================= +c CALL zenang(cycle_diurne,gmtime,rlat,rlon,rmu0,fract) +c Auteur : A. Campoy et F. Hourdin +c Objet : calculer les valeurs moyennes du cos de l'angle zenithal +c et l'ensoleillement moyen entre gmtime1 et gmtime2 +c connaissant la declinaison, la latitude et la longitude. +c +c Dans cette version particuliere, on calcule le rayonnement +c moyen sur l'année à chaque latitude. +c angle zenithal calculé pour obtenir un +c Fit polynomial de l'ensoleillement moyen au sommet de l'atmosphere +c en moyenne annuelle. +c Spécifique de la terre. Utilisé pour les aqua planetes. +c +c Rque : Different de la routine angle en ce sens que zenang +c fournit des moyennes de pmu0 et non des valeurs +c instantanees, du coup frac prend toutes les valeurs +c entre 0 et 1. +c Date : premiere version le 13 decembre 1994 +c revu pour GCM le 30 septembre 1996 +c=============================================================== +c longi----INPUT : la longitude vraie de la terre dans son plan +c solaire a partir de l'equinoxe de printemps (degre) +c gmtime---INPUT : temps universel en fraction de jour +c pdtrad---INPUT : pas de temps du rayonnement (secondes) +c lat------INPUT : latitude en degres +c long-----INPUT : longitude en degres +c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad +c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad +c================================================================ +#include "YOMCST.h" +c================================================================ + logical cycle_diurne + real gmtime + real rlat(klon), rlon(klon), rmu0(klon), fract(klon) +c================================================================ + integer i + real gmtime1, gmtime2 + real pi_local + + + real rmu0m(klon),rmu0a(klon) +c + + pi_local = 4.0 * ATAN(1.0) + +c================================================================ +c Calcul de l'angle zenithal moyen sur la journee +c================================================================ + + DO i=1,klon + fract(i)=1. +! Calcule du flux moyen + IF (abs(rlat(i)).LE.28.75) THEN + rmu0m(i)=(210.1924+206.6059*cos(0.0174533*rlat(i))**2)/1365. + ELSEIF (abs(rlat(i)).LE.43.75) THEN + rmu0m(i)=(187.4562+236.1853*cos(0.0174533*rlat(i))**2)/1365. + ELSEIF (abs(rlat(i)).LE.71.25) THEN + rmu0m(i)=(162.4439+284.1192*cos(0.0174533*rlat(i))**2)/1365. + ELSE + rmu0m(i)=(172.8125+183.7673*cos(0.0174533*rlat(i))**2)/1365. + ENDIF + ENDDO + +c================================================================ +! Avec ou sans cycle diurne +c================================================================ + + IF (cycle_diurne) THEN + +! On redecompose flux au sommet suivant un cycle diurne idealise +! identique a toutes les latitudes. + + DO i=1,klon + rmu0a(i)=2.*rmu0m(i)*sqrt(2.)*pi_local/(4.-pi_local) + rmu0(i)=rmu0a(i)*abs(sin(pi_local*gmtime+pi_local* + & rlon(i)/360.))-rmu0a(i)/sqrt(2.) + ENDDO + + DO i=1,klon + IF (rmu0(i).LE.0.) THEN + rmu0(i)=0. + fract(i)=0. + ELSE + fract(i)=1. + ENDIF + ENDDO + +! Affichage de l'angel zenitale +! print*,'************************************' +! print*,'************************************' +! print*,'************************************' +! print*,'latitude=',rlat(i),'longitude=',rlon(i) +! print*,'rmu0m=',rmu0m(i) +! print*,'rmu0a=',rmu0a(i) +! print*,'rmu0=',rmu0(i) + + ELSE + + DO i=1,klon + fract(i)=0.5 + rmu0(i)=rmu0m(i)*2. + ENDDO + + ENDIF + + RETURN + END + subroutine writelim + s (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice, + s phy_fter,phy_foce,phy_flic,phy_fsic) +c +!#include "dimensions.h" +!#include "dimphy.h" +#include "netcdf.inc" + + integer klon + REAL phy_nat(klon,360) + REAL phy_alb(klon,360) + REAL phy_sst(klon,360) + REAL phy_bil(klon,360) + REAL phy_rug(klon,360) + REAL phy_ice(klon,360) + REAL phy_fter(klon,360) + REAL phy_foce(klon,360) + REAL phy_flic(klon,360) + REAL phy_fsic(klon,360) + + INTEGER ierr + INTEGER dimfirst(3) + INTEGER dimlast(3) +c + INTEGER nid, ndim, ntim + INTEGER dims(2), debut(2), epais(2) + INTEGER id_tim + INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB + INTEGER id_FTER,id_FOCE,id_FSIC,id_FLIC + + PRINT*, 'Ecriture du fichier limit' +c + ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid) +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30, + . "Fichier conditions aux limites") + ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim) + ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim) +c + dims(1) = ndim + dims(2) = ntim +c +ccc ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim) + ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim) + ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17, + . "Jour dans l annee") +ccc ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT) + ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT) + ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23, + . "Nature du sol (0,1,2,3)") +ccc ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST) + ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST) + ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35, + . "Temperature superficielle de la mer") +ccc ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS) + ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS) + ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32, + . "Reference flux de chaleur au sol") +ccc ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB) + ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB) + ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19, + . "Albedo a la surface") +ccc ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG) + ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG) + ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8, + . "Rugosite") + + ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER) + ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 8,"Frac. Terre") + ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE) + ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 8,"Frac. Terre") + ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC) + ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 8,"Frac. Terre") + ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC) + ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 8,"Frac. Terre") +c + ierr = NF_ENDDEF(nid) +c + DO k = 1, 360 +c + debut(1) = 1 + debut(2) = k + epais(1) = klon + epais(2) = 1 +c + print*,'Instant ',k +#ifdef NC_DOUBLE + print*,'NC DOUBLE' + ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais,phy_nat(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais,phy_fter(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais,phy_foce(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais,phy_fsic(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais,phy_flic(1,k)) +#else + print*,'NC PAS DOUBLE' + ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k)) + ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais,phy_nat(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais,phy_fter(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais,phy_foce(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais,phy_fsic(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais,phy_flic(1,k)) + +#endif +c + ENDDO +c + ierr = NF_CLOSE(nid) +c + return + end + + SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst) + use dimphy + IMPLICIT none +c + INTEGER nlon, type_profil, i, k, j + REAL :: rlatd(nlon), phy_sst(nlon, 360) + INTEGER imn, imx, amn, amx, kmn, kmx + INTEGER p, pplus, nlat_max + parameter (nlat_max=72) + REAL x_anom_sst(nlat_max) +c + if (klon.ne.nlon) stop'probleme de dimensions dans iniaqua' + do i=1,360 +c phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2 + +c Rajout fbrlmd + + if(type_profil.EQ.1)then +c Méthode 1 "Control" faible plateau à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**2) +c PI/3=1.047197551 + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273. + endif + enddo + endif + if(type_profil.EQ.2)then +c Méthode 2 "Flat" fort plateau à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273. + endif + enddo + endif + + + if (type_profil.EQ.3) then +c Méthode 3 "Qobs" plateau réel à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273. + endif + enddo + endif + + if (type_profil.EQ.4) then +c Méthode 4 : Méthode 3 + SST+2 "Qobs" plateau réel à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273. + endif + enddo + endif + + if (type_profil.EQ.5) then +c Méthode 5 : Méthode 3 + +2K "Qobs" plateau réel à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+2.+0.5*27.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273.+2. + endif + + enddo + endif + + if(type_profil.EQ.6)then +c Méthode 6 "cst" valeur constante de SST + do j=1,klon + phy_sst(j,i)=288. + enddo + endif + + + if(type_profil.EQ.7)then +c Méthode 7 "cst" valeur constante de SST +2 + do j=1,klon + phy_sst(j,i)=288.+2. + enddo + endif + + p=0 + if(type_profil.EQ.8)then +c Méthode 8 profil anomalies SST du modèle couplé AR4 + do j=1,klon + if (rlatd(j).EQ.rlatd(j-1)) then + phy_sst(j,i)=273.+x_anom_sst(pplus) + & +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273.+x_anom_sst(pplus) + endif + else + p=p+1 + pplus=73-p + phy_sst(j,i)=273.+x_anom_sst(pplus) + & +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273.+x_anom_sst(pplus) + endif + write (*,*) rlatd(j),x_anom_sst(pplus),phy_sst(j,i) + endif + enddo + endif + + if (type_profil.EQ.9) then +c Méthode 5 : Méthode 3 + -2K "Qobs" plateau réel à l'Equateur + do j=1,klon + phy_sst(j,i)=273.-2.+0.5*27.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273.-2. + endif + enddo + endif + + + if (type_profil.EQ.10) then +c Méthode 10 : Méthode 3 + +4K "Qobs" plateau réel à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273.+4. + endif + enddo + endif + + if (type_profil.EQ.11) then +c Méthode 11 : Méthode 3 + 4CO2 "Qobs" plateau réel à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273. + endif + enddo + endif + + if (type_profil.EQ.12) then +c Méthode 12 : Méthode 10 + 4CO2 "Qobs" plateau réel à l'Equateur + do j=1,klon + phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273.+4. + endif + enddo + endif + + if (type_profil.EQ.13) then +c Méthode 13 "Qmax" plateau réel à l'Equateur augmenté ! + do j=1,klon + phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273. + endif + enddo + endif + + if (type_profil.EQ.14) then +c Méthode 13 "Qmax2K" plateau réel à l'Equateur augmenté +2K ! + do j=1,klon + phy_sst(j,i)=273.+2.+0.5*29.*(2-sin(1.5*rlatd(j))**2 + & -sin(1.5*rlatd(j))**4) + if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then + phy_sst(j,i)=273. + endif + enddo + endif + + enddo + +cIM beg : verif profil SST: phy_sst + amn=MIN(phy_sst(1,1),1000.) + amx=MAX(phy_sst(1,1),-1000.) + DO k=1, 360 + DO i=2, nlon + IF(phy_sst(i,k).LT.amn) THEN + amn=phy_sst(i,k) + imn=i + kmn=k + ENDIF + IF(phy_sst(i,k).GT.amx) THEN + amx=phy_sst(i,k) + imx=i + kmx=k + ENDIF + ENDDO + ENDDO +c + PRINT*,' debut avant writelim min max phy_sst',imn,kmn,amn, + & imx,kmx,amx +cIM end : verif profil SST: phy_sst + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyetat0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyetat0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyetat0.F (revision 1634) @@ -0,0 +1,1095 @@ +! +! $Id$ +! +c +c + SUBROUTINE phyetat0 (fichnom, + . clesphy0, + . tabcntr0) + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy + USE ocean_cpl_mod, ONLY : ocean_cpl_init + USE fonte_neige_mod, ONLY : fonte_neige_init + USE pbl_surface_mod, ONLY : pbl_surface_init + USE surface_data, ONLY : type_ocean + USE phys_state_var_mod + USE iostart + USE write_field_phy + USE infotrac + USE traclmdz_mod, ONLY : traclmdz_from_restart + USE carbon_cycle_mod,ONLY : + & carbon_cycle_tr, carbon_cycle_cpl, co2_send + + IMPLICIT none +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Lecture de l'etat initial pour la physique +c====================================================================== +#include "dimensions.h" +#include "netcdf.inc" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "temps.h" +#include "thermcell.h" +#include "compbl.h" +c====================================================================== + CHARACTER*(*) fichnom + +c les variables globales lues dans le fichier restart + + REAL tsoil(klon,nsoilmx,nbsrf) + REAL tslab(klon), seaice(klon) + REAL qsurf(klon,nbsrf) + REAL qsol(klon) + REAL snow(klon,nbsrf) + REAL evap(klon,nbsrf) + real fder(klon) + REAL frugs(klon,nbsrf) + REAL agesno(klon,nbsrf) + REAL run_off_lic_0(klon) + REAL fractint(klon) + REAL trs(klon,nbtr) + + CHARACTER*6 ocean_in + LOGICAL ok_veget_in + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) +c + REAL xmin, xmax +c + INTEGER nid, nvarid + INTEGER ierr, i, nsrf, isoil ,k + INTEGER length + PARAMETER (length=100) + INTEGER it, iiq + REAL tab_cntrl(length), tabcntr0(length) + CHARACTER*7 str7 + CHARACTER*2 str2 + LOGICAL :: found + +c FH1D +c real iolat(jjm+1) + real iolat(jjm+1-1/iim) +c +c Ouvrir le fichier contenant l'etat initial: +c + + + CALL open_startphy(fichnom) + + +c +c Lecture des parametres de controle: +c + CALL get_var("controle",tab_cntrl) + +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +! Les constantes de la physiques sont lues dans la physique seulement. +! Les egalites du type +! tab_cntrl( 5 )=clesphy0(1) +! sont remplacees par +! clesphy0(1)=tab_cntrl( 5 ) +! On inverse aussi la logique. +! On remplit les tab_cntrl avec les parametres lus dans les .def +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + DO i = 1, length + tabcntr0( i ) = tab_cntrl( i ) + ENDDO +c + tab_cntrl(1)=dtime + tab_cntrl(2)=radpas + +c co2_ppm : value from the previous time step + IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN + co2_ppm = tab_cntrl(3) + RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97 +c ELSE : keep value from .def + END IF + +c co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def) + co2_ppm0 = tab_cntrl(16) + + solaire_etat0 = tab_cntrl(4) + tab_cntrl(5)=iflag_con + tab_cntrl(6)=nbapp_rad + + if (cycle_diurne) tab_cntrl( 7) =1. + if (soil_model) tab_cntrl( 8) =1. + if (new_oliq) tab_cntrl( 9) =1. + if (ok_orodr) tab_cntrl(10) =1. + if (ok_orolf) tab_cntrl(11) =1. + if (ok_limitvrai) tab_cntrl(12) =1. + + + itau_phy = tab_cntrl(15) + + + clesphy0(1)=tab_cntrl( 5 ) + clesphy0(2)=tab_cntrl( 6 ) + clesphy0(3)=tab_cntrl( 7 ) + clesphy0(4)=tab_cntrl( 8 ) + clesphy0(5)=tab_cntrl( 9 ) + clesphy0(6)=tab_cntrl( 10 ) + clesphy0(7)=tab_cntrl( 11 ) + clesphy0(8)=tab_cntrl( 12 ) + +c +c Lecture des latitudes (coordonnees): +c + CALL get_field("latitude",rlat) + +c +c Lecture des longitudes (coordonnees): +c + CALL get_field("longitude",rlon) + +C +C +C Lecture du masque terre mer +C + CALL get_field("masque",zmasq,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT *, 'fichier startphy non compatible avec phyetat0' + ENDIF + + +C Lecture des fractions pour chaque sous-surface +C +C initialisation des sous-surfaces +C + pctsrf = 0. +C +C fraction de terre +C + + CALL get_field("FTER",pctsrf(:,is_ter),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C fraction de glace de terre +C + CALL get_field("FLIC",pctsrf(:,is_lic),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C fraction d'ocean +C + CALL get_field("FOCE",pctsrf(:,is_oce),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C fraction glace de mer +C + CALL get_field("FSIC",pctsrf(:,is_sic),found) + IF (.NOT. found) PRINT*, 'phyetat0: Le champ est absent' + +C +C Verification de l'adequation entre le masque et les sous-surfaces +C + fractint( 1 : klon) = pctsrf(1 : klon, is_ter) + $ + pctsrf(1 : klon, is_lic) + DO i = 1 , klon + IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN + WRITE(*,*) 'phyetat0: attention fraction terre pas ', + $ 'coherente ', i, zmasq(i), pctsrf(i, is_ter) + $ ,pctsrf(i, is_lic) + WRITE(*,*) 'Je force la coherence zmasq=fractint' + zmasq(i) = fractint(i) + ENDIF + END DO + fractint (1 : klon) = pctsrf(1 : klon, is_oce) + $ + pctsrf(1 : klon, is_sic) + DO i = 1 , klon + IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN + WRITE(*,*) 'phyetat0 attention fraction ocean pas ', + $ 'coherente ', i, zmasq(i) , pctsrf(i, is_oce) + $ ,pctsrf(i, is_sic) + WRITE(*,*) 'Je force la coherence zmasq=fractint' + zmasq(i) = fractint(i) + ENDIF + END DO + +C +c Lecture des temperatures du sol: +c + + CALL get_field("TS",ftsol(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire TS**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("TS"//str2,ftsol(:,nsrf)) + + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(ftsol(i,nsrf),xmin) + xmax = MAX(ftsol(i,nsrf),xmax) + ENDDO + PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres temperatures TS**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(ftsol(i,1),xmin) + xmax = MAX(ftsol(i,1),xmax) + ENDDO + PRINT*,'Temperature du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + ftsol(i,nsrf) = ftsol(i,1) + ENDDO + ENDDO + ENDIF + +c +c Lecture des temperatures du sol profond: +c + DO nsrf = 1, nbsrf + DO isoil=1, nsoilmx + IF (isoil.GT.99 .AND. nsrf.GT.99) THEN + PRINT*, "Trop de couches ou sous-mailles" + CALL abort + ENDIF + WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf + + CALL get_field('Tsoil'//str7,tsoil(:,isoil,nsrf),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, " Il prend donc la valeur de surface" + DO i=1, klon + tsoil(i,isoil,nsrf)=ftsol(i,nsrf) + ENDDO + ENDIF + ENDDO + ENDDO +c +c Lecture de l'humidite de l'air juste au dessus du sol: +c + + CALL get_field("QS",qsurf(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire QS**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("QS"//str2,qsurf(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(qsurf(i,nsrf),xmin) + xmax = MAX(qsurf(i,nsrf),xmax) + ENDDO + PRINT*,'Humidite pres du sol QS**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres humidites QS**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(qsurf(i,1),xmin) + xmax = MAX(qsurf(i,1),xmax) + ENDDO + PRINT*,'Humidite pres du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + qsurf(i,nsrf) = qsurf(i,1) + ENDDO + ENDDO + ENDIF + +C +C Eau dans le sol (pour le modele de sol "bucket") +C + CALL get_field("QSOL",qsol,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Valeur par defaut nulle' + qsol(:)=0. + ENDIF + + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(qsol(i),xmin) + xmax = MAX(qsol(i),xmax) + ENDDO + PRINT*,'Eau dans le sol (mm) ', xmin, xmax + +c +c Lecture de neige au sol: +c + + CALL get_field("SNOW",snow(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire SNOW**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field( "SNOW"//str2,snow(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(snow(i,nsrf),xmin) + xmax = MAX(snow(i,nsrf),xmax) + ENDDO + PRINT*,'Neige du sol SNOW**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres neiges SNOW**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(snow(i,1),xmin) + xmax = MAX(snow(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + snow(i,nsrf) = snow(i,1) + ENDDO + ENDDO + ENDIF +c +c Lecture de albedo de l'interval visible au sol: +c + CALL get_field("ALBE",falb1(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire ALBE**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("ALBE"//str2,falb1(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(falb1(i,nsrf),xmin) + xmax = MAX(falb1(i,nsrf),xmax) + ENDDO + PRINT*,'Albedo du sol ALBE**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres ALBE**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(falb1(i,1),xmin) + xmax = MAX(falb1(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + falb1(i,nsrf) = falb1(i,1) + ENDDO + ENDDO + ENDIF + +c +c Lecture de albedo au sol dans l'interval proche infra-rouge: +c + CALL get_field("ALBLW",falb2(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais prendre ALBE**' + DO nsrf = 1, nbsrf + DO i = 1, klon + falb2(i,nsrf) = falb1(i,nsrf) + ENDDO + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres ALBLW**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(falb2(i,1),xmin) + xmax = MAX(falb2(i,1),xmax) + ENDDO + PRINT*,'Neige du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + falb2(i,nsrf) = falb2(i,1) + ENDDO + ENDDO + ENDIF +c +c Lecture de evaporation: +c + CALL get_field("EVAP",evap(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire EVAP**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("EVAP"//str2, evap(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(evap(i,nsrf),xmin) + xmax = MAX(evap(i,nsrf),xmax) + ENDDO + PRINT*,'evap du sol EVAP**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres EVAP**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(evap(i,1),xmin) + xmax = MAX(evap(i,1),xmax) + ENDDO + PRINT*,'Evap du sol ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + evap(i,nsrf) = evap(i,1) + ENDDO + ENDDO + ENDIF +c +c Lecture precipitation liquide: +c + CALL get_field("rain_f",rain_fall) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(rain_fall(i),xmin) + xmax = MAX(rain_fall(i),xmax) + ENDDO + PRINT*,'Precipitation liquide rain_f:', xmin, xmax +c +c Lecture precipitation solide: +c + CALL get_field("snow_f",snow_fall) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(snow_fall(i),xmin) + xmax = MAX(snow_fall(i),xmax) + ENDDO + PRINT*,'Precipitation solide snow_f:', xmin, xmax +c +c Lecture rayonnement solaire au sol: +c + CALL get_field("solsw",solsw,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + solsw(:) = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(solsw(i),xmin) + xmax = MAX(solsw(i),xmax) + ENDDO + PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax +c +c Lecture rayonnement IF au sol: +c + CALL get_field("sollw",sollw,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + sollw = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(sollw(i),xmin) + xmax = MAX(sollw(i),xmax) + ENDDO + PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax + +c +c Lecture derive des flux: +c + CALL get_field("fder",fder,found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + fder = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(fder(i),xmin) + xmax = MAX(fder(i),xmax) + ENDDO + PRINT*,'Derive des flux fder:', xmin, xmax + +c +c Lecture du rayonnement net au sol: +c + CALL get_field("RADS",radsol) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(radsol(i),xmin) + xmax = MAX(radsol(i),xmax) + ENDDO + PRINT*,'Rayonnement net au sol radsol:', xmin, xmax +c +c Lecture de la longueur de rugosite +c +c + CALL get_field("RUG",frugs(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire RUG**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("RUG"//str2,frugs(:,nsrf)) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(frugs(i,nsrf),xmin) + xmax = MAX(frugs(i,nsrf),xmax) + ENDDO + PRINT*,'rugosite du sol RUG**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres RUG**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(frugs(i,1),xmin) + xmax = MAX(frugs(i,1),xmax) + ENDDO + PRINT*,'rugosite ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + frugs(i,nsrf) = frugs(i,1) + ENDDO + ENDDO + ENDIF + +c +c Lecture de l'age de la neige: +c + CALL get_field("AGESNO",agesno(:,1),found) + IF (.NOT. found) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, ' Mais je vais essayer de lire AGESNO**' + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("AGESNO"//str2,agesno(:,nsrf),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + agesno = 50.0 + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(agesno(i,nsrf),xmin) + xmax = MAX(agesno(i,nsrf),xmax) + ENDDO + PRINT*,'Age de la neige AGESNO**:', nsrf, xmin, xmax + ENDDO + ELSE + PRINT*, 'phyetat0: Le champ est present' + PRINT*, ' J ignore donc les autres AGESNO**' + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(agesno(i,1),xmin) + xmax = MAX(agesno(i,1),xmax) + ENDDO + PRINT*,'Age de la neige ', xmin, xmax + DO nsrf = 2, nbsrf + DO i = 1, klon + agesno(i,nsrf) = agesno(i,1) + ENDDO + ENDDO + ENDIF + +c + CALL get_field("ZMEA", zmea) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zmea(i),xmin) + xmax = MAX(zmea(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax +c +c + CALL get_field("ZSTD",zstd) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zstd(i),xmin) + xmax = MAX(zstd(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax +c +c + CALL get_field("ZSIG",zsig) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zsig(i),xmin) + xmax = MAX(zsig(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax +c +c + CALL get_field("ZGAM",zgam) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zgam(i),xmin) + xmax = MAX(zgam(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax +c +c + CALL get_field("ZTHE",zthe) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zthe(i),xmin) + xmax = MAX(zthe(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax +c +c + CALL get_field("ZPIC",zpic) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zpic(i),xmin) + xmax = MAX(zpic(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax +c + CALL get_field("ZVAL",zval) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(zval(i),xmin) + xmax = MAX(zval(i),xmax) + ENDDO + PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax +c +c + CALL get_field("RUGSREL",rugoro) + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon + xmin = MIN(rugoro(i),xmin) + xmax = MAX(rugoro(i),xmax) + ENDDO + PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax +c +c + +c + ancien_ok = .TRUE. + + CALL get_field("TANCIEN",t_ancien,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ENDIF + + + CALL get_field("QANCIEN",q_ancien,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ancien_ok = .FALSE. + ENDIF + + u_ancien = 0.0 !AXC: We don't have u_ancien and v_ancien in the start + v_ancien = 0.0 !AXC: files, therefore they have to be initialized. +c + + clwcon=0. + CALL get_field("CLWCON",clwcon(:,1),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ CLWCON est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(clwcon) + xmax = MAXval(clwcon) + PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax +c + rnebcon = 0. + CALL get_field("RNEBCON",rnebcon(:,1),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ RNEBCON est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(rnebcon) + xmax = MAXval(rnebcon) + PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax + +c +c Lecture ratqs +c + ratqs=0. + CALL get_field("RATQS",ratqs(:,1),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(ratqs) + xmax = MAXval(ratqs) + PRINT*,'(ecart-type) ratqs:', xmin, xmax +c +c Lecture run_off_lic_0 +c + CALL get_field("RUNOFFLIC0",run_off_lic_0,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + run_off_lic_0 = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(run_off_lic_0) + xmax = MAXval(run_off_lic_0) + PRINT*,'(ecart-type) run_off_lic_0:', xmin, xmax + + +c Lecture de l'energie cinetique turbulente +c + + IF (iflag_pbl>1) then + DO nsrf = 1, nbsrf + IF (nsrf.GT.99) THEN + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') nsrf + CALL get_field("TKE"//str2,pbl_tke(:,1:klev+1,nsrf),found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: est absent" + pbl_tke(:,:,nsrf)=1.e-8 + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev+1 + DO i = 1, klon + xmin = MIN(pbl_tke(i,k,nsrf),xmin) + xmax = MAX(pbl_tke(i,k,nsrf),xmax) + ENDDO + ENDDO + PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax + ENDDO + ENDIF +c +c zmax0 + CALL get_field("ZMAX0",zmax0,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + zmax0=40. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(zmax0) + xmax = MAXval(zmax0) + PRINT*,'(ecart-type) zmax0:', xmin, xmax +c +c f0(ig)=1.e-5 +c f0 + CALL get_field("F0",f0,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + f0=1.e-5 + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(f0) + xmax = MAXval(f0) + PRINT*,'(ecart-type) f0:', xmin, xmax +c +c ema_work1 +c + CALL get_field("EMA_WORK1",ema_work1,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ema_work1=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(ema_work1(i,k),xmin) + xmax = MAX(ema_work1(i,k),xmax) + ENDDO + ENDDO + PRINT*,'ema_work1:', xmin, xmax + ENDIF +c +c ema_work2 +c + CALL get_field("EMA_WORK2",ema_work2,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + ema_work2=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(ema_work2(i,k),xmin) + xmax = MAX(ema_work2(i,k),xmax) + ENDDO + ENDDO + PRINT*,'ema_work2:', xmin, xmax + ENDIF +c +c wake_deltat +c + CALL get_field("WAKE_DELTAT",wake_deltat,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_deltat=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(wake_deltat(i,k),xmin) + xmax = MAX(wake_deltat(i,k),xmax) + ENDDO + ENDDO + PRINT*,'wake_deltat:', xmin, xmax + ENDIF +c +c wake_deltaq +c + CALL get_field("WAKE_DELTAQ",wake_deltaq,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_deltaq=0. + ELSE + xmin = 1.0E+20 + xmax = -1.0E+20 + DO k = 1, klev + DO i = 1, klon + xmin = MIN(wake_deltaq(i,k),xmin) + xmax = MAX(wake_deltaq(i,k),xmax) + ENDDO + ENDDO + PRINT*,'wake_deltaq:', xmin, xmax + ENDIF +c +c wake_s +c + CALL get_field("WAKE_S",wake_s,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_s=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(wake_s) + xmax = MAXval(wake_s) + PRINT*,'(ecart-type) wake_s:', xmin, xmax +c +c wake_cstar +c + CALL get_field("WAKE_CSTAR",wake_cstar,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_cstar=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(wake_cstar) + xmax = MAXval(wake_cstar) + PRINT*,'(ecart-type) wake_cstar:', xmin, xmax +c +c wake_pe +c + CALL get_field("WAKE_PE",wake_pe,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_pe=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(wake_pe) + xmax = MAXval(wake_pe) + PRINT*,'(ecart-type) wake_pe:', xmin, xmax +c +c wake_fip +c + CALL get_field("WAKE_FIP",wake_fip,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + wake_fip=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(wake_fip) + xmax = MAXval(wake_fip) + PRINT*,'(ecart-type) wake_fip:', xmin, xmax +c +c thermiques +c + + CALL get_field("FM_THERM",fm_therm,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + fm_therm=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(fm_therm) + xmax = MAXval(fm_therm) + PRINT*,'(ecart-type) fm_therm:', xmin, xmax + + CALL get_field("ENTR_THERM",entr_therm,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + entr_therm=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(entr_therm) + xmax = MAXval(entr_therm) + PRINT*,'(ecart-type) entr_therm:', xmin, xmax + + CALL get_field("DETR_THERM",detr_therm,found) + IF (.NOT. found) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + detr_therm=0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(detr_therm) + xmax = MAXval(detr_therm) + PRINT*,'(ecart-type) detr_therm:', xmin, xmax + + + +c +c Read and send field trs to traclmdz +c + IF (type_trac == 'lmdz') THEN + DO it=1,nbtr + iiq=niadv(it+2) + CALL get_field("trs_"//tname(iiq),trs(:,it),found) + IF (.NOT. found) THEN + PRINT*, + $ "phyetat0: Le champ est absent" + PRINT*, "Depart legerement fausse. Mais je continue" + trs(:,it) = 0. + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + xmin = MINval(trs(:,it)) + xmax = MAXval(trs(:,it)) + PRINT*,"(ecart-type) trs_"//tname(iiq)//" :", xmin, xmax + + END DO + CALL traclmdz_from_restart(trs) + + IF (carbon_cycle_cpl) THEN + ALLOCATE(co2_send(klon), stat=ierr) + IF (ierr /= 0) CALL abort_gcm + & ('phyetat0','pb allocation co2_send',1) + CALL get_field("co2_send",co2_send,found) + IF (.NOT. found) THEN + PRINT*,"phyetat0: Le champ est absent" + PRINT*,"Initialisation uniforme a co2_ppm=",co2_ppm + co2_send(:) = co2_ppm + END IF + END IF + END IF + + +c on ferme le fichier + CALL close_startphy + + CALL init_iophy_new(rlat,rlon) + + +c +c Initialize module pbl_surface_mod +c + CALL pbl_surface_init(qsol, fder, snow, qsurf, + $ evap, frugs, agesno, tsoil) + +c Initialize module ocean_cpl_mod for the case of coupled ocean + IF ( type_ocean == 'couple' ) THEN + CALL ocean_cpl_init(dtime, rlon, rlat) + ENDIF +c +c Initilialize module fonte_neige_mod +c + CALL fonte_neige_init(run_off_lic_0) + + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyredem.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyredem.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phyredem.F (revision 1634) @@ -0,0 +1,352 @@ +! +! $Id$ +! +c + SUBROUTINE phyredem (fichnom) + + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE fonte_neige_mod, ONLY : fonte_neige_final + USE pbl_surface_mod, ONLY : pbl_surface_final + USE phys_state_var_mod + USE iostart + USE traclmdz_mod, ONLY : traclmdz_to_restart + USE infotrac + USE control_mod + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send + + IMPLICIT none +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Ecriture de l'etat de redemarrage pour la physique +c====================================================================== +#include "netcdf.inc" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "temps.h" +#include "thermcell.h" +#include "compbl.h" +c====================================================================== + CHARACTER*(*) fichnom + +c les variables globales ecrites dans le fichier restart + + + REAL tsoil(klon,nsoilmx,nbsrf) + REAL tslab(klon), seaice(klon) + REAL qsurf(klon,nbsrf) + REAL qsol(klon) + REAL snow(klon,nbsrf) + REAL evap(klon,nbsrf) + real fder(klon) + REAL frugs(klon,nbsrf) + REAL agesno(klon,nbsrf) + REAL run_off_lic_0(klon) + REAL trs(klon,nbtr) +c + INTEGER nid, nvarid, idim1, idim2, idim3 + INTEGER ierr + INTEGER length + PARAMETER (length=100) + REAL tab_cntrl(length) +c + INTEGER isoil, nsrf + CHARACTER (len=7) :: str7 + CHARACTER (len=2) :: str2 + INTEGER :: it, iiq + +c====================================================================== +c +c Get variables which will be written to restart file from module +c pbl_surface_mod + CALL pbl_surface_final(qsol, fder, snow, qsurf, + $ evap, frugs, agesno, tsoil) + +c Get a variable calculated in module fonte_neige_mod + CALL fonte_neige_final(run_off_lic_0) + +c====================================================================== + + CALL open_restartphy(fichnom) + + DO ierr = 1, length + tab_cntrl(ierr) = 0.0 + ENDDO + tab_cntrl(1) = dtime + tab_cntrl(2) = radpas +c co2_ppm : current value of atmospheric CO2 + tab_cntrl(3) = co2_ppm + tab_cntrl(4) = solaire + tab_cntrl(5) = iflag_con + tab_cntrl(6) = nbapp_rad + + IF( cycle_diurne ) tab_cntrl( 7 ) = 1. + IF( soil_model ) tab_cntrl( 8 ) = 1. + IF( new_oliq ) tab_cntrl( 9 ) = 1. + IF( ok_orodr ) tab_cntrl(10 ) = 1. + IF( ok_orolf ) tab_cntrl(11 ) = 1. + + tab_cntrl(13) = day_end + tab_cntrl(14) = annee_ref + tab_cntrl(15) = itau_phy + +c co2_ppm0 : initial value of atmospheric CO2 + tab_cntrl(16) = co2_ppm0 +c + CALL put_var("controle","Parametres de controle",tab_cntrl) +c + + CALL put_field("longitude", + . "Longitudes de la grille physique",rlon) + + CALL put_field("latitude","Latitudes de la grille physique",rlat) + +c +C PB ajout du masque terre/mer +C + CALL put_field("masque","masque terre mer",zmasq) + +c BP ajout des fraction de chaque sous-surface +C +C 1. fraction de terre +C + CALL put_field("FTER","fraction de continent",pctsrf(:,is_ter)) +C +C 2. Fraction de glace de terre +C + CALL put_field("FLIC","fraction glace de terre",pctsrf(:,is_lic)) +C +C 3. fraction ocean +C + CALL put_field("FOCE","fraction ocean",pctsrf(:,is_oce)) +C +C 4. Fraction glace de mer +C + CALL put_field("FSIC","fraction glace mer",pctsrf(:,is_sic)) +C +C +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("TS"//str2,"Temperature de surface No."//str2, + . ftsol(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c + DO nsrf = 1, nbsrf + DO isoil=1, nsoilmx + IF (isoil.LE.99 .AND. nsrf.LE.99) THEN + WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf + CALL put_field("Tsoil"//str7,"Temperature du sol No."//str7, + . tsoil(:,isoil,nsrf)) + ELSE + PRINT*, "Trop de couches" + CALL abort + ENDIF + ENDDO + ENDDO +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("QS"//str2,"Humidite de surface No."//str2, + . qsurf(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + END DO +C + CALL put_field("QSOL","Eau dans le sol (mm)",qsol) +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("ALBE"//str2,"albedo de surface No."//str2, + . falb1(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("ALBLW"//str2,"albedo LW de surface No."//str2, + . falb2(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("EVAP"//str2,"Evaporation de surface No."//str2 + . ,evap(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("SNOW"//str2,"Neige de surface No."//str2, + . snow(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + +c + CALL put_field("RADS","Rayonnement net a la surface",radsol) +c + CALL put_field("solsw","Rayonnement solaire a la surface",solsw) +c + CALL put_field("sollw","Rayonnement IF a la surface",sollw) +c + CALL put_field("fder","Derive de flux",fder) +c + CALL put_field("rain_f","precipitation liquide",rain_fall) +c + CALL put_field("snow_f", "precipitation solide",snow_fall) +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("RUG"//str2,"rugosite de surface No."//str2, + . frugs(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("AGESNO"//str2, + . "Age de la neige surface No."//str2, + . agesno(:,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO +c + CALL put_field("ZMEA","ZMEA",zmea) +c + CALL put_field("ZSTD","ZSTD",zstd) + + CALL put_field("ZSIG","ZSIG",zsig) + + CALL put_field("ZGAM","ZGAM",zgam) + + CALL put_field("ZTHE","ZTHE",zthe) + + CALL put_field("ZPIC","ZPIC",zpic) + + CALL put_field("ZVAL","ZVAL",zval) + + CALL put_field("RUGSREL","RUGSREL",rugoro) + + CALL put_field("TANCIEN","TANCIEN",t_ancien) + + CALL put_field("QANCIEN","QANCIEN",q_ancien) + + CALL put_field("RUGMER","Longueur de rugosite sur mer", + . frugs(:,is_oce)) + + CALL put_field("CLWCON","Eau liquide convective",clwcon(:,1)) + + CALL put_field("RNEBCON","Nebulosite convective",rnebcon(:,1)) + + CALL put_field("RATQS", "Ratqs",ratqs(:,1)) +c +c run_off_lic_0 +c + CALL put_field("RUNOFFLIC0","Runofflic0",run_off_lic_0) +c +c +!!!!!!!!!!!!!!!!!!!! DEB TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!! +c + IF (iflag_pbl>1) then + DO nsrf = 1, nbsrf + IF (nsrf.LE.99) THEN + WRITE(str2,'(i2.2)') nsrf + CALL put_field("TKE"//str2,"Energ. Cineti. Turb."//str2, + . pbl_tke(:,1:klev+1,nsrf)) + ELSE + PRINT*, "Trop de sous-mailles" + CALL abort + ENDIF + ENDDO + ENDIF + +!!!!!!!!!!!!!!!!!!!! FIN TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!! +cIM ajout zmax0, f0, ema_work1, ema_work2 +cIM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip + + CALL put_field("ZMAX0","ZMAX0",zmax0) + + CALL put_field("F0","F0",f0) + + CALL put_field("EMA_WORK1","EMA_WORK1",ema_work1) + + CALL put_field("EMA_WORK2","EMA_WORK2",ema_work2) + +c wake_deltat + CALL put_field("WAKE_DELTAT","WAKE_DELTAT",wake_deltat) + + CALL put_field("WAKE_DELTAQ","WAKE_DELTAQ",wake_deltaq) + + CALL put_field("WAKE_S","WAKE_S",wake_s) + + CALL put_field("WAKE_CSTAR","WAKE_CSTAR",wake_cstar) + + CALL put_field("WAKE_PE","WAKE_PE",wake_pe) + + CALL put_field("WAKE_FIP","WAKE_FIP",wake_fip) + +c thermiques + + CALL put_field("FM_THERM","FM_THERM",fm_therm) + + CALL put_field("ENTR_THERM","ENTR_THERM",entr_therm) + + CALL put_field("DETR_THERM","DETR_THERM",detr_therm) + +! trs from traclmdz_mod + IF (type_trac == 'lmdz') THEN + CALL traclmdz_to_restart(trs) + DO it=1,nbtr + iiq=niadv(it+2) + CALL put_field("trs_"//tname(iiq),"",trs(:,it)) + END DO + IF (carbon_cycle_cpl) THEN + IF (.NOT. ALLOCATED(co2_send)) THEN + ! This is the case of create_etat0_limit, ce0l + ALLOCATE(co2_send(klon)) + co2_send(:) = co2_ppm0 + END IF + CALL put_field("co2_send","co2_ppm for coupling",co2_send) + END IF + END IF + + CALL close_restartphy +!$OMP BARRIER + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_cal_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_cal_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_cal_mod.F90 (revision 1634) @@ -0,0 +1,41 @@ +! $Id:$ +MODULE phys_cal_mod +! This module contains information on the calendar at the actual time step + + SAVE + + INTEGER :: year_cur ! current year + INTEGER :: mth_cur ! current month + INTEGER :: day_cur ! current day + INTEGER :: days_elapsed ! number of whole days since start of the simulation + INTEGER :: mth_len ! number of days in the current month + REAL :: hour + REAL :: jD_1jan + REAL :: jH_1jan + REAL :: xjour + + +CONTAINS + + SUBROUTINE phys_cal_update(jD_cur, jH_cur) + ! This subroutine updates the module saved variables. + + USE IOIPSL + + REAL, INTENT(IN) :: jD_cur ! jour courant a l'appel de la physique (jour julien) + REAL, INTENT(IN) :: jH_cur ! heure courante a l'appel de la physique (jour julien) + + CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour) + CALL ymds2ju(year_cur, 1, 1, 0., jD_1jan) + + jH_1jan = jD_1jan - int (jD_1jan) + jD_1jan = int (jD_1jan) + xjour = jD_cur - jD_1jan + days_elapsed = jD_cur - jD_1jan + + ! Get lenght of acutual month + mth_len = ioget_mon_len(year_cur,mth_cur) + + END SUBROUTINE phys_cal_update + +END MODULE phys_cal_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_local_var_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_local_var_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_local_var_mod.F90 (revision 1634) @@ -0,0 +1,366 @@ +! +! $Id$ +! + MODULE phys_local_var_mod + +! Variables locales pour effectuer les appels en serie +!====================================================================== +! +! +!====================================================================== +! Declaration des variables + + REAL, SAVE, ALLOCATABLE :: t_seri(:,:), q_seri(:,:) + !$OMP THREADPRIVATE(t_seri, q_seri) + REAL, SAVE, ALLOCATABLE :: ql_seri(:,:),qs_seri(:,:) + !$OMP THREADPRIVATE(ql_seri,qs_seri) + REAL, SAVE, ALLOCATABLE :: u_seri(:,:), v_seri(:,:) + !$OMP THREADPRIVATE(u_seri, v_seri) + + REAL, SAVE, ALLOCATABLE :: tr_seri(:,:,:) + !$OMP THREADPRIVATE(tr_seri) + REAL, SAVE, ALLOCATABLE :: d_t_dyn(:,:), d_q_dyn(:,:) + !$OMP THREADPRIVATE(d_t_dyn, d_q_dyn) + REAL, SAVE, ALLOCATABLE :: d_u_dyn(:,:), d_v_dyn(:,:) + !$OMP THREADPRIVATE(d_u_dyn, d_v_dyn) + REAL, SAVE, ALLOCATABLE :: d_t_con(:,:),d_q_con(:,:) + !$OMP THREADPRIVATE(d_t_con,d_q_con) + REAL, SAVE, ALLOCATABLE :: d_u_con(:,:),d_v_con(:,:) + !$OMP THREADPRIVATE(d_u_con,d_v_con) + REAL, SAVE, ALLOCATABLE :: d_t_wake(:,:),d_q_wake(:,:) + !$OMP THREADPRIVATE( d_t_wake,d_q_wake) + REAL, SAVE, ALLOCATABLE :: d_t_lsc(:,:),d_q_lsc(:,:),d_ql_lsc(:,:) + !$OMP THREADPRIVATE(d_t_lsc,d_q_lsc,d_ql_lsc) + REAL, SAVE, ALLOCATABLE :: d_t_ajsb(:,:), d_q_ajsb(:,:) + !$OMP THREADPRIVATE(d_t_ajsb, d_q_ajsb) + REAL, SAVE, ALLOCATABLE :: d_t_ajs(:,:), d_q_ajs(:,:) + !$OMP THREADPRIVATE(d_t_ajs, d_q_ajs) + REAL, SAVE, ALLOCATABLE :: d_u_ajs(:,:), d_v_ajs(:,:) + !$OMP THREADPRIVATE(d_u_ajs, d_v_ajs) + REAL, SAVE, ALLOCATABLE :: d_t_eva(:,:),d_q_eva(:,:) + !$OMP THREADPRIVATE(d_t_eva,d_q_eva) + REAL, SAVE, ALLOCATABLE :: d_t_lscst(:,:),d_q_lscst(:,:) + !$OMP THREADPRIVATE(d_t_lscst,d_q_lscst) + REAL, SAVE, ALLOCATABLE :: d_t_lscth(:,:),d_q_lscth(:,:) + !$OMP THREADPRIVATE(d_t_lscth,d_q_lscth) + REAL, SAVE, ALLOCATABLE :: plul_th(:),plul_st(:) + !$OMP THREADPRIVATE(plul_th,plul_st) +!tendances dues a oro et lif + REAL, SAVE, ALLOCATABLE :: d_t_oli(:,:) + !$OMP THREADPRIVATE(d_t_oli) + REAL, SAVE, ALLOCATABLE :: d_u_oli(:,:), d_v_oli(:,:) + !$OMP THREADPRIVATE(d_u_oli, d_v_oli) + REAL, SAVE, ALLOCATABLE :: d_t_vdf(:,:), d_q_vdf(:,:) + !$OMP THREADPRIVATE( d_t_vdf, d_q_vdf) + REAL, SAVE, ALLOCATABLE :: d_u_vdf(:,:), d_v_vdf(:,:) + !$OMP THREADPRIVATE(d_u_vdf, d_v_vdf) + REAL, SAVE, ALLOCATABLE :: d_t_oro(:,:) + !$OMP THREADPRIVATE(d_t_oro) + REAL, SAVE, ALLOCATABLE :: d_u_oro(:,:), d_v_oro(:,:) + !$OMP THREADPRIVATE(d_u_oro, d_v_oro) + REAL, SAVE, ALLOCATABLE :: d_t_lif(:,:) + !$OMP THREADPRIVATE(d_t_lif) + REAL, SAVE, ALLOCATABLE :: d_u_lif(:,:), d_v_lif(:,:) + !$OMP THREADPRIVATE(d_u_lif, d_v_lif) +! Tendances Ondes de G non oro (runs strato). + REAL, SAVE, ALLOCATABLE :: d_u_hin(:,:) + !$OMP THREADPRIVATE(d_u_hin) + REAL, SAVE, ALLOCATABLE :: d_v_hin(:,:) + !$OMP THREADPRIVATE(d_v_hin) + REAL, SAVE, ALLOCATABLE :: d_t_hin(:,:) + !$OMP THREADPRIVATE(d_t_hin) + +! tendance du a la conersion Ec -> E thermique + REAL, SAVE, ALLOCATABLE :: d_t_ec(:,:) + !$OMP THREADPRIVATE(d_t_ec) + REAL, SAVE, ALLOCATABLE :: d_ts(:,:), d_tr(:,:,:) + !$OMP THREADPRIVATE(d_ts, d_tr) + +! diagnostique pour le rayonnement + REAL, SAVE, ALLOCATABLE :: topswad_aero(:), solswad_aero(:) ! diag + !$OMP THREADPRIVATE(topswad_aero,solswad_aero) + REAL, SAVE, ALLOCATABLE :: topswai_aero(:), solswai_aero(:) ! diag + !$OMP THREADPRIVATE(topswai_aero,solswai_aero) + REAL, SAVE, ALLOCATABLE :: topswad0_aero(:), solswad0_aero(:) ! diag + !$OMP THREADPRIVATE(topswad0_aero,solswad0_aero) + REAL, SAVE, ALLOCATABLE :: topsw_aero(:,:), solsw_aero(:,:) ! diag + !$OMP THREADPRIVATE(topsw_aero,solsw_aero) + REAL, SAVE, ALLOCATABLE :: topsw0_aero(:,:), solsw0_aero(:,:) ! diag + !$OMP THREADPRIVATE(topsw0_aero,solsw0_aero) + REAL, SAVE, ALLOCATABLE :: topswcf_aero(:,:), solswcf_aero(:,:) ! diag + !$OMP THREADPRIVATE(topswcf_aero,solswcf_aero) + REAL, SAVE, ALLOCATABLE :: tausum_aero(:,:,:) + !$OMP THREADPRIVATE(tausum_aero) + REAL, SAVE, ALLOCATABLE :: tau3d_aero(:,:,:,:) + !$OMP THREADPRIVATE(tau3d_aero) + REAL, SAVE, ALLOCATABLE :: scdnc(:,:) + !$OMP THREADPRIVATE(scdnc) + REAL, SAVE, ALLOCATABLE :: cldncl(:) + !$OMP THREADPRIVATE(cldncl) + REAL, SAVE, ALLOCATABLE :: reffclwtop(:) + !$OMP THREADPRIVATE(reffclwtop) + REAL, SAVE, ALLOCATABLE :: lcc(:) + !$OMP THREADPRIVATE(lcc) + REAL, SAVE, ALLOCATABLE :: reffclws(:,:) + !$OMP THREADPRIVATE(reffclws) + REAL, SAVE, ALLOCATABLE :: reffclwc(:,:) + !$OMP THREADPRIVATE(reffclwc) + REAL, SAVE, ALLOCATABLE :: cldnvi(:) + !$OMP THREADPRIVATE(cldnvi) + REAL, SAVE, ALLOCATABLE :: lcc3d(:,:) + !$OMP THREADPRIVATE(lcc3d) + REAL, SAVE, ALLOCATABLE :: lcc3dcon(:,:) + !$OMP THREADPRIVATE(lcc3dcon) + REAL, SAVE, ALLOCATABLE :: lcc3dstra(:,:) + !$OMP THREADPRIVATE(lcc3dstra) + REAL, SAVE, ALLOCATABLE :: od550aer(:) + !$OMP THREADPRIVATE(od550aer) + REAL, SAVE, ALLOCATABLE :: absvisaer(:) + !$OMP THREADPRIVATE(absvisaer) + REAL, SAVE, ALLOCATABLE :: od865aer(:) + !$OMP THREADPRIVATE(od865aer) + REAL, SAVE, ALLOCATABLE :: ec550aer(:,:) + !$OMP THREADPRIVATE(ec550aer) + REAL, SAVE, ALLOCATABLE :: od550lt1aer(:) + !$OMP THREADPRIVATE(od550lt1aer) + REAL, SAVE, ALLOCATABLE :: sconcso4(:) + !$OMP THREADPRIVATE(sconcso4) + REAL, SAVE, ALLOCATABLE :: sconcoa(:) + !$OMP THREADPRIVATE(sconcoa) + REAL, SAVE, ALLOCATABLE :: sconcbc(:) + !$OMP THREADPRIVATE(sconcbc) + REAL, SAVE, ALLOCATABLE :: sconcss(:) + !$OMP THREADPRIVATE(sconcss) + REAL, SAVE, ALLOCATABLE :: sconcdust(:) + !$OMP THREADPRIVATE(sconcdust) + REAL, SAVE, ALLOCATABLE :: concso4(:,:) + !$OMP THREADPRIVATE(concso4) + REAL, SAVE, ALLOCATABLE :: concoa(:,:) + !$OMP THREADPRIVATE(concoa) + REAL, SAVE, ALLOCATABLE :: concbc(:,:) + !$OMP THREADPRIVATE(concbc) + REAL, SAVE, ALLOCATABLE :: concss(:,:) + !$OMP THREADPRIVATE(concss) + REAL, SAVE, ALLOCATABLE :: concdust(:,:) + !$OMP THREADPRIVATE(concdust) + REAL, SAVE, ALLOCATABLE :: loadso4(:) + !$OMP THREADPRIVATE(loadso4) + REAL, SAVE, ALLOCATABLE :: loadoa(:) + !$OMP THREADPRIVATE(loadoa) + REAL, SAVE, ALLOCATABLE :: loadbc(:) + !$OMP THREADPRIVATE(loadbc) + REAL, SAVE, ALLOCATABLE :: loadss(:) + !$OMP THREADPRIVATE(loadss) + REAL, SAVE, ALLOCATABLE :: loaddust(:) + !$OMP THREADPRIVATE(loaddust) + REAL, SAVE, ALLOCATABLE :: load_tmp1(:) + !$OMP THREADPRIVATE(load_tmp1) + REAL, SAVE, ALLOCATABLE :: load_tmp2(:) + !$OMP THREADPRIVATE(load_tmp2) + REAL, SAVE, ALLOCATABLE :: load_tmp3(:) + !$OMP THREADPRIVATE(load_tmp3) + REAL, SAVE, ALLOCATABLE :: load_tmp4(:) + !$OMP THREADPRIVATE(load_tmp4) + REAL, SAVE, ALLOCATABLE :: load_tmp5(:) + !$OMP THREADPRIVATE(load_tmp5) + REAL, SAVE, ALLOCATABLE :: load_tmp6(:) + !$OMP THREADPRIVATE(load_tmp6) + REAL, SAVE, ALLOCATABLE :: load_tmp7(:) + !$OMP THREADPRIVATE(load_tmp7) + +!IM ajout variables CFMIP2/CMIP5 + REAL,ALLOCATABLE,SAVE :: topswad_aerop(:), solswad_aerop(:) +!$OMP THREADPRIVATE(topswad_aerop, solswad_aerop) + REAL,ALLOCATABLE,SAVE :: topswai_aerop(:), solswai_aerop(:) +!$OMP THREADPRIVATE(topswai_aerop, solswai_aerop) + REAL,ALLOCATABLE,SAVE :: topswad0_aerop(:), solswad0_aerop(:) +!$OMP THREADPRIVATE(topswad0_aerop, solswad0_aerop) + REAL,ALLOCATABLE,SAVE :: topsw_aerop(:,:), topsw0_aerop(:,:) +!$OMP THREADPRIVATE(topsw_aerop, topsw0_aerop) + REAL,ALLOCATABLE,SAVE :: solsw_aerop(:,:), solsw0_aerop(:,:) +!$OMP THREADPRIVATE(solsw_aerop, solsw0_aerop) + REAL,ALLOCATABLE,SAVE :: topswcf_aerop(:,:), solswcf_aerop(:,:) +!$OMP THREADPRIVATE(topswcf_aerop, solswcf_aerop) + +CONTAINS + +!====================================================================== +SUBROUTINE phys_local_var_init +use dimphy +use infotrac, ONLY : nbtr +USE aero_mod + +IMPLICIT NONE +#include "indicesol.h" + allocate(t_seri(klon,klev),q_seri(klon,klev),ql_seri(klon,klev),qs_seri(klon,klev)) + allocate(u_seri(klon,klev),v_seri(klon,klev)) + + allocate(tr_seri(klon,klev,nbtr)) + allocate(d_t_dyn(klon,klev),d_q_dyn(klon,klev)) + allocate(d_u_dyn(klon,klev),d_v_dyn(klon,klev)) + allocate(d_t_con(klon,klev),d_q_con(klon,klev)) + allocate(d_u_con(klon,klev),d_v_con(klon,klev)) + allocate(d_t_wake(klon,klev),d_q_wake(klon,klev)) + allocate(d_t_lsc(klon,klev),d_q_lsc(klon,klev)) + allocate(d_ql_lsc(klon,klev)) + allocate(d_t_ajsb(klon,klev),d_q_ajsb(klon,klev)) + allocate(d_t_ajs(klon,klev),d_q_ajs(klon,klev)) + allocate(d_u_ajs(klon,klev),d_v_ajs(klon,klev)) + allocate(d_t_eva(klon,klev),d_q_eva(klon,klev)) + allocate(d_t_lscst(klon,klev),d_q_lscst(klon,klev)) + allocate(d_t_lscth(klon,klev),d_q_lscth(klon,klev)) + allocate(plul_st(klon),plul_th(klon)) + allocate(d_t_vdf(klon,klev),d_q_vdf(klon,klev)) + allocate(d_u_vdf(klon,klev),d_v_vdf(klon,klev)) + allocate(d_t_oli(klon,klev),d_t_oro(klon,klev)) + allocate(d_u_oli(klon,klev),d_v_oli(klon,klev)) + allocate(d_u_oro(klon,klev),d_v_oro(klon,klev)) + allocate(d_t_lif(klon,klev),d_t_ec(klon,klev)) + allocate(d_u_lif(klon,klev),d_v_lif(klon,klev)) + allocate(d_ts(klon,nbsrf), d_tr(klon,klev,nbtr)) + allocate(topswad_aero(klon), solswad_aero(klon)) + allocate(topswai_aero(klon), solswai_aero(klon)) + allocate(topswad0_aero(klon), solswad0_aero(klon)) + allocate(topsw_aero(klon,naero_grp), solsw_aero(klon,naero_grp)) + allocate(topsw0_aero(klon,naero_grp), solsw0_aero(klon,naero_grp)) + allocate(topswcf_aero(klon,3), solswcf_aero(klon,3)) + allocate(d_u_hin(klon,klev),d_v_hin(klon,klev),d_t_hin(klon,klev)) + allocate(tausum_aero(klon,nwave,naero_spc)) + allocate(tau3d_aero(klon,klev,nwave,naero_spc)) + allocate(scdnc(klon, klev)) + allocate(cldncl(klon)) + allocate(reffclwtop(klon)) + allocate(lcc(klon)) + allocate(reffclws(klon, klev)) + allocate(reffclwc(klon, klev)) + allocate(cldnvi(klon)) + allocate(lcc3d(klon, klev)) + allocate(lcc3dcon(klon, klev)) + allocate(lcc3dstra(klon, klev)) + allocate(od550aer(klon)) + allocate(od865aer(klon)) + allocate(absvisaer(klon)) + allocate(ec550aer(klon,klev)) + allocate(od550lt1aer(klon)) + allocate(sconcso4(klon)) + allocate(sconcoa(klon)) + allocate(sconcbc(klon)) + allocate(sconcss(klon)) + allocate(sconcdust(klon)) + allocate(concso4(klon,klev)) + allocate(concoa(klon,klev)) + allocate(concbc(klon,klev)) + allocate(concss(klon,klev)) + allocate(concdust(klon,klev)) + allocate(loadso4(klon)) + allocate(loadoa(klon)) + allocate(loadbc(klon)) + allocate(loadss(klon)) + allocate(loaddust(klon)) + allocate(load_tmp1(klon)) + allocate(load_tmp2(klon)) + allocate(load_tmp3(klon)) + allocate(load_tmp4(klon)) + allocate(load_tmp5(klon)) + allocate(load_tmp6(klon)) + allocate(load_tmp7(klon)) + +!IM ajout variables CFMIP2/CMIP5 + ALLOCATE(topswad_aerop(klon), solswad_aerop(klon)) + ALLOCATE(topswai_aerop(klon), solswai_aerop(klon)) + ALLOCATE(topswad0_aerop(klon), solswad0_aerop(klon)) + ALLOCATE(topsw_aerop(klon,naero_grp), topsw0_aerop(klon,naero_grp)) + ALLOCATE(solsw_aerop(klon,naero_grp), solsw0_aerop(klon,naero_grp)) + ALLOCATE(topswcf_aerop(klon,naero_grp), solswcf_aerop(klon,naero_grp)) + +END SUBROUTINE phys_local_var_init + +!====================================================================== +SUBROUTINE phys_local_var_end +use dimphy +IMPLICIT NONE +#include "indicesol.h" + deallocate(t_seri,q_seri,ql_seri,qs_seri) + deallocate(u_seri,v_seri) + + deallocate(tr_seri) + deallocate(d_t_dyn,d_q_dyn) + deallocate(d_u_dyn,d_v_dyn) + deallocate(d_t_con,d_q_con) + deallocate(d_u_con,d_v_con) + deallocate(d_t_wake,d_q_wake) + deallocate(d_t_lsc,d_q_lsc) + deallocate(d_ql_lsc) + deallocate(d_t_ajsb,d_q_ajsb) + deallocate(d_t_ajs,d_q_ajs) + deallocate(d_u_ajs,d_v_ajs) + deallocate(d_t_eva,d_q_eva) + deallocate(d_t_lscst,d_q_lscst) + deallocate(d_t_lscth,d_q_lscth) + deallocate(plul_st,plul_th) + deallocate(d_t_vdf,d_q_vdf) + deallocate(d_u_vdf,d_v_vdf) + deallocate(d_t_oli,d_t_oro) + deallocate(d_u_oli,d_v_oli) + deallocate(d_u_oro,d_v_oro) + deallocate(d_t_lif,d_t_ec) + deallocate(d_u_lif,d_v_lif) + deallocate(d_ts, d_tr) + deallocate(topswad_aero,solswad_aero) + deallocate(topswai_aero,solswai_aero) + deallocate(topswad0_aero,solswad0_aero) + deallocate(topsw_aero,solsw_aero) + deallocate(topsw0_aero,solsw0_aero) + deallocate(topswcf_aero,solswcf_aero) + deallocate(tausum_aero) + deallocate(tau3d_aero) + deallocate(scdnc) + deallocate(cldncl) + deallocate(reffclwtop) + deallocate(lcc) + deallocate(reffclws) + deallocate(reffclwc) + deallocate(cldnvi) + deallocate(lcc3d) + deallocate(lcc3dcon) + deallocate(lcc3dstra) + deallocate(od550aer) + deallocate(od865aer) + deallocate(absvisaer) + deallocate(ec550aer) + deallocate(od550lt1aer) + deallocate(sconcso4) + deallocate(sconcoa) + deallocate(sconcbc) + deallocate(sconcss) + deallocate(sconcdust) + deallocate(concso4) + deallocate(concoa) + deallocate(concbc) + deallocate(concss) + deallocate(concdust) + deallocate(loadso4) + deallocate(loadoa) + deallocate(loadbc) + deallocate(loadss) + deallocate(loaddust) + deallocate(load_tmp1) + deallocate(load_tmp2) + deallocate(load_tmp3) + deallocate(load_tmp4) + deallocate(load_tmp5) + deallocate(load_tmp6) + deallocate(load_tmp7) + deallocate(d_u_hin,d_v_hin,d_t_hin) + +!IM ajout variables CFMIP2/CMIP5 + deallocate(topswad_aerop, solswad_aerop) + deallocate(topswai_aerop, solswai_aerop) + deallocate(topswad0_aerop, solswad0_aerop) + deallocate(topsw_aerop, topsw0_aerop) + deallocate(solsw_aerop, solsw0_aerop) + deallocate(topswcf_aerop, solswcf_aerop) + +END SUBROUTINE phys_local_var_end + +END MODULE phys_local_var_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_mod.F90 (revision 1634) @@ -0,0 +1,1869 @@ +! $Id$ +! +! Abderrahmane 12 2007 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! Ecreture des Sorties du modele dans les fichiers Netcdf : +! histmth.nc : moyennes mensuelles +! histday.nc : moyennes journalieres +! histhf.nc : moyennes toutes les 3 heures +! histins.nc : valeurs instantanees +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MODULE phys_output_mod + + IMPLICIT NONE + + private histdef2d, histdef3d, conf_physoutputs + + + integer, parameter :: nfiles = 6 + logical, dimension(nfiles), save :: clef_files + logical, dimension(nfiles), save :: clef_stations + integer, dimension(nfiles), save :: lev_files + integer, dimension(nfiles), save :: nid_files + integer, dimension(nfiles), save :: nnid_files +!!$OMP THREADPRIVATE(clef_files, clef_stations, lev_files,nid_files,nnid_files) + integer, dimension(nfiles), private, save :: nnhorim + + integer, dimension(nfiles), private, save :: nhorim, nvertm + integer, dimension(nfiles), private, save :: nvertap, nvertbp, nvertAlt +! integer, dimension(nfiles), private, save :: nvertp0 + real, dimension(nfiles), private, save :: zoutm + real, private, save :: zdtime + CHARACTER(len=20), dimension(nfiles), private, save :: type_ecri +!$OMP THREADPRIVATE(nhorim, nvertm, zoutm,zdtime,type_ecri) + +! integer, save :: nid_hf3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Definition pour chaque variable du niveau d ecriture dans chaque fichier +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!/ histmth, histday, histhf, histins /),'!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer, private:: levmin(nfiles) = 1 + integer, private:: levmax(nfiles) + + TYPE ctrl_out + integer,dimension(6) :: flag + character(len=20) :: name + END TYPE ctrl_out + +!!! Comosentes de la coordonnee sigma-hybride +!!! Ap et Bp + type(ctrl_out),save :: o_Ahyb = ctrl_out((/ 1, 1, 1, 1, 1, 1 /), 'Ap') + type(ctrl_out),save :: o_Bhyb = ctrl_out((/ 1, 1, 1, 1, 1, 1 /), 'Bp') + type(ctrl_out),save :: o_Alt = ctrl_out((/ 1, 1, 1, 1, 1, 1 /), 'Alt') + +!!! 1D + type(ctrl_out),save :: o_phis = ctrl_out((/ 1, 1, 10, 5, 1, 1 /), 'phis') + type(ctrl_out),save :: o_aire = ctrl_out((/ 1, 1, 10, 10, 1, 1 /),'aire') + type(ctrl_out),save :: o_contfracATM = ctrl_out((/ 10, 1, 1, 10, 10, 10 /),'contfracATM') + type(ctrl_out),save :: o_contfracOR = ctrl_out((/ 10, 1, 1, 10, 10, 10 /),'contfracOR') + type(ctrl_out),save :: o_aireTER = ctrl_out((/ 10, 10, 1, 10, 10, 10 /),'aireTER') + +!!! 2D + type(ctrl_out),save :: o_flat = ctrl_out((/ 5, 1, 10, 10, 5, 10 /),'flat') + type(ctrl_out),save :: o_slp = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'slp') + type(ctrl_out),save :: o_tsol = ctrl_out((/ 1, 1, 1, 5, 10, 10 /),'tsol') + type(ctrl_out),save :: o_t2m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /),'t2m') + type(ctrl_out),save :: o_t2m_min = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'t2m_min') + type(ctrl_out),save :: o_t2m_max = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'t2m_max') + type(ctrl_out),save,dimension(4) :: o_t2m_srf = (/ ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'t2m_ter'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'t2m_lic'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'t2m_oce'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'t2m_sic') /) + + type(ctrl_out),save :: o_wind10m = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'wind10m') + type(ctrl_out),save :: o_wind10max = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'wind10max') + type(ctrl_out),save :: o_sicf = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'sicf') + type(ctrl_out),save :: o_q2m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /),'q2m') + type(ctrl_out),save :: o_u10m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /),'u10m') + type(ctrl_out),save :: o_v10m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /),'v10m') + type(ctrl_out),save :: o_psol = ctrl_out((/ 1, 1, 1, 5, 10, 10 /),'psol') + type(ctrl_out),save :: o_qsurf = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'qsurf') + + type(ctrl_out),save,dimension(4) :: o_u10m_srf = (/ ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_ter'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_lic'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_oce'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_sic') /) + + type(ctrl_out),save,dimension(4) :: o_v10m_srf = (/ ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_ter'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_lic'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_oce'), & + ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_sic') /) + + type(ctrl_out),save :: o_qsol = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'qsol') + + type(ctrl_out),save :: o_ndayrain = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'ndayrain') + type(ctrl_out),save :: o_precip = ctrl_out((/ 1, 1, 1, 10, 5, 10 /),'precip') + type(ctrl_out),save :: o_plul = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'plul') + + type(ctrl_out),save :: o_pluc = ctrl_out((/ 1, 1, 1, 10, 5, 10 /),'pluc') + type(ctrl_out),save :: o_snow = ctrl_out((/ 1, 1, 10, 10, 5, 10 /),'snow') + type(ctrl_out),save :: o_evap = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'evap') + type(ctrl_out),save,dimension(4) :: o_evap_srf = (/ ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_ter'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_lic'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_oce'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_sic') /) + type(ctrl_out),save :: o_msnow = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'msnow') + type(ctrl_out),save :: o_fsnow = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsnow') + + type(ctrl_out),save :: o_tops = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'tops') + type(ctrl_out),save :: o_tops0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'tops0') + type(ctrl_out),save :: o_topl = ctrl_out((/ 1, 1, 10, 5, 10, 10 /),'topl') + type(ctrl_out),save :: o_topl0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'topl0') + type(ctrl_out),save :: o_SWupTOA = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'SWupTOA') + type(ctrl_out),save :: o_SWupTOAclr = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'SWupTOAclr') + type(ctrl_out),save :: o_SWdnTOA = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'SWdnTOA') + type(ctrl_out),save :: o_SWdnTOAclr = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'SWdnTOAclr') + type(ctrl_out),save :: o_nettop = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'nettop') + + type(ctrl_out),save :: o_SWup200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'SWup200') + type(ctrl_out),save :: o_SWup200clr = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'SWup200clr') + type(ctrl_out),save :: o_SWdn200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'SWdn200') + type(ctrl_out),save :: o_SWdn200clr = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'SWdn200clr') + +! arajouter +! type(ctrl_out),save :: o_LWupTOA = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWupTOA') +! type(ctrl_out),save :: o_LWupTOAclr = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWupTOAclr') +! type(ctrl_out),save :: o_LWdnTOA = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWdnTOA') +! type(ctrl_out),save :: o_LWdnTOAclr = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWdnTOAclr') + + type(ctrl_out),save :: o_LWup200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'LWup200') + type(ctrl_out),save :: o_LWup200clr = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'LWup200clr') + type(ctrl_out),save :: o_LWdn200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'LWdn200') + type(ctrl_out),save :: o_LWdn200clr = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'LWdn200clr') + type(ctrl_out),save :: o_sols = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'sols') + type(ctrl_out),save :: o_sols0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'sols0') + type(ctrl_out),save :: o_soll = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'soll') + type(ctrl_out),save :: o_soll0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'soll0') + type(ctrl_out),save :: o_radsol = ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'radsol') + type(ctrl_out),save :: o_SWupSFC = ctrl_out((/ 1, 4, 10, 10, 5, 10 /),'SWupSFC') + type(ctrl_out),save :: o_SWupSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /),'SWupSFCclr') + type(ctrl_out),save :: o_SWdnSFC = ctrl_out((/ 1, 1, 10, 10, 5, 10 /),'SWdnSFC') + type(ctrl_out),save :: o_SWdnSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /),'SWdnSFCclr') + type(ctrl_out),save :: o_LWupSFC = ctrl_out((/ 1, 4, 10, 10, 5, 10 /),'LWupSFC') + type(ctrl_out),save :: o_LWupSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /),'LWupSFCclr') + type(ctrl_out),save :: o_LWdnSFC = ctrl_out((/ 1, 4, 10, 10, 5, 10 /),'LWdnSFC') + type(ctrl_out),save :: o_LWdnSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /),'LWdnSFCclr') + type(ctrl_out),save :: o_bils = ctrl_out((/ 1, 2, 10, 5, 10, 10 /),'bils') + type(ctrl_out),save :: o_sens = ctrl_out((/ 1, 1, 10, 10, 5, 10 /),'sens') + type(ctrl_out),save :: o_fder = ctrl_out((/ 1, 2, 10, 10, 10, 10 /),'fder') + type(ctrl_out),save :: o_ffonte = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'ffonte') + type(ctrl_out),save :: o_fqcalving = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fqcalving') + type(ctrl_out),save :: o_fqfonte = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fqfonte') + + type(ctrl_out),save :: o_taux = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'taux') + type(ctrl_out),save :: o_tauy = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'tauy') + type(ctrl_out),save,dimension(4) :: o_taux_srf = (/ ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_ter'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_lic'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_oce'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_sic') /) + + type(ctrl_out),save,dimension(4) :: o_tauy_srf = (/ ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_ter'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_lic'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_oce'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_sic') /) + + + type(ctrl_out),save,dimension(4) :: o_pourc_srf = (/ ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_ter'), & + ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_lic'), & + ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_oce'), & + ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_sic') /) + + type(ctrl_out),save,dimension(4) :: o_fract_srf = (/ ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_ter'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_lic'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_oce'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_sic') /) + + type(ctrl_out),save,dimension(4) :: o_tsol_srf = (/ ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_ter'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_lic'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_oce'), & + ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_sic') /) + + type(ctrl_out),save,dimension(4) :: o_sens_srf = (/ ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_ter'), & + ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_lic'), & + ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_oce'), & + ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_sic') /) + + type(ctrl_out),save,dimension(4) :: o_lat_srf = (/ ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_ter'), & + ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_lic'), & + ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_oce'), & + ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_sic') /) + + type(ctrl_out),save,dimension(4) :: o_flw_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_sic') /) + + type(ctrl_out),save,dimension(4) :: o_fsw_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_sic') /) + + type(ctrl_out),save,dimension(4) :: o_wbils_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_sic') /) + + type(ctrl_out),save,dimension(4) :: o_wbilo_srf = (/ ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_ter'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_lic'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_oce'), & + ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_sic') /) + + + type(ctrl_out),save :: o_cdrm = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'cdrm') + type(ctrl_out),save :: o_cdrh = ctrl_out((/ 1, 10, 10, 7, 10, 10 /),'cdrh') + type(ctrl_out),save :: o_cldl = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'cldl') + type(ctrl_out),save :: o_cldm = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'cldm') + type(ctrl_out),save :: o_cldh = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'cldh') + type(ctrl_out),save :: o_cldt = ctrl_out((/ 1, 1, 2, 10, 5, 10 /),'cldt') + type(ctrl_out),save :: o_cldq = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'cldq') + type(ctrl_out),save :: o_lwp = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'lwp') + type(ctrl_out),save :: o_iwp = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'iwp') + type(ctrl_out),save :: o_ue = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'ue') + type(ctrl_out),save :: o_ve = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'ve') + type(ctrl_out),save :: o_uq = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'uq') + type(ctrl_out),save :: o_vq = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'vq') + + type(ctrl_out),save :: o_cape = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'cape') + type(ctrl_out),save :: o_pbase = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'pbase') + type(ctrl_out),save :: o_ptop = ctrl_out((/ 1, 5, 10, 10, 10, 10 /),'ptop') + type(ctrl_out),save :: o_fbase = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fbase') + type(ctrl_out),save :: o_plcl = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'plcl') + type(ctrl_out),save :: o_plfc = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'plfc') + type(ctrl_out),save :: o_wbeff = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbeff') + type(ctrl_out),save :: o_prw = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'prw') + + type(ctrl_out),save :: o_s_pblh = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_pblh') + type(ctrl_out),save :: o_s_pblt = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_pblt') + type(ctrl_out),save :: o_s_lcl = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_lcl') + type(ctrl_out),save :: o_s_therm = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_therm') +!IM : Les champs suivants (s_capCL, s_oliqCL, s_cteiCL, s_trmb1, s_trmb2, s_trmb3) ne sont pas definis dans HBTM.F +! type(ctrl_out),save :: o_s_capCL = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_capCL') +! type(ctrl_out),save :: o_s_oliqCL = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_oliqCL') +! type(ctrl_out),save :: o_s_cteiCL = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_cteiCL') +! type(ctrl_out),save :: o_s_trmb1 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_trmb1') +! type(ctrl_out),save :: o_s_trmb2 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_trmb2') +! type(ctrl_out),save :: o_s_trmb3 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_trmb3') + + type(ctrl_out),save :: o_slab_bils = ctrl_out((/ 1, 1, 10, 10, 10, 10 /),'slab_bils_oce') + + type(ctrl_out),save :: o_ale_bl = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'ale_bl') + type(ctrl_out),save :: o_alp_bl = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'alp_bl') + type(ctrl_out),save :: o_ale_wk = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'ale_wk') + type(ctrl_out),save :: o_alp_wk = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'alp_wk') + + type(ctrl_out),save :: o_ale = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'ale') + type(ctrl_out),save :: o_alp = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'alp') + type(ctrl_out),save :: o_cin = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'cin') + type(ctrl_out),save :: o_wape = ctrl_out((/ 1, 1, 1, 10, 10, 10 /),'wape') + + +! Champs interpolles sur des niveaux de pression ??? a faire correctement + + type(ctrl_out),save,dimension(7) :: o_uSTDlevs = (/ ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u850'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u700'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u500'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u200'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u100'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u50'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u10') /) + + + type(ctrl_out),save,dimension(7) :: o_vSTDlevs = (/ ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v850'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v700'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v500'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v200'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v100'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v50'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v10') /) + + type(ctrl_out),save,dimension(7) :: o_wSTDlevs = (/ ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w850'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w700'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w500'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w200'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w100'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w50'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w10') /) + + type(ctrl_out),save,dimension(7) :: o_tSTDlevs = (/ ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t850'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t700'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t500'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t200'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t100'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t50'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t10') /) + + type(ctrl_out),save,dimension(7) :: o_qSTDlevs = (/ ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q850'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q700'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q500'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q200'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q100'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q50'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q10') /) + + type(ctrl_out),save,dimension(7) :: o_zSTDlevs = (/ ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z850'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z700'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z500'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z200'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z100'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z50'), & + ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z10') /) + + + type(ctrl_out),save :: o_t_oce_sic = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'t_oce_sic') + + type(ctrl_out),save :: o_weakinv = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'weakinv') + type(ctrl_out),save :: o_dthmin = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'dthmin') + type(ctrl_out),save,dimension(4) :: o_u10_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_sic') /) + + type(ctrl_out),save,dimension(4) :: o_v10_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_sic') /) + + type(ctrl_out),save :: o_cldtau = ctrl_out((/ 10, 5, 10, 10, 10, 10 /),'cldtau') + type(ctrl_out),save :: o_cldemi = ctrl_out((/ 10, 5, 10, 10, 10, 10 /),'cldemi') + type(ctrl_out),save :: o_rh2m = ctrl_out((/ 5, 5, 10, 10, 10, 10 /),'rh2m') + type(ctrl_out),save :: o_rh2m_min = ctrl_out((/ 10, 5, 10, 10, 10, 10 /),'rh2m_min') + type(ctrl_out),save :: o_rh2m_max = ctrl_out((/ 10, 5, 10, 10, 10, 10 /),'rh2m_max') + type(ctrl_out),save :: o_qsat2m = ctrl_out((/ 10, 5, 10, 10, 10, 10 /),'qsat2m') + type(ctrl_out),save :: o_tpot = ctrl_out((/ 10, 5, 10, 10, 10, 10 /),'tpot') + type(ctrl_out),save :: o_tpote = ctrl_out((/ 10, 5, 10, 10, 10, 10 /),'tpote') + type(ctrl_out),save :: o_tke = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tke ') + type(ctrl_out),save :: o_tke_max = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tke_max') + + type(ctrl_out),save,dimension(4) :: o_tke_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_sic') /) + + type(ctrl_out),save,dimension(4) :: o_tke_max_srf = (/ ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_ter'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_lic'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_oce'), & + ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_sic') /) + + type(ctrl_out),save :: o_kz = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'kz') + type(ctrl_out),save :: o_kz_max = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'kz_max') + type(ctrl_out),save :: o_SWnetOR = ctrl_out((/ 10, 10, 2, 10, 10, 10 /),'SWnetOR') + type(ctrl_out),save :: o_SWdownOR = ctrl_out((/ 10, 10, 2, 10, 10, 10 /),'SWdownOR') + type(ctrl_out),save :: o_LWdownOR = ctrl_out((/ 10, 10, 2, 10, 10, 10 /),'LWdownOR') + + type(ctrl_out),save :: o_snowl = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'snowl') + type(ctrl_out),save :: o_cape_max = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'cape_max') + type(ctrl_out),save :: o_solldown = ctrl_out((/ 10, 1, 10, 10, 10, 10 /),'solldown') + + type(ctrl_out),save :: o_dtsvdfo = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dtsvdfo') + type(ctrl_out),save :: o_dtsvdft = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dtsvdft') + type(ctrl_out),save :: o_dtsvdfg = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dtsvdfg') + type(ctrl_out),save :: o_dtsvdfi = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dtsvdfi') + type(ctrl_out),save :: o_rugs = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'rugs') + + type(ctrl_out),save :: o_topswad = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'topswad') + type(ctrl_out),save :: o_topswai = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'topswai') + type(ctrl_out),save :: o_solswad = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'solswad') + type(ctrl_out),save :: o_solswai = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'solswai') + + type(ctrl_out),save,dimension(10) :: o_tausumaero = (/ ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASBCM'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASPOMM'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASSO4M'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_CSSO4M'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_SSSSM'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASSSM'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_CSSSM'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_CIDUSTM'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_AIBCM'), & + ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_AIPOMM') /) + + type(ctrl_out),save :: o_od550aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'od550aer') + type(ctrl_out),save :: o_od865aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'od865aer') + type(ctrl_out),save :: o_absvisaer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'absvisaer') + type(ctrl_out),save :: o_od550lt1aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'od550lt1aer') + + type(ctrl_out),save :: o_sconcso4 = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'sconcso4') + type(ctrl_out),save :: o_sconcoa = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'sconcoa') + type(ctrl_out),save :: o_sconcbc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'sconcbc') + type(ctrl_out),save :: o_sconcss = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'sconcss') + type(ctrl_out),save :: o_sconcdust = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'sconcdust') + type(ctrl_out),save :: o_concso4 = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'concso4') + type(ctrl_out),save :: o_concoa = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'concoa') + type(ctrl_out),save :: o_concbc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'concbc') + type(ctrl_out),save :: o_concss = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'concss') + type(ctrl_out),save :: o_concdust = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'concdust') + type(ctrl_out),save :: o_loadso4 = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'loadso4') + type(ctrl_out),save :: o_loadoa = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'loadoa') + type(ctrl_out),save :: o_loadbc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'loadbc') + type(ctrl_out),save :: o_loadss = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'loadss') + type(ctrl_out),save :: o_loaddust = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'loaddust') + + type(ctrl_out),save :: o_swtoaas_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swtoaas_nat') + type(ctrl_out),save :: o_swsrfas_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swsrfas_nat') + type(ctrl_out),save :: o_swtoacs_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swtoacs_nat') + type(ctrl_out),save :: o_swsrfcs_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swsrfcs_nat') + + type(ctrl_out),save :: o_swtoaas_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swtoaas_ant') + type(ctrl_out),save :: o_swsrfas_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swsrfas_ant') + type(ctrl_out),save :: o_swtoacs_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swtoacs_ant') + type(ctrl_out),save :: o_swsrfcs_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swsrfcs_ant') + + type(ctrl_out),save :: o_swtoacf_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swtoacf_nat') + type(ctrl_out),save :: o_swsrfcf_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swsrfcf_nat') + type(ctrl_out),save :: o_swtoacf_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swtoacf_ant') + type(ctrl_out),save :: o_swsrfcf_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swsrfcf_ant') + type(ctrl_out),save :: o_swtoacf_zero = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swtoacf_zero') + type(ctrl_out),save :: o_swsrfcf_zero = ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'swsrfcf_zero') + + type(ctrl_out),save :: o_cldncl = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'cldncl') + type(ctrl_out),save :: o_reffclwtop = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'reffclwtop') + type(ctrl_out),save :: o_cldnvi = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'cldnvi') + type(ctrl_out),save :: o_lcc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'lcc') + + +!!!!!!!!!!!!!!!!!!!!!! 3D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + type(ctrl_out),save :: o_ec550aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'ec550aer') + type(ctrl_out),save :: o_lwcon = ctrl_out((/ 2, 5, 10, 10, 10, 10 /),'lwcon') + type(ctrl_out),save :: o_iwcon = ctrl_out((/ 2, 5, 10, 10, 10, 10 /),'iwcon') + type(ctrl_out),save :: o_temp = ctrl_out((/ 2, 3, 4, 10, 10, 10 /),'temp') + type(ctrl_out),save :: o_theta = ctrl_out((/ 2, 3, 4, 10, 10, 10 /),'theta') + type(ctrl_out),save :: o_ovap = ctrl_out((/ 2, 3, 4, 10, 10, 10 /),'ovap') + type(ctrl_out),save :: o_ovapinit = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'ovapinit') + type(ctrl_out),save :: o_wvapp = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'wvapp') + type(ctrl_out),save :: o_geop = ctrl_out((/ 2, 3, 10, 10, 10, 10 /),'geop') + type(ctrl_out),save :: o_vitu = ctrl_out((/ 2, 3, 4, 6, 10, 10 /),'vitu') + type(ctrl_out),save :: o_vitv = ctrl_out((/ 2, 3, 4, 6, 10, 10 /),'vitv') + type(ctrl_out),save :: o_vitw = ctrl_out((/ 2, 3, 10, 6, 10, 10 /),'vitw') + type(ctrl_out),save :: o_pres = ctrl_out((/ 2, 3, 10, 10, 10, 10 /),'pres') + type(ctrl_out),save :: o_paprs = ctrl_out((/ 2, 3, 10, 10, 10, 10 /),'paprs') + type(ctrl_out),save :: o_mass = ctrl_out((/ 2, 3, 10, 10, 10, 10 /),'mass') + type(ctrl_out),save :: o_zfull = ctrl_out((/ 2, 3, 10, 10, 10, 10 /),'zfull') + type(ctrl_out),save :: o_zhalf = ctrl_out((/ 2, 3, 10, 10, 10, 10 /),'zhalf') + type(ctrl_out),save :: o_rneb = ctrl_out((/ 2, 5, 10, 10, 10, 10 /),'rneb') + type(ctrl_out),save :: o_rnebcon = ctrl_out((/ 2, 5, 10, 10, 10, 10 /),'rnebcon') + type(ctrl_out),save :: o_rhum = ctrl_out((/ 2, 5, 10, 10, 10, 10 /),'rhum') + type(ctrl_out),save :: o_ozone = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'ozone') + type(ctrl_out),save :: o_ozone_light = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'ozone_daylight') + type(ctrl_out),save :: o_upwd = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'upwd') + type(ctrl_out),save :: o_dtphy = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'dtphy') + type(ctrl_out),save :: o_dqphy = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'dqphy') + type(ctrl_out),save :: o_pr_con_l = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'pr_con_l') + type(ctrl_out),save :: o_pr_con_i = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'pr_con_i') + type(ctrl_out),save :: o_pr_lsc_l = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'pr_lsc_l') + type(ctrl_out),save :: o_pr_lsc_i = ctrl_out((/ 2, 10, 10, 10, 10, 10 /),'pr_lsc_i') + type(ctrl_out),save :: o_re = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'re') + type(ctrl_out),save :: o_fl = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'fl') + type(ctrl_out),save :: o_scdnc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'scdnc') + type(ctrl_out),save :: o_reffclws = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'reffclws') + type(ctrl_out),save :: o_reffclwc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'reffclwc') + type(ctrl_out),save :: o_lcc3d = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'lcc3d') + type(ctrl_out),save :: o_lcc3dcon = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'lcc3dcon') + type(ctrl_out),save :: o_lcc3dstra = ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'lcc3dstra') +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type(ctrl_out),save,dimension(4) :: o_albe_srf = (/ ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_ter'), & + ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_lic'), & + ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_oce'), & + ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_sic') /) + + type(ctrl_out),save,dimension(4) :: o_ages_srf = (/ ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'ages_ter'), & + ctrl_out((/ 3, 10, 10, 10, 10, 10 /),'ages_lic'), & + ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'ages_oce'), & + ctrl_out((/ 3, 10, 10, 10, 10, 10 /),'ages_sic') /) + + type(ctrl_out),save,dimension(4) :: o_rugs_srf = (/ ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_ter'), & + ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_lic'), & + ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_oce'), & + ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_sic') /) + + type(ctrl_out),save :: o_alb1 = ctrl_out((/ 3, 10, 10, 10, 10, 10 /),'alb1') + type(ctrl_out),save :: o_alb2 = ctrl_out((/ 3, 10, 10, 10, 10, 10 /),'alb2') + + type(ctrl_out),save :: o_clwcon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'clwcon') + type(ctrl_out),save :: o_Ma = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'Ma') + type(ctrl_out),save :: o_dnwd = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dnwd') + type(ctrl_out),save :: o_dnwd0 = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dnwd0') + type(ctrl_out),save :: o_mc = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'mc') + type(ctrl_out),save :: o_ftime_con = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'ftime_con') + type(ctrl_out),save :: o_dtdyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtdyn') + type(ctrl_out),save :: o_dqdyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dqdyn') + type(ctrl_out),save :: o_dudyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dudyn') !AXC + type(ctrl_out),save :: o_dvdyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dvdyn') !AXC + type(ctrl_out),save :: o_dtcon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtcon') + type(ctrl_out),save :: o_ducon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'ducon') + type(ctrl_out),save :: o_dqcon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dqcon') + type(ctrl_out),save :: o_dtwak = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'dtwak') + type(ctrl_out),save :: o_dqwak = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'dqwak') + type(ctrl_out),save :: o_wake_h = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'wake_h') + type(ctrl_out),save :: o_wake_s = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'wake_s') + type(ctrl_out),save :: o_wake_deltat = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'wake_deltat') + type(ctrl_out),save :: o_wake_deltaq = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'wake_deltaq') + type(ctrl_out),save :: o_wake_omg = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'wake_omg') + type(ctrl_out),save :: o_Vprecip = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'Vprecip') + type(ctrl_out),save :: o_ftd = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'ftd') + type(ctrl_out),save :: o_fqd = ctrl_out((/ 4, 5, 10, 10, 10, 10 /),'fqd') + type(ctrl_out),save :: o_dtlsc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtlsc') + type(ctrl_out),save :: o_dtlschr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtlschr') + type(ctrl_out),save :: o_dqlsc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dqlsc') + type(ctrl_out),save :: o_dtvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtvdf') + type(ctrl_out),save :: o_dqvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dqvdf') + type(ctrl_out),save :: o_dteva = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dteva') + type(ctrl_out),save :: o_dqeva = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dqeva') + +!!!!!!!!!!!!!!!! Specifique thermiques + type(ctrl_out),save :: o_dqlscth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dqlscth') + type(ctrl_out),save :: o_dqlscst = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dqlscst') + type(ctrl_out),save :: o_dtlscth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dtlscth') + type(ctrl_out),save :: o_dtlscst = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'dtlscst') + type(ctrl_out),save :: o_plulth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'plulth') + type(ctrl_out),save :: o_plulst = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'plulst') + type(ctrl_out),save :: o_lmaxth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'lmaxth') + type(ctrl_out),save :: o_ptconvth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'ptconvth') +!!!!!!!!!!!!!!!!!!!!!!!! + + + type(ctrl_out),save :: o_ptconv = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'ptconv') + type(ctrl_out),save :: o_ratqs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'ratqs') + type(ctrl_out),save :: o_dtthe = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtthe') + type(ctrl_out),save :: o_f_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'f_th') + type(ctrl_out),save :: o_e_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'e_th') + type(ctrl_out),save :: o_w_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'w_th') + type(ctrl_out),save :: o_lambda_th = ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'lambda_th') + type(ctrl_out),save :: o_ftime_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'ftime_th') + type(ctrl_out),save :: o_q_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'q_th') + type(ctrl_out),save :: o_a_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'a_th') + type(ctrl_out),save :: o_d_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'d_th') + type(ctrl_out),save :: o_f0_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'f0_th') + type(ctrl_out),save :: o_zmax_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'zmax_th') + type(ctrl_out),save :: o_dqthe = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dqthe') + type(ctrl_out),save :: o_dtajs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtajs') + type(ctrl_out),save :: o_dqajs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dqajs') + type(ctrl_out),save :: o_dtswr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtswr') + type(ctrl_out),save :: o_dtsw0 = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtsw0') + type(ctrl_out),save :: o_dtlwr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtlwr') + type(ctrl_out),save :: o_dtlw0 = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtlw0') + type(ctrl_out),save :: o_dtec = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtec') + type(ctrl_out),save :: o_duvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'duvdf') + type(ctrl_out),save :: o_dvvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dvvdf') + type(ctrl_out),save :: o_duoro = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'duoro') + type(ctrl_out),save :: o_dvoro = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dvoro') + type(ctrl_out),save :: o_dulif = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dulif') + type(ctrl_out),save :: o_dvlif = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dvlif') + type(ctrl_out),save :: o_duhin = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'duhin') + type(ctrl_out),save :: o_dvhin = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dvhin') + type(ctrl_out),save :: o_dtoro = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtoro') + type(ctrl_out),save :: o_dtlif = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dtlif') + type(ctrl_out),save :: o_dthin = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dthin') + + type(ctrl_out),save,allocatable :: o_trac(:) + + type(ctrl_out),save :: o_rsu = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rsu') + type(ctrl_out),save :: o_rsd = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rsd') + type(ctrl_out),save :: o_rlu = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rlu') + type(ctrl_out),save :: o_rld = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rld') + type(ctrl_out),save :: o_rsucs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rsucs') + type(ctrl_out),save :: o_rsdcs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rsdcs') + type(ctrl_out),save :: o_rlucs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rlucs') + type(ctrl_out),save :: o_rldcs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'rldcs') + + type(ctrl_out),save :: o_tnt = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tnt') + type(ctrl_out),save :: o_tntc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tntc') + type(ctrl_out),save :: o_tntr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tntr') + type(ctrl_out),save :: o_tntscpbl = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tntscpbl') + + type(ctrl_out),save :: o_tnhus = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tnhus') + type(ctrl_out),save :: o_tnhusc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tnhusc') + type(ctrl_out),save :: o_tnhusscpbl = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'tnhusscpbl') + + type(ctrl_out),save :: o_evu = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'evu') + + type(ctrl_out),save :: o_h2o = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'h2o') + + type(ctrl_out),save :: o_mcd = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'mcd') + type(ctrl_out),save :: o_dmc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'dmc') + type(ctrl_out),save :: o_ref_liq = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'ref_liq') + type(ctrl_out),save :: o_ref_ice = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),'ref_ice') + + type(ctrl_out),save :: o_rsut4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rsut4co2') + type(ctrl_out),save :: o_rlut4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rlut4co2') + type(ctrl_out),save :: o_rsutcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rsutcs4co2') + type(ctrl_out),save :: o_rlutcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rlutcs4co2') + + type(ctrl_out),save :: o_rsu4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rsu4co2') + type(ctrl_out),save :: o_rlu4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rlu4co2') + type(ctrl_out),save :: o_rsucs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rsucs4co2') + type(ctrl_out),save :: o_rlucs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rlucs4co2') + type(ctrl_out),save :: o_rsd4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rsd4co2') + type(ctrl_out),save :: o_rld4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rld4co2') + type(ctrl_out),save :: o_rsdcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rsdcs4co2') + type(ctrl_out),save :: o_rldcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /),'rldcs4co2') + + + CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!! Ouverture des fichier et definition des variable de sortie !!!!!!!! +!! histbeg, histvert et histdef +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE phys_output_open(rlon,rlat,pim,tabij,ipt,jpt,plon,plat, & + jjmp1,nlevSTD,clevSTD,nbteta, & + ctetaSTD, dtime, ok_veget, & + type_ocean, iflag_pbl,ok_mensuel,ok_journe, & + ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, read_climoz, & + phys_out_filestations, & + new_aod, aerosol_couple) + + USE iophy + USE dimphy + USE infotrac + USE ioipsl + USE mod_phys_lmdz_para + USE aero_mod, only : naero_spc,name_aero + + IMPLICIT NONE + include "dimensions.h" + include "temps.h" + include "indicesol.h" + include "clesphys.h" + include "thermcell.h" + include "comvert.h" + + real,dimension(klon),intent(in) :: rlon + real,dimension(klon),intent(in) :: rlat + integer, intent(in) :: pim + INTEGER, DIMENSION(pim) :: tabij + INTEGER,dimension(pim), intent(in) :: ipt, jpt + REAL,dimension(pim), intent(in) :: plat, plon + REAL,dimension(pim,2) :: plat_bounds, plon_bounds + + integer :: jjmp1 + integer :: nbteta, nlevSTD, radpas + logical :: ok_mensuel, ok_journe, ok_hf, ok_instan + logical :: ok_LES,ok_ade,ok_aie + logical :: new_aod, aerosol_couple + integer, intent(in):: read_climoz ! read ozone climatology + ! Allowed values are 0, 1 and 2 + ! 0: do not read an ozone climatology + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + + real :: dtime + integer :: idayref + real :: zjulian + real, dimension(klev) :: Ahyb, Bhyb, Alt + character(len=4), dimension(nlevSTD) :: clevSTD + integer :: nsrf, k, iq, iiq, iff, i, j, ilev + integer :: naero + logical :: ok_veget + integer :: iflag_pbl + CHARACTER(len=4) :: bb2 + CHARACTER(len=2) :: bb3 + character(len=6) :: type_ocean + CHARACTER(len=3) :: ctetaSTD(nbteta) + real, dimension(nfiles) :: ecrit_files + CHARACTER(len=20), dimension(nfiles) :: phys_out_filenames + INTEGER, dimension(iim*jjmp1) :: ndex2d + INTEGER, dimension(iim*jjmp1*klev) :: ndex3d + integer :: imin_ins, imax_ins + integer :: jmin_ins, jmax_ins + integer, dimension(nfiles) :: phys_out_levmin, phys_out_levmax + integer, dimension(nfiles) :: phys_out_filelevels + CHARACTER(len=20), dimension(nfiles) :: type_ecri_files, phys_out_filetypes + character(len=20), dimension(nfiles) :: chtimestep = (/ 'DefFreq', 'DefFreq','DefFreq', 'DefFreq', 'DefFreq', 'DefFreq' /) + logical, dimension(nfiles) :: phys_out_filekeys + logical, dimension(nfiles) :: phys_out_filestations + +!!!!!!!!!! stockage dans une region limitee pour chaque fichier !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! entre [phys_out_lonmin,phys_out_lonmax] et [phys_out_latmin,phys_out_latmax] + + logical, dimension(nfiles), save :: phys_out_regfkey = (/ .false., .false., .false., .false., .false., .false. /) + real, dimension(nfiles), save :: phys_out_lonmin = (/ -180., -180., -180., -180., -180., -180. /) + real, dimension(nfiles), save :: phys_out_lonmax = (/ 180., 180., 180., 180., 180., 180. /) + real, dimension(nfiles), save :: phys_out_latmin = (/ -90., -90., -90., -90., -90., -90. /) + real, dimension(nfiles), save :: phys_out_latmax = (/ 90., 90., 90., 90., 90., 90. /) + + print*,'Debut phys_output_mod.F90' +! Initialisations (Valeurs par defaut + + if (.not. allocated(o_trac)) ALLOCATE(o_trac(nqtot)) + + levmax = (/ klev, klev, klev, klev, klev, klev /) + + phys_out_filenames(1) = 'histmth' + phys_out_filenames(2) = 'histday' + phys_out_filenames(3) = 'histhf' + phys_out_filenames(4) = 'histins' + phys_out_filenames(5) = 'histLES' + phys_out_filenames(6) = 'histstn' + + type_ecri(1) = 'ave(X)' + type_ecri(2) = 'ave(X)' + type_ecri(3) = 'ave(X)' + type_ecri(4) = 'inst(X)' + type_ecri(5) = 'ave(X)' + type_ecri(6) = 'inst(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 + +!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. + + 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 + + ecrit_files(1) = ecrit_mth + ecrit_files(2) = ecrit_day + ecrit_files(3) = ecrit_hf + ecrit_files(4) = ecrit_ins + ecrit_files(5) = ecrit_LES + ecrit_files(6) = ecrit_ins + +!! Lectures des parametres de sorties dans physiq.def + + call getin('phys_out_regfkey',phys_out_regfkey) + call getin('phys_out_lonmin',phys_out_lonmin) + call getin('phys_out_lonmax',phys_out_lonmax) + call getin('phys_out_latmin',phys_out_latmin) + call getin('phys_out_latmax',phys_out_latmax) + phys_out_levmin(:)=levmin(:) + call getin('phys_out_levmin',levmin) + phys_out_levmax(:)=levmax(:) + call getin('phys_out_levmax',levmax) + call getin('phys_out_filenames',phys_out_filenames) + phys_out_filekeys(:)=clef_files(:) + call getin('phys_out_filekeys',clef_files) + phys_out_filestations(:)=clef_stations(:) + call getin('phys_out_filestations',clef_stations) + phys_out_filelevels(:)=lev_files(:) + call getin('phys_out_filelevels',lev_files) + call getin('phys_out_filetimesteps',chtimestep) + phys_out_filetypes(:)=type_ecri(:) + call getin('phys_out_filetypes',type_ecri) + + type_ecri_files(:)=type_ecri(:) + + print*,'phys_out_lonmin=',phys_out_lonmin + print*,'phys_out_lonmax=',phys_out_lonmax + print*,'phys_out_latmin=',phys_out_latmin + print*,'phys_out_latmax=',phys_out_latmax + print*,'phys_out_filenames=',phys_out_filenames + print*,'phys_out_filetypes=',type_ecri + print*,'phys_out_filekeys=',clef_files + print*,'phys_out_filestations=',clef_stations + print*,'phys_out_filelevels=',lev_files + +!!!!!!!!!!!!!!!!!!!!!!! Boucle sur les fichiers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Appel de histbeg et histvert pour creer le fichier et les niveaux verticaux !! +! Appel des histbeg pour definir les variables (nom, moy ou inst, freq de sortie .. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + zdtime = dtime ! Frequence ou l on moyenne + +! Calcul des Ahyb, Bhyb et Alt + do k=1,klev + Ahyb(k)=(ap(k)+ap(k+1))/2. + Bhyb(k)=(bp(k)+bp(k+1))/2. + Alt(k)=log(preff/presnivs(k))*8. + enddo +! if(prt_level.ge.1) then + print*,'Ap Hybrid = ',Ahyb(1:klev) + print*,'Bp Hybrid = ',Bhyb(1:klev) + print*,'Alt approx des couches pour une haut d echelle de 8km = ',Alt(1:klev) +! endif + DO iff=1,nfiles + + IF (clef_files(iff)) THEN + + if ( chtimestep(iff).eq.'DefFreq' ) then +! Par defaut ecrit_files = (ecrit_mensuel ecrit_jour ecrit_hf ...)*86400. + ecrit_files(iff)=ecrit_files(iff)*86400. + else + call convers_timesteps(chtimestep(iff),dtime,ecrit_files(iff)) + endif + print*,'ecrit_files(',iff,')= ',ecrit_files(iff) + + zoutm(iff) = ecrit_files(iff) ! Frequence ou l on ecrit en seconde + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + +!!!!!!!!!!!!!!!!! Traitement dans le cas ou l'on veut stocker sur un domaine limite !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (phys_out_regfkey(iff)) then + + imin_ins=1 + imax_ins=iim + jmin_ins=1 + jmax_ins=jjmp1 + +! correction abderr + do i=1,iim + print*,'io_lon(i)=',io_lon(i) + if (io_lon(i).le.phys_out_lonmin(iff)) imin_ins=i + if (io_lon(i).le.phys_out_lonmax(iff)) imax_ins=i+1 + enddo + + do j=1,jjmp1 + print*,'io_lat(j)=',io_lat(j) + if (io_lat(j).ge.phys_out_latmin(iff)) jmax_ins=j+1 + if (io_lat(j).ge.phys_out_latmax(iff)) jmin_ins=j + enddo + + print*,'On stoke le fichier histoire numero ',iff,' sur ', & + imin_ins,imax_ins,jmin_ins,jmax_ins + print*,'longitudes : ', & + io_lon(imin_ins),io_lon(imax_ins), & + 'latitudes : ', & + io_lat(jmax_ins),io_lat(jmin_ins) + + CALL histbeg(phys_out_filenames(iff),iim,io_lon,jjmp1,io_lat, & + imin_ins,imax_ins-imin_ins+1, & + jmin_ins,jmax_ins-jmin_ins+1, & + itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff)) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!IM fichiers stations + else if (clef_stations(iff)) THEN + + print*,'phys_output_mod phys_out_filenames=',phys_out_filenames(iff) + + call histbeg_phy_all(rlon,rlat,pim,tabij,ipt,jpt,plon,plat,plon_bounds,plat_bounds, & + phys_out_filenames(iff), & + itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff)) + else + CALL histbeg_phy(phys_out_filenames(iff),itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff)) + endif + + CALL histvert(nid_files(iff), "presnivs", "Vertical levels", "Pa", & + levmax(iff) - levmin(iff) + 1, & + presnivs(levmin(iff):levmax(iff)), nvertm(iff),"down") + +!!!!!!!!!!!!! Traitement des champs 3D pour histhf !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!! A Revoir plus tard !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! IF (iff.eq.3.and.lev_files(iff).ge.4) THEN +! CALL histbeg_phy("histhf3d",itau_phy, & +! & zjulian, dtime, & +! & nhorim, nid_hf3d) + +! CALL histvert(nid_hf3d, "presnivs", & +! & "Vertical levels", "mb", & +! & klev, presnivs/100., nvertm) +! ENDIF +! +!!!! Composentes de la coordonnee sigma-hybride + CALL histvert(nid_files(iff), "Ahyb","Ahyb comp of Hyb Cord ", "Pa", & + levmax(iff) - levmin(iff) + 1,Ahyb,nvertap(iff)) + + CALL histvert(nid_files(iff), "Bhyb","Bhyb comp of Hyb Cord", " ", & + levmax(iff) - levmin(iff) + 1,Bhyb,nvertbp(iff)) + + CALL histvert(nid_files(iff), "Alt","Height approx for scale heigh of 8km at levels", "Km", & + levmax(iff) - levmin(iff) + 1,Alt,nvertAlt(iff)) + +! CALL histvert(nid_files(iff), "preff","Reference pressure", "Pa", & +! 1,preff,nvertp0(iff)) +!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (.NOT.clef_stations(iff)) THEN +! +!IM: there is no way to have one single value in a netcdf file +! + type_ecri(1) = 'once' + type_ecri(2) = 'once' + type_ecri(3) = 'once' + type_ecri(4) = 'once' + type_ecri(5) = 'once' + type_ecri(6) = 'once' + CALL histdef2d(iff,clef_stations(iff),o_aire%flag,o_aire%name,"Grid area", "-") + CALL histdef2d(iff,clef_stations(iff),o_contfracATM%flag,o_contfracATM%name,"% sfce ter+lic", "-") + ENDIF + type_ecri(:) = type_ecri_files(:) + +!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CALL histdef2d(iff,clef_stations(iff),o_phis%flag,o_phis%name,"Surface geop.height", "m2/s2" ) + CALL histdef2d(iff,clef_stations(iff),o_contfracOR%flag,o_contfracOR%name,"% sfce terre OR", "-" ) + CALL histdef2d(iff,clef_stations(iff),o_aireTER%flag,o_aireTER%name,"Grid area CONT", "-" ) + CALL histdef2d(iff,clef_stations(iff),o_flat%flag,o_flat%name, "Latent heat flux", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_slp%flag,o_slp%name, "Sea Level Pressure", "Pa" ) + CALL histdef2d(iff,clef_stations(iff),o_tsol%flag,o_tsol%name, "Surface Temperature", "K") + CALL histdef2d(iff,clef_stations(iff),o_t2m%flag,o_t2m%name, "Temperature 2m", "K" ) + IF (.NOT.clef_stations(iff)) THEN +! +!IM: there is no way to have one single value in a netcdf file +! + type_ecri(1) = 't_min(X)' + type_ecri(2) = 't_min(X)' + type_ecri(3) = 't_min(X)' + type_ecri(4) = 't_min(X)' + type_ecri(5) = 't_min(X)' + type_ecri(6) = 't_min(X)' + CALL histdef2d(iff,clef_stations(iff),o_t2m_min%flag,o_t2m_min%name, "Temp 2m min", "K" ) + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + type_ecri(6) = 't_max(X)' + CALL histdef2d(iff,clef_stations(iff),o_t2m_max%flag,o_t2m_max%name, "Temp 2m max", "K" ) + ENDIF + type_ecri(:) = type_ecri_files(:) + CALL histdef2d(iff,clef_stations(iff),o_wind10m%flag,o_wind10m%name, "10-m wind speed", "m/s") + CALL histdef2d(iff,clef_stations(iff),o_wind10max%flag,o_wind10max%name, "10m wind speed max", "m/s") + CALL histdef2d(iff,clef_stations(iff),o_sicf%flag,o_sicf%name, "Sea-ice fraction", "-" ) + CALL histdef2d(iff,clef_stations(iff),o_q2m%flag,o_q2m%name, "Specific humidity 2m", "kg/kg") + CALL histdef2d(iff,clef_stations(iff),o_u10m%flag,o_u10m%name, "Vent zonal 10m", "m/s" ) + CALL histdef2d(iff,clef_stations(iff),o_v10m%flag,o_v10m%name, "Vent meridien 10m", "m/s") + CALL histdef2d(iff,clef_stations(iff),o_psol%flag,o_psol%name, "Surface Pressure", "Pa" ) + CALL histdef2d(iff,clef_stations(iff),o_qsurf%flag,o_qsurf%name, "Surface Air humidity", "kg/kg") + + if (.not. ok_veget) then + CALL histdef2d(iff,clef_stations(iff),o_qsol%flag,o_qsol%name, "Soil watter content", "mm" ) + endif + + CALL histdef2d(iff,clef_stations(iff),o_ndayrain%flag,o_ndayrain%name, "Number of dayrain(liq+sol)", "-") + CALL histdef2d(iff,clef_stations(iff),o_precip%flag,o_precip%name, "Precip Totale liq+sol", "kg/(s*m2)" ) + CALL histdef2d(iff,clef_stations(iff),o_plul%flag,o_plul%name, "Large-scale Precip.", "kg/(s*m2)") + CALL histdef2d(iff,clef_stations(iff),o_pluc%flag,o_pluc%name, "Convective Precip.", "kg/(s*m2)") + CALL histdef2d(iff,clef_stations(iff),o_snow%flag,o_snow%name, "Snow fall", "kg/(s*m2)" ) + CALL histdef2d(iff,clef_stations(iff),o_msnow%flag,o_msnow%name, "Surface snow amount", "kg/m2" ) + CALL histdef2d(iff,clef_stations(iff),o_fsnow%flag,o_fsnow%name, "Surface snow area fraction", "-" ) + CALL histdef2d(iff,clef_stations(iff),o_evap%flag,o_evap%name, "Evaporat", "kg/(s*m2)" ) + CALL histdef2d(iff,clef_stations(iff),o_tops%flag,o_tops%name, "Solar rad. at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_tops0%flag,o_tops0%name, "CS Solar rad. at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_topl%flag,o_topl%name, "IR rad. at TOA", "W/m2" ) + CALL histdef2d(iff,clef_stations(iff),o_topl0%flag,o_topl0%name, "IR rad. at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWupTOA%flag,o_SWupTOA%name, "SWup at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWupTOAclr%flag,o_SWupTOAclr%name, "SWup clear sky at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWdnTOA%flag,o_SWdnTOA%name, "SWdn at TOA", "W/m2" ) + CALL histdef2d(iff,clef_stations(iff),o_SWdnTOAclr%flag,o_SWdnTOAclr%name, "SWdn clear sky at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_nettop%flag,o_nettop%name, "Net dn radiatif flux at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWup200%flag,o_SWup200%name, "SWup at 200mb", "W/m2" ) + CALL histdef2d(iff,clef_stations(iff),o_SWup200clr%flag,o_SWup200clr%name, "SWup clear sky at 200mb", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWdn200%flag,o_SWdn200%name, "SWdn at 200mb", "W/m2" ) + CALL histdef2d(iff,clef_stations(iff),o_SWdn200clr%flag,o_SWdn200clr%name, "SWdn clear sky at 200mb", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWup200%flag,o_LWup200%name, "LWup at 200mb", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWup200clr%flag,o_LWup200clr%name, "LWup clear sky at 200mb", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWdn200%flag,o_LWdn200%name, "LWdn at 200mb", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWdn200clr%flag,o_LWdn200clr%name, "LWdn clear sky at 200mb", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_sols%flag,o_sols%name, "Solar rad. at surf.", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_sols0%flag,o_sols0%name, "Solar rad. at surf.", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_soll%flag,o_soll%name, "IR rad. at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_radsol%flag,o_radsol%name, "Rayonnement au sol", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_soll0%flag,o_soll0%name, "IR rad. at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWupSFC%flag,o_SWupSFC%name, "SWup at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWupSFCclr%flag,o_SWupSFCclr%name, "SWup clear sky at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWdnSFC%flag,o_SWdnSFC%name, "SWdn at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWdnSFCclr%flag,o_SWdnSFCclr%name, "SWdn clear sky at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWupSFC%flag,o_LWupSFC%name, "Upwd. IR rad. at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWdnSFC%flag,o_LWdnSFC%name, "Down. IR rad. at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWupSFCclr%flag,o_LWupSFCclr%name, "CS Upwd. IR rad. at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWdnSFCclr%flag,o_LWdnSFCclr%name, "Down. CS IR rad. at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_bils%flag,o_bils%name, "Surf. total heat flux", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_sens%flag,o_sens%name, "Sensible heat flux", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_fder%flag,o_fder%name, "Heat flux derivation", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_ffonte%flag,o_ffonte%name, "Thermal flux for snow melting", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_fqcalving%flag,o_fqcalving%name, "Ice Calving", "kg/m2/s") + CALL histdef2d(iff,clef_stations(iff),o_fqfonte%flag,o_fqfonte%name, "Land ice melt", "kg/m2/s") + + CALL histdef2d(iff,clef_stations(iff),o_taux%flag,o_taux%name, "Zonal wind stress","Pa") + CALL histdef2d(iff,clef_stations(iff),o_tauy%flag,o_tauy%name, "Meridional wind stress","Pa") + + DO nsrf = 1, nbsrf + CALL histdef2d(iff,clef_stations(iff),o_pourc_srf(nsrf)%flag,o_pourc_srf(nsrf)%name,"% "//clnsurf(nsrf),"%") + CALL histdef2d(iff,clef_stations(iff),o_fract_srf(nsrf)%flag,o_fract_srf(nsrf)%name,"Fraction "//clnsurf(nsrf),"1") + CALL histdef2d(iff,clef_stations(iff), & +o_taux_srf(nsrf)%flag,o_taux_srf(nsrf)%name,"Zonal wind stress"//clnsurf(nsrf),"Pa") + CALL histdef2d(iff,clef_stations(iff), & +o_tauy_srf(nsrf)%flag,o_tauy_srf(nsrf)%name,"Meridional wind stress "//clnsurf(nsrf),"Pa") + CALL histdef2d(iff,clef_stations(iff), & +o_tsol_srf(nsrf)%flag,o_tsol_srf(nsrf)%name,"Temperature "//clnsurf(nsrf),"K") + CALL histdef2d(iff,clef_stations(iff), & +o_u10m_srf(nsrf)%flag,o_u10m_srf(nsrf)%name,"Vent Zonal 10m "//clnsurf(nsrf),"m/s") + CALL histdef2d(iff,clef_stations(iff), & +o_evap_srf(nsrf)%flag,o_evap_srf(nsrf)%name,"evaporation at surface "//clnsurf(nsrf),"kg/(s*m2)") + CALL histdef2d(iff,clef_stations(iff), & +o_v10m_srf(nsrf)%flag,o_v10m_srf(nsrf)%name,"Vent meredien 10m "//clnsurf(nsrf),"m/s") + CALL histdef2d(iff,clef_stations(iff), & +o_t2m_srf(nsrf)%flag,o_t2m_srf(nsrf)%name,"Temp 2m "//clnsurf(nsrf),"K") + CALL histdef2d(iff,clef_stations(iff), & +o_sens_srf(nsrf)%flag,o_sens_srf(nsrf)%name,"Sensible heat flux "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_lat_srf(nsrf)%flag,o_lat_srf(nsrf)%name,"Latent heat flux "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_flw_srf(nsrf)%flag,o_flw_srf(nsrf)%name,"LW "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_fsw_srf(nsrf)%flag,o_fsw_srf(nsrf)%name,"SW "//clnsurf(nsrf),"W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_wbils_srf(nsrf)%flag,o_wbils_srf(nsrf)%name,"Bilan sol "//clnsurf(nsrf),"W/m2" ) + CALL histdef2d(iff,clef_stations(iff), & +o_wbilo_srf(nsrf)%flag,o_wbilo_srf(nsrf)%name,"Bilan eau "//clnsurf(nsrf),"kg/(m2*s)") + if (iflag_pbl>1 .and. lev_files(iff).gt.10 ) then + CALL histdef2d(iff,clef_stations(iff), & +o_tke_srf(nsrf)%flag,o_tke_srf(nsrf)%name,"Max Turb. Kinetic Energy "//clnsurf(nsrf),"-") + + IF (.NOT.clef_stations(iff)) THEN +! +!IM: there is no way to have one single value in a netcdf file +! + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + type_ecri(6) = 't_max(X)' + CALL histdef2d(iff,clef_stations(iff), & + o_tke_max_srf(nsrf)%flag,o_tke_max_srf(nsrf)%name,"Max Turb. Kinetic Energy "//clnsurf(nsrf),"-") + type_ecri(:) = type_ecri_files(:) + ENDIF + + endif + + CALL histdef2d(iff,clef_stations(iff), & +o_albe_srf(nsrf)%flag,o_albe_srf(nsrf)%name,"Albedo VIS surf. "//clnsurf(nsrf),"-") + CALL histdef2d(iff,clef_stations(iff), & +o_rugs_srf(nsrf)%flag,o_rugs_srf(nsrf)%name,"Surface roughness "//clnsurf(nsrf),"m") + CALL histdef2d(iff,clef_stations(iff), & +o_ages_srf(nsrf)%flag,o_ages_srf(nsrf)%name,"Snow age", "day") +END DO + +IF (new_aod .AND. (.NOT. aerosol_couple)) THEN + IF (ok_ade.OR.ok_aie) THEN + + CALL histdef2d(iff,clef_stations(iff), & +o_od550aer%flag,o_od550aer%name, "Total aerosol optical depth at 550nm", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_od865aer%flag,o_od865aer%name, "Total aerosol optical depth at 870nm", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_absvisaer%flag,o_absvisaer%name, "Absorption aerosol visible optical depth", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_od550lt1aer%flag,o_od550lt1aer%name, "Fine mode optical depth", "-") + + + CALL histdef2d(iff,clef_stations(iff), & +o_sconcso4%flag,o_sconcso4%name,"Surface Concentration of Sulfate ","kg/m3") + CALL histdef2d(iff,clef_stations(iff), & +o_sconcoa%flag,o_sconcoa%name,"Surface Concentration of Organic Aerosol ","kg/m3") + CALL histdef2d(iff,clef_stations(iff), & +o_sconcbc%flag,o_sconcbc%name,"Surface Concentration of Black Carbon ","kg/m3") + CALL histdef2d(iff,clef_stations(iff), & +o_sconcss%flag,o_sconcss%name,"Surface Concentration of Sea Salt ","kg/m3") + CALL histdef2d(iff,clef_stations(iff), & +o_sconcdust%flag,o_sconcdust%name,"Surface Concentration of Dust ","kg/m3") + CALL histdef3d(iff,clef_stations(iff), & +o_concso4%flag,o_concso4%name,"Concentration of Sulfate ","kg/m3") + CALL histdef3d(iff,clef_stations(iff), & +o_concoa%flag,o_concoa%name,"Concentration of Organic Aerosol ","kg/m3") + CALL histdef3d(iff,clef_stations(iff), & +o_concbc%flag,o_concbc%name,"Concentration of Black Carbon ","kg/m3") + CALL histdef3d(iff,clef_stations(iff), & +o_concss%flag,o_concss%name,"Concentration of Sea Salt ","kg/m3") + CALL histdef3d(iff,clef_stations(iff), & +o_concdust%flag,o_concdust%name,"Concentration of Dust ","kg/m3") + CALL histdef2d(iff,clef_stations(iff), & +o_loadso4%flag,o_loadso4%name,"Column Load of Sulfate ","kg/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_loadoa%flag,o_loadoa%name,"Column Load of Organic Aerosol ","kg/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_loadbc%flag,o_loadbc%name,"Column Load of Black Carbon ","kg/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_loadss%flag,o_loadss%name,"Column Load of Sea Salt ","kg/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_loaddust%flag,o_loaddust%name,"Column Load of Dust ","kg/m2") + + DO naero = 1, naero_spc + CALL histdef2d(iff,clef_stations(iff), & +o_tausumaero(naero)%flag,o_tausumaero(naero)%name,"Aerosol Optical depth at 550 nm "//name_aero(naero),"1") + END DO + ENDIF +ENDIF + + IF (ok_ade) THEN + CALL histdef2d(iff,clef_stations(iff), & +o_topswad%flag,o_topswad%name, "ADE at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_solswad%flag,o_solswad%name, "ADE at SRF", "W/m2") + + CALL histdef2d(iff,clef_stations(iff), & +o_swtoaas_nat%flag,o_swtoaas_nat%name, "Natural aerosol radiative forcing all-sky at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swsrfas_nat%flag,o_swsrfas_nat%name, "Natural aerosol radiative forcing all-sky at SRF", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swtoacs_nat%flag,o_swtoacs_nat%name, "Natural aerosol radiative forcing clear-sky at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swsrfcs_nat%flag,o_swsrfcs_nat%name, "Natural aerosol radiative forcing clear-sky at SRF", "W/m2") + + CALL histdef2d(iff,clef_stations(iff), & +o_swtoaas_ant%flag,o_swtoaas_ant%name, "Anthropogenic aerosol radiative forcing all-sky at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swsrfas_ant%flag,o_swsrfas_ant%name, "Anthropogenic aerosol radiative forcing all-sky at SRF", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swtoacs_ant%flag,o_swtoacs_ant%name, "Anthropogenic aerosol radiative forcing clear-sky at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swsrfcs_ant%flag,o_swsrfcs_ant%name, "Anthropogenic aerosol radiative forcing clear-sky at SRF", "W/m2") + + IF (.NOT. aerosol_couple) THEN + CALL histdef2d(iff,clef_stations(iff), & +o_swtoacf_nat%flag,o_swtoacf_nat%name, "Natural aerosol impact on cloud radiative forcing at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swsrfcf_nat%flag,o_swsrfcf_nat%name, "Natural aerosol impact on cloud radiative forcing at SRF", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swtoacf_ant%flag,o_swtoacf_ant%name, "Anthropogenic aerosol impact on cloud radiative forcing at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swsrfcf_ant%flag,o_swsrfcf_ant%name, "Anthropogenic aerosol impact on cloud radiative forcing at SRF", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swtoacf_zero%flag,o_swtoacf_zero%name, "Cloud radiative forcing (allsky-clearsky fluxes) at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_swsrfcf_zero%flag,o_swsrfcf_zero%name, "Cloud radiative forcing (allsky-clearsky fluxes) at SRF", "W/m2") + ENDIF + + ENDIF + + IF (ok_aie) THEN + CALL histdef2d(iff,clef_stations(iff), & +o_topswai%flag,o_topswai%name, "AIE at TOA", "W/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_solswai%flag,o_solswai%name, "AIE at SFR", "W/m2") +!Cloud droplet number concentration + CALL histdef3d(iff,clef_stations(iff), & +o_scdnc%flag,o_scdnc%name, "Cloud droplet number concentration","m-3") + CALL histdef2d(iff,clef_stations(iff), & +o_cldncl%flag,o_cldncl%name, "CDNC at top of liquid water cloud", "m-3") + CALL histdef3d(iff,clef_stations(iff), & +o_reffclws%flag,o_reffclws%name, "Stratiform Cloud Droplet Effective Radius (aerosol diags.)","m") + CALL histdef3d(iff,clef_stations(iff), & +o_reffclwc%flag,o_reffclwc%name, "Convective Cloud Droplet Effective Radius (aerosol diags.)","m") + CALL histdef2d(iff,clef_stations(iff), & +o_cldnvi%flag,o_cldnvi%name, "Column Integrated Cloud Droplet Number", "m-2") + CALL histdef3d(iff,clef_stations(iff), & +o_lcc3d%flag,o_lcc3d%name, "Cloud liquid fraction","1") + CALL histdef3d(iff,clef_stations(iff), & +o_lcc3dcon%flag,o_lcc3dcon%name, "Convective cloud liquid fraction","1") + CALL histdef3d(iff,clef_stations(iff), & +o_lcc3dstra%flag,o_lcc3dstra%name, "Stratiform cloud liquid fraction","1") + CALL histdef2d(iff,clef_stations(iff), & +o_lcc%flag,o_lcc%name, "Cloud liquid fraction at top of cloud","1") + CALL histdef2d(iff,clef_stations(iff), & +o_reffclwtop%flag,o_reffclwtop%name, "Droplet effective radius at top of liquid water cloud", "m") + ENDIF + + + CALL histdef2d(iff,clef_stations(iff), & +o_alb1%flag,o_alb1%name, "Surface VIS albedo", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_alb2%flag,o_alb2%name, "Surface Near IR albedo", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_cdrm%flag,o_cdrm%name, "Momentum drag coef.", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_cdrh%flag,o_cdrh%name, "Heat drag coef.", "-" ) + CALL histdef2d(iff,clef_stations(iff), & +o_cldl%flag,o_cldl%name, "Low-level cloudiness", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_cldm%flag,o_cldm%name, "Mid-level cloudiness", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_cldh%flag,o_cldh%name, "High-level cloudiness", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_cldt%flag,o_cldt%name, "Total cloudiness", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_cldq%flag,o_cldq%name, "Cloud liquid water path", "kg/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_lwp%flag,o_lwp%name, "Cloud water path", "kg/m2") + CALL histdef2d(iff,clef_stations(iff), & +o_iwp%flag,o_iwp%name, "Cloud ice water path", "kg/m2" ) + CALL histdef2d(iff,clef_stations(iff), & +o_ue%flag,o_ue%name, "Zonal energy transport", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_ve%flag,o_ve%name, "Merid energy transport", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_uq%flag,o_uq%name, "Zonal humidity transport", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_vq%flag,o_vq%name, "Merid humidity transport", "-") + + IF(iflag_con.GE.3) THEN ! sb + CALL histdef2d(iff,clef_stations(iff), & +o_cape%flag,o_cape%name, "Conv avlbl pot ener", "J/kg") + CALL histdef2d(iff,clef_stations(iff), & +o_pbase%flag,o_pbase%name, "Cld base pressure", "Pa") + CALL histdef2d(iff,clef_stations(iff), & +o_ptop%flag,o_ptop%name, "Cld top pressure", "Pa") + CALL histdef2d(iff,clef_stations(iff), & +o_fbase%flag,o_fbase%name, "Cld base mass flux", "kg/m2/s") + CALL histdef2d(iff,clef_stations(iff), & +o_plcl%flag,o_plcl%name, "Lifting Condensation Level", "hPa") + CALL histdef2d(iff,clef_stations(iff), & +o_plfc%flag,o_plfc%name, "Level of Free Convection", "hPa") + CALL histdef2d(iff,clef_stations(iff), & +o_wbeff%flag,o_wbeff%name, "Conv. updraft velocity at LFC", "m/s") + CALL histdef2d(iff,clef_stations(iff), & +o_prw%flag,o_prw%name, "Precipitable water", "kg/m2") + IF (.NOT.clef_stations(iff)) THEN +! +!IM: there is no way to have one single value in a netcdf file +! + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + type_ecri(6) = 't_max(X)' + CALL histdef2d(iff,clef_stations(iff), & + o_cape_max%flag,o_cape_max%name, "CAPE max.", "J/kg") + ENDIF + type_ecri(:) = type_ecri_files(:) + CALL histdef3d(iff,clef_stations(iff), & +o_upwd%flag,o_upwd%name, "saturated updraft", "kg/m2/s") + CALL histdef3d(iff,clef_stations(iff), & +o_Ma%flag,o_Ma%name, "undilute adiab updraft", "kg/m2/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dnwd%flag,o_dnwd%name, "saturated downdraft", "kg/m2/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dnwd0%flag,o_dnwd0%name, "unsat. downdraft", "kg/m2/s") + CALL histdef3d(iff,clef_stations(iff), & +o_mc%flag,o_mc%name, "Convective mass flux", "kg/m2/s") + type_ecri(1) = 'inst(X)' + type_ecri(2) = 'inst(X)' + type_ecri(3) = 'inst(X)' + type_ecri(4) = 'inst(X)' + type_ecri(5) = 'inst(X)' + type_ecri(6) = 'inst(X)' + CALL histdef2d(iff,clef_stations(iff), & +o_ftime_con%flag,o_ftime_con%name, "Fraction of time convection Occurs", " ") + type_ecri(:) = type_ecri_files(:) + ENDIF !iflag_con .GE. 3 + + CALL histdef2d(iff,clef_stations(iff), & +o_s_pblh%flag,o_s_pblh%name, "Boundary Layer Height", "m") + CALL histdef2d(iff,clef_stations(iff), & +o_s_pblt%flag,o_s_pblt%name, "t at Boundary Layer Height", "K") + CALL histdef2d(iff,clef_stations(iff), & +o_s_lcl%flag,o_s_lcl%name, "Condensation level", "m") + CALL histdef2d(iff,clef_stations(iff), & +o_s_therm%flag,o_s_therm%name, "Exces du thermique", "K") +!IM : Les champs suivants (s_oliqCL, s_cteiCL, s_trmb1, s_trmb2, s_trmb3) ne sont pas definis dans HBTM.F +!CALL histdef2d(iff,clef_stations(iff), & +!o_s_capCL%flag,o_s_capCL%name, "Conv avlbl pot enerfor ABL", "J/m2" ) +!CALL histdef2d(iff,clef_stations(iff), & +!o_s_oliqCL%flag,o_s_oliqCL%name, "Liq Water in BL", "kg/m2") +!CALL histdef2d(iff,clef_stations(iff), & +!o_s_cteiCL%flag,o_s_cteiCL%name, "Instability criteria(ABL)", "K") +!CALL histdef2d(iff,clef_stations(iff), & +!o_s_trmb1%flag,o_s_trmb1%name, "deep_cape(HBTM2)", "J/m2") +!CALL histdef2d(iff,clef_stations(iff), & +!o_s_trmb2%flag,o_s_trmb2%name, "inhibition (HBTM2)", "J/m2") +!CALL histdef2d(iff,clef_stations(iff), & +!o_s_trmb3%flag,o_s_trmb3%name, "Point Omega (HBTM2)", "m") + +! Champs interpolles sur des niveaux de pression + + type_ecri(1) = 'inst(X)' + type_ecri(2) = 'inst(X)' + type_ecri(3) = 'inst(X)' + type_ecri(4) = 'inst(X)' + type_ecri(5) = 'inst(X)' + type_ecri(6) = 'inst(X)' + +! Attention a reverifier + + ilev=0 + DO k=1, nlevSTD + bb2=clevSTD(k) + IF(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200" & +.OR.bb2.EQ."100".OR.bb2.EQ."50".OR.bb2.EQ."10")THEN + ilev=ilev+1 +! print*,'ilev k bb2 flag name ',ilev,k, bb2,o_uSTDlevs(ilev)%flag,o_uSTDlevs(ilev)%name + CALL histdef2d(iff,clef_stations(iff), & +o_uSTDlevs(ilev)%flag,o_uSTDlevs(ilev)%name,"Zonal wind "//bb2//"hPa", "m/s") + CALL histdef2d(iff,clef_stations(iff), & +o_vSTDlevs(ilev)%flag,o_vSTDlevs(ilev)%name,"Meridional wind "//bb2//"hPa", "m/s") + CALL histdef2d(iff,clef_stations(iff), & +o_wSTDlevs(ilev)%flag,o_wSTDlevs(ilev)%name,"Vertical wind "//bb2//"hPa", "Pa/s") + CALL histdef2d(iff,clef_stations(iff), & +o_zSTDlevs(ilev)%flag,o_zSTDlevs(ilev)%name,"Geopotential height "//bb2//"hPa", "m") + CALL histdef2d(iff,clef_stations(iff), & +o_qSTDlevs(ilev)%flag,o_qSTDlevs(ilev)%name,"Specific humidity "//bb2//"hPa", "kg/kg" ) + CALL histdef2d(iff,clef_stations(iff), & +o_tSTDlevs(ilev)%flag,o_tSTDlevs(ilev)%name,"Temperature "//bb2//"hPa", "K") + ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR."500".OR.bb2.EQ."200".OR.bb2.EQ."50".OR.bb2.EQ."10") + ENDDO + type_ecri(:) = type_ecri_files(:) + + CALL histdef2d(iff,clef_stations(iff), & +o_t_oce_sic%flag,o_t_oce_sic%name, "Temp mixte oce-sic", "K") + + IF (type_ocean=='slab') & + CALL histdef2d(iff,clef_stations(iff), & +o_slab_bils%flag, o_slab_bils%name,"Bilan au sol sur ocean slab", "W/m2") + +! Couplage conv-CL + IF (iflag_con.GE.3) THEN + IF (iflag_coupl>=1) THEN + CALL histdef2d(iff,clef_stations(iff), & +o_ale_bl%flag,o_ale_bl%name, "ALE BL", "m2/s2") + CALL histdef2d(iff,clef_stations(iff), & +o_alp_bl%flag,o_alp_bl%name, "ALP BL", "m2/s2") + ENDIF + ENDIF !(iflag_con.GE.3) + + CALL histdef2d(iff,clef_stations(iff), & +o_weakinv%flag,o_weakinv%name, "Weak inversion", "-") + CALL histdef2d(iff,clef_stations(iff), & +o_dthmin%flag,o_dthmin%name, "dTheta mini", "K/m") + CALL histdef2d(iff,clef_stations(iff), & +o_rh2m%flag,o_rh2m%name, "Relative humidity at 2m", "%" ) + + IF (.NOT.clef_stations(iff)) THEN +! +!IM: there is no way to have one single value in a netcdf file +! + type_ecri(1) = 't_min(X)' + type_ecri(2) = 't_min(X)' + type_ecri(3) = 't_min(X)' + type_ecri(4) = 't_min(X)' + type_ecri(5) = 't_min(X)' + type_ecri(6) = 't_min(X)' + CALL histdef2d(iff,clef_stations(iff),o_rh2m_min%flag,o_rh2m_min%name, "Min Relative humidity at 2m", "%" ) + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + type_ecri(6) = 't_max(X)' + CALL histdef2d(iff,clef_stations(iff),o_rh2m_max%flag,o_rh2m_max%name, "Max Relative humidity at 2m", "%" ) + ENDIF + + type_ecri(:) = type_ecri_files(:) + CALL histdef2d(iff,clef_stations(iff),o_qsat2m%flag,o_qsat2m%name, "Saturant humidity at 2m", "%") + CALL histdef2d(iff,clef_stations(iff),o_tpot%flag,o_tpot%name, "Surface air potential temperature", "K") + CALL histdef2d(iff,clef_stations(iff), & +o_tpote%flag,o_tpote%name, "Surface air equivalent potential temperature", "K") + CALL histdef2d(iff,clef_stations(iff),o_SWnetOR%flag,o_SWnetOR%name, "Sfce net SW radiation OR", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_SWdownOR%flag,o_SWdownOR%name, "Sfce incident SW radiation OR", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_LWdownOR%flag,o_LWdownOR%name, "Sfce incident LW radiation OR", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_snowl%flag,o_snowl%name, "Solid Large-scale Precip.", "kg/(m2*s)") + + CALL histdef2d(iff,clef_stations(iff),o_solldown%flag,o_solldown%name, "Down. IR rad. at surface", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_dtsvdfo%flag,o_dtsvdfo%name, "Boundary-layer dTs(o)", "K/s") + CALL histdef2d(iff,clef_stations(iff),o_dtsvdft%flag,o_dtsvdft%name, "Boundary-layer dTs(t)", "K/s") + CALL histdef2d(iff,clef_stations(iff),o_dtsvdfg%flag,o_dtsvdfg%name, "Boundary-layer dTs(g)", "K/s") + CALL histdef2d(iff,clef_stations(iff),o_dtsvdfi%flag,o_dtsvdfi%name, "Boundary-layer dTs(g)", "K/s") + CALL histdef2d(iff,clef_stations(iff),o_rugs%flag,o_rugs%name, "rugosity", "-" ) + +! Champs 3D: + CALL histdef3d(iff,clef_stations(iff),o_ec550aer%flag,o_ec550aer%name, "Extinction at 550nm", "m^-1") + CALL histdef3d(iff,clef_stations(iff),o_lwcon%flag,o_lwcon%name, "Cloud liquid water content", "kg/kg") + CALL histdef3d(iff,clef_stations(iff),o_iwcon%flag,o_iwcon%name, "Cloud ice water content", "kg/kg") + CALL histdef3d(iff,clef_stations(iff),o_temp%flag,o_temp%name, "Air temperature", "K" ) + CALL histdef3d(iff,clef_stations(iff),o_theta%flag,o_theta%name, "Potential air temperature", "K" ) + CALL histdef3d(iff,clef_stations(iff),o_ovap%flag,o_ovap%name, "Specific humidity", "kg/kg" ) + CALL histdef3d(iff,clef_stations(iff), & +o_ovapinit%flag,o_ovapinit%name, "Specific humidity (begin of timestep)", "kg/kg" ) + CALL histdef3d(iff,clef_stations(iff), & +o_geop%flag,o_geop%name, "Geopotential height", "m2/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_vitu%flag,o_vitu%name, "Zonal wind", "m/s" ) + CALL histdef3d(iff,clef_stations(iff), & +o_vitv%flag,o_vitv%name, "Meridional wind", "m/s" ) + CALL histdef3d(iff,clef_stations(iff), & +o_vitw%flag,o_vitw%name, "Vertical wind", "Pa/s" ) + CALL histdef3d(iff,clef_stations(iff), & +o_pres%flag,o_pres%name, "Air pressure", "Pa" ) + CALL histdef3d(iff,clef_stations(iff), & +o_paprs%flag,o_paprs%name, "Air pressure Inter-Couches", "Pa" ) + CALL histdef3d(iff,clef_stations(iff), & +o_mass%flag,o_mass%name, "Masse Couches", "kg/m2" ) + CALL histdef3d(iff,clef_stations(iff), & +o_zfull%flag,o_zfull%name, "Altitude of full pressure levels", "m" ) + CALL histdef3d(iff,clef_stations(iff), & +o_zhalf%flag,o_zhalf%name, "Altitude of half pressure levels", "m" ) + CALL histdef3d(iff,clef_stations(iff), & +o_rneb%flag,o_rneb%name, "Cloud fraction", "-") + CALL histdef3d(iff,clef_stations(iff), & +o_rnebcon%flag,o_rnebcon%name, "Convective Cloud Fraction", "-") + CALL histdef3d(iff,clef_stations(iff), & +o_rhum%flag,o_rhum%name, "Relative humidity", "-") + CALL histdef3d(iff,clef_stations(iff), & +o_ozone%flag,o_ozone%name, "Ozone mole fraction", "-") + if (read_climoz == 2) & + CALL histdef3d(iff,clef_stations(iff), & +o_ozone_light%flag,o_ozone_light%name, & + "Daylight ozone mole fraction", "-") + CALL histdef3d(iff,clef_stations(iff), & +o_dtphy%flag,o_dtphy%name, "Physics dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dqphy%flag,o_dqphy%name, "Physics dQ", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff), & +o_cldtau%flag,o_cldtau%name, "Cloud optical thickness", "1") + CALL histdef3d(iff,clef_stations(iff), & +o_cldemi%flag,o_cldemi%name, "Cloud optical emissivity", "1") +!IM: bug ?? dimensionnement variables (klon,klev+1) pmflxr, pmflxs, prfl, psfl + CALL histdef3d(iff,clef_stations(iff), & +o_pr_con_l%flag,o_pr_con_l%name, "Convective precipitation lic", " ") + CALL histdef3d(iff,clef_stations(iff), & +o_pr_con_i%flag,o_pr_con_i%name, "Convective precipitation ice", " ") + CALL histdef3d(iff,clef_stations(iff), & +o_pr_lsc_l%flag,o_pr_lsc_l%name, "Large scale precipitation lic", " ") + CALL histdef3d(iff,clef_stations(iff), & +o_pr_lsc_i%flag,o_pr_lsc_i%name, "Large scale precipitation ice", " ") +!Cloud droplet effective radius + CALL histdef3d(iff,clef_stations(iff), & +o_re%flag,o_re%name, "Cloud droplet effective radius","um") + CALL histdef3d(iff,clef_stations(iff), & +o_fl%flag,o_fl%name, "Denominator of Cloud droplet effective radius"," ") +!FH Sorties pour la couche limite + if (iflag_pbl>1) then + CALL histdef3d(iff,clef_stations(iff), & +o_tke%flag,o_tke%name, "TKE", "m2/s2") + IF (.NOT.clef_stations(iff)) THEN +! +!IM: there is no way to have one single value in a netcdf file +! + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + type_ecri(6) = 't_max(X)' + CALL histdef3d(iff,clef_stations(iff), & + o_tke_max%flag,o_tke_max%name, "TKE max", "m2/s2") + ENDIF + type_ecri(:) = type_ecri_files(:) + endif + + CALL histdef3d(iff,clef_stations(iff), & +o_kz%flag,o_kz%name, "Kz melange", "m2/s") + IF (.NOT.clef_stations(iff)) THEN +! +!IM: there is no way to have one single value in a netcdf file +! + type_ecri(1) = 't_max(X)' + type_ecri(2) = 't_max(X)' + type_ecri(3) = 't_max(X)' + type_ecri(4) = 't_max(X)' + type_ecri(5) = 't_max(X)' + type_ecri(6) = 't_max(X)' + CALL histdef3d(iff,clef_stations(iff), & + o_kz_max%flag,o_kz_max%name, "Kz melange max", "m2/s" ) + ENDIF + type_ecri(:) = type_ecri_files(:) + CALL histdef3d(iff,clef_stations(iff), & +o_clwcon%flag,o_clwcon%name, "Convective Cloud Liquid water content", "kg/kg") + CALL histdef3d(iff,clef_stations(iff), & +o_dtdyn%flag,o_dtdyn%name, "Dynamics dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dqdyn%flag,o_dqdyn%name, "Dynamics dQ", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dudyn%flag,o_dudyn%name, "Dynamics dU", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dvdyn%flag,o_dvdyn%name, "Dynamics dV", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dtcon%flag,o_dtcon%name, "Convection dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_ducon%flag,o_ducon%name, "Convection du", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dqcon%flag,o_dqcon%name, "Convection dQ", "(kg/kg)/s") + +! Wakes + IF(iflag_con.EQ.3) THEN + IF (iflag_wake >= 1) THEN + CALL histdef2d(iff,clef_stations(iff), & +o_ale_wk%flag,o_ale_wk%name, "ALE WK", "m2/s2") + CALL histdef2d(iff,clef_stations(iff), & +o_alp_wk%flag,o_alp_wk%name, "ALP WK", "m2/s2") + CALL histdef2d(iff,clef_stations(iff), & +o_ale%flag,o_ale%name, "ALE", "m2/s2") + CALL histdef2d(iff,clef_stations(iff), & +o_alp%flag,o_alp%name, "ALP", "W/m2") + CALL histdef2d(iff,clef_stations(iff),o_cin%flag,o_cin%name, "Convective INhibition", "m2/s2") + CALL histdef2d(iff,clef_stations(iff),o_wape%flag,o_WAPE%name, "WAPE", "m2/s2") + CALL histdef2d(iff,clef_stations(iff),o_wake_h%flag,o_wake_h%name, "wake_h", "-") + CALL histdef2d(iff,clef_stations(iff),o_wake_s%flag,o_wake_s%name, "wake_s", "-") + CALL histdef3d(iff,clef_stations(iff),o_dtwak%flag,o_dtwak%name, "Wake dT", "K/s") + CALL histdef3d(iff,clef_stations(iff),o_dqwak%flag,o_dqwak%name, "Wake dQ", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff),o_wake_deltat%flag,o_wake_deltat%name, "wake_deltat", " ") + CALL histdef3d(iff,clef_stations(iff),o_wake_deltaq%flag,o_wake_deltaq%name, "wake_deltaq", " ") + CALL histdef3d(iff,clef_stations(iff),o_wake_omg%flag,o_wake_omg%name, "wake_omg", " ") + ENDIF + CALL histdef3d(iff,clef_stations(iff),o_Vprecip%flag,o_Vprecip%name, "precipitation vertical profile", "-") + CALL histdef3d(iff,clef_stations(iff),o_ftd%flag,o_ftd%name, "tend temp due aux descentes precip", "-") + CALL histdef3d(iff,clef_stations(iff),o_fqd%flag,o_fqd%name,"tend vap eau due aux descentes precip", "-") + ENDIF !(iflag_con.EQ.3) + + CALL histdef3d(iff,clef_stations(iff),o_dtlsc%flag,o_dtlsc%name, "Condensation dT", "K/s") + CALL histdef3d(iff,clef_stations(iff),o_dtlschr%flag,o_dtlschr%name,"Large-scale condensational heating rate","K/s") + CALL histdef3d(iff,clef_stations(iff),o_dqlsc%flag,o_dqlsc%name, "Condensation dQ", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff),o_dtvdf%flag,o_dtvdf%name, "Boundary-layer dT", "K/s") + CALL histdef3d(iff,clef_stations(iff),o_dqvdf%flag,o_dqvdf%name, "Boundary-layer dQ", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff),o_dteva%flag,o_dteva%name, "Reevaporation dT", "K/s") + CALL histdef3d(iff,clef_stations(iff),o_dqeva%flag,o_dqeva%name, "Reevaporation dQ", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff),o_ptconv%flag,o_ptconv%name, "POINTS CONVECTIFS", " ") + CALL histdef3d(iff,clef_stations(iff),o_ratqs%flag,o_ratqs%name, "RATQS", " ") + CALL histdef3d(iff,clef_stations(iff),o_dtthe%flag,o_dtthe%name, "Thermal dT", "K/s") + +if(iflag_thermals.gt.1) THEN + CALL histdef3d(iff,clef_stations(iff),o_dqlscth%flag,o_dqlscth%name, "dQ therm.", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff),o_dqlscst%flag,o_dqlscst%name, "dQ strat.", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff),o_dtlscth%flag,o_dtlscth%name, "dQ therm.", "K/s") + CALL histdef3d(iff,clef_stations(iff),o_dtlscst%flag,o_dtlscst%name, "dQ strat.", "K/s") + CALL histdef2d(iff,clef_stations(iff),o_plulth%flag,o_plulth%name, "Rainfall therm.", "K/s") + CALL histdef2d(iff,clef_stations(iff),o_plulst%flag,o_plulst%name, "Rainfall strat.", "K/s") + CALL histdef2d(iff,clef_stations(iff),o_lmaxth%flag,o_lmaxth%name, "Upper level thermals", "") + CALL histdef3d(iff,clef_stations(iff),o_ptconvth%flag,o_ptconvth%name, "POINTS CONVECTIFS therm.", " ") + CALL histdef3d(iff,clef_stations(iff),o_f_th%flag,o_f_th%name, "Thermal plume mass flux", "kg/(m2*s)") + CALL histdef3d(iff,clef_stations(iff),o_e_th%flag,o_e_th%name,"Thermal plume entrainment","K/s") + CALL histdef3d(iff,clef_stations(iff),o_w_th%flag,o_w_th%name,"Thermal plume vertical velocity","m/s") + CALL histdef3d(iff,clef_stations(iff), & +o_lambda_th%flag,o_lambda_th%name,"Thermal plume vertical velocity","m/s") + CALL histdef2d(iff,clef_stations(iff), & +o_ftime_th%flag,o_ftime_th%name,"Fraction of time Shallow convection occurs"," ") + CALL histdef3d(iff,clef_stations(iff), & +o_q_th%flag,o_q_th%name, "Thermal plume total humidity", "kg/kg") + CALL histdef3d(iff,clef_stations(iff), & +o_a_th%flag,o_a_th%name, "Thermal plume fraction", "") + CALL histdef3d(iff,clef_stations(iff), & +o_d_th%flag,o_d_th%name, "Thermal plume detrainment", "K/s") + + CALL histdef2d(iff,clef_stations(iff), & +o_f0_th%flag,o_f0_th%name, "Thermal closure mass flux", "K/s") + CALL histdef2d(iff,clef_stations(iff), & +o_zmax_th%flag,o_zmax_th%name, "Thermal plume height", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dqthe%flag,o_dqthe%name, "Thermal dQ", "(kg/kg)/s") +endif !iflag_thermals.gt.1 + CALL histdef3d(iff,clef_stations(iff), & +o_dtajs%flag,o_dtajs%name, "Dry adjust. dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dqajs%flag,o_dqajs%name, "Dry adjust. dQ", "(kg/kg)/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dtswr%flag,o_dtswr%name, "SW radiation dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dtsw0%flag,o_dtsw0%name, "CS SW radiation dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dtlwr%flag,o_dtlwr%name, "LW radiation dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dtlw0%flag,o_dtlw0%name, "CS LW radiation dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_dtec%flag,o_dtec%name, "Cinetic dissip dT", "K/s") + CALL histdef3d(iff,clef_stations(iff), & +o_duvdf%flag,o_duvdf%name, "Boundary-layer dU", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dvvdf%flag,o_dvvdf%name, "Boundary-layer dV", "m/s2") + + IF (ok_orodr) THEN + CALL histdef3d(iff,clef_stations(iff), & +o_duoro%flag,o_duoro%name, "Orography dU", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dvoro%flag,o_dvoro%name, "Orography dV", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dtoro%flag,o_dtoro%name, "Orography dT", "K/s") + ENDIF + + IF (ok_orolf) THEN + CALL histdef3d(iff,clef_stations(iff), & +o_dulif%flag,o_dulif%name, "Orography dU", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dvlif%flag,o_dvlif%name, "Orography dV", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dtlif%flag,o_dtlif%name, "Orography dT", "K/s") + ENDIF + + IF (ok_hines) then + CALL histdef3d(iff,clef_stations(iff), & +o_duhin%flag,o_duhin%name, "Hines GWD dU", "m/s2") + CALL histdef3d(iff,clef_stations(iff), & +o_dvhin%flag,o_dvhin%name, "Hines GWD dV", "m/s2") + + CALL histdef3d(iff,clef_stations(iff), & +o_dthin%flag,o_dthin%name, "Hines GWD dT", "K/s") + ENDIF + + CALL histdef3d(iff,clef_stations(iff), & +o_rsu%flag,o_rsu%name, "SW upward radiation", "W m-2") + CALL histdef3d(iff,clef_stations(iff), & +o_rsd%flag,o_rsd%name, "SW downward radiation", "W m-2") + CALL histdef3d(iff,clef_stations(iff), & +o_rlu%flag,o_rlu%name, "LW upward radiation", "W m-2") + CALL histdef3d(iff,clef_stations(iff), & +o_rld%flag,o_rld%name, "LW downward radiation", "W m-2") + + CALL histdef3d(iff,clef_stations(iff), & +o_rsucs%flag,o_rsucs%name, "SW CS upward radiation", "W m-2") + CALL histdef3d(iff,clef_stations(iff), & +o_rsdcs%flag,o_rsdcs%name, "SW CS downward radiation", "W m-2") + CALL histdef3d(iff,clef_stations(iff), & +o_rlucs%flag,o_rlucs%name, "LW CS upward radiation", "W m-2") + CALL histdef3d(iff,clef_stations(iff), & +o_rldcs%flag,o_rldcs%name, "LW CS downward radiation", "W m-2") + + CALL histdef3d(iff,clef_stations(iff), & +o_tnt%flag,o_tnt%name, "Tendency of air temperature", "K s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_tntc%flag,o_tntc%name, "Tendency of air temperature due to Moist Convection", & +"K s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_tntr%flag,o_tntr%name, "Air temperature tendency due to Radiative heating", & +"K s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_tntscpbl%flag,o_tntscpbl%name, "Air temperature tendency due to St cloud and precipitation and BL mixing", & +"K s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_tnhus%flag,o_tnhus%name, "Tendency of specific humidity", "s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_tnhusc%flag,o_tnhusc%name, "Tendency of specific humidity due to convection", "s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_tnhusscpbl%flag,o_tnhusscpbl%name, "Tendency of Specific humidity due to ST cl, precip and BL mixing", & +"s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_evu%flag,o_evu%name, "Eddy viscosity coefficient for Momentum Variables", "m2 s-1") + + CALL histdef3d(iff,clef_stations(iff), & +o_h2o%flag,o_h2o%name, "Mass Fraction of Water", "1") + + CALL histdef3d(iff,clef_stations(iff), & +o_mcd%flag,o_mcd%name, "Downdraft COnvective Mass Flux", "kg/(m2*s)") + + CALL histdef3d(iff,clef_stations(iff), & +o_dmc%flag,o_dmc%name, "Deep COnvective Mass Flux", "kg/(m2*s)") + + CALL histdef3d(iff,clef_stations(iff), & +o_ref_liq%flag,o_ref_liq%name, "Effective radius of convective cloud liquid water particle", "m") + + CALL histdef3d(iff,clef_stations(iff), & +o_ref_ice%flag,o_ref_ice%name, "Effective radius of startiform cloud ice particle", "m") + + if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. & + RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. & + RCFC12_per.NE.RCFC12_act) THEN + + CALL histdef2d(iff,clef_stations(iff),o_rsut4co2%flag,o_rsut4co2%name, & + "TOA Out SW in 4xCO2 atmosphere", "W/m2") +CALL histdef2d(iff,clef_stations(iff),o_rlut4co2%flag,o_rlut4co2%name, & +"TOA Out LW in 4xCO2 atmosphere", "W/m2") +CALL histdef2d(iff,clef_stations(iff),o_rsutcs4co2%flag,o_rsutcs4co2%name, & +"TOA Out CS SW in 4xCO2 atmosphere", "W/m2") +CALL histdef2d(iff,clef_stations(iff),o_rlutcs4co2%flag,o_rlutcs4co2%name, & +"TOA Out CS LW in 4xCO2 atmosphere", "W/m2") + +CALL histdef3d(iff,clef_stations(iff),o_rsu4co2%flag,o_rsu4co2%name, & +"Upwelling SW 4xCO2 atmosphere", "W/m2") +CALL histdef3d(iff,clef_stations(iff),o_rlu4co2%flag,o_rlu4co2%name, & +"Upwelling LW 4xCO2 atmosphere", "W/m2") +CALL histdef3d(iff,clef_stations(iff),o_rsucs4co2%flag,o_rsucs4co2%name, & +"Upwelling CS SW 4xCO2 atmosphere", "W/m2") +CALL histdef3d(iff,clef_stations(iff),o_rlucs4co2%flag,o_rlucs4co2%name, & +"Upwelling CS LW 4xCO2 atmosphere", "W/m2") + + CALL histdef3d(iff,clef_stations(iff),o_rsd4co2%flag,o_rsd4co2%name, & + "Downwelling SW 4xCO2 atmosphere", "W/m2") + CALL histdef3d(iff,clef_stations(iff),o_rld4co2%flag,o_rld4co2%name, & +"Downwelling LW 4xCO2 atmosphere", "W/m2") + CALL histdef3d(iff,clef_stations(iff),o_rsdcs4co2%flag,o_rsdcs4co2%name, & +"Downwelling CS SW 4xCO2 atmosphere", "W/m2") + CALL histdef3d(iff,clef_stations(iff),o_rldcs4co2%flag,o_rldcs4co2%name, & +"Downwelling CS LW 4xCO2 atmosphere", "W/m2") + + endif + + + IF (nqtot>=3) THEN + DO iq=3,nqtot + iiq=niadv(iq) + o_trac(iq-2) = ctrl_out((/ 4, 5, 1, 1, 1, 10 /),tname(iiq)) + CALL histdef3d (iff,clef_stations(iff), & + o_trac(iq-2)%flag,o_trac(iq-2)%name,'Tracer '//ttext(iiq), "-" ) + ENDDO + ENDIF + + CALL histend(nid_files(iff)) + + ndex2d = 0 + ndex3d = 0 + + ENDIF ! clef_files + + ENDDO ! iff + print*,'Fin phys_output_mod.F90' + end subroutine phys_output_open + + SUBROUTINE histdef2d (iff,lpoint,flag_var,nomvar,titrevar,unitvar) + + use ioipsl + USE dimphy + USE mod_phys_lmdz_para + USE iophy + + IMPLICIT NONE + + include "dimensions.h" + include "temps.h" + include "indicesol.h" + include "clesphys.h" + + integer :: iff + logical :: lpoint + integer, dimension(nfiles) :: flag_var + character(len=20) :: nomvar + character(len=*) :: titrevar + character(len=*) :: unitvar + + real zstophym + + if (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') then + zstophym=zoutm(iff) + else + zstophym=zdtime + endif + +! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def + call conf_physoutputs(nomvar,flag_var) + + if(.NOT.lpoint) THEN + if ( flag_var(iff)<=lev_files(iff) ) then + call histdef (nid_files(iff),nomvar,titrevar,unitvar, & + iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, & + type_ecri(iff), zstophym,zoutm(iff)) + endif + else + if ( flag_var(iff)<=lev_files(iff) ) then + call histdef (nid_files(iff),nomvar,titrevar,unitvar, & + npstn,1,nhorim(iff), 1,1,1, -99, 32, & + type_ecri(iff), zstophym,zoutm(iff)) + endif + endif + end subroutine histdef2d + + SUBROUTINE histdef3d (iff,lpoint,flag_var,nomvar,titrevar,unitvar) + + use ioipsl + USE dimphy + USE mod_phys_lmdz_para + USE iophy + + IMPLICIT NONE + + include "dimensions.h" + include "temps.h" + include "indicesol.h" + include "clesphys.h" + + integer :: iff + logical :: lpoint + integer, dimension(nfiles) :: flag_var + character(len=20) :: nomvar + character(len=*) :: titrevar + character(len=*) :: unitvar + + real zstophym + +! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def + call conf_physoutputs(nomvar,flag_var) + + if (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') then + zstophym=zoutm(iff) + else + zstophym=zdtime + endif + + if(.NOT.lpoint) THEN + if ( flag_var(iff)<=lev_files(iff) ) then + call histdef (nid_files(iff), nomvar, titrevar, unitvar, & + iim, jj_nb, nhorim(iff), klev, levmin(iff), & + levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), & + zstophym, zoutm(iff)) + endif + else + if ( flag_var(iff)<=lev_files(iff) ) then + call histdef (nid_files(iff), nomvar, titrevar, unitvar, & + npstn,1,nhorim(iff), klev, levmin(iff), & + levmax(iff)-levmin(iff)+1, nvertm(iff), 32, & + type_ecri(iff), zstophym,zoutm(iff)) + endif + endif + end subroutine histdef3d + + SUBROUTINE conf_physoutputs(nam_var,flag_var) +!!! Lecture des noms et niveau de sortie des variables dans output.def +! en utilisant les routines getin de IOIPSL + use ioipsl + + IMPLICIT NONE + + include 'iniprint.h' + + character(len=20) :: nam_var + integer, dimension(nfiles) :: flag_var + + IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:) + call getin('flag_'//nam_var,flag_var) + call getin('name_'//nam_var,nam_var) + IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:) + + END SUBROUTINE conf_physoutputs + + SUBROUTINE convers_timesteps(str,dtime,timestep) + + use ioipsl + USE phys_cal_mod + + IMPLICIT NONE + + character(len=20) :: str + character(len=10) :: type + integer :: ipos,il + real :: ttt,xxx,timestep,dayseconde,dtime + parameter (dayseconde=86400.) + include "temps.h" + include "comconst.h" + + ipos=scan(str,'0123456789.',.true.) +! + il=len_trim(str) + print*,ipos,il + read(str(1:ipos),*) ttt + print*,ttt + type=str(ipos+1:il) + + + if ( il == ipos ) then + type='day' + endif + + if ( type == 'day'.or.type == 'days'.or.type == 'jours'.or.type == 'jour' ) timestep = ttt * dayseconde + if ( type == 'mounths'.or.type == 'mth'.or.type == 'mois' ) then + print*,'annee_ref,day_ref mon_len',annee_ref,day_ref,ioget_mon_len(annee_ref,day_ref) + timestep = ttt * dayseconde * mth_len + endif + if ( type == 'hours'.or.type == 'hr'.or.type == 'heurs') timestep = ttt * dayseconde / 24. + if ( type == 'mn'.or.type == 'minutes' ) timestep = ttt * 60. + if ( type == 's'.or.type == 'sec'.or.type == 'secondes' ) timestep = ttt + if ( type == 'TS' ) timestep = dtime + + print*,'type = ',type + print*,'nb j/h/m = ',ttt + print*,'timestep(s)=',timestep + + END SUBROUTINE convers_timesteps + +END MODULE phys_output_mod + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_var_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_var_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_var_mod.F90 (revision 1634) @@ -0,0 +1,41 @@ +! +! phys_local_var_mod.F90 1327 2010-03-17 15:33:56Z idelkadi $ + + MODULE phys_output_var_mod + + use dimphy +! Variables outputs pour les ecritures des sorties +!====================================================================== +! +! +!====================================================================== +! Declaration des variables + + REAL, SAVE, ALLOCATABLE :: snow_o(:), zfra_o(:) +!$OMP THREADPRIVATE(snow_o, zfra_o) + INTEGER, save, ALLOCATABLE :: itau_con(:) ! Nombre de pas ou rflag <= 1 +!$OMP THREADPRIVATE(itau_con) + +CONTAINS + +!====================================================================== +SUBROUTINE phys_output_var_init +use dimphy + +IMPLICIT NONE + + allocate(snow_o(klon), zfra_o(klon)) + allocate(itau_con(klon)) + +END SUBROUTINE phys_output_var_init + +!====================================================================== +SUBROUTINE phys_output_var_end +use dimphy +IMPLICIT NONE + + deallocate(snow_o,zfra_o,itau_con) + +END SUBROUTINE phys_output_var_end + +END MODULE phys_output_var_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_write.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_write.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_output_write.h (revision 1634) @@ -0,0 +1,2165 @@ + itau_w = itau_phy + itap + + DO iff=1,nfiles + + IF (clef_files(iff)) THEN + ndex2d = 0 + ndex3d = 0 + +!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (o_phis%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_phis%name,itau_w,pphis) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_aire%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_aire%name,itau_w,airephy) + ENDIF + + IF (o_contfracATM%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_contfracATM%name,itau_w,zx_tmp_fi2d) + ENDIF + ENDIF + + IF (o_contfracOR%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_contfracOR%name,itau_w,pctsrf(:,is_ter)) + ENDIF + + IF (o_aireTER%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_aireTER%name,itau_w,paire_ter) + ENDIF + +!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IF (o_flat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_flat%name,itau_w,zxfluxlat) + ENDIF + + IF (o_slp%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_slp%name,itau_w,slp) + ENDIF + + IF (o_tsol%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_tsol%name,itau_w,zxtsol) + ENDIF + + IF (o_t2m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_t2m%name,itau_w,zt2m) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_t2m_min%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_t2m_min%name,itau_w,zt2m) + ENDIF + + IF (o_t2m_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_t2m_max%name,itau_w,zt2m) + ENDIF + ENDIF + + IF (o_wind10m%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_wind10m%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_wind10max%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_wind10max%name,itau_w,zx_tmp_fi2d) + ENDIF + ENDIF + + IF (o_sicf%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = pctsrf(i,is_sic) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_sicf%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_q2m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_q2m%name,itau_w,zq2m) + ENDIF + + IF (o_u10m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_u10m%name,itau_w,zu10m) + ENDIF + + IF (o_v10m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_v10m%name,itau_w,zv10m) + ENDIF + + IF (o_psol%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = paprs(i,1) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_psol%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_mass%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_mass%name,itau_w,zmasse) + ENDIF + + + IF (o_qsurf%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_qsurf%name,itau_w,zxqsurf) + ENDIF + + if (.not. ok_veget) then + IF (o_qsol%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_qsol%name,itau_w,qsol) + ENDIF + endif + + IF (o_precip%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_precip%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_ndayrain%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ndayrain%name,itau_w,nday_rain) + ENDIF + + IF (o_plul%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_plul%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_pluc%flag(iff)<=lev_files(iff)) THEN + DO i = 1, klon + zx_tmp_fi2d(i) = rain_con(i) + snow_con(i) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_pluc%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_snow%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_snow%name,itau_w,snow_fall) + ENDIF + + IF (o_msnow%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_msnow%name,itau_w,snow_o) + ENDIF + + IF (o_fsnow%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_fsnow%name,itau_w,zfra_o) + ENDIF + + IF (o_evap%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_evap%name,itau_w,evap) + ENDIF + + IF (o_tops%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tops%name,itau_w,topsw) + ENDIF + + IF (o_tops0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tops0%name,itau_w,topsw0) + ENDIF + + IF (o_topl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_topl%name,itau_w,toplw) + ENDIF + + IF (o_topl0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_topl0%name,itau_w,toplw0) + ENDIF + + IF (o_SWupTOA%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_SWupTOA%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWupTOAclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_SWupTOAclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnTOA%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_SWdnTOA%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnTOAclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_SWdnTOAclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_nettop%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(:) = topsw(:)-toplw(:) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_nettop%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWup200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_SWup200%name,itau_w,SWup200) + ENDIF + + IF (o_SWup200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_SWup200clr%name,itau_w,SWup200clr) + ENDIF + + IF (o_SWdn200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_SWdn200%name,itau_w,SWdn200) + ENDIF + + IF (o_SWdn200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_SWdn200clr%name,itau_w,SWdn200clr) + ENDIF + + IF (o_LWup200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_LWup200%name,itau_w,LWup200) + ENDIF + + IF (o_LWup200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_LWup200clr%name,itau_w,LWup200clr) + ENDIF + + IF (o_LWdn200%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_LWdn200%name,itau_w,LWdn200) + ENDIF + + IF (o_LWdn200clr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_LWdn200clr%name,itau_w,LWdn200clr) + ENDIF + + IF (o_sols%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_sols%name,itau_w,solsw) + ENDIF + + IF (o_sols0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_sols0%name,itau_w,solsw0) + ENDIF + + IF (o_soll%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_soll%name,itau_w,sollw) + ENDIF + + IF (o_radsol%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_radsol%name,itau_w,radsol) + ENDIF + + IF (o_soll0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_soll0%name,itau_w,sollw0) + ENDIF + + IF (o_SWupSFC%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_SWupSFC%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWupSFCclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_SWupSFCclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnSFC%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_SWdnSFC%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_SWdnSFCclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_SWdnSFCclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_LWupSFC%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_LWupSFC%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_LWdnSFC%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_LWdnSFC%name,itau_w,sollwdown) + ENDIF + + sollwdownclr(1:klon) = -1.*lwdn0(1:klon,1) + IF (o_LWupSFCclr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_LWupSFCclr%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_LWdnSFCclr%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_LWdnSFCclr%name,itau_w,sollwdownclr) + ENDIF + + IF (o_bils%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_bils%name,itau_w,bils) + ENDIF + + IF (o_sens%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon)=-1*sens(1:klon) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_sens%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_fder%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_fder%name,itau_w,fder) + ENDIF + + IF (o_ffonte%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ffonte%name,itau_w,zxffonte) + ENDIF + + IF (o_fqcalving%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_fqcalving%name,itau_w,zxfqcalving) + ENDIF + + IF (o_fqfonte%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_fqfonte%name,itau_w,zxfqfonte) + ENDIF + + IF (o_taux%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d=0. + do nsrf=1,nbsrf + zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+pctsrf(:,nsrf)*fluxu(:,1,nsrf) + enddo + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_taux%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_tauy%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d=0. + do nsrf=1,nbsrf + zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+pctsrf(:,nsrf)*fluxv(:,1,nsrf) + enddo + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_tauy%name,itau_w,zx_tmp_fi2d) + ENDIF + + DO nsrf = 1, nbsrf +! IF(nsrf.GE.2) THEN + IF (o_pourc_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100. + CALL histwrite_phy(nid_files(iff), + $ clef_stations(iff), + $ o_pourc_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_fract_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_fract_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF +! ENDIF !nsrf.GT.2 + + IF (o_taux_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_taux_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_tauy_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_tauy_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_tsol_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_tsol_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_u10m_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = u10m(1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_u10m_srf(nsrf)%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_v10m_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = v10m(1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_v10m_srf(nsrf)%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_t2m_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = t2m(1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_t2m_srf(nsrf)%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_evap_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fevap(1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_evap_srf(nsrf)%name, + $ itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_sens_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_sens_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_lat_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_lat_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_flw_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_flw_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_fsw_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_fsw_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_wbils_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_wbils_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_wbilo_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_wbilo_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + if (iflag_pbl>1 .and. lev_histday.gt.10 ) then + IF (o_tke_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_tke_srf(nsrf)%name,itau_w, + $ pbl_tke(:,1:klev,nsrf)) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_tke_max_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_tke_max_srf(nsrf)%name,itau_w, + $ pbl_tke(:,1:klev,nsrf)) + ENDIF + ENDIF + endif + ENDDO + + IF (o_cdrm%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cdrm%name,itau_w,cdragm) + ENDIF + + IF (o_cdrh%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cdrh%name,itau_w,cdragh) + ENDIF + + IF (o_cldl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cldl%name,itau_w,cldl) + ENDIF + + IF (o_cldm%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cldm%name,itau_w,cldm) + ENDIF + + IF (o_cldh%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cldh%name,itau_w,cldh) + ENDIF + + IF (o_cldt%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cldt%name, + & itau_w,cldt) + ENDIF + + IF (o_cldq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cldq%name,itau_w,cldq) + ENDIF + + IF (o_lwp%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon) = flwp(1:klon) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_lwp%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_iwp%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon) = fiwp(1:klon) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_iwp%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_ue%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ue%name,itau_w,ue) + ENDIF + + IF (o_ve%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ve%name,itau_w,ve) + ENDIF + + IF (o_uq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_uq%name,itau_w,uq) + ENDIF + + IF (o_vq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_vq%name,itau_w,vq) + ENDIF + + IF(iflag_con.GE.3) THEN ! sb + IF (o_cape%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cape%name,itau_w,cape) + ENDIF + + IF (o_pbase%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_pbase%name,itau_w,ema_pcb) + ENDIF + + IF (o_ptop%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ptop%name,itau_w,ema_pct) + ENDIF + + IF (o_fbase%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_fbase%name,itau_w,ema_cbmf) + ENDIF + + IF (o_plcl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_plcl%name,itau_w,plcl) + ENDIF + + IF (o_plfc%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_plfc%name,itau_w,plfc) + ENDIF + + IF (o_wbeff%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_wbeff%name,itau_w,wbeff) + ENDIF + + + IF (o_prw%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_prw%name,itau_w,prw) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_cape_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cape_max%name,itau_w,cape) + ENDIF + ENDIF + + IF (o_upwd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_upwd%name,itau_w,upwd) + ENDIF + + IF (o_Ma%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_Ma%name,itau_w,Ma) + ENDIF + + IF (o_dnwd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dnwd%name,itau_w,dnwd) + ENDIF + + IF (o_dnwd0%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dnwd0%name,itau_w,dnwd0) + ENDIF + + IF (o_ftime_con%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d=float(itau_con)/float(itap) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ftime_con%name, + s itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_mc%flag(iff)<=lev_files(iff)) THEN + if(iflag_thermals.gt.1)then + zx_tmp_fi3d=dnwd+dnwd0+upwd+fm_therm(:,1:klev) + else + zx_tmp_fi3d=dnwd+dnwd0+upwd + endif + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_mc%name,itau_w,zx_tmp_fi3d) + ENDIF + + ENDIF !iflag_con .GE. 3 + + IF (o_s_pblh%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_s_pblh%name,itau_w,s_pblh) + ENDIF + + IF (o_s_pblt%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_s_pblt%name,itau_w,s_pblt) + ENDIF + + IF (o_s_lcl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_s_lcl%name,itau_w,s_lcl) + ENDIF + + IF (o_s_therm%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_s_therm%name,itau_w,s_therm) + ENDIF + +!IM : Les champs suivants (s_capCL, s_oliqCL, s_cteiCL, s_trmb1, s_trmb2, s_trmb3) ne sont pas definis dans HBTM.F +! IF (o_s_capCL%flag(iff)<=lev_files(iff)) THEN +! CALL histwrite_phy(nid_files(iff),clef_stations(iff), +! $o_s_capCL%name,itau_w,s_capCL) +! ENDIF + +! IF (o_s_oliqCL%flag(iff)<=lev_files(iff)) THEN +! CALL histwrite_phy(nid_files(iff),clef_stations(iff), +! $o_s_oliqCL%name,itau_w,s_oliqCL) +! ENDIF + +! IF (o_s_cteiCL%flag(iff)<=lev_files(iff)) THEN +! CALL histwrite_phy(nid_files(iff),clef_stations(iff), +! $o_s_cteiCL%name,itau_w,s_cteiCL) +! ENDIF + +! IF (o_s_trmb1%flag(iff)<=lev_files(iff)) THEN +! CALL histwrite_phy(nid_files(iff),clef_stations(iff), +! $o_s_trmb1%name,itau_w,s_trmb1) +! ENDIF + +! IF (o_s_trmb2%flag(iff)<=lev_files(iff)) THEN +! CALL histwrite_phy(nid_files(iff),clef_stations(iff), +! $o_s_trmb2%name,itau_w,s_trmb2) +! ENDIF + +! IF (o_s_trmb3%flag(iff)<=lev_files(iff)) THEN +! CALL histwrite_phy(nid_files(iff),clef_stations(iff), +! $o_s_trmb3%name,itau_w,s_trmb3) +! ENDIF + +! Champs interpolles sur des niveaux de pression + + ll=0 + DO k=1, nlevSTD + bb2=clevSTD(k) + IF(bb2.EQ."850".OR.bb2.EQ."700".OR. + $ bb2.EQ."500".OR.bb2.EQ."200".OR. + $ bb2.EQ."100".OR. + $ bb2.EQ."50".OR.bb2.EQ."10") THEN + +! a refaire correctement !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ll=ll+1 + IF (o_uSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_uSTDlevs(ll)%name, + & itau_w,uwriteSTD(:,k,iff)) + ENDIF + + IF (o_vSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_vSTDlevs(ll)%name, + & itau_w,vwriteSTD(:,k,iff)) + ENDIF + + IF (o_wSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_wSTDlevs(ll)%name, + & itau_w,wwriteSTD(:,k,iff)) + ENDIF + + IF (o_zSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_zSTDlevs(ll)%name, + & itau_w,phiwriteSTD(:,k,iff)) + ENDIF + + IF (o_qSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_qSTDlevs(ll)%name, + & itau_w, qwriteSTD(:,k,iff)) + ENDIF + + IF (o_tSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tSTDlevs(ll)%name, + & itau_w, twriteSTD(:,k,iff)) + ENDIF + + ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR. + ENDDO + + IF (o_t_oce_sic%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + IF (pctsrf(i,is_oce).GT.epsfra.OR. + $ pctsrf(i,is_sic).GT.epsfra) THEN + zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ + $ ftsol(i, is_sic) * pctsrf(i,is_sic))/ + $ (pctsrf(i,is_oce)+pctsrf(i,is_sic)) + ELSE + zx_tmp_fi2d(i) = 273.15 + ENDIF + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_t_oce_sic%name,itau_w,zx_tmp_fi2d) + ENDIF + +! Couplage convection-couche limite + IF (iflag_con.GE.3) THEN + IF (iflag_coupl>=1) THEN + IF (o_ale_bl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ale_bl%name,itau_w,ale_bl) + ENDIF + IF (o_alp_bl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_alp_bl%name,itau_w,alp_bl) + ENDIF + ENDIF !iflag_coupl>=1 + ENDIF !(iflag_con.GE.3) + +! Wakes + IF (iflag_con.EQ.3) THEN + IF (iflag_wake>=1) THEN + IF (o_ale_wk%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ale_wk%name,itau_w,ale_wake) + ENDIF + IF (o_alp_wk%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_alp_wk%name,itau_w,alp_wake) + ENDIF + + IF (o_ale%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ale%name,itau_w,ale) + ENDIF + IF (o_alp%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_alp%name,itau_w,alp) + ENDIF + IF (o_cin%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cin%name,itau_w,cin) + ENDIF + IF (o_wape%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_WAPE%name,itau_w,wake_pe) + ENDIF + IF (o_wake_h%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_wake_h%name,itau_w,wake_h) + ENDIF + + IF (o_wake_s%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_wake_s%name,itau_w,wake_s) + ENDIF + + IF (o_wake_deltat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_wake_deltat%name, + $ itau_w,wake_deltat) + ENDIF + + IF (o_wake_deltaq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_wake_deltaq%name, + $ itau_w,wake_deltaq) + ENDIF + + IF (o_wake_omg%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_wake_omg%name,itau_w,wake_omg) + ENDIF + + IF (o_dtwak%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_wake(1:klon,1:klev) + & /pdtphys + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + & o_dtwak%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqwak%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_wake(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + & o_dqwak%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF ! iflag_wake>=1 + + IF (o_Vprecip%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_Vprecip%name,itau_w,Vprecip) + ENDIF + + IF (o_ftd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ftd%name,itau_w,ftd) + ENDIF + + IF (o_fqd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_fqd%name,itau_w,fqd) + ENDIF + ENDIF !(iflag_con.EQ.3) + + IF (type_ocean=='slab ') THEN + IF ( o_slab_bils%flag(iff)<=lev_files(iff)) + $ CALL histwrite_phy( + $ nid_files(iff),clef_stations(iff), + $o_slab_bils%name,itau_w,slab_wfbils) + + ENDIF !type_ocean == force/slab + + IF (o_weakinv%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_weakinv%name,itau_w,weak_inversion) + ENDIF + + IF (o_dthmin%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dthmin%name,itau_w,dthmin) + ENDIF + + IF (o_cldtau%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cldtau%name,itau_w,cldtau) + ENDIF + + IF (o_cldemi%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_cldemi%name,itau_w,cldemi) + ENDIF + + IF (o_pr_con_l%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_pr_con_l%name,itau_w,pmflxr(:,1:klev)) + ENDIF + + IF (o_pr_con_i%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_pr_con_i%name,itau_w,pmflxs(:,1:klev)) + ENDIF + + IF (o_pr_lsc_l%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_pr_lsc_l%name,itau_w,prfl(:,1:klev)) + ENDIF + + IF (o_pr_lsc_i%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_pr_lsc_i%name,itau_w,psfl(:,1:klev)) + ENDIF + + IF (o_re%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_re%name,itau_w,re) + ENDIF + + IF (o_fl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_fl%name,itau_w,fl) + ENDIF + + + + IF (o_rh2m%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rh2m%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_rh2m_min%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rh2m_min%name, + s itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_rh2m_max%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.) + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rh2m_max%name, + s itau_w,zx_tmp_fi2d) + ENDIF + ENDIF + + + IF (o_qsat2m%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_qsat2m%name,itau_w,qsat2m) + ENDIF + + IF (o_tpot%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tpot%name,itau_w,tpot) + ENDIF + + IF (o_tpote%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tpote%name,itau_w,tpote) + ENDIF + + IF (o_SWnetOR%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_SWnetOR%name,itau_w, zx_tmp_fi2d) + ENDIF + + IF (o_SWdownOR%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1:klon) = solsw(1:klon)/(1.-albsol1(1:klon)) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_SWdownOR%name,itau_w, zx_tmp_fi2d) + ENDIF + + IF (o_LWdownOR%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_LWdownOR%name,itau_w,sollwdown) + ENDIF + + IF (o_snowl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_snowl%name,itau_w,snow_lsc) + ENDIF + + IF (o_solldown%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_solldown%name,itau_w,sollwdown) + ENDIF + + IF (o_dtsvdfo%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_dtsvdfo%name,itau_w,d_ts(:,is_oce)) + ENDIF + + IF (o_dtsvdft%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_dtsvdft%name,itau_w,d_ts(:,is_ter)) + ENDIF + + IF (o_dtsvdfg%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_dtsvdfg%name,itau_w, d_ts(:,is_lic)) + ENDIF + + IF (o_dtsvdfi%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_dtsvdfi%name,itau_w,d_ts(:,is_sic)) + ENDIF + + IF (o_rugs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rugs%name,itau_w,zxrugs) + ENDIF + +! OD550 per species + IF (new_aod .and. (.not. aerosol_couple)) THEN + IF (ok_ade.OR.ok_aie) THEN + + IF (o_od550aer%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_od550aer%name,itau_w, + $ od550aer) + ENDIF + IF (o_od865aer%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_od865aer%name,itau_w, + $ od865aer) + ENDIF + IF (o_absvisaer%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_absvisaer%name,itau_w, + $ absvisaer) + ENDIF + IF (o_od550lt1aer%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_od550lt1aer%name,itau_w, + $ od550lt1aer) + ENDIF + + IF (o_sconcso4%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_sconcso4%name,itau_w, + $ sconcso4) + ENDIF + IF (o_sconcoa%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_sconcoa%name,itau_w, + $ sconcoa) + ENDIF + IF (o_sconcbc%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_sconcbc%name,itau_w, + $ sconcbc) + ENDIF + IF (o_sconcss%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_sconcss%name,itau_w, + $ sconcss) + ENDIF + IF (o_sconcdust%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_sconcdust%name,itau_w, + $ sconcdust) + ENDIF + + IF (o_concso4%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_concso4%name,itau_w, + $ concso4) + ENDIF + IF (o_concoa%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_concoa%name,itau_w, + $ concoa) + ENDIF + IF (o_concbc%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_concbc%name,itau_w, + $ concbc) + ENDIF + IF (o_concss%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_concss%name,itau_w, + $ concss) + ENDIF + IF (o_concdust%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_concdust%name,itau_w, + $ concdust) + ENDIF + + IF (o_loadso4%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_loadso4%name,itau_w, + $ loadso4) + ENDIF + IF (o_loadoa%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_loadoa%name,itau_w, + $ loadoa) + ENDIF + IF (o_loadbc%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_loadbc%name,itau_w, + $ loadbc) + ENDIF + IF (o_loadss%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_loadss%name,itau_w, + $ loadss) + ENDIF + IF (o_loaddust%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_loaddust%name,itau_w, + $ loaddust) + ENDIF + + DO naero = 1, naero_spc + IF (o_tausumaero(naero)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $ o_tausumaero(naero)%name,itau_w, + $ tausum_aero(:,2,naero) ) + ENDIF + END DO + endif + ENDIF + + IF (ok_ade) THEN + IF (o_topswad%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_topswad%name,itau_w, + $ topswad_aero) + ENDIF + IF (o_solswad%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_solswad%name,itau_w, + $ solswad_aero) + ENDIF + +!====MS forcing diagnostics + if (new_aod) then + IF (o_swtoaas_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swtoaas_nat%name,itau_w, + $ topsw_aero(:,1)) + ENDIF + + IF (o_swsrfas_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swsrfas_nat%name,itau_w, + $ solsw_aero(:,1)) + ENDIF + + IF (o_swtoacs_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swtoacs_nat%name,itau_w, + $ topsw0_aero(:,1)) + ENDIF + + IF (o_swsrfcs_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swsrfcs_nat%name,itau_w, + $ solsw0_aero(:,1)) + ENDIF + +!ant + IF (o_swtoaas_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swtoaas_ant%name,itau_w, + $ topsw_aero(:,2)) + ENDIF + + IF (o_swsrfas_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swsrfas_ant%name,itau_w, + $ solsw_aero(:,2)) + ENDIF + + IF (o_swtoacs_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swtoacs_ant%name,itau_w, + $ topsw0_aero(:,2)) + ENDIF + + IF (o_swsrfcs_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swsrfcs_ant%name,itau_w, + $ solsw0_aero(:,2)) + ENDIF + +!cf + + if (.not. aerosol_couple) then + IF (o_swtoacf_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swtoacf_nat%name,itau_w, + $ topswcf_aero(:,1)) + ENDIF + + IF (o_swsrfcf_nat%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swsrfcf_nat%name,itau_w, + $ solswcf_aero(:,1)) + ENDIF + + IF (o_swtoacf_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swtoacf_ant%name,itau_w, + $ topswcf_aero(:,2)) + ENDIF + + IF (o_swsrfcf_ant%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swsrfcf_ant%name,itau_w, + $ solswcf_aero(:,2)) + ENDIF + + IF (o_swtoacf_zero%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swtoacf_zero%name,itau_w, + $ topswcf_aero(:,3)) + ENDIF + + IF (o_swsrfcf_zero%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_swsrfcf_zero%name,itau_w, + $ solswcf_aero(:,3)) + ENDIF + endif + + endif ! new_aod +!====MS forcing diagnostics + + ENDIF + + IF (ok_aie) THEN + IF (o_topswai%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_topswai%name,itau_w, + $ topswai_aero) + ENDIF + IF (o_solswai%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_solswai%name,itau_w, + $ solswai_aero) + ENDIF + IF (o_scdnc%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_scdnc%name,itau_w, + $ scdnc) + ENDIF + IF (o_cldncl%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_cldncl%name,itau_w, + $ cldncl) + ENDIF + IF (o_reffclws%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_reffclws%name,itau_w, + $ reffclws) + ENDIF + IF (o_reffclwc%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_reffclwc%name,itau_w, + $ reffclwc) + ENDIF + IF (o_cldnvi%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_cldnvi%name,itau_w, + $ cldnvi) + ENDIF + IF (o_lcc%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_lcc%name,itau_w, + $ lcc) + ENDIF + IF (o_lcc3d%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_lcc3d%name,itau_w, + $ lcc3d) + ENDIF + IF (o_lcc3dcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_lcc3dcon%name,itau_w, + $ lcc3dcon) + ENDIF + IF (o_lcc3dstra%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_lcc3dstra%name,itau_w, + $ lcc3dstra) + ENDIF + IF (o_reffclwtop%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_reffclwtop%name,itau_w, + $ reffclwtop) + ENDIF + ENDIF + +! Champs 3D: + IF (ok_ade .OR. ok_aie) then + IF (o_ec550aer%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff), + $clef_stations(iff), + $o_ec550aer%name,itau_w, + & ec550aer) + ENDIF + ENDIF + + IF (o_lwcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_lwcon%name,itau_w,flwc) + ENDIF + + IF (o_iwcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_iwcon%name,itau_w,fiwc) + ENDIF + + IF (o_temp%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_temp%name,itau_w,t_seri) + ENDIF + + IF (o_theta%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_theta%name,itau_w,theta) + ENDIF + + IF (o_ovapinit%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ovapinit%name,itau_w, + $ qx(:,:,ivap)) + ENDIF + + IF (o_ovap%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $ o_ovap%name,itau_w,q_seri) + ENDIF + + IF (o_geop%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_geop%name,itau_w,zphi) + ENDIF + + IF (o_vitu%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_vitu%name,itau_w,u_seri) + ENDIF + + IF (o_vitv%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_vitv%name,itau_w,v_seri) + ENDIF + + IF (o_vitw%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_vitw%name,itau_w,omega) + ENDIF + + IF (o_pres%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_pres%name,itau_w,pplay) + ENDIF + + IF (o_paprs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_paprs%name, + s itau_w,paprs(:,1:klev)) + ENDIF + + IF (o_zfull%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi3d1(i,1)= pphis(i)/RG +!020611 zx_tmp_fi3d(i,1)= pphis(i)/RG + ENDDO + DO k=1, klev +!020611 DO k=1, klev-1 + DO i=1, klon +!020611 zx_tmp_fi3d(i,k+1)= zx_tmp_fi3d(i,k) - (t_seri(i,k) *RD * + zx_tmp_fi3d1(i,k+1)= zx_tmp_fi3d1(i,k) - (t_seri(i,k) *RD * + $ (paprs(i,k+1) - paprs(i,k))) / ( pplay(i,k) * RG ) + ENDDO + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_zfull%name,itau_w,zx_tmp_fi3d1(:,2:klevp1)) +!020611 $o_zfull%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_zhalf%flag(iff)<=lev_files(iff)) THEN + DO i=1, klon + zx_tmp_fi3d(i,1)= pphis(i)/RG - ( + $ (t_seri(i,1)+zxtsol(i))/2. *RD * + $ (pplay(i,1) - paprs(i,1)))/( (paprs(i,1)+pplay(i,1))/2. * RG) + ENDDO + DO k=1, klev-1 + DO i=1, klon + zx_tmp_fi3d(i,k+1)= zx_tmp_fi3d(i,k) - ( + $ (t_seri(i,k)+t_seri(i,k+1))/2. *RD * + $ (pplay(i,k+1) - pplay(i,k))) / ( paprs(i,k) * RG ) + ENDDO + ENDDO + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_zhalf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_rneb%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rneb%name,itau_w,cldfra) + ENDIF + + IF (o_rnebcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rnebcon%name,itau_w,rnebcon) + ENDIF + + IF (o_rhum%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rhum%name,itau_w,zx_rh) + ENDIF + + IF (o_ozone%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ozone%name, itau_w, + $ wo(:, :, 1) * dobson_u * 1e3 / zmasse / rmo3 * rmd) + ENDIF + + IF (o_ozone_light%flag(iff)<=lev_files(iff) .and. + $ read_climoz == 2) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ozone_light%name, itau_w, + $ wo(:, :, 2) * dobson_u * 1e3 / zmasse / rmo3 * rmd) + ENDIF + + IF (o_dtphy%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtphy%name,itau_w,d_t) + ENDIF + + IF (o_dqphy%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_dqphy%name,itau_w, d_qx(:,:,ivap)) + ENDIF + + DO nsrf=1, nbsrf + IF (o_albe_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_albe_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_rugs_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_rugs_srf(nsrf)%name,itau_w, + $ zx_tmp_fi2d) + ENDIF + + IF (o_ages_srf(nsrf)%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_ages_srf(nsrf)%name,itau_w + $ ,zx_tmp_fi2d) + ENDIF + ENDDO !nsrf=1, nbsrf + + IF (o_alb1%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_alb1%name,itau_w,albsol1) + ENDIF + + IF (o_alb2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_alb2%name,itau_w,albsol2) + ENDIF + +!FH Sorties pour la couche limite + if (iflag_pbl>1) then + zx_tmp_fi3d=0. + do nsrf=1,nbsrf + do k=1,klev + zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k) + $ +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf) + enddo + enddo + IF (o_tke%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tke%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_tke_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_tke_max%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF + endif + + IF (o_kz%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_kz%name,itau_w,coefh) + ENDIF + + IF (.NOT.clef_stations(iff)) THEN + IF (o_kz_max%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_kz_max%name,itau_w,coefh) + ENDIF + ENDIF + + IF (o_clwcon%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_clwcon%name,itau_w,clwcon0) + ENDIF + + IF (o_dtdyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtdyn%name,itau_w,d_t_dyn) + ENDIF + + IF (o_dqdyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqdyn%name,itau_w,d_q_dyn) + ENDIF + + IF (o_dudyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dudyn%name,itau_w,d_u_dyn) + ENDIF + + IF (o_dvdyn%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dvdyn%name,itau_w,d_v_dyn) + ENDIF + + IF (o_dtcon%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtcon%name,itau_w,zx_tmp_fi3d) + ENDIF + + if(iflag_thermals.eq.1)then + IF (o_tntc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + + $ d_t_ajsb(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tntc%name,itau_w,zx_tmp_fi3d) + ENDIF + else if(iflag_thermals.gt.1.and.iflag_wake.EQ.1)then + IF (o_tntc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + + $ d_t_ajs(1:klon,1:klev)/pdtphys + + $ d_t_wake(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tntc%name,itau_w,zx_tmp_fi3d) + ENDIF + endif + + IF (o_ducon%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ducon%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqcon%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqcon%name,itau_w,zx_tmp_fi3d) + ENDIF + + if(iflag_thermals.eq.1)then + IF (o_tnhusc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tnhusc%name,itau_w,zx_tmp_fi3d) + ENDIF + else if(iflag_thermals.gt.1.and.iflag_wake.EQ.1)then + IF (o_tnhusc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys + + $ d_q_ajs(1:klon,1:klev)/pdtphys + + $ d_q_wake(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tnhusc%name,itau_w,zx_tmp_fi3d) + ENDIF + endif + + IF (o_dtlsc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtlsc%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlschr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+ + $ d_t_eva(1:klon,1:klev))/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_dtlschr%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqlsc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqlsc%name,itau_w,zx_tmp_fi3d) + ENDIF + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Sorties specifiques a la separation thermiques/non thermiques + if (iflag_thermals>1) then + + IF (o_dtlscth%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_lscth(1:klon,1:klev)/pdtphys + CALL + s histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtlscth%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlscst%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_lscst(1:klon,1:klev)/pdtphys + CALL + s histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtlscst%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqlscth%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_lscth(1:klon,1:klev)/pdtphys + CALL + s histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqlscth%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqlscst%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_lscst(1:klon,1:klev)/pdtphys + CALL + s histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqlscst%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_plulth%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_plulth%name,itau_w,plul_th) + ENDIF + + IF (o_plulst%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_plulst%name,itau_w,plul_st) + ENDIF + + do k=1,klev + do i=1,klon + if (ptconvth(i,k)) then + zx_tmp_fi3d(i,k)=1. + else + zx_tmp_fi3d(i,k)=0. + endif + enddo + enddo + IF (o_ptconvth%flag(iff)<=lev_files(iff)) THEN + CALL + s histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ptconvth%name,itau_w,zx_tmp_fi3d) + ENDIF + + do i=1,klon + zx_tmp_fi2d(1:klon)=lmax_th(:) + enddo + IF (o_ptconvth%flag(iff)<=lev_files(iff)) THEN + CALL + s histwrite_phy(nid_files(iff),clef_stations(iff), + $o_lmaxth%name,itau_w,zx_tmp_fi2d) + ENDIF + + endif ! iflag_thermals>1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IF (o_dtvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dteva%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dteva%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqeva%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqeva%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_ptconv%flag(iff)<=lev_files(iff)) THEN + zpt_conv = 0. + where (ptconv) zpt_conv = 1. + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ptconv%name,itau_w,zpt_conv) + ENDIF + + IF (o_ratqs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ratqs%name,itau_w,ratqs) + ENDIF + + IF (o_dtthe%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys - + $ d_t_ajsb(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtthe%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (iflag_thermals.gt.1) THEN + IF (o_ftime_th%flag(iff)<=lev_files(iff)) THEN +! Pour l instant 0 a y reflichir pour les thermiques + zx_tmp_fi2d=0. + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ftime_th%name, + s itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_f_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_f_th%name,itau_w,fm_therm) + ENDIF + + IF (o_e_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_e_th%name,itau_w,entr_therm) + ENDIF + + IF (o_w_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_w_th%name,itau_w,zw2) + ENDIF + + IF (o_q_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_q_th%name,itau_w,zqasc) + ENDIF + + IF (o_lambda_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_lambda_th%name,itau_w,lambda_th) + ENDIF + + IF (o_a_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_a_th%name,itau_w,fraca) + ENDIF + + IF (o_d_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_d_th%name,itau_w,detr_therm) + ENDIF + + IF (o_f0_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_f0_th%name,itau_w,f0) + ENDIF + + IF (o_zmax_th%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_zmax_th%name,itau_w,zmax_th) + ENDIF + + IF (o_dqthe%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys - + $ d_q_ajsb(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqthe%name,itau_w,zx_tmp_fi3d) + ENDIF + + ENDIF !iflag_thermals + + IF (o_dtajs%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtajs%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dqajs%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dqajs%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtswr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtswr%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtsw0%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtsw0%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlwr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtlwr%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlw0%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtlw0%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtec%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtec%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_duvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_duvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dvvdf%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dvvdf%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (ok_orodr) THEN + IF (o_duoro%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_duoro%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dvoro%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dvoro%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtoro%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_oro(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtoro%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF + + IF (ok_orolf) THEN + IF (o_dulif%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dulif%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dvlif%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dvlif%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dtlif%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_lif(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dtlif%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF + + IF (ok_hines) THEN + IF (o_duhin%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_u_hin(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_duhin%name,itau_w,zx_tmp_fi3d) + ENDIF + + + IF (o_dvhin%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_v_hin(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dvhin%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dthin%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t_hin(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dthin%name,itau_w,zx_tmp_fi3d) + ENDIF + ENDIF + + IF (o_rsu%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsu%name,itau_w,swup) + ENDIF + IF (o_rsd%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsd%name,itau_w,swdn) + ENDIF + IF (o_rlu%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rlu%name,itau_w,lwup) + ENDIF + IF (o_rld%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rld%name,itau_w,lwdn) + ENDIF + + IF (o_rsucs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsucs%name,itau_w,swup0) + ENDIF + IF (o_rsdcs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsdcs%name,itau_w,swdn0) + ENDIF + IF (o_rlucs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rlucs%name,itau_w,lwup0) + ENDIF + IF (o_rldcs%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rldcs%name,itau_w,lwdn0) + ENDIF + + IF (o_tnt%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_t(1:klon,1:klev)+ + $d_t_dyn(1:klon,1:klev) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tnt%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_tntr%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY - + $cool(1:klon,1:klev)/RDAY + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tntr%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_tntscpbl%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)= (d_t_lsc(1:klon,1:klev)+ + $ d_t_eva(1:klon,1:klev)+ + $ d_t_vdf(1:klon,1:klev))/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tntscpbl%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_tnhus%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_qx(1:klon,1:klev,ivap)+ + $d_q_dyn(1:klon,1:klev) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tnhus%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_tnhusscpbl%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys+ + $ d_q_eva(1:klon,1:klev)/pdtphys + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_tnhusscpbl%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_evu%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_evu%name,itau_w,coefm) + ENDIF + + IF (o_h2o%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=q_seri(1:klon,1:klev)+ + $ ql_seri(1:klon,1:klev) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_h2o%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_mcd%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=-1 * (dnwd(1:klon,1:klev)+ + $ dnwd0(1:klon,1:klev)) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_mcd%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_dmc%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi3d(1:klon,1:klev)=upwd(1:klon,1:klev) + + $ dnwd(1:klon,1:klev)+ dnwd0(1:klon,1:klev) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_dmc%name,itau_w,zx_tmp_fi3d) + ENDIF + + IF (o_ref_liq%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ref_liq%name,itau_w,ref_liq) + ENDIF + + IF (o_ref_ice%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_ref_ice%name,itau_w,ref_ice) + ENDIF + + if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. + $ RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. + $ RCFC12_per.NE.RCFC12_act) THEN + + IF (o_rsut4co2%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swupp ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsut4co2%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_rlut4co2%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = lwupp ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rlut4co2%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_rsutcs4co2%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = swup0p ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsutcs4co2%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_rlutcs4co2%flag(iff)<=lev_files(iff)) THEN + zx_tmp_fi2d(1 : klon) = lwup0p ( 1 : klon, klevp1 ) + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rlutcs4co2%name,itau_w,zx_tmp_fi2d) + ENDIF + + IF (o_rsu4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsu4co2%name,itau_w,swupp) + ENDIF + + IF (o_rlu4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rlu4co2%name,itau_w,lwupp) + ENDIF + + IF (o_rsucs4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsucs4co2%name,itau_w,swup0p) + ENDIF + + IF (o_rlucs4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rlucs4co2%name,itau_w,lwup0p) + ENDIF + + IF (o_rsd4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsd4co2%name,itau_w,swdnp) + ENDIF + + IF (o_rld4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rld4co2%name,itau_w,lwdnp) + ENDIF + + IF (o_rsdcs4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rsdcs4co2%name,itau_w,swdn0p) + ENDIF + + IF (o_rldcs4co2%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + $o_rldcs4co2%name,itau_w,lwdn0p) + ENDIF + + endif + + if (nqtot.GE.3) THEN + DO iq=3,nqtot + IF (o_trac(iq-2)%flag(iff)<=lev_files(iff)) THEN + CALL histwrite_phy(nid_files(iff),clef_stations(iff), + s o_trac(iq-2)%name,itau_w,qx(:,:,iq)) + ENDIF + ENDDO + endif + + if (ok_sync) then +c$OMP MASTER + call histsync(nid_files(iff)) +c$OMP END MASTER + endif + + ENDIF ! clef_files + + ENDDO ! iff=1,nfiles Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_state_var_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_state_var_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phys_state_var_mod.F90 (revision 1634) @@ -0,0 +1,607 @@ +! +! $Id$ +! + MODULE phys_state_var_mod +! Variables sauvegardees pour le startphy.nc +!====================================================================== +! +! +!====================================================================== +! Declaration des variables + USE dimphy + INTEGER, PARAMETER :: nlevSTD=17 + INTEGER, PARAMETER :: nlevSTD8=8 + INTEGER, PARAMETER :: nlevSTD3=3 + INTEGER, PARAMETER :: nout=3 + INTEGER, PARAMETER :: napisccp=1 + INTEGER, SAVE :: radpas +!$OMP THREADPRIVATE(radpas) + REAL, SAVE :: dtime, solaire_etat0 +!$OMP THREADPRIVATE(dtime, solaire_etat0) + + REAL, ALLOCATABLE, SAVE :: rlat(:), rlon(:), pctsrf(:,:) +!$OMP THREADPRIVATE(rlat, rlon, pctsrf) + REAL, ALLOCATABLE, SAVE :: ftsol(:,:) +!$OMP THREADPRIVATE(ftsol) +! character(len=6), SAVE :: ocean +!!!!!!$OMP THREADPRIVATE(ocean) +! logical, SAVE :: ok_veget +!!!!!!$OMP THREADPRIVATE(ok_veget) + REAL, ALLOCATABLE, SAVE :: falb1(:,:), falb2(:,:) +!$OMP THREADPRIVATE(falb1, falb2) + REAL, ALLOCATABLE, SAVE :: rain_fall(:), snow_fall(:) +!$OMP THREADPRIVATE( rain_fall, snow_fall) + REAL, ALLOCATABLE, SAVE :: solsw(:), sollw(:) +!$OMP THREADPRIVATE(solsw, sollw) + REAL, ALLOCATABLE, SAVE :: radsol(:) +!$OMP THREADPRIVATE(radsol) + +!clesphy0 param physiq +! +! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): +! + REAL, ALLOCATABLE, SAVE :: zmea(:), zstd(:), zsig(:), zgam(:) +!$OMP THREADPRIVATE(zmea, zstd, zsig, zgam) + REAL, ALLOCATABLE, SAVE :: zthe(:), zpic(:), zval(:) +!$OMP THREADPRIVATE(zthe, zpic, zval) +! REAL tabcntr0(100) + REAL, ALLOCATABLE, SAVE :: rugoro(:) +!$OMP THREADPRIVATE(rugoro) + REAL, ALLOCATABLE, SAVE :: t_ancien(:,:), q_ancien(:,:) +!$OMP THREADPRIVATE(t_ancien, q_ancien) + REAL, ALLOCATABLE, SAVE :: u_ancien(:,:), v_ancien(:,:) +!$OMP THREADPRIVATE(u_ancien, v_ancien) + LOGICAL, SAVE :: ancien_ok +!$OMP THREADPRIVATE(ancien_ok) + REAL, ALLOCATABLE, SAVE :: clwcon(:,:),rnebcon(:,:) +!$OMP THREADPRIVATE(clwcon,rnebcon) + REAL, ALLOCATABLE, SAVE :: ratqs(:,:) +!$OMP THREADPRIVATE(ratqs) + REAL, ALLOCATABLE, SAVE :: pbl_tke(:,:,:) ! turb kinetic energy +!$OMP THREADPRIVATE(pbl_tke) + REAL, ALLOCATABLE, SAVE :: zmax0(:), f0(:) ! +!$OMP THREADPRIVATE(zmax0,f0) + REAL, ALLOCATABLE, SAVE :: ema_work1(:,:), ema_work2(:,:) +!$OMP THREADPRIVATE(ema_work1,ema_work2) + REAL, ALLOCATABLE, SAVE :: entr_therm(:,:), fm_therm(:,:) +!$OMP THREADPRIVATE(entr_therm,fm_therm) + REAL, ALLOCATABLE, SAVE :: detr_therm(:,:) +!$OMP THREADPRIVATE(detr_therm) +!IM 150408 +! pour phsystoke avec thermiques + REAL,ALLOCATABLE,SAVE :: clwcon0th(:,:),rnebcon0th(:,:) +!$OMP THREADPRIVATE(clwcon0th,rnebcon0th) +! radiation outputs + REAL,ALLOCATABLE,SAVE :: swdn0(:,:), swdn(:,:) +!$OMP THREADPRIVATE(swdn0,swdn) + REAL,ALLOCATABLE,SAVE :: swup0(:,:), swup(:,:) +!$OMP THREADPRIVATE(swup0,swup) + REAL,ALLOCATABLE,SAVE :: SWdn200clr(:), SWdn200(:) +!$OMP THREADPRIVATE(SWdn200clr,SWdn200) + REAL,ALLOCATABLE,SAVE :: SWup200clr(:), SWup200(:) +!$OMP THREADPRIVATE(SWup200clr,SWup200) + REAL,ALLOCATABLE,SAVE :: lwdn0(:,:), lwdn(:,:) +!$OMP THREADPRIVATE(lwdn0,lwdn) + REAL,ALLOCATABLE,SAVE :: lwup0(:,:), lwup(:,:) +!$OMP THREADPRIVATE(lwup0,lwup) + REAL,ALLOCATABLE,SAVE :: LWdn200clr(:), LWdn200(:) +!$OMP THREADPRIVATE(LWdn200clr,LWdn200) + REAL,ALLOCATABLE,SAVE :: LWup200clr(:), LWup200(:) +!$OMP THREADPRIVATE(LWup200clr,LWup200) + REAL,ALLOCATABLE,SAVE :: LWdnTOA(:), LWdnTOAclr(:) +!$OMP THREADPRIVATE(LWdnTOA,LWdnTOAclr) +! pressure level + REAL,ALLOCATABLE,SAVE :: tsumSTD(:,:,:) +!$OMP THREADPRIVATE(tsumSTD) + REAL,ALLOCATABLE,SAVE :: usumSTD(:,:,:), vsumSTD(:,:,:) +!$OMP THREADPRIVATE(usumSTD,vsumSTD) + REAL,ALLOCATABLE,SAVE :: wsumSTD(:,:,:), phisumSTD(:,:,:) +!$OMP THREADPRIVATE(wsumSTD,phisumSTD) + REAL,ALLOCATABLE,SAVE :: qsumSTD(:,:,:), rhsumSTD(:,:,:) +!$OMP THREADPRIVATE(qsumSTD,rhsumSTD) + REAL,ALLOCATABLE,SAVE :: tnondef(:,:,:) +!$OMP THREADPRIVATE(tnondef) + REAL,ALLOCATABLE,SAVE :: uvsumSTD(:,:,:) +!$OMP THREADPRIVATE(uvsumSTD) + REAL,ALLOCATABLE,SAVE :: vqsumSTD(:,:,:) +!$OMP THREADPRIVATE(vqsumSTD) + REAL,ALLOCATABLE,SAVE :: vTsumSTD(:,:,:) +!$OMP THREADPRIVATE(vTsumSTD) + REAL,ALLOCATABLE,SAVE :: wqsumSTD(:,:,:) +!$OMP THREADPRIVATE(wqsumSTD) + REAL,ALLOCATABLE,SAVE :: vphisumSTD(:,:,:) +!$OMP THREADPRIVATE(vphisumSTD) + REAL,ALLOCATABLE,SAVE :: wTsumSTD(:,:,:) +!$OMP THREADPRIVATE(wTsumSTD) + REAL,ALLOCATABLE,SAVE :: u2sumSTD(:,:,:) +!$OMP THREADPRIVATE(u2sumSTD) + REAL,ALLOCATABLE,SAVE :: v2sumSTD(:,:,:) +!$OMP THREADPRIVATE(v2sumSTD) + REAL,ALLOCATABLE,SAVE :: T2sumSTD(:,:,:) +!$OMP THREADPRIVATE(T2sumSTD) + REAL,ALLOCATABLE,SAVE :: O3sumSTD(:,:,:), O3daysumSTD(:,:,:) +!$OMP THREADPRIVATE(O3sumSTD,O3daysumSTD) +!IM begin + REAL,ALLOCATABLE,SAVE :: wlevSTD(:,:), ulevSTD(:,:), vlevSTD(:,:) +!$OMP THREADPRIVATE(wlevSTD,ulevSTD,vlevSTD) + REAL,ALLOCATABLE,SAVE :: tlevSTD(:,:), qlevSTD(:,:), rhlevSTD(:,:) +!$OMP THREADPRIVATE(tlevSTD,qlevSTD,rhlevSTD) + REAL,ALLOCATABLE,SAVE :: philevSTD(:,:) +!$OMP THREADPRIVATE(philevSTD) + REAL,ALLOCATABLE,SAVE :: uvSTD(:,:) +!$OMP THREADPRIVATE(uvSTD) + REAL,ALLOCATABLE,SAVE :: vqSTD(:,:) +!$OMP THREADPRIVATE(vqSTD) + REAL,ALLOCATABLE,SAVE :: vTSTD(:,:) +!$OMP THREADPRIVATE(vTSTD) + REAL,ALLOCATABLE,SAVE :: wqSTD(:,:) +!$OMP THREADPRIVATE(wqSTD) + REAL,ALLOCATABLE,SAVE :: vphiSTD(:,:) +!$OMP THREADPRIVATE(vphiSTD) + REAL,ALLOCATABLE,SAVE :: wTSTD(:,:) +!$OMP THREADPRIVATE(wTSTD) + REAL,ALLOCATABLE,SAVE :: u2STD(:,:) +!$OMP THREADPRIVATE(u2STD) + REAL,ALLOCATABLE,SAVE :: v2STD(:,:) +!$OMP THREADPRIVATE(v2STD) + REAL,ALLOCATABLE,SAVE :: T2STD(:,:) +!$OMP THREADPRIVATE(T2STD) + REAL,ALLOCATABLE,SAVE :: O3STD(:,:), O3daySTD(:,:) +!$OMP THREADPRIVATE(O3STD,O3daySTD) +!IM end + INTEGER,ALLOCATABLE,SAVE :: seed_old(:,:) +!$OMP THREADPRIVATE(seed_old) + REAL,ALLOCATABLE,SAVE :: zuthe(:),zvthe(:) +!$OMP THREADPRIVATE(zuthe,zvthe) + REAL,ALLOCATABLE,SAVE :: alb_neig(:) +!$OMP THREADPRIVATE(alb_neig) +!cloud base mass flux + REAL,ALLOCATABLE,SAVE :: ema_cbmf(:) +!$OMP THREADPRIVATE(ema_cbmf) +!cloud base pressure & cloud top pressure + REAL,ALLOCATABLE,SAVE :: ema_pcb(:), ema_pct(:) +!$OMP THREADPRIVATE(ema_pcb,ema_pct) + REAL,ALLOCATABLE,SAVE :: Ma(:,:) ! undilute upward mass flux +!$OMP THREADPRIVATE(Ma) + REAL,ALLOCATABLE,SAVE :: qcondc(:,:) ! in-cld water content from convect +!$OMP THREADPRIVATE(qcondc) + REAL,ALLOCATABLE,SAVE :: wd(:) ! sb +!$OMP THREADPRIVATE(wd) + REAL,ALLOCATABLE,SAVE :: sigd(:) +!$OMP THREADPRIVATE(sigd) +! + REAL,ALLOCATABLE,SAVE :: cin(:) +!$OMP THREADPRIVATE(cin) +! ftd : differential heating between wake and environment + REAL,ALLOCATABLE,SAVE :: ftd(:,:) +!$OMP THREADPRIVATE(ftd) +! fqd : differential moistening between wake and environment + REAL,ALLOCATABLE,SAVE :: fqd(:,:) +!$OMP THREADPRIVATE(fqd) +!34EK +! -- Variables de controle de ALE et ALP +!ALE : Energie disponible pour soulevement : utilisee par la +! convection d'Emanuel pour le declenchement et la regulation + REAL,ALLOCATABLE,SAVE :: ALE(:) +!$OMP THREADPRIVATE(ALE) +!ALP : Puissance disponible pour soulevement + REAL,ALLOCATABLE,SAVE :: ALP(:) +!$OMP THREADPRIVATE(ALP) +! +! nouvelles variables pour le couplage convection-couche limite + REAL,ALLOCATABLE,SAVE :: Ale_bl(:) +!$OMP THREADPRIVATE(Ale_bl) + REAL,ALLOCATABLE,SAVE :: Alp_bl(:) +!$OMP THREADPRIVATE(Alp_bl) + INTEGER,ALLOCATABLE,SAVE :: lalim_conv(:) +!$OMP THREADPRIVATE(lalim_conv) + REAL,ALLOCATABLE,SAVE :: wght_th(:,:) +!$OMP THREADPRIVATE(wght_th) +! +! variables de la wake +! wake_deltat : ecart de temperature avec la zone non perturbee +! wake_deltaq : ecart d'humidite avec la zone non perturbee +! wake_Cstar : vitesse d'etalement de la poche +! wake_s : fraction surfacique occupee par la poche froide +! wake_pe : wake potential energy - WAPE +! wake_fip : Gust Front Impinging power - ALP +! dt_wake, dq_wake: LS tendencies due to wake + REAL,ALLOCATABLE,SAVE :: wake_deltat(:,:) +!$OMP THREADPRIVATE(wake_deltat) + REAL,ALLOCATABLE,SAVE :: wake_deltaq(:,:) +!$OMP THREADPRIVATE(wake_deltaq) + REAL,ALLOCATABLE,SAVE :: wake_Cstar(:) +!$OMP THREADPRIVATE(wake_Cstar) + REAL,ALLOCATABLE,SAVE :: wake_s(:) +!$OMP THREADPRIVATE(wake_s) + REAL,ALLOCATABLE,SAVE :: wake_pe(:) +!$OMP THREADPRIVATE(wake_pe) + REAL,ALLOCATABLE,SAVE :: wake_fip(:) +!$OMP THREADPRIVATE(wake_fip) + REAL,ALLOCATABLE,SAVE :: dt_wake(:,:) +!$OMP THREADPRIVATE(dt_wake) + REAL,ALLOCATABLE,SAVE :: dq_wake(:,:) +!$OMP THREADPRIVATE(dq_wake) +! +! pfrac_impa : Produits des coefs lessivage impaction +! pfrac_nucl : Produits des coefs lessivage nucleation +! pfrac_1nucl: Produits des coefs lessi nucl (alpha = 1) + REAL,ALLOCATABLE,SAVE :: pfrac_impa(:,:), pfrac_nucl(:,:) +!$OMP THREADPRIVATE(pfrac_impa,pfrac_nucl) + REAL,ALLOCATABLE,SAVE :: pfrac_1nucl(:,:) +!$OMP THREADPRIVATE(pfrac_1nucl) +! + REAL,ALLOCATABLE,SAVE :: total_rain(:), nday_rain(:) +!$OMP THREADPRIVATE(total_rain,nday_rain) + REAL,ALLOCATABLE,SAVE :: paire_ter(:) +!$OMP THREADPRIVATE(paire_ter) +! albsol1: albedo du sol total pour SW visible +! albsol2: albedo du sol total pour SW proche IR + REAL,ALLOCATABLE,SAVE :: albsol1(:), albsol2(:) +!$OMP THREADPRIVATE(albsol1,albsol2) + + REAL, ALLOCATABLE, SAVE:: wo(:, :, :) + ! column-density of ozone in a layer, in kilo-Dobsons + ! Third dimension has size 1 or 2. + ! "wo(:, :, 1)" is for the average day-night field, + ! "wo(:, :, 2)" is for daylight time. + !$OMP THREADPRIVATE(wo) + +! heat : chauffage solaire +! heat0: chauffage solaire ciel clair +! cool : refroidissement infrarouge +! cool0 : refroidissement infrarouge ciel clair +! sollwdown : downward LW flux at surface +! sollwdownclr : downward CS LW flux at surface +! toplwdown : downward CS LW flux at TOA +! toplwdownclr : downward CS LW flux at TOA + REAL,ALLOCATABLE,SAVE :: clwcon0(:,:),rnebcon0(:,:) +!$OMP THREADPRIVATE(clwcon0,rnebcon0) + REAL,ALLOCATABLE,SAVE :: heat(:,:) +!$OMP THREADPRIVATE(heat) + REAL,ALLOCATABLE,SAVE :: heat0(:,:) +!$OMP THREADPRIVATE(heat0) + REAL,ALLOCATABLE,SAVE :: cool(:,:) +!$OMP THREADPRIVATE(cool) + REAL,ALLOCATABLE,SAVE :: cool0(:,:) +!$OMP THREADPRIVATE(cool0) + REAL,ALLOCATABLE,SAVE :: topsw(:), toplw(:) +!$OMP THREADPRIVATE(topsw,toplw) + REAL,ALLOCATABLE,SAVE :: sollwdown(:) +!$OMP THREADPRIVATE(sollwdown) + REAL,ALLOCATABLE,SAVE :: sollwdownclr(:) +!$OMP THREADPRIVATE(sollwdownclr) + REAL,ALLOCATABLE,SAVE :: toplwdown(:) +!$OMP THREADPRIVATE(toplwdown) + REAL,ALLOCATABLE,SAVE :: toplwdownclr(:) +!$OMP THREADPRIVATE(toplwdownclr) + REAL,ALLOCATABLE,SAVE :: topsw0(:),toplw0(:),solsw0(:),sollw0(:) +!$OMP THREADPRIVATE(topsw0,toplw0,solsw0,sollw0) + REAL,ALLOCATABLE,SAVE :: albpla(:) +!$OMP THREADPRIVATE(albpla) + +!IM ajout variables CFMIP2/CMIP5 + REAL,ALLOCATABLE,SAVE :: heatp(:,:), coolp(:,:) +!$OMP THREADPRIVATE(heatp, coolp) + REAL,ALLOCATABLE,SAVE :: heat0p(:,:), cool0p(:,:) +!$OMP THREADPRIVATE(heat0p, cool0p) + REAL,ALLOCATABLE,SAVE :: radsolp(:), topswp(:), toplwp(:) +!$OMP THREADPRIVATE(radsolp, topswp, toplwp) + REAL,ALLOCATABLE,SAVE :: albplap(:) +!$OMP THREADPRIVATE(albplap) + REAL,ALLOCATABLE,SAVE :: solswp(:), sollwp(:) +!$OMP THREADPRIVATE(solswp, sollwp) + REAL,ALLOCATABLE,SAVE :: sollwdownp(:) +!$OMP THREADPRIVATE(sollwdownp) + REAL,ALLOCATABLE,SAVE :: topsw0p(:),toplw0p(:) + REAL,ALLOCATABLE,SAVE :: solsw0p(:),sollw0p(:) +!$OMP THREADPRIVATE(topsw0p,toplw0p,solsw0p,sollw0p) + REAL,ALLOCATABLE,SAVE :: lwdn0p(:,:), lwdnp(:,:) + REAL,ALLOCATABLE,SAVE :: lwup0p(:,:), lwupp(:,:) +!$OMP THREADPRIVATE(lwdn0p, lwdnp, lwup0p, lwupp) + REAL,ALLOCATABLE,SAVE :: swdn0p(:,:), swdnp(:,:) + REAL,ALLOCATABLE,SAVE :: swup0p(:,:), swupp(:,:) +!$OMP THREADPRIVATE(swdn0p, swdnp, swup0p, swupp) + +! pbase : cloud base pressure +! bbase : cloud base buoyancy + REAL,ALLOCATABLE,SAVE :: cape(:) +!$OMP THREADPRIVATE(cape) + REAL,ALLOCATABLE,SAVE :: pbase(:) +!$OMP THREADPRIVATE(pbase) + REAL,ALLOCATABLE,SAVE :: bbase(:) +!$OMP THREADPRIVATE(bbase) +! + REAL,SAVE,ALLOCATABLE :: zqasc(:,:) +!$OMP THREADPRIVATE( zqasc) + INTEGER,ALLOCATABLE,SAVE :: ibas_con(:), itop_con(:) +!$OMP THREADPRIVATE(ibas_con,itop_con) + REAL,SAVE,ALLOCATABLE :: rain_con(:) +!$OMP THREADPRIVATE(rain_con) + REAL,SAVE,ALLOCATABLE :: snow_con(:) +!$OMP THREADPRIVATE(snow_con) +! + REAL,SAVE,ALLOCATABLE :: rlonPOS(:) +!$OMP THREADPRIVATE(rlonPOS) + REAL,SAVE,ALLOCATABLE :: newsst(:) +!$OMP THREADPRIVATE(newsst) + REAL,SAVE,ALLOCATABLE :: u10m(:,:), v10m(:,:) +!$OMP THREADPRIVATE(u10m,v10m) +! +! ok_ade=T -ADE=topswad-topsw +! ok_aie=T -> +! ok_ade=T -AIE=topswai-topswad +! ok_ade=F -AIE=topswai-topsw +! +!topswad, solswad : Aerosol direct effect + REAL,SAVE,ALLOCATABLE :: topswad(:), solswad(:) +!$OMP THREADPRIVATE(topswad,solswad) +!topswai, solswai : Aerosol indirect effect + REAL,SAVE,ALLOCATABLE :: topswai(:), solswai(:) +!$OMP THREADPRIVATE(topswai,solswai) + + REAL,SAVE,ALLOCATABLE :: tau_aero(:,:,:,:), piz_aero(:,:,:,:), cg_aero(:,:,:,:) +!$OMP THREADPRIVATE(tau_aero, piz_aero, cg_aero) + REAL,SAVE,ALLOCATABLE :: ccm(:,:,:) +!$OMP THREADPRIVATE(ccm) + +CONTAINS + +!====================================================================== +SUBROUTINE phys_state_var_init(read_climoz) +use dimphy +USE control_mod +use aero_mod +IMPLICIT NONE + +integer, intent(in):: read_climoz +! read ozone climatology +! Allowed values are 0, 1 and 2 +! 0: do not read an ozone climatology +! 1: read a single ozone climatology that will be used day and night +! 2: read two ozone climatologies, the average day and night +! climatology and the daylight climatology + +#include "indicesol.h" + ALLOCATE(rlat(klon), rlon(klon)) + ALLOCATE(pctsrf(klon,nbsrf)) + ALLOCATE(ftsol(klon,nbsrf)) + ALLOCATE(falb1(klon,nbsrf)) + ALLOCATE(falb2(klon,nbsrf)) + ALLOCATE(rain_fall(klon)) + ALLOCATE(snow_fall(klon)) + ALLOCATE(solsw(klon), sollw(klon)) + ALLOCATE(radsol(klon)) + ALLOCATE(zmea(klon), zstd(klon), zsig(klon), zgam(klon)) + ALLOCATE(zthe(klon), zpic(klon), zval(klon)) + + ALLOCATE(rugoro(klon)) + ALLOCATE(t_ancien(klon,klev), q_ancien(klon,klev)) + ALLOCATE(u_ancien(klon,klev), v_ancien(klon,klev)) + ALLOCATE(clwcon(klon,klev),rnebcon(klon,klev)) + ALLOCATE(ratqs(klon,klev)) + ALLOCATE(pbl_tke(klon,klev+1,nbsrf)) + ALLOCATE(zmax0(klon), f0(klon)) + ALLOCATE(ema_work1(klon,klev), ema_work2(klon,klev)) + ALLOCATE(entr_therm(klon,klev), fm_therm(klon,klev+1)) + ALLOCATE(detr_therm(klon,klev)) +! pour phsystoke avec thermiques + ALLOCATE(clwcon0th(klon,klev),rnebcon0th(klon,klev)) +! radiation outputs + ALLOCATE(swdn0(klon,klevp1), swdn(klon,klevp1)) + ALLOCATE(swup0(klon,klevp1), swup(klon,klevp1)) + ALLOCATE(lwdn0(klon,klevp1), lwdn(klon,klevp1)) + ALLOCATE(lwup0(klon,klevp1), lwup(klon,klevp1)) + ALLOCATE(SWdn200clr(klon), SWdn200(klon)) + ALLOCATE(SWup200clr(klon), SWup200(klon)) + ALLOCATE(LWdn200clr(klon), LWdn200(klon)) + ALLOCATE(LWup200clr(klon), LWup200(klon)) + ALLOCATE(LWdnTOA(klon), LWdnTOAclr(klon)) +! pressure level + ALLOCATE(tsumSTD(klon,nlevSTD,nout)) + ALLOCATE(usumSTD(klon,nlevSTD,nout), vsumSTD(klon,nlevSTD,nout)) + ALLOCATE(wsumSTD(klon,nlevSTD,nout), phisumSTD(klon,nlevSTD,nout)) + ALLOCATE(qsumSTD(klon,nlevSTD,nout), rhsumSTD(klon,nlevSTD,nout)) + ALLOCATE(tnondef(klon,nlevSTD,nout)) + ALLOCATE(uvsumSTD(klon,nlevSTD,nout)) + ALLOCATE(vqsumSTD(klon,nlevSTD,nout)) + ALLOCATE(vTsumSTD(klon,nlevSTD,nout)) + ALLOCATE(wqsumSTD(klon,nlevSTD,nout)) + ALLOCATE(vphisumSTD(klon,nlevSTD,nout)) + ALLOCATE(wTsumSTD(klon,nlevSTD,nout)) + ALLOCATE(u2sumSTD(klon,nlevSTD,nout)) + ALLOCATE(v2sumSTD(klon,nlevSTD,nout)) + ALLOCATE(T2sumSTD(klon,nlevSTD,nout)) + ALLOCATE(O3sumSTD(klon,nlevSTD,nout)) + ALLOCATE(O3daysumSTD(klon,nlevSTD,nout)) +!IM beg + ALLOCATE(wlevSTD(klon,nlevSTD), ulevSTD(klon,nlevSTD), vlevSTD(klon,nlevSTD)) + ALLOCATE(tlevSTD(klon,nlevSTD), qlevSTD(klon,nlevSTD), rhlevSTD(klon,nlevSTD)) + ALLOCATE(philevSTD(klon,nlevSTD)) + ALLOCATE(uvSTD(klon,nlevSTD),vqSTD(klon,nlevSTD)) + ALLOCATE(vTSTD(klon,nlevSTD),wqSTD(klon,nlevSTD)) + ALLOCATE(vphiSTD(klon,nlevSTD),wTSTD(klon,nlevSTD)) + ALLOCATE(u2STD(klon,nlevSTD),v2STD(klon,nlevSTD)) + ALLOCATE(T2STD(klon,nlevSTD)) + ALLOCATE(O3STD(klon,nlevSTD)) + ALLOCATE(O3daySTD(klon,nlevSTD)) +!IM end + ALLOCATE(seed_old(klon,napisccp)) + ALLOCATE(zuthe(klon),zvthe(klon)) + ALLOCATE(alb_neig(klon)) +!cloud base mass flux + ALLOCATE(ema_cbmf(klon)) +!cloud base pressure & cloud top pressure + ALLOCATE(ema_pcb(klon), ema_pct(klon)) +! + ALLOCATE(Ma(klon,klev)) + ALLOCATE(qcondc(klon,klev)) + ALLOCATE(wd(klon)) + ALLOCATE(sigd(klon)) + ALLOCATE(cin(klon), ALE(klon), ALP(klon)) + ALLOCATE(ftd(klon,klev), fqd(klon,klev)) + ALLOCATE(Ale_bl(klon)) + ALLOCATE(Alp_bl(klon)) + ALLOCATE(lalim_conv(klon)) + ALLOCATE(wght_th(klon,klev)) + ALLOCATE(wake_deltat(klon,klev), wake_deltaq(klon,klev)) + ALLOCATE(wake_Cstar(klon), wake_s(klon)) + ALLOCATE(wake_pe(klon), wake_fip(klon)) + ALLOCATE(dt_wake(klon,klev), dq_wake(klon,klev)) + ALLOCATE(pfrac_impa(klon,klev), pfrac_nucl(klon,klev)) + ALLOCATE(pfrac_1nucl(klon,klev)) + ALLOCATE(total_rain(klon), nday_rain(klon)) + ALLOCATE(paire_ter(klon)) + ALLOCATE(albsol1(klon), albsol2(klon)) + + if (read_climoz <= 1) then + ALLOCATE(wo(klon,klev, 1)) + else + ! read_climoz == 2 + ALLOCATE(wo(klon,klev, 2)) + end if + + ALLOCATE(clwcon0(klon,klev),rnebcon0(klon,klev)) + ALLOCATE(heat(klon,klev), heat0(klon,klev)) + ALLOCATE(cool(klon,klev), cool0(klon,klev)) + ALLOCATE(topsw(klon), toplw(klon)) + ALLOCATE(sollwdown(klon), sollwdownclr(klon)) + ALLOCATE(toplwdown(klon), toplwdownclr(klon)) + ALLOCATE(topsw0(klon),toplw0(klon),solsw0(klon),sollw0(klon)) + ALLOCATE(albpla(klon)) +!IM ajout variables CFMIP2/CMIP5 + ALLOCATE(heatp(klon,klev), coolp(klon,klev)) + ALLOCATE(heat0p(klon,klev), cool0p(klon,klev)) + ALLOCATE(radsolp(klon), topswp(klon), toplwp(klon)) + ALLOCATE(albplap(klon)) + ALLOCATE(solswp(klon), sollwp(klon)) + ALLOCATE(sollwdownp(klon)) + ALLOCATE(topsw0p(klon),toplw0p(klon)) + ALLOCATE(solsw0p(klon),sollw0p(klon)) + ALLOCATE(lwdn0p(klon,klevp1), lwdnp(klon,klevp1)) + ALLOCATE(lwup0p(klon,klevp1), lwupp(klon,klevp1)) + ALLOCATE(swdn0p(klon,klevp1), swdnp(klon,klevp1)) + ALLOCATE(swup0p(klon,klevp1), swupp(klon,klevp1)) + + ALLOCATE(cape(klon)) + ALLOCATE(pbase(klon),bbase(klon)) + ALLOCATE(zqasc(klon,klev)) + ALLOCATE(ibas_con(klon), itop_con(klon)) + ALLOCATE(rain_con(klon), snow_con(klon)) + ALLOCATE(rlonPOS(klon)) + ALLOCATE(newsst(klon)) + ALLOCATE(u10m(klon,nbsrf), v10m(klon,nbsrf)) + ALLOCATE(topswad(klon), solswad(klon)) + ALLOCATE(topswai(klon), solswai(klon)) + ALLOCATE(tau_aero(klon,klev,naero_grp,nbands),piz_aero(klon,klev,naero_grp,nbands),cg_aero(klon,klev,naero_grp,nbands)) + ALLOCATE(ccm(klon,klev,nbands)) + +END SUBROUTINE phys_state_var_init + +!====================================================================== +SUBROUTINE phys_state_var_end +use dimphy +use control_mod +IMPLICIT NONE +#include "indicesol.h" + + deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2) + deallocate(rain_fall, snow_fall, solsw, sollw, radsol) + deallocate(zmea, zstd, zsig, zgam) + deallocate(zthe, zpic, zval) + deallocate(rugoro, t_ancien, q_ancien, clwcon, rnebcon) + deallocate( u_ancien, v_ancien ) + deallocate(ratqs, pbl_tke) + deallocate(zmax0, f0) + deallocate(ema_work1, ema_work2) + deallocate(entr_therm, fm_therm) + deallocate(detr_therm) + deallocate(clwcon0th, rnebcon0th) +! radiation outputs + deallocate(swdn0, swdn) + deallocate(swup0, swup) + deallocate(lwdn0, lwdn) + deallocate(lwup0, lwup) + deallocate(SWdn200clr, SWdn200) + deallocate(SWup200clr, SWup200) + deallocate(LWdn200clr, LWdn200) + deallocate(LWup200clr, LWup200) + deallocate(LWdnTOA, LWdnTOAclr) +! pressure level + deallocate(tsumSTD) + deallocate(usumSTD, vsumSTD) + deallocate(wsumSTD, phisumSTD) + deallocate(tnondef) + deallocate(qsumSTD, rhsumSTD) + deallocate(uvsumSTD) + deallocate(vqsumSTD) + deallocate(vTsumSTD) + deallocate(wqsumSTD) + deallocate(vphisumSTD) + deallocate(wTsumSTD) + deallocate(u2sumSTD) + deallocate(v2sumSTD) + deallocate(T2sumSTD) + deallocate(O3sumSTD) + deallocate(O3daysumSTD) +!IM beg + deallocate(wlevSTD,ulevSTD,vlevSTD,tlevSTD,qlevSTD,rhlevSTD,philevSTD) + deallocate(uvSTD,vqSTD,vTSTD,wqSTD,vphiSTD,wTSTD,u2STD,v2STD,T2STD,O3STD,O3daySTD) +!IM end + deallocate(seed_old) + deallocate(zuthe, zvthe) + deallocate(alb_neig) + deallocate(ema_cbmf) + deallocate(ema_pcb, ema_pct) + deallocate(Ma, qcondc) + deallocate(wd, sigd) + deallocate(cin, ALE, ALP) + deallocate(ftd, fqd) + deallocate(Ale_bl, Alp_bl) + deallocate(lalim_conv, wght_th) + deallocate(wake_deltat, wake_deltaq) + deallocate(wake_Cstar, wake_s, wake_pe, wake_fip) + deallocate(dt_wake, dq_wake) + deallocate(pfrac_impa, pfrac_nucl) + deallocate(pfrac_1nucl) + deallocate(total_rain, nday_rain) + deallocate(paire_ter) + deallocate(albsol1, albsol2) + deallocate(wo) + deallocate(clwcon0,rnebcon0) + deallocate(heat, heat0) + deallocate(cool, cool0) + deallocate(topsw, toplw) + deallocate(sollwdown, sollwdownclr) + deallocate(toplwdown, toplwdownclr) + deallocate(topsw0,toplw0,solsw0,sollw0) + deallocate(albpla) +!IM ajout variables CFMIP2/CMIP5 + deallocate(heatp, coolp) + deallocate(heat0p, cool0p) + deallocate(radsolp, topswp, toplwp) + deallocate(albplap) + deallocate(solswp, sollwp) + deallocate(sollwdownp) + deallocate(topsw0p,toplw0p) + deallocate(solsw0p,sollw0p) + deallocate(lwdn0p, lwdnp) + deallocate(lwup0p, lwupp) + deallocate(swdn0p, swdnp) + deallocate(swup0p, swupp) + deallocate(cape) + deallocate(pbase,bbase) + deallocate(zqasc) + deallocate(ibas_con, itop_con) + deallocate(rain_con, snow_con) + deallocate(rlonPOS) + deallocate(newsst) + deallocate(u10m, v10m) + deallocate(topswad, solswad) + deallocate(topswai, solswai) + deallocate(tau_aero,piz_aero,cg_aero) + deallocate(ccm) + +END SUBROUTINE phys_state_var_end + + END MODULE phys_state_var_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/physiq.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/physiq.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/physiq.F (revision 1634) @@ -0,0 +1,4181 @@ +! $Id$ +c#define IO_DEBUG + + SUBROUTINE physiq (nlon,nlev, + . debut,lafin,jD_cur, jH_cur,pdtphys, + . paprs,pplay,pphi,pphis,presnivs,clesphy0, + . u,v,t,qx, + . flxmass_w, + . d_u, d_v, d_t, d_qx, d_ps + . , dudyn + . , PVteta) + + USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, + $ histwrite, ju2ymds, ymds2ju, ioget_year_len + USE comgeomphy + USE phys_cal_mod + USE write_field_phy + USE dimphy + USE infotrac + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy + USE misc_mod, mydebug=>debug + USE vampir + USE pbl_surface_mod, ONLY : pbl_surface + USE change_srf_frac_mod + USE surface_data, ONLY : type_ocean, ok_veget + USE phys_local_var_mod ! Variables internes non sauvegardees de la physique + USE phys_state_var_mod ! Variables sauvegardees de la physique + USE phys_output_var_mod ! Variables pour les ecritures des sorties + USE fonte_neige_mod, ONLY : fonte_neige_get_vars + USE phys_output_mod + use open_climoz_m, only: open_climoz ! ozone climatology from a file + use regr_pr_av_m, only: regr_pr_av + use netcdf95, only: nf95_close +cIM for NMC files + use netcdf, only: nf90_fill_real + use mod_phys_lmdz_mpi_data, only: is_mpi_root + USE aero_mod + use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer + use conf_phys_m, only: conf_phys + use radlwsw_m, only: radlwsw + USE control_mod + + +!IM stations CFMIP + USE CFMIP_point_locations + IMPLICIT none +c====================================================================== +c +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c +c Objet: Moniteur general de la physique du modele +cAA Modifications quant aux traceurs : +cAA - uniformisation des parametrisations ds phytrac +cAA - stockage des moyennes des champs necessaires +cAA en mode traceur off-line +c====================================================================== +c CLEFS CPP POUR LES IO +c ===================== +#define histNMC +c#define histISCCP +c====================================================================== +c modif ( P. Le Van , 12/10/98 ) +c +c Arguments: +c +c nlon----input-I-nombre de points horizontaux +c nlev----input-I-nombre de couches verticales, doit etre egale a klev +c debut---input-L-variable logique indiquant le premier passage +c lafin---input-L-variable logique indiquant le dernier passage +c jD_cur -R-jour courant a l'appel de la physique (jour julien) +c jH_cur -R-heure courante a l'appel de la physique (jour julien) +c pdtphys-input-R-pas d'integration pour la physique (seconde) +c paprs---input-R-pression pour chaque inter-couche (en Pa) +c pplay---input-R-pression pour le mileu de chaque couche (en Pa) +c pphi----input-R-geopotentiel de chaque couche (g z) (reference sol) +c pphis---input-R-geopotentiel du sol +c presnivs-input_R_pressions approximat. des milieux couches ( en PA) +c u-------input-R-vitesse dans la direction X (de O a E) en m/s +c v-------input-R-vitesse Y (de S a N) en m/s +c t-------input-R-temperature (K) +c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs +c d_t_dyn-input-R-tendance dynamique pour "t" (K/s) +c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s) +c flxmass_w -input-R- flux de masse verticale +c d_u-----output-R-tendance physique de "u" (m/s/s) +c d_v-----output-R-tendance physique de "v" (m/s/s) +c d_t-----output-R-tendance physique de "t" (K/s) +c d_qx----output-R-tendance physique de "qx" (kg/kg/s) +c d_ps----output-R-tendance physique de la pression au sol +cIM +c PVteta--output-R-vorticite potentielle a des thetas constantes +c====================================================================== +#include "dimensions.h" + integer jjmp1 + parameter (jjmp1=jjm+1-1/jjm) + integer iip1 + parameter (iip1=iim+1) + +#include "regdim.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "clesphys.h" +#include "temps.h" +#include "iniprint.h" +#include "thermcell.h" +c====================================================================== + LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE + PARAMETER (ok_cvl=.TRUE.) + LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface + PARAMETER (ok_gust=.FALSE.) + integer iflag_radia ! active ou non le rayonnement (MPL) + save iflag_radia +c$OMP THREADPRIVATE(iflag_radia) +c====================================================================== + LOGICAL check ! Verifier la conservation du modele en eau + PARAMETER (check=.FALSE.) + LOGICAL ok_stratus ! Ajouter artificiellement les stratus + PARAMETER (ok_stratus=.FALSE.) +c====================================================================== + REAL amn, amx + INTEGER igout +c====================================================================== +c Clef controlant l'activation du cycle diurne: +ccc LOGICAL cycle_diurne +ccc PARAMETER (cycle_diurne=.FALSE.) +c====================================================================== +c Modele thermique du sol, a activer pour le cycle diurne: +ccc LOGICAL soil_model +ccc PARAMETER (soil_model=.FALSE.) +c====================================================================== +c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans +c le calcul du rayonnement est celle apres la precipitation des nuages. +c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre +c la condensation et la precipitation. Cette cle augmente les impacts +c radiatifs des nuages. +ccc LOGICAL new_oliq +ccc PARAMETER (new_oliq=.FALSE.) +c====================================================================== +c Clefs controlant deux parametrisations de l'orographie: +cc LOGICAL ok_orodr +ccc PARAMETER (ok_orodr=.FALSE.) +ccc LOGICAL ok_orolf +ccc PARAMETER (ok_orolf=.FALSE.) +c====================================================================== + LOGICAL ok_journe ! sortir le fichier journalier + save ok_journe +c$OMP THREADPRIVATE(ok_journe) +c + LOGICAL ok_mensuel ! sortir le fichier mensuel + save ok_mensuel +c$OMP THREADPRIVATE(ok_mensuel) +c + LOGICAL ok_instan ! sortir le fichier instantane + save ok_instan +c$OMP THREADPRIVATE(ok_instan) +c + LOGICAL ok_LES ! sortir le fichier LES + save ok_LES +c$OMP THREADPRIVATE(ok_LES) +c + LOGICAL callstats ! sortir le fichier stats + save callstats +c$OMP THREADPRIVATE(callstats) +c + LOGICAL ok_region ! sortir le fichier regional + PARAMETER (ok_region=.FALSE.) +c====================================================================== + real weak_inversion(klon),dthmin(klon) + real seuil_inversion + save seuil_inversion +c$OMP THREADPRIVATE(seuil_inversion) + integer iflag_ratqs + save iflag_ratqs +c$OMP THREADPRIVATE(iflag_ratqs) + real facteur,zfratqs1,zfratqs2 + + REAL lambda_th(klon,klev),zz,znum,zden + REAL wmax_th(klon) + REAL zmax_th(klon) + REAL tau_overturning_th(klon) + + integer lmax_th(klon) + integer limbas(klon) + real ratqscth(klon,klev) + real ratqsdiff(klon,klev) + real zqsatth(klon,klev) + +c====================================================================== +c + INTEGER ivap ! indice de traceurs pour vapeur d'eau + PARAMETER (ivap=1) + INTEGER iliq ! indice de traceurs pour eau liquide + PARAMETER (iliq=2) + +c +c +c Variables argument: +c + INTEGER nlon + INTEGER nlev + REAL, intent(in):: jD_cur, jH_cur + + REAL pdtphys + LOGICAL debut, lafin + REAL paprs(klon,klev+1) + REAL pplay(klon,klev) + REAL pphi(klon,klev) + REAL pphis(klon) + REAL presnivs(klev) + REAL znivsig(klev) + real pir + + REAL u(klon,klev) + REAL v(klon,klev) + REAL t(klon,klev),theta(klon,klev) + REAL qx(klon,klev,nqtot) + REAL flxmass_w(klon,klev) + REAL omega(klon,klev) ! vitesse verticale en Pa/s + REAL d_u(klon,klev) + REAL d_v(klon,klev) + REAL d_t(klon,klev) + REAL d_qx(klon,klev,nqtot) + REAL d_ps(klon) + real da(klon,klev),phi(klon,klev,klev),mp(klon,klev) +!IM definition dynamique o_trac dans phys_output_open +! type(ctrl_out) :: o_trac(nqtot) +c +cIM Amip2 PV a theta constante +c + INTEGER nbteta + PARAMETER(nbteta=3) + CHARACTER*3 ctetaSTD(nbteta) + DATA ctetaSTD/'350','380','405'/ + SAVE ctetaSTD +c$OMP THREADPRIVATE(ctetaSTD) + REAL rtetaSTD(nbteta) + DATA rtetaSTD/350., 380., 405./ + SAVE rtetaSTD +c$OMP THREADPRIVATE(rtetaSTD) +c + REAL PVteta(klon,nbteta) + REAL zx_tmp_3dte(iim,jjmp1,nbteta) +c +cMI Amip2 PV a theta constante + +cym INTEGER klevp1, klevm1 +cym PARAMETER(klevp1=klev+1,klevm1=klev-1) +cym#include "raddim.h" +c +c +cIM Amip2 +c variables a une pression donnee +c + real rlevSTD(nlevSTD) + DATA rlevSTD/100000., 92500., 85000., 70000., + .60000., 50000., 40000., 30000., 25000., 20000., + .15000., 10000., 7000., 5000., 3000., 2000., 1000./ + SAVE rlevstd +c$OMP THREADPRIVATE(rlevstd) + CHARACTER*4 clevSTD(nlevSTD) + DATA clevSTD/'1000','925 ','850 ','700 ','600 ', + .'500 ','400 ','300 ','250 ','200 ','150 ','100 ', + .'70 ','50 ','30 ','20 ','10 '/ + SAVE clevSTD +c$OMP THREADPRIVATE(clevSTD) +c + CHARACTER*4 bb2 + CHARACTER*2 bb3 + + real twriteSTD(klon,nlevSTD,nfiles) + real qwriteSTD(klon,nlevSTD,nfiles) + real rhwriteSTD(klon,nlevSTD,nfiles) + real phiwriteSTD(klon,nlevSTD,nfiles) + real uwriteSTD(klon,nlevSTD,nfiles) + real vwriteSTD(klon,nlevSTD,nfiles) + real wwriteSTD(klon,nlevSTD,nfiles) +cIM for NMC files + REAL geo500(klon) + real :: rlevSTD3(nlevSTD3) + DATA rlevSTD3/85000., 50000., 25000./ + SAVE rlevSTD3 +c$OMP THREADPRIVATE(rlevSTD3) + real :: rlevSTD8(nlevSTD8) + DATA rlevSTD8/100000., 85000., 70000., 50000., 25000., 10000., + $ 5000., 1000./ + SAVE rlevSTD8 +c$OMP THREADPRIVATE(rlevSTD8) + real twriteSTD3(klon,nlevSTD3) + real qwriteSTD3(klon,nlevSTD3) + real rhwriteSTD3(klon,nlevSTD3) + real phiwriteSTD3(klon,nlevSTD3) + real uwriteSTD3(klon,nlevSTD3) + real vwriteSTD3(klon,nlevSTD3) + real wwriteSTD3(klon,nlevSTD3) +c + real tnondefSTD8(klon,nlevSTD8) + real twriteSTD8(klon,nlevSTD8) + real qwriteSTD8(klon,nlevSTD8) + real rhwriteSTD8(klon,nlevSTD8) + real phiwriteSTD8(klon,nlevSTD8) + real uwriteSTD8(klon,nlevSTD8) + real vwriteSTD8(klon,nlevSTD8) + real wwriteSTD8(klon,nlevSTD8) +c +c plevSTD3 END +c +c nout : niveau de output des variables a une pression donnee + logical oknondef(klon,nlevSTD,nout) +c +c les produits uvSTD, vqSTD, .., T2STD sont calcules +c a partir des valeurs instantannees toutes les 6 h +c qui sont moyennees sur le mois +c +#include "radopt.h" +c +c +c prw: precipitable water + real prw(klon) + + REAL convliq(klon,klev) ! eau liquide nuageuse convective + REAL convfra(klon,klev) ! fraction nuageuse convective + + REAL cldl_c(klon),cldm_c(klon),cldh_c(klon) !nuages bas, moyen et haut + REAL cldt_c(klon),cldq_c(klon) !nuage total, eau liquide integree + REAL cldl_s(klon),cldm_s(klon),cldh_s(klon) !nuages bas, moyen et haut + REAL cldt_s(klon),cldq_s(klon) !nuage total, eau liquide integree + + INTEGER linv, kp1 +c flwp, fiwp = Liquid Water Path & Ice Water Path (kg/m2) +c flwc, fiwc = Liquid Water Content & Ice Water Content (kg/kg) + REAL flwp(klon), fiwp(klon) + REAL flwc(klon,klev), fiwc(klon,klev) + REAL flwp_c(klon), fiwp_c(klon) + REAL flwc_c(klon,klev), fiwc_c(klon,klev) + REAL flwp_s(klon), fiwp_s(klon) + REAL flwc_s(klon,klev), fiwc_s(klon,klev) + +cIM ISCCP simulator v3.4 +c dans clesphys.h top_height, overlap +cv3.4 + INTEGER debug, debugcol +cym INTEGER npoints +cym PARAMETER(npoints=klon) +c + INTEGER sunlit(klon) !sunlit=1 if day; sunlit=0 if night + INTEGER nregISCtot + PARAMETER(nregISCtot=1) +c +c imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire +c y compris pour 1 point +c imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude) +c jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude) + INTEGER imin_debut, nbpti + INTEGER jmin_debut, nbptj +cIM parametres ISCCP BEG + INTEGER nbapp_isccp +! INTEGER nbapp_isccp,isccppas +! PARAMETER(isccppas=6) !appel du simulateurs tous les 6pas de temps de la physique +! !i.e. toutes les 3 heures + INTEGER n + INTEGER ifreq_isccp(napisccp), freqin_pdt(napisccp) + DATA ifreq_isccp/3/ + SAVE ifreq_isccp +c$OMP THREADPRIVATE(ifreq_isccp) + CHARACTER*5 typinout(napisccp) + DATA typinout/'i3od'/ + SAVE typinout +c$OMP THREADPRIVATE(typinout) +cIM verif boxptop BEG + CHARACTER*1 verticaxe(napisccp) + DATA verticaxe/'1'/ + SAVE verticaxe +c$OMP THREADPRIVATE(verticaxe) +cIM verif boxptop END + INTEGER nvlev(napisccp) +c INTEGER nvlev + REAL t1, aa + REAL seed_re(klon,napisccp) +cym !!!! A voir plus tard +cym INTEGER iphy(iim,jjmp1) +cIM parametres ISCCP END +c +c ncol = nb. de sous-colonnes pour chaque maille du GCM +c ncolmx = No. max. de sous-colonnes pour chaque maille du GCM +c INTEGER ncol(napisccp), ncolmx, seed(klon,napisccp) + INTEGER,SAVE :: ncol(napisccp) +c$OMP THREADPRIVATE(ncol) + INTEGER ncolmx, seed(klon,napisccp) + REAL nbsunlit(nregISCtot,klon,napisccp) !nbsunlit : moyenne de sunlit +c PARAMETER(ncolmx=1500) + PARAMETER(ncolmx=300) +c +cIM verif boxptop BEG + REAL vertlev(ncolmx,napisccp) +cIM verif boxptop END +c + REAL,SAVE :: tautab_omp(0:255),tautab(0:255) + INTEGER,SAVE :: invtau_omp(-20:45000),invtau(-20:45000) +c$OMP THREADPRIVATE(tautab,invtau) + REAL emsfc_lw + PARAMETER(emsfc_lw=0.99) +c REAL ran0 ! type for random number fuction +c + REAL cldtot(klon,klev) +c variables de haut en bas pour le simulateur ISCCP + REAL dtau_s(klon,klev) !tau nuages startiformes + REAL dtau_c(klon,klev) !tau nuages convectifs + REAL dem_s(klon,klev) !emissivite nuages startiformes + REAL dem_c(klon,klev) !emissivite nuages convectifs +c +c variables de haut en bas pour le simulateur ISCCP + REAL pfull(klon,klev) + REAL phalf(klon,klev+1) + REAL qv(klon,klev) + REAL cc(klon,klev) + REAL conv(klon,klev) + REAL dtau_sH2B(klon,klev) + REAL dtau_cH2B(klon,klev) + REAL at(klon,klev) + REAL dem_sH2B(klon,klev) + REAL dem_cH2B(klon,klev) +c + INTEGER kmax, lmax, lmax3 + PARAMETER(kmax=8, lmax=8, lmax3=3) + INTEGER kmaxm1, lmaxm1 + PARAMETER(kmaxm1=kmax-1, lmaxm1=lmax-1) + INTEGER iimx7, jjmx7, jjmp1x7 + PARAMETER(iimx7=iim*kmaxm1, jjmx7=jjm*lmaxm1, + .jjmp1x7=jjmp1*lmaxm1) +c +c output from ISCCP simulator + REAL fq_isccp(klon,kmaxm1,lmaxm1,napisccp) + REAL fq_is_true(klon,kmaxm1,lmaxm1,napisccp) + REAL totalcldarea(klon,napisccp) + REAL meanptop(klon,napisccp) + REAL meantaucld(klon,napisccp) + REAL boxtau(klon,ncolmx,napisccp) + REAL boxptop(klon,ncolmx,napisccp) + REAL zx_tmp_fi3d_bx(klon,ncolmx) + REAL zx_tmp_3d_bx(iim,jjmp1,ncolmx) +c + REAL cld_fi3d(klon,lmax3) + REAL cld_3d(iim,jjmp1,lmax3) +c + INTEGER iw, iwmax + REAL wmin, pas_w +c PARAMETER(wmin=-100.,pas_w=10.,iwmax=30) +cIM 051005 PARAMETER(wmin=-200.,pas_w=10.,iwmax=40) + PARAMETER(wmin=-100.,pas_w=10.,iwmax=20) + REAL o500(klon) +c + +c sorties ISCCP + + integer nid_isccp + save nid_isccp +c$OMP THREADPRIVATE(nid_isccp) + + REAL zx_tau(kmaxm1), zx_pc(lmaxm1), zx_o500(iwmax) + DATA zx_tau/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60./ + SAVE zx_tau + DATA zx_pc/180., 310., 440., 560., 680., 800., 1000./ + SAVE zx_pc +c$OMP THREADPRIVATE(zx_tau,zx_pc) +c cldtopres pression au sommet des nuages + REAL cldtopres(lmaxm1), cldtopres3(lmax3) + DATA cldtopres/180., 310., 440., 560., 680., 800., 1000./ + DATA cldtopres3/440., 680., 1000./ + SAVE cldtopres,cldtopres3 +c$OMP THREADPRIVATE(cldtopres,cldtopres3) +cIM 051005 BEG + INTEGER komega, nhoriRD + +c taulev: numero du niveau de tau dans les sorties ISCCP + CHARACTER *4 taulev(kmaxm1) +c DATA taulev/'tau1','tau2','tau3','tau4','tau5','tau6','tau7'/ + DATA taulev/'tau0','tau1','tau2','tau3','tau4','tau5','tau6'/ + CHARACTER *3 pclev(lmaxm1) + DATA pclev/'pc1','pc2','pc3','pc4','pc5','pc6','pc7'/ + SAVE taulev,pclev +c$OMP THREADPRIVATE(taulev,pclev) +c +c cnameisccp + CHARACTER *29 cnameisccp(lmaxm1,kmaxm1) +cIM bad 151205 DATA cnameisccp/'pc< 50hPa, tau< 0.3', + DATA cnameisccp/'pc= 50-180hPa, tau< 0.3', + . 'pc= 180-310hPa, tau< 0.3', + . 'pc= 310-440hPa, tau< 0.3', + . 'pc= 440-560hPa, tau< 0.3', + . 'pc= 560-680hPa, tau< 0.3', + . 'pc= 680-800hPa, tau< 0.3', + . 'pc= 800-1000hPa, tau< 0.3', + . 'pc= 50-180hPa, tau= 0.3-1.3', + . 'pc= 180-310hPa, tau= 0.3-1.3', + . 'pc= 310-440hPa, tau= 0.3-1.3', + . 'pc= 440-560hPa, tau= 0.3-1.3', + . 'pc= 560-680hPa, tau= 0.3-1.3', + . 'pc= 680-800hPa, tau= 0.3-1.3', + . 'pc= 800-1000hPa, tau= 0.3-1.3', + . 'pc= 50-180hPa, tau= 1.3-3.6', + . 'pc= 180-310hPa, tau= 1.3-3.6', + . 'pc= 310-440hPa, tau= 1.3-3.6', + . 'pc= 440-560hPa, tau= 1.3-3.6', + . 'pc= 560-680hPa, tau= 1.3-3.6', + . 'pc= 680-800hPa, tau= 1.3-3.6', + . 'pc= 800-1000hPa, tau= 1.3-3.6', + . 'pc= 50-180hPa, tau= 3.6-9.4', + . 'pc= 180-310hPa, tau= 3.6-9.4', + . 'pc= 310-440hPa, tau= 3.6-9.4', + . 'pc= 440-560hPa, tau= 3.6-9.4', + . 'pc= 560-680hPa, tau= 3.6-9.4', + . 'pc= 680-800hPa, tau= 3.6-9.4', + . 'pc= 800-1000hPa, tau= 3.6-9.4', + . 'pc= 50-180hPa, tau= 9.4-23', + . 'pc= 180-310hPa, tau= 9.4-23', + . 'pc= 310-440hPa, tau= 9.4-23', + . 'pc= 440-560hPa, tau= 9.4-23', + . 'pc= 560-680hPa, tau= 9.4-23', + . 'pc= 680-800hPa, tau= 9.4-23', + . 'pc= 800-1000hPa, tau= 9.4-23', + . 'pc= 50-180hPa, tau= 23-60', + . 'pc= 180-310hPa, tau= 23-60', + . 'pc= 310-440hPa, tau= 23-60', + . 'pc= 440-560hPa, tau= 23-60', + . 'pc= 560-680hPa, tau= 23-60', + . 'pc= 680-800hPa, tau= 23-60', + . 'pc= 800-1000hPa, tau= 23-60', + . 'pc= 50-180hPa, tau> 60.', + . 'pc= 180-310hPa, tau> 60.', + . 'pc= 310-440hPa, tau> 60.', + . 'pc= 440-560hPa, tau> 60.', + . 'pc= 560-680hPa, tau> 60.', + . 'pc= 680-800hPa, tau> 60.', + . 'pc= 800-1000hPa, tau> 60.'/ + SAVE cnameisccp +c$OMP THREADPRIVATE(cnameisccp) +c +c REAL zx_lonx7(iimx7), zx_latx7(jjmp1x7) +c INTEGER nhorix7 +cIM: region='3d' <==> sorties en global + CHARACTER*3 region + PARAMETER(region='3d') +c +cIM ISCCP simulator v3.4 +c + logical ok_hf +c + integer nid_hf, nid_hf3d + save ok_hf, nid_hf, nid_hf3d +c$OMP THREADPRIVATE(ok_hf, nid_hf, nid_hf3d) +c QUESTION : noms de variables ? + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Variables propres a la physique + INTEGER itap + SAVE itap ! compteur pour la physique +c$OMP THREADPRIVATE(itap) +c + real slp(klon) ! sea level pressure +c + REAL fevap(klon,nbsrf) + REAL fluxlat(klon,nbsrf) +c + REAL qsol(klon) + REAL,save :: solarlong0 +c$OMP THREADPRIVATE(solarlong0) + +c +c Parametres de l'Orographie a l'Echelle Sous-Maille (OESM): +c +cIM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon) + REAL zulow(klon),zvlow(klon) +c + INTEGER igwd,idx(klon),itest(klon) +c + REAL agesno(klon,nbsrf) +c +c REAL,allocatable,save :: run_off_lic_0(:) +cc$OMP THREADPRIVATE(run_off_lic_0) +cym SAVE run_off_lic_0 +cKE43 +c Variables liees a la convection de K. Emanuel (sb): +c + REAL bas, top ! cloud base and top levels + SAVE bas + SAVE top +c$OMP THREADPRIVATE(bas, top) + + REAL wdn(klon), tdn(klon), qdn(klon) +c +c================================================================================================= +cCR04.12.07: on ajoute les nouvelles variables du nouveau schema de convection avec poches froides +c Variables liées à la poche froide (jyg) + + REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level + REAL Vprecip(klon,klev+1) ! precipitation vertical profile +c + REAL wape_prescr, fip_prescr + INTEGER it_wape_prescr + SAVE wape_prescr, fip_prescr, it_wape_prescr +c$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr) +c +c variables supplementaires de concvl + REAL Tconv(klon,klev) + REAL ment(klon,klev,klev),sij(klon,klev,klev) + REAL dd_t(klon,klev),dd_q(klon,klev) + + real, save :: alp_bl_prescr=0. + real, save :: ale_bl_prescr=0. + + real, save :: ale_max=1000. + real, save :: alp_max=2. + + real, save :: wake_s_min_lsp=0.1 + +c$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr) +c$OMP THREADPRIVATE(ale_max,alp_max) +c$OMP THREADPRIVATE(wake_s_min_lsp) + + real ale_wake(klon) + real alp_wake(klon) + + real ok_wk_lsp(klon) + +cRC +c Variables liées à la poche froide (jyg et rr) +c Version diagnostique pour l'instant : pas de rétroaction sur la convection + + REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection + + REAL wake_dth(klon,klev) ! wake : temp pot difference + + REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to Gravity Wave (/s) + REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta transported by LS omega + REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of large scale omega + REAL wake_dtKE(klon,klev) ! Wake : differential heating (wake - unpertubed) CONV + REAL wake_dqKE(klon,klev) ! Wake : differential moistening (wake - unpertubed) CONV + REAL wake_dtPBL(klon,klev) ! Wake : differential heating (wake - unpertubed) PBL + REAL wake_dqPBL(klon,klev) ! Wake : differential moistening (wake - unpertubed) PBL + REAL wake_omg(klon,klev+1) ! Wake : velocity difference (wake - unpertubed) + REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev) + REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg + REAL wake_spread(klon,klev) ! spreading term in wake_delt +c +cpourquoi y'a pas de save?? + REAL wake_h(klon) ! Wake : hauteur de la poche froide +c + INTEGER wake_k(klon) ! Wake sommet +c + REAL t_undi(klon,klev) ! temperature moyenne dans la zone non perturbee + REAL q_undi(klon,klev) ! humidite moyenne dans la zone non perturbee +c +cjyg +ccc REAL wake_pe(klon) ! Wake potential energy - WAPE + + REAL wake_gfl(klon) ! Gust Front Length + REAL wake_dens(klon) +c +c + REAL dt_dwn(klon,klev) + REAL dq_dwn(klon,klev) + REAL wdt_PBL(klon,klev) + REAL udt_PBL(klon,klev) + REAL wdq_PBL(klon,klev) + REAL udq_PBL(klon,klev) + REAL M_dwn(klon,klev) + REAL M_up(klon,klev) + REAL dt_a(klon,klev) + REAL dq_a(klon,klev) + REAL, SAVE :: alp_offset +c$OMP THREADPRIVATE(alp_offset) + +c +cRR:fin declarations poches froides +c======================================================================================================= + + REAL zw2(klon,klev+1) + REAL fraca(klon,klev+1) + REAL ztv(klon,klev) + REAL zpspsk(klon,klev) + REAL ztla(klon,klev) + REAL zthl(klon,klev) + +c Variables locales pour la couche limite (al1): +c +cAl1 REAL pblh(klon) ! Hauteur de couche limite +cAl1 SAVE pblh +c34EK +c +c Variables locales: +c + REAL cdragh(klon) ! drag coefficient pour T and Q + REAL cdragm(klon) ! drag coefficient pour vent +cAA +cAA Pour phytrac +cAA + REAL coefh(klon,klev) ! coef d'echange pour phytrac, valable pour 2<=k<=klev + REAL coefm(klon,klev) ! coef d'echange pour U, V + REAL u1(klon) ! vents dans la premiere couche U + REAL v1(klon) ! vents dans la premiere couche V + + REAL zxffonte(klon), zxfqcalving(klon),zxfqfonte(klon) + +c@$$ LOGICAL offline ! Controle du stockage ds "physique" +c@$$ PARAMETER (offline=.false.) +c@$$ INTEGER physid + REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction) + REAL frac_nucl(klon,klev) ! idem (nucleation) + INTEGER :: iii + REAL :: calday + +cIM cf FH pour Tiedtke 080604 + REAL rain_tiedtke(klon),snow_tiedtke(klon) +c +cIM 050204 END + REAL evap(klon), devap(klon) ! evaporation et sa derivee + REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee + + REAL bils(klon) ! bilan de chaleur au sol + REAL wfbilo(klon,nbsrf) ! bilan d'eau, pour chaque +C ! type de sous-surface et pondere par la fraction + REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque +C ! type de sous-surface et pondere par la fraction + REAL slab_wfbils(klon) ! bilan de chaleur au sol pour le cas de slab, sur les points d'ocean + + REAL fder(klon) + REAL ve(klon) ! integr. verticale du transport meri. de l'energie + REAL vq(klon) ! integr. verticale du transport meri. de l'eau + REAL ue(klon) ! integr. verticale du transport zonal de l'energie + REAL uq(klon) ! integr. verticale du transport zonal de l'eau +c + REAL frugs(klon,nbsrf) + REAL zxrugs(klon) ! longueur de rugosite +c +c Conditions aux limites +c +! + REAL :: day_since_equinox +! Date de l'equinoxe de printemps + INTEGER, parameter :: mth_eq=3, day_eq=21 + REAL :: jD_eq + + LOGICAL, parameter :: new_orbit = .true. + +c + INTEGER lmt_pas + SAVE lmt_pas ! frequence de mise a jour +c$OMP THREADPRIVATE(lmt_pas) + real zmasse(klon, llm) +C (column-density of mass of air in a cell, in kg m-2) + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + +cIM sorties + REAL un_jour + PARAMETER(un_jour=86400.) +c====================================================================== +c +c Declaration des procedures appelees +c + EXTERNAL angle ! calculer angle zenithal du soleil + EXTERNAL alboc ! calculer l'albedo sur ocean + EXTERNAL ajsec ! ajustement sec + EXTERNAL conlmd ! convection (schema LMD) +cKE43 + EXTERNAL conema3 ! convect4.3 + EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie) +cAA + EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie) +c ! stockage des coefficients necessaires au +c ! lessivage OFF-LINE et ON-LINE + EXTERNAL hgardfou ! verifier les temperatures + EXTERNAL nuage ! calculer les proprietes radiatives +CC EXTERNAL o3cm ! initialiser l'ozone + EXTERNAL orbite ! calculer l'orbite terrestre + EXTERNAL phyetat0 ! lire l'etat initial de la physique + EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique + EXTERNAL suphel ! initialiser certaines constantes + EXTERNAL transp ! transport total de l'eau et de l'energie + EXTERNAL ecribina ! ecrire le fichier binaire global + EXTERNAL ecribins ! ecrire le fichier binaire global + EXTERNAL ecrirega ! ecrire le fichier binaire regional + EXTERNAL ecriregs ! ecrire le fichier binaire regional +cIM + EXTERNAL haut2bas !variables de haut en bas + INTEGER lnblnk1 + EXTERNAL lnblnk1 !enleve les blancs a la fin d'une variable de type + !caracter + EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression + EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression +c EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression +c EXTERNAL moyglo_aire !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire) +c !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass) +c +c Variables locales +c + REAL rhcl(klon,klev) ! humiditi relative ciel clair + REAL dialiq(klon,klev) ! eau liquide nuageuse + REAL diafra(klon,klev) ! fraction nuageuse + REAL cldliq(klon,klev) ! eau liquide nuageuse + REAL cldfra(klon,klev) ! fraction nuageuse + REAL cldtau(klon,klev) ! epaisseur optique + REAL cldemi(klon,klev) ! emissivite infrarouge +c +CXXX PB + REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite + REAL fluxt(klon,klev, nbsrf) ! flux turbulent de chaleur + REAL fluxu(klon,klev, nbsrf) ! flux turbulent de vitesse u + REAL fluxv(klon,klev, nbsrf) ! flux turbulent de vitesse v +c + REAL zxfluxt(klon, klev) + REAL zxfluxq(klon, klev) + REAL zxfluxu(klon, klev) + REAL zxfluxv(klon, klev) +CXXX +c + REAL fsollw(klon, nbsrf) ! bilan flux IR pour chaque sous surface + REAL fsolsw(klon, nbsrf) ! flux solaire absorb. pour chaque sous surface +c Le rayonnement n'est pas calcule tous les pas, il faut donc +c sauvegarder les sorties du rayonnement +cym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown +cym SAVE sollwdownclr, toplwdown, toplwdownclr +cym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0 +c + INTEGER itaprad + SAVE itaprad +c$OMP THREADPRIVATE(itaprad) +c + REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s) + REAL conv_t(klon,klev) ! convergence de la temperature(K/s) +c + REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut + REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree +c + REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon) + REAL zxsnow_dummy(klon) +c + REAL dist, rmu0(klon), fract(klon) + REAL zdtime, zlongi +c + CHARACTER*2 str2 + CHARACTER*2 iqn +c + REAL qcheck + REAL z_avant(klon), z_apres(klon), z_factor(klon) + LOGICAL zx_ajustq +c + REAL za, zb + REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp + real zqsat(klon,klev) + INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq, iff + REAL t_coup + PARAMETER (t_coup=234.0) +c + REAL zphi(klon,klev) +cym A voir plus tard !! +cym REAL zx_relief(iim,jjmp1) +cym REAL zx_aire(iim,jjmp1) +c +c Grandeurs de sorties + REAL s_pblh(klon), s_lcl(klon), s_capCL(klon) + REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon) + REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon) + REAL s_trmb3(klon) +cKE43 +c Variables locales pour la convection de K. Emanuel (sb): +c + REAL upwd(klon,klev) ! saturated updraft mass flux + REAL dnwd(klon,klev) ! saturated downdraft mass flux + REAL dnwd0(klon,klev) ! unsaturated downdraft mass flux + REAL tvp(klon,klev) ! virtual temp of lifted parcel + REAL plcl(klon) ! Lifting Condensation Level + REAL plfc(klon) ! Level of Free Convection + REAL wbeff(klon) ! saturated updraft velocity at LFC + CHARACTER*40 capemaxcels !max(CAPE) + + REAL rflag(klon) ! flag fonctionnement de convect + INTEGER iflagctrl(klon) ! flag fonctionnement de convect + +c -- convect43: + INTEGER ntra ! nb traceurs pour convect4.3 + REAL pori_con(klon) ! pressure at the origin level of lifted parcel + REAL dtma_con(klon),dtlcl_con(klon) + REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev) + REAL dplcldt(klon), dplcldr(klon) +c? . condm_con(klon,klev),conda_con(klon,klev), +c? . mr_con(klon,klev),ep_con(klon,klev) +c? . ,sadiab(klon,klev),wadiab(klon,klev) +c -- +c34EK +c +c Variables du changement +c +c con: convection +c lsc: condensation a grande echelle (Large-Scale-Condensation) +c ajs: ajustement sec +c eva: evaporation de l'eau liquide nuageuse +c vdf: couche limite (Vertical DiFfusion) + REAL rneb(klon,klev) + +! tendance nulles + REAL du0(klon,klev),dv0(klon,klev),dq0(klon,klev),dql0(klon,klev) + +c +********************************************************* +* declarations + +********************************************************* +cIM 081204 END +c + REAL pmfu(klon,klev), pmfd(klon,klev) + REAL pen_u(klon,klev), pen_d(klon,klev) + REAL pde_u(klon,klev), pde_d(klon,klev) + INTEGER kcbot(klon), kctop(klon), kdtop(klon) + REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1) + REAL prfl(klon,klev+1), psfl(klon,klev+1) +c + REAL rain_lsc(klon) + REAL snow_lsc(klon) +c + REAL ratqss(klon,klev),ratqsc(klon,klev) + real ratqsbas,ratqshaut,tau_ratqs + save ratqsbas,ratqshaut,tau_ratqs +c$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs) + real zpt_conv(klon,klev) + +c Parametres lies au nouveau schema de nuages (SB, PDF) + real fact_cldcon + real facttemps + logical ok_newmicro + save ok_newmicro + real ref_liq(klon,klev), ref_ice(klon,klev) +c$OMP THREADPRIVATE(ok_newmicro) + save fact_cldcon,facttemps +c$OMP THREADPRIVATE(fact_cldcon,facttemps) + + integer iflag_cldcon + save iflag_cldcon +c$OMP THREADPRIVATE(iflag_cldcon) + logical ptconv(klon,klev) +cIM cf. AM 081204 BEG + logical ptconvth(klon,klev) +cIM cf. AM 081204 END +c +c Variables liees a l'ecriture de la bande histoire physique +c +c====================================================================== +c +cIM cf. AM 081204 BEG +c declarations pour sortir sur une sous-region + integer imin_ins,imax_ins,jmin_ins,jmax_ins + save imin_ins,imax_ins,jmin_ins,jmax_ins +c$OMP THREADPRIVATE(imin_ins,imax_ins,jmin_ins,jmax_ins) +c real lonmin_ins,lonmax_ins,latmin_ins +c s ,latmax_ins +c data lonmin_ins,lonmax_ins,latmin_ins +c s ,latmax_ins/ +c valeurs initiales s -5.,20.,41.,55./ +c s 100.,130.,-20.,20./ +c s -180.,180.,-90.,90./ +c====================================================================== +cIM cf. AM 081204 END + +c + integer itau_w ! pas de temps ecriture = itap + itau_phy +c +c +c Variables locales pour effectuer les appels en serie +c + REAL zx_rh(klon,klev) +cIM RH a 2m (la surface) + REAL rh2m(klon), qsat2m(klon) + REAL tpot(klon), tpote(klon) + REAL Lheat + + INTEGER length + PARAMETER ( length = 100 ) + REAL tabcntr0( length ) +c + INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev) +cIM + INTEGER ndex2d1(iwmax) +c +cIM AMIP2 BEG + REAL moyglo, mountor +cIM 141004 BEG + REAL zustrdr(klon), zvstrdr(klon) + REAL zustrli(klon), zvstrli(klon) + REAL zustrph(klon), zvstrph(klon) + REAL zustrhi(klon), zvstrhi(klon) + REAL aam, torsfc +cIM 141004 END +cIM 190504 BEG + INTEGER ij, imp1jmp1 + PARAMETER(imp1jmp1=(iim+1)*jjmp1) +cym A voir plus tard + REAL zx_tmp(imp1jmp1), airedyn(iim+1,jjmp1) + REAL padyn(iim+1,jjmp1,klev+1) + REAL dudyn(iim+1,jjmp1,klev) + REAL rlatdyn(iim+1,jjmp1) +cIM 190504 END + LOGICAL ok_msk + REAL msk(klon) +cIM + REAL airetot, pi +cym A voir plus tard +cym REAL zm_wo(jjmp1, klev) +cIM AMIP2 END +c + REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique + REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D + REAL zx_tmp_fi3d1(klon,klev+1) !variable temporaire pour champs 3D (kelvp1) +c#ifdef histNMC +cym A voir plus tard !!!! +cym REAL zx_tmp_NC(iim,jjmp1,nlevSTD) + REAL zx_tmp_fiNC(klon,nlevSTD) +c#endif + REAL(KIND=8) zx_tmp2_fi3d(klon,klev) ! variable temporaire pour champs 3D + REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev) + REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1) +cIM for NMC files + REAL missing_val + REAL, SAVE :: freq_moyNMC(nout) +c$OMP THREADPRIVATE(freq_moyNMC) +c + INTEGER nid_day, nid_mth, nid_ins, nid_mthnmc, nid_daynmc + INTEGER nid_hfnmc, nid_day_seri, nid_ctesGCM + SAVE nid_day, nid_mth, nid_ins, nid_mthnmc, nid_daynmc + SAVE nid_hfnmc, nid_day_seri, nid_ctesGCM +c$OMP THREADPRIVATE(nid_day, nid_mth, nid_ins) +c$OMP THREADPRIVATE(nid_mthnmc, nid_daynmc, nid_hfnmc) +c$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM) +c +cIM 280405 BEG + INTEGER nid_bilKPins, nid_bilKPave + SAVE nid_bilKPins, nid_bilKPave +c$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave) +c + REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert. + REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert. + REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert. + REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert. +c + INTEGER nhori, nvert, nvert1, nvert3 + REAL zsto, zsto1, zsto2 + REAL zstophy, zstorad, zstohf, zstoday, zstomth, zout + REAL zcals(napisccp), zcalh(napisccp), zoutj(napisccp) + REAL zout_isccp(napisccp) + SAVE zcals, zcalh, zoutj, zout_isccp +c$OMP THREADPRIVATE(zcals, zcalh, zoutj, zout_isccp) + + real zjulian + save zjulian +c$OMP THREADPRIVATE(zjulian) + + character*20 modname + character*80 abort_message + logical ok_sync + real date0 + integer idayref + +C essai writephys + integer fid_day, fid_mth, fid_ins + parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) + integer prof2d_on, prof3d_on, prof2d_av, prof3d_av + parameter (prof2d_on = 1, prof3d_on = 2, + . prof2d_av = 3, prof3d_av = 4) + character*30 nom_fichier + character*10 varname + character*40 vartitle + character*20 varunits +C Variables liees au bilan d'energie et d'enthalpi + REAL ztsol(klon) + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot + SAVE h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + $ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, +c$OMP+ h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot) + REAL d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec + REAL d_h_vcol_phy + REAL fs_bound, fq_bound + SAVE d_h_vcol_phy +c$OMP THREADPRIVATE(d_h_vcol_phy) + REAL zero_v(klon) + CHARACTER*15 ztit + INTEGER ip_ebil ! PRINT level for energy conserv. diag. + SAVE ip_ebil + DATA ip_ebil/0/ +c$OMP THREADPRIVATE(ip_ebil) + INTEGER if_ebil ! level for energy conserv. dignostics + SAVE if_ebil +c$OMP THREADPRIVATE(if_ebil) +c+jld ec_conser + REAL ZRCPD +c-jld ec_conser + REAL t2m(klon,nbsrf) ! temperature a 2m + REAL q2m(klon,nbsrf) ! humidite a 2m + +cIM: t2m, q2m, u10m, v10m et t2mincels, t2maxcels + REAL zt2m(klon), zq2m(klon) !temp., hum. 2m moyenne s/ 1 maille + REAL zu10m(klon), zv10m(klon) !vents a 10m moyennes s/1 maille + CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max + CHARACTER*40 tinst, tave, typeval + REAL cldtaupi(klon,klev) ! Cloud optical thickness for pre-industrial (pi) aerosols + + REAL re(klon, klev) ! Cloud droplet effective radius + REAL fl(klon, klev) ! denominator of re + + REAL re_top(klon), fl_top(klon) ! CDR at top of liquid water clouds + + ! Aerosol optical properties + CHARACTER*4, DIMENSION(naero_grp) :: rfname + REAL, DIMENSION(klon) :: aerindex ! POLDER aerosol index + REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass concentration for all soluble aerosols[ug/m3] + REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi ! - " - (pre-industrial value) + INTEGER :: naero ! aerosol species + + ! Parameters + LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not + REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995) + SAVE ok_ade, ok_aie, bl95_b0, bl95_b1 +c$OMP THREADPRIVATE(ok_ade, ok_aie, bl95_b0, bl95_b1) + LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA + ! false : lecture des aerosol dans un fichier +c$OMP THREADPRIVATE(aerosol_couple) + INTEGER, SAVE :: flag_aerosol +c$OMP THREADPRIVATE(flag_aerosol) + LOGICAL, SAVE :: new_aod +c$OMP THREADPRIVATE(new_aod) + +c +c Declaration des constantes et des fonctions thermodynamiques +c + LOGICAL,SAVE :: first=.true. +c$OMP THREADPRIVATE(first) + + integer iunit + + integer, save:: read_climoz ! read ozone climatology +C (let it keep the default OpenMP shared attribute) +C Allowed values are 0, 1 and 2 +C 0: do not read an ozone climatology +C 1: read a single ozone climatology that will be used day and night +C 2: read two ozone climatologies, the average day and night +C climatology and the daylight climatology + + integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies +C (let it keep the default OpenMP shared attribute) + + real, pointer, save:: press_climoz(:) +C (let it keep the default OpenMP shared attribute) +! edges of pressure intervals for ozone climatologies, in Pa, in strictly +! ascending order + + integer, save:: co3i = 0 +! time index in NetCDF file of current ozone fields +c$OMP THREADPRIVATE(co3i) + + integer ro3i +! required time index in NetCDF file for the ozone fields, between 1 +! and 360 + + INTEGER ierr +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +cIM 100106 BEG : pouvoir sortir les ctes de la physique +#include "conema3.h" +#include "fisrtilp.h" +#include "nuage.h" +#include "compbl.h" +cIM 100106 END : pouvoir sortir les ctes de la physique +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c Declarations pour Simulateur COSP +c============================================================ + real :: mr_ozone(klon,klev) + +cIM sorties fichier 1D paramLMDZ_phy.nc + REAL :: zx_tmp_0d(1,1) + INTEGER, PARAMETER :: np=1 + REAL,dimension(klon_glo) :: rlat_glo + REAL,dimension(klon_glo) :: rlon_glo + REAL gbils(1), gevap(1), gevapt(1), glat(1), gnet0(1), gnet(1) + REAL grain(1), gtsol(1), gt2m(1), gprw(1) + +cIM stations CFMIP + INTEGER, SAVE :: nCFMIP +c$OMP THREADPRIVATE(nCFMIP) + INTEGER, PARAMETER :: npCFMIP=120 + INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:) + REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:) +c$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP) + INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:) + REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:) +c$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM) + INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:) +c$OMP THREADPRIVATE(iGCM, jGCM) + logical, dimension(nfiles) :: phys_out_filestations + logical, parameter :: lNMC=.FALSE. + +cIM betaCRF + REAL, SAVE :: pfree, beta_pbl, beta_free +c$OMP THREADPRIVATE(pfree, beta_pbl, beta_free) + REAL, SAVE :: lon1_beta, lon2_beta, lat1_beta, lat2_beta +c$OMP THREADPRIVATE(lon1_beta, lon2_beta, lat1_beta, lat2_beta) + LOGICAL, SAVE :: mskocean_beta +c$OMP THREADPRIVATE(mskocean_beta) + REAL, dimension(klon, klev) :: beta ! facteur sur cldtaurad et cldemirad pour evaluer les retros liees aux CRF + REAL, dimension(klon, klev) :: cldtaurad ! epaisseur optique pour radlwsw,COSP + REAL, dimension(klon, klev) :: cldemirad ! emissivite pour radlwsw,COSP + +cIM for NMC files + missing_val=nf90_fill_real +c====================================================================== +! Gestion calendrier : mise a jour du module phys_cal_mod +! + CALL phys_cal_update(jD_cur,jH_cur) + +c====================================================================== +! Ecriture eventuelle d'un profil verticale en entree de la physique. +! Utilise notamment en 1D mais peut etre active egalement en 3D +! en imposant la valeur de igout. +c====================================================================== + + if (prt_level.ge.1) then + igout=klon/2+1/klon + write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' + write(lunout,*) + s 'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys' + write(lunout,*) + s nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys + + write(lunout,*) 'paprs, play, phi, u, v, t' + do k=1,klev + write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), + s u(igout,k),v(igout,k),t(igout,k) + enddo + write(lunout,*) 'ovap (g/kg), oliq (g/kg)' + do k=1,klev + write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000. + enddo + endif + +c====================================================================== + +cym => necessaire pour iflag_con != 2 + pmfd(:,:) = 0. + pen_u(:,:) = 0. + pen_d(:,:) = 0. + pde_d(:,:) = 0. + pde_u(:,:) = 0. + aam=0. + + torsfc=0. + forall (k=1: llm) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg + + if (first) then + +cCR:nvelles variables convection/poches froides + + print*, '=================================================' + print*, 'Allocation des variables locales et sauvegardees' + call phys_local_var_init +c + pasphys=pdtphys +c appel a la lecture du run.def physique + call conf_phys(ok_journe, ok_mensuel, + . ok_instan, ok_hf, + . ok_LES, + . callstats, + . solarlong0,seuil_inversion, + . fact_cldcon, facttemps,ok_newmicro,iflag_radia, + . iflag_cldcon,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, + . ok_ade, ok_aie, aerosol_couple, + . flag_aerosol, new_aod, + . bl95_b0, bl95_b1, +c nv flags pour la convection et les poches froides + . read_climoz, + & alp_offset) + call phys_state_var_init(read_climoz) + call phys_output_var_init + print*, '=================================================' +cIM for NMC files +cIM freq_moyNMC = frequences auxquelles on moyenne les champs accumules +cIM sur les niveaux de pression standard du NMC + DO n=1, nout + freq_moyNMC(n)=freq_outNMC(n)/freq_calNMC(n) + ENDDO +c +cIM beg + dnwd0=0.0 + ftd=0.0 + fqd=0.0 + cin=0. +cym Attention pbase pas initialise dans concvl !!!! + pbase=0 +cIM 180608 +c pmflxr=0. +c pmflxs=0. + + itau_con=0 + first=.false. + + endif ! first + + modname = 'physiq' +cIM + IF (ip_ebil_phy.ge.1) THEN + DO i=1,klon + zero_v(i)=0. + END DO + END IF + ok_sync=.TRUE. + + IF (debut) THEN + CALL suphel ! initialiser constantes et parametres phys. + ENDIF + + if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 ' + + +c====================================================================== +! Gestion calendrier : mise a jour du module phys_cal_mod +! +c CALL phys_cal_update(jD_cur,jH_cur) + +c +c Si c'est le debut, il faut initialiser plusieurs choses +c ******** +c + IF (debut) THEN +!rv +cCRinitialisation de wght_th et lalim_conv pour la definition de la couche alimentation +cde la convection a partir des caracteristiques du thermique + wght_th(:,:)=1. + lalim_conv(:)=1 +cRC + u10m(:,:)=0. + v10m(:,:)=0. + rain_con(:)=0. + snow_con(:)=0. + topswai(:)=0. + topswad(:)=0. + solswai(:)=0. + solswad(:)=0. + + lambda_th(:,:)=0. + wmax_th(:)=0. + tau_overturning_th(:)=0. + + IF (config_inca /= 'none') THEN + ! jg : initialisation jusqu'au ces variables sont dans restart + ccm(:,:,:) = 0. + tau_aero(:,:,:,:) = 0. + piz_aero(:,:,:,:) = 0. + cg_aero(:,:,:,:) = 0. + END IF + + rnebcon0(:,:) = 0.0 + clwcon0(:,:) = 0.0 + rnebcon(:,:) = 0.0 + clwcon(:,:) = 0.0 + +cIM + IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0. +c + print*,'iflag_coupl,iflag_clos,iflag_wake', + . iflag_coupl,iflag_clos,iflag_wake + print*,'CYCLE_DIURNE', cycle_diurne +c + IF (iflag_con.EQ.2.AND.iflag_cldcon.GT.-1) THEN + abort_message = 'Tiedtke needs iflag_cldcon=-2 or -1' + CALL abort_gcm (modname,abort_message,1) + ENDIF +c + IF(ok_isccp.AND.iflag_con.LE.2) THEN + abort_message = 'ISCCP-like outputs may be available for KE + .(iflag_con >= 3); for Tiedtke (iflag_con=-2) put ok_isccp=n' + CALL abort_gcm (modname,abort_message,1) + ENDIF +c +c Initialiser les compteurs: +c + itap = 0 + itaprad = 0 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Un petit travail à faire ici. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (iflag_pbl>1) then + PRINT*, "Using method MELLOR&YAMADA" + endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd plutot que +! dyn3d +! Attention : la version precedente n'etait pas tres propre. +! Il se peut qu'il faille prendre une valeur differente de nbapp_rad +! pour obtenir le meme resultat. + dtime=pdtphys + radpas = NINT( 86400./dtime/nbapp_rad) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0) +cIM begin + print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) + $,ratqs(1,1) +cIM end + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +C on remet le calendrier a zero +c + IF (raz_date .eq. 1) THEN + itau_phy = 0 + ENDIF + +cIM cf. AM 081204 BEG + PRINT*,'cycle_diurne3 =',cycle_diurne +cIM cf. AM 081204 END +c + CALL printflag( tabcntr0,radpas,ok_journe, + , ok_instan, ok_region ) +c + IF (ABS(dtime-pdtphys).GT.0.001) THEN + WRITE(lunout,*) 'Pas physique n est pas correct',dtime, + . pdtphys + abort_message='Pas physique n est pas correct ' +! call abort_gcm(modname,abort_message,1) + dtime=pdtphys + ENDIF + IF (nlon .NE. klon) THEN + WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, + . klon + abort_message='nlon et klon ne sont pas coherents' + call abort_gcm(modname,abort_message,1) + ENDIF + IF (nlev .NE. klev) THEN + WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, + . klev + abort_message='nlev et klev ne sont pas coherents' + call abort_gcm(modname,abort_message,1) + ENDIF +c + IF (dtime*REAL(radpas).GT.21600..AND.cycle_diurne) THEN + WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' + WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" + abort_message='Nbre d appels au rayonnement insuffisant' + call abort_gcm(modname,abort_message,1) + ENDIF + WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con + WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", + . ok_cvl +c +cKE43 +c Initialisation pour la convection de K.E. (sb): + IF (iflag_con.GE.3) THEN + + WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3 " + WRITE(lunout,*) + . "On va utiliser le melange convectif des traceurs qui" + WRITE(lunout,*)"est calcule dans convect4.3" + WRITE(lunout,*)" !!! penser aux logical flags de phytrac" + + DO i = 1, klon + ema_cbmf(i) = 0. + ema_pcb(i) = 0. + ema_pct(i) = 0. +c ema_workcbmf(i) = 0. + ENDDO +cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG + DO i = 1, klon + ibas_con(i) = 1 + itop_con(i) = 1 + ENDDO +cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END +c=============================================================================== +cCR:04.12.07: initialisations poches froides +c Controle de ALE et ALP pour la fermeture convective (jyg) + if (iflag_wake>=1) then + CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr + s ,alp_bl_prescr, ale_bl_prescr) +c 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU) +c print*,'apres ini_wake iflag_cldcon=', iflag_cldcon + endif + + do i = 1,klon + Ale_bl(i)=0. + Alp_bl(i)=0. + enddo + +c================================================================================ +cIM stations CFMIP + nCFMIP=npCFMIP + OPEN(98,file='npCFMIP_param.data',status='old', + $ form='formatted',err=999) + READ(98,*,end=998) nCFMIP +998 CONTINUE + CLOSE(98) + CONTINUE + IF(nCFMIP.GT.npCFMIP) THEN + print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' + CALL abort + else + print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP + ENDIF +c + ALLOCATE(tabCFMIP(nCFMIP)) + ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP)) + ALLOCATE(tabijGCM(nCFMIP)) + ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP)) + ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP)) +c +c lecture des nCFMIP stations CFMIP, de leur numero +c et des coordonnees geographiques lonCFMIP, latCFMIP +c + CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, + $lonCFMIP, latCFMIP) +c +c identification des +c 1) coordonnees lonGCM, latGCM des points CFMIP dans la grille de LMDZ +c 2) indices points tabijGCM de la grille physique 1d sur klon points +c 3) indices iGCM, jGCM de la grille physique 2d +c + CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, + $tabijGCM, lonGCM, latGCM, iGCM, jGCM) +c +999 CONTINUE + ENDIF !debut + + DO i=1,klon + rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0) + ENDDO + +c34EK + IF (ok_orodr) THEN + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH sans doute a enlever de finitivement ou, si on le garde, l'activer +! justement quand ok_orodr = false. +! ce rugoro est utilise par la couche limite et fait double emploi +! avec les paramétrisations spécifiques de Francois Lott. +! DO i=1,klon +! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0) +! ENDDO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (ok_strato) THEN + CALL SUGWD_strato(klon,klev,paprs,pplay) + ELSE + CALL SUGWD(klon,klev,paprs,pplay) + ENDIF + + DO i=1,klon + zuthe(i)=0. + zvthe(i)=0. + if(zstd(i).gt.10.)then + zuthe(i)=(1.-zgam(i))*cos(zthe(i)) + zvthe(i)=(1.-zgam(i))*sin(zthe(i)) + endif + ENDDO + ENDIF +c +c + lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours + WRITE(lunout,*)'La frequence de lecture surface est de ', + . lmt_pas +c + capemaxcels = 't_max(X)' + t2mincels = 't_min(X)' + t2maxcels = 't_max(X)' + tinst = 'inst(X)' + tave = 'ave(X)' +cIM cf. AM 081204 BEG + write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con +cIM cf. AM 081204 END +c +c============================================================= +c Initialisation des sorties +c============================================================= + +#ifdef CPP_IOIPSL + +c$OMP MASTER + call phys_output_open(rlon,rlat,nCFMIP,tabijGCM, + & iGCM,jGCM,lonGCM,latGCM, + & jjmp1,nlevSTD,clevSTD, + & nbteta, ctetaSTD, dtime,ok_veget, + & type_ocean,iflag_pbl,ok_mensuel,ok_journe, + & ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, + & read_climoz, phys_out_filestations, + & new_aod, aerosol_couple + & ) +c$OMP END MASTER +c$OMP BARRIER + +#ifdef histISCCP +#include "ini_histISCCP.h" +#endif + +#ifdef histNMC +#include "ini_histhfNMC.h" +#include "ini_histdayNMC.h" +#include "ini_histmthNMC.h" +#endif + +#include "ini_histday_seri.h" + +#include "ini_paramLMDZ_phy.h" + +#endif + + ecrit_hf2mth = ecrit_mth/ecrit_hf + + ecrit_hf = ecrit_hf * un_jour +cIM + IF(ecrit_day.LE.1.) THEN + ecrit_day = ecrit_day * un_jour !en secondes + ENDIF +cIM + ecrit_mth = ecrit_mth * un_jour + ecrit_ins = ecrit_ins * un_jour + ecrit_reg = ecrit_reg * un_jour + ecrit_tra = ecrit_tra * un_jour + ecrit_LES = ecrit_LES * un_jour +c + PRINT*,'physiq ecrit_ hf day mth reg tra ISCCP hf2mth', + . ecrit_hf,ecrit_day,ecrit_mth,ecrit_reg,ecrit_tra,ecrit_ISCCP, + . ecrit_hf2mth + +cXXXPB Positionner date0 pour initialisation de ORCHIDEE + date0 = jD_ref + WRITE(*,*) 'physiq date0 : ',date0 +c +c +c +c Prescrire l'ozone dans l'atmosphere +c +c +cc DO i = 1, klon +cc DO k = 1, klev +cc CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20) +cc ENDDO +cc ENDDO +c + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) +! iii = MOD(NINT(xjour),360) +! calday = REAL(iii) + jH_cur + calday = REAL(days_elapsed) + jH_cur + WRITE(lunout,*) 'initial time chemini', days_elapsed, calday + + CALL chemini( + $ rg, + $ ra, + $ airephy, + $ rlat, + $ rlon, + $ presnivs, + $ calday, + $ klon, + $ nqtot, + $ pdtphys, + $ annee_ref, + $ day_ref, + $ itau_phy) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF +c +c +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Nouvelle initialisation pour le rayonnement RRTM +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call iniradia(klon,klev,paprs(1,1:klev+1)) + +C$omp single + if (read_climoz >= 1) then + call open_climoz(ncid_climoz, press_climoz) + END IF +C$omp end single +c +cIM betaCRF + pfree=70000. !Pa + beta_pbl=1. + beta_free=1. + lon1_beta=-180. + lon2_beta=+180. + lat1_beta=90. + lat2_beta=-90. + mskocean_beta=.FALSE. + + OPEN(99,file='beta_crf.data',status='old', + $ form='formatted',err=9999) + READ(99,*,end=9998) pfree + READ(99,*,end=9998) beta_pbl + READ(99,*,end=9998) beta_free + READ(99,*,end=9998) lon1_beta + READ(99,*,end=9998) lon2_beta + READ(99,*,end=9998) lat1_beta + READ(99,*,end=9998) lat2_beta + READ(99,*,end=9998) mskocean_beta +9998 Continue + CLOSE(99) +9999 Continue + WRITE(*,*)'pfree=',pfree + WRITE(*,*)'beta_pbl=',beta_pbl + WRITE(*,*)'beta_free=',beta_free + WRITE(*,*)'lon1_beta=',lon1_beta + WRITE(*,*)'lon2_beta=',lon2_beta + WRITE(*,*)'lat1_beta=',lat1_beta + WRITE(*,*)'lat2_beta=',lat2_beta + WRITE(*,*)'mskocean_beta=',mskocean_beta + ENDIF +! +! **************** Fin de IF ( debut ) *************** +! +! +! Incrementer le compteur de la physique +! + itap = itap + 1 +! +! Update fraction of the sub-surfaces (pctsrf) and +! initialize, where a new fraction has appeared, all variables depending +! on the surface fraction. +! + CALL change_srf_frac(itap, dtime, days_elapsed+1, + * pctsrf, falb1, falb2, ftsol, u10m, v10m, pbl_tke) + +! Tendances bidons pour les processus qui n'affectent pas certaines +! variables. + du0(:,:)=0. + dv0(:,:)=0. + dq0(:,:)=0. + dql0(:,:)=0. +c +c Mettre a zero des variables de sortie (pour securite) +c + DO i = 1, klon + d_ps(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + d_t(i,k) = 0.0 + d_u(i,k) = 0.0 + d_v(i,k) = 0.0 + ENDDO + ENDDO + DO iq = 1, nqtot + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = 0.0 + ENDDO + ENDDO + ENDDO + da(:,:)=0. + mp(:,:)=0. + phi(:,:,:)=0. +c +c Ne pas affecter les valeurs entrees de u, v, h, et q +c + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t(i,k) + u_seri(i,k) = u(i,k) + v_seri(i,k) = v(i,k) + q_seri(i,k) = qx(i,k,ivap) + ql_seri(i,k) = qx(i,k,iliq) + qs_seri(i,k) = 0. + ENDDO + ENDDO + IF (nqtot.GE.3) THEN + DO iq = 3, nqtot + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,iq-2) = qx(i,k,iq) + ENDDO + ENDDO + ENDDO + ELSE + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,1) = 0.0 + ENDDO + ENDDO + ENDIF +C + DO i = 1, klon + ztsol(i) = 0. + ENDDO + DO nsrf = 1, nbsrf + DO i = 1, klon + ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf) + ENDDO + ENDDO +cIM + IF (ip_ebil_phy.ge.1) THEN + ztit='after dynamic' + CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C Comme les tendances de la physique sont ajoute dans la dynamique, +C on devrait avoir que la variation d'entalpie par la dynamique +C est egale a la variation de la physique au pas de temps precedent. +C Donc la somme de ces 2 variations devrait etre nulle. + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol+d_h_vcol_phy, d_qt, 0. + s , fs_bound, fq_bound ) + END IF + +c Diagnostiquer la tendance dynamique +c + IF (ancien_ok) THEN + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime + d_v_dyn(i,k) = (v_seri(i,k)-v_ancien(i,k))/dtime + d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime + d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime + ENDDO + ENDDO + ELSE + DO k = 1, klev + DO i = 1, klon + d_u_dyn(i,k) = 0.0 + d_v_dyn(i,k) = 0.0 + d_t_dyn(i,k) = 0.0 + d_q_dyn(i,k) = 0.0 + ENDDO + ENDDO + ancien_ok = .TRUE. + ENDIF +c +c Ajouter le geopotentiel du sol: +c + DO k = 1, klev + DO i = 1, klon + zphi(i,k) = pphi(i,k) + pphis(i) + ENDDO + ENDDO +c +c Verifier les temperatures +c +cIM BEG + IF (check) THEN + amn=MIN(ftsol(1,is_ter),1000.) + amx=MAX(ftsol(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ftsol(i,is_ter),amn) + amx=MAX(ftsol(i,is_ter),amx) + ENDDO +c + PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx + ENDIF !(check) THEN +cIM END +c + CALL hgardfou(t_seri,ftsol,'debutphy') +c +cIM BEG + IF (check) THEN + amn=MIN(ftsol(1,is_ter),1000.) + amx=MAX(ftsol(1,is_ter),-1000.) + DO i=2, klon + amn=MIN(ftsol(i,is_ter),amn) + amx=MAX(ftsol(i,is_ter),amx) + ENDDO +c + PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx + ENDIF !(check) THEN +cIM END +c +c Mettre en action les conditions aux limites (albedo, sst, etc.). +c Prescrire l'ozone et calculer l'albedo sur l'ocean. +c + if (read_climoz >= 1) then +C Ozone from a file +! Update required ozone index: + ro3i = int((days_elapsed + jh_cur - jh_1jan) + $ / ioget_year_len(year_cur) * 360.) + 1 + if (ro3i == 361) ro3i = 360 +C (This should never occur, except perhaps because of roundup +C error. See documentation.) + if (ro3i /= co3i) then +C Update ozone field: + if (read_climoz == 1) then + call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i, + $ press_in_edg=press_climoz, paprs=paprs, v3=wo) + else +C read_climoz == 2 + call regr_pr_av(ncid_climoz, + $ (/"tro3 ", "tro3_daylight"/), + $ julien=ro3i, press_in_edg=press_climoz, paprs=paprs, + $ v3=wo) + end if +! Convert from mole fraction of ozone to column density of ozone in a +! cell, in kDU: + forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) + $ * rmo3 / rmd * zmasse / dobson_u / 1e3 +C (By regridding ozone values for LMDZ only once every 360th of +C year, we have already neglected the variation of pressure in one +C 360th of year. So do not recompute "wo" at each time step even if +C "zmasse" changes a little.) + co3i = ro3i + end if + elseif (MOD(itap-1,lmt_pas) == 0) THEN +C Once per day, update ozone from Royer: + wo(:, :, 1) = ozonecm(rlat, paprs, rjour=real(days_elapsed+1)) + ENDIF +c +c Re-evaporer l'eau liquide nuageuse +c + DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse + DO i = 1, klon + zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) +c zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) + zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k)) + zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k))) + zb = MAX(0.0,ql_seri(i,k)) + za = - MAX(0.0,ql_seri(i,k)) + . * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta) + t_seri(i,k) = t_seri(i,k) + za + q_seri(i,k) = q_seri(i,k) + zb + ql_seri(i,k) = 0.0 + d_t_eva(i,k) = za + d_q_eva(i,k) = zb + ENDDO + ENDDO +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after reevap' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,1,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) +C + END IF + +c +c========================================================================= +! Calculs de l'orbite. +! Necessaires pour le rayonnement et la surface (calcul de l'albedo). +! doit donc etre placé avant radlwsw et pbl_surface + +!!! jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq) + day_since_equinox = (jD_cur + jH_cur) - jD_eq +! +! choix entre calcul de la longitude solaire vraie ou valeur fixee a +! solarlong0 + if (solarlong0<-999.) then + if (new_orbit) then +! calcul selon la routine utilisee pour les planetes + call solarlong(day_since_equinox, zlongi, dist) + else +! calcul selon la routine utilisee pour l'AR4 + CALL orbite(REAL(days_elapsed+1),zlongi,dist) + endif + else + zlongi=solarlong0 ! longitude solaire vraie + dist=1. ! distance au soleil / moyenne + endif + if(prt_level.ge.1) & + & write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Calcul de l'ensoleillement : +! ============================ +! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur +! l'annee a partir d'une formule analytique. +! Cet ensoleillement est symmétrique autour de l'équateur et +! non nul aux poles. + IF (abs(solarlong0-1000.)<1.e-4) then + call zenang_an(cycle_diurne,jH_cur,rlat,rlon,rmu0,fract) + ELSE +! Avec ou sans cycle diurne + IF (cycle_diurne) THEN + zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s) + CALL zenang(zlongi,jH_cur,zdtime,rlat,rlon,rmu0,fract) + ELSE + CALL angle(zlongi, rlat, fract, rmu0) + ENDIF + ENDIF + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Appel au pbl_surface : Planetary Boudary Layer et Surface +c Cela implique tous les interactions des sous-surfaces et la partie diffusion +c turbulent du couche limit. +c +c Certains varibales de sorties de pbl_surface sont utiliser que pour +c ecriture des fihiers hist_XXXX.nc, ces sont : +c qsol, zq2m, s_pblh, s_lcl, +c s_capCL, s_oliqCL, s_cteiCL,s_pblT, +c s_therm, s_trmb1, s_trmb2, s_trmb3, +c zxrugs, zu10m, zv10m, fder, +c zxqsurf, rh2m, zxfluxu, zxfluxv, +c frugs, agesno, fsollw, fsolsw, +c d_ts, fevap, fluxlat, t2m, +c wfbils, wfbilo, fluxt, fluxu, fluxv, +c +c Certains ne sont pas utiliser du tout : +c dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq +c + + CALL pbl_surface( + e dtime, date0, itap, days_elapsed+1, + e debut, lafin, + e rlon, rlat, rugoro, rmu0, + e rain_fall, snow_fall, solsw, sollw, + e t_seri, q_seri, u_seri, v_seri, + e pplay, paprs, pctsrf, + + ftsol, falb1, falb2, u10m, v10m, + s sollwdown, cdragh, cdragm, u1, v1, + s albsol1, albsol2, sens, evap, + s zxtsol, zxfluxlat, zt2m, qsat2m, + s d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, + s coefh, coefm, slab_wfbils, + d qsol, zq2m, s_pblh, s_lcl, + d s_capCL, s_oliqCL, s_cteiCL,s_pblT, + d s_therm, s_trmb1, s_trmb2, s_trmb3, + d zxrugs, zu10m, zv10m, fder, + d zxqsurf, rh2m, zxfluxu, zxfluxv, + d frugs, agesno, fsollw, fsolsw, + d d_ts, fevap, fluxlat, t2m, + d wfbils, wfbilo, fluxt, fluxu, fluxv, + - dsens, devap, zxsnow, + - zxfluxt, zxfluxq, q2m, fluxq, pbl_tke ) + + +!----------------------------------------------------------------------------------------- +! ajout des tendances de la diffusion turbulente + CALL add_phys_tend(d_u_vdf,d_v_vdf,d_t_vdf,d_q_vdf,dql0,'vdf') +!----------------------------------------------------------------------------------------- + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + + IF (ip_ebil_phy.ge.2) THEN + ztit='after surface_main' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, sens + e , evap , zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF + +c =================================================================== c +c Calcul de Qsat + + DO k = 1, klev + DO i = 1, klon + zx_t = t_seri(i,k) + IF (thermcep) THEN + zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) + zx_qs = MIN(0.5,zx_qs) + zcor = 1./(1.-retv*zx_qs) + zx_qs = zx_qs*zcor + ELSE + IF (zx_t.LT.t_coup) THEN + zx_qs = qsats(zx_t)/pplay(i,k) + ELSE + zx_qs = qsatl(zx_t)/pplay(i,k) + ENDIF + ENDIF + zqsat(i,k)=zx_qs + ENDDO + ENDDO + + if (prt_level.ge.1) then + write(lunout,*) 'L qsat (g/kg) avant clouds_gno' + write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev) + endif +c +c Appeler la convection (au choix) +c + DO k = 1, klev + DO i = 1, klon + conv_q(i,k) = d_q_dyn(i,k) + . + d_q_vdf(i,k)/dtime + conv_t(i,k) = d_t_dyn(i,k) + . + d_t_vdf(i,k)/dtime + ENDDO + ENDDO + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy) + WRITE(lunout,*) "avantcon=", za + ENDIF + zx_ajustq = .FALSE. + IF (iflag_con.EQ.2) zx_ajustq=.TRUE. + IF (zx_ajustq) THEN + DO i = 1, klon + z_avant(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + ENDIF + +c Calcule de vitesse verticale a partir de flux de masse verticale + DO k = 1, klev + DO i = 1, klon + omega(i,k) = RG*flxmass_w(i,k) / airephy(i) + END DO + END DO + if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', + $ omega(igout, :) + + IF (iflag_con.EQ.1) THEN + abort_message ='reactiver le call conlmd dans physiq.F' + CALL abort_gcm (modname,abort_message,1) +c CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q, +c . d_t_con, d_q_con, +c . rain_con, snow_con, ibas_con, itop_con) + ELSE IF (iflag_con.EQ.2) THEN + CALL conflx(dtime, paprs, pplay, t_seri, q_seri, + e conv_t, conv_q, -evap, omega, + s d_t_con, d_q_con, rain_con, snow_con, + s pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + s kcbot, kctop, kdtop, pmflxr, pmflxs) + d_u_con = 0. + d_v_con = 0. + + WHERE (rain_con < 0.) rain_con = 0. + WHERE (snow_con < 0.) snow_con = 0. + DO i = 1, klon + ibas_con(i) = klev+1 - kcbot(i) + itop_con(i) = klev+1 - kctop(i) + ENDDO + ELSE IF (iflag_con.GE.3) THEN +c nb of tracers for the KE convection: +c MAF la partie traceurs est faite dans phytrac +c on met ntra=1 pour limiter les appels mais on peut +c supprimer les calculs / ftra. + ntra = 1 + +c===================================================================================== +cajout pour la parametrisation des poches froides: +ccalcul de t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri + do k=1,klev + do i=1,klon + if (iflag_wake>=1) then + t_wake(i,k) = t_seri(i,k) + . +(1-wake_s(i))*wake_deltat(i,k) + q_wake(i,k) = q_seri(i,k) + . +(1-wake_s(i))*wake_deltaq(i,k) + t_undi(i,k) = t_seri(i,k) + . -wake_s(i)*wake_deltat(i,k) + q_undi(i,k) = q_seri(i,k) + . -wake_s(i)*wake_deltaq(i,k) + else + t_wake(i,k) = t_seri(i,k) + q_wake(i,k) = q_seri(i,k) + t_undi(i,k) = t_seri(i,k) + q_undi(i,k) = q_seri(i,k) + endif + enddo + enddo + +cc-- Calcul de l'energie disponible ALE (J/kg) et de la puissance disponible ALP (W/m2) +cc-- pour le soulevement des particules dans le modele convectif +c + do i = 1,klon + ALE(i) = 0. + ALP(i) = 0. + enddo +c +ccalcul de ale_wake et alp_wake + if (iflag_wake>=1) then + if (itap .le. it_wape_prescr) then + do i = 1,klon + ale_wake(i) = wape_prescr + alp_wake(i) = fip_prescr + enddo + else + do i = 1,klon +cjyg ALE=WAPE au lieu de ALE = 1/2 Cstar**2 +ccc ale_wake(i) = 0.5*wake_cstar(i)**2 + ale_wake(i) = wake_pe(i) + alp_wake(i) = wake_fip(i) + enddo + endif + else + do i = 1,klon + ale_wake(i) = 0. + alp_wake(i) = 0. + enddo + endif +ccombinaison avec ale et alp de couche limite: constantes si pas de couplage, valeurs calculees +cdans le thermique sinon + if (iflag_coupl.eq.0) then + if (debut.and.prt_level.gt.9) + $ WRITE(lunout,*)'ALE et ALP imposes' + do i = 1,klon +con ne couple que ale +c ALE(i) = max(ale_wake(i),Ale_bl(i)) + ALE(i) = max(ale_wake(i),ale_bl_prescr) +con ne couple que alp +c ALP(i) = alp_wake(i) + Alp_bl(i) + ALP(i) = alp_wake(i) + alp_bl_prescr + enddo + else + IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique' +! do i = 1,klon +! ALE(i) = max(ale_wake(i),Ale_bl(i)) +! avant ALP(i) = alp_wake(i) + Alp_bl(i) +! ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb +! write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i) +! write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i) +! enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Modif FH 2010/04/27. Sans doute temporaire. +! Deux options pour le alp_offset : constant si > 0 ou proportionnel Ãa +! w si <0 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do i = 1,klon + ALE(i) = max(ale_wake(i),Ale_bl(i)) + if (alp_offset>=0.) then + ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb + else + ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.) + if (alp(i)<0.) then + print*,'ALP ',alp(i),alp_wake(i) + s ,Alp_bl(i),alp_offset*min(omega(i,6),0.) + endif + endif + enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + endif + do i=1,klon + if (alp(i)>alp_max) then + IF(prt_level>9)WRITE(lunout,*) & + & 'WARNING SUPER ALP (seuil=',alp_max, + , '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i) + alp(i)=alp_max + endif + if (ale(i)>ale_max) then + IF(prt_level>9)WRITE(lunout,*) & + & 'WARNING SUPER ALE (seuil=',ale_max, + , '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i) + ale(i)=ale_max + endif + enddo + +cfin calcul ale et alp +c================================================================================================= + + +c sb, oct02: +c Schema de convection modularise et vectorise: +c (driver commun aux versions 3 et 4) +c + IF (ok_cvl) THEN ! new driver for convectL + + CALL concvl (iflag_con,iflag_clos, + . dtime,paprs,pplay,t_undi,q_undi, + . t_wake,q_wake,wake_s, + . u_seri,v_seri,tr_seri,nbtr, + . ALE,ALP, + . ema_work1,ema_work2, + . d_t_con,d_q_con,d_u_con,d_v_con,d_tr, + . rain_con, snow_con, ibas_con, itop_con, sigd, + . ema_cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwd0, + . Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, + . pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, + . pmflxr,pmflxs,da,phi,mp, + . ftd,fqd,lalim_conv,wght_th) + +cIM begin +c print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1), +c .dnwd0(1,1),ftd(1,1),fqd(1,1) +cIM end +cIM cf. FH + clwcon0=qcondc + pmfu(:,:)=upwd(:,:)+dnwd(:,:) + + do i = 1, klon + if (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1 + enddo + + ELSE ! ok_cvl + +c MAF conema3 ne contient pas les traceurs + CALL conema3 (dtime, + . paprs,pplay,t_seri,q_seri, + . u_seri,v_seri,tr_seri,ntra, + . ema_work1,ema_work2, + . d_t_con,d_q_con,d_u_con,d_v_con,d_tr, + . rain_con, snow_con, ibas_con, itop_con, + . upwd,dnwd,dnwd0,bas,top, + . Ma,cape,tvp,rflag, + . pbase + . ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr + . ,clwcon0) + + ENDIF ! ok_cvl + +c +c Correction precip + rain_con = rain_con * cvl_corr + snow_con = snow_con * cvl_corr +c + + IF (.NOT. ok_gust) THEN + do i = 1, klon + wd(i)=0.0 + enddo + ENDIF + +c =================================================================== c +c Calcul des proprietes des nuages convectifs +c + +c calcul des proprietes des nuages convectifs + clwcon0(:,:)=fact_cldcon*clwcon0(:,:) + call clouds_gno + s (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0) + +c =================================================================== c + + DO i = 1, klon + itop_con(i) = min(max(itop_con(i),1),klev) + ibas_con(i) = min(max(ibas_con(i),1),itop_con(i)) + ENDDO + + DO i = 1, klon + ema_pcb(i) = paprs(i,ibas_con(i)) + ENDDO + DO i = 1, klon +! L'idicage de itop_con peut cacher un pb potentiel +! FH sous la dictee de JYG, CR + ema_pct(i) = paprs(i,itop_con(i)+1) + + if (itop_con(i).gt.klev-3) then + if(prt_level >= 9) then + write(lunout,*)'La convection monte trop haut ' + write(lunout,*)'itop_con(,',i,',)=',itop_con(i) + endif + endif + ENDDO + ELSE IF (iflag_con.eq.0) THEN + write(lunout,*) 'On n appelle pas la convection' + clwcon0=0. + rnebcon0=0. + d_t_con=0. + d_q_con=0. + d_u_con=0. + d_v_con=0. + rain_con=0. + snow_con=0. + bas=1 + top=1 + ELSE + WRITE(lunout,*) "iflag_con non-prevu", iflag_con + CALL abort + ENDIF + +c CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri, +c . d_u_con, d_v_con) + +!----------------------------------------------------------------------------------------- +! ajout des tendances de la diffusion turbulente + CALL add_phys_tend(d_u_con,d_v_con,d_t_con,d_q_con,dql0,'con') +!----------------------------------------------------------------------------------------- + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after convect' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, rain_con, snow_con, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +C + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy) + WRITE(lunout,*)"aprescon=", za + zx_t = 0.0 + za = 0.0 + DO i = 1, klon + za = za + airephy(i)/REAL(klon) + zx_t = zx_t + (rain_con(i)+ + . snow_con(i))*airephy(i)/REAL(klon) + ENDDO + zx_t = zx_t/za*dtime + WRITE(lunout,*)"Precip=", zx_t + ENDIF + IF (zx_ajustq) THEN + DO i = 1, klon + z_apres(i) = 0.0 + ENDDO + DO k = 1, klev + DO i = 1, klon + z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO + DO i = 1, klon + z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) + . /z_apres(i) + ENDDO + DO k = 1, klev + DO i = 1, klon + IF (z_factor(i).GT.(1.0+1.0E-08) .OR. + . z_factor(i).LT.(1.0-1.0E-08)) THEN + q_seri(i,k) = q_seri(i,k) * z_factor(i) + ENDIF + ENDDO + ENDDO + ENDIF + zx_ajustq=.FALSE. + +c +c============================================================================= +cRR:Evolution de la poche froide: on ne fait pas de separation wake/env +cpour la couche limite diffuse pour l instant +c + if (iflag_wake>=1) then + DO k=1,klev + DO i=1,klon + dt_dwn(i,k) = ftd(i,k) + wdt_PBL(i,k) = 0. + dq_dwn(i,k) = fqd(i,k) + wdq_PBL(i,k) = 0. + M_dwn(i,k) = dnwd0(i,k) + M_up(i,k) = upwd(i,k) + dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k) + udt_PBL(i,k) = 0. + dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k) + udq_PBL(i,k) = 0. + ENDDO + ENDDO + + if (iflag_wake==2) then + ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.) + DO k = 1,klev + dt_dwn(:,k)= dt_dwn(:,k)+ + : ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime + dq_dwn(:,k)= dq_dwn(:,k)+ + : ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime + ENDDO + endif +c +ccalcul caracteristiques de la poche froide + call calWAKE (paprs,pplay,dtime + : ,t_seri,q_seri,omega + : ,dt_dwn,dq_dwn,M_dwn,M_up + : ,dt_a,dq_a,sigd + : ,wdt_PBL,wdq_PBL + : ,udt_PBL,udq_PBL + o ,wake_deltat,wake_deltaq,wake_dth + o ,wake_h,wake_s,wake_dens + o ,wake_pe,wake_fip,wake_gfl + o ,dt_wake,dq_wake + o ,wake_k, t_undi,q_undi + o ,wake_omgbdth,wake_dp_omgb + o ,wake_dtKE,wake_dqKE + o ,wake_dtPBL,wake_dqPBL + o ,wake_omg,wake_dp_deltomg + o ,wake_spread,wake_Cstar,wake_d_deltat_gw + o ,wake_ddeltat,wake_ddeltaq) +c +!----------------------------------------------------------------------------------------- +! ajout des tendances des poches froides +! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake +! coherent avec les autres d_t_... + d_t_wake(:,:)=dt_wake(:,:)*dtime + d_q_wake(:,:)=dq_wake(:,:)*dtime + CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,'wake') +!----------------------------------------------------------------------------------------- + + endif +c +c=================================================================== +cJYG + IF (ip_ebil_phy.ge.2) THEN + ztit='after wake' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF + +c print*,'apres callwake iflag_cldcon=', iflag_cldcon +c +c=================================================================== +c Convection seche (thermiques ou ajustement) +c=================================================================== +c + call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri + s ,seuil_inversion,weak_inversion,dthmin) + + + + d_t_ajsb(:,:)=0. + d_q_ajsb(:,:)=0. + d_t_ajs(:,:)=0. + d_u_ajs(:,:)=0. + d_v_ajs(:,:)=0. + d_q_ajs(:,:)=0. + clwcon0th(:,:)=0. +c +c fm_therm(:,:)=0. +c entr_therm(:,:)=0. +c detr_therm(:,:)=0. +c + IF(prt_level>9)WRITE(lunout,*) + . 'AVANT LA CONVECTION SECHE , iflag_thermals=' + s ,iflag_thermals,' nsplit_thermals=',nsplit_thermals + if(iflag_thermals.lt.0) then +c Rien +c ==== + IF(prt_level>9)WRITE(lunout,*)'pas de convection' + + + else + +c Thermiques +c ========== + IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' + s ,iflag_thermals,' nsplit_thermals=',nsplit_thermals + + + if (iflag_thermals.gt.1) then + call calltherm(pdtphys + s ,pplay,paprs,pphi,weak_inversion + s ,u_seri,v_seri,t_seri,q_seri,zqsat,debut + s ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs + s ,fm_therm,entr_therm,detr_therm + s ,zqasc,clwcon0th,lmax_th,ratqscth + s ,ratqsdiff,zqsatth +con rajoute ale et alp, et les caracteristiques de la couche alim + s ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca + s ,ztv,zpspsk,ztla,zthl) + +! ---------------------------------------------------------------------- +! Transport de la TKE par les panaches thermiques. +! FH : 2010/02/01 + if (iflag_pbl.eq.10) then + call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm, + s rg,paprs,pbl_tke) + endif +! ---------------------------------------------------------------------- +!IM/FH: 2011/02/23 +! Couplage Thermiques/Emanuel seulement si T<0 + if (iflag_coupl==2) then + print*,'Couplage Thermiques/Emanuel seulement si T<0' + do i=1,klon + if (t_seri(i,lmax_th(i))>273.) then + Ale_bl(i)=0. + endif + enddo + endif + + do i=1,klon + zmax_th(i)=pphi(i,lmax_th(i))/rg + enddo + + endif + + +c Ajustement sec +c ============== + +! Dans le cas où on active les thermiques, on fait partir l'ajustement +! a partir du sommet des thermiques. +! Dans le cas contraire, on demarre au niveau 1. + + if (iflag_thermals.ge.13.or.iflag_thermals.eq.0) then + + if(iflag_thermals.eq.0) then + IF(prt_level>9)WRITE(lunout,*)'ajsec' + limbas(:)=1 + else + limbas(:)=lmax_th(:) + endif + +! Attention : le call ajsec_convV2 n'est maintenu que momentanneement +! pour des test de convergence numerique. +! Le nouveau ajsec est a priori mieux, meme pour le cas +! iflag_thermals = 0 (l'ancienne version peut faire des tendances +! non nulles numeriquement pour des mailles non concernees. + + if (iflag_thermals.eq.0) then + CALL ajsec_convV2(paprs, pplay, t_seri,q_seri + s , d_t_ajsb, d_q_ajsb) + else + CALL ajsec(paprs, pplay, t_seri,q_seri,limbas + s , d_t_ajsb, d_q_ajsb) + endif + +!----------------------------------------------------------------------------------------- +! ajout des tendances de l'ajustement sec ou des thermiques + CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,'ajsb') + d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:) + d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:) + +!----------------------------------------------------------------------------------------- + + endif + + endif +c +c=================================================================== +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after dry_adjust' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF + + +c------------------------------------------------------------------------- +c Caclul des ratqs +c------------------------------------------------------------------------- + +c print*,'calcul des ratqs' +c ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q +c ---------------- +c on ecrase le tableau ratqsc calcule par clouds_gno + if (iflag_cldcon.eq.1) then + do k=1,klev + do i=1,klon + if(ptconv(i,k)) then + ratqsc(i,k)=ratqsbas + s +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k) + else + ratqsc(i,k)=0. + endif + enddo + enddo + +c----------------------------------------------------------------------- +c par nversion de la fonction log normale +c----------------------------------------------------------------------- + else if (iflag_cldcon.eq.4) then + ptconvth(:,:)=.false. + ratqsc(:,:)=0. + if(prt_level.ge.9) print*,'avant clouds_gno thermique' + call clouds_gno + s (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th) + if(prt_level.ge.9) print*,' CLOUDS_GNO OK' + + endif + +c ratqs stables +c ------------- + + if (iflag_ratqs.eq.0) then + +! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele. + do k=1,klev + do i=1, klon + ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* + s min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) + enddo + enddo + +! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de +! 300 hPa (ratqshaut), varie lineariement en fonction de la pression +! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1 +! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2 +! Il s'agit de differents tests dans la phase de reglage du modele +! avec thermiques. + + else if (iflag_ratqs.eq.1) then + + do k=1,klev + do i=1, klon + if (pplay(i,k).ge.60000.) then + ratqss(i,k)=ratqsbas + else if ((pplay(i,k).ge.30000.).and. + s (pplay(i,k).lt.60000.)) then + ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* + s (60000.-pplay(i,k))/(60000.-30000.) + else + ratqss(i,k)=ratqshaut + endif + enddo + enddo + + else if (iflag_ratqs.eq.2) then + + do k=1,klev + do i=1, klon + if (pplay(i,k).ge.60000.) then + ratqss(i,k)=ratqsbas + s *(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.) + else if ((pplay(i,k).ge.30000.).and. + s (pplay(i,k).lt.60000.)) then + ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* + s (60000.-pplay(i,k))/(60000.-30000.) + else + ratqss(i,k)=ratqshaut + endif + enddo + enddo + + else if (iflag_ratqs==3) then + do k=1,klev + ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas) + s *min( ((paprs(:,1)-pplay(:,k))/70000.)**2 , 1. ) + enddo + + else if (iflag_ratqs==4) then + do k=1,klev + ratqss(:,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) + s *( tanh( (50000.-pplay(:,k))/20000.) + 1.) + enddo + + endif + + + + +c ratqs final +c ----------- + + if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2 + s .or.iflag_cldcon.eq.4) then + +! On ajoute une constante au ratqsc*2 pour tenir compte de +! fluctuations turbulentes de petite echelle + + do k=1,klev + do i=1,klon + if ((fm_therm(i,k).gt.1.e-10)) then + ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2) + endif + enddo + enddo + +! les ratqs sont une combinaison de ratqss et ratqsc + if(prt_level.ge.9) + $ write(lunout,*)'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs + + if (tau_ratqs>1.e-10) then + facteur=exp(-pdtphys/tau_ratqs) + else + facteur=0. + endif + ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH 22/09/2009 +! La ligne ci-dessous faisait osciller le modele et donnait une solution +! assymptotique bidon et dépendant fortement du pas de temps. +! ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ratqs(:,:)=max(ratqs(:,:),ratqss(:,:)) + else if (iflag_cldcon<=6) then +! on ne prend que le ratqs stable pour fisrtilp + ratqs(:,:)=ratqss(:,:) + else + zfratqs1=exp(-pdtphys/10800.) + zfratqs2=exp(-pdtphys/10800.) +! print*,'RAPPEL RATQS 1 ',zfratqs1,zfratqs2 +! s ,ratqss(1,14),ratqs(1,14),ratqsc(1,14) + do k=1,klev + do i=1,klon + if (ratqsc(i,k).gt.1.e-10) then + ratqs(i,k)=ratqs(i,k)*zfratqs2 + s +(iflag_cldcon/100.)*ratqsc(i,k)*(1.-zfratqs2) + endif + ratqs(i,k)=min(ratqs(i,k)*zfratqs1 + s +ratqss(i,k)*(1.-zfratqs1),0.5) + enddo + enddo + endif + + +c +c Appeler le processus de condensation a grande echelle +c et le processus de precipitation +c------------------------------------------------------------------------- + CALL fisrtilp(dtime,paprs,pplay, + . t_seri, q_seri,ptconv,ratqs, + . d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq, + . rain_lsc, snow_lsc, + . pfrac_impa, pfrac_nucl, pfrac_1nucl, + . frac_impa, frac_nucl, + . prfl, psfl, rhcl, + . zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cldcon ) + + WHERE (rain_lsc < 0) rain_lsc = 0. + WHERE (snow_lsc < 0) snow_lsc = 0. +!----------------------------------------------------------------------------------------- +! ajout des tendances de la diffusion turbulente + CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,'lsc') +!----------------------------------------------------------------------------------------- + DO k = 1, klev + DO i = 1, klon + cldfra(i,k) = rneb(i,k) + IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k) + ENDDO + ENDDO + IF (check) THEN + za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy) + WRITE(lunout,*)"apresilp=", za + zx_t = 0.0 + za = 0.0 + DO i = 1, klon + za = za + airephy(i)/REAL(klon) + zx_t = zx_t + (rain_lsc(i) + . + snow_lsc(i))*airephy(i)/REAL(klon) + ENDDO + zx_t = zx_t/za*dtime + WRITE(lunout,*)"Precip=", zx_t + ENDIF +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after fisrt' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, rain_lsc, snow_lsc, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +c +c------------------------------------------------------------------- +c PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT +c------------------------------------------------------------------- + +c 1. NUAGES CONVECTIFS +c +cIM cf FH +c IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke + IF (iflag_cldcon.le.-1) THEN ! seulement pour Tiedtke + snow_tiedtke=0. +c print*,'avant calcul de la pseudo precip ' +c print*,'iflag_cldcon',iflag_cldcon + if (iflag_cldcon.eq.-1) then + rain_tiedtke=rain_con + else +c print*,'calcul de la pseudo precip ' + rain_tiedtke=0. +c print*,'calcul de la pseudo precip 0' + do k=1,klev + do i=1,klon + if (d_q_con(i,k).lt.0.) then + rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys + s *(paprs(i,k)-paprs(i,k+1))/rg + endif + enddo + enddo + endif +c +c call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ') +c + +c Nuages diagnostiques pour Tiedtke + CALL diagcld1(paprs,pplay, +cIM cf FH . rain_con,snow_con,ibas_con,itop_con, + . rain_tiedtke,snow_tiedtke,ibas_con,itop_con, + . diafra,dialiq) + DO k = 1, klev + DO i = 1, klon + IF (diafra(i,k).GT.cldfra(i,k)) THEN + cldliq(i,k) = dialiq(i,k) + cldfra(i,k) = diafra(i,k) + ENDIF + ENDDO + ENDDO + + ELSE IF (iflag_cldcon.ge.3) THEN +c On prend pour les nuages convectifs le max du calcul de la +c convection et du calcul du pas de temps precedent diminue d'un facteur +c facttemps + facteur = pdtphys *facttemps + do k=1,klev + do i=1,klon + rnebcon(i,k)=rnebcon(i,k)*facteur + if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k)) + s then + rnebcon(i,k)=rnebcon0(i,k) + clwcon(i,k)=clwcon0(i,k) + endif + enddo + enddo + +c +cjq - introduce the aerosol direct and first indirect radiative forcings +cjq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr) + IF (ok_ade.OR.ok_aie) THEN + IF (.NOT. aerosol_couple) + & CALL readaerosol_optic( + & debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, + & pdtphys, pplay, paprs, t_seri, rhcl, presnivs, + & mass_solu_aero, mass_solu_aero_pi, + & tau_aero, piz_aero, cg_aero, + & tausum_aero, tau3d_aero) + ELSE + tausum_aero(:,:,:) = 0. + tau_aero(:,:,:,:) = 0. + piz_aero(:,:,:,:) = 0. + cg_aero(:,:,:,:) = 0. + ENDIF + +cIM calcul nuages par le simulateur ISCCP +c +#ifdef histISCCP + IF (ok_isccp) THEN +c +cIM lecture invtau, tautab des fichiers formattes +c + IF (debut) THEN +c$OMP MASTER +c + open(99,file='tautab.formatted', FORM='FORMATTED') + read(99,'(f30.20)') tautab_omp + close(99) +c + open(99,file='invtau.formatted',form='FORMATTED') + read(99,'(i10)') invtau_omp + +c print*,'calcul_simulISCCP invtau_omp',invtau_omp +c write(6,'(a,8i10)') 'invtau_omp',(invtau_omp(i),i=1,100) + + close(99) +c$OMP END MASTER +c$OMP BARRIER + tautab=tautab_omp + invtau=invtau_omp +c + ENDIF !debut +c +cIM appel simulateur toutes les NINT(freq_ISCCP/dtime) heures + IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN +#include "calcul_simulISCCP.h" + ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime)) + ENDIF !ok_isccp +#endif + +c On prend la somme des fractions nuageuses et des contenus en eau + + if (iflag_cldcon>=5) then + + do k=1,klev + ptconvth(:,k)=fm_therm(:,k+1)>0. + enddo + + if (iflag_coupl==4) then + +! Dans le cas iflag_coupl==4, on prend la somme des convertures +! convectives et lsc dans la partie des thermiques +! Le controle par iflag_coupl est peut etre provisoire. + do k=1,klev + do i=1,klon + if (ptconv(i,k).and.ptconvth(i,k)) then + cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) + cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) + else if (ptconv(i,k)) then + cldfra(i,k)=rnebcon(i,k) + cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) + endif + enddo + enddo + + else if (iflag_coupl==5) then + do k=1,klev + do i=1,klon + cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.) + cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k) + enddo + enddo + + else + +! Si on est sur un point touche par la convection profonde et pas +! par les thermiques, on prend la couverture nuageuse et l'eau nuageuse +! de la convection profonde. + +!IM/FH: 2011/02/23 +! definition des points sur lesquels ls thermiques sont actifs + + do k=1,klev + do i=1,klon + if (ptconv(i,k).and. .not. ptconvth(i,k)) then + cldfra(i,k)=rnebcon(i,k) + cldliq(i,k)=rnebcon(i,k)*clwcon(i,k) + endif + enddo + enddo + + endif + + else + +! Ancienne version + cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.) + cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:) + endif + + ENDIF + +! plulsc(:)=0. +! do k=1,klev,-1 +! do i=1,klon +! zzz=prfl(:,k)+psfl(:,k) +! if (.not.ptconvth.zzz.gt.0.) +! enddo prfl, psfl, +! enddo +c +c 2. NUAGES STARTIFORMES +c + IF (ok_stratus) THEN + CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq) + DO k = 1, klev + DO i = 1, klon + IF (diafra(i,k).GT.cldfra(i,k)) THEN + cldliq(i,k) = dialiq(i,k) + cldfra(i,k) = diafra(i,k) + ENDIF + ENDDO + ENDDO + ENDIF +c +c Precipitation totale +c + DO i = 1, klon + rain_fall(i) = rain_con(i) + rain_lsc(i) + snow_fall(i) = snow_con(i) + snow_lsc(i) + ENDDO +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit="after diagcld" + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +c +c Calculer l'humidite relative pour diagnostique +c + DO k = 1, klev + DO i = 1, klon + zx_t = t_seri(i,k) + IF (thermcep) THEN + zdelta = MAX(0.,SIGN(1.,rtt-zx_t)) + zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k) + zx_qs = MIN(0.5,zx_qs) + zcor = 1./(1.-retv*zx_qs) + zx_qs = zx_qs*zcor + ELSE + IF (zx_t.LT.t_coup) THEN + zx_qs = qsats(zx_t)/pplay(i,k) + ELSE + zx_qs = qsatl(zx_t)/pplay(i,k) + ENDIF + ENDIF + zx_rh(i,k) = q_seri(i,k)/zx_qs + zqsat(i,k)=zx_qs + ENDDO + ENDDO + +cIM Calcul temp.potentielle a 2m (tpot) et temp. potentielle +c equivalente a 2m (tpote) pour diagnostique +c + DO i = 1, klon + tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA + IF (thermcep) THEN + IF(zt2m(i).LT.RTT) then + Lheat=RLSTT + ELSE + Lheat=RLVTT + ENDIF + ELSE + IF (zt2m(i).LT.RTT) THEN + Lheat=RLSTT + ELSE + Lheat=RLVTT + ENDIF + ENDIF + tpote(i) = tpot(i)* + . EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i))) + ENDDO + + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) + calday = REAL(days_elapsed + 1) + jH_cur + + call chemtime(itap+itau_phy-1, date0, dtime) + IF (config_inca == 'aero') THEN + CALL AEROSOL_METEO_CALC( + $ calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, + $ prfl,psfl,pctsrf,airephy,rlat,rlon,u10m,v10m) + END IF + + zxsnow_dummy(:) = 0.0 + + CALL chemhook_begin (calday, + $ days_elapsed+1, + $ jH_cur, + $ pctsrf(1,1), + $ rlat, + $ rlon, + $ airephy, + $ paprs, + $ pplay, + $ coefh, + $ pphi, + $ t_seri, + $ u, + $ v, + $ wo(:, :, 1), + $ q_seri, + $ zxtsol, + $ zxsnow_dummy, + $ solsw, + $ albsol1, + $ rain_fall, + $ snow_fall, + $ itop_con, + $ ibas_con, + $ cldfra, + $ iim, + $ jjm, + $ tr_seri, + $ ftsol, + $ paprs, + $ cdragh, + $ cdragm, + $ pctsrf, + $ pdtphys, + $ itap) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF !config_inca /= 'none' +c +c Calculer les parametres optiques des nuages et quelques +c parametres pour diagnostiques: +c + + IF (aerosol_couple) THEN + mass_solu_aero(:,:) = ccm(:,:,1) + mass_solu_aero_pi(:,:) = ccm(:,:,2) + END IF + + if (ok_newmicro) then + CALL newmicro (paprs, pplay,ok_newmicro, + . t_seri, cldliq, cldfra, cldtau, cldemi, + . cldh, cldl, cldm, cldt, cldq, + . flwp, fiwp, flwc, fiwc, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl, ref_liq, ref_ice) + else + CALL nuage (paprs, pplay, + . t_seri, cldliq, cldfra, cldtau, cldemi, + . cldh, cldl, cldm, cldt, cldq, + e ok_aie, + e mass_solu_aero, mass_solu_aero_pi, + e bl95_b0, bl95_b1, + s cldtaupi, re, fl) + + endif +c +cIM betaCRF +c + cldtaurad = cldtau + cldemirad = cldemi +c + if(lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND. + $lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN +c +c global +c + DO k=1, klev + DO i=1, klon + if (pplay(i,k).GE.pfree) THEN + beta(i,k) = beta_pbl + else + beta(i,k) = beta_free + endif + if (mskocean_beta) THEN + beta(i,k) = beta(i,k) * pctsrf(i,is_oce) + endif + cldtaurad(i,k) = cldtau(i,k) * beta(i,k) + cldemirad(i,k) = cldemi(i,k) * beta(i,k) + ENDDO + ENDDO +c + else +c +c regional +c + DO k=1, klev + DO i=1,klon +c + if (rlon(i).ge.lon1_beta.AND.rlon(i).le.lon2_beta.AND. + $ rlat(i).le.lat1_beta.AND.rlat(i).ge.lat2_beta) THEN + if (pplay(i,k).GE.pfree) THEN + beta(i,k) = beta_pbl + else + beta(i,k) = beta_free + endif + if (mskocean_beta) THEN + beta(i,k) = beta(i,k) * pctsrf(i,is_oce) + endif + cldtaurad(i,k) = cldtau(i,k) * beta(i,k) + cldemirad(i,k) = cldemi(i,k) * beta(i,k) + endif +c + ENDDO + ENDDO +c + endif +c +c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol. +c + IF (MOD(itaprad,radpas).EQ.0) THEN + + DO i = 1, klon + albsol1(i) = falb1(i,is_oce) * pctsrf(i,is_oce) + . + falb1(i,is_lic) * pctsrf(i,is_lic) + . + falb1(i,is_ter) * pctsrf(i,is_ter) + . + falb1(i,is_sic) * pctsrf(i,is_sic) + albsol2(i) = falb2(i,is_oce) * pctsrf(i,is_oce) + . + falb2(i,is_lic) * pctsrf(i,is_lic) + . + falb2(i,is_ter) * pctsrf(i,is_ter) + . + falb2(i,is_sic) * pctsrf(i,is_sic) + ENDDO + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + IF (aerosol_couple) THEN +#ifdef INCA + CALL radlwsw_inca + e (kdlon,kflev,dist, rmu0, fract, solaire, + e paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, + e wo(:, :, 1), + e cldfra, cldemirad, cldtaurad, + s heat,heat0,cool,cool0,radsol,albpla, + s topsw,toplw,solsw,sollw, + s sollwdown, + s topsw0,toplw0,solsw0,sollw0, + s lwdn0, lwdn, lwup0, lwup, + s swdn0, swdn, swup0, swup, + e ok_ade, ok_aie, + e tau_aero, piz_aero, cg_aero, + s topswad_aero, solswad_aero, + s topswad0_aero, solswad0_aero, + s topsw_aero, topsw0_aero, + s solsw_aero, solsw0_aero, + e cldtaupi, + s topswai_aero, solswai_aero) + +#endif + ELSE +c +cIM calcul radiatif pour le cas actuel +c + RCO2 = RCO2_act + RCH4 = RCH4_act + RN2O = RN2O_act + RCFC11 = RCFC11_act + RCFC12 = RCFC12_act +c + CALL radlwsw + e (dist, rmu0, fract, + e paprs, pplay,zxtsol,albsol1, albsol2, + e t_seri,q_seri,wo, + e cldfra, cldemirad, cldtaurad, + e ok_ade, ok_aie, + e tau_aero, piz_aero, cg_aero, + e cldtaupi,new_aod, + e zqsat, flwc, fiwc, + s heat,heat0,cool,cool0,radsol,albpla, + s topsw,toplw,solsw,sollw, + s sollwdown, + s topsw0,toplw0,solsw0,sollw0, + s lwdn0, lwdn, lwup0, lwup, + s swdn0, swdn, swup0, swup, + s topswad_aero, solswad_aero, + s topswai_aero, solswai_aero, + o topswad0_aero, solswad0_aero, + o topsw_aero, topsw0_aero, + o solsw_aero, solsw0_aero, + o topswcf_aero, solswcf_aero) + +c +cIM 2eme calcul radiatif pour le cas perturbe ou au moins un +cIM des taux doit etre different du taux actuel +cIM Par defaut on a les taux perturbes egaux aux taux actuels +c + if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. + $RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. + $RCFC12_per.NE.RCFC12_act) THEN +c + RCO2 = RCO2_per + RCH4 = RCH4_per + RN2O = RN2O_per + RCFC11 = RCFC11_per + RCFC12 = RCFC12_per +c + CALL radlwsw + e (dist, rmu0, fract, + e paprs, pplay,zxtsol,albsol1, albsol2, + e t_seri,q_seri,wo, + e cldfra, cldemi, cldtau, + e ok_ade, ok_aie, + e tau_aero, piz_aero, cg_aero, + e cldtaupi,new_aod, + e zqsat, flwc, fiwc, + s heatp,heat0p,coolp,cool0p,radsolp,albplap, + s topswp,toplwp,solswp,sollwp, + s sollwdownp, + s topsw0p,toplw0p,solsw0p,sollw0p, + s lwdn0p, lwdnp, lwup0p, lwupp, + s swdn0p, swdnp, swup0p, swupp, + s topswad_aerop, solswad_aerop, + s topswai_aerop, solswai_aerop, + o topswad0_aerop, solswad0_aerop, + o topsw_aerop, topsw0_aerop, + o solsw_aerop, solsw0_aerop, + o topswcf_aerop, solswcf_aerop) + endif +c + ENDIF ! aerosol_couple + itaprad = 0 + ENDIF ! MOD(itaprad,radpas) + itaprad = itaprad + 1 + + IF (iflag_radia.eq.0) THEN + IF (prt_level.ge.9) THEN + PRINT *,'--------------------------------------------------' + PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas' + PRINT *,'>>>> heat et cool mis a zero ' + PRINT *,'--------------------------------------------------' + END IF + heat=0. + cool=0. + sollw=0. ! MPL 01032011 + solsw=0. + radsol=0. + END IF + +c +c Ajouter la tendance des rayonnements (tous les pas) +c + DO k = 1, klev + DO i = 1, klon + t_seri(i,k) = t_seri(i,k) + . + (heat(i,k)-cool(i,k)) * dtime/RDAY + ENDDO + ENDDO +c + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after rad' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , topsw, toplw, solsw, sollw, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +c +c +c Calculer l'hydrologie de la surface +c +c CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap, +c . agesno, ftsol,fqsurf,fsnow, ruis) +c + +c +c Calculer le bilan du sol et la derive de temperature (couplage) +c + DO i = 1, klon +c bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT +c a la demande de JLD + bils(i) = radsol(i) - sens(i) + zxfluxlat(i) + ENDDO +c +cmoddeblott(jan95) +c Appeler le programme de parametrisation de l'orographie +c a l'echelle sous-maille: +c + IF (ok_orodr) THEN +c +c selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 +c IF ((zstd(i).gt.10.0)) THEN + IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO +c igwdim=MAX(1,igwd) +c + IF (ok_strato) THEN + + CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, + e zmea,zstd, zsig, zgam, zthe,zpic,zval, + e igwd,idx,itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrdr, zvstrdr, + s d_t_oro, d_u_oro, d_v_oro) + + ELSE + CALL drag_noro(klon,klev,dtime,paprs,pplay, + e zmea,zstd, zsig, zgam, zthe,zpic,zval, + e igwd,idx,itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrdr, zvstrdr, + s d_t_oro, d_u_oro, d_v_oro) + ENDIF +c +c ajout des tendances +!----------------------------------------------------------------------------------------- +! ajout des tendances de la trainee de l'orographie + CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,'oro') +!----------------------------------------------------------------------------------------- +c + ENDIF ! fin de test sur ok_orodr +c + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + IF (ok_orolf) THEN +c +c selection des points pour lesquels le shema est actif: + igwd=0 + DO i=1,klon + itest(i)=0 + IF ((zpic(i)-zmea(i)).GT.100.) THEN + itest(i)=1 + igwd=igwd+1 + idx(igwd)=i + ENDIF + ENDDO +c igwdim=MAX(1,igwd) +c + IF (ok_strato) THEN + + CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, + e rlat,zmea,zstd,zpic,zgam,zthe,zpic,zval, + e igwd,idx,itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrli, zvstrli, + s d_t_lif, d_u_lif, d_v_lif ) + + ELSE + CALL lift_noro(klon,klev,dtime,paprs,pplay, + e rlat,zmea,zstd,zpic, + e itest, + e t_seri, u_seri, v_seri, + s zulow, zvlow, zustrli, zvstrli, + s d_t_lif, d_u_lif, d_v_lif) + ENDIF +c +!----------------------------------------------------------------------------------------- +! ajout des tendances de la portance de l'orographie + CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,'lif') +!----------------------------------------------------------------------------------------- +c + ENDIF ! fin de test sur ok_orolf +C HINES GWD PARAMETRIZATION + + IF (ok_hines) then + + CALL hines_gwd(klon,klev,dtime,paprs,pplay, + i rlat,t_seri,u_seri,v_seri, + o zustrhi,zvstrhi, + o d_t_hin, d_u_hin, d_v_hin) +c +c ajout des tendances + CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,'hin') + + ENDIF +c + +c +cIM cf. FLott BEG +C STRESS NECESSAIRES: TOUTE LA PHYSIQUE + + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + DO i = 1, klon + zustrph(i)=0. + zvstrph(i)=0. + ENDDO + DO k = 1, klev + DO i = 1, klon + zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* + c (paprs(i,k)-paprs(i,k+1))/rg + zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* + c (paprs(i,k)-paprs(i,k+1))/rg + ENDDO + ENDDO +c +cIM calcul composantes axiales du moment angulaire et couple des montagnes +c + IF (is_sequential) THEN + + CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, + C ra,rg,romega, + C rlat,rlon,pphis, + C zustrdr,zustrli,zustrph, + C zvstrdr,zvstrli,zvstrph, + C paprs,u,v, + C aam, torsfc) + ENDIF +cIM cf. FLott END +cIM + IF (ip_ebil_phy.ge.2) THEN + ztit='after orography' + CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) + call diagphy(airephy,ztit,ip_ebil_phy + e , zero_v, zero_v, zero_v, zero_v, zero_v + e , zero_v, zero_v, zero_v, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) + END IF +c +c +!==================================================================== +! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..) +!==================================================================== +! Abderrahmane 24.08.09 + + IF (ok_cosp) THEN +! adeclarer +#ifdef CPP_COSP + IF (MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN + + print*,'freq_cosp',freq_cosp + mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse +! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=', +! s ref_liq,ref_ice + call phys_cosp(itap,dtime,freq_cosp, + $ ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, + $ ecrit_mth,ecrit_day,ecrit_hf, + $ klon,klev,rlon,rlat,presnivs,overlap, + $ ref_liq,ref_ice, + $ pctsrf(:,is_ter)+pctsrf(:,is_lic), + $ zu10m,zv10m,pphis, + $ zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, + $ qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, + $ prfl(:,1:klev),psfl(:,1:klev), + $ pmflxr(:,1:klev),pmflxs(:,1:klev), + $ mr_ozone,cldtaurad, cldemirad) + +! L calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol, +! L cfaddbze,clcalipso2,dbze,cltlidarradar, +! M clMISR, +! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp, +! I tauisccp,albisccp,meantbisccp,meantbclrisccp) + + ENDIF + +#endif + ENDIF !ok_cosp +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +cAA +cAA Installation de l'interface online-offline pour traceurs +cAA +c==================================================================== +c Calcul des tendances traceurs +c==================================================================== +C + + call phytrac ( + I itap, days_elapsed+1, jH_cur, debut, + I lafin, dtime, u, v, t, + I paprs, pplay, pmfu, pmfd, + I pen_u, pde_u, pen_d, pde_d, + I cdragh, coefh, fm_therm, entr_therm, + I u1, v1, ftsol, pctsrf, + I rlat, frac_impa, frac_nucl,rlon, + I presnivs, pphis, pphi, albsol1, + I qx(:,:,ivap),rhcl, cldfra, rneb, + I diafra, cldliq, itop_con, ibas_con, + I pmflxr, pmflxs, prfl, psfl, + I da, phi, mp, upwd, + I dnwd, aerosol_couple, flxmass_w, + I tau_aero, piz_aero, cg_aero, ccm, + I rfname, + O tr_seri) + + IF (offline) THEN + + IF (prt_level.ge.9) + $ print*,'Attention on met a 0 les thermiques pour phystoke' + call phystokenc ( + I nlon,klev,pdtphys,rlon,rlat, + I t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, + I fm_therm,entr_therm, + I cdragh,coefh,u1,v1,ftsol,pctsrf, + I frac_impa, frac_nucl, + I pphis,airephy,dtime,itap, + I qx(:,:,ivap),da,phi,mp,upwd,dnwd) + + + ENDIF + +c +c Calculer le transport de l'eau et de l'energie (diagnostique) +c + CALL transp (paprs,zxtsol, + e t_seri, q_seri, u_seri, v_seri, zphi, + s ve, vq, ue, uq) +c +cIM global posePB BEG + IF(1.EQ.0) THEN +c + CALL transp_lay (paprs,zxtsol, + e t_seri, q_seri, u_seri, v_seri, zphi, + s ve_lay, vq_lay, ue_lay, uq_lay) +c + ENDIF !(1.EQ.0) THEN +cIM global posePB END +c Accumuler les variables a stocker dans les fichiers histoire: +c +c+jld ec_conser + DO k = 1, klev + DO i = 1, klon + ZRCPD = RCPD*(1.0+RVTMP2*q_seri(i,k)) + d_t_ec(i,k)=0.5/ZRCPD + $ *(u(i,k)**2+v(i,k)**2-u_seri(i,k)**2-v_seri(i,k)**2) + ENDDO + ENDDO + + DO k = 1, klev + DO i = 1, klon + t_seri(i,k)=t_seri(i,k)+d_t_ec(i,k) + d_t_ec(i,k) = d_t_ec(i,k)/dtime + END DO + END DO +c-jld ec_conser +cIM + IF (ip_ebil_phy.ge.1) THEN + ztit='after physic' + CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime + e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay + s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec) +C Comme les tendances de la physique sont ajoute dans la dynamique, +C on devrait avoir que la variation d'entalpie par la dynamique +C est egale a la variation de la physique au pas de temps precedent. +C Donc la somme de ces 2 variations devrait etre nulle. + + call diagphy(airephy,ztit,ip_ebil_phy + e , topsw, toplw, solsw, sollw, sens + e , evap, rain_fall, snow_fall, ztsol + e , d_h_vcol, d_qt, d_ec + s , fs_bound, fq_bound ) +C + d_h_vcol_phy=d_h_vcol +C + END IF +C +c======================================================================= +c SORTIES +c======================================================================= + +cIM Interpolation sur les niveaux de pression du NMC +c ------------------------------------------------- +c +#include "calcul_STDlev.h" + 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(:,:) +c +cIM 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(:,:) +c +cIM 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(:,:) +cIM for NMC files + DO n=1, nlevSTD3 + DO k=1, nlevSTD + if(rlevSTD3(n).EQ.rlevSTD(k)) THEN + twriteSTD3(:,n)=tlevSTD(:,k) + qwriteSTD3(:,n)=qlevSTD(:,k) + rhwriteSTD3(:,n)=rhlevSTD(:,k) + phiwriteSTD3(:,n)=philevSTD(:,k) + uwriteSTD3(:,n)=ulevSTD(:,k) + vwriteSTD3(:,n)=vlevSTD(:,k) + wwriteSTD3(:,n)=wlevSTD(:,k) + endif !rlevSTD3(n).EQ.rlevSTD(k) + ENDDO + ENDDO +c + DO n=1, nlevSTD8 + DO k=1, nlevSTD + if(rlevSTD8(n).EQ.rlevSTD(k)) THEN + tnondefSTD8(:,n)=tnondef(:,k,2) + twriteSTD8(:,n)=tsumSTD(:,k,2) + qwriteSTD8(:,n)=qsumSTD(:,k,2) + rhwriteSTD8(:,n)=rhsumSTD(:,k,2) + phiwriteSTD8(:,n)=phisumSTD(:,k,2) + uwriteSTD8(:,n)=usumSTD(:,k,2) + vwriteSTD8(:,n)=vsumSTD(:,k,2) + wwriteSTD8(:,n)=wsumSTD(:,k,2) + endif !rlevSTD8(n).EQ.rlevSTD(k) + ENDDO + ENDDO +c +c slp sea level pressure + slp(:) = paprs(:,1)*exp(pphis(:)/(RD*t_seri(:,1))) +c +ccc prw = eau precipitable + DO i = 1, klon + prw(i) = 0. + DO k = 1, klev + prw(i) = prw(i) + + . q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO +c +cIM initialisation + calculs divers diag AMIP2 +c +#include "calcul_divers.h" +c + IF (config_inca /= 'none') THEN +#ifdef INCA + CALL VTe(VTphysiq) + CALL VTb(VTinca) + + CALL chemhook_end ( + $ dtime, + $ pplay, + $ t_seri, + $ tr_seri, + $ nbtr, + $ paprs, + $ q_seri, + $ airephy, + $ pphi, + $ pphis, + $ zx_rh) + + CALL VTe(VTinca) + CALL VTb(VTphysiq) +#endif + END IF + +c============================================================= +c +c Convertir les incrementations en tendances +c + if (mydebug) then + call writefield_phy('u_seri',u_seri,llm) + call writefield_phy('v_seri',v_seri,llm) + call writefield_phy('t_seri',t_seri,llm) + call writefield_phy('q_seri',q_seri,llm) + endif + + DO k = 1, klev + DO i = 1, klon + d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime + d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime + d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime + d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime + d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime + ENDDO + ENDDO +c + IF (nqtot.GE.3) THEN + DO iq = 3, nqtot + DO k = 1, klev + DO i = 1, klon + d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime + ENDDO + ENDDO + ENDDO + ENDIF +c +cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano +cIM global posePB#include "write_bilKP_ins.h" +cIM global posePB#include "write_bilKP_ave.h" +c + +c Sauvegarder les valeurs de t et q a la fin de la physique: +c + DO k = 1, klev + DO i = 1, klon + u_ancien(i,k) = u_seri(i,k) + v_ancien(i,k) = v_seri(i,k) + t_ancien(i,k) = t_seri(i,k) + q_ancien(i,k) = q_seri(i,k) + ENDDO + ENDDO +c +!========================================================================== +! Sorties des tendances pour un point particulier +! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier +! pour le debug +! La valeur de igout est attribuee plus haut dans le programme +!========================================================================== + + if (prt_level.ge.1) then + write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!' + write(lunout,*) + s 'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos' + write(lunout,*) + s nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, + s pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), + s pctsrf(igout,is_sic) + write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva' + do k=1,klev + write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), + s d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), + s d_t_eva(igout,k) + enddo + write(lunout,*) 'cool,heat' + do k=1,klev + write(lunout,*) cool(igout,k),heat(igout,k) + enddo + + write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec' + do k=1,klev + write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), + s d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k) + enddo + + write(lunout,*) 'd_ps ',d_ps(igout) + write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 ' + do k=1,klev + write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), + s d_qx(igout,k,1),d_qx(igout,k,2) + enddo + endif + +!========================================================================== + +c============================================================ +c Calcul de la temperature potentielle +c============================================================ + DO k = 1, klev + DO i = 1, klon +cJYG/IM theta en debut du pas de temps +cJYG/IM theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD) +cJYG/IM theta en fin de pas de temps de physique + theta(i,k)=t_seri(i,k)*(100000./pplay(i,k))**(RD/RCPD) + ENDDO + ENDDO +c + +c 22.03.04 BEG +c============================================================= +c Ecriture des sorties +c============================================================= +#ifdef CPP_IOIPSL + +c Recupere des varibles calcule dans differents modules +c pour ecriture dans histxxx.nc + + ! Get some variables from module fonte_neige_mod + CALL fonte_neige_get_vars(pctsrf, + . zxfqcalving, zxfqfonte, zxffonte) + + + +c============================================================= +! Separation entre thermiques et non thermiques dans les sorties +! de fisrtilp +c============================================================= + + if (iflag_thermals>1) then + d_t_lscth=0. + d_t_lscst=0. + d_q_lscth=0. + d_q_lscst=0. + do k=1,klev + do i=1,klon + if (ptconvth(i,k)) then + d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) + d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) + else + d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k) + d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k) + endif + enddo + enddo + + do i=1,klon + plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1) + plul_th(i)=prfl(i,1)+psfl(i,1) + enddo + endif + + +#include "phys_output_write.h" + +#ifdef histISCCP +#include "write_histISCCP.h" +#endif + +#ifdef histNMC +#include "write_histhfNMC.h" +#include "write_histdayNMC.h" +#include "write_histmthNMC.h" +#endif + +#include "write_histday_seri.h" + +#include "write_paramLMDZ_phy.h" + +#endif + +c 22.03.04 END +c +c==================================================================== +c Si c'est la fin, il faut conserver l'etat de redemarrage +c==================================================================== +c + +c ----------------------------------------------------------------- +c WSTATS: Saving statistics +c ----------------------------------------------------------------- +c ("stats" stores and accumulates 8 key variables in file "stats.nc" +c which can later be used to make the statistic files of the run: +c "stats") only possible in 3D runs ! + + + IF (callstats) THEN + + call wstats(klon,o_psol%name,"Surface pressure","Pa" + & ,2,paprs(:,1)) + call wstats(klon,o_tsol%name,"Surface temperature","K", + & 2,zxtsol) + zx_tmp_fi2d(:) = rain_fall(:) + snow_fall(:) + call wstats(klon,o_precip%name,"Precip Totale liq+sol", + & "kg/(s*m2)",2,zx_tmp_fi2d) + zx_tmp_fi2d(:) = rain_lsc(:) + snow_lsc(:) + call wstats(klon,o_plul%name,"Large-scale Precip", + & "kg/(s*m2)",2,zx_tmp_fi2d) + zx_tmp_fi2d(:) = rain_con(:) + snow_con(:) + call wstats(klon,o_pluc%name,"Convective Precip", + & "kg/(s*m2)",2,zx_tmp_fi2d) + call wstats(klon,o_sols%name,"Solar rad. at surf.", + & "W/m2",2,solsw) + call wstats(klon,o_soll%name,"IR rad. at surf.", + & "W/m2",2,sollw) + zx_tmp_fi2d(:) = topsw(:)-toplw(:) + call wstats(klon,o_nettop%name,"Net dn radiatif flux at TOA", + & "W/m2",2,zx_tmp_fi2d) + + + + call wstats(klon,o_temp%name,"Air temperature","K", + & 3,t_seri) + call wstats(klon,o_vitu%name,"Zonal wind","m.s-1", + & 3,u_seri) + call wstats(klon,o_vitv%name,"Meridional wind", + & "m.s-1",3,v_seri) + call wstats(klon,o_vitw%name,"Vertical wind", + & "m.s-1",3,omega) + call wstats(klon,o_ovap%name,"Specific humidity", "kg/kg", + & 3,q_seri) + + + + IF(lafin) THEN + write (*,*) "Writing stats..." + call mkstats(ierr) + ENDIF + + ENDIF !if callstats + + + IF (lafin) THEN + itau_phy = itau_phy + itap + CALL phyredem ("restartphy.nc") +! open(97,form="unformatted",file="finbin") +! write(97) u_seri,v_seri,t_seri,q_seri +! close(97) +C$OMP MASTER + if (read_climoz >= 1) then + if (is_mpi_root) then + call nf95_close(ncid_climoz) + end if + deallocate(press_climoz) ! pointer + end if +C$OMP END MASTER + ENDIF + +! first=.false. + + RETURN + END + FUNCTION qcheck(klon,klev,paprs,q,ql,aire) + IMPLICIT none +c +c Calculer et imprimer l'eau totale. A utiliser pour verifier +c la conservation de l'eau +c +#include "YOMCST.h" + INTEGER klon,klev + REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev) + REAL aire(klon) + REAL qtotal, zx, qcheck + INTEGER i, k +c + zx = 0.0 + DO i = 1, klon + zx = zx + aire(i) + ENDDO + qtotal = 0.0 + DO k = 1, klev + DO i = 1, klon + qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i) + . *(paprs(i,k)-paprs(i,k+1))/RG + ENDDO + ENDDO +c + qcheck = qtotal/zx +c + RETURN + END + SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit) + IMPLICIT none +c +c Tranformer une variable de la grille physique a +c la grille d'ecriture +c + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield) +c + INTEGER i, n, ig +c + jjm = jjmp1 - 1 + DO n = 1, nfield + DO i=1,iim + ecrit(i,n) = fi(1,n) + ecrit(i+jjm*iim,n) = fi(nlon,n) + ENDDO + DO ig = 1, nlon - 2 + ecrit(iim+ig,n) = fi(1+ig,n) + ENDDO + ENDDO + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phystokenc.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phystokenc.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phystokenc.F90 (revision 1634) @@ -0,0 +1,363 @@ +SUBROUTINE phystokenc (nlon,nlev,pdtphys,rlon,rlat, & + pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & + pfm_therm,pentr_therm, & + cdragh, pcoefh,yu1,yv1,ftsol,pctsrf, & + frac_impa,frac_nucl, & + pphis,paire,dtime,itap, & + psh, pda, pphi, pmp, pupwd, pdnwd) + + USE ioipsl + USE dimphy + USE infotrac, ONLY : nqtot + USE iophy + USE control_mod + + IMPLICIT NONE + +!====================================================================== +! Auteur(s) FH +! Objet: Ecriture des variables pour transport offline +! +!====================================================================== + INCLUDE "dimensions.h" + INCLUDE "tracstoke.h" + INCLUDE "indicesol.h" + INCLUDE "iniprint.h" +!====================================================================== + +! Arguments: +! + REAL,DIMENSION(klon,klev), INTENT(IN) :: psh ! humidite specifique + REAL,DIMENSION(klon,klev), INTENT(IN) :: pda + REAL,DIMENSION(klon,klev,klev), INTENT(IN):: pphi + REAL,DIMENSION(klon,klev), INTENT(IN) :: pmp + REAL,DIMENSION(klon,klev), INTENT(IN) :: pupwd ! saturated updraft mass flux + REAL,DIMENSION(klon,klev), INTENT(IN) :: pdnwd ! saturated downdraft mass flux + +! EN ENTREE: +! ========== +! +! divers: +! ------- +! + INTEGER nlon ! nombre de points horizontaux + INTEGER nlev ! nombre de couches verticales + REAL pdtphys ! pas d'integration pour la physique (seconde) + INTEGER itap + INTEGER, SAVE :: physid +!$OMP THREADPRIVATE(physid) + +! convection: +! ----------- +! + REAL pmfu(klon,klev) ! flux de masse dans le panache montant + REAL pmfd(klon,klev) ! flux de masse dans le panache descendant + REAL pen_u(klon,klev) ! flux entraine dans le panache montant + REAL pde_u(klon,klev) ! flux detraine dans le panache montant + REAL pen_d(klon,klev) ! flux entraine dans le panache descendant + REAL pde_d(klon,klev) ! flux detraine dans le panache descendant + REAL pt(klon,klev) + REAL,ALLOCATABLE,SAVE :: t(:,:) +!$OMP THREADPRIVATE(t) +! + REAL rlon(klon), rlat(klon), dtime + REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1) + +! Couche limite: +! -------------- +! + REAL cdragh(klon) ! cdrag + REAL pcoefh(klon,klev) ! coeff melange CL + REAL pcoefh_buf(klon,klev) ! coeff melange CL + cdrag + REAL yv1(klon) + REAL yu1(klon),pphis(klon),paire(klon) + +! Les Thermiques : (Abderr 25 11 02) +! --------------- + REAL, INTENT(IN) :: pfm_therm(klon,klev+1) + REAL pentr_therm(klon,klev) + + REAL,ALLOCATABLE,SAVE :: entr_therm(:,:) + REAL,ALLOCATABLE,SAVE :: fm_therm(:,:) +!$OMP THREADPRIVATE(entr_therm) +!$OMP THREADPRIVATE(fm_therm) +! +! Lessivage: +! ---------- +! + REAL frac_impa(klon,klev) + REAL frac_nucl(klon,klev) +! +! Arguments necessaires pour les sources et puits de traceur +! + REAL ftsol(klon,nbsrf) ! Temperature du sol (surf)(Kelvin) + REAL pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol) +!====================================================================== +! + INTEGER i, k, kk + REAL,ALLOCATABLE,SAVE :: mfu(:,:) ! flux de masse dans le panache montant + REAL,ALLOCATABLE,SAVE :: mfd(:,:) ! flux de masse dans le panache descendant + REAL,ALLOCATABLE,SAVE :: en_u(:,:) ! flux entraine dans le panache montant + REAL,ALLOCATABLE,SAVE :: de_u(:,:) ! flux detraine dans le panache montant + REAL,ALLOCATABLE,SAVE :: en_d(:,:) ! flux entraine dans le panache descendant + REAL,ALLOCATABLE,SAVE :: de_d(:,:) ! flux detraine dans le panache descendant + REAL,ALLOCATABLE,SAVE :: coefh(:,:) ! flux detraine dans le panache descendant + + REAL,ALLOCATABLE,SAVE :: pyu1(:) + REAL,ALLOCATABLE,SAVE :: pyv1(:) + REAL,ALLOCATABLE,SAVE :: pftsol(:,:) + REAL,ALLOCATABLE,SAVE :: ppsrf(:,:) +!$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh) +!$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf) + + + REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: sh + REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: da + REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: phi + REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: mp + REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: upwd + REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: dnwd + + REAL, SAVE :: dtcum + INTEGER, SAVE:: iadvtr=0 +!$OMP THREADPRIVATE(dtcum,iadvtr) + REAL zmin,zmax + LOGICAL ok_sync + CHARACTER(len=12) :: nvar + logical, parameter :: lstokenc=.FALSE. +! +!====================================================================== + + iadvtr=iadvtr+1 + +! Dans le meme vecteur on recombine le drag et les coeff d'echange + pcoefh_buf(:,1) = cdragh(:) + pcoefh_buf(:,2:klev) = pcoefh(:,2:klev) + + ok_sync = .TRUE. + +! Initialization done only once +!====================================================================== + IF (iadvtr==1) THEN + ALLOCATE( t(klon,klev)) + ALLOCATE( mfu(klon,klev)) + ALLOCATE( mfd(klon,klev)) + ALLOCATE( en_u(klon,klev)) + ALLOCATE( de_u(klon,klev)) + ALLOCATE( en_d(klon,klev)) + ALLOCATE( de_d(klon,klev)) + ALLOCATE( coefh(klon,klev)) + ALLOCATE( entr_therm(klon,klev)) + ALLOCATE( fm_therm(klon,klev)) + ALLOCATE( pyu1(klon)) + ALLOCATE( pyv1(klon)) + ALLOCATE( pftsol(klon,nbsrf)) + ALLOCATE( ppsrf(klon,nbsrf)) + + ALLOCATE(sh(klon,klev)) + ALLOCATE(da(klon,klev)) + ALLOCATE(phi(klon,klev,klev)) + ALLOCATE(mp(klon,klev)) + ALLOCATE(upwd(klon,klev)) + ALLOCATE(dnwd(klon,klev)) + + CALL initphysto('phystoke', dtime, dtime*istphy,dtime*istphy,physid) + + ! Write field phis and aire only once + CALL histwrite_phy(physid,lstokenc,"phis",itap,pphis) + CALL histwrite_phy(physid,lstokenc,"aire",itap,paire) + CALL histwrite_phy(physid,lstokenc,"longitudes",itap,rlon) + CALL histwrite_phy(physid,lstokenc,"latitudes",itap,rlat) + + END IF + + +! Set to zero cumulating fields +!====================================================================== + IF (MOD(iadvtr,istphy)==1.OR.istphy==1) THEN + WRITE(lunout,*)'reinitialisation des champs cumules a iadvtr=',iadvtr + mfu(:,:)=0. + mfd(:,:)=0. + en_u(:,:)=0. + de_u(:,:)=0. + en_d(:,:)=0. + de_d(:,:)=0. + coefh(:,:)=0. + t(:,:)=0. + fm_therm(:,:)=0. + entr_therm(:,:)=0. + pyv1(:)=0. + pyu1(:)=0. + pftsol(:,:)=0. + ppsrf(:,:)=0. + sh(:,:)=0. + da(:,:)=0. + phi(:,:,:)=0. + mp(:,:)=0. + upwd(:,:)=0. + dnwd(:,:)=0. + dtcum=0. + ENDIF + + +! Cumulate fields at each time step +!====================================================================== + DO k=1,klev + DO i=1,klon + mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys + mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys + en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys + de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys + en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys + de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys + coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys + t(i,k)=t(i,k)+pt(i,k)*pdtphys + fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys + entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys + sh(i,k) = sh(i,k) + psh(i,k)*pdtphys + da(i,k) = da(i,k) + pda(i,k)*pdtphys + mp(i,k) = mp(i,k) + pmp(i,k)*pdtphys + upwd(i,k) = upwd(i,k) + pupwd(i,k)*pdtphys + dnwd(i,k) = dnwd(i,k) + pdnwd(i,k)*pdtphys + ENDDO + ENDDO + + DO kk=1,klev + DO k=1,klev + DO i=1,klon + phi(i,k,kk) = phi(i,k,kk) + pphi(i,k,kk)*pdtphys + END DO + END DO + END DO + + DO i=1,klon + pyv1(i)=pyv1(i)+yv1(i)*pdtphys + pyu1(i)=pyu1(i)+yu1(i)*pdtphys + END DO + DO k=1,nbsrf + DO i=1,klon + pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys + ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys + ENDDO + ENDDO + +! Add time step to cumulated time + dtcum=dtcum+pdtphys + + +! Write fields to file, if it is time to do so +!====================================================================== + IF(MOD(iadvtr,istphy)==0) THEN + + ! normalize with time period + DO k=1,klev + DO i=1,klon + mfu(i,k)=mfu(i,k)/dtcum + mfd(i,k)=mfd(i,k)/dtcum + en_u(i,k)=en_u(i,k)/dtcum + de_u(i,k)=de_u(i,k)/dtcum + en_d(i,k)=en_d(i,k)/dtcum + de_d(i,k)=de_d(i,k)/dtcum + coefh(i,k)=coefh(i,k)/dtcum + t(i,k)=t(i,k)/dtcum + fm_therm(i,k)=fm_therm(i,k)/dtcum + entr_therm(i,k)=entr_therm(i,k)/dtcum + sh(i,k)=sh(i,k)/dtcum + da(i,k)=da(i,k)/dtcum + mp(i,k)=mp(i,k)/dtcum + upwd(i,k)=upwd(i,k)/dtcum + dnwd(i,k)=dnwd(i,k)/dtcum + ENDDO + ENDDO + DO kk=1,klev + DO k=1,klev + DO i=1,klon + phi(i,k,kk) = phi(i,k,kk)/dtcum + END DO + END DO + END DO + DO i=1,klon + pyv1(i)=pyv1(i)/dtcum + pyu1(i)=pyu1(i)/dtcum + END DO + DO k=1,nbsrf + DO i=1,klon + pftsol(i,k)=pftsol(i,k)/dtcum + ppsrf(i,k)=ppsrf(i,k)/dtcum + ENDDO + ENDDO + + ! write fields + CALL histwrite_phy(physid,lstokenc,"t",itap,t) + CALL histwrite_phy(physid,lstokenc,"mfu",itap,mfu) + CALL histwrite_phy(physid,lstokenc,"mfd",itap,mfd) + CALL histwrite_phy(physid,lstokenc,"en_u",itap,en_u) + CALL histwrite_phy(physid,lstokenc,"de_u",itap,de_u) + CALL histwrite_phy(physid,lstokenc,"en_d",itap,en_d) + CALL histwrite_phy(physid,lstokenc,"de_d",itap,de_d) + CALL histwrite_phy(physid,lstokenc,"coefh",itap,coefh) + CALL histwrite_phy(physid,lstokenc,"fm_th",itap,fm_therm) + CALL histwrite_phy(physid,lstokenc,"en_th",itap,entr_therm) + CALL histwrite_phy(physid,lstokenc,"frac_impa",itap,frac_impa) + CALL histwrite_phy(physid,lstokenc,"frac_nucl",itap,frac_nucl) + CALL histwrite_phy(physid,lstokenc,"pyu1",itap,pyu1) + CALL histwrite_phy(physid,lstokenc,"pyv1",itap,pyv1) + CALL histwrite_phy(physid,lstokenc,"ftsol1",itap,pftsol(:,1)) + CALL histwrite_phy(physid,lstokenc,"ftsol2",itap,pftsol(:,2)) + CALL histwrite_phy(physid,lstokenc,"ftsol3",itap,pftsol(:,3)) + CALL histwrite_phy(physid,lstokenc,"ftsol4",itap,pftsol(:,4)) + CALL histwrite_phy(physid,lstokenc,"psrf1",itap,ppsrf(:,1)) + CALL histwrite_phy(physid,lstokenc,"psrf2",itap,ppsrf(:,2)) + CALL histwrite_phy(physid,lstokenc,"psrf3",itap,ppsrf(:,3)) + CALL histwrite_phy(physid,lstokenc,"psrf4",itap,ppsrf(:,4)) + CALL histwrite_phy(physid,lstokenc,"sh",itap,sh) + CALL histwrite_phy(physid,lstokenc,"da",itap,da) + CALL histwrite_phy(physid,lstokenc,"mp",itap,mp) + CALL histwrite_phy(physid,lstokenc,"upwd",itap,upwd) + CALL histwrite_phy(physid,lstokenc,"dnwd",itap,dnwd) + + +! phi + DO k=1,klev + IF (k<10) THEN + WRITE(nvar,'(i1)') k + ELSE IF (k<100) THEN + WRITE(nvar,'(i2)') k + ELSE + WRITE(nvar,'(i3)') k + END IF + nvar='phi_lev'//trim(nvar) + + CALL histwrite_phy(physid,lstokenc,nvar,itap,phi(:,:,k)) + END DO + + ! Syncronize file +!$OMP MASTER + IF (ok_sync) CALL histsync(physid) +!$OMP END MASTER + + + ! Calculate min and max values for some fields (coefficients de lessivage) + zmin=1e33 + zmax=-1e33 + DO k=1,klev + DO i=1,klon + zmax=MAX(zmax,frac_nucl(i,k)) + zmin=MIN(zmin,frac_nucl(i,k)) + ENDDO + ENDDO + WRITE(lunout,*)'------ coefs de lessivage (min et max) --------' + WRITE(lunout,*)'facteur de nucleation ',zmin,zmax + zmin=1e33 + zmax=-1e33 + DO k=1,klev + DO i=1,klon + zmax=MAX(zmax,frac_impa(i,k)) + zmin=MIN(zmin,frac_impa(i,k)) + ENDDO + ENDDO + WRITE(lunout,*)'facteur d impaction ',zmin,zmax + + ENDIF ! IF(MOD(iadvtr,istphy)==0) + +END SUBROUTINE phystokenc Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phytrac.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phytrac.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/phytrac.F90 (revision 1634) @@ -0,0 +1,408 @@ +!$Id $ + +SUBROUTINE phytrac( & + nstep, julien, gmtime, debutphy, & + lafin, pdtphys, u, v, t_seri, & + paprs, pplay, pmfu, pmfd, & + pen_u, pde_u, pen_d, pde_d, & + cdragh, coefh, fm_therm, entr_therm,& + yu1, yv1, ftsol, pctsrf, & + xlat, frac_impa,frac_nucl,xlon, & + presnivs, pphis, pphi, albsol, & + sh, rh, cldfra, rneb, & + diafra, cldliq, itop_con, ibas_con, & + pmflxr, pmflxs, prfl, psfl, & + da, phi, mp, upwd, & + dnwd, aerosol_couple, flxmass_w, & + tau_aero, piz_aero, cg_aero, ccm, & + rfname, & + tr_seri) +! +!====================================================================== +! Auteur(s) FH +! Objet: Moniteur general des tendances traceurs +!====================================================================== + + USE ioipsl + USE dimphy + USE infotrac + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE comgeomphy + USE iophy + USE traclmdz_mod + USE tracinca_mod + USE control_mod + + + + IMPLICIT NONE + + INCLUDE "YOMCST.h" + INCLUDE "dimensions.h" + INCLUDE "indicesol.h" + INCLUDE "clesphys.h" + INCLUDE "temps.h" + INCLUDE "paramet.h" + INCLUDE "thermcell.h" +!========================================================================== +! -- ARGUMENT DESCRIPTION -- +!========================================================================== + +! Input arguments +!---------------- +!Configuration grille,temps: + INTEGER,INTENT(IN) :: nstep ! Appel physique + INTEGER,INTENT(IN) :: julien ! Jour julien + REAL,INTENT(IN) :: gmtime + REAL,INTENT(IN) :: pdtphys ! Pas d'integration pour la physique (seconde) + LOGICAL,INTENT(IN) :: debutphy ! le flag de l'initialisation de la physique + LOGICAL,INTENT(IN) :: lafin ! le flag de la fin de la physique + + REAL,DIMENSION(klon),INTENT(IN) :: xlat ! latitudes pour chaque point + REAL,DIMENSION(klon),INTENT(IN) :: xlon ! longitudes pour chaque point +! +!Physique: +!-------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: t_seri ! Temperature + REAL,DIMENSION(klon,klev),INTENT(IN) :: u ! variable not used + REAL,DIMENSION(klon,klev),INTENT(IN) :: v ! variable not used + REAL,DIMENSION(klon,klev),INTENT(IN) :: sh ! humidite specifique + REAL,DIMENSION(klon,klev),INTENT(IN) :: rh ! humidite relative + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression pour chaque inter-couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le mileu de chaque couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pphi ! geopotentiel + REAL,DIMENSION(klon),INTENT(IN) :: pphis + REAL,DIMENSION(klev),INTENT(IN) :: presnivs + REAL,DIMENSION(klon,klev),INTENT(IN) :: cldliq ! eau liquide nuageuse + REAL,DIMENSION(klon,klev),INTENT(IN) :: cldfra ! fraction nuageuse (tous les nuages) + REAL,DIMENSION(klon,klev),INTENT(IN) :: diafra ! fraction nuageuse (convection ou stratus artificiels) + REAL,DIMENSION(klon,klev),INTENT(IN) :: rneb ! fraction nuageuse (grande echelle) + INTEGER,DIMENSION(klon),INTENT(IN) :: itop_con + INTEGER,DIMENSION(klon),INTENT(IN) :: ibas_con + REAL,DIMENSION(klon),INTENT(IN) :: albsol ! albedo surface +! +!Convection: +!---------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu ! flux de masse dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd ! flux de masse dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant + REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant + +!...Tiedke + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection] + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale] + + LOGICAL,INTENT(IN) :: aerosol_couple + REAL,DIMENSION(klon,klev),INTENT(IN) :: flxmass_w + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: tau_aero + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: piz_aero + REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: cg_aero + CHARACTER(len=4),DIMENSION(9),INTENT(IN) :: rfname + REAL,DIMENSION(klon,klev,2),INTENT(IN) :: ccm +!... K.Emanuel + REAL,DIMENSION(klon,klev),INTENT(IN) :: da + REAL,DIMENSION(klon,klev,klev),INTENT(IN):: phi + REAL,DIMENSION(klon,klev),INTENT(IN) :: mp + REAL,DIMENSION(klon,klev),INTENT(IN) :: upwd ! saturated updraft mass flux + REAL,DIMENSION(klon,klev),INTENT(IN) :: dnwd ! saturated downdraft mass flux +! +!Thermiques: +!---------- + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: fm_therm + REAL,DIMENSION(klon,klev),INTENT(IN) :: entr_therm +! +!Couche limite: +!-------------- +! + REAL,DIMENSION(klon),INTENT(IN) :: cdragh ! coeff drag pour T et Q + REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh ! coeff melange CL (m**2/s) + REAL,DIMENSION(klon),INTENT(IN) :: yu1 ! vents au premier niveau + REAL,DIMENSION(klon),INTENT(IN) :: yv1 ! vents au premier niveau +! +!Lessivage: +!---------- +! +! pour le ON-LINE +! + REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_impa ! fraction d'aerosols non impactes + REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_nucl ! fraction d'aerosols non nuclees + +! Arguments necessaires pour les sources et puits de traceur: + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol ! Temperature du sol (surf)(Kelvin) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol (nature du sol) + + +! Output argument +!---------------- + REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA] + +!======================================================================================= +! -- LOCAL VARIABLES -- +!======================================================================================= + + INTEGER :: i, k, it + INTEGER :: nsplit + +!Sources et Reservoirs de traceurs (ex:Radon): +!-------------------------------------------- +! + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: source ! a voir lorsque le flux de surface est prescrit +!$OMP THREADPRIVATE(source) + +! +!Entrees/Sorties: (cf ini_histrac.h et write_histrac.h) +!--------------- + INTEGER :: iiq, ierr + INTEGER :: nhori, nvert + REAL :: zsto, zout, zjulian + INTEGER,SAVE :: nid_tra ! pointe vers le fichier histrac.nc +!$OMP THREADPRIVATE(nid_tra) + REAL,DIMENSION(klon) :: zx_tmp_fi2d ! variable temporaire grille physique + INTEGER :: itau_w ! pas de temps ecriture = nstep + itau_phy + LOGICAL,PARAMETER :: ok_sync=.TRUE. + +! +! Nature du traceur +!------------------ + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: aerosol ! aerosol(it) = true => aerosol => lessivage +!$OMP THREADPRIVATE(aerosol) ! aerosol(it) = false => gaz + REAL,DIMENSION(klon,klev) :: delp ! epaisseur de couche (Pa) +! +! Tendances de traceurs (Td): +!------------------------ +! + REAL,DIMENSION(klon,klev) :: d_tr ! Td dans l'atmosphere + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_cl ! Td couche limite/traceur + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_cv ! Td convection/traceur + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_th ! Td thermique + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_lessi_impa ! Td du lessivage par impaction + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_lessi_nucl ! Td du lessivage par nucleation +! +! Physique +!---------- + REAL,DIMENSION(klon,klev,nbtr) :: flestottr ! flux de lessivage dans chaque couche + REAL,DIMENSION(klon,klev) :: zmasse ! densité atmosphérique Kg/m2 + REAL,DIMENSION(klon,klev) :: ztra_th + +!Controles: +!--------- + LOGICAL,SAVE :: couchelimite=.TRUE. + LOGICAL,SAVE :: convection=.TRUE. + LOGICAL,SAVE :: lessivage +!$OMP THREADPRIVATE(couchelimite,convection,lessivage) + + CHARACTER(len=8),DIMENSION(nbtr) :: solsym + + +!###################################################################### +! -- INITIALIZATION -- +!###################################################################### + IF (debutphy) THEN + WRITE(*,*) 'FIRST TIME IN PHYTRAC : pdtphys(sec) = ',pdtphys,'ecrit_tra (sec) = ',ecrit_tra + ALLOCATE( source(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('phytrac', 'pb in allocation 1',1) + + ALLOCATE( aerosol(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('phytrac', 'pb in allocation 2',1) + + + ! Initialize module for specific tracers + SELECT CASE(type_trac) + CASE('lmdz') + CALL traclmdz_init(pctsrf, ftsol, tr_seri, t_seri, pplay, sh, pdtphys, aerosol, lessivage) + CASE('inca') + source(:,:)=0. + CALL tracinca_init(aerosol,lessivage) + END SELECT +! +! Initialize diagnostic output +! ---------------------------- +#ifdef CPP_IOIPSL +! INCLUDE "ini_histrac.h" +#endif + END IF +!############################################ END INITIALIZATION ####### + + DO k=1,klev + DO i=1,klon + zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg + END DO + END DO + +!=============================================================================== +! -- Do specific treatment according to chemestry model or local LMDZ tracers +! +!=============================================================================== + SELECT CASE(type_trac) + CASE('lmdz') + ! -- Traitement des traceurs avec traclmdz + CALL traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, & + cdragh, coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon, couchelimite, & + sh, tr_seri, source, solsym, d_tr_cl, zmasse) + CASE('inca') + ! -- CHIMIE INCA config_inca = aero or chem -- + + CALL tracinca(& + nstep, julien, gmtime, lafin, & + pdtphys, t_seri, paprs, pplay, & + pmfu, ftsol, pctsrf, pphis, & + pphi, albsol, sh, rh, & + cldfra, rneb, diafra, cldliq, & + itop_con, ibas_con, pmflxr, pmflxs, & + prfl, psfl, aerosol_couple, flxmass_w, & + tau_aero, piz_aero, cg_aero, ccm, & + rfname, & + tr_seri, source, solsym) + END SELECT + +!====================================================================== +! -- Calcul de l'effet de la convection -- +!====================================================================== + IF (convection) THEN + DO it=1, nbtr + IF ( conv_flg(it) == 0 ) CYCLE + + IF (iflag_con.LT.2) THEN + d_tr_cv(:,:,:)=0. + ELSE IF (iflag_con.EQ.2) THEN +!..Tiedke + CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & + pplay, paprs, tr_seri(:,:,it), d_tr_cv(:,:,it)) + ELSE +!..K.Emanuel + CALL cvltr(pdtphys, da, phi, mp, paprs,pplay, tr_seri(:,:,it),& + upwd,dnwd,d_tr_cv(:,:,it)) + END IF + + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it) + END DO + END DO + + CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//solsym(it)) + + END DO ! nbtr + END IF ! convection + +!====================================================================== +! -- Calcul de l'effet des thermiques -- +!====================================================================== + + DO it=1,nbtr + DO k=1,klev + DO i=1,klon + d_tr_th(i,k,it)=0. + tr_seri(i,k,it)=MAX(tr_seri(i,k,it),0.) + tr_seri(i,k,it)=MIN(tr_seri(i,k,it),1.e10) + END DO + END DO + END DO + + IF (iflag_thermals.GT.0) THEN + nsplit=10 + DO it=1, nbtr + DO isplit=1,nsplit + + CALL dqthermcell(klon,klev,pdtphys/nsplit, & + fm_therm,entr_therm,zmasse, & + tr_seri(1:klon,1:klev,it),d_tr,ztra_th) + + DO k=1,klev + DO i=1,klon + d_tr(i,k)=pdtphys*d_tr(i,k)/nsplit + d_tr_th(i,k,it)=d_tr_th(i,k,it)+d_tr(i,k) + tr_seri(i,k,it)=MAX(tr_seri(i,k,it)+d_tr(i,k),0.) + END DO + END DO + END DO ! nsplit + END DO ! it + END IF ! Thermiques + +!====================================================================== +! -- Calcul de l'effet de la couche limite -- +!====================================================================== + + IF (couchelimite) THEN + + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k)-paprs(i,k+1) + END DO + END DO + + DO it=1, nbtr + + IF( pbl_flg(it) /= 0 ) THEN + + CALL cltrac(pdtphys, coefh,t_seri, & + tr_seri(:,:,it), source(:,it), & + paprs, pplay, delp, & + d_tr_cl(:,:,it)) + + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it) + END DO + END DO + END IF + + END DO + + END IF ! couche limite + + +!====================================================================== +! Calcul de l'effet de la precipitation +!====================================================================== + + IF (lessivage) THEN + + d_tr_lessi_nucl(:,:,:) = 0. + d_tr_lessi_impa(:,:,:) = 0. + flestottr(:,:,:) = 0. +!========================= +! LESSIVAGE LARGE SCALE : +!========================= + +! Tendance des aerosols nuclees et impactes +! ----------------------------------------- + DO it = 1, nbtr + IF (aerosol(it)) THEN + DO k = 1, klev + DO i = 1, klon + d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) + & + ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it) + d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) + & + ( 1 - frac_impa(i,k) )*tr_seri(i,k,it) + +! +! Flux lessivage total +! ------------------------------------------------------------ + flestottr(i,k,it) = flestottr(i,k,it) - & + ( d_tr_lessi_nucl(i,k,it) + & + d_tr_lessi_impa(i,k,it) ) * & + ( paprs(i,k)-paprs(i,k+1) ) / & + (RG * pdtphys) +! +! Mise a jour des traceurs due a l'impaction,nucleation +! ---------------------------------------------------------------------- + tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k) + END DO + END DO + END IF + END DO + + END IF ! lessivage + +!============================================================= +! Ecriture des sorties +!============================================================= +#ifdef CPP_IOIPSL +! INCLUDE "write_histrac.h" +#endif + +END SUBROUTINE phytrac Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/planete.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/planete.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/planete.h (revision 1634) @@ -0,0 +1,13 @@ +c----------------------------------------------------------------------- +c INCLUDE planet.h + + COMMON/planet/aphelie,periheli,year_day,peri_day, & + & obliquit, & + & timeperi,e_elips,p_elips,unitastr + + REAL aphelie,periheli,year_day,peri_day, & + & obliquit, & + & timeperi,e_elips,p_elips,unitastr + +c----------------------------------------------------------------------- +!$OMP THREADPRIVATE(/planet/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/plevel.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/plevel.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/plevel.F (revision 1634) @@ -0,0 +1,132 @@ +! +! $Header$ +! +c================================================================ +c================================================================ + SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + USE netcdf + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cy#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- + +cym INTEGER lt(klon), lb(klon) +cym REAL ptop, pbot, aist(klon), aisb(klon) + +cym save lt,lb,ptop,pbot,aist,aisb + INTEGER,ALLOCATABLE,SAVE,DIMENSION(:) :: lt,lb + REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: aist,aisb +c$OMP THREADPRIVATE(lt,lb,aist,aisb) + REAL,SAVE :: ptop, pbot +c$OMP THREADPRIVATE(ptop, pbot) + LOGICAL,SAVE :: first = .true. +c$OMP THREADPRIVATE(first) + INTEGER i, k +c + REAL missing_val +c + missing_val=nf90_fill_real +c + if (first) then + allocate(lt(klon),lb(klon),aist(klon),aisb(klon)) + first=.false. + endif + +c===================================================================== + if (lnew) then +c on r�nitialise les r�ndicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, klon + IF ( ABS(pres-pgcm(i,ilev) ) .LT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, klon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) + IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, klon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Fr��ic Hourdin (3/01/02) + + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,klon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, klon + if (pgcm(i,1).LT.pres) THEN + Qpres(i)=missing_val + endif + enddo + +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/plevel_new.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/plevel_new.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/plevel_new.F (revision 1634) @@ -0,0 +1,138 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17 15:41:51 fairhead Exp $ +! +c================================================================ +c================================================================ + SUBROUTINE plevel_new(ilon,ilev,klevSTD,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + USE netcdf + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cy#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev, klevSTD + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres(klevSTD) + REAL Qpres(ilon, klevSTD) + +c local : +c ------- + +cym INTEGER lt(klon), lb(klon) +cym REAL ptop, pbot, aist(klon), aisb(klon) + +cym save lt,lb,ptop,pbot,aist,aisb + INTEGER,ALLOCATABLE,SAVE,DIMENSION(:,:) :: lt,lb + REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: aist,aisb +c$OMP THREADPRIVATE(lt,lb,aist,aisb) + REAL,SAVE :: ptop, pbot +c$OMP THREADPRIVATE(ptop, pbot) + LOGICAL,SAVE :: first = .true. + INTEGER :: nlev +c$OMP THREADPRIVATE(first) + INTEGER i, k +c + REAL missing_val +c + missing_val=nf90_fill_real +c + if (first) then + allocate(lt(klon,klevSTD),lb(klon,klevSTD)) + allocate(aist(klon,klevSTD),aisb(klon, klevSTD)) + first=.false. + endif + +c===================================================================== + if (lnew) then +c on reinitialise les reindicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: +c +c + DO nlev = 1, klevSTD + DO i = 1, klon + IF ( ABS(pres(nlev)-pgcm(i,ilev) ) .LT. + & ABS(pres(nlev)-pgcm(i,1)) ) THEN + lt(i,nlev) = ilev ! 2 + lb(i,nlev) = ilev-1 ! 1 + ELSE + lt(i,nlev) = 2 + lb(i,nlev) = 1 + ENDIF + ENDDO + DO k = 1, ilev-1 + DO i = 1, klon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) + IF (ptop.LE.pres(nlev) .AND. pbot.GE.pres(nlev)) THEN + lt(i,nlev) = k+1 + lb(i,nlev) = k + ENDIF + ENDDO + ENDDO + +c Interpolation lineaire: + DO i = 1, klon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Frederic Hourdin (3/01/02) + + aist(i,nlev) = LOG( pgcm(i,lb(i,nlev))/ pres(nlev) ) + & / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev)) ) + aisb(i,nlev) = LOG( pres(nlev) / pgcm(i,lt(i,nlev)) ) + & / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev))) + ENDDO + ENDDO + + ENDIF ! lnew + +c====================================================================== +c inteprollation +c ET je mets les vents a zero quand je rencontre une montagne +c====================================================================== + + DO nlev = 1, klevSTD + DO i=1,klon + IF (pgcm(i,1).LT.pres(nlev)) THEN + Qpres(i,nlev) = missing_val + ELSE + Qpres(i,nlev) = + & Qgcm(i,lb(i,nlev))*aisb(i,nlev) + + & Qgcm(i,lt(i,nlev))*aist(i,nlev) + ENDIF + ENDDO + ENDDO + +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/press_coefoz_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/press_coefoz_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/press_coefoz_m.F90 (revision 1634) @@ -0,0 +1,72 @@ +! $Id$ +module press_coefoz_m + + implicit none + + real, pointer, save:: plev(:) + ! (pressure level of Mobidic input data, converted to Pa, in strictly + ! ascending order) + + real, allocatable, save:: press_in_edg(:) + ! (edges of pressure intervals for Mobidic input data, in Pa, in strictly + ! ascending order) + +contains + + subroutine press_coefoz + + ! This procedure is called once per "gcm" run. + ! A single thread of the root process reads the pressure levels + ! from "coefoz_LMDZ.nc" and broadcasts them to the other processes. + + ! We assume that, in "coefoz_LMDZ.nc", the pressure levels are in hPa + ! and in strictly ascending order. + + use netcdf95, only: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid + use netcdf, only: nf90_nowrite + + use mod_phys_lmdz_mpi_data, only: is_mpi_root + use mod_phys_lmdz_mpi_transfert, only: bcast_mpi ! broadcast + + ! Variables local to the procedure: + integer ncid, varid ! for NetCDF + integer n_plev ! number of pressure levels in the input data + integer k + + !--------------------------------------- + + !$omp single + print *, "Call sequence information: press_coefoz" + + if (is_mpi_root) then + call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid) + + call nf95_inq_varid(ncid, "plev", varid) + call nf95_gw_var(ncid, varid, plev) + ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa: + plev = plev * 100. + n_plev = size(plev) + + call nf95_close(ncid) + end if + + call bcast_mpi(n_plev) + if (.not. is_mpi_root) allocate(plev(n_plev)) + call bcast_mpi(plev) + + ! Compute edges of pressure intervals: + allocate(press_in_edg(n_plev + 1)) + if (is_mpi_root) then + press_in_edg(1) = 0. + ! We choose edges halfway in logarithm: + forall (k = 2:n_plev) press_in_edg(k) = sqrt(plev(k - 1) * plev(k)) + press_in_edg(n_plev + 1) = huge(0.) + ! (infinity, but any value guaranteed to be greater than the + ! surface pressure would do) + end if + call bcast_mpi(press_in_edg) + !$omp end single + + end subroutine press_coefoz + +end module press_coefoz_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/print_debug_phys.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/print_debug_phys.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/print_debug_phys.F90 (revision 1634) @@ -0,0 +1,20 @@ +SUBROUTINE print_debug_phys (i,debug_lev,text) + +use dimphy +use phys_local_var_mod +use phys_state_var_mod +IMPLICIT NONE +integer i,debug_lev +CHARACTER*(*) text + + +integer k + +print*,'PLANTAGE POUR LE POINT i=',i,text +print*,'l u, v, T, q, ql' +DO k = 1, klev + write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,rlon(i),rlat(i),u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k) +ENDDO + +RETURN +END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/printflag.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/printflag.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/printflag.F (revision 1634) @@ -0,0 +1,183 @@ +! +! $Header$ +! + SUBROUTINE printflag( tabcntr0, radpas, + , ok_journe,ok_instan,ok_region ) +c + +c +c Auteur : P. Le Van + + IMPLICIT NONE + + REAL tabcntr0( 100 ) + LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0 + LOGICAL ok_orolf0,ok_limitvr0 + LOGICAL ok_journe,ok_instan,ok_region + INTEGER radpas , radpas0 +c +#include "clesphys.h" +c +c + PRINT 100 + PRINT *,' ******************************************************* + ,************' + PRINT *,' ******** Choix des principales cles de la physique + , *********' + PRINT *,' ******************************************************* + ,************' + PRINT 100 + PRINT 10, cycle_diurne, soil_model + PRINT 100 + + IF ( iflag_con.EQ. 1 ) THEN + PRINT *,' ***** Shema convection LMD + , ******' + ELSE IF ( iflag_con.EQ. 2 ) THEN + PRINT *,' ***** Shema convection Tiedtke + , ******' + ELSE IF ( iflag_con.GE. 3 ) THEN + PRINT *,' ***** Shema convection Emanuel + , ******' + ENDIF + PRINT 100 + + PRINT 11, new_oliq, ok_orodr, ok_orolf + PRINT 100 + + PRINT 7, ok_limitvrai + PRINT 100 + + PRINT 12, nbapp_rad + PRINT 100 + + PRINT 8, radpas + PRINT 100 + + PRINT 4,ok_journe,ok_instan,ok_region + PRINT 100 + PRINT 100 +c +c + cycle_diurn0 = .FALSE. + soil_model0 = .FALSE. + new_oliq0 = .FALSE. + ok_orodr0 = .FALSE. + ok_orolf0 = .FALSE. + ok_limitvr0 = .FALSE. + + IF( tabcntr0( 7 ).EQ. 1. ) cycle_diurn0 = .TRUE. + IF( tabcntr0( 8 ).EQ. 1. ) soil_model0 = .TRUE. + IF( tabcntr0( 9 ).EQ. 1. ) new_oliq0 = .TRUE. + IF( tabcntr0(10 ).EQ. 1. ) ok_orodr0 = .TRUE. + IF( tabcntr0(11 ).EQ. 1. ) ok_orolf0 = .TRUE. + IF( tabcntr0(12 ).EQ. 1. ) ok_limitvr0 = .TRUE. + + PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + ,$$$$$$$$$$$$$' + PRINT 100 +c + IF( INT( tabcntr0( 5 ) ) .NE. iflag_con ) THEN + PRINT 20, INT(tabcntr0(5)), iflag_con + PRINT 100 + ENDIF + + IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad ) THEN + PRINT 21, INT(tabcntr0(6)), nbapp_rad +! radpas0 = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) ) + PRINT 100 + PRINT 22, radpas0, radpas + PRINT 100 + ENDIF + + IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND. + , cycle_diurne ) THEN + PRINT 13, cycle_diurn0, cycle_diurne + PRINT 100 + ENDIF + + IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND. + , soil_model ) THEN + PRINT 14, soil_model0, soil_model + PRINT 100 + ENDIF + + IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND. + , new_oliq ) THEN + PRINT 16, new_oliq0, new_oliq + PRINT 100 + ENDIF + + IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND. + , ok_orodr ) THEN + PRINT 15, ok_orodr0, ok_orodr + PRINT 100 + ENDIF + + IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND. + , ok_orolf ) THEN + PRINT 17, ok_orolf0, ok_orolf + PRINT 100 + ENDIF + + IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0. + , AND.ok_limitvrai ) THEN + PRINT 18, ok_limitvr0, ok_limitvrai + PRINT 100 + ENDIF + + PRINT 100 + PRINT *,' ******************************************************* + ,************' + PRINT 100 + + 4 FORMAT(2x,5("*"),' ok_journe= ',l3,3x,',ok_instan = ', + , l3,3x,',ok_region = ',l3,3x,5("*") ) + + 7 FORMAT(2x,5("*"),15x,' ok_limitvrai = ',l3,16x,5("*") ) + + 8 FORMAT(2x,'***** radpas = ' , + , i4,6x,' *****') + + 10 FORMAT(2x,5("*"),' Cycle_diurne = ',l3,4x,', Soil_model = ', + , l3,12x,6("*") ) + + + 11 FORMAT(2x,5("*"),' new_oliq = ',l3,3x,', Ok_orodr = ', + , l3,3x,', Ok_orolf = ',l3,3x,5("*") ) + + + 12 FORMAT(2x,'***** Nb d appels /jour des routines de rayonn. = ' , + , i4,6x,' *****') + + 13 FORMAT(2x,'$$$$$$$$ Attention !! cycle_diurne different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 14 FORMAT(2x,'$$$$$$$$ Attention !! soil_model different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 15 FORMAT(2x,'$$$$$$$$ Attention !! ok_orodr different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 16 FORMAT(2x,'$$$$$$$$ Attention !! new_oliq different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 17 FORMAT(2x,'$$$$$$$$ Attention !! ok_orolf different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 18 FORMAT(2x,'$$$$$$$$ Attention !! ok_limitvrai different sur', + , /1x,10x,' startphy = ',l3,2x,' et run.def = ',l3) + + 20 FORMAT(/2x,'$$$$$$$$ Attention !! iflag_con different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 21 FORMAT(2x,'$$$$$$$$ Attention !! nbapp_rad different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 22 FORMAT(2x,'$$$$$$$$ Attention !! radpas different sur', + , /1x,10x,' startphy = ',i3,2x,' et run.def = ',i3 ) + + 100 FORMAT(/) + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.160.98.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.160.98.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.160.98.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=78,kflev=klev) ! 78*199 Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.192.143.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.192.143.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.192.143.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=10,kflev=klev) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.32.24.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.32.24.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.32.24.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=klon,kflev=klev) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.48.32.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.48.32.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.48.32.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=149,kflev=klev) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.72.46.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.72.46.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.72.46.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=1621,kflev=klev) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.96.72.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.96.72.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.96.72.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=487,kflev=klev) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.defaut.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.defaut.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.defaut.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=klon,kflev=klev) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddim.h (revision 1634) @@ -0,0 +1,5 @@ +! +! $Header$ +! + INTEGER kdlon, kflev + PARAMETER (kdlon=149,kflev=klev) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddimlw.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddimlw.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/raddimlw.h (revision 1634) @@ -0,0 +1,11 @@ +! +! $Header$ +! + INTEGER NUA + PARAMETER (NUA=24) + INTEGER NTRA + PARAMETER (NTRA=15) + INTEGER Ninter + PARAMETER (Ninter=6) + INTEGER NG1, NG1P1 + PARAMETER (NG1=2, NG1P1=NG1+1) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radepsi.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radepsi.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radepsi.h (revision 1634) @@ -0,0 +1,16 @@ +! +! $Header$ +! + REAL(KIND=8) ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW + REAL(KIND=8) ZEPSEC, ZEPSCR + PARAMETER (ZEELOG = 1.E-07) !1.e-10 (not good for 32-bit machines) + PARAMETER (ZEPSC = 1.E-20) + PARAMETER (ZEPSCO = 1.E-10) + PARAMETER (ZEPSCQ = 1.E-10) + PARAMETER (ZEPSCT = 1.E-20) + PARAMETER (ZEPSCW = 1.E-20) + PARAMETER (ZEPSEC = 1.0E-12) + PARAMETER (ZEPSCR = 1.0E-10) +c + REAL(KIND=8) REPSCT + PARAMETER (REPSCT=1.0E-10) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radiation_AR4.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radiation_AR4.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radiation_AR4.F (revision 1634) @@ -0,0 +1,5999 @@ +cIM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, + SUBROUTINE SW_LMDAR4(PSCT, PRMU0, PFRAC, + S PPMB, PDP, + S PPSOL, PALBD, PALBP, + S PTAVE, PWV, PQS, POZON, PAER, + S PCLDSW, PTAU, POMEGA, PCG, + S PHEAT, PHEAT0, + S PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0, + S ZFSUP,ZFSDN,ZFSUP0,ZFSDN0, + S tauae, pizae, cgae, + s PTAUA, POMEGAA, + S PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI, + J ok_ade, ok_aie ) + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "YOMCST.h" +C +C ------------------------------------------------------------------ +C +C PURPOSE. +C -------- +C +C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO +C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). +C +C METHOD. +C ------- +C +C 1. COMPUTES ABSORBER AMOUNTS (SWU) +C 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) +C 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo +c 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER) +C ------------------------------------------------------------------ +C +C* ARGUMENTS: +C + REAL(KIND=8) PSCT ! constante solaire (valeur conseillee: 1370) +cIM ctes ds clesphys.h REAL(KIND=8) RCO2 ! concentration CO2 (IPCC: 353.E-06*44.011/28.97) +#include "clesphys.h" +C + REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (PA) + REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) +C + REAL(KIND=8) PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE + REAL(KIND=8) PFRAC(KDLON) ! fraction de la journee +C + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG) + REAL(KIND=8) PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG) + REAL(KIND=8) POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG) + REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS +C + REAL(KIND=8) PALBD(KDLON,2) ! albedo du sol (lumiere diffuse) + REAL(KIND=8) PALBP(KDLON,2) ! albedo du sol (lumiere parallele) +C + REAL(KIND=8) PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION + REAL(KIND=8) PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS + REAL(KIND=8) PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO +C + REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY) + REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky + REAL(KIND=8) PALBPLA(KDLON) ! PLANETARY ALBEDO + REAL(KIND=8) PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A. + REAL(KIND=8) PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE + REAL(KIND=8) PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL(KIND=8) PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) +C +C* LOCAL VARIABLES: +C + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + + REAL(KIND=8) ZOZ(KDLON,KFLEV) +! column-density of ozone in layer, in kilo-Dobsons + + REAL(KIND=8) ZAKI(KDLON,2) + REAL(KIND=8) ZCLD(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZDSIG(KDLON,KFLEV) + REAL(KIND=8) ZFACT(KDLON) + REAL(KIND=8) ZFD(KDLON,KFLEV+1) + REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1) + REAL(KIND=8) ZFU(KDLON,KFLEV+1) + REAL(KIND=8) ZFUP(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU(KDLON) + REAL(KIND=8) ZSEC(KDLON) + REAL(KIND=8) ZUD(KDLON,5,KFLEV+1) + REAL(KIND=8) ZCLDSW0(KDLON,KFLEV) +c + REAL(KIND=8) ZFSUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1) +C + INTEGER inu, jl, jk, i, k, kpl1 +c + INTEGER swpas ! Every swpas steps, sw is calculated + PARAMETER(swpas=1) +c + INTEGER itapsw + LOGICAL appel1er + DATA itapsw /0/ + DATA appel1er /.TRUE./ + SAVE itapsw,appel1er +c$OMP THREADPRIVATE(appel1er) +c$OMP THREADPRIVATE(itapsw) +cjq-Introduced for aerosol forcings + real(kind=8) flag_aer + logical ok_ade, ok_aie ! use aerosol forcings or not? + real(kind=8) tauae(kdlon,kflev,2) ! aerosol optical properties + real(kind=8) pizae(kdlon,kflev,2) ! (see aeropt.F) + real(kind=8) cgae(kdlon,kflev,2) ! -"- + REAL(KIND=8) PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value) + REAL(KIND=8) POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO + REAL(KIND=8) PTOPSWAD(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) + REAL(KIND=8) PSOLSWAD(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) + REAL(KIND=8) PTOPSWAI(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) + REAL(KIND=8) PSOLSWAI(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) +cjq - Fluxes including aerosol effects + REAL(KIND=8),allocatable,save :: ZFSUPAD(:,:) +c$OMP THREADPRIVATE(ZFSUPAD) + REAL(KIND=8),allocatable,save :: ZFSDNAD(:,:) +c$OMP THREADPRIVATE(ZFSDNAD) + REAL(KIND=8),allocatable,save :: ZFSUPAI(:,:) +c$OMP THREADPRIVATE(ZFSUPAI) + REAL(KIND=8),allocatable,save :: ZFSDNAI(:,:) +c$OMP THREADPRIVATE(ZFSDNAI) + logical initialized +cym SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes +!rv + save flag_aer +c$OMP THREADPRIVATE(flag_aer) + data initialized/.false./ + save initialized +c$OMP THREADPRIVATE(initialized) +cjq-end + REAL tmp_ + if(.not.initialized) then + flag_aer=0. + initialized=.TRUE. + allocate(ZFSUPAD(KDLON,KFLEV+1)) + allocate(ZFSDNAD(KDLON,KFLEV+1)) + allocate(ZFSUPAI(KDLON,KFLEV+1)) + allocate(ZFSDNAI(KDLON,KFLEV+1)) + DO JK = 1 , KDLON*(KFLEV+1) + ZFSUPAD(JK,1) = 0.0 ! ZFSUPAD(:,:)=0. + ZFSDNAD(JK,1) = 0.0 ! ZFSDNAD(:,:)=0. + ZFSUPAI(JK,1) = 0.0 ! ZFSUPAI(:,:)=0. + ZFSDNAI(JK,1) = 0.0 ! ZFSDNAI(:,:)=0. + END DO + endif +!rv + +c + IF (appel1er) THEN + PRINT*, 'SW calling frequency : ', swpas + PRINT*, " In general, it should be 1" + appel1er = .FALSE. + ENDIF +C ------------------------------------------------------------------ + IF (MOD(itapsw,swpas).EQ.0) THEN +c + tmp_ = 1./( dobson_u * 1e3 * RG) +!cdir collapse + DO JK = 1 , KFLEV + DO JL = 1, KDLON + ZCLDSW0(JL,JK) = 0.0 + ZOZ(JL,JK) = POZON(JL,JK)*tmp_*PDP(JL,JK) + ENDDO + ENDDO +C +C +c clear-sky: +cIM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL, + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + + flag_aer=0.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + +c cloudy-sky: + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + +c + IF (ok_ade) THEN +c +c cloudy-sky + aerosol dir OB + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUPAD(JL,JK) = ZFSUP(JL,JK) + ZFSDNAD(JL,JK) = ZFSDN(JL,JK) + ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + + ENDIF ! ok_ade + + IF (ok_aie) THEN + +cjq cloudy-sky + aerosol direct + aerosol indirect + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, + S PRMU0,PFRAC,PTAVE,PWV, + S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD, + S ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, + S PAER, flag_aer, tauae, pizae, cgae, + S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, + S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD, + S PWV, PQS, + S ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUPAI(JL,JK) = ZFSUP(JL,JK) + ZFSDNAI(JL,JK) = ZFSDN(JL,JK) + ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF ! ok_aie +cjq -end + + itapsw = 0 + ENDIF + itapsw = itapsw + 1 +C + DO k = 1, KFLEV + kpl1 = k+1 + DO i = 1, KDLON + PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k)) + . -(ZFSDN(i,k)-ZFSDN(i,kpl1)) + PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k) + PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k)) + . -(ZFSDN0(i,k)-ZFSDN0(i,kpl1)) + PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k) + ENDDO + ENDDO + DO i = 1, KDLON + PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20) +c + PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1) + PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1) +c + PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1) + PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1) +c-OB + PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1) + PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1) +c + PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1) + PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1) +c-fin + ENDDO +C + RETURN + END +c +cIM ctes ds clesphys.h SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, + SUBROUTINE SWU_LMDAR4 (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, + S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT, + S PRMU,PSEC,PUD) + USE dimphy + USE radiation_AR4_param, only : + S ZPDH2O,ZPDUMG,ZPRH2O,ZPRUMG,RTDH2O,RTDUMG,RTH2O,RTUMG + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +#include "YOMCST.h" +C +C* ARGUMENTS: +C + REAL(KIND=8) PSCT +cIM ctes ds clesphys.h REAL(KIND=8) RCO2 +#include "clesphys.h" + REAL(KIND=8) PCLDSW(KDLON,KFLEV) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) + REAL(KIND=8) PPSOL(KDLON) + REAL(KIND=8) PRMU0(KDLON) + REAL(KIND=8) PFRAC(KDLON) + REAL(KIND=8) PTAVE(KDLON,KFLEV) + REAL(KIND=8) PWV(KDLON,KFLEV) +C + REAL(KIND=8) PAKI(KDLON,2) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PCLEAR(KDLON) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) PFACT(KDLON) + REAL(KIND=8) PRMU(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PUD(KDLON,5,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND(2) + REAL(KIND=8) ZC1J(KDLON,KFLEV+1) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZCLOUD(KDLON) + REAL(KIND=8) ZN175(KDLON) + REAL(KIND=8) ZN190(KDLON) + REAL(KIND=8) ZO175(KDLON) + REAL(KIND=8) ZO190(KDLON) + REAL(KIND=8) ZSIGN(KDLON) + REAL(KIND=8) ZR(KDLON,2) + REAL(KIND=8) ZSIGO(KDLON) + REAL(KIND=8) ZUD(KDLON,2) + REAL(KIND=8) ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW + INTEGER jl, jk, jkp1, jkl, jklp1, ja +C +C ------------------------------------------------------------------ +C +C* 1. COMPUTES AMOUNTS OF ABSORBERS +C ----------------------------- +C + 100 CONTINUE +C + IIND(1)=1 + IIND(2)=2 +C +C +C* 1.1 INITIALIZES QUANTITIES +C ---------------------- +C + 110 CONTINUE +C + DO 111 JL = 1, KDLON + PUD(JL,1,KFLEV+1)=0. + PUD(JL,2,KFLEV+1)=0. + PUD(JL,3,KFLEV+1)=0. + PUD(JL,4,KFLEV+1)=0. + PUD(JL,5,KFLEV+1)=0. + PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT + PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35. + PSEC(JL)=1./PRMU(JL) + ZC1J(JL,KFLEV+1)=0. + 111 CONTINUE +C +C* 1.3 AMOUNTS OF ABSORBERS +C -------------------- +C + 130 CONTINUE +C + DO 131 JL= 1, KDLON + ZUD(JL,1) = 0. + ZUD(JL,2) = 0. + ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.) + ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.) + ZSIGO(JL) = PPSOL(JL) + ZCLEAR(JL)=1. + ZCLOUD(JL)=0. + 131 CONTINUE +C + DO 133 JK = 1 , KFLEV + JKP1 = JK + 1 + JKL = KFLEV+1 - JK + JKLP1 = JKL+1 + DO 132 JL = 1, KDLON + ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O + ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG + ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ ) + ZSIGN(JL) = 100. * PPMB(JL,JKP1) + PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL) + ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.) + ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.) + ZDSCO2 = ZO175(JL) - ZN175(JL) + ZDSH2O = ZO190(JL) - ZN190(JL) + PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O) + . * ZDSH2O * ZWH2O * ZRTH + PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG) + . * ZDSCO2 * RCO2 * ZRTU + ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O) + PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW + PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW) + ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK) + ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK) + ZSIGO(JL) = ZSIGN(JL) + ZO175(JL) = ZN175(JL) + ZO190(JL) = ZN190(JL) +C + IF (NOVLP.EQ.1) THEN + ZCLEAR(JL)=ZCLEAR(JL) + S *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL))) + S /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = PCLDSW(JL,JKL) + ELSE IF (NOVLP.EQ.2) THEN + ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL)) + ZC1J(JL,JKL) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN + ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZC1J(JL,JKL) = ZCLOUD(JL) + END IF + 132 CONTINUE + 133 CONTINUE + DO 134 JL=1, KDLON + PCLEAR(JL)=1.-ZC1J(JL,1) + 134 CONTINUE + DO 136 JK=1,KFLEV + DO 135 JL=1, KDLON + IF (PCLEAR(JL).LT.1.) THEN + PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL)) + ELSE + PCLD(JL,JK)=0. + END IF + 135 CONTINUE + 136 CONTINUE +C +C +C* 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS +C ----------------------------------------------- +C + 140 CONTINUE +C + DO 142 JA = 1,2 + DO 141 JL = 1, KDLON + ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL) + 141 CONTINUE + 142 CONTINUE +C + CALL SWTT1_LMDAR4(2, 2, IIND, ZUD, ZR) +C + DO 144 JA = 1,2 + DO 143 JL = 1, KDLON + PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA) + 143 CONTINUE + 144 CONTINUE +C +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SW1S_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW + S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD + S , PFD , PFU) + USE dimphy + USE radiation_AR4_param, only : RSUN, RRAY + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C +C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO +C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). +C +C METHOD. +C ------- +C +C 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO +C CONTINUUM SCATTERING +C 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO +C ------------------------------------------------------------------ +C +C* ARGUMENTS: +C + INTEGER KNU +c-OB + real(kind=8) flag_aer + real(kind=8) tauae(kdlon,kflev,2) + real(kind=8) pizae(kdlon,kflev,2) + real(kind=8) cgae(kdlon,kflev,2) + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PALBD(KDLON,2) + REAL(KIND=8) PALBP(KDLON,2) + REAL(KIND=8) PCG(KDLON,2,KFLEV) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PCLDSW(KDLON,KFLEV) + REAL(KIND=8) PCLEAR(KDLON) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) + REAL(KIND=8) POZ(KDLON,KFLEV) + REAL(KIND=8) PRMU(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PTAU(KDLON,2,KFLEV) + REAL(KIND=8) PUD(KDLON,5,KFLEV+1) +C + REAL(KIND=8) PFD(KDLON,KFLEV+1) + REAL(KIND=8) PFU(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND(4) +C + REAL(KIND=8) ZCGAZ(KDLON,KFLEV) + REAL(KIND=8) ZDIFF(KDLON) + REAL(KIND=8) ZDIRF(KDLON) + REAL(KIND=8) ZPIZAZ(KDLON,KFLEV) + REAL(KIND=8) ZRAYL(KDLON) + REAL(KIND=8) ZRAY1(KDLON,KFLEV+1) + REAL(KIND=8) ZRAY2(KDLON,KFLEV+1) + REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRMUE(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU0(KDLON,KFLEV+1) + REAL(KIND=8) ZR(KDLON,4) + REAL(KIND=8) ZTAUAZ(KDLON,KFLEV) + REAL(KIND=8) ZTRA1(KDLON,KFLEV+1) + REAL(KIND=8) ZTRA2(KDLON,KFLEV+1) + REAL(KIND=8) ZW(KDLON,4) +C + INTEGER jl, jk, k, jaj, ikm1, ikl + +C ------------------------------------------------------------------ +C +C* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON) +C ----------------------- ------------------ +C + 100 CONTINUE +C +C +C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING +C ----------------------------------------- +C + 110 CONTINUE +C + DO 111 JL = 1, KDLON + ZRAYL(JL) = RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL) + S * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL) + S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) )))) + 111 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM SCATTERING CALCULATIONS +C --------------------------------- +C + 200 CONTINUE +C +C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN +C -------------------------------- +C + 210 CONTINUE +C + CALL SWCLR_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBP , PDSIG , ZRAYL, PSEC + S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 + S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) +C +C +C* 2.2 CLOUDY FRACTION OF THE COLUMN +C ----------------------------- +C + 220 CONTINUE +C + CALL SWR_LMDAR4 ( KNU + S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL + S , PSEC ,PTAU + S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE + S , ZTAUAZ,ZTRA1 ,ZTRA2) +C +C +C ------------------------------------------------------------------ +C +C* 3. OZONE ABSORPTION +C ---------------- +C + 300 CONTINUE +C + IIND(1)=1 + IIND(2)=3 + IIND(3)=1 + IIND(4)=3 +C +C +C* 3.1 DOWNWARD FLUXES +C --------------- +C + 310 CONTINUE +C + JAJ = 2 +C + DO 311 JL = 1, KDLON + ZW(JL,1)=0. + ZW(JL,2)=0. + ZW(JL,3)=0. + ZW(JL,4)=0. + PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1) + S + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU) + 311 CONTINUE + DO 314 JK = 1 , KFLEV + IKL = KFLEV+1-JK + DO 312 JL = 1, KDLON + ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL) + ZW(JL,2)=ZW(JL,2)+POZ(JL, IKL)/ZRMUE(JL,IKL) + ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) + ZW(JL,4)=ZW(JL,4)+POZ(JL, IKL)/ZRMU0(JL,IKL) + 312 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR) +C + DO 313 JL = 1, KDLON + ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL) + ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL) + PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL) + S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) + 313 CONTINUE + 314 CONTINUE +C +C +C* 3.2 UPWARD FLUXES +C ------------- +C + 320 CONTINUE +C + DO 325 JL = 1, KDLON + PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU) + S + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU)) + S * RSUN(KNU) + 325 CONTINUE +C + DO 328 JK = 2 , KFLEV+1 + IKM1=JK-1 + DO 326 JL = 1, KDLON + ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66 + ZW(JL,2)=ZW(JL,2)+POZ(JL, IKM1)*1.66 + ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66 + ZW(JL,4)=ZW(JL,4)+POZ(JL, IKM1)*1.66 + 326 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR) +C + DO 327 JL = 1, KDLON + ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK) + ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK) + PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL) + S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) + 327 CONTINUE + 328 CONTINUE +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SW2S_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PAKI, PALBD, PALBP, PCG , PCLD, PCLEAR, PCLDSW + S , PDSIG ,POMEGA,POZ , PRMU , PSEC , PTAU + S , PUD ,PWV , PQS + S , PFDOWN,PFUP ) + USE dimphy + USE radiation_AR4_param, only : RSUN, RRAY + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C +C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE +C SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980). +C +C METHOD. +C ------- +C +C 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO +C CONTINUUM SCATTERING +C 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR +C A GREY MOLECULAR ABSORPTION +C 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS +C OF ABSORBERS +C 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS +C 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + INTEGER KNU +c-OB + real(kind=8) flag_aer + real(kind=8) tauae(kdlon,kflev,2) + real(kind=8) pizae(kdlon,kflev,2) + real(kind=8) cgae(kdlon,kflev,2) + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PAKI(KDLON,2) + REAL(KIND=8) PALBD(KDLON,2) + REAL(KIND=8) PALBP(KDLON,2) + REAL(KIND=8) PCG(KDLON,2,KFLEV) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PCLDSW(KDLON,KFLEV) + REAL(KIND=8) PCLEAR(KDLON) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) + REAL(KIND=8) POZ(KDLON,KFLEV) + REAL(KIND=8) PQS(KDLON,KFLEV) + REAL(KIND=8) PRMU(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PTAU(KDLON,2,KFLEV) + REAL(KIND=8) PUD(KDLON,5,KFLEV+1) + REAL(KIND=8) PWV(KDLON,KFLEV) +C + REAL(KIND=8) PFDOWN(KDLON,KFLEV+1) + REAL(KIND=8) PFUP(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + INTEGER IIND2(2), IIND3(3) + REAL(KIND=8) ZCGAZ(KDLON,KFLEV) + REAL(KIND=8) ZFD(KDLON,KFLEV+1) + REAL(KIND=8) ZFU(KDLON,KFLEV+1) + REAL(KIND=8) ZG(KDLON) + REAL(KIND=8) ZGG(KDLON) + REAL(KIND=8) ZPIZAZ(KDLON,KFLEV) + REAL(KIND=8) ZRAYL(KDLON) + REAL(KIND=8) ZRAY1(KDLON,KFLEV+1) + REAL(KIND=8) ZRAY2(KDLON,KFLEV+1) + REAL(KIND=8) ZREF(KDLON) + REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) ZRE1(KDLON) + REAL(KIND=8) ZRE2(KDLON) + REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1) + REAL(KIND=8) ZRL(KDLON,8) + REAL(KIND=8) ZRMUE(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU0(KDLON,KFLEV+1) + REAL(KIND=8) ZRMUZ(KDLON) + REAL(KIND=8) ZRNEB(KDLON) + REAL(KIND=8) ZRUEF(KDLON,8) + REAL(KIND=8) ZR1(KDLON) + REAL(KIND=8) ZR2(KDLON,2) + REAL(KIND=8) ZR3(KDLON,3) + REAL(KIND=8) ZR4(KDLON) + REAL(KIND=8) ZR21(KDLON) + REAL(KIND=8) ZR22(KDLON) + REAL(KIND=8) ZS(KDLON) + REAL(KIND=8) ZTAUAZ(KDLON,KFLEV) + REAL(KIND=8) ZTO1(KDLON) + REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) + REAL(KIND=8) ZTRA1(KDLON,KFLEV+1) + REAL(KIND=8) ZTRA2(KDLON,KFLEV+1) + REAL(KIND=8) ZTR1(KDLON) + REAL(KIND=8) ZTR2(KDLON) + REAL(KIND=8) ZW(KDLON) + REAL(KIND=8) ZW1(KDLON) + REAL(KIND=8) ZW2(KDLON,2) + REAL(KIND=8) ZW3(KDLON,3) + REAL(KIND=8) ZW4(KDLON) + REAL(KIND=8) ZW5(KDLON) +C + INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 + INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs + REAL(KIND=8) ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11 +C + +C +C ------------------------------------------------------------------ +C +C* 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON) +C ------------------------------------------- +C + 100 CONTINUE +C +C +C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING +C ----------------------------------------- +C + 110 CONTINUE +C + DO 111 JL = 1, KDLON + ZRMUM1 = 1. - PRMU(JL) + ZRAYL(JL) = RRAY(KNU,1) + ZRMUM1 * (RRAY(KNU,2) + ZRMUM1 + S * (RRAY(KNU,3) + ZRMUM1 * (RRAY(KNU,4) + ZRMUM1 + S * (RRAY(KNU,5) + ZRMUM1 * RRAY(KNU,6) )))) + 111 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM SCATTERING CALCULATIONS +C --------------------------------- +C + 200 CONTINUE +C +C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN +C -------------------------------- +C + 210 CONTINUE +C + CALL SWCLR_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBP , PDSIG , ZRAYL, PSEC + S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 + S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) +C +C +C* 2.2 CLOUDY FRACTION OF THE COLUMN +C ----------------------------- +C + 220 CONTINUE +C + CALL SWR_LMDAR4 ( KNU + S , PALBD , PCG , PCLD , PDSIG, POMEGA, ZRAYL + S , PSEC , PTAU + S , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ , ZRK, ZRMUE + S , ZTAUAZ, ZTRA1 , ZTRA2) +C +C +C ------------------------------------------------------------------ +C +C* 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION +C ------------------------------------------------------ +C + 300 CONTINUE +C + JN = 2 +C + DO 361 JABS=1,2 +C +C +C* 3.1 SURFACE CONDITIONS +C ------------------ +C + 310 CONTINUE +C + DO 311 JL = 1, KDLON + ZREFZ(JL,2,1) = PALBD(JL,KNU) + ZREFZ(JL,1,1) = PALBD(JL,KNU) + 311 CONTINUE +C +C +C* 3.2 INTRODUCING CLOUD EFFECTS +C ------------------------- +C + 320 CONTINUE +C + DO 324 JK = 2 , KFLEV+1 + JKM1 = JK - 1 + IKL=KFLEV+1-JKM1 + DO 322 JL = 1, KDLON + ZRNEB(JL) = PCLD(JL,JKM1) + IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN + ZWH2O=MAX(PWV(JL,JKM1),ZEELOG) + ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG)) + ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O + ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG) + ELSE + ZAA=PUD(JL,JABS,JKM1) + ZBB=ZAA + END IF + ZRKI = PAKI(JL,JABS) + ZS(JL) = EXP(-ZRKI * ZAA * 1.66) + ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK)) + ZTR1(JL) = 0. + ZRE1(JL) = 0. + ZTR2(JL) = 0. + ZRE2(JL) = 0. +C + ZW(JL)= POMEGA(JL,KNU,JKM1) + ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL) + S + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1) + S + ZBB * ZRKI + + ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1) + ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) + ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) + S + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1) + ZW(JL) = ZR21(JL) / ZTO1(JL) + ZREF(JL) = ZREFZ(JL,1,JKM1) + ZRMUZ(JL) = ZRMUE(JL,JK) + 322 CONTINUE +C + CALL SWDE_LMDAR4(ZGG, ZREF, ZRMUZ, ZTO1, ZW, + S ZRE1, ZRE2, ZTR1, ZTR2) +C + DO 323 JL = 1, KDLON +C + ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1) + S + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1) + S * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL) + S + ZRNEB(JL) * ZRE1(JL) +C + ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL) + S + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL)) +C + ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1) + S +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1) + S /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL) + S + ZRNEB(JL) * ZRE2(JL) +C + ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL) + S + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1) + S * ZREFZ(JL,1,JKM1))) + S * ZG(JL) * (1. -ZRNEB(JL)) +C + 323 CONTINUE + 324 CONTINUE +C +C* 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL +C ------------------------------------------------- +C + 330 CONTINUE +C + DO 351 JREF=1,2 +C + JN = JN + 1 +C + DO 331 JL = 1, KDLON + ZRJ(JL,JN,KFLEV+1) = 1. + ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1) + 331 CONTINUE +C + DO 333 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 332 JL = 1, KDLON + ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL) + ZRJ(JL,JN,JKL) = ZRE11 + ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL) + 332 CONTINUE + 333 CONTINUE + 351 CONTINUE + 361 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 4. INVERT GREY AND CONTINUUM FLUXES +C -------------------------------- +C + 400 CONTINUE +C +C +C* 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES +C --------------------------------------------- +C + 410 CONTINUE +C + DO 414 JK = 1 , KFLEV+1 + DO 413 JAJ = 1 , 5 , 2 + JAJP = JAJ + 1 + DO 412 JL = 1, KDLON + ZRJ(JL,JAJ,JK)= ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK) + ZRK(JL,JAJ,JK)= ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK) + ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) + ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) + 412 CONTINUE + 413 CONTINUE + 414 CONTINUE +C + DO 417 JK = 1 , KFLEV+1 + DO 416 JAJ = 2 , 6 , 2 + DO 415 JL = 1, KDLON + ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) + ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) + 415 CONTINUE + 416 CONTINUE + 417 CONTINUE +C +C* 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE +C --------------------------------------------- +C + 420 CONTINUE +C + DO 437 JK = 1 , KFLEV+1 + JKKI = 1 + DO 425 JAJ = 1 , 2 + IIND2(1)=JAJ + IIND2(2)=JAJ + DO 424 JN = 1 , 2 + JN2J = JN + 2 * JAJ + JKKP4 = JKKI + 4 +C +C* 4.2.1 EFFECTIVE ABSORBER AMOUNTS +C -------------------------- +C + 4210 CONTINUE +C + DO 4211 JL = 1, KDLON + ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK)) + S / PAKI(JL,JAJ) + ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK)) + S / PAKI(JL,JAJ) + 4211 CONTINUE +C +C* 4.2.2 TRANSMISSION FUNCTION +C --------------------- +C + 4220 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 2, IIND2, ZW2, ZR2) +C + DO 4221 JL = 1, KDLON + ZRL(JL,JKKI) = ZR2(JL,1) + ZRUEF(JL,JKKI) = ZW2(JL,1) + ZRL(JL,JKKP4) = ZR2(JL,2) + ZRUEF(JL,JKKP4) = ZW2(JL,2) + 4221 CONTINUE +C + JKKI=JKKI+1 + 424 CONTINUE + 425 CONTINUE +C +C* 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION +C ------------------------------------------------------ +C + 430 CONTINUE +C + DO 431 JL = 1, KDLON + PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3) + S + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4) + PFUP(JL,JK) = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7) + S + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8) + 431 CONTINUE + 437 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES +C ---------------------------------------- +C + 500 CONTINUE +C +C +C* 5.1 DOWNWARD FLUXES +C --------------- +C + 510 CONTINUE +C + JAJ = 2 + IIND3(1)=1 + IIND3(2)=2 + IIND3(3)=3 +C + DO 511 JL = 1, KDLON + ZW3(JL,1)=0. + ZW3(JL,2)=0. + ZW3(JL,3)=0. + ZW4(JL) =0. + ZW5(JL) =0. + ZR4(JL) =1. + ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1) + 511 CONTINUE + DO 514 JK = 1 , KFLEV + IKL = KFLEV+1-JK + DO 512 JL = 1, KDLON + ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) + ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL) + ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKL)/ZRMU0(JL,IKL) + ZW4(JL) =ZW4(JL) +PUD(JL,4,IKL)/ZRMU0(JL,IKL) + ZW5(JL) =ZW5(JL) +PUD(JL,5,IKL)/ZRMU0(JL,IKL) + 512 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3) +C + DO 513 JL = 1, KDLON +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) + S * ZRJ0(JL,JAJ,IKL) + 513 CONTINUE + 514 CONTINUE +C +C +C* 5.2 UPWARD FLUXES +C ------------- +C + 520 CONTINUE +C + DO 525 JL = 1, KDLON + ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU) + 525 CONTINUE +C + DO 528 JK = 2 , KFLEV+1 + IKM1=JK-1 + DO 526 JL = 1, KDLON + ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66 + ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66 + ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKM1)*1.66 + ZW4(JL) =ZW4(JL) +PUD(JL,4,IKM1)*1.66 + ZW5(JL) =ZW5(JL) +PUD(JL,5,IKM1)*1.66 + 526 CONTINUE +C + CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3) +C + DO 527 JL = 1, KDLON +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) + S * ZRK0(JL,JAJ,JK) + 527 CONTINUE + 528 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION +C -------------------------------------------------- +C + 600 CONTINUE + IABS=3 +C +C* 6.1 DOWNWARD FLUXES +C --------------- +C + 610 CONTINUE + DO 611 JL = 1, KDLON + ZW1(JL)=0. + ZW4(JL)=0. + ZW5(JL)=0. + ZR1(JL)=0. + PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1) + S + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU) + 611 CONTINUE +C + DO 614 JK = 1 , KFLEV + IKL=KFLEV+1-JK + DO 612 JL = 1, KDLON + ZW1(JL) = ZW1(JL)+POZ(JL, IKL)/ZRMUE(JL,IKL) + ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL) + ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL) +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + 612 CONTINUE +C + CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1) +C + DO 613 JL = 1, KDLON + PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL) + S +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU) + 613 CONTINUE + 614 CONTINUE +C +C +C* 6.2 UPWARD FLUXES +C ------------- +C + 620 CONTINUE + DO 621 JL = 1, KDLON + PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1) + S +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU) + 621 CONTINUE +C + DO 624 JK = 2 , KFLEV+1 + IKM1=JK-1 + DO 622 JL = 1, KDLON + ZW1(JL) = ZW1(JL)+POZ(JL ,IKM1)*1.66 + ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66 + ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66 +C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) + 622 CONTINUE +C + CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1) +C + DO 623 JL = 1, KDLON + PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK) + S +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU) + 623 CONTINUE + 624 CONTINUE +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SWCLR_LMDAR4 ( KNU + S , PAER , flag_aer, tauae, pizae, cgae + S , PALBP , PDSIG , PRAYL , PSEC + S , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ + S , PRK , PRMU0 , PTAUAZ, PTRA1 , PTRA2 ) + USE dimphy + USE radiation_AR4_param, only : TAUA, RPIZA, RCGA + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF +C CLEAR-SKY COLUMN +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 94-11-15 +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + INTEGER KNU +c-OB + real(kind=8) flag_aer + real(kind=8) tauae(kdlon,kflev,2) + real(kind=8) pizae(kdlon,kflev,2) + real(kind=8) cgae(kdlon,kflev,2) + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PALBP(KDLON,2) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) PRAYL(KDLON) + REAL(KIND=8) PSEC(KDLON) +C + REAL(KIND=8) PCGAZ(KDLON,KFLEV) + REAL(KIND=8) PPIZAZ(KDLON,KFLEV) + REAL(KIND=8) PRAY1(KDLON,KFLEV+1) + REAL(KIND=8) PRAY2(KDLON,KFLEV+1) + REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) PRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) PRK(KDLON,6,KFLEV+1) + REAL(KIND=8) PRMU0(KDLON,KFLEV+1) + REAL(KIND=8) PTAUAZ(KDLON,KFLEV) + REAL(KIND=8) PTRA1(KDLON,KFLEV+1) + REAL(KIND=8) PTRA2(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZC0I(KDLON,KFLEV+1) + REAL(KIND=8) ZCLE0(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZR21(KDLON) + REAL(KIND=8) ZR23(KDLON) + REAL(KIND=8) ZSS0(KDLON) + REAL(KIND=8) ZSCAT(KDLON) + REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) +C + INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in + REAL(KIND=8) ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE + REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1 + REAL(KIND=8) ZBMU0, ZBMU1, ZRE11 +C + +C ------------------------------------------------------------------ +C +C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH +C -------------------------------------------- +C + 100 CONTINUE +C +!cdir collapse + DO 103 JK = 1 , KFLEV+1 + DO 102 JA = 1 , 6 + DO 101 JL = 1, KDLON + PRJ(JL,JA,JK) = 0. + PRK(JL,JA,JK) = 0. + 101 CONTINUE + 102 CONTINUE + 103 CONTINUE +C + DO 108 JK = 1 , KFLEV +c-OB +c DO 104 JL = 1, KDLON +c PCGAZ(JL,JK) = 0. +c PPIZAZ(JL,JK) = 0. +c PTAUAZ(JL,JK) = 0. +c 104 CONTINUE +c-OB +c DO 106 JAE=1,5 +c DO 105 JL = 1, KDLON +c PTAUAZ(JL,JK)=PTAUAZ(JL,JK) +c S +PAER(JL,JK,JAE)*TAUA(KNU,JAE) +c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE) +c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE) +c PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE) +c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE) +c 105 CONTINUE +c 106 CONTINUE +c-OB + DO 105 JL = 1, KDLON + PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU) + PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU) + PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU) + 105 CONTINUE +C + IF (flag_aer.GT.0) THEN +c-OB + DO 107 JL = 1, KDLON +c PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK) +c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK) + ZTRAY = PRAYL(JL) * PDSIG(JL,JK) + ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK)) + ZGAR = PCGAZ(JL,JK) + ZFF = ZGAR * ZGAR + PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF) + PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR) + PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF) + S / (1. - PPIZAZ(JL,JK) * ZFF) + 107 CONTINUE + ELSE + DO JL = 1, KDLON + ZTRAY = PRAYL(JL) * PDSIG(JL,JK) + PTAUAZ(JL,JK) = ZTRAY + PCGAZ(JL,JK) = 0. + PPIZAZ(JL,JK) = 1.-REPSCT + END DO + END IF ! check flag_aer +c 107 CONTINUE +c PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5) +c $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON) +c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5) +C + 108 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL +C ---------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + ZR23(JL) = 0. + ZC0I(JL,KFLEV+1) = 0. + ZCLEAR(JL) = 1. + ZSCAT(JL) = 0. + 201 CONTINUE +C + JK = 1 + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 202 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZSS0(JL) = 1.-ZR21(JL) + ZCLE0(JL,JKL) = ZSS0(JL) +C + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) + S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) + ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZSCAT(JL) = ZSS0(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) + ZC0I(JL,JKL) = ZSCAT(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) + ZSCAT(JL) = 1.0 - ZCLEAR(JL) + ZC0I(JL,JKL) = ZSCAT(JL) + END IF + 202 CONTINUE +C + DO 205 JK = 2 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 204 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZSS0(JL) = 1.-ZR21(JL) + ZCLE0(JL,JKL) = ZSS0(JL) +c + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) + S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) + ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZSCAT(JL) = ZSS0(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) + ZC0I(JL,JKL) = ZSCAT(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) + ZSCAT(JL) = 1.0 - ZCLEAR(JL) + ZC0I(JL,JKL) = ZSCAT(JL) + END IF + 204 CONTINUE + 205 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING +C ----------------------------------------------- +C + 300 CONTINUE +C + DO 301 JL = 1, KDLON + PRAY1(JL,KFLEV+1) = 0. + PRAY2(JL,KFLEV+1) = 0. + PREFZ(JL,2,1) = PALBP(JL,KNU) + PREFZ(JL,1,1) = PALBP(JL,KNU) + PTRA1(JL,KFLEV+1) = 1. + PTRA2(JL,KFLEV+1) = 1. + 301 CONTINUE +C + DO 346 JK = 2 , KFLEV+1 + JKM1 = JK-1 + DO 342 JL = 1, KDLON +C +C +C ------------------------------------------------------------------ +C +C* 3.1 EQUIVALENT ZENITH ANGLE +C ----------------------- +C + 310 CONTINUE +C + ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL) + S + ZC0I(JL,JK) * 1.66 + PRMU0(JL,JK) = 1./ZMUE +C +C +C ------------------------------------------------------------------ +C +C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS +C ---------------------------------------------------- +C + 320 CONTINUE +C + ZGAP = PCGAZ(JL,JKM1) + ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE + ZWW = PPIZAZ(JL,JKM1) + ZTO = PTAUAZ(JL,JKM1) + ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE + S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE + PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN + PTRA1(JL,JKM1) = 1. / ZDEN +C + ZMU1 = 0.5 + ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 + ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 + S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 + PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 + PTRA2(JL,JKM1) = 1. / ZDEN1 +C +C +C + PREFZ(JL,1,JK) = (PRAY1(JL,JKM1) + S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) +C + ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) +C + PREFZ(JL,2,JK) = (PRAY1(JL,JKM1) + S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) ) +C + ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) +C + 342 CONTINUE + 346 CONTINUE + DO 347 JL = 1, KDLON + ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66 + PRMU0(JL,1)=1./ZMUE + 347 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL +C ------------------------------------------------- +C + 350 CONTINUE +C + IF (KNU.EQ.1) THEN + JAJ = 2 + DO 351 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) + 351 CONTINUE +C + DO 353 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 352 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) + 352 CONTINUE + 353 CONTINUE + 354 CONTINUE +C + ELSE +C + DO 358 JAJ = 1 , 2 + DO 355 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) + 355 CONTINUE +C + DO 357 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 356 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) + 356 CONTINUE + 357 CONTINUE + 358 CONTINUE +C + END IF +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SWR_LMDAR4 ( KNU + S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL + S , PSEC , PTAU + S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE + S , PTAUAZ, PTRA1 , PTRA2 ) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF +C CONTINUUM SCATTERING +C +C METHOD. +C ------- +C +C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL +C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION) +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT +C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + INTEGER KNU + REAL(KIND=8) PALBD(KDLON,2) + REAL(KIND=8) PCG(KDLON,2,KFLEV) + REAL(KIND=8) PCLD(KDLON,KFLEV) + REAL(KIND=8) PDSIG(KDLON,KFLEV) + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) + REAL(KIND=8) PRAYL(KDLON) + REAL(KIND=8) PSEC(KDLON) + REAL(KIND=8) PTAU(KDLON,2,KFLEV) +C + REAL(KIND=8) PRAY1(KDLON,KFLEV+1) + REAL(KIND=8) PRAY2(KDLON,KFLEV+1) + REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1) + REAL(KIND=8) PRJ(KDLON,6,KFLEV+1) + REAL(KIND=8) PRK(KDLON,6,KFLEV+1) + REAL(KIND=8) PRMUE(KDLON,KFLEV+1) + REAL(KIND=8) PCGAZ(KDLON,KFLEV) + REAL(KIND=8) PPIZAZ(KDLON,KFLEV) + REAL(KIND=8) PTAUAZ(KDLON,KFLEV) + REAL(KIND=8) PTRA1(KDLON,KFLEV+1) + REAL(KIND=8) PTRA2(KDLON,KFLEV+1) +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZC1I(KDLON,KFLEV+1) + REAL(KIND=8) ZCLEQ(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZCLOUD(KDLON) + REAL(KIND=8) ZGG(KDLON) + REAL(KIND=8) ZREF(KDLON) + REAL(KIND=8) ZRE1(KDLON) + REAL(KIND=8) ZRE2(KDLON) + REAL(KIND=8) ZRMUZ(KDLON) + REAL(KIND=8) ZRNEB(KDLON) + REAL(KIND=8) ZR21(KDLON) + REAL(KIND=8) ZR22(KDLON) + REAL(KIND=8) ZR23(KDLON) + REAL(KIND=8) ZSS1(KDLON) + REAL(KIND=8) ZTO1(KDLON) + REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) + REAL(KIND=8) ZTR1(KDLON) + REAL(KIND=8) ZTR2(KDLON) + REAL(KIND=8) ZW(KDLON) +C + INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj + REAL(KIND=8) ZFACOA, ZFACOC, ZCORAE, ZCORCD + REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1 + REAL(KIND=8) ZMU1, ZRE11, ZBMU0, ZBMU1 +C +C ------------------------------------------------------------------ +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C + DO 103 JK = 1 , KFLEV+1 + DO 102 JA = 1 , 6 + DO 101 JL = 1, KDLON + PRJ(JL,JA,JK) = 0. + PRK(JL,JA,JK) = 0. + 101 CONTINUE + 102 CONTINUE + 103 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL +C ---------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + ZR23(JL) = 0. + ZC1I(JL,KFLEV+1) = 0. + ZCLEAR(JL) = 1. + ZCLOUD(JL) = 0. + 201 CONTINUE +C + JK = 1 + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 202 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) + S * PCG(JL,KNU,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZR22(JL) = EXP(-ZCORCD ) + ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) + S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) + ZCLEQ(JL,JKL) = ZSS1(JL) +C + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) + S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = ZSS1(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) + ZC1I(JL,JKL) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZC1I(JL,JKL) = ZCLOUD(JL) + END IF + 202 CONTINUE +C + DO 205 JK = 2 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 204 JL = 1, KDLON + ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) + ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) + S * PCG(JL,KNU,JKL) + ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) + ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) + ZR21(JL) = EXP(-ZCORAE ) + ZR22(JL) = EXP(-ZCORCD ) + ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) + S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) + ZCLEQ(JL,JKL) = ZSS1(JL) +c + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL) = ZCLEAR(JL) + S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) + S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = ZSS1(JL) + ELSE IF (NOVLP.EQ.2) THEN +C* maximum + ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) + ZC1I(JL,JKL) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZC1I(JL,JKL) = ZCLOUD(JL) + END IF + 204 CONTINUE + 205 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING +C ----------------------------------------------- +C + 300 CONTINUE +C + DO 301 JL = 1, KDLON + PRAY1(JL,KFLEV+1) = 0. + PRAY2(JL,KFLEV+1) = 0. + PREFZ(JL,2,1) = PALBD(JL,KNU) + PREFZ(JL,1,1) = PALBD(JL,KNU) + PTRA1(JL,KFLEV+1) = 1. + PTRA2(JL,KFLEV+1) = 1. + 301 CONTINUE +C + DO 346 JK = 2 , KFLEV+1 + JKM1 = JK-1 + DO 342 JL = 1, KDLON + ZRNEB(JL)= PCLD(JL,JKM1) + ZRE1(JL)=0. + ZTR1(JL)=0. + ZRE2(JL)=0. + ZTR2(JL)=0. +C +C +C ------------------------------------------------------------------ +C +C* 3.1 EQUIVALENT ZENITH ANGLE +C ----------------------- +C + 310 CONTINUE +C + ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL) + S + ZC1I(JL,JK) * 1.66 + PRMUE(JL,JK) = 1./ZMUE +C +C +C ------------------------------------------------------------------ +C +C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS +C ---------------------------------------------------- +C + 320 CONTINUE +C + ZGAP = PCGAZ(JL,JKM1) + ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE + ZWW = PPIZAZ(JL,JKM1) + ZTO = PTAUAZ(JL,JKM1) + ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE + S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE + PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN + PTRA1(JL,JKM1) = 1. / ZDEN +c PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1) +C + ZMU1 = 0.5 + ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 + ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 + S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 + PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 + PTRA2(JL,JKM1) = 1. / ZDEN1 +C +C +C ------------------------------------------------------------------ +C +C* 3.3 EFFECT OF CLOUD LAYER +C --------------------- +C + 330 CONTINUE +C + ZW(JL) = POMEGA(JL,KNU,JKM1) + ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL) + S + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1) + ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1) + ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) + ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) + S + (1. - ZR22(JL)) * PCGAZ(JL,JKM1) +C Modif PhD - JJM 19/03/96 pour erreurs arrondis +C machine +C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL) + IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN + ZW(JL)=1. + ELSE + ZW(JL) = ZR21(JL) / ZTO1(JL) + END IF + ZREF(JL) = PREFZ(JL,1,JKM1) + ZRMUZ(JL) = PRMUE(JL,JK) + 342 CONTINUE +C + CALL SWDE_LMDAR4(ZGG , ZREF , ZRMUZ , ZTO1 , ZW, + S ZRE1 , ZRE2 , ZTR1 , ZTR2) +C + DO 345 JL = 1, KDLON +C + PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) + S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) + S + ZRNEB(JL) * ZRE2(JL) +C + ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1) + S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) + S * (1.-ZRNEB(JL)) +C + PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) + S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) + S * PTRA2(JL,JKM1) ) + S + ZRNEB(JL) * ZRE1(JL) +C + ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL) + S + PTRA1(JL,JKM1) * (1.-ZRNEB(JL)) +C + 345 CONTINUE + 346 CONTINUE + DO 347 JL = 1, KDLON + ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66 + PRMUE(JL,1)=1./ZMUE + 347 CONTINUE +C +C +C ------------------------------------------------------------------ +C +C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL +C ------------------------------------------------- +C + 350 CONTINUE +C + IF (KNU.EQ.1) THEN + JAJ = 2 + DO 351 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) + 351 CONTINUE +C + DO 353 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 352 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) + 352 CONTINUE + 353 CONTINUE + 354 CONTINUE +C + ELSE +C + DO 358 JAJ = 1 , 2 + DO 355 JL = 1, KDLON + PRJ(JL,JAJ,KFLEV+1) = 1. + PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) + 355 CONTINUE +C + DO 357 JK = 1 , KFLEV + JKL = KFLEV+1 - JK + JKLP1 = JKL + 1 + DO 356 JL = 1, KDLON + ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) + PRJ(JL,JAJ,JKL) = ZRE11 + PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) + 356 CONTINUE + 357 CONTINUE + 358 CONTINUE +C + END IF +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE SWDE_LMDAR4 (PGG,PREF,PRMUZ,PTO1,PW, + S PRE1,PRE2,PTR1,PTR2) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY +C LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION. +C +C METHOD. +C ------- +C +C STANDARD DELTA-EDDINGTON LAYER CALCULATIONS. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C ------------------------------------------------------------------ +C* ARGUMENTS: +C + REAL(KIND=8) PGG(KDLON) ! ASSYMETRY FACTOR + REAL(KIND=8) PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER + REAL(KIND=8) PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE + REAL(KIND=8) PTO1(KDLON) ! OPTICAL THICKNESS + REAL(KIND=8) PW(KDLON) ! SINGLE SCATTERING ALBEDO + REAL(KIND=8) PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION) + REAL(KIND=8) PRE2(KDLON) ! LAYER REFLECTIVITY + REAL(KIND=8) PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION) + REAL(KIND=8) PTR2(KDLON) ! LAYER TRANSMISSIVITY +C +C* LOCAL VARIABLES: +C + INTEGER jl + REAL(KIND=8) ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM + REAL(KIND=8) ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG + REAL(KIND=8) ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, + $ ZAM2B + REAL(KIND=8) ZA11, ZA12, ZA13, ZA21, ZA22, ZA23 + REAL(KIND=8) ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A + REAL(KIND=8) ZRI0B, ZRI1B + REAL(KIND=8) ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B + REAL(KIND=8) ZRI0C, ZRI1C, ZRI0D, ZRI1D +C ------------------------------------------------------------------ +C +C* 1. DELTA-EDDINGTON CALCULATIONS +C + 100 CONTINUE +C + DO 131 JL = 1, KDLON +C +C* 1.1 SET UP THE DELTA-MODIFIED PARAMETERS +C + 110 CONTINUE +C + ZFF = PGG(JL)*PGG(JL) + ZGP = PGG(JL)/(1.+PGG(JL)) + ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL) + ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF) + ZDT = 2./3. + ZX1 = 1.-ZWCP*ZGP + ZWM = 1.-ZWCP + ZRM2 = PRMUZ(JL) * PRMUZ(JL) + ZRK = SQRT(3.*ZWM*ZX1) + ZX2 = 4.*(1.-ZRK*ZRK*ZRM2) + ZRP=ZRK/ZX1 + ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2 + ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2 + ZARG=MIN(ZTOP/PRMUZ(JL),200._8) + ZEXMU0=EXP(-ZARG) + ZARG2=MIN(ZRK*ZTOP,200._8) + ZEXKP=EXP(ZARG2) + ZEXKM = 1./ZEXKP + ZXP2P = 1.+ZDT*ZRP + ZXM2P = 1.-ZDT*ZRP + ZAP2B = ZALPHA+ZDT*ZBETA + ZAM2B = ZALPHA-ZDT*ZBETA +C +C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER +C + 120 CONTINUE +C + ZA11 = ZXP2P + ZA12 = ZXM2P + ZA13 = ZAP2B + ZA22 = ZXP2P*ZEXKP + ZA21 = ZXM2P*ZEXKM + ZA23 = ZAM2B*ZEXMU0 + ZDENA = ZA11 * ZA22 - ZA21 * ZA12 + ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA + ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA + ZRI0A = ZC1A+ZC2A-ZALPHA + ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA + PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL) + ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0 + ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0 + PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL) +C +C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER +C + 130 CONTINUE +C + ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM + ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP + ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) ) + ZDENB = ZA11 * ZB22 - ZB21 * ZA12 + ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB + ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB + ZRI0C = ZC1B+ZC2B-ZALPHA + ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA + PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL) + ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0 + ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0 + PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL) +C + 131 CONTINUE + RETURN + END + SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR) + USE dimphy + USE radiation_AR4_param, only : APAD, BPAD, D + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS +C AND HORNER'S ALGORITHM. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C----------------------------------------------------------------------- +C +C* ARGUMENTS +C + INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL + INTEGER KA ! INDEX OF THE ABSORBER + REAL(KIND=8) PU(KDLON) ! ABSORBER AMOUNT +C + REAL(KIND=8) PTR(KDLON) ! TRANSMISSION FUNCTION +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZR1(KDLON), ZR2(KDLON) + INTEGER jl, i,j +C + +C +C----------------------------------------------------------------------- +C +C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION +C + 100 CONTINUE +C + DO 201 JL = 1, KDLON + ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL) + S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL) + S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL) + S * ( APAD(KNU,KA,7) )))))) +C + ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL) + S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL) + S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL) + S * ( BPAD(KNU,KA,7) )))))) +C +C +C* 2. ADD THE BACKGROUND TRANSMISSION +C + 200 CONTINUE +C +C + PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA) + 201 CONTINUE +C + RETURN + END + SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR) + USE dimphy + USE radiation_AR4_param, only : APAD, BPAD, D + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS +C AND HORNER'S ALGORITHM. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 95-01-20 +C----------------------------------------------------------------------- +C* ARGUMENTS: +C + INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL + INTEGER KABS ! NUMBER OF ABSORBERS + INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS + REAL(KIND=8) PU(KDLON,KABS) ! ABSORBER AMOUNT +C + REAL(KIND=8) PTR(KDLON,KABS) ! TRANSMISSION FUNCTION +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZR1(KDLON) + REAL(KIND=8) ZR2(KDLON) + REAL(KIND=8) ZU(KDLON) + INTEGER jl, ja, i, j, ia +C + +C----------------------------------------------------------------------- +C +C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION +C + 100 CONTINUE +C + DO 202 JA = 1,KABS + IA=KIND(JA) + DO 201 JL = 1, KDLON + ZU(JL) = PU(JL,JA) + ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL) + S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL) + S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL) + S * ( APAD(KNU,IA,7) )))))) +C + ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL) + S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL) + S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL) + S * ( BPAD(KNU,IA,7) )))))) +C +C +C* 2. ADD THE BACKGROUND TRANSMISSION +C + 200 CONTINUE +C + PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) + 201 CONTINUE + 202 CONTINUE +C + RETURN + END +cIM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, + SUBROUTINE LW_LMDAR4( + . PPMB, PDP, + . PPSOL,PDT0,PEMIS, + . PTL, PTAVE, PWV, POZON, PAER, + . PCLDLD,PCLDLU, + . PVIEW, + . PCOLR, PCOLR0, + . PTOPLW,PSOLLW,PTOPLW0,PSOLLW0, + . psollwdown, +cIM . psollwdown,psollwdownclr, +cIM . ptoplwdown,ptoplwdownclr) + . plwup, plwdn, plwup0, plwdn0) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +C +C----------------------------------------------------------------------- +C METHOD. +C ------- +C +C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF +C ABSORBERS. +C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE +C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. +C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- +C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE +C BOUNDARIES. +C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. +C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES. +C +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +cIM ctes ds clesphys.h +c REAL(KIND=8) RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97) +c REAL(KIND=8) RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97) +c REAL(KIND=8) RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97) +c REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97) +c REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97) +#include "clesphys.h" + REAL(KIND=8) PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER + REAL(KIND=8) PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER + REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa) + REAL(KIND=8) PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K) + REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb) + REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (Pa) + REAL(KIND=8) POZON(KDLON,KFLEV) ! O3 mass fraction + REAL(KIND=8) PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K) + REAL(KIND=8) PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL(KIND=8) PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE + REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg) +C + REAL(KIND=8) PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) + REAL(KIND=8) PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky + REAL(KIND=8) PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A. + REAL(KIND=8) PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE + REAL(KIND=8) PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL(KIND=8) PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY) +c Rajout LF + real(kind=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface +c Rajout IM +cIM real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface +cIM real(kind=8) ptoplwdown(kdlon) ! LONGWAVE downwards flux at T.O.A. +cIM real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A. +cIM + REAL(KIND=8) plwup(KDLON,KFLEV+1) ! LW up total sky + REAL(KIND=8) plwup0(KDLON,KFLEV+1) ! LW up clear sky + REAL(KIND=8) plwdn(KDLON,KFLEV+1) ! LW down total sky + REAL(KIND=8) plwdn0(KDLON,KFLEV+1) ! LW down clear sky +C------------------------------------------------------------------------- + REAL(KIND=8) ZABCU(KDLON,NUA,3*KFLEV+1) + + REAL(KIND=8) ZOZ(KDLON,KFLEV) +! equivalent pressure of ozone in a layer, in Pa + +cym REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down) +cym REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES +cym REAL(KIND=8) ZBINT(KDLON,KFLEV+1) ! Intermediate variable +cym REAL(KIND=8) ZBSUI(KDLON) ! Intermediate variable +cym REAL(KIND=8) ZCTS(KDLON,KFLEV) ! Intermediate variable +cym REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable +cym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB + REAL(KIND=8),allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down) + REAL(KIND=8),allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES + REAL(KIND=8),allocatable,save :: ZBINT(:,:) ! Intermediate variable + REAL(KIND=8),allocatable,save :: ZBSUI(:) ! Intermediate variable + REAL(KIND=8),allocatable,save :: ZCTS(:,:) ! Intermediate variable + REAL(KIND=8),allocatable,save :: ZCNTRB(:,:,:) ! Intermediate variable +c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB) +c + INTEGER ilim, i, k, kpl1 +C + INTEGER lw0pas ! Every lw0pas steps, clear-sky is done + PARAMETER (lw0pas=1) + INTEGER lwpas ! Every lwpas steps, cloudy-sky is done + PARAMETER (lwpas=1) +c + INTEGER itaplw0, itaplw + LOGICAL appel1er + SAVE appel1er, itaplw0, itaplw +c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw) + DATA appel1er /.TRUE./ + DATA itaplw0,itaplw /0,0/ + +C ------------------------------------------------------------------ + IF (appel1er) THEN + PRINT*, "LW clear-sky calling frequency: ", lw0pas + PRINT*, "LW cloudy-sky calling frequency: ", lwpas + PRINT*, " In general, they should be 1" +cym + allocate(ZFLUX(KDLON,2,KFLEV+1) ) + allocate(ZFLUC(KDLON,2,KFLEV+1) ) + allocate(ZBINT(KDLON,KFLEV+1)) + allocate(ZBSUI(KDLON)) + allocate(ZCTS(KDLON,KFLEV)) + allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1)) + appel1er=.FALSE. + ENDIF +C + IF (MOD(itaplw0,lw0pas).EQ.0) THEN +c Compute equivalent pressure of ozone from mass fraction: + DO k = 1, KFLEV + DO i = 1, KDLON + ZOZ(i,k) = POZON(i,k)*PDP(i,k) + ENDDO + ENDDO +cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12, + CALL LWU_LMDAR4( + S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU) + CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU, + S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB) + itaplw0 = 0 + ENDIF + itaplw0 = itaplw0 + 1 +C + IF (MOD(itaplw,lwpas).EQ.0) THEN + CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS, + S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB, + S ZFLUX) + itaplw = 0 + ENDIF + itaplw = itaplw + 1 +C + DO k = 1, KFLEV + kpl1 = k+1 + DO i = 1, KDLON + PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1) + . - ZFLUX(i,1,k)- ZFLUX(i,2,k) + PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k) + PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1) + . - ZFLUC(i,1,k)- ZFLUC(i,2,k) + PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k) + ENDDO + ENDDO + DO i = 1, KDLON + PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1) + PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1) +c + PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1) + PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1) + psollwdown(i) = -ZFLUX(i,2,1) +c +cIM attention aux signes !; LWtop >0, LWdn < 0 + DO k = 1, KFLEV+1 + plwup(i,k) = ZFLUX(i,1,k) + plwup0(i,k) = ZFLUC(i,1,k) + plwdn(i,k) = ZFLUX(i,2,k) + plwdn0(i,k) = ZFLUC(i,2,k) + ENDDO + ENDDO +C ------------------------------------------------------------------ + RETURN + END +cIM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12, + SUBROUTINE LWU_LMDAR4( + S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV, + S PABCU) + USE dimphy + USE radiation_AR4_param, only : TREF, RT1, RAER, AT, BT, OCT + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +#include "radepsi.h" +#include "radopt.h" +C +C PURPOSE. +C -------- +C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND +C TEMPERATURE EFFECTS +C +C METHOD. +C ------- +C +C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF +C ABSORBERS. +C +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C Voigt lines (loop 404 modified) - JJM & PhD - 01/96 +C----------------------------------------------------------------------- +C* ARGUMENTS: +cIM ctes ds clesphys.h +c REAL(KIND=8) RCO2 +c REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12 +#include "clesphys.h" + REAL(KIND=8) PAER(KDLON,KFLEV,5) + REAL(KIND=8) PDP(KDLON,KFLEV) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) + REAL(KIND=8) PPSOL(KDLON) + REAL(KIND=8) POZ(KDLON,KFLEV) + REAL(KIND=8) PTAVE(KDLON,KFLEV) + REAL(KIND=8) PVIEW(KDLON) + REAL(KIND=8) PWV(KDLON,KFLEV) +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS +C +C----------------------------------------------------------------------- +C* LOCAL VARIABLES: + REAL(KIND=8) ZABLY(KDLON,NUA,3*KFLEV+1) + REAL(KIND=8) ZDUC(KDLON,3*KFLEV+1) + REAL(KIND=8) ZPHIO(KDLON) + REAL(KIND=8) ZPSC2(KDLON) + REAL(KIND=8) ZPSC3(KDLON) + REAL(KIND=8) ZPSH1(KDLON) + REAL(KIND=8) ZPSH2(KDLON) + REAL(KIND=8) ZPSH3(KDLON) + REAL(KIND=8) ZPSH4(KDLON) + REAL(KIND=8) ZPSH5(KDLON) + REAL(KIND=8) ZPSH6(KDLON) + REAL(KIND=8) ZPSIO(KDLON) + REAL(KIND=8) ZTCON(KDLON) + REAL(KIND=8) ZPHM6(KDLON) + REAL(KIND=8) ZPSM6(KDLON) + REAL(KIND=8) ZPHN6(KDLON) + REAL(KIND=8) ZPSN6(KDLON) + REAL(KIND=8) ZSSIG(KDLON,3*KFLEV+1) + REAL(KIND=8) ZTAVI(KDLON) + REAL(KIND=8) ZUAER(KDLON,Ninter) + REAL(KIND=8) ZXOZ(KDLON) + REAL(KIND=8) ZXWV(KDLON) +C + INTEGER jl, jk, jkj, jkjr, jkjp, ig1 + INTEGER jki, jkip1, ja, jj + INTEGER jkl, jkp1, jkk, jkjpn + INTEGER jae1, jae2, jae3, jae, jjpn + INTEGER ir, jc, jcp1 + REAL(KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup + REAL(KIND=8) zfppw, ztx, ztx2, zzably + REAL(KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3 + REAL(KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6 + REAL(KIND=8) zcac8, zcbc8 + REAL(KIND=8) zalup, zdiff +c + REAL(KIND=8) PVGCO2, PVGH2O, PVGO3 +C + REAL(KIND=8) R10E ! DECIMAL/NATURAL LOG.FACTOR + PARAMETER (R10E=0.4342945) + +C----------------------------------------------------------------------- +c + IF (LEVOIGT) THEN + PVGCO2= 60. + PVGH2O= 30. + PVGO3 =400. + ELSE + PVGCO2= 0. + PVGH2O= 0. + PVGO3 = 0. + ENDIF +C +C +C* 2. PRESSURE OVER GAUSS SUB-LEVELS +C ------------------------------ +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + ZSSIG(JL, 1 ) = PPMB(JL,1) * 100. + 201 CONTINUE +C + DO 206 JK = 1 , KFLEV + JKJ=(JK-1)*NG1P1+1 + JKJR = JKJ + JKJP = JKJ + NG1P1 + DO 203 JL = 1, KDLON + ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100. + 203 CONTINUE + DO 205 IG1=1,NG1 + JKJ=JKJ+1 + DO 204 JL = 1, KDLON + ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5 + S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5 + 204 CONTINUE + 205 CONTINUE + 206 CONTINUE +C +C----------------------------------------------------------------------- +C +C +C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS +C -------------------------------------------------- +C + 400 CONTINUE +C + DO 402 JKI=1,3*KFLEV + JKIP1=JKI+1 + DO 401 JL = 1, KDLON + ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5 + ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1)) + S /(10.*RG) + 401 CONTINUE + 402 CONTINUE +C + DO 406 JK = 1 , KFLEV + JKP1=JK+1 + JKL = KFLEV+1 - JK + DO 403 JL = 1, KDLON + ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ ) + ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO ) + 403 CONTINUE + JKJ=(JK-1)*NG1P1+1 + JKJPN=JKJ+NG1 + DO 405 JKK=JKJ,JKJPN + DO 404 JL = 1, KDLON + ZDPM = ZABLY(JL,3,JKK) + ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325. + ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325. + ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325. + ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325. + ZDUC(JL,JKK) = ZDPM + ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM + ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3 + ZU6 = ZXWV(JL) * ZUPM + ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL)) + ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O + ZABLY(JL,11,JKK) = ZU6 * ZFPPW + ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW) + ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2 + ZABLY(JL,8,JKK) = RCO2 * ZDPM + 404 CONTINUE + 405 CONTINUE + 406 CONTINUE +C +C----------------------------------------------------------------------- +C +C +C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE +C -------------------------------------------------- +C + 500 CONTINUE +C + DO 502 JA = 1, NUA + DO 501 JL = 1, KDLON + PABCU(JL,JA,3*KFLEV+1) = 0. + 501 CONTINUE + 502 CONTINUE +C + DO 529 JK = 1 , KFLEV + JJ=(JK-1)*NG1P1+1 + JJPN=JJ+NG1 + JKL=KFLEV+1-JK +C +C +C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE +C -------------------------------------------------- +C + 510 CONTINUE +C + JAE1=3*KFLEV+1-JJ + JAE2=3*KFLEV+1-(JJ+1) + JAE3=3*KFLEV+1-JJPN + DO 512 JAE=1,5 + DO 511 JL = 1, KDLON + ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1) + S +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3) + S +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5)) + S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3)) + 511 CONTINUE + 512 CONTINUE +C +C +C +C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS +C -------------------------------------------------- +C + 520 CONTINUE +C + DO 521 JL = 1, KDLON + ZTAVI(JL)=PTAVE(JL,JKL) + ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.)) + ZTX=ZTAVI(JL)-TREF + ZTX2=ZTX*ZTX + ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3) + ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0._8), 6._8) + ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3))) + ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3))) + ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 ) + ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3))) + ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3))) + ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 ) + ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3))) + ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3))) + ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 ) + ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3))) + ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3))) + ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 ) + ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3))) + ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3))) + ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 ) + ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3))) + ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3))) + ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 ) + ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 ) + ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 ) + ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 ) + ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 ) + 521 CONTINUE +C + DO 522 JL = 1, KDLON + ZTAVI(JL)=PTAVE(JL,JKL) + ZTX=ZTAVI(JL)-TREF + ZTX2=ZTX*ZTX + ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3) + ZALUP = R10E * LOG ( ZZABLY ) + ZUP = MAX( 0._8, 5.0 + 0.5 * ZALUP ) + ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP + ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3))) + ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3))) + ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 ) + ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2) + ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2)) + 522 CONTINUE +C + DO 524 JKK=JJ,JJPN + JC=3*KFLEV+1-JKK + JCP1=JC+1 + DO 523 JL = 1, KDLON + ZDIFF = PVIEW(JL) + PABCU(JL,10,JC)=PABCU(JL,10,JCP1) + S +ZABLY(JL,10,JC) *ZDIFF + PABCU(JL,11,JC)=PABCU(JL,11,JCP1) + S +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF +C + PABCU(JL,12,JC)=PABCU(JL,12,JCP1) + S +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF + PABCU(JL,13,JC)=PABCU(JL,13,JCP1) + S +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF +C + PABCU(JL,7,JC)=PABCU(JL,7,JCP1) + S +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF + PABCU(JL,8,JC)=PABCU(JL,8,JCP1) + S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF + PABCU(JL,9,JC)=PABCU(JL,9,JCP1) + S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF +C + PABCU(JL,1,JC)=PABCU(JL,1,JCP1) + S +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF + PABCU(JL,2,JC)=PABCU(JL,2,JCP1) + S +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF + PABCU(JL,3,JC)=PABCU(JL,3,JCP1) + S +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF + PABCU(JL,4,JC)=PABCU(JL,4,JCP1) + S +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF + PABCU(JL,5,JC)=PABCU(JL,5,JCP1) + S +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF + PABCU(JL,6,JC)=PABCU(JL,6,JCP1) + S +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF +C + PABCU(JL,14,JC)=PABCU(JL,14,JCP1) + S +ZUAER(JL,1) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,15,JC)=PABCU(JL,15,JCP1) + S +ZUAER(JL,2) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,16,JC)=PABCU(JL,16,JCP1) + S +ZUAER(JL,3) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,17,JC)=PABCU(JL,17,JCP1) + S +ZUAER(JL,4) *ZDUC(JL,JC)*ZDIFF + PABCU(JL,18,JC)=PABCU(JL,18,JCP1) + S +ZUAER(JL,5) *ZDUC(JL,JC)*ZDIFF +C + PABCU(JL,19,JC)=PABCU(JL,19,JCP1) + S +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF + PABCU(JL,20,JC)=PABCU(JL,20,JCP1) + S +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF + PABCU(JL,21,JC)=PABCU(JL,21,JCP1) + S +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF + PABCU(JL,22,JC)=PABCU(JL,22,JCP1) + S +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF +C + PABCU(JL,23,JC)=PABCU(JL,23,JCP1) + S +ZABLY(JL,8,JC)*RCFC11/RCO2 *ZDIFF + PABCU(JL,24,JC)=PABCU(JL,24,JCP1) + S +ZABLY(JL,8,JC)*RCFC12/RCO2 *ZDIFF + 523 CONTINUE + 524 CONTINUE +C + 529 CONTINUE +C +C + RETURN + END + SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU, + S PFLUC,PBINT,PBSUI,PCTS,PCNTRB) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +C +C PURPOSE. +C -------- +C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE +C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY +C SAVING +C +C METHOD. +C ------- +C +C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE +C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. +C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- +C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE +C BOUNDARIES. +C 3. COMPUTES THE CLEAR-SKY COOLING RATES. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE +C MEMORY) +C----------------------------------------------------------------------- +C* ARGUMENTS: + INTEGER KLIM +C + REAL(KIND=8) PDP(KDLON,KFLEV) + REAL(KIND=8) PDT0(KDLON) + REAL(KIND=8) PEMIS(KDLON) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) + REAL(KIND=8) PTL(KDLON,KFLEV+1) + REAL(KIND=8) PTAVE(KDLON,KFLEV) +C + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) + REAL(KIND=8) PBINT(KDLON,KFLEV+1) + REAL(KIND=8) PBSUI(KDLON) + REAL(KIND=8) PCTS(KDLON,KFLEV) + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) +C +C------------------------------------------------------------------------- +C +C* LOCAL VARIABLES: + REAL(KIND=8) ZB(KDLON,Ninter,KFLEV+1) + REAL(KIND=8) ZBSUR(KDLON,Ninter) + REAL(KIND=8) ZBTOP(KDLON,Ninter) + REAL(KIND=8) ZDBSL(KDLON,Ninter,KFLEV*2) + REAL(KIND=8) ZGA(KDLON,8,2,KFLEV) + REAL(KIND=8) ZGB(KDLON,8,2,KFLEV) + REAL(KIND=8) ZGASUR(KDLON,8,2) + REAL(KIND=8) ZGBSUR(KDLON,8,2) + REAL(KIND=8) ZGATOP(KDLON,8,2) + REAL(KIND=8) ZGBTOP(KDLON,8,2) +C + INTEGER nuaer, ntraer +C ------------------------------------------------------------------ +C* COMPUTES PLANCK FUNCTIONS: + CALL LWB_LMDAR4(PDT0,PTAVE,PTL, + S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL, + S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP) +C ------------------------------------------------------------------ +C* PERFORMS THE VERTICAL INTEGRATION: + NUAER = NUA + NTRAER = NTRA + CALL LWV_LMDAR4(NUAER,NTRAER, KLIM + R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE + R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP + S , PCNTRB,PCTS,PFLUC) +C ------------------------------------------------------------------ + RETURN + END + SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC, + R PBINT,PBSUIN,PCTS,PCNTRB, + S PFLUX) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "radepsi.h" +#include "radopt.h" +C +C PURPOSE. +C -------- +C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR +C RADIANCES +C +C EXPLICIT ARGUMENTS : +C -------------------- +C ==== INPUTS === +C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION +C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION +C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION +C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION +C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE +C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE +C PEMIS : (KDLON) ; SURFACE EMISSIVITY +C PFLUC +C ==== OUTPUTS === +C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES : +C 1 ==> UPWARD FLUX TOTAL +C 2 ==> DOWNWARD FLUX TOTAL +C +C METHOD. +C ------- +C +C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES +C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER +C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED +C CLOUDS +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96 +C----------------------------------------------------------------------- +C* ARGUMENTS: + INTEGER klim + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION + REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE + REAL(KIND=8) PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE +c + REAL(KIND=8) PCLDLD(KDLON,KFLEV) + REAL(KIND=8) PCLDLU(KDLON,KFLEV) + REAL(KIND=8) PEMIS(KDLON) +C + REAL(KIND=8) PFLUX(KDLON,2,KFLEV+1) +C----------------------------------------------------------------------- +C* LOCAL VARIABLES: + INTEGER IMX(KDLON), IMXP(KDLON) +C + REAL(KIND=8) ZCLEAR(KDLON),ZCLOUD(KDLON), + $ ZDNF(KDLON,KFLEV+1,KFLEV+1) + S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON) + S , ZUPF(KDLON,KFLEV+1,KFLEV+1) + REAL(KIND=8) ZCLM(KDLON,KFLEV+1,KFLEV+1) +C + INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1 + INTEGER jk1, jk2, jkc, jkcp1, jcloud + INTEGER imxm1, imxp1 + REAL(KIND=8) zcfrac +C ------------------------------------------------------------------ +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C + IMAXC = 0 +C + DO 101 JL = 1, KDLON + IMX(JL)=0 + IMXP(JL)=0 + ZCLOUD(JL) = 0. + 101 CONTINUE +C +C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD +C ------------------------------------------- +C + 110 CONTINUE +C + DO 112 JK = 1 , KFLEV + DO 111 JL = 1, KDLON + IMX1=IMX(JL) + IMX2=JK + IF (PCLDLU(JL,JK).GT.ZEPSC) THEN + IMXP(JL)=IMX2 + ELSE + IMXP(JL)=IMX1 + END IF + IMAXC=MAX(IMXP(JL),IMAXC) + IMX(JL)=IMXP(JL) + 111 CONTINUE + 112 CONTINUE +CGM******* + IMAXC=KFLEV +CGM******* +C + DO 114 JK = 1 , KFLEV+1 + DO 113 JL = 1, KDLON + PFLUX(JL,1,JK) = PFLUC(JL,1,JK) + PFLUX(JL,2,JK) = PFLUC(JL,2,JK) + 113 CONTINUE + 114 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES +C --------------------------------------- +C + IF (IMAXC.GT.0) THEN +C + IMXP1 = IMAXC + 1 + IMXM1 = IMAXC - 1 +C +C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES +C ------------------------------ +C + 200 CONTINUE +C + DO 203 JK1=1,KFLEV+1 + DO 202 JK2=1,KFLEV+1 + DO 201 JL = 1, KDLON + ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1) + ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1) + 201 CONTINUE + 202 CONTINUE + 203 CONTINUE +C +C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD +C ---------------------------------------------- +C + 210 CONTINUE +C + DO 213 JKC = 1 , IMAXC + JCLOUD=JKC + JKCP1=JCLOUD+1 +C +C* 2.1.1 ABOVE THE CLOUD +C --------------- +C + 2110 CONTINUE +C + DO 2115 JK=JKCP1,KFLEV+1 + JKM1=JK-1 + DO 2111 JL = 1, KDLON + ZFU(JL)=0. + 2111 CONTINUE + IF (JK .GT. JKCP1) THEN + DO 2113 JKJ=JKCP1,JKM1 + DO 2112 JL = 1, KDLON + ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ) + 2112 CONTINUE + 2113 CONTINUE + END IF +C + DO 2114 JL = 1, KDLON + ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL) + 2114 CONTINUE + 2115 CONTINUE +C +C* 2.1.2 BELOW THE CLOUD +C --------------- +C + 2120 CONTINUE +C + DO 2125 JK=1,JCLOUD + JKP1=JK+1 + DO 2121 JL = 1, KDLON + ZFD(JL)=0. + 2121 CONTINUE +C + IF (JK .LT. JCLOUD) THEN + DO 2123 JKJ=JKP1,JCLOUD + DO 2122 JL = 1, KDLON + ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ) + 2122 CONTINUE + 2123 CONTINUE + END IF + DO 2124 JL = 1, KDLON + ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL) + 2124 CONTINUE + 2125 CONTINUE +C + 213 CONTINUE +C +C +C* 2.2 CLOUD COVER MATRIX +C ------------------ +C +C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN +C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1 +C + 220 CONTINUE +C + DO 223 JK1 = 1 , KFLEV+1 + DO 222 JK2 = 1 , KFLEV+1 + DO 221 JL = 1, KDLON + ZCLM(JL,JK1,JK2) = 0. + 221 CONTINUE + 222 CONTINUE + 223 CONTINUE +C +C +C +C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION +C ------------------------------------------ +C + 240 CONTINUE +C + DO 244 JK1 = 2 , KFLEV+1 + DO 241 JL = 1, KDLON + ZCLEAR(JL)=1. + ZCLOUD(JL)=0. + 241 CONTINUE + DO 243 JK = JK1 - 1 , 1 , -1 + DO 242 JL = 1, KDLON + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL))) + * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = PCLDLU(JL,JK) + ELSE IF (NOVLP.EQ.2) THEN +c* maximum + ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK)) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + END IF + 242 CONTINUE + 243 CONTINUE + 244 CONTINUE +C +C +C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION +C ------------------------------------------ +C + 250 CONTINUE +C + DO 254 JK1 = 1 , KFLEV + DO 251 JL = 1, KDLON + ZCLEAR(JL)=1. + ZCLOUD(JL)=0. + 251 CONTINUE + DO 253 JK = JK1 , KFLEV + DO 252 JL = 1, KDLON + IF (NOVLP.EQ.1) THEN +c* maximum-random + ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL))) + * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) + ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) + ZCLOUD(JL) = PCLDLD(JL,JK) + ELSE IF (NOVLP.EQ.2) THEN +c* maximum + ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK)) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + ELSE IF (NOVLP.EQ.3) THEN +c* random + ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK)) + ZCLOUD(JL) = 1.0 - ZCLEAR(JL) + ZCLM(JL,JK1,JK) = ZCLOUD(JL) + END IF + 252 CONTINUE + 253 CONTINUE + 254 CONTINUE +C +C +C +C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS +C ---------------------------------------------- +C + 300 CONTINUE +C +C* 3.1 DOWNWARD FLUXES +C --------------- +C + 310 CONTINUE +C + DO 311 JL = 1, KDLON + PFLUX(JL,2,KFLEV+1) = 0. + 311 CONTINUE +C + DO 317 JK1 = KFLEV , 1 , -1 +C +C* CONTRIBUTION FROM CLEAR-SKY FRACTION +C + DO 312 JL = 1, KDLON + ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1) + 312 CONTINUE +C +C* CONTRIBUTION FROM ADJACENT CLOUD +C + DO 313 JL = 1, KDLON + ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1) + 313 CONTINUE +C +C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS +C + DO 315 JK = KFLEV-1 , JK1 , -1 + DO 314 JL = 1, KDLON + ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK) + ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1) + 314 CONTINUE + 315 CONTINUE +C + DO 316 JL = 1, KDLON + PFLUX(JL,2,JK1) = ZFD (JL) + 316 CONTINUE +C + 317 CONTINUE +C +C +C +C +C* 3.2 UPWARD FLUX AT THE SURFACE +C -------------------------- +C + 320 CONTINUE +C + DO 321 JL = 1, KDLON + PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1) + 321 CONTINUE +C +C +C +C* 3.3 UPWARD FLUXES +C ------------- +C + 330 CONTINUE +C + DO 337 JK1 = 2 , KFLEV+1 +C +C* CONTRIBUTION FROM CLEAR-SKY FRACTION +C + DO 332 JL = 1, KDLON + ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1) + 332 CONTINUE +C +C* CONTRIBUTION FROM ADJACENT CLOUD +C + DO 333 JL = 1, KDLON + ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1) + 333 CONTINUE +C +C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS +C + DO 335 JK = 2 , JK1-1 + DO 334 JL = 1, KDLON + ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK) + ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1) + 334 CONTINUE + 335 CONTINUE +C + DO 336 JL = 1, KDLON + PFLUX(JL,1,JK1) = ZFU (JL) + 336 CONTINUE +C + 337 CONTINUE +C +C + END IF +C +C +C* 2.3 END OF CLOUD EFFECT COMPUTATIONS +C + 230 CONTINUE +C + IF (.NOT.LEVOIGT) THEN + DO 231 JL = 1, KDLON + ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM) + 231 CONTINUE + DO 233 JK = KLIM+1 , KFLEV+1 + DO 232 JL = 1, KDLON + ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) + PFLUX(JL,1,JK) = ZFN10(JL) + PFLUX(JL,2,JK) = 0.0 + 232 CONTINUE + 233 CONTINUE + ENDIF +C + RETURN + END + SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL + S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL + S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP) + USE dimphy + USE radiation_AR4_param, only : TINTP, XP, GA, GB + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C COMPUTES PLANCK FUNCTIONS +C +C EXPLICIT ARGUMENTS : +C -------------------- +C ==== INPUTS === +C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY +C PTAVE : (KDLON,KFLEV) ; TEMPERATURE +C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE +C ==== OUTPUTS === +C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION +C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION +C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION +C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION +C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION +C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT +C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS +C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS +C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS +C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS +C +C IMPLICIT ARGUMENTS : NONE +C -------------------- +C +C METHOD. +C ------- +C +C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS +C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS " +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C +C----------------------------------------------------------------------- +C +C ARGUMENTS: +C + REAL(KIND=8) PDT0(KDLON) + REAL(KIND=8) PTAVE(KDLON,KFLEV) + REAL(KIND=8) PTL(KDLON,KFLEV+1) +C + REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION + REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS + REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS + REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS +C +C------------------------------------------------------------------------- +C* LOCAL VARIABLES: + INTEGER INDB(KDLON),INDS(KDLON) + REAL(KIND=8) ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1) + REAL(KIND=8) ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON) +c + INTEGER jk, jl, ic, jnu, jf, jg + INTEGER jk1, jk2 + INTEGER k, j, ixtox, indto, ixtx, indt + INTEGER indsu, indtp + REAL(KIND=8) zdsto1, zdstox, zdst1, zdstx +c +C* Quelques parametres: + REAL(KIND=8) TSTAND + PARAMETER (TSTAND=250.0) + REAL(KIND=8) TSTP + PARAMETER (TSTP=12.5) + INTEGER MXIXT + PARAMETER (MXIXT=10) +C +C* Used Data Block: +c REAL*8 TINTP(11) +c SAVE TINTP +cc$OMP THREADPRIVATE(TINTP) +c REAL*8 GA(11,16,3), GB(11,16,3) +c SAVE GA, GB +cc$OMP THREADPRIVATE(GA, GB) +c REAL*8 XP(6,6) +c SAVE XP +cc$OMP THREADPRIVATE(XP) +c +c DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250., +c S 262.5, 275., 287.5, 300., 312.5 / +C----------------------------------------------------------------------- +C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ---------------- +C +C +C +C +C-- R.D. -- G = - 0.2 SLA +C +C +C----- INTERVAL = 1 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 1, 1,IC),IC=1,3) / +C S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/ +C DATA (GB( 1, 1,IC),IC=1,3) / +C S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/ +C DATA (GA( 1, 2,IC),IC=1,3) / +C S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/ +C DATA (GB( 1, 2,IC),IC=1,3) / +C S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 2, 1,IC),IC=1,3) / +C S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/ +C DATA (GB( 2, 1,IC),IC=1,3) / +C S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/ +C DATA (GA( 2, 2,IC),IC=1,3) / +C S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/ +C DATA (GB( 2, 2,IC),IC=1,3) / +C S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 3, 1,IC),IC=1,3) / +C S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/ +C DATA (GB( 3, 1,IC),IC=1,3) / +C S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/ +C DATA (GA( 3, 2,IC),IC=1,3) / +C S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/ +C DATA (GB( 3, 2,IC),IC=1,3) / +C S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 4, 1,IC),IC=1,3) / +C S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/ +C DATA (GB( 4, 1,IC),IC=1,3) / +C S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/ +C DATA (GA( 4, 2,IC),IC=1,3) / +C S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/ +C DATA (GB( 4, 2,IC),IC=1,3) / +C S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 5, 1,IC),IC=1,3) / +C S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/ +C DATA (GB( 5, 1,IC),IC=1,3) / +C S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/ +C DATA (GA( 5, 2,IC),IC=1,3) / +C S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/ +C DATA (GB( 5, 2,IC),IC=1,3) / +C S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 6, 1,IC),IC=1,3) / +C S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/ +C DATA (GB( 6, 1,IC),IC=1,3) / +C S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/ +C DATA (GA( 6, 2,IC),IC=1,3) / +C S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/ +C DATA (GB( 6, 2,IC),IC=1,3) / +C S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 7, 1,IC),IC=1,3) / +C S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/ +C DATA (GB( 7, 1,IC),IC=1,3) / +C S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/ +C DATA (GA( 7, 2,IC),IC=1,3) / +C S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/ +C DATA (GB( 7, 2,IC),IC=1,3) / +C S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 8, 1,IC),IC=1,3) / +C S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/ +C DATA (GB( 8, 1,IC),IC=1,3) / +C S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/ +C DATA (GA( 8, 2,IC),IC=1,3) / +C S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/ +C DATA (GB( 8, 2,IC),IC=1,3) / +C S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 9, 1,IC),IC=1,3) / +C S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/ +C DATA (GB( 9, 1,IC),IC=1,3) / +C S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/ +C DATA (GA( 9, 2,IC),IC=1,3) / +C S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/ +C DATA (GB( 9, 2,IC),IC=1,3) / +C S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(10, 1,IC),IC=1,3) / +C S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/ +C DATA (GB(10, 1,IC),IC=1,3) / +C S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/ +C DATA (GA(10, 2,IC),IC=1,3) / +C S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/ +C DATA (GB(10, 2,IC),IC=1,3) / +C S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/ +C +C----- INTERVAL = 1 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(11, 1,IC),IC=1,3) / +C S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/ +C DATA (GB(11, 1,IC),IC=1,3) / +C S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/ +C DATA (GA(11, 2,IC),IC=1,3) / +C S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/ +C DATA (GB(11, 2,IC),IC=1,3) / +C S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/ +C +C +C +C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 --------- +C +C +C +C +C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U ) +C +C +C----- INTERVAL = 2 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 1, 3,IC),IC=1,3) / +C S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/ +C DATA (GB( 1, 3,IC),IC=1,3) / +C S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/ +C DATA (GA( 1, 4,IC),IC=1,3) / +C S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/ +C DATA (GB( 1, 4,IC),IC=1,3) / +C S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 2, 3,IC),IC=1,3) / +C S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/ +C DATA (GB( 2, 3,IC),IC=1,3) / +C S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/ +C DATA (GA( 2, 4,IC),IC=1,3) / +C S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/ +C DATA (GB( 2, 4,IC),IC=1,3) / +C S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 3, 3,IC),IC=1,3) / +C S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/ +C DATA (GB( 3, 3,IC),IC=1,3) / +C S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/ +C DATA (GA( 3, 4,IC),IC=1,3) / +C S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/ +C DATA (GB( 3, 4,IC),IC=1,3) / +C S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 4, 3,IC),IC=1,3) / +C S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/ +C DATA (GB( 4, 3,IC),IC=1,3) / +C S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/ +C DATA (GA( 4, 4,IC),IC=1,3) / +C S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/ +C DATA (GB( 4, 4,IC),IC=1,3) / +C S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 5, 3,IC),IC=1,3) / +C S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/ +C DATA (GB( 5, 3,IC),IC=1,3) / +C S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/ +C DATA (GA( 5, 4,IC),IC=1,3) / +C S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/ +C DATA (GB( 5, 4,IC),IC=1,3) / +C S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 6, 3,IC),IC=1,3) / +C S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/ +C DATA (GB( 6, 3,IC),IC=1,3) / +C S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/ +C DATA (GA( 6, 4,IC),IC=1,3) / +C S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/ +C DATA (GB( 6, 4,IC),IC=1,3) / +C S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 7, 3,IC),IC=1,3) / +C S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/ +C DATA (GB( 7, 3,IC),IC=1,3) / +C S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/ +C DATA (GA( 7, 4,IC),IC=1,3) / +C S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/ +C DATA (GB( 7, 4,IC),IC=1,3) / +C S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 8, 3,IC),IC=1,3) / +C S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/ +C DATA (GB( 8, 3,IC),IC=1,3) / +C S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/ +C DATA (GA( 8, 4,IC),IC=1,3) / +C S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/ +C DATA (GB( 8, 4,IC),IC=1,3) / +C S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 9, 3,IC),IC=1,3) / +C S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/ +C DATA (GB( 9, 3,IC),IC=1,3) / +C S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/ +C DATA (GA( 9, 4,IC),IC=1,3) / +C S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/ +C DATA (GB( 9, 4,IC),IC=1,3) / +C S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(10, 3,IC),IC=1,3) / +C S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/ +C DATA (GB(10, 3,IC),IC=1,3) / +C S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/ +C DATA (GA(10, 4,IC),IC=1,3) / +C S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/ +C DATA (GB(10, 4,IC),IC=1,3) / +C S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(11, 3,IC),IC=1,3) / +C S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/ +C DATA (GB(11, 3,IC),IC=1,3) / +C S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/ +C DATA (GA(11, 4,IC),IC=1,3) / +C S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/ +C DATA (GB(11, 4,IC),IC=1,3) / +C S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/ +C +C +C +C +C +C +C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS - +C +C +C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1) +C +C +C +C--- G = 3.875E-03 --------------- +C +C----- INTERVAL = 3 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 1, 7,IC),IC=1,3) / +C S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/ +C DATA (GB( 1, 7,IC),IC=1,3) / +C S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/ +C DATA (GA( 1, 8,IC),IC=1,3) / +C S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/ +C DATA (GB( 1, 8,IC),IC=1,3) / +C S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 2, 7,IC),IC=1,3) / +C S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/ +C DATA (GB( 2, 7,IC),IC=1,3) / +C S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/ +C DATA (GA( 2, 8,IC),IC=1,3) / +C S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/ +C DATA (GB( 2, 8,IC),IC=1,3) / +C S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 3, 7,IC),IC=1,3) / +C S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/ +C DATA (GB( 3, 7,IC),IC=1,3) / +C S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/ +C DATA (GA( 3, 8,IC),IC=1,3) / +C S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/ +C DATA (GB( 3, 8,IC),IC=1,3) / +C S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 4, 7,IC),IC=1,3) / +C S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/ +C DATA (GB( 4, 7,IC),IC=1,3) / +C S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/ +C DATA (GA( 4, 8,IC),IC=1,3) / +C S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/ +C DATA (GB( 4, 8,IC),IC=1,3) / +C S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 5, 7,IC),IC=1,3) / +C S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/ +C DATA (GB( 5, 7,IC),IC=1,3) / +C S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/ +C DATA (GA( 5, 8,IC),IC=1,3) / +C S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/ +C DATA (GB( 5, 8,IC),IC=1,3) / +C S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 6, 7,IC),IC=1,3) / +C S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/ +C DATA (GB( 6, 7,IC),IC=1,3) / +C S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/ +C DATA (GA( 6, 8,IC),IC=1,3) / +C S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/ +C DATA (GB( 6, 8,IC),IC=1,3) / +C S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 7, 7,IC),IC=1,3) / +C S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/ +C DATA (GB( 7, 7,IC),IC=1,3) / +C S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/ +C DATA (GA( 7, 8,IC),IC=1,3) / +C S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/ +C DATA (GB( 7, 8,IC),IC=1,3) / +C S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 8, 7,IC),IC=1,3) / +C S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/ +C DATA (GB( 8, 7,IC),IC=1,3) / +C S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/ +C DATA (GA( 8, 8,IC),IC=1,3) / +C S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/ +C DATA (GB( 8, 8,IC),IC=1,3) / +C S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 9, 7,IC),IC=1,3) / +C S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/ +C DATA (GB( 9, 7,IC),IC=1,3) / +C S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/ +C DATA (GA( 9, 8,IC),IC=1,3) / +C S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/ +C DATA (GB( 9, 8,IC),IC=1,3) / +C S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(10, 7,IC),IC=1,3) / +C S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/ +C DATA (GB(10, 7,IC),IC=1,3) / +C S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/ +C DATA (GA(10, 8,IC),IC=1,3) / +C S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/ +C DATA (GB(10, 8,IC),IC=1,3) / +C S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/ +C +C----- INTERVAL = 3 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(11, 7,IC),IC=1,3) / +C S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/ +C DATA (GB(11, 7,IC),IC=1,3) / +C S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/ +C DATA (GA(11, 8,IC),IC=1,3) / +C S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/ +C DATA (GB(11, 8,IC),IC=1,3) / +C S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/ +C +C +C-- WATER VAPOR -- 970-1110 CM-1 ---------------------------------------- +C +C-- G = 3.6E-03 +C +C----- INTERVAL = 4 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 1, 9,IC),IC=1,3) / +C S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/ +C DATA (GB( 1, 9,IC),IC=1,3) / +C S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/ +C DATA (GA( 1,10,IC),IC=1,3) / +C S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/ +C DATA (GB( 1,10,IC),IC=1,3) / +C S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 2, 9,IC),IC=1,3) / +C S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/ +C DATA (GB( 2, 9,IC),IC=1,3) / +C S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/ +C DATA (GA( 2,10,IC),IC=1,3) / +C S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/ +C DATA (GB( 2,10,IC),IC=1,3) / +C S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 3, 9,IC),IC=1,3) / +C S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/ +C DATA (GB( 3, 9,IC),IC=1,3) / +C S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/ +C DATA (GA( 3,10,IC),IC=1,3) / +C S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/ +C DATA (GB( 3,10,IC),IC=1,3) / +C S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 4, 9,IC),IC=1,3) / +C S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/ +C DATA (GB( 4, 9,IC),IC=1,3) / +C S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/ +C DATA (GA( 4,10,IC),IC=1,3) / +C S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/ +C DATA (GB( 4,10,IC),IC=1,3) / +C S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 5, 9,IC),IC=1,3) / +C S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/ +C DATA (GB( 5, 9,IC),IC=1,3) / +C S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/ +C DATA (GA( 5,10,IC),IC=1,3) / +C S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/ +C DATA (GB( 5,10,IC),IC=1,3) / +C S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 6, 9,IC),IC=1,3) / +C S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/ +C DATA (GB( 6, 9,IC),IC=1,3) / +C S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/ +C DATA (GA( 6,10,IC),IC=1,3) / +C S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/ +C DATA (GB( 6,10,IC),IC=1,3) / +C S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 7, 9,IC),IC=1,3) / +C S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/ +C DATA (GB( 7, 9,IC),IC=1,3) / +C S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/ +C DATA (GA( 7,10,IC),IC=1,3) / +C S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/ +C DATA (GB( 7,10,IC),IC=1,3) / +C S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 8, 9,IC),IC=1,3) / +C S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/ +C DATA (GB( 8, 9,IC),IC=1,3) / +C S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/ +C DATA (GA( 8,10,IC),IC=1,3) / +C S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/ +C DATA (GB( 8,10,IC),IC=1,3) / +C S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA( 9, 9,IC),IC=1,3) / +C S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/ +C DATA (GB( 9, 9,IC),IC=1,3) / +C S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/ +C DATA (GA( 9,10,IC),IC=1,3) / +C S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/ +C DATA (GB( 9,10,IC),IC=1,3) / +C S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(10, 9,IC),IC=1,3) / +C S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/ +C DATA (GB(10, 9,IC),IC=1,3) / +C S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/ +C DATA (GA(10,10,IC),IC=1,3) / +C S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/ +C DATA (GB(10,10,IC),IC=1,3) / +C S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 +C DATA (GA(11, 9,IC),IC=1,3) / +C S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/ +C DATA (GB(11, 9,IC),IC=1,3) / +C S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/ +C DATA (GA(11,10,IC),IC=1,3) / +C S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/ +C DATA (GB(11,10,IC),IC=1,3) / +C S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/ +C +C +C +C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ---- +C +C-- WATER VAPOR --- 350 - 500 CM-1 +C +C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U) +C +C----- INTERVAL = 5 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 1, 5,IC),IC=1,3) / +C S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/ +C DATA (GB( 1, 5,IC),IC=1,3) / +C S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/ +C DATA (GA( 1, 6,IC),IC=1,3) / +C S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/ +C DATA (GB( 1, 6,IC),IC=1,3) / +C S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 2, 5,IC),IC=1,3) / +C S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/ +C DATA (GB( 2, 5,IC),IC=1,3) / +C S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/ +C DATA (GA( 2, 6,IC),IC=1,3) / +C S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/ +C DATA (GB( 2, 6,IC),IC=1,3) / +C S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 3, 5,IC),IC=1,3) / +C S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/ +C DATA (GB( 3, 5,IC),IC=1,3) / +C S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/ +C DATA (GA( 3, 6,IC),IC=1,3) / +C S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/ +C DATA (GB( 3, 6,IC),IC=1,3) / +C S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 4, 5,IC),IC=1,3) / +C S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/ +C DATA (GB( 4, 5,IC),IC=1,3) / +C S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/ +C DATA (GA( 4, 6,IC),IC=1,3) / +C S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/ +C DATA (GB( 4, 6,IC),IC=1,3) / +C S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 5, 5,IC),IC=1,3) / +C S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/ +C DATA (GB( 5, 5,IC),IC=1,3) / +C S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/ +C DATA (GA( 5, 6,IC),IC=1,3) / +C S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/ +C DATA (GB( 5, 6,IC),IC=1,3) / +C S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 6, 5,IC),IC=1,3) / +C S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/ +C DATA (GB( 6, 5,IC),IC=1,3) / +C S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/ +C DATA (GA( 6, 6,IC),IC=1,3) / +C S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/ +C DATA (GB( 6, 6,IC),IC=1,3) / +C S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 7, 5,IC),IC=1,3) / +C S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/ +C DATA (GB( 7, 5,IC),IC=1,3) / +C S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/ +C DATA (GA( 7, 6,IC),IC=1,3) / +C S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/ +C DATA (GB( 7, 6,IC),IC=1,3) / +C S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 8, 5,IC),IC=1,3) / +C S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/ +C DATA (GB( 8, 5,IC),IC=1,3) / +C S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/ +C DATA (GA( 8, 6,IC),IC=1,3) / +C S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/ +C DATA (GB( 8, 6,IC),IC=1,3) / +C S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 9, 5,IC),IC=1,3) / +C S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/ +C DATA (GB( 9, 5,IC),IC=1,3) / +C S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/ +C DATA (GA( 9, 6,IC),IC=1,3) / +C S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/ +C DATA (GB( 9, 6,IC),IC=1,3) / +C S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(10, 5,IC),IC=1,3) / +C S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/ +C DATA (GB(10, 5,IC),IC=1,3) / +C S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/ +C DATA (GA(10, 6,IC),IC=1,3) / +C S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/ +C DATA (GB(10, 6,IC),IC=1,3) / +C S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/ +C +C----- INTERVAL = 5 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(11, 5,IC),IC=1,3) / +C S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/ +C DATA (GB(11, 5,IC),IC=1,3) / +C S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/ +C DATA (GA(11, 6,IC),IC=1,3) / +C S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/ +C DATA (GB(11, 6,IC),IC=1,3) / +C S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/ +C +C +C +C +C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 - +C--- G = 0.0 +C +C +C----- INTERVAL = 6 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 1,11,IC),IC=1,3) / +C S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/ +C DATA (GB( 1,11,IC),IC=1,3) / +C S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/ +C DATA (GA( 1,12,IC),IC=1,3) / +C S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/ +C DATA (GB( 1,12,IC),IC=1,3) / +C S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 2,11,IC),IC=1,3) / +C S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/ +C DATA (GB( 2,11,IC),IC=1,3) / +C S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/ +C DATA (GA( 2,12,IC),IC=1,3) / +C S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/ +C DATA (GB( 2,12,IC),IC=1,3) / +C S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 3,11,IC),IC=1,3) / +C S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/ +C DATA (GB( 3,11,IC),IC=1,3) / +C S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/ +C DATA (GA( 3,12,IC),IC=1,3) / +C S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/ +C DATA (GB( 3,12,IC),IC=1,3) / +C S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 4,11,IC),IC=1,3) / +C S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/ +C DATA (GB( 4,11,IC),IC=1,3) / +C S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/ +C DATA (GA( 4,12,IC),IC=1,3) / +C S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/ +C DATA (GB( 4,12,IC),IC=1,3) / +C S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 5,11,IC),IC=1,3) / +C S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/ +C DATA (GB( 5,11,IC),IC=1,3) / +C S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/ +C DATA (GA( 5,12,IC),IC=1,3) / +C S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/ +C DATA (GB( 5,12,IC),IC=1,3) / +C S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 6,11,IC),IC=1,3) / +C S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/ +C DATA (GB( 6,11,IC),IC=1,3) / +C S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/ +C DATA (GA( 6,12,IC),IC=1,3) / +C S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/ +C DATA (GB( 6,12,IC),IC=1,3) / +C S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 7,11,IC),IC=1,3) / +C S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/ +C DATA (GB( 7,11,IC),IC=1,3) / +C S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/ +C DATA (GA( 7,12,IC),IC=1,3) / +C S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/ +C DATA (GB( 7,12,IC),IC=1,3) / +C S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 8,11,IC),IC=1,3) / +C S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/ +C DATA (GB( 8,11,IC),IC=1,3) / +C S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/ +C DATA (GA( 8,12,IC),IC=1,3) / +C S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/ +C DATA (GB( 8,12,IC),IC=1,3) / +C S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA( 9,11,IC),IC=1,3) / +C S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/ +C DATA (GB( 9,11,IC),IC=1,3) / +C S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/ +C DATA (GA( 9,12,IC),IC=1,3) / +C S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/ +C DATA (GB( 9,12,IC),IC=1,3) / +C S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(10,11,IC),IC=1,3) / +C S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/ +C DATA (GB(10,11,IC),IC=1,3) / +C S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/ +C DATA (GA(10,12,IC),IC=1,3) / +C S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/ +C DATA (GB(10,12,IC),IC=1,3) / +C S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/ +C +C----- INTERVAL = 6 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 +C DATA (GA(11,11,IC),IC=1,3) / +C S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/ +C DATA (GB(11,11,IC),IC=1,3) / +C S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/ +C DATA (GA(11,12,IC),IC=1,3) / +C S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/ +C DATA (GB(11,12,IC),IC=1,3) / +C S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/ +C +C +C +C +C +C-- END WATER VAPOR +C +C +C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ---------------------- +C +C +C +C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9 +C +C----- INTERVAL = 2 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 1,13,IC),IC=1,3) / +C S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/ +C DATA (GB( 1,13,IC),IC=1,3) / +C S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/ +C DATA (GA( 1,14,IC),IC=1,3) / +C S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/ +C DATA (GB( 1,14,IC),IC=1,3) / +C S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 2,13,IC),IC=1,3) / +C S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/ +C DATA (GB( 2,13,IC),IC=1,3) / +C S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/ +C DATA (GA( 2,14,IC),IC=1,3) / +C S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/ +C DATA (GB( 2,14,IC),IC=1,3) / +C S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 3,13,IC),IC=1,3) / +C S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/ +C DATA (GB( 3,13,IC),IC=1,3) / +C S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/ +C DATA (GA( 3,14,IC),IC=1,3) / +C S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/ +C DATA (GB( 3,14,IC),IC=1,3) / +C S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 4,13,IC),IC=1,3) / +C S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/ +C DATA (GB( 4,13,IC),IC=1,3) / +C S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/ +C DATA (GA( 4,14,IC),IC=1,3) / +C S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/ +C DATA (GB( 4,14,IC),IC=1,3) / +C S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 5,13,IC),IC=1,3) / +C S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/ +C DATA (GB( 5,13,IC),IC=1,3) / +C S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/ +C DATA (GA( 5,14,IC),IC=1,3) / +C S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/ +C DATA (GB( 5,14,IC),IC=1,3) / +C S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 6,13,IC),IC=1,3) / +C S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/ +C DATA (GB( 6,13,IC),IC=1,3) / +C S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/ +C DATA (GA( 6,14,IC),IC=1,3) / +C S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/ +C DATA (GB( 6,14,IC),IC=1,3) / +C S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 7,13,IC),IC=1,3) / +C S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/ +C DATA (GB( 7,13,IC),IC=1,3) / +C S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/ +C DATA (GA( 7,14,IC),IC=1,3) / +C S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/ +C DATA (GB( 7,14,IC),IC=1,3) / +C S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 8,13,IC),IC=1,3) / +C S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/ +C DATA (GB( 8,13,IC),IC=1,3) / +C S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/ +C DATA (GA( 8,14,IC),IC=1,3) / +C S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/ +C DATA (GB( 8,14,IC),IC=1,3) / +C S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA( 9,13,IC),IC=1,3) / +C S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/ +C DATA (GB( 9,13,IC),IC=1,3) / +C S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/ +C DATA (GA( 9,14,IC),IC=1,3) / +C S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/ +C DATA (GB( 9,14,IC),IC=1,3) / +C S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA(10,13,IC),IC=1,3) / +C S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/ +C DATA (GB(10,13,IC),IC=1,3) / +C S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/ +C DATA (GA(10,14,IC),IC=1,3) / +C S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/ +C DATA (GB(10,14,IC),IC=1,3) / +C S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/ +C +C----- INTERVAL = 2 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 +C DATA (GA(11,13,IC),IC=1,3) / +C S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/ +C DATA (GB(11,13,IC),IC=1,3) / +C S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/ +C DATA (GA(11,14,IC),IC=1,3) / +C S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/ +C DATA (GB(11,14,IC),IC=1,3) / +C S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/ +C +C +C +C +C +C +C +C +C +C +C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1) +C +C +C-- G = 0.0 +C +C +C----- INTERVAL = 4 ----- T = 187.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 1,15,IC),IC=1,3) / +C S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/ +C DATA (GB( 1,15,IC),IC=1,3) / +C S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/ +C DATA (GA( 1,16,IC),IC=1,3) / +C S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/ +C DATA (GB( 1,16,IC),IC=1,3) / +C S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 200.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 2,15,IC),IC=1,3) / +C S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/ +C DATA (GB( 2,15,IC),IC=1,3) / +C S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/ +C DATA (GA( 2,16,IC),IC=1,3) / +C S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/ +C DATA (GB( 2,16,IC),IC=1,3) / +C S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 212.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 3,15,IC),IC=1,3) / +C S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/ +C DATA (GB( 3,15,IC),IC=1,3) / +C S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/ +C DATA (GA( 3,16,IC),IC=1,3) / +C S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/ +C DATA (GB( 3,16,IC),IC=1,3) / +C S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 225.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 4,15,IC),IC=1,3) / +C S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/ +C DATA (GB( 4,15,IC),IC=1,3) / +C S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/ +C DATA (GA( 4,16,IC),IC=1,3) / +C S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/ +C DATA (GB( 4,16,IC),IC=1,3) / +C S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 237.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 5,15,IC),IC=1,3) / +C S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/ +C DATA (GB( 5,15,IC),IC=1,3) / +C S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/ +C DATA (GA( 5,16,IC),IC=1,3) / +C S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/ +C DATA (GB( 5,16,IC),IC=1,3) / +C S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 250.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 6,15,IC),IC=1,3) / +C S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/ +C DATA (GB( 6,15,IC),IC=1,3) / +C S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/ +C DATA (GA( 6,16,IC),IC=1,3) / +C S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/ +C DATA (GB( 6,16,IC),IC=1,3) / +C S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 262.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 7,15,IC),IC=1,3) / +C S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/ +C DATA (GB( 7,15,IC),IC=1,3) / +C S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/ +C DATA (GA( 7,16,IC),IC=1,3) / +C S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/ +C DATA (GB( 7,16,IC),IC=1,3) / +C S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 275.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 8,15,IC),IC=1,3) / +C S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/ +C DATA (GB( 8,15,IC),IC=1,3) / +C S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/ +C DATA (GA( 8,16,IC),IC=1,3) / +C S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/ +C DATA (GB( 8,16,IC),IC=1,3) / +C S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 287.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA( 9,15,IC),IC=1,3) / +C S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/ +C DATA (GB( 9,15,IC),IC=1,3) / +C S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/ +C DATA (GA( 9,16,IC),IC=1,3) / +C S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/ +C DATA (GB( 9,16,IC),IC=1,3) / +C S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 300.0 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(10,15,IC),IC=1,3) / +C S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/ +C DATA (GB(10,15,IC),IC=1,3) / +C S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/ +C DATA (GA(10,16,IC),IC=1,3) / +C S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/ +C DATA (GB(10,16,IC),IC=1,3) / +C S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/ +C +C----- INTERVAL = 4 ----- T = 312.5 +C +C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 +C DATA (GA(11,15,IC),IC=1,3) / +C S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/ +C DATA (GB(11,15,IC),IC=1,3) / +C S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/ +C DATA (GA(11,16,IC),IC=1,3) / +C S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/ +C DATA (GB(11,16,IC),IC=1,3) / +C S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/ +C +C ------------------------------------------------------------------ +C DATA (( XP( J,K),J=1,6), K=1,6) / +C S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, +C S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03, +C S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, +C S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02, +C S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, +C S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02, +C S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, +C S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02, +C S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, +C S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01, +C S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, +C S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 / + +C +C +C* 1.0 PLANCK FUNCTIONS AND GRADIENTS +C ------------------------------ +C + 100 CONTINUE +C +!cdir collapse + DO 102 JK = 1 , KFLEV+1 + DO 101 JL = 1, KDLON + PBINT(JL,JK) = 0. + 101 CONTINUE + 102 CONTINUE + DO 103 JL = 1, KDLON + PBSUIN(JL) = 0. + 103 CONTINUE +C + DO 141 JNU=1,Ninter +C +C +C* 1.1 LEVELS FROM SURFACE TO KFLEV +C ---------------------------- +C + 110 CONTINUE +C + DO 112 JK = 1 , KFLEV + DO 111 JL = 1, KDLON + ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND + ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) + S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) + S ))))) + PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL) + PB(JL,JNU,JK)= ZRES(JL) + ZBLEV(JL,JK) = ZRES(JL) + ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND + ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) + S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) + S ))))) + ZBLAY(JL,JK) = ZRES2(JL) + 111 CONTINUE + 112 CONTINUE +C +C +C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE +C --------------------------------- +C + 120 CONTINUE +C + DO 121 JL = 1, KDLON + ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND + ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND + ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) + S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) + S ))))) + ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) + S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) + S ))))) + PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL) + PB(JL,JNU,KFLEV+1)= ZRES(JL) + ZBLEV(JL,KFLEV+1) = ZRES(JL) + PBTOP(JL,JNU) = ZRES(JL) + PBSUR(JL,JNU) = ZRES2(JL) + PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL) + 121 CONTINUE +C +C +C* 1.3 GRADIENTS IN SUB-LAYERS +C ----------------------- +C + 130 CONTINUE +C + DO 132 JK = 1 , KFLEV + JK2 = 2 * JK + JK1 = JK2 - 1 + DO 131 JL = 1, KDLON + PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK) + PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK) + 131 CONTINUE + 132 CONTINUE +C + 141 CONTINUE +C +C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS +C --------------------------------------------- +C + 200 CONTINUE +C +C + 210 CONTINUE +C + DO 211 JL=1, KDLON + ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP + IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) ) + ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP + IF (ZDSTOX.LT.0.5) THEN + INDTO=IXTOX + ELSE + INDTO=IXTOX+1 + END IF + INDB(JL)=INDTO + ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP + IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) + ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP + IF (ZDSTX.LT.0.5) THEN + INDT=IXTX + ELSE + INDT=IXTX+1 + END IF + INDS(JL)=INDT + 211 CONTINUE +C + DO 214 JF=1,2 + DO 213 JG=1, 8 + DO 212 JL=1, KDLON + INDSU=INDS(JL) + PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF) + PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF) + INDTP=INDB(JL) + PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF) + PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF) + 212 CONTINUE + 213 CONTINUE + 214 CONTINUE +C + 220 CONTINUE +C + DO 225 JK=1,KFLEV + DO 221 JL=1, KDLON + ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP + IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) + ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP + IF (ZDSTX.LT.0.5) THEN + INDT=IXTX + ELSE + INDT=IXTX+1 + END IF + INDB(JL)=INDT + 221 CONTINUE +C + DO 224 JF=1,2 + DO 223 JG=1, 8 + DO 222 JL=1, KDLON + INDT=INDB(JL) + PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF) + PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF) + 222 CONTINUE + 223 CONTINUE + 224 CONTINUE + 225 CONTINUE +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM + R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE + R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP + S , PCNTRB,PCTS,PFLUC) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "YOMCST.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE +C FLUXES OR RADIANCES +C +C METHOD. +C ------- +C +C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN +C CONTRIBUTIONS BY - THE NEARBY LAYERS +C - THE DISTANT LAYERS +C - THE BOUNDARY TERMS +C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +C +C* ARGUMENTS: + INTEGER KUAER,KTRAER, KLIM +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS + REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION + REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! TEMPERATURE + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGASUR(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGATOP(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS +C + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX + REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES +C----------------------------------------------------------------------- +C LOCAL VARIABLES: + REAL(KIND=8) ZADJD(KDLON,KFLEV+1) + REAL(KIND=8) ZADJU(KDLON,KFLEV+1) + REAL(KIND=8) ZDBDT(KDLON,Ninter,KFLEV) + REAL(KIND=8) ZDISD(KDLON,KFLEV+1) + REAL(KIND=8) ZDISU(KDLON,KFLEV+1) +C + INTEGER jk, jl +C----------------------------------------------------------------------- +C + DO 112 JK=1,KFLEV+1 + DO 111 JL=1, KDLON + ZADJD(JL,JK)=0. + ZADJU(JL,JK)=0. + ZDISD(JL,JK)=0. + ZDISU(JL,JK)=0. + 111 CONTINUE + 112 CONTINUE +C + DO 114 JK=1,KFLEV + DO 113 JL=1, KDLON + PCTS(JL,JK)=0. + 113 CONTINUE + 114 CONTINUE +C +C* CONTRIBUTION FROM ADJACENT LAYERS +C + CALL LWVN_LMDAR4(KUAER,KTRAER + R , PABCU,PDBSL,PGA,PGB + S , ZADJD,ZADJU,PCNTRB,ZDBDT) +C* CONTRIBUTION FROM DISTANT LAYERS +C + CALL LWVD_LMDAR4(KUAER,KTRAER + R , PABCU,ZDBDT,PGA,PGB + S , PCNTRB,ZDISD,ZDISU) +C +C* EXCHANGE WITH THE BOUNDARIES +C + CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM + R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP + R , ZDISD,ZDISU,PEMIS,PPMB + R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP + S , PCTS,PFLUC) +C +C + RETURN + END + SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM + R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP + R , PDISD,PDISU,PEMIS,PPMB + R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP + S , PCTS,PFLUC) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +#include "radopt.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL +C INTEGRATION +C +C METHOD. +C ------- +C +C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE +C ATMOSPHERE +C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND +C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA +C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96 +C----------------------------------------------------------------------- +C +C* 0.1 ARGUMENTS +C --------- +C + INTEGER KUAER,KTRAER, KLIM +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS + REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS + REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS + REAL(KIND=8) PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION + REAL(KIND=8) PBSUI(KDLON) ! SURFACE PLANCK FUNCTION + REAL(KIND=8) PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION + REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! PRESSURE MB + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS + REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS + REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS +C + REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES + REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZBGND(KDLON) + REAL(KIND=8) ZFD(KDLON) + REAL(KIND=8) ZFN10(KDLON) + REAL(KIND=8) ZFU(KDLON) + REAL(KIND=8) ZTT(KDLON,NTRA) + REAL(KIND=8) ZTT1(KDLON,NTRA) + REAL(KIND=8) ZTT2(KDLON,NTRA) + REAL(KIND=8) ZUU(KDLON,NUA) + REAL(KIND=8) ZCNSOL(KDLON) + REAL(KIND=8) ZCNTOP(KDLON) +C + INTEGER jk, jl, ja + INTEGER jstra, jstru + INTEGER ind1, ind2, ind3, ind4, in, jlim + REAL(KIND=8) zctstr +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C +C +C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS +C --------------------------------- +C + 120 CONTINUE +C + DO 122 JA=1,NTRA + DO 121 JL=1, KDLON + ZTT (JL,JA)=1.0 + ZTT1(JL,JA)=1.0 + ZTT2(JL,JA)=1.0 + 121 CONTINUE + 122 CONTINUE +C + DO 124 JA=1,NUA + DO 123 JL=1, KDLON + ZUU(JL,JA)=1.0 + 123 CONTINUE + 124 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. VERTICAL INTEGRATION +C -------------------- +C + 200 CONTINUE +C + IND1=0 + IND3=0 + IND4=1 + IND2=1 +C +C +C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE +C ----------------------------------- +C + 230 CONTINUE +C + DO 235 JK = 1 , KFLEV + IN=(JK-1)*NG1P1+1 +C + DO 232 JA=1,KUAER + DO 231 JL=1, KDLON + ZUU(JL,JA)=PABCU(JL,JA,IN) + 231 CONTINUE + 232 CONTINUE +C +C + CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT) +C + DO 234 JL = 1, KDLON + ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1) *ZTT(JL,10) + 2 +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + 3 +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + 4 +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + 5 +PBTOP(JL,5)*ZTT(JL,3) *ZTT(JL,14) + 6 +PBTOP(JL,6)*ZTT(JL,6) *ZTT(JL,15) + ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) + PFLUC(JL,2,JK)=ZFD(JL) + 234 CONTINUE +C + 235 CONTINUE +C + JK = KFLEV+1 + IN=(JK-1)*NG1P1+1 +C + DO 236 JL = 1, KDLON + ZCNTOP(JL)= PBTOP(JL,1) + 1 + PBTOP(JL,2) + 2 + PBTOP(JL,3) + 3 + PBTOP(JL,4) + 4 + PBTOP(JL,5) + 5 + PBTOP(JL,6) + ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) + PFLUC(JL,2,JK)=ZFD(JL) + 236 CONTINUE +C +C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA +C --------------------------------------- +C + 240 CONTINUE +C +C +C* 2.4.1 INITIALIZATION +C -------------- +C + 2410 CONTINUE +C + JLIM = KFLEV +C + IF (.NOT.LEVOIGT) THEN + DO 2412 JK = KFLEV,1,-1 + IF(PPMB(1,JK).LT.10.0) THEN + JLIM=JK + ENDIF + 2412 CONTINUE + ENDIF + KLIM=JLIM +C + IF (.NOT.LEVOIGT) THEN + DO 2414 JA=1,KTRAER + DO 2413 JL=1, KDLON + ZTT1(JL,JA)=1.0 + 2413 CONTINUE + 2414 CONTINUE +C +C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA +C ----------------------------- +C + 2420 CONTINUE +C + DO 2427 JSTRA = KFLEV,JLIM,-1 + JSTRU=(JSTRA-1)*NG1P1+1 +C + DO 2423 JA=1,KUAER + DO 2422 JL=1, KDLON + ZUU(JL,JA)=PABCU(JL,JA,JSTRU) + 2422 CONTINUE + 2423 CONTINUE +C +C + CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT) +C + DO 2424 JL = 1, KDLON + ZCTSTR = + 1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1)) + 1 *(ZTT1(JL,1) *ZTT1(JL,10) + 1 - ZTT (JL,1) *ZTT (JL,10)) + 2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1)) + 2 *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11) + 2 - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11)) + 3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1)) + 3 *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12) + 3 - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12)) + 4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1)) + 4 *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13) + 4 - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13)) + 5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1)) + 5 *(ZTT1(JL,3) *ZTT1(JL,14) + 5 - ZTT (JL,3) *ZTT (JL,14)) + 6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1)) + 6 *(ZTT1(JL,6) *ZTT1(JL,15) + 6 - ZTT (JL,6) *ZTT (JL,15)) + PCTS(JL,JSTRA)=ZCTSTR*0.5 + 2424 CONTINUE + DO 2426 JA=1,KTRAER + DO 2425 JL=1, KDLON + ZTT1(JL,JA)=ZTT(JL,JA) + 2425 CONTINUE + 2426 CONTINUE + 2427 CONTINUE + ENDIF +C Mise a zero de securite pour PCTS en cas de LEVOIGT + IF(LEVOIGT)THEN + DO 2429 JSTRA = 1,KFLEV + DO 2428 JL = 1, KDLON + PCTS(JL,JSTRA)=0. + 2428 CONTINUE + 2429 CONTINUE + ENDIF +C +C +C* 2.5 EXCHANGE WITH LOWER LIMIT +C ------------------------- +C + 250 CONTINUE +C + DO 251 JL = 1, KDLON + ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL)) + S *PFLUC(JL,2,1)-PBINT(JL,1) + 251 CONTINUE +C + JK = 1 + IN=(JK-1)*NG1P1+1 +C + DO 252 JL = 1, KDLON + ZCNSOL(JL)=PBSUR(JL,1) + 1 +PBSUR(JL,2) + 2 +PBSUR(JL,3) + 3 +PBSUR(JL,4) + 4 +PBSUR(JL,5) + 5 +PBSUR(JL,6) + ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) + ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) + PFLUC(JL,1,JK)=ZFU(JL) + 252 CONTINUE +C + DO 257 JK = 2 , KFLEV+1 + IN=(JK-1)*NG1P1+1 +C +C + DO 255 JA=1,KUAER + DO 254 JL=1, KDLON + ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN) + 254 CONTINUE + 255 CONTINUE +C +C + CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT) +C + DO 256 JL = 1, KDLON + ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1) *ZTT(JL,10) + 2 +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + 3 +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + 4 +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + 5 +PBSUR(JL,5)*ZTT(JL,3) *ZTT(JL,14) + 6 +PBSUR(JL,6)*ZTT(JL,6) *ZTT(JL,15) + ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) + ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) + PFLUC(JL,1,JK)=ZFU(JL) + 256 CONTINUE +C +C + 257 CONTINUE +C +C +C +C* 2.7 CLEAR-SKY FLUXES +C ---------------- +C + 270 CONTINUE +C + IF (.NOT.LEVOIGT) THEN + DO 271 JL = 1, KDLON + ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM) + 271 CONTINUE + DO 273 JK = JLIM+1,KFLEV+1 + DO 272 JL = 1, KDLON + ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) + PFLUC(JL,1,JK) = ZFN10(JL) + PFLUC(JL,2,JK) = 0. + 272 CONTINUE + 273 CONTINUE + ENDIF +C +C ------------------------------------------------------------------ +C + RETURN + END + SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER + S , PABCU,PDBDT + R , PGA,PGB + S , PCNTRB,PDISD,PDISU) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS +C +C METHOD. +C ------- +C +C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE +C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +C* ARGUMENTS: +C + INTEGER KUAER,KTRAER +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS +C + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX + REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS + REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) ZGLAYD(KDLON) + REAL(KIND=8) ZGLAYU(KDLON) + REAL(KIND=8) ZTT(KDLON,NTRA) + REAL(KIND=8) ZTT1(KDLON,NTRA) + REAL(KIND=8) ZTT2(KDLON,NTRA) +C + INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2 + INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2 + INTEGER ind1, ind2, ind3, ind4, itt + REAL(KIND=8) zww, zdzxdg, zdzxmg +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C +C* 1.1 INITIALIZE LAYER CONTRIBUTIONS +C ------------------------------ +C + 110 CONTINUE +C + DO 112 JK = 1, KFLEV+1 + DO 111 JL = 1, KDLON + PDISD(JL,JK) = 0. + PDISU(JL,JK) = 0. + 111 CONTINUE + 112 CONTINUE +C +C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS +C --------------------------------- +C + 120 CONTINUE +C +C + DO 122 JA = 1, NTRA + DO 121 JL = 1, KDLON + ZTT (JL,JA) = 1.0 + ZTT1(JL,JA) = 1.0 + ZTT2(JL,JA) = 1.0 + 121 CONTINUE + 122 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. VERTICAL INTEGRATION +C -------------------- +C + 200 CONTINUE +C + IND1=0 + IND3=0 + IND4=1 + IND2=1 +C +C +C* 2.2 CONTRIBUTION FROM DISTANT LAYERS +C --------------------------------- +C + 220 CONTINUE +C +C +C* 2.2.1 DISTANT AND ABOVE LAYERS +C ------------------------ +C + 2210 CONTINUE +C +C +C +C* 2.2.2 FIRST UPPER LEVEL +C ----------------- +C + 2220 CONTINUE +C + DO 225 JK = 1 , KFLEV-1 + IKP1=JK+1 + IKN=(JK-1)*NG1P1+1 + IKD1= JK *NG1P1+1 +C + CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK) + 2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1) +C +C +C +C* 2.2.3 HIGHER UP +C --------- +C + 2230 CONTINUE +C + ITT=1 + DO 224 JKJ=IKP1,KFLEV + IF(ITT.EQ.1) THEN + ITT=2 + ELSE + ITT=1 + ENDIF + IKJP1=JKJ+1 + IKD2= JKJ *NG1P1+1 +C + IF(ITT.EQ.1) THEN + CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) + 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1) + ELSE + CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) + 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2) + ENDIF +C + DO 2235 JA = 1, KTRAER + DO 2234 JL = 1, KDLON + ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 + 2234 CONTINUE + 2235 CONTINUE +C + DO 2236 JL = 1, KDLON + ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1) *ZTT(JL,10) + S +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBDT(JL,5,JKJ)*ZTT(JL,3) *ZTT(JL,14) + S +PDBDT(JL,6,JKJ)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYD(JL)=ZWW + ZDZXDG=ZGLAYD(JL) + PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG + PCNTRB(JL,JK,IKJP1)=ZDZXDG + 2236 CONTINUE +C +C + 224 CONTINUE + 225 CONTINUE +C +C +C* 2.2.4 DISTANT AND BELOW LAYERS +C ------------------------ +C + 2240 CONTINUE +C +C +C +C* 2.2.5 FIRST LOWER LEVEL +C ----------------- +C + 2250 CONTINUE +C + DO 228 JK=3,KFLEV+1 + IKN=(JK-1)*NG1P1+1 + IKM1=JK-1 + IKJ=JK-2 + IKU1= IKJ *NG1P1+1 +C +C + CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ) + 2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1) +C +C +C +C* 2.2.6 DOWN BELOW +C ---------- +C + 2260 CONTINUE +C + ITT=1 + DO 227 JLK=1,IKJ + IF(ITT.EQ.1) THEN + ITT=2 + ELSE + ITT=1 + ENDIF + IJKL=IKM1-JLK + IKU2=(IJKL-1)*NG1P1+1 +C +C + IF(ITT.EQ.1) THEN + CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) + 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1) + ELSE + CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) + 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2) + ENDIF +C + DO 2265 JA = 1, KTRAER + DO 2264 JL = 1, KDLON + ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 + 2264 CONTINUE + 2265 CONTINUE +C + DO 2266 JL = 1, KDLON + ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1) *ZTT(JL,10) + S +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBDT(JL,5,IJKL)*ZTT(JL,3) *ZTT(JL,14) + S +PDBDT(JL,6,IJKL)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYU(JL)=ZWW + ZDZXMG=ZGLAYU(JL) + PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG + PCNTRB(JL,JK,IJKL)=ZDZXMG + 2266 CONTINUE +C +C + 227 CONTINUE + 228 CONTINUE +C + RETURN + END + SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER + R , PABCU,PDBSL,PGA,PGB + S , PADJD,PADJU,PCNTRB,PDBDT) + USE dimphy + USE radiation_AR4_param, only : WG1 + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS +C TO GIVE LONGWAVE FLUXES OR RADIANCES +C +C METHOD. +C ------- +C +C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE +C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 89-07-14 +C----------------------------------------------------------------------- +C +C* ARGUMENTS: +C + INTEGER KUAER,KTRAER +C + REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS + REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT + REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS +C + REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS + REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS + REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX + REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT +C +C* LOCAL ARRAYS: +C + REAL(KIND=8) ZGLAYD(KDLON) + REAL(KIND=8) ZGLAYU(KDLON) + REAL(KIND=8) ZTT(KDLON,NTRA) + REAL(KIND=8) ZTT1(KDLON,NTRA) + REAL(KIND=8) ZTT2(KDLON,NTRA) + REAL(KIND=8) ZUU(KDLON,NUA) +C + INTEGER jk, jl, ja, im12, ind, inu, ixu, jg + INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu + REAL(KIND=8) zwtr +c + +C----------------------------------------------------------------------- +C +C* 1. INITIALIZATION +C -------------- +C + 100 CONTINUE +C +C* 1.1 INITIALIZE LAYER CONTRIBUTIONS +C ------------------------------ +C + 110 CONTINUE +C + DO 112 JK = 1 , KFLEV+1 + DO 111 JL = 1, KDLON + PADJD(JL,JK) = 0. + PADJU(JL,JK) = 0. + 111 CONTINUE + 112 CONTINUE +C +C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS +C --------------------------------- +C + 120 CONTINUE +C + DO 122 JA = 1 , NTRA + DO 121 JL = 1, KDLON + ZTT (JL,JA) = 1.0 + ZTT1(JL,JA) = 1.0 + ZTT2(JL,JA) = 1.0 + 121 CONTINUE + 122 CONTINUE +C + DO 124 JA = 1 , NUA + DO 123 JL = 1, KDLON + ZUU(JL,JA) = 0. + 123 CONTINUE + 124 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. VERTICAL INTEGRATION +C -------------------- +C + 200 CONTINUE +C +C +C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS +C --------------------------------- +C + 210 CONTINUE +C + DO 215 JK = 1 , KFLEV +C +C* 2.1.1 DOWNWARD LAYERS +C --------------- +C + 2110 CONTINUE +C + IM12 = 2 * (JK - 1) + IND = (JK - 1) * NG1P1 + 1 + IXD = IND + INU = JK * NG1P1 + 1 + IXU = IND +C + DO 2111 JL = 1, KDLON + ZGLAYD(JL) = 0. + ZGLAYU(JL) = 0. + 2111 CONTINUE +C + DO 213 JG = 1 , NG1 + IBS = IM12 + JG + IDD = IXD + JG + DO 2113 JA = 1 , KUAER + DO 2112 JL = 1, KDLON + ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD) + 2112 CONTINUE + 2113 CONTINUE +C +C + CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) +C + DO 2114 JL = 1, KDLON + ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) + S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) + S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG) + 2114 CONTINUE +C +C* 2.1.2 DOWNWARD LAYERS +C --------------- +C + 2120 CONTINUE +C + IMU = IXU + JG + DO 2122 JA = 1 , KUAER + DO 2121 JL = 1, KDLON + ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU) + 2121 CONTINUE + 2122 CONTINUE +C +C + CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) +C + DO 2123 JL = 1, KDLON + ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) + S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) + S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) + S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) + S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) + S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) + ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG) + 2123 CONTINUE +C + 213 CONTINUE +C + DO 214 JL = 1, KDLON + PADJD(JL,JK) = ZGLAYD(JL) + PCNTRB(JL,JK,JK+1) = ZGLAYD(JL) + PADJU(JL,JK+1) = ZGLAYU(JL) + PCNTRB(JL,JK+1,JK) = ZGLAYU(JL) + PCNTRB(JL,JK ,JK) = 0.0 + 214 CONTINUE +C + 215 CONTINUE +C + DO 218 JK = 1 , KFLEV + JK2 = 2 * JK + JK1 = JK2 - 1 + DO 217 JNU = 1 , Ninter + DO 216 JL = 1, KDLON + PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2) + 216 CONTINUE + 217 CONTINUE + 218 CONTINUE +C + RETURN +C + END + SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C----------------------------------------------------------------------- +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE +C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. +C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. +C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN +C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C +C----------------------------------------------------------------------- + REAL(KIND=8) O1H, O2H + PARAMETER (O1H=2230.) + PARAMETER (O2H=100.) + REAL(KIND=8) RPIALF0 + PARAMETER (RPIALF0=2.0) +C +C* ARGUMENTS: +C + REAL(KIND=8) PUU(KDLON,NUA) + REAL(KIND=8) PTT(KDLON,NTRA) + REAL(KIND=8) PGA(KDLON,8,2) + REAL(KIND=8) PGB(KDLON,8,2) +C +C* LOCAL VARIABLES: +C + REAL(KIND=8) zz, zxd, zxn + REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 + REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 + REAL(KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy + REAL(KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o + REAL(KIND=8) zsqn21, zodn21, zsqh42, zodh42 + REAL(KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12 + REAL(KIND=8) zuu11, zuu12, za11, za12 + INTEGER jl, ja +C ------------------------------------------------------------------ +C +C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION +C ----------------------------------------------- +C + 100 CONTINUE +C +C +!cdir collapse + DO 130 JA = 1 , 8 + DO 120 JL = 1, KDLON + ZZ =SQRT(PUU(JL,JA)) +c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1)) +c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) ) +c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1) + ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) + ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) + PTT(JL,JA)=ZXN /ZXD + 120 CONTINUE + 130 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS +C --------------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + PTT(JL, 9) = PTT(JL, 8) +C +C- CONTINUUM ABSORPTION: E- AND P-TYPE +C + ZPU = 0.002 * PUU(JL,10) + ZPU10 = 112. * ZPU + ZPU11 = 6.25 * ZPU + ZPU12 = 5.00 * ZPU + ZPU13 = 80.0 * ZPU + ZEU = PUU(JL,11) + ZEU10 = 12. * ZEU + ZEU11 = 6.25 * ZEU + ZEU12 = 5.00 * ZEU + ZEU13 = 80.0 * ZEU +C +C- OZONE ABSORPTION +C + ZX = PUU(JL,12) + ZY = PUU(JL,13) + ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) + ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. + ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. + ZVXY = RPIALF0 * ZY / (2. * ZX) + ZAERCN = PUU(JL,17) + ZEU12 + ZPU12 + ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) + ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) +C +C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) +C +C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 +C +c NEXOTIC=1 +c IF (NEXOTIC.EQ.1) THEN + ZXCH4 = PUU(JL,19) + ZYCH4 = PUU(JL,20) + ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) + ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. + ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) + ZODH41 = ZVXY * ZSQH41 +C +C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZXN2O = PUU(JL,21) + ZYN2O = PUU(JL,22) + ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) + ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. + ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) + ZODN21 = ZVXY * ZSQN21 +C +C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) + ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. + ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) + ZODH42 = ZVXY * ZSQH42 +C +C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) + ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. + ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) + ZODN22 = ZVXY * ZSQN22 +C +C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA11 = 2. * PUU(JL,23) * 4.404E+05 + ZTTF11 = 1. - ZA11 * 0.003225 +C +C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA12 = 2. * PUU(JL,24) * 6.7435E+05 + ZTTF12 = 1. - ZA12 * 0.003225 +C + ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10 + ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21 + PTT(JL,10) = EXP( - PUU(JL,14) ) + PTT(JL,11) = EXP( ZUU11 ) + PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 + PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 + PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) + PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 ) + 201 CONTINUE +C + RETURN + END + SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT) + USE dimphy + IMPLICIT none +cym#include "dimensions.h" +cym#include "dimphy.h" +cym#include "raddim.h" +#include "raddimlw.h" +C +C ------------------------------------------------------------------ +C PURPOSE. +C -------- +C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE +C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL +C INTERVALS. +C +C METHOD. +C ------- +C +C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE +C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. +C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. +C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN +C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. +C +C REFERENCE. +C ---------- +C +C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND +C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS +C +C AUTHOR. +C ------- +C JEAN-JACQUES MORCRETTE *ECMWF* +C +C MODIFICATIONS. +C -------------- +C ORIGINAL : 88-12-15 +C +C----------------------------------------------------------------------- + REAL(KIND=8) O1H, O2H + PARAMETER (O1H=2230.) + PARAMETER (O2H=100.) + REAL(KIND=8) RPIALF0 + PARAMETER (RPIALF0=2.0) +C +C* ARGUMENTS: +C + REAL(KIND=8) PGA(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PGB(KDLON,8,2) ! PADE APPROXIMANTS + REAL(KIND=8) PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1 + REAL(KIND=8) PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2 + REAL(KIND=8) PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS +C +C* LOCAL VARIABLES: +C + INTEGER ja, jl + REAL(KIND=8) zz, zxd, zxn + REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 + REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 + REAL(KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2 + REAL(KIND=8) zxch4, zych4, zsqh41, zodh41 + REAL(KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42 + REAL(KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12 + REAL(KIND=8) zuu11, zuu12 +C ------------------------------------------------------------------ +C +C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION +C ----------------------------------------------- +C + 100 CONTINUE +C +C + +!CDIR ON_ADB(PUU1) +!CDIR ON_ADB(PUU2) +!CDIR COLLAPSE + DO 130 JA = 1 , 8 + DO 120 JL = 1, KDLON + ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA)) + ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) + ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) + PTT(JL,JA)=ZXN /ZXD + 120 CONTINUE + 130 CONTINUE +C +C ------------------------------------------------------------------ +C +C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS +C --------------------------------------------------- +C + 200 CONTINUE +C + DO 201 JL = 1, KDLON + PTT(JL, 9) = PTT(JL, 8) +C +C- CONTINUUM ABSORPTION: E- AND P-TYPE +C + ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10)) + ZPU10 = 112. * ZPU + ZPU11 = 6.25 * ZPU + ZPU12 = 5.00 * ZPU + ZPU13 = 80.0 * ZPU + ZEU = (PUU1(JL,11) - PUU2(JL,11)) + ZEU10 = 12. * ZEU + ZEU11 = 6.25 * ZEU + ZEU12 = 5.00 * ZEU + ZEU13 = 80.0 * ZEU +C +C- OZONE ABSORPTION +C + ZX = (PUU1(JL,12) - PUU2(JL,12)) + ZY = (PUU1(JL,13) - PUU2(JL,13)) + ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) + ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. + ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. + ZVXY = RPIALF0 * ZY / (2. * ZX) + ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12 + ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) + ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) +C +C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) +C +C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZXCH4 = (PUU1(JL,19) - PUU2(JL,19)) + ZYCH4 = (PUU1(JL,20) - PUU2(JL,20)) + ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) + ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. + ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) + ZODH41 = ZVXY * ZSQH41 +C +C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZXN2O = (PUU1(JL,21) - PUU2(JL,21)) + ZYN2O = (PUU1(JL,22) - PUU2(JL,22)) + ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) + ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. + ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) + ZODN21 = ZVXY * ZSQN21 +C +C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) + ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. + ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) + ZODH42 = ZVXY * ZSQH42 +C +C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 +C + ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) + ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. + ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) + ZODN22 = ZVXY * ZSQN22 +C +C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05 + ZTTF11 = 1. - ZA11 * 0.003225 +C +C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 +C + ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05 + ZTTF12 = 1. - ZA12 * 0.003225 +C + ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10 + ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 - + S ZODH41 - ZODN21 + PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) ) + PTT(JL,11) = EXP( ZUU11 ) + PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 + PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 + PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) + PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 ) + 201 CONTINUE +C + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radiation_AR4_param.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radiation_AR4_param.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radiation_AR4_param.F90 (revision 1634) @@ -0,0 +1,240 @@ +MODULE radiation_AR4_param + + REAL*8, parameter :: ZPDH2O = 0.8 + REAL*8, parameter :: ZPDUMG = 0.75 + REAL*8, parameter :: ZPRH2O = 30000.0 + REAL*8, parameter :: ZPRUMG = 30000.0 + REAL*8, parameter :: RTDH2O = 0.40 + REAL*8, parameter :: RTDUMG = 0.375 + REAL*8, parameter :: RTH2O = 240.0 + REAL*8, parameter :: RTUMG = 240.0 + + REAL*8, dimension(2), parameter :: WG1 = (/1.0, 1.0/) + REAL*8, dimension(11), parameter :: TINTP = (/ 187.5, 200., 212.5, 225., 237.5, 250., 262.5, 275., 287.5, 300., 312.5 /) + + real*8, dimension(11,16,3), parameter :: GA = reshape ( (/ & + 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,& + 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,& + 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,& + 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,& + 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,& + 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,& + 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,& + 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,& + 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,& + 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,& + 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,& + 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,& + 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,& + 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,& + 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,& + 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,& + 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,& + 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,& + 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,& + 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,& + 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,& + 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,& +-0.99506586E-03,-0.10184169E-02,-0.10404730E-02,-0.10621792E-02,-0.10847662E-02,-0.11094726E-02,-0.11372949E-02,-0.11687683E-02,& +-0.12038314E-02,-0.12418367E-02,-0.12817135E-02,-0.11661515E-02,-0.11886130E-02,-0.12139929E-02,-0.12445811E-02,-0.12807672E-02,& +-0.13208251E-02,-0.13619034E-02,-0.14014165E-02,-0.14378639E-02,-0.14708488E-02,-0.15006791E-02, 0.41243390E+00, 0.43407282E+00,& + 0.45331413E+00, 0.47048604E+00, 0.48586286E+00, 0.49968044E+00, 0.51214132E+00, 0.52341830E+00, 0.53365803E+00, 0.54298448E+00,& + 0.55150227E+00, 0.48318936E+00, 0.50501827E+00, 0.52409502E+00, 0.54085277E+00, 0.55565422E+00, 0.56878618E+00, 0.58047395E+00,& + 0.59089894E+00, 0.60021475E+00, 0.60856112E+00, 0.61607594E+00,-0.22159303E-01,-0.22748917E-01,-0.23269898E-01,-0.23732392E-01,& +-0.24145123E-01,-0.24515269E-01,-0.24848690E-01,-0.25150210E-01,-0.25423873E-01,-0.25673139E-01,-0.25901055E-01,-0.24972399E-01,& +-0.25537247E-01,-0.26025624E-01,-0.26450280E-01,-0.26821236E-01,-0.27146657E-01,-0.27433354E-01,-0.27687065E-01,-0.27912608E-01,& +-0.28113944E-01,-0.28294180E-01, 0.80737799E+01, 0.79171158E+01, 0.77609605E+01, 0.76087371E+01, 0.74627112E+01, 0.73239981E+01,& + 0.71929934E+01, 0.70697065E+01, 0.69539626E+01, 0.68455144E+01, 0.67441020E+01, 0.77425778E+01, 0.75443460E+01, 0.73526151E+01,& + 0.71711188E+01, 0.70015571E+01, 0.68442532E+01, 0.66987996E+01, 0.65644820E+01, 0.64405267E+01, 0.63262376E+01, 0.62210701E+01,& + 0.10542131E+02, 0.10515895E+02, 0.10492949E+02, 0.10472049E+02, 0.10452961E+02, 0.10435562E+02, 0.10419710E+02, 0.10405247E+02,& + 0.10392022E+02, 0.10379892E+02, 0.10368736E+02, 0.10490353E+02, 0.10463512E+02, 0.10439183E+02, 0.10417324E+02, 0.10397704E+02,& + 0.10380038E+02, 0.10364052E+02, 0.10349509E+02, 0.10336215E+02, 0.10324018E+02, 0.10312808E+02,-0.12823142E+01,-0.10571588E+01,& +-0.74864953E+00,-0.58705980E+00,-0.49305772E+00,-0.51461431E+00, 0.12373350E+02, 0.44809588E+00, 0.46548918E+00, 0.59121475E+00,& + 0.74676119E+00,-0.74805226E+00,-0.56252739E+00,-0.46188072E+00,-0.40712065E+00,-0.15295996E+01, 0.43555255E+00, 0.50380874E+00,& + 0.68537352E+00, 0.89437630E+00, 0.11127003E+01, 0.13329782E+01, 0.13845511E+01, 0.13187042E+01, 0.12644396E+01, 0.12191543E+01,& + 0.11809511E+01, 0.11484154E+01, 0.11204723E+01, 0.10962918E+01, 0.10752229E+01, 0.10567474E+01, 0.10404465E+01, 0.11718758E+01,& + 0.11216131E+01, 0.10809473E+01, 0.10476396E+01, 0.10200373E+01, 0.99692726E+00, 0.97740923E+00, 0.96080188E+00, 0.94657562E+00,& + 0.93430511E+00, 0.92363528E+00, 0.22042132E+02, 0.22107298E+02, 0.22180915E+02, 0.22259478E+02, 0.22341039E+02, 0.22424247E+02,& + 0.22508089E+02, 0.22591771E+02, 0.22674661E+02, 0.22756246E+02, 0.22836093E+02, 0.22169501E+02, 0.22270075E+02, 0.22379193E+02,& + 0.22492992E+02, 0.22608508E+02, 0.22723843E+02, 0.22837837E+02, 0.22949751E+02, 0.23059032E+02, 0.23165146E+02, 0.23267456E+02,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,& + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00 /) & + , (/ 11,16,3 /) ) + + real*8, dimension(11,16,3), parameter :: GB = reshape ( (/ & + 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,& + 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,& + 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,& + 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,& + 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,& + 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,& + 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,& + 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,& + 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,& + 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,& + 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,& + 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,& + 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,& + 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,& + 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,& + 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,& + 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,& + 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,& + 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,& + 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,& + 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,& + 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,& + 0.97222852E-01, 0.98862238E-01, 0.10061504E+00, 0.10256222E+00, 0.10475952E+00, 0.10720986E+00, 0.10985370E+00, 0.11257633E+00,& + 0.11522980E+00, 0.11766343E+00, 0.11975320E+00, 0.10681591E+00, 0.10921298E+00, 0.11198225E+00, 0.11487826E+00, 0.11751113E+00,& + 0.11951535E+00, 0.12069945E+00, 0.12108524E+00, 0.12084229E+00, 0.12019005E+00, 0.11932684E+00, 0.10346097E+01, 0.10433655E+01,& + 0.10511933E+01, 0.10582150E+01, 0.10645317E+01, 0.10702313E+01, 0.10753907E+01, 0.10800762E+01, 0.10843446E+01, 0.10882439E+01,& + 0.10918144E+01, 0.10626130E+01, 0.10716026E+01, 0.10795108E+01, 0.10865006E+01, 0.10927103E+01, 0.10982489E+01, 0.11032019E+01,& + 0.11076379E+01, 0.11116160E+01, 0.11151910E+01, 0.11184188E+01, 0.38103212E+00, 0.38913800E+00, 0.39613651E+00, 0.40222421E+00,& + 0.40756010E+00, 0.41226954E+00, 0.41645142E+00, 0.42018474E+00, 0.42353379E+00, 0.42655211E+00, 0.42928533E+00, 0.41646579E+00,& + 0.42345095E+00, 0.42937476E+00, 0.43444062E+00, 0.43880316E+00, 0.44258354E+00, 0.44587882E+00, 0.44876776E+00, 0.45131451E+00,& + 0.45357095E+00, 0.45557797E+00, 0.82623280E+01, 0.81072291E+01, 0.79523834E+01, 0.78012527E+01, 0.76561458E+01, 0.75182174E+01,& + 0.73878952E+01, 0.72652133E+01, 0.71500151E+01, 0.70420667E+01, 0.69411177E+01, 0.79342219E+01, 0.77373458E+01, 0.75467334E+01,& + 0.73661786E+01, 0.71974319E+01, 0.70408543E+01, 0.68960649E+01, 0.67623672E+01, 0.66389989E+01, 0.65252707E+01, 0.64206412E+01,& + 0.10656640E+02, 0.10630910E+02, 0.10608399E+02, 0.10587891E+02, 0.10569156E+02, 0.10552075E+02, 0.10536510E+02, 0.10522307E+02,& + 0.10509317E+02, 0.10497402E+02, 0.10486443E+02, 0.10605856E+02, 0.10579514E+02, 0.10555632E+02, 0.10534169E+02, 0.10514900E+02,& + 0.10497547E+02, 0.10481842E+02, 0.10467553E+02, 0.10454488E+02, 0.10442501E+02, 0.10431483E+02, 0.26681588E+02, 0.24728346E+02,& + 0.20551342E+02, 0.19955244E+02, 0.22227100E+02, 0.31770288E+02,-0.74061287E+03,-0.81329826E+01, 0.90279822E+00, 0.37532746E+01,& + 0.50437916E+01, 0.18377807E+02, 0.17643148E+02, 0.19296161E+02, 0.24951120E+02, 0.10957372E+03,-0.67432659E+01, 0.24550746E+01,& + 0.49089917E+01, 0.59008712E+01, 0.63532616E+01, 0.65558627E+01, 0.23203798E+01, 0.22288925E+01, 0.21515593E+01, 0.20855896E+01,& + 0.20288489E+01, 0.19796791E+01, 0.19367778E+01, 0.18991112E+01, 0.18658501E+01, 0.18363226E+01, 0.18099779E+01, 0.20206726E+01,& + 0.19441824E+01, 0.18807257E+01, 0.18275618E+01, 0.17825910E+01, 0.17442308E+01, 0.17112809E+01, 0.16828137E+01, 0.16580908E+01,& + 0.16365014E+01, 0.16175164E+01, 0.22051750E+02, 0.22116850E+02, 0.22190410E+02, 0.22268925E+02, 0.22350445E+02, 0.22433617E+02,& + 0.22517429E+02, 0.22601086E+02, 0.22683956E+02, 0.22765522E+02, 0.22845354E+02, 0.22178972E+02, 0.22279484E+02, 0.22388551E+02,& + 0.22502309E+02, 0.22617792E+02, 0.22733099E+02, 0.22847071E+02, 0.22958967E+02, 0.23068234E+02, 0.23174336E+02, 0.23276638E+02,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,& + 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01 /) & + , (/ 11,16,3 /) ) + + real*8, dimension(6,6), parameter :: XP = reshape ( (/ & + 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, 0.31398411E+03, 0.18373177E+03, -0.11412303E+03, & + 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, -0.57322111E+02, -0.64742459E+02, 0.87238280E+02, & + 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, 0.17401171E+03, -0.13350302E+03, -0.37651795E+02, & + 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, 0.93433860E+02, -0.70646020E+02, -0.26373150E+02, & + 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, -0.31496190E+02, 0.12791300E+00, 0.18017770E+01, & + 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /) , (/ 6,6 /) ) + + REAL*8, dimension(2), parameter :: RSUN = (/ 0.441676 , 0.558324 /) + REAL*8, dimension(2,6), parameter :: RRAY = reshape ( & + (/ .428937E-01, .697200E-02,& + .890743E+00, .173297E-01,& + -.288555E+01,-.850903E-01,& + .522744E+01, .248261E+00,& + -.469173E+01,-.302031E+00,& + .161645E+01, .129662E+00 /) , (/2,6/) ) + + REAL*8, dimension(2,5), parameter :: TAUA = reshape ( & + (/ 0.730719, 0.730719, 0.912819, 0.912819, 0.725059, & + 0.725059, 0.745405, 0.745405, 0.682188, 0.682188 /),(/2,5/) ) + REAL*8, dimension(2,5), parameter :: RPIZA = reshape ( & + (/ 0.872212, 0.872212, 0.982545, 0.982545, 0.623143, & + 0.623143, 0.944887, 0.944887, 0.997975, 0.997975 /),(/2,5/) ) + REAL*8, dimension(2,5), parameter :: RCGA = reshape ( & + (/ 0.647596, 0.647596, 0.739002, 0.739002, 0.580845, & + 0.580845, 0.662657, 0.662657, 0.624246, 0.624246 /),(/2,5/) ) + + REAL*8, dimension(2,3,7), parameter :: APAD = reshape ( & + (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,& + 0.739646016E-08, 0.925887084E-04, 0.410177786E+03,& + 0.723613782E+05, 0.978576773E-04, 0.000000000E-00,& + 0.131849595E-03, 0.129353723E-01, 0.672595424E+02,& + 0.596037057E+04, 0.387714006E+00, 0.000000000E-00,& + 0.437772681E+00, 0.800821928E+00, 0.000000000E-00,& + 0.000000000E-00, 0.118461660E+03, 0.000000000E-00,& + 0.151345118E+03, 0.242715973E+02, 0.000000000E-00,& + 0.000000000E-00, 0.119079797E+04, 0.000000000E-00,& + 0.233628890E+04, 0.878331486E+02, 0.000000000E-00,& + 0.000000000E-00, 0.293353397E+03, 0.000000000E-00,& + 0.797219934E+03, 0.191559725E+02, 0.000000000E-00,& + 0.000000000E-00, 0.000000000E+00, 0.000000000E-00,& + 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /) , (/2,3,7/) ) + REAL*8, dimension(2,3,7), parameter :: BPAD = reshape ( & + (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,& + 0.739646016E-08, 0.925887084E-04, 0.410177786E+03,& + 0.724555318E+05, 0.979023421E-04, 0.000000000E-00,& + 0.131861712E-03, 0.131812683E-01, 0.731185438E+02,& + 0.602593328E+04, 0.388611139E+00, 0.000000000E-00,& + 0.437949001E+00, 0.812706117E+00, 0.100000000E+01,& + 0.100000000E+01, 0.120291383E+03, 0.000000000E-00,& + 0.151692730E+03, 0.249863591E+02, 0.000000000E+00,& + 0.000000000E-00, 0.130531005E+04, 0.000000000E-00,& + 0.237071130E+04, 0.931071925E+02, 0.000000000E+00,& + 0.000000000E-00, 0.415049409E+03, 0.000000000E-00,& + 0.867914360E+03, 0.252233437E+02, 0.000000000E+00,& + 0.000000000E-00, 0.100000000E+01, 0.000000000E-00,& + 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /) , (/2,3,7/) ) + REAL*8, dimension(2,3), parameter :: D = reshape ( & + (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.8 /) , (/2,3/) ) + + REAL*8, parameter :: TREF = 250.0 + REAL*8, dimension(2), parameter :: RT1 = (/ -0.577350269, +0.577350269 /) + REAL*8, dimension(5,5), parameter :: RAER= reshape ( & + (/ .038520, .037196, .040532, .054934, .038520 & + , .12613 , .18313 , .10357 , .064106, .126130 & + , .012579, .013649, .018652, .025181, .012579 & + , .011890, .016142, .021105, .028908, .011890 & + , .013792, .026810, .052203, .066338, .013792 /) , (/5,5/) ) + + REAL*8, dimension(8,3), parameter :: AT= reshape ( & + (/ 0.298199E-02,0.143676E-01,0.197861E-01,0.289560E-01,& + 0.103800E-01,0.868859E-02,0.250073E-03,0.307423E-01,& + -.394023E-03,0.366501E-02,0.315541E-02,-.208807E-02,& + 0.436296E-02,-.972752E-03,0.455875E-03,0.110879E-02,& + 0.319566E-04,-.160822E-02,-.174547E-02,-.121943E-02,& + -.161431E-02,0.000000E-00,0.109242E-03,-.322172E-03 /) , (/8,3/) ) + + REAL*8, dimension(8,3), parameter :: BT= reshape ( & + (/ -0.106432E-04,-0.553979E-04,-0.877012E-04,-0.165960E-03,& + -0.276744E-04,-0.278412E-04, 0.199846E-05,-0.108482E-03,& + 0.660324E-06,-0.101701E-04, 0.513302E-04, 0.157704E-03,& + -0.327381E-04,-0.713940E-06,-0.216313E-05, 0.258096E-05,& + 0.174356E-06, 0.920868E-05, 0.523138E-06,-0.146427E-04,& + 0.127646E-04 ,0.117469E-05, 0.175991E-06,-0.814575E-06 /) , (/8,3/) ) + + REAL*8, dimension(4), parameter :: OCT = (/ -.326E-03, -.102E-05, .137E-02, -.535E-05 /) + + end module radiation_AR4_param Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radio_decay.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radio_decay.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radio_decay.F90 (revision 1634) @@ -0,0 +1,59 @@ +! +! $Id $ +! +SUBROUTINE radio_decay(radio,rnpb,dtime,tautr,tr,d_tr) +! +! Caluclate radioactive decay for all tracers with radio(it)=true +! + USE dimphy + USE infotrac, ONLY : nbtr + USE traclmdz_mod, ONLY : id_rn, id_pb + IMPLICIT NONE +!----------------------------------------------------------------------- +! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94 +! Objet: Calcul de la tendance radioactive des traceurs type radioelements +! Cas particulier pour le couple radon-plomb : Le radon decroit en plomb +!----------------------------------------------------------------------- +! +! Entrees +! + LOGICAL,DIMENSION(nbtr),INTENT(IN) :: radio ! .true. = traceur radioactif + LOGICAL,INTENT(IN) :: rnpb ! .true. = decroissance RN = source PB + REAL,INTENT(IN) :: dtime ! Pas de temps physique (secondes) + REAL,DIMENSION(nbtr),INTENT(IN) :: tautr ! Constante de decroissance radioactive + REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr ! Concentrations traceurs U/kgA +! +! Sortie +! + REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: d_tr ! Tendance de decroissance radioactive +! +! Locales +! + INTEGER :: i,k,it + + + DO it = 1,nbtr + d_tr(:,:,it) = 0. + IF ( radio(it) ) THEN + IF (tautr(it) .GT. 0.) THEN + DO k = 1,klev + DO i = 1,klon + d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it) + END DO + END DO + END IF + END IF + END DO + +!------------------------------------------------------- +! Cas particulier radon (id_rn) => plomb (id_pb) +!------------------------------------------------------- + IF ( rnpb ) THEN + DO k = 1,klev + DO i = 1,klon + d_tr(i,k,id_pb) = d_tr(i,k,id_pb) - d_tr(i,k,id_rn) + ENDDO + ENDDO + ENDIF + +END SUBROUTINE radio_decay Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radlwsw.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radlwsw.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radlwsw.F90 (revision 1634) @@ -0,0 +1,456 @@ +module radlwsw_m + + IMPLICIT NONE + +contains + +SUBROUTINE radlwsw( & + dist, rmu0, fract, & + paprs, pplay,tsol,alb1, alb2, & + t,q,wo,& + cldfra, cldemi, cldtaupd,& + ok_ade, ok_aie,& + tau_aero, piz_aero, cg_aero,& + cldtaupi, new_aod, & + qsat, flwc, fiwc, & + heat,heat0,cool,cool0,radsol,albpla,& + topsw,toplw,solsw,sollw,& + sollwdown,& + topsw0,toplw0,solsw0,sollw0,& + lwdn0, lwdn, lwup0, lwup,& + swdn0, swdn, swup0, swup,& + topswad_aero, solswad_aero,& + topswai_aero, solswai_aero, & + topswad0_aero, solswad0_aero,& + topsw_aero, topsw0_aero,& + solsw_aero, solsw0_aero, & + topswcf_aero, solswcf_aero) + + + + USE DIMPHY + use assert_m, only: assert + + !====================================================================== + ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719 + ! Objet: interface entre le modele et les rayonnements + ! Arguments: + ! dist-----input-R- distance astronomique terre-soleil + ! rmu0-----input-R- cosinus de l'angle zenithal + ! fract----input-R- duree d'ensoleillement normalisee + ! co2_ppm--input-R- concentration du gaz carbonique (en ppm) + ! paprs----input-R- pression a inter-couche (Pa) + ! pplay----input-R- pression au milieu de couche (Pa) + ! tsol-----input-R- temperature du sol (en K) + ! alb1-----input-R- albedo du sol(entre 0 et 1) dans l'interval visible + ! alb2-----input-R- albedo du sol(entre 0 et 1) dans l'interval proche infra-rouge + ! t--------input-R- temperature (K) + ! q--------input-R- vapeur d'eau (en kg/kg) + ! cldfra---input-R- fraction nuageuse (entre 0 et 1) + ! cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value) + ! cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1) + ! ok_ade---input-L- apply the Aerosol Direct Effect or not? + ! ok_aie---input-L- apply the Aerosol Indirect Effect or not? + ! tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F) + ! cldtaupi-input-R- epaisseur optique des nuages dans le visible + ! calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller + ! droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd + ! it is needed for the diagnostics of the aerosol indirect radiative forcing + ! + ! heat-----output-R- echauffement atmospherique (visible) (K/jour) + ! cool-----output-R- refroidissement dans l'IR (K/jour) + ! radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas) + ! albpla---output-R- albedo planetaire (entre 0 et 1) + ! topsw----output-R- flux solaire net au sommet de l'atm. + ! toplw----output-R- ray. IR montant au sommet de l'atmosphere + ! solsw----output-R- flux solaire net a la surface + ! sollw----output-R- ray. IR montant a la surface + ! solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir) + ! topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir) + ! solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind) + ! topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind) + ! + ! ATTENTION: swai and swad have to be interpreted in the following manner: + ! --------- + ! ok_ade=F & ok_aie=F -both are zero + ! ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad + ! indirect is zero + ! ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai + ! direct is zero + ! ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai + ! aerosol direct forcing is F_{AD} = topswai-topswad + ! + + !====================================================================== + + ! ==================================================================== + ! Adapte au modele de chimie INCA par Celine Deandreis & Anne Cozic -- 2009 + ! 1 = ZERO + ! 2 = AER total + ! 3 = NAT + ! 4 = BC + ! 5 = SO4 + ! 6 = POM + ! 7 = DUST + ! 8 = SS + ! 9 = NO3 + ! + ! ==================================================================== + include "YOETHF.h" + include "YOMCST.h" + include "clesphys.h" + include "iniprint.h" + +! Input arguments + REAL, INTENT(in) :: dist + REAL, INTENT(in) :: rmu0(KLON), fract(KLON) + REAL, INTENT(in) :: paprs(KLON,KLEV+1), pplay(KLON,KLEV) + REAL, INTENT(in) :: alb1(KLON), alb2(KLON), tsol(KLON) + REAL, INTENT(in) :: t(KLON,KLEV), q(KLON,KLEV) + + REAL, INTENT(in):: wo(:, :, :) ! dimension(KLON,KLEV, 1 or 2) + ! column-density of ozone in a layer, in kilo-Dobsons + ! "wo(:, :, 1)" is for the average day-night field, + ! "wo(:, :, 2)" is for daylight time. + + LOGICAL, INTENT(in) :: ok_ade, ok_aie ! switches whether to use aerosol direct (indirect) effects or not + REAL, INTENT(in) :: cldfra(KLON,KLEV), cldemi(KLON,KLEV), cldtaupd(KLON,KLEV) + REAL, INTENT(in) :: tau_aero(KLON,KLEV,9,2) ! aerosol optical properties (see aeropt.F) + REAL, INTENT(in) :: piz_aero(KLON,KLEV,9,2) ! aerosol optical properties (see aeropt.F) + REAL, INTENT(in) :: cg_aero(KLON,KLEV,9,2) ! aerosol optical properties (see aeropt.F) + REAL, INTENT(in) :: cldtaupi(KLON,KLEV) ! cloud optical thickness for pre-industrial aerosol concentrations + LOGICAL, INTENT(in) :: new_aod ! flag pour retrouver les resultats exacts de l'AR4 dans le cas ou l'on ne travaille qu'avec les sulfates + REAL, INTENT(in) :: qsat(klon,klev) ! Variable pour iflag_rrtm=1 + REAL, INTENT(in) :: flwc(klon,klev) ! Variable pour iflag_rrtm=1 + REAL, INTENT(in) :: fiwc(klon,klev) ! Variable pour iflag_rrtm=1 + +! Output arguments + REAL, INTENT(out) :: heat(KLON,KLEV), cool(KLON,KLEV) + REAL, INTENT(out) :: heat0(KLON,KLEV), cool0(KLON,KLEV) + REAL, INTENT(out) :: radsol(KLON), topsw(KLON), toplw(KLON) + REAL, INTENT(out) :: solsw(KLON), sollw(KLON), albpla(KLON) + REAL, INTENT(out) :: topsw0(KLON), toplw0(KLON), solsw0(KLON), sollw0(KLON) + REAL, INTENT(out) :: sollwdown(KLON) + REAL, INTENT(out) :: swdn(KLON,kflev+1),swdn0(KLON,kflev+1) + REAL, INTENT(out) :: swup(KLON,kflev+1),swup0(KLON,kflev+1) + REAL, INTENT(out) :: lwdn(KLON,kflev+1),lwdn0(KLON,kflev+1) + REAL, INTENT(out) :: lwup(KLON,kflev+1),lwup0(KLON,kflev+1) + 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 + REAL, DIMENSION(klon), INTENT(out) :: topswad0_aero + REAL, DIMENSION(klon), INTENT(out) :: solswad0_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: topsw_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: topsw0_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: solsw_aero + REAL, DIMENSION(kdlon,9), INTENT(out) :: solsw0_aero + REAL, DIMENSION(kdlon,3), INTENT(out) :: topswcf_aero + REAL, DIMENSION(kdlon,3), INTENT(out) :: solswcf_aero + +! Local variables + REAL(KIND=8) ZFSUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1) + REAL(KIND=8) ZFLUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFLDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFLUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFLDN0(KDLON,KFLEV+1) + REAL(KIND=8) zx_alpha1, zx_alpha2 + INTEGER k, kk, i, j, iof, nb_gr + REAL(KIND=8) PSCT + REAL(KIND=8) PALBD(kdlon,2), PALBP(kdlon,2) + REAL(KIND=8) PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon) + REAL(KIND=8) PPSOL(kdlon), PDP(kdlon,KLEV) + REAL(KIND=8) PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1) + REAL(KIND=8) PTAVE(kdlon,kflev) + REAL(KIND=8) PWV(kdlon,kflev), PQS(kdlon,kflev) + + 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. + + REAL(KIND=8) PAER(kdlon,kflev,5) + REAL(KIND=8) PCLDLD(kdlon,kflev) + REAL(KIND=8) PCLDLU(kdlon,kflev) + REAL(KIND=8) PCLDSW(kdlon,kflev) + REAL(KIND=8) PTAU(kdlon,2,kflev) + REAL(KIND=8) POMEGA(kdlon,2,kflev) + REAL(KIND=8) PCG(kdlon,2,kflev) + REAL(KIND=8) zfract(kdlon), zrmu0(kdlon), zdist + REAL(KIND=8) zheat(kdlon,kflev), zcool(kdlon,kflev) + REAL(KIND=8) zheat0(kdlon,kflev), zcool0(kdlon,kflev) + REAL(KIND=8) ztopsw(kdlon), ztoplw(kdlon) + REAL(KIND=8) zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon) + REAL(KIND=8) zsollwdown(kdlon) + REAL(KIND=8) ztopsw0(kdlon), ztoplw0(kdlon) + REAL(KIND=8) zsolsw0(kdlon), zsollw0(kdlon) + REAL(KIND=8) zznormcp + REAL(KIND=8) tauaero(kdlon,kflev,9,2) ! aer opt properties + REAL(KIND=8) pizaero(kdlon,kflev,9,2) + REAL(KIND=8) cgaero(kdlon,kflev,9,2) + REAL(KIND=8) PTAUA(kdlon,2,kflev) ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use + REAL(KIND=8) POMEGAA(kdlon,2,kflev) ! dito for single scatt albedo + REAL(KIND=8) ztopswadaero(kdlon), zsolswadaero(kdlon) ! Aerosol direct forcing at TOAand surface + REAL(KIND=8) ztopswad0aero(kdlon), zsolswad0aero(kdlon) ! Aerosol direct forcing at TOAand surface + REAL(KIND=8) ztopswaiaero(kdlon), zsolswaiaero(kdlon) ! dito, indirect + REAL(KIND=8) ztopsw_aero(kdlon,9), ztopsw0_aero(kdlon,9) + REAL(KIND=8) zsolsw_aero(kdlon,9), zsolsw0_aero(kdlon,9) + REAL(KIND=8) ztopswcf_aero(kdlon,3), zsolswcf_aero(kdlon,3) + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + + call assert(size(wo, 1) == klon, size(wo, 2) == klev, "radlwsw wo") + ! initialisation + tauaero(:,:,:,:)=0. + pizaero(:,:,:,:)=0. + cgaero(:,:,:,:)=0. + + ! + !------------------------------------------- + nb_gr = KLON / kdlon + IF (nb_gr*kdlon .NE. KLON) THEN + PRINT*, "kdlon mauvais:", KLON, kdlon, nb_gr + CALL abort + ENDIF + IF (kflev .NE. KLEV) THEN + PRINT*, "kflev differe de KLEV, kflev, KLEV" + CALL abort + ENDIF + !------------------------------------------- + DO k = 1, KLEV + DO i = 1, KLON + heat(i,k)=0. + cool(i,k)=0. + heat0(i,k)=0. + cool0(i,k)=0. + ENDDO + ENDDO + ! + zdist = dist + ! + PSCT = solaire/zdist/zdist + DO j = 1, nb_gr + iof = kdlon*(j-1) + DO i = 1, kdlon + zfract(i) = fract(iof+i) + zrmu0(i) = rmu0(iof+i) + PALBD(i,1) = alb1(iof+i) + PALBD(i,2) = alb2(iof+i) + PALBP(i,1) = alb1(iof+i) + PALBP(i,2) = alb2(iof+i) + PEMIS(i) = 1.0 + PVIEW(i) = 1.66 + PPSOL(i) = paprs(iof+i,1) + zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2))/(pplay(iof+i,1)-pplay(iof+i,2)) + zx_alpha2 = 1.0 - zx_alpha1 + PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2 + PTL(i,KLEV+1) = t(iof+i,KLEV) + PDT0(i) = tsol(iof+i) - PTL(i,1) + ENDDO + DO k = 2, kflev + DO i = 1, kdlon + PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5 + ENDDO + ENDDO + DO k = 1, kflev + DO i = 1, kdlon + PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1) + PTAVE(i,k) = t(iof+i,k) + PWV(i,k) = MAX (q(iof+i,k), 1.0e-12) + PQS(i,k) = PWV(i,k) + POZON(i,k, :) = wo(iof+i, k, :) * RG * dobson_u * 1e3 & + / (paprs(iof+i, k) - paprs(iof+i, k+1)) + PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k) + PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k) + PCLDSW(i,k) = cldfra(iof+i,k) + PTAU(i,1,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! 1e-12 serait instable + PTAU(i,2,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! pour 32-bit machines + POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k)) + POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k)) + PCG(i,1,k) = 0.865 + PCG(i,2,k) = 0.910 + !- + ! Introduced for aerosol indirect forcings. + ! The following values use the cloud optical thickness calculated from + ! present-day aerosol concentrations whereas the quantities without the + ! "A" at the end are for pre-industial (natural-only) aerosol concentrations + ! + PTAUA(i,1,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! 1e-12 serait instable + PTAUA(i,2,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! pour 32-bit machines + POMEGAA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAUA(i,1,k)) + POMEGAA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAUA(i,2,k)) + ENDDO + ENDDO + ! + DO k = 1, kflev+1 + DO i = 1, kdlon + PPMB(i,k) = paprs(iof+i,k)/100.0 + ENDDO + ENDDO + ! + DO kk = 1, 5 + DO k = 1, kflev + DO i = 1, kdlon + PAER(i,k,kk) = 1.0E-15 + ENDDO + ENDDO + ENDDO + DO k = 1, kflev + DO i = 1, kdlon + tauaero(i,k,:,1)=tau_aero(iof+i,k,:,1) + pizaero(i,k,:,1)=piz_aero(iof+i,k,:,1) + cgaero(i,k,:,1) =cg_aero(iof+i,k,:,1) + tauaero(i,k,:,2)=tau_aero(iof+i,k,:,2) + pizaero(i,k,:,2)=piz_aero(iof+i,k,:,2) + cgaero(i,k,:,2) =cg_aero(iof+i,k,:,2) + ENDDO + ENDDO + +! +!===== iflag_rrtm ================================================ +! + IF (iflag_rrtm == 0) THEN + ! Old radiation scheme, used for AR4 runs + ! average day-night ozone for longwave + CALL LW_LMDAR4(& + PPMB, PDP,& + PPSOL,PDT0,PEMIS,& + PTL, PTAVE, PWV, POZON(:, :, 1), PAER,& + PCLDLD,PCLDLU,& + PVIEW,& + zcool, zcool0,& + ztoplw,zsollw,ztoplw0,zsollw0,& + zsollwdown,& + ZFLUP, ZFLDN, ZFLUP0,ZFLDN0) + + ! daylight ozone, if we have it, for short wave + IF (.NOT. new_aod) THEN + ! use old version + CALL SW_LMDAR4(PSCT, zrmu0, zfract,& + PPMB, PDP, & + PPSOL, PALBD, PALBP,& + PTAVE, PWV, PQS, POZON(:, :, size(wo, 3)), PAER,& + PCLDSW, PTAU, POMEGA, PCG,& + zheat, zheat0,& + zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,& + ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,& + tau_aero(:,:,5,:), piz_aero(:,:,5,:), cg_aero(:,:,5,:),& + PTAUA, POMEGAA,& + ztopswadaero,zsolswadaero,& + ztopswaiaero,zsolswaiaero,& + ok_ade, ok_aie) + + ELSE ! new_aod=T + CALL SW_AEROAR4(PSCT, zrmu0, zfract,& + PPMB, PDP,& + PPSOL, PALBD, PALBP,& + PTAVE, PWV, PQS, POZON(:, :, size(wo, 3)), PAER,& + PCLDSW, PTAU, POMEGA, PCG,& + zheat, zheat0,& + zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,& + ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,& + tauaero, pizaero, cgaero, & + PTAUA, POMEGAA,& + ztopswadaero,zsolswadaero,& + ztopswad0aero,zsolswad0aero,& + ztopswaiaero,zsolswaiaero, & + ztopsw_aero,ztopsw0_aero,& + zsolsw_aero,zsolsw0_aero,& + ztopswcf_aero,zsolswcf_aero, & + ok_ade, ok_aie) + + ENDIF + + ELSE +!===== iflag_rrtm=1, on passe dans SW via RECMWFL =============== + WRITE(lunout,*) "Option iflag_rrtm=T ne fonctionne pas encore !!!" + CALL abort_gcm('radlwsw','iflag_rrtm=T not valid',1) + + ENDIF ! iflag_rrtm +!====================================================================== + + DO i = 1, kdlon + radsol(iof+i) = zsolsw(i) + zsollw(i) + topsw(iof+i) = ztopsw(i) + toplw(iof+i) = ztoplw(i) + solsw(iof+i) = zsolsw(i) + sollw(iof+i) = zsollw(i) + sollwdown(iof+i) = zsollwdown(i) + DO k = 1, kflev+1 + lwdn0 ( iof+i,k) = ZFLDN0 ( i,k) + lwdn ( iof+i,k) = ZFLDN ( i,k) + lwup0 ( iof+i,k) = ZFLUP0 ( i,k) + lwup ( iof+i,k) = ZFLUP ( i,k) + ENDDO + topsw0(iof+i) = ztopsw0(i) + toplw0(iof+i) = ztoplw0(i) + solsw0(iof+i) = zsolsw0(i) + sollw0(iof+i) = zsollw0(i) + albpla(iof+i) = zalbpla(i) + + DO k = 1, kflev+1 + swdn0 ( iof+i,k) = ZFSDN0 ( i,k) + swdn ( iof+i,k) = ZFSDN ( i,k) + swup0 ( iof+i,k) = ZFSUP0 ( i,k) + swup ( iof+i,k) = ZFSUP ( i,k) + ENDDO + ENDDO + !-transform the aerosol forcings, if they have + ! to be calculated + IF (ok_ade) THEN + DO i = 1, kdlon + topswad_aero(iof+i) = ztopswadaero(i) + topswad0_aero(iof+i) = ztopswad0aero(i) + solswad_aero(iof+i) = zsolswadaero(i) + solswad0_aero(iof+i) = zsolswad0aero(i) +! MS the following lines seem to be wrong, why is iof on right hand side??? +! topsw_aero(iof+i,:) = ztopsw_aero(iof+i,:) +! topsw0_aero(iof+i,:) = ztopsw0_aero(iof+i,:) +! solsw_aero(iof+i,:) = zsolsw_aero(iof+i,:) +! solsw0_aero(iof+i,:) = zsolsw0_aero(iof+i,:) + topsw_aero(iof+i,:) = ztopsw_aero(i,:) + topsw0_aero(iof+i,:) = ztopsw0_aero(i,:) + solsw_aero(iof+i,:) = zsolsw_aero(i,:) + solsw0_aero(iof+i,:) = zsolsw0_aero(i,:) + topswcf_aero(iof+i,:) = ztopswcf_aero(i,:) + solswcf_aero(iof+i,:) = zsolswcf_aero(i,:) + ENDDO + ELSE + DO i = 1, kdlon + topswad_aero(iof+i) = 0.0 + solswad_aero(iof+i) = 0.0 + topswad0_aero(iof+i) = 0.0 + solswad0_aero(iof+i) = 0.0 + topsw_aero(iof+i,:) = 0. + topsw0_aero(iof+i,:) =0. + solsw_aero(iof+i,:) = 0. + solsw0_aero(iof+i,:) = 0. + ENDDO + ENDIF + IF (ok_aie) THEN + DO i = 1, kdlon + topswai_aero(iof+i) = ztopswaiaero(i) + solswai_aero(iof+i) = zsolswaiaero(i) + ENDDO + ELSE + DO i = 1, kdlon + topswai_aero(iof+i) = 0.0 + solswai_aero(iof+i) = 0.0 + ENDDO + ENDIF + DO k = 1, kflev + DO i = 1, kdlon + ! scale factor to take into account the difference between + ! dry air and watter vapour scpecifi! heat capacity + zznormcp=1.0+RVTMP2*PWV(i,k) + heat(iof+i,k) = zheat(i,k)/zznormcp + cool(iof+i,k) = zcool(i,k)/zznormcp + heat0(iof+i,k) = zheat0(i,k)/zznormcp + cool0(iof+i,k) = zcool0(i,k)/zznormcp + ENDDO + ENDDO + + ENDDO ! j = 1, nb_gr + +END SUBROUTINE radlwsw + +end module radlwsw_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radopt.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radopt.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/radopt.h (revision 1634) @@ -0,0 +1,9 @@ +! +! $Header$ +! + LOGICAL LEVOIGT + PARAMETER (LEVOIGT=.FALSE.) + INTEGER NOVLP + PARAMETER (NOVLP=1) + INTEGER KAER + PARAMETER (KAER=0) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ran0_vec.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ran0_vec.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ran0_vec.F (revision 1634) @@ -0,0 +1,34 @@ +! +! $Header$ +! + subroutine ran0_vec(npoints,idum,ran0) + +! $Id$ +! Platform independent random number generator from +! Numerical Recipies +! Mark Webb July 1999 + + implicit none + + integer j,npoints,idum(npoints),IA,IM,IQ,IR,k(npoints) + real ran0(npoints),AM + + parameter (IA=16807, IM=2147483647, AM=1.0/IM, IQ=127773, IR=2836) + +c do j=1,npoints +c if (idum(j).eq.0) then +c write(6,*) 'idum=',idum +c write(6,*) 'ZERO seed not allowed' +c stop +c endif +c enddo + + do j=1,npoints + k(j)=idum(j)/IQ + idum(j)=IA*(idum(j)-k(j)*IQ)-IR*k(j) + if (idum(j).lt.0) idum(j)=idum(j)+IM + ran0(j)=AM*idum(j) + enddo + + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_map2D.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_map2D.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_map2D.F90 (revision 1634) @@ -0,0 +1,80 @@ +SUBROUTINE read_map2D(filename, varname, timestep, inverse, varout) +! Open file and read one variable for one timestep. +! Return variable for the given timestep. + USE dimphy + USE netcdf + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + + + IMPLICIT NONE + +! Input arguments + CHARACTER(len=*), INTENT(IN) :: filename ! name of file to read + CHARACTER(len=*), INTENT(IN) :: varname ! name of variable in file + INTEGER, INTENT(IN) :: timestep ! actual timestep + LOGICAL, INTENT(IN) :: inverse ! TRUE if latitude needs to be inversed +! Output argument + REAL, DIMENSION(klon), INTENT(OUT) :: varout ! The variable read from file for the given timestep + +! Local variables + INTEGER :: j + INTEGER :: nid, nvarid, ierr + INTEGER, DIMENSION(3) :: start, count + CHARACTER(len=20) :: modname='read_map2D' + + REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D ! 2D global + REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D_tmp ! 2D global + REAL, DIMENSION(klon_glo) :: var_glo1D ! 1D global + INCLUDE "iniprint.h" + +! Read variable from file. Done by master process MPI and master thread OpenMP + IF (is_mpi_root .AND. is_omp_root) THEN + ierr = NF90_OPEN(trim(filename), NF90_NOWRITE, nid) + IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in opening file') + + ierr = NF90_INQ_VARID(nid, trim(varname), nvarid) + IF (ierr /= NF90_NOERR) CALL write_err_mess('The variable is absent in file') + + start=(/1,1,timestep/) + count=(/nbp_lon,nbp_lat,1/) + ierr = NF90_GET_VAR(nid, nvarid, var_glo2D,start,count) + IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in reading varaiable') + + ierr = NF90_CLOSE(nid) + IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in closing file') + + ! Inverse latitude order + IF (inverse) THEN + var_glo2D_tmp(:,:) = var_glo2D(:,:) + DO j=1, nbp_lat + var_glo2D(:,j) = var_glo2D_tmp(:,nbp_lat-j+1) + END DO + END IF + + ! Transform the global field from 2D to 1D + CALL grid2Dto1D_glo(var_glo2D,var_glo1D) + + WRITE(lunout,*) 'in read_map2D, filename = ', trim(filename) + WRITE(lunout,*) 'in read_map2D, varname = ', trim(varname) + WRITE(lunout,*) 'in read_map2D, timestep = ', timestep + ENDIF + +! Scatter gloabl 1D variable to all processes + CALL scatter(var_glo1D, varout) + + CONTAINS + SUBROUTINE write_err_mess(err_mess) + + CHARACTER(len=*), INTENT(IN) :: err_mess + INCLUDE "iniprint.h" + + WRITE(lunout,*) 'Error in read_map2D, filename = ', trim(filename) + WRITE(lunout,*) 'Error in read_map2D, varname = ', trim(varname) + WRITE(lunout,*) 'Error in read_map2D, timestep = ', timestep + + CALL abort_gcm(modname, err_mess, 1) + + END SUBROUTINE write_err_mess + +END SUBROUTINE read_map2D Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_pstoke.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_pstoke.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_pstoke.F (revision 1634) @@ -0,0 +1,488 @@ +! +! $Id$ +! +c +c + subroutine read_pstoke(irec, + . zrec,zklono,zklevo,airefi,phisfi, + . t,mfu,mfd,en_u,de_u,en_d,de_d,coefh, + . fm_therm,en_therm, + . frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf) + +C****************************************************************************** +C Frederic HOURDIN, Abderrahmane IDELKADI +C Lecture des parametres physique stockes online necessaires pour +C recalculer offline le transport de traceurs sur une grille 2x plus fine que +C celle online +C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)! +C****************************************************************************** + + use netcdf + USE dimphy + USE control_mod + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "indicesol.h" +cccc#include "dimphy.h" + + integer klono,klevo,imo,jmo + parameter (imo=iim/2,jmo=(jjm+1)/2) + parameter(klono=(jmo-1)*imo+2,klevo=llm) + REAL phisfi(klono) + REAL phisfi2(imo,jmo+1),airefi2(imo,jmo+1) + + REAL mfu(klono,klevo), mfd(klono,klevo) + REAL en_u(klono,klevo), de_u(klono,klevo) + REAL en_d(klono,klevo), de_d(klono,klevo) + REAL coefh(klono,klevo) + REAL fm_therm(klono,klevo),en_therm(klono,klevo) + + REAL mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo) + REAL en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo) + REAL en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo) + REAL coefh2(imo,jmo+1,klevo) + REAL fm_therm2(imo,jmo+1,klevo) + REAL en_therm2(imo,jmo+1,klevo) + + REAL pl(klevo) + integer irec + integer xid,yid,zid,tid + real zrec,zklono,zklevo,zim,zjm + integer ncrec,ncklono,ncklevo,ncim,ncjm + + real airefi(klono) + character*20 namedim + +c !! attention !! +c attention il y a aussi le pb de def klono +c dim de phis?? + + + REAL frac_impa(klono,klevo), frac_nucl(klono,klevo) + REAL frac_impa2(imo,jmo+1,klevo), + . frac_nucl2(imo,jmo+1,klevo) + REAL pyu1(klono), pyv1(klono) + REAL pyu12(imo,jmo+1), pyv12(imo,jmo+1) + REAL ftsol(klono,nbsrf) + REAL psrf(klono,nbsrf) + REAL ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono) + REAL psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono) + REAL ftsol12(imo,jmo+1),ftsol22(imo,jmo+1), + . ftsol32(imo,jmo+1), + . ftsol42(imo,jmo+1) + REAL psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1), + . psrf42(imo,jmo+1) + REAL t(klono,klevo) + REAL t2(imo,jmo+1,klevo) + integer ncidp + save ncidp + integer varidt + integer varidmfu, varidmfd, varidps, varidenu, variddeu + integer varidend,varidded,varidch,varidfi,varidfn + integer varidfmth,varidenth + integer varidyu1,varidyv1,varidpl,varidai,varididvt + integer varidfts1,varidfts2,varidfts3,varidfts4 + integer varidpsr1,varidpsr2,varidpsr3,varidpsr4 + save varidmfu, varidmfd, varidps, varidenu, variddeu + save varidend,varidded,varidch,varidfi,varidfn + save varidfmth,varidenth + save varidyu1,varidyv1,varidpl,varidai,varididvt + save varidfts1,varidfts2,varidfts3,varidfts4 + save varidpsr1,varidpsr2,varidpsr3,varidpsr4 + save varidt + + integer l, i + integer start(4),count(4),status + real rcode + logical first + save first + data first/.true./ + + + +c --------------------------------------------- +c Initialisation de la lecture des fichiers +c --------------------------------------------- + + if (irec .eq. 0) then + + rcode=nf90_open('phystoke.nc',nf90_nowrite,ncidp) + + rcode = nf90_inq_varid(ncidp, 'phis', varidps) + print*,'ncidp,varidps',ncidp,varidps + + rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl) + print*,'ncidp,varidpl',ncidp,varidpl + + rcode = nf90_inq_varid(ncidp, 'aire', varidai) + print*,'ncidp,varidai',ncidp,varidai + +c A FAIRE: Es-il necessaire de stocke t? + rcode = nf90_inq_varid(ncidp, 't', varidt) + print*,'ncidp,varidt',ncidp,varidt + + rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu) + print*,'ncidp,varidmfu',ncidp,varidmfu + + rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd) + print*,'ncidp,varidmfd',ncidp,varidmfd + + rcode = nf90_inq_varid(ncidp, 'en_u', varidenu) + print*,'ncidp,varidenu',ncidp,varidenu + + rcode = nf90_inq_varid(ncidp, 'de_u', variddeu) + print*,'ncidp,variddeu',ncidp,variddeu + + rcode = nf90_inq_varid(ncidp, 'en_d', varidend) + print*,'ncidp,varidend',ncidp,varidend + + rcode = nf90_inq_varid(ncidp, 'de_d', varidded) + print*,'ncidp,varidded',ncidp,varidded + + rcode = nf90_inq_varid(ncidp, 'coefh', varidch) + print*,'ncidp,varidch',ncidp,varidch + +c abder (pour thermiques) + rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth) + print*,'ncidp,varidfmth',ncidp,varidfmth + + rcode = nf90_inq_varid(ncidp, 'en_th', varidenth) + print*,'ncidp,varidenth',ncidp,varidenth + + rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi) + print*,'ncidp,varidfi',ncidp,varidfi + + rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn) + print*,'ncidp,varidfn',ncidp,varidfn + + rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1) + print*,'ncidp,varidyu1',ncidp,varidyu1 + + rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1) + print*,'ncidp,varidyv1',ncidp,varidyv1 + + rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1) + print*,'ncidp,varidfts1',ncidp,varidfts1 + + rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2) + print*,'ncidp,varidfts2',ncidp,varidfts2 + + rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3) + print*,'ncidp,varidfts3',ncidp,varidfts3 + + rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4) + print*,'ncidp,varidfts4',ncidp,varidfts4 + + rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1) + print*,'ncidp,varidpsr1',ncidp,varidpsr1 + + rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2) + print*,'ncidp,varidpsr2',ncidp,varidpsr2 + + rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3) + print*,'ncidp,varidpsr3',ncidp,varidpsr3 + + rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4) + print*,'ncidp,varidpsr4',ncidp,varidpsr4 + +c ID pour les dimensions + + status = nf_inq_dimid(ncidp,'y',yid) + status = nf_inq_dimid(ncidp,'x',xid) + status = nf_inq_dimid(ncidp,'sig_s',zid) + status = nf_inq_dimid(ncidp,'time_counter',tid) + +c lecture des dimensions + + status = nf_inq_dim(ncidp,yid,namedim,ncjm) + status = nf_inq_dim(ncidp,xid,namedim,ncim) + status = nf_inq_dim(ncidp,zid,namedim,ncklevo) + status = nf_inq_dim(ncidp,tid,namedim,ncrec) + + zrec=ncrec + zklevo=ncklevo + zim=ncim + zjm=ncjm + + zklono=zim*(zjm-2)+2 + + write(*,*) 'read_pstoke : zrec = ', zrec + write(*,*) 'read_pstoke : zklevo = ', zklevo + write(*,*) 'read_pstoke : zim = ', zim + write(*,*) 'read_pstoke : zjm = ', zjm + write(*,*) 'read_pstoke : zklono = ', zklono + +c niveaux de pression +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpl,1,zklevo,pl) +#else + status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl) +#endif + +c lecture de aire et phis + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=0 + + count(1)=zim + count(2)=zjm + count(3)=1 + count(4)=0 + +c phis +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi) + +c aire +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi) + else + + print*,'ok1' + +c --------------------- +c lecture des champs +c --------------------- + + print*,'WARNING!!! Il n y a pas de test de coherence' + print*,'sur le nombre de niveaux verticaux dans le fichier nc' + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=irec + + count(1)=zim + count(2)=zjm + count(3)=zklevo + count(4)=1 + + +C *** Lessivage****************************************************** +c frac_impa +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa) + +c frac_nucl +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl) + +C*** Temperature ****************************************************** +c abder t +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2) +#else + status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t) + +C*** Flux pour le calcul de la convection TIEDTK *********************** +c mfu +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu) + +c mfd +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd) + +c en_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u) + +c de_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2) +#else + status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u) + +c en_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d) + +c de_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d) + +C **** Coeffecient du mellange turbulent********************************** +c coefh +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2) +#else + status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh) + +C*** Flux ascendant et entrant pour les Thermiques************************ +cabder thermiques +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,count,fm_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfmth,start,count,fm_therm2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,fm_therm2,fm_therm) + +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,count,en_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenth,start,count,en_therm2) +#endif + call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_therm2,en_therm) + +C*** Vitesses aux sol ****************************************************** + start(3)=irec + start(4)=0 + count(3)=1 + count(4)=0 +c pyu1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1) + +c pyv1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1) + +C*** Temperature au sol ******************************************** +c ftsol1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1) + +c ftsol2 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2) + +c ftsol3 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3) + +c ftsol4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4) + +C*** Nature du sol ************************************************** +c psrf1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1) + +c psrf2 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2) + +c psrf3 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3) + +c psrf4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42) +#endif + call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4) + + do i = 1,klono + + psrf(i,1) = psrf1(i) + psrf(i,2) = psrf2(i) + psrf(i,3) = psrf3(i) + psrf(i,4) = psrf4(i) + + ftsol(i,1) = ftsol1(i) + ftsol(i,2) = ftsol2(i) + ftsol(i,3) = ftsol3(i) + ftsol(i,4) = ftsol4(i) + + enddo + + endif + + return + + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_pstoke0.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_pstoke0.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/read_pstoke0.F (revision 1634) @@ -0,0 +1,512 @@ +! +! $Id$ +! +c +c + subroutine read_pstoke0(irec, + . zrec,zkon,zkev,airefi,phisfi, + . t,mfu,mfd,en_u,de_u,en_d,de_d,coefh, + . fm_therm,en_therm, + . frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf) + +C****************************************************************************** +C Frederic HOURDIN, Abderrahmane IDELKADI +C Lecture des parametres physique stockes online necessaires pour +C recalculer offline le transport des traceurs sur la meme grille que online +C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)! +C****************************************************************************** + + use netcdf + USE dimphy + USE control_mod + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "indicesol.h" +cccc#include "dimphy.h" + + integer kon,kev,zkon,zkev + parameter(kon=iim*(jjm-1)+2,kev=llm) + REAL phisfi(kon) + REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1) + + REAL mfu(kon,kev), mfd(kon,kev) + REAL en_u(kon,kev), de_u(kon,kev) + REAL en_d(kon,kev), de_d(kon,kev) + REAL coefh(kon,kev) + +c abd 25 11 02 +c Thermiques + REAL fm_therm(kon,kev),en_therm(kon,kev) + REAL t(kon,kev) + + REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev) + REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev) + REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev) + REAL coefh2(iim,jjm+1,kev) + REAL t2(iim,jjm+1,kev) +c Thermiques + REAL fm_therm2(iim,jjm+1,kev) + REAL en_therm2(iim,jjm+1,kev) + + REAL pl(kev) + integer irec + integer xid,yid,zid,tid + integer zrec,zim,zjm + integer ncrec,nckon,nckev,ncim,ncjm + + real airefi(kon) + character*20 namedim + +c !! attention !! +c attention il y a aussi le pb de def kon +c dim de phis?? + + REAL frac_impa(kon,kev), frac_nucl(kon,kev) + REAL frac_impa2(iim,jjm+1,kev), + . frac_nucl2(iim,jjm+1,kev) + REAL pyu1(kon), pyv1(kon) + REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1) + REAL ftsol(kon,nbsrf) + REAL psrf(kon,nbsrf) + REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon) + REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon) + REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1), + . ftsol32(iim,jjm+1), + . ftsol42(iim,jjm+1) + REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1), + . psrf42(iim,jjm+1) + + integer ncidp + save ncidp + integer varidmfu, varidmfd, varidps, varidenu, variddeu + integer varidt + integer varidend,varidded,varidch,varidfi,varidfn +c therm + integer varidfmth,varidenth + integer varidyu1,varidyv1,varidpl,varidai,varididvt + integer varidfts1,varidfts2,varidfts3,varidfts4 + integer varidpsr1,varidpsr2,varidpsr3,varidpsr4 + save varidmfu, varidmfd, varidps, varidenu, variddeu + save varidt + save varidend,varidded,varidch,varidfi,varidfn +c therm + save varidfmth,varidenth + save varidyu1,varidyv1,varidpl,varidai,varididvt + save varidfts1,varidfts2,varidfts3,varidfts4 + save varidpsr1,varidpsr2,varidpsr3,varidpsr4 + + integer l, i + integer start(4),count(4),status + real rcode + logical first + save first + data first/.true./ + + + +c --------------------------------------------- +c Initialisation de la lecture des fichiers +c --------------------------------------------- + + if (irec .eq. 0) then + + rcode=nf90_open('phystoke.nc',nf90_nowrite,ncidp) + + rcode = nf90_inq_varid(ncidp, 'phis', varidps) + print*,'ncidp,varidps',ncidp,varidps + + rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl) + print*,'ncidp,varidpl',ncidp,varidpl + + rcode = nf90_inq_varid(ncidp, 'aire', varidai) + print*,'ncidp,varidai',ncidp,varidai + + rcode = nf90_inq_varid(ncidp, 't', varidt) + print*,'ncidp,varidt',ncidp,varidt + + rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu) + print*,'ncidp,varidmfu',ncidp,varidmfu + + rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd) + print*,'ncidp,varidmfd',ncidp,varidmfd + + rcode = nf90_inq_varid(ncidp, 'en_u', varidenu) + print*,'ncidp,varidenu',ncidp,varidenu + + rcode = nf90_inq_varid(ncidp, 'de_u', variddeu) + print*,'ncidp,variddeu',ncidp,variddeu + + rcode = nf90_inq_varid(ncidp, 'en_d', varidend) + print*,'ncidp,varidend',ncidp,varidend + + rcode = nf90_inq_varid(ncidp, 'de_d', varidded) + print*,'ncidp,varidded',ncidp,varidded + + rcode = nf90_inq_varid(ncidp, 'coefh', varidch) + print*,'ncidp,varidch',ncidp,varidch + +c Thermiques + rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth) + print*,'ncidp,varidfmth',ncidp,varidfmth + + rcode = nf90_inq_varid(ncidp, 'en_th', varidenth) + print*,'ncidp,varidenth',ncidp,varidenth + + rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi) + print*,'ncidp,varidfi',ncidp,varidfi + + rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn) + print*,'ncidp,varidfn',ncidp,varidfn + + rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1) + print*,'ncidp,varidyu1',ncidp,varidyu1 + + rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1) + print*,'ncidp,varidyv1',ncidp,varidyv1 + + rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1) + print*,'ncidp,varidfts1',ncidp,varidfts1 + + rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2) + print*,'ncidp,varidfts2',ncidp,varidfts2 + + rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3) + print*,'ncidp,varidfts3',ncidp,varidfts3 + + rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4) + print*,'ncidp,varidfts4',ncidp,varidfts4 + + rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1) + print*,'ncidp,varidpsr1',ncidp,varidpsr1 + + rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2) + print*,'ncidp,varidpsr2',ncidp,varidpsr2 + + rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3) + print*,'ncidp,varidpsr3',ncidp,varidpsr3 + + rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4) + print*,'ncidp,varidpsr4',ncidp,varidpsr4 + +c ID pour les dimensions + + status = nf_inq_dimid(ncidp,'y',yid) + status = nf_inq_dimid(ncidp,'x',xid) + status = nf_inq_dimid(ncidp,'sig_s',zid) + status = nf_inq_dimid(ncidp,'time_counter',tid) + +c lecture des dimensions + + status = nf_inq_dim(ncidp,yid,namedim,ncjm) + status = nf_inq_dim(ncidp,xid,namedim,ncim) + status = nf_inq_dim(ncidp,zid,namedim,nckev) + status = nf_inq_dim(ncidp,tid,namedim,ncrec) + + zrec=ncrec + zkev=nckev + zim=ncim + zjm=ncjm + + zkon=zim*(zjm-2)+2 + + write(*,*) 'read_pstoke : zrec = ', zrec + write(*,*) 'read_pstoke : kev = ', zkev + write(*,*) 'read_pstoke : zim = ', zim + write(*,*) 'read_pstoke : zjm = ', zjm + write(*,*) 'read_pstoke : kon = ', zkon + +c niveaux de pression + + status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl) + +c lecture de aire et phis + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=0 + + count(1)=zim + count(2)=zjm + count(3)=1 + count(4)=0 + +c +C**** Geopotentiel au sol *************************************** +c phis +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi) + +C**** Aires des mails aux sol ************************************ +c aire +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2) +#else + status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi) + else + + print*,'ok1' + +c --------------------- +c lecture des champs +c --------------------- + + print*,'WARNING!!! Il n y a pas de test de coherence' + print*,'sur le nombre de niveaux verticaux dans le fichier nc' + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=irec + + count(1)=zim + count(2)=zjm + count(3)=kev + count(4)=1 + +C**** Temperature ******************************************** +cA FAIRE : Es-ce necessaire ? + +c abder t +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2) +#else + status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t) + +C**** Flux pour la convection (Tiedtk) ******************************************** +c mfu +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu) + +c mfd +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2) +#else + status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd) + +c en_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u) + +c de_u +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2) +#else + status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u) + +c en_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d) + +c de_d +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2) +#else + status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d) + +C**** Coefficient de mellange turbulent ******************************************* +c coefh + print*,'LECTURE de coefh a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2) +#else + status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh) +c call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ ') +c call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ ') + +C**** Flux ascendants et entrant dans le thermique ********************************** +cThermiques + print*,'LECTURE de fm_therm a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start, + . count,fm_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfmth,start, + . count,fm_therm2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm) + print*,'LECTURE de en_therm a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start, + . count,en_therm2) +#else + status=NF_GET_VARA_REAL(ncidp,varidenth,start, + . count,en_therm2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm) + +C**** Coefficients de lessivage ******************************************* +c frac_impa +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa) + +c frac_nucl + +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2) +#else + status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2) +#endif + call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl) + +C**** Vents aux sol ******************************************** + + start(3)=irec + start(4)=0 + count(3)=1 + count(4)=0 + +c pyu1 + print*,'LECTURE de yu1 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1) + +c pyv1 + print*,'LECTURE de yv1 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12) +#else + status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1) + +C**** Temerature au sol ******************************************** +c ftsol1 + print*,'LECTURE de ftsol1 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1) + +c ftsol2 + print*,'LECTURE de ftsol2 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2) + +c ftsol3 + print*,'LECTURE de ftsol3 a irec =',irec +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3) + +c ftsol4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42) +#else + status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4) + +C**** Nature sol ******************************************** +c psrf1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12) +#endif +c call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC') + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1) + +c psrf2 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22) +#endif +c call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC') + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2) + +c psrf3 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3) + +c psrf4 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42) +#else + status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42) +#endif + call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4) + + do i = 1,kon + + psrf(i,1) = psrf1(i) + psrf(i,2) = psrf2(i) + psrf(i,3) = psrf3(i) +c test abderr +c print*,'Dans read_pstoke psrf3 =',psrf3(i),i + psrf(i,4) = psrf4(i) + + ftsol(i,1) = ftsol1(i) + ftsol(i,2) = ftsol2(i) + ftsol(i,3) = ftsol3(i) + ftsol(i,4) = ftsol4(i) + + enddo + + endif + + return + + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol.F90 (revision 1634) @@ -0,0 +1,587 @@ +! $Id$ +! +MODULE readaerosol_mod + + REAL, SAVE :: not_valid=-333. + +CONTAINS + +SUBROUTINE readaerosol(name_aero, type, filename, iyr_in, klev_src, pt_ap, pt_b, pt_out, psurf, load) + +!**************************************************************************************** +! This routine will read the aersosol from file. +! +! Read a year data with get_aero_fromfile depending on aer_type : +! - actuel : read year 1980 +! - preind : read natural data +! - scenario : read one or two years and do eventually linare time interpolation +! +! Return pointer, pt_out, to the year read or result from interpolation +!**************************************************************************************** + USE dimphy + + IMPLICIT NONE + + INCLUDE "iniprint.h" + + ! Input arguments + CHARACTER(len=7), INTENT(IN) :: name_aero + CHARACTER(len=*), INTENT(IN) :: type ! actuel, annuel, scenario or preind + CHARACTER(len=8), INTENT(IN) :: filename + INTEGER, INTENT(IN) :: iyr_in + + ! Output + INTEGER, INTENT(OUT) :: klev_src + REAL, POINTER, DIMENSION(:) :: pt_ap ! Pointer for describing the vertical levels + REAL, POINTER, DIMENSION(:) :: pt_b ! Pointer for describing the vertical levels + REAL, POINTER, DIMENSION(:,:,:) :: pt_out ! The massvar distributions, DIMENSION(klon, klev_src, 12) + REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf ! Surface pression for 12 months + REAL, DIMENSION(klon,12), INTENT(OUT) :: load ! Aerosol mass load in each column for 12 months + + ! Local variables + CHARACTER(len=4) :: cyear + REAL, POINTER, DIMENSION(:,:,:) :: pt_2 + REAL, DIMENSION(klon,12) :: psurf2, load2 + REAL :: p0 ! Reference pressure + INTEGER :: iyr1, iyr2, klev_src2 + INTEGER :: it, k, i + LOGICAL, PARAMETER :: lonlyone=.FALSE. + +!**************************************************************************************** +! Read data depending on aer_type +! +!**************************************************************************************** + + IF (type == 'actuel') THEN +! Read and return data for year 1980 +!**************************************************************************************** + cyear='1980' + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + + ELSE IF (type == 'preind') THEN +! Read and return data from file with suffix .nat +!**************************************************************************************** + cyear='.nat' + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ELSE IF (type == 'annuel') THEN +! Read and return data from scenario annual files +!**************************************************************************************** + WRITE(cyear,'(I4)') iyr_in + WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,' ',cyear + ! get_aero_fromfile returns pt_out allocated and initialized with data for nbr_tsteps month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ELSE IF (type == 'scenario') THEN +! Read data depending on actual year and interpolate if necessary +!**************************************************************************************** + IF (iyr_in .LT. 1850) THEN + cyear='.nat' + WRITE(lunout,*) 'get_aero 1 iyr_in=', iyr_in,' ',cyear + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ELSE IF (iyr_in .GE. 2100) THEN + cyear='2100' + WRITE(lunout,*) 'get_aero 2 iyr_in=', iyr_in,' ',cyear + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ELSE + ! Read data from 2 decades and interpolate to actual year + ! a) from actual 10-yr-period + IF (iyr_in.LT.1900) THEN + iyr1 = 1850 + iyr2 = 1900 + ELSE IF (iyr_in.GE.1900.AND.iyr_in.LT.1920) THEN + iyr1 = 1900 + iyr2 = 1920 + ELSE + iyr1 = INT(iyr_in/10)*10 + iyr2 = INT(1+iyr_in/10)*10 + ENDIF + + WRITE(cyear,'(I4)') iyr1 + WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,' ',cyear + ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month + ! pt_out has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load) + + ! If to read two decades: + IF (.NOT.lonlyone) THEN + + ! b) from the next following one + WRITE(cyear,'(I4)') iyr2 + WRITE(lunout,*) 'get_aero 4 iyr_in=', iyr_in,' ',cyear + + NULLIFY(pt_2) + ! get_aero_fromfile returns pt_2 allocated and initialized with data for 12 month + ! pt_2 has dimensions (klon, klev_src, 12) + CALL get_aero_fromfile(name_aero, cyear, filename, klev_src2, pt_ap, pt_b, p0, pt_2, psurf2, load2) + ! Test for same number of vertical levels + IF (klev_src /= klev_src2) THEN + WRITE(lunout,*) 'Two aerosols files with different number of vertical levels is not allowded' + CALL abort_gcm('readaersosol','Error in number of vertical levels',1) + END IF + + ! Linare interpolate to the actual year: + DO it=1,12 + DO k=1,klev_src + DO i = 1, klon + pt_out(i,k,it) = & + pt_out(i,k,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * & + (pt_out(i,k,it) - pt_2(i,k,it)) + END DO + END DO + + DO i = 1, klon + psurf(i,it) = & + psurf(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * & + (psurf(i,it) - psurf2(i,it)) + + load(i,it) = & + load(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * & + (load(i,it) - load2(i,it)) + END DO + END DO + + ! Deallocate pt_2 no more needed + DEALLOCATE(pt_2) + + END IF ! lonlyone + END IF ! iyr_in .LT. 1850 + + ELSE + WRITE(lunout,*)'This option is not implemented : aer_type = ', type,' name_aero=',name_aero + CALL abort_gcm('readaerosol','Error : aer_type parameter not accepted',1) + END IF ! type + + +END SUBROUTINE readaerosol + + + SUBROUTINE get_aero_fromfile(varname, cyr, filename, klev_src, pt_ap, pt_b, p0, pt_year, psurf_out, load_out) +!**************************************************************************************** +! Read 12 month aerosol from file and distribute to local process on physical grid. +! Vertical levels, klev_src, may differ from model levels if new file format. +! +! For mpi_root and master thread : +! 1) Open file +! 2) Find vertical dimension klev_src +! 3) Read field month by month +! 4) Close file +! 5) Transform the global field from 2D(iim, jjp+1) to 1D(klon_glo) +! - Also the levels and the latitudes have to be inversed +! +! For all processes and threads : +! 6) Scatter global field(klon_glo) to local process domain(klon) +! 7) Test for negative values +!**************************************************************************************** + + USE netcdf + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + USE iophy, ONLY : io_lon, io_lat + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" + +! Input argumets + CHARACTER(len=7), INTENT(IN) :: varname + CHARACTER(len=4), INTENT(IN) :: cyr + CHARACTER(len=8), INTENT(IN) :: filename + +! Output arguments + INTEGER, INTENT(OUT) :: klev_src ! Number of vertical levels in file + REAL, POINTER, DIMENSION(:) :: pt_ap ! Pointer for describing the vertical levels + REAL, POINTER, DIMENSION(:) :: pt_b ! Pointer for describing the vertical levels + REAL :: p0 ! Reference pressure value + REAL, POINTER, DIMENSION(:,:,:) :: pt_year ! Pointer-variabale from file, 12 month, grid : klon,klev_src + REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf_out ! Surface pression for 12 months + REAL, DIMENSION(klon,12), INTENT(OUT) :: load_out ! Aerosol mass load in each column + INTEGER :: nbr_tsteps ! number of month in file read + +! Local variables + CHARACTER(len=30) :: fname + CHARACTER(len=30) :: cvar + INTEGER :: ncid, dimid, varid + INTEGER :: imth, i, j, k, ierr + REAL :: npole, spole + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: varmth + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: varyear ! Global variable read from file, 12 month + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: varyear_glo1D !(klon_glo, klev_src, 12) + REAL, ALLOCATABLE, DIMENSION(:) :: varktmp + + REAL, DIMENSION(iim,jjm+1,12) :: psurf_glo2D ! Surface pression for 12 months on dynamics global grid + REAL, DIMENSION(klon_glo,12) :: psurf_glo1D ! -"- on physical global grid + REAL, DIMENSION(iim,jjm+1,12) :: load_glo2D ! Load for 12 months on dynamics global grid + REAL, DIMENSION(klon_glo,12) :: load_glo1D ! -"- on physical global grid + REAL, DIMENSION(iim,jjm+1) :: vartmp + REAL, DIMENSION(iim) :: lon_src ! longitudes in file + REAL, DIMENSION(jjm+1) :: lat_src, lat_src_inv ! latitudes in file + LOGICAL :: new_file ! true if new file format detected + LOGICAL :: invert_lat ! true if the field has to be inverted for latitudes + + + ! Deallocate pointers + IF (ASSOCIATED(pt_ap)) DEALLOCATE(pt_ap) + IF (ASSOCIATED(pt_b)) DEALLOCATE(pt_b) + + IF (is_mpi_root .AND. is_omp_root) THEN + +! 1) Open file +!**************************************************************************************** +! Add suffix to filename + fname = trim(filename)//cyr//'.nc' + + WRITE(lunout,*) 'reading variable ',TRIM(varname),' in file ', TRIM(fname) + CALL check_err( nf90_open(TRIM(fname), NF90_NOWRITE, ncid) ) + +! Test for equal longitudes and latitudes in file and model +!**************************************************************************************** + ! Read and test longitudes + CALL check_err( nf90_inq_varid(ncid, 'lon', varid) ) + CALL check_err( nf90_get_var(ncid, varid, lon_src(:)) ) + + IF (maxval(ABS(lon_src - io_lon)) > 0.001) THEN + WRITE(lunout,*) 'Problem in longitudes read from file : ',TRIM(fname) + WRITE(lunout,*) 'longitudes in file ', TRIM(fname),' : ', lon_src + WRITE(lunout,*) 'longitudes in model :', io_lon + + CALL abort_gcm('get_aero_fromfile', 'longitudes are not the same in file and model',1) + END IF + + ! Read and test latitudes + CALL check_err( nf90_inq_varid(ncid, 'lat', varid) ) + CALL check_err( nf90_get_var(ncid, varid, lat_src(:)) ) + + ! Invert source latitudes + DO j = 1, jjm+1 + lat_src_inv(j) = lat_src(jjm+1 +1 -j) + END DO + + IF (maxval(ABS(lat_src - io_lat)) < 0.001) THEN + ! Latitudes are the same + invert_lat=.FALSE. + ELSE IF (maxval(ABS(lat_src_inv - io_lat)) < 0.001) THEN + ! Inverted source latitudes correspond to model latitudes + WRITE(lunout,*) 'latitudes will be inverted for file : ',TRIM(fname) + invert_lat=.TRUE. + ELSE + WRITE(lunout,*) 'Problem in latitudes read from file : ',TRIM(fname) + WRITE(lunout,*) 'latitudes in file ', TRIM(fname),' : ', lat_src + WRITE(lunout,*) 'latitudes in model :', io_lat + CALL abort_gcm('get_aero_fromfile', 'latitudes do not correspond between file and model',1) + END IF + + +! 2) Check if old or new file is avalabale. +! New type of file should contain the dimension 'lev' +! Old type of file should contain the dimension 'PRESNIVS' +!**************************************************************************************** + ierr = nf90_inq_dimid(ncid, 'lev', dimid) + IF (ierr /= NF90_NOERR) THEN + ! Coordinate axe lev not found. Check for presnivs. + ierr = nf90_inq_dimid(ncid, 'PRESNIVS', dimid) + IF (ierr /= NF90_NOERR) THEN + ! Dimension PRESNIVS not found either + CALL abort_gcm('get_aero_fromfile', 'dimension lev or presnivs not in file',1) + ELSE + ! Old file found + new_file=.FALSE. + WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will not be done' + END IF + ELSE + ! New file found + new_file=.TRUE. + WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will be done' + END IF + +! 2) Find vertical dimension klev_src +!**************************************************************************************** + CALL check_err( nf90_inquire_dimension(ncid, dimid, len = klev_src) ) + + ! Allocate variables depending on the number of vertical levels + ALLOCATE(varmth(iim, jjm+1, klev_src), varyear(iim, jjm+1, klev_src, 12), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 1',1) + + ALLOCATE(pt_ap(klev_src), pt_b(klev_src), varktmp(klev_src), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 2',1) + +! 3) Read all variables from file +! There is 2 options for the file structure : +! new_file=TRUE : read varyear, ps, pt_ap and pt_b +! new_file=FALSE : read varyear month by month +!**************************************************************************************** + + IF (new_file) THEN +! ++) Check number of month in file opened +!************************************************************************************************** + ierr = nf90_inq_dimid(ncid, 'TIME',dimid) + CALL check_err( nf90_inquire_dimension(ncid, dimid, len = nbr_tsteps) ) +! IF (nbr_tsteps /= 12 .AND. nbr_tsteps /= 14) THEN + IF (nbr_tsteps /= 12 ) THEN + CALL abort_gcm('get_aero_fromfile', 'not the right number of months in aerosol file read (should be 12 for the moment)',1) + ENDIF + +! ++) Read the aerosol concentration month by month and concatenate to total variable varyear +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, TRIM(varname), varid) ) + + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, varyear(:,:,:,:)) ) + +! ++) Read surface pression, 12 month in one variable +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "ps", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, psurf_glo2D) ) + +! ++) Read mass load, 12 month in one variable +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "load_"//TRIM(varname), varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, load_glo2D) ) + +! ++) Read ap +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "ap", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, pt_ap) ) + +! ++) Read b +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "b", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, pt_b) ) + +! ++) Read p0 : reference pressure +!**************************************************************************************** + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, "p0", varid) ) + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, p0) ) + + + ELSE ! old file + +! ++) Read the aerosol concentration month by month and concatenate to total variable varyear +!**************************************************************************************** + DO imth=1, 12 + IF (imth.EQ.1) THEN + cvar=TRIM(varname)//'JAN' + ELSE IF (imth.EQ.2) THEN + cvar=TRIM(varname)//'FEB' + ELSE IF (imth.EQ.3) THEN + cvar=TRIM(varname)//'MAR' + ELSE IF (imth.EQ.4) THEN + cvar=TRIM(varname)//'APR' + ELSE IF (imth.EQ.5) THEN + cvar=TRIM(varname)//'MAY' + ELSE IF (imth.EQ.6) THEN + cvar=TRIM(varname)//'JUN' + ELSE IF (imth.EQ.7) THEN + cvar=TRIM(varname)//'JUL' + ELSE IF (imth.EQ.8) THEN + cvar=TRIM(varname)//'AUG' + ELSE IF (imth.EQ.9) THEN + cvar=TRIM(varname)//'SEP' + ELSE IF (imth.EQ.10) THEN + cvar=TRIM(varname)//'OCT' + ELSE IF (imth.EQ.11) THEN + cvar=TRIM(varname)//'NOV' + ELSE IF (imth.EQ.12) THEN + cvar=TRIM(varname)//'DEC' + END IF + + ! Get variable id + CALL check_err( nf90_inq_varid(ncid, TRIM(cvar), varid) ) + + ! Get the variable + CALL check_err( nf90_get_var(ncid, varid, varmth) ) + + ! Store in variable for the whole year + varyear(:,:,:,imth)=varmth(:,:,:) + + END DO + + ! Putting dummy + psurf_glo2D(:,:,:) = not_valid + load_glo2D(:,:,:) = not_valid + pt_ap(:) = not_valid + pt_b(:) = not_valid + + END IF + +! 4) Close file +!**************************************************************************************** + CALL check_err( nf90_close(ncid) ) + + +! 5) Transform the global field from 2D(iim, jjp+1) to 1D(klon_glo) +!**************************************************************************************** +! Test if vertical levels have to be inversed + + IF ((pt_b(1) < pt_b(klev_src)) .OR. .NOT. new_file) THEN +! WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' needs to be inverted' +! WRITE(lunout,*) 'before pt_ap = ', pt_ap +! WRITE(lunout,*) 'before pt_b = ', pt_b + + ! Inverse vertical levels for varyear + DO imth=1, 12 + varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly + DO k=1, klev_src + DO j=1, jjm+1 + DO i=1,iim + varyear(i,j,k,imth) = varmth(i,j,klev_src+1-k) + END DO + END DO + END DO + END DO + + ! Inverte vertical axes for pt_ap and pt_b + varktmp(:) = pt_ap(:) + DO k=1, klev_src + pt_ap(k) = varktmp(klev_src+1-k) + END DO + + varktmp(:) = pt_b(:) + DO k=1, klev_src + pt_b(k) = varktmp(klev_src+1-k) + END DO + WRITE(lunout,*) 'after pt_ap = ', pt_ap + WRITE(lunout,*) 'after pt_b = ', pt_b + + ELSE + WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' is ok, no vertical inversion is done' + WRITE(lunout,*) 'pt_ap = ', pt_ap + WRITE(lunout,*) 'pt_b = ', pt_b + END IF + +! - Invert latitudes if necessary + DO imth=1, 12 + IF (invert_lat) THEN + + ! Invert latitudes for the variable + varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly + DO k=1,klev_src + DO j=1,jjm+1 + DO i=1,iim + varyear(i,j,k,imth) = varmth(i,jjm+1+1-j,k) + END DO + END DO + END DO + + ! Invert latitudes for surface pressure + vartmp(:,:) = psurf_glo2D(:,:,imth) + DO j=1, jjm+1 + DO i=1,iim + psurf_glo2D(i,j,imth)= vartmp(i,jjm+1+1-j) + END DO + END DO + + ! Invert latitudes for the load + vartmp(:,:) = load_glo2D(:,:,imth) + DO j=1, jjm+1 + DO i=1,iim + load_glo2D(i,j,imth)= vartmp(i,jjm+1+1-j) + END DO + END DO + END IF ! invert_lat + + ! Do zonal mead at poles and distribut at whole first and last latitude + DO k=1, klev_src + npole=0. ! North pole, j=1 + spole=0. ! South pole, j=jjm+1 + DO i=1,iim + npole = npole + varyear(i,1,k,imth) + spole = spole + varyear(i,jjm+1,k,imth) + END DO + npole = npole/REAL(iim) + spole = spole/REAL(iim) + varyear(:,1, k,imth) = npole + varyear(:,jjm+1,k,imth) = spole + END DO + END DO ! imth + + ALLOCATE(varyear_glo1D(klon_glo, klev_src, 12), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 3',1) + + ! Transform from 2D to 1D field + CALL grid2Dto1D_glo(varyear,varyear_glo1D) + CALL grid2Dto1D_glo(psurf_glo2D,psurf_glo1D) + CALL grid2Dto1D_glo(load_glo2D,load_glo1D) + + ELSE + ALLOCATE(varyear_glo1D(0,0,0)) + END IF ! is_mpi_root .AND. is_omp_root + +!$OMP BARRIER + +! 6) Distribute to all processes +! Scatter global field(klon_glo) to local process domain(klon) +! and distribute klev_src to all processes +!**************************************************************************************** + + ! Distribute klev_src + CALL bcast(klev_src) + + ! Allocate and distribute pt_ap and pt_b + IF (.NOT. ASSOCIATED(pt_ap)) THEN ! if pt_ap is allocated also pt_b is allocated + ALLOCATE(pt_ap(klev_src), pt_b(klev_src), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 4',1) + END IF + CALL bcast(pt_ap) + CALL bcast(pt_b) + + ! Allocate space for output pointer variable at local process + IF (ASSOCIATED(pt_year)) DEALLOCATE(pt_year) + ALLOCATE(pt_year(klon, klev_src, 12), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 5',1) + + ! Scatter global field to local domain at local process + CALL scatter(varyear_glo1D, pt_year) + CALL scatter(psurf_glo1D, psurf_out) + CALL scatter(load_glo1D, load_out) + +! 7) Test for negative values +!**************************************************************************************** + IF (MINVAL(pt_year) < 0.) THEN + WRITE(lunout,*) 'Warning! Negative values read from file :', fname + END IF + + END SUBROUTINE get_aero_fromfile + + + SUBROUTINE check_err(status) + USE netcdf + IMPLICIT NONE + + INCLUDE "iniprint.h" + INTEGER, INTENT (IN) :: status + + IF (status /= NF90_NOERR) THEN + WRITE(lunout,*) 'Error in get_aero_fromfile ',status + CALL abort_gcm('get_aero_fromfile',trim(nf90_strerror(status)),1) + END IF + + END SUBROUTINE check_err + + +END MODULE readaerosol_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol_interp.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol_interp.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol_interp.F90 (revision 1634) @@ -0,0 +1,571 @@ +! $Id$ +! +SUBROUTINE readaerosol_interp(id_aero, itap, pdtphys, r_day, first, pplay, paprs, t_seri, mass_out, pi_mass_out, load_src) +! +! This routine will return the mass concentration at actual day(mass_out) and +! the pre-industrial values(pi_mass_out) for aerosol corresponding to "id_aero". +! The mass concentrations for all aerosols are saved in this routine but each +! call to this routine only treats the aerosol "id_aero". +! +! 1) Read in data for the whole year, only at first time step +! 2) Interpolate to the actual day, only at new day +! 3) Interpolate to the model vertical grid (target grid), only at new day +! 4) Test for negative mass values + + USE ioipsl + USE dimphy, ONLY : klev,klon + USE mod_phys_lmdz_para, ONLY : mpi_rank + USE readaerosol_mod + USE aero_mod, ONLY : naero_spc, name_aero + USE write_field_phy + USE phys_cal_mod + + IMPLICIT NONE + + INCLUDE "YOMCST.h" + INCLUDE "chem.h" + INCLUDE "temps.h" + INCLUDE "clesphys.h" + INCLUDE "iniprint.h" + INCLUDE "dimensions.h" + INCLUDE "comvert.h" +! +! Input: +!**************************************************************************************** + INTEGER, INTENT(IN) :: id_aero! Identity number for the aerosol to treat + INTEGER, INTENT(IN) :: itap ! Physic step count + REAL, INTENT(IN) :: pdtphys! Physic day step + REAL, INTENT(IN) :: r_day ! Day of integration + LOGICAL, INTENT(IN) :: first ! First model timestep + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! pression at model mid-layers + REAL, DIMENSION(klon,klev+1),INTENT(IN):: paprs ! pression between model layers + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri ! air temperature +! +! Output: +!**************************************************************************************** + REAL, INTENT(OUT) :: mass_out(klon,klev) ! Mass of aerosol (monthly mean data,from file) [ug AIBCM/m3] + REAL, INTENT(OUT) :: pi_mass_out(klon,klev) ! Mass of preindustrial aerosol (monthly mean data,from file) [ug AIBCM/m3] + REAL, INTENT(OUT) :: load_src(klon) ! Load of aerosol (monthly mean data,from file) [kg/m3] +! +! Local Variables: +!**************************************************************************************** + INTEGER :: i, k, ierr + INTEGER :: iday, iyr, lmt_pas +! INTEGER :: im, day1, day2, im2 + INTEGER :: im, im2 + REAL :: day1, day2 + INTEGER :: pi_klev_src ! Only for testing purpose + INTEGER, SAVE :: klev_src ! Number of vertical levles in source field +!$OMP THREADPRIVATE(klev_src) + + REAL :: zrho ! Air density [kg/m3] + REAL :: volm ! Volyme de melange [kg/kg] + REAL, DIMENSION(klon) :: psurf_day, pi_psurf_day + REAL, DIMENSION(klon) :: pi_load_src ! Mass load at source grid + REAL, DIMENSION(klon) :: load_tgt, load_tgt_test + REAL, DIMENSION(klon,klev) :: delp ! pressure difference in each model layer + + REAL, ALLOCATABLE, DIMENSION(:,:) :: pplay_src ! pression mid-layer at source levels + REAL, ALLOCATABLE, DIMENSION(:,:) :: tmp1, tmp2 ! Temporary variables + REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE :: var_year ! VAR in right dimension for the total year + REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE :: pi_var_year ! pre-industrial VAR, -"- +!$OMP THREADPRIVATE(var_year,pi_var_year) + REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: var_day ! VAR interpolated to the actual day and model grid + REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: pi_var_day ! pre-industrial VAR, -"- +!$OMP THREADPRIVATE(var_day,pi_var_day) + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: psurf_year, pi_psurf_year ! surface pressure for the total year +!$OMP THREADPRIVATE(psurf_year, pi_psurf_year) + REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: load_year, pi_load_year ! load in the column for the total year +!$OMP THREADPRIVATE(load_year, pi_load_year) + + REAL, DIMENSION(:,:,:), POINTER :: pt_tmp ! Pointer allocated in readaerosol + REAL, POINTER, DIMENSION(:), SAVE :: pt_ap, pt_b ! Pointer for describing the vertical levels +!$OMP THREADPRIVATE(pt_ap, pt_b) + INTEGER, SAVE :: nbr_tsteps ! number of time steps in file read + REAL, DIMENSION(14), SAVE :: month_len, month_start, month_mid +!$OMP THREADPRIVATE(nbr_tsteps, month_len, month_start, month_mid) + REAL :: jDay + + LOGICAL :: lnewday ! Indicates if first time step at a new day + LOGICAL :: OLDNEWDAY + LOGICAL,SAVE :: vert_interp ! Indicates if vertical interpolation will be done + LOGICAL,SAVE :: debug=.FALSE.! Debugging in this subroutine +!$OMP THREADPRIVATE(vert_interp, debug) + CHARACTER(len=8) :: type + CHARACTER(len=8) :: filename + + +!**************************************************************************************** +! Initialization +! +!**************************************************************************************** + +! Calculation to find if it is a new day + + IF(mpi_rank == 0 .AND. debug )then + PRINT*,'CONTROL PANEL REGARDING TIME STEPING' + ENDIF + + ! Use phys_cal_mod + iday= day_cur + iyr = year_cur + im = mth_cur + +! iday = INT(r_day) +! iyr = iday/360 +! iday = iday-iyr*360 ! day of the actual year +! iyr = iyr + annee_ref ! year of the run +! im = iday/30 +1 ! the actual month + CALL ymds2ju(iyr, im, iday, 0., jDay) +! CALL ymds2ju(iyr, im, iday-(im-1)*30, 0., jDay) + + + IF(MOD(itap-1,NINT(86400./pdtphys)) == 0)THEN + lnewday=.TRUE. + ELSE + lnewday=.FALSE. + ENDIF + + IF(mpi_rank == 0 .AND. debug)then + ! 0.02 is about 0.5/24, namly less than half an hour + OLDNEWDAY = (r_day-REAL(iday) < 0.02) + ! Once per day, update aerosol fields + lmt_pas = NINT(86400./pdtphys) + PRINT*,'r_day-REAL(iday) =',r_day-REAL(iday) + PRINT*,'itap =',itap + PRINT*,'pdtphys =',pdtphys + PRINT*,'lmt_pas =',lmt_pas + PRINT*,'iday =',iday + PRINT*,'r_day =',r_day + PRINT*,'day_cur =',day_cur + PRINT*,'mth_cur =',mth_cur + PRINT*,'year_cur =',year_cur + PRINT*,'NINT(86400./pdtphys) =',NINT(86400./pdtphys) + PRINT*,'MOD(0,1) =',MOD(0,1) + PRINT*,'lnewday =',lnewday + PRINT*,'OLDNEWDAY =',OLDNEWDAY + ENDIF + + IF (.NOT. ALLOCATED(var_day)) THEN + ALLOCATE( var_day(klon, klev, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 1',1) + ALLOCATE( pi_var_day(klon, klev, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 2',1) + + ALLOCATE( psurf_year(klon, 12, naero_spc), pi_psurf_year(klon, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 3',1) + + ALLOCATE( load_year(klon, 12, naero_spc), pi_load_year(klon, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 4',1) + + lnewday=.TRUE. + + NULLIFY(pt_ap) + NULLIFY(pt_b) + END IF + +!**************************************************************************************** +! 1) Read in data : corresponding to the actual year and preindustrial data. +! Only for the first day of the year. +! +!**************************************************************************************** + IF ( (first .OR. iday==0) .AND. lnewday ) THEN + NULLIFY(pt_tmp) + + ! Reading values corresponding to the closest year taking into count the choice of aer_type. + ! For aer_type=scenario interpolation between 2 data sets is done in readaerosol. + ! If aer_type=mix1 or mix2, the run type and file name depends on the aerosol. + IF (aer_type=='preind' .OR. aer_type=='actuel' .OR. aer_type=='annuel' .OR. aer_type=='scenario') THEN + ! Standard case + filename='aerosols' + type=aer_type + ELSE IF (aer_type == 'mix1') THEN + ! Special case using a mix of decenal sulfate file and annual aerosols(all aerosols except sulfate) + IF (name_aero(id_aero) == 'SO4') THEN + filename='so4.run ' + type='scenario' + ELSE + filename='aerosols' + type='annuel' + END IF + ELSE IF (aer_type == 'mix2') THEN + ! Special case using a mix of decenal sulfate file and natrual aerosols + IF (name_aero(id_aero) == 'SO4') THEN + filename='so4.run ' + type='scenario' + ELSE + filename='aerosols' + type='preind' + END IF + ELSE + CALL abort_gcm('readaerosol_interp', 'this aer_type not supported',1) + END IF + + CALL readaerosol(name_aero(id_aero), type, filename, iyr, klev_src, pt_ap, pt_b, pt_tmp, & + psurf_year(:,:,id_aero), load_year(:,:,id_aero)) + IF (.NOT. ALLOCATED(var_year)) THEN + ALLOCATE(var_year(klon, klev_src, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 5',1) + END IF + var_year(:,:,:,id_aero) = pt_tmp(:,:,:) + + ! Reading values corresponding to the preindustrial concentrations. + type='preind' + CALL readaerosol(name_aero(id_aero), type, filename, iyr, pi_klev_src, pt_ap, pt_b, pt_tmp, & + pi_psurf_year(:,:,id_aero), pi_load_year(:,:,id_aero)) + + ! klev_src must be the same in both files. + ! Also supposing pt_ap and pt_b to be the same in the 2 files without testing. + IF (pi_klev_src /= klev_src) THEN + WRITE(lunout,*) 'Error! All forcing files for the same aerosol must have the same vertical dimension' + WRITE(lunout,*) 'Aerosol : ', name_aero(id_aero) + CALL abort_gcm('readaerosol_interp','Differnt vertical axes in aerosol forcing files',1) + END IF + + IF (.NOT. ALLOCATED(pi_var_year)) THEN + ALLOCATE(pi_var_year(klon, klev_src, 12, naero_spc), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 6',1) + END IF + pi_var_year(:,:,:,id_aero) = pt_tmp(:,:,:) + + IF (debug) THEN + CALL writefield_phy('var_year_jan',var_year(:,:,1,id_aero),klev_src) + CALL writefield_phy('var_year_dec',var_year(:,:,12,id_aero),klev_src) + CALL writefield_phy('psurf_src',psurf_year(:,:,id_aero),1) + CALL writefield_phy('pi_psurf_src',pi_psurf_year(:,:,id_aero),1) + CALL writefield_phy('load_year_src',load_year(:,:,id_aero),1) + CALL writefield_phy('pi_load_year_src',pi_load_year(:,:,id_aero),1) + END IF + + ! Pointer no more useful, deallocate. + DEALLOCATE(pt_tmp) + + ! Test if vertical interpolation will be needed. + IF (psurf_year(1,1,id_aero)==not_valid .OR. pi_psurf_year(1,1,id_aero)==not_valid ) THEN + ! Pressure=not_valid indicates old file format, see module readaerosol + vert_interp = .FALSE. + + ! If old file format, both psurf_year and pi_psurf_year must be not_valid + IF ( psurf_year(1,1,id_aero) /= pi_psurf_year(1,1,id_aero) ) THEN + WRITE(lunout,*) 'Warning! All forcing files for the same aerosol must have the same structure' + CALL abort_gcm('readaerosol_interp', 'The aerosol files have not the same format',1) + END IF + + IF (klev /= klev_src) THEN + WRITE(lunout,*) 'Old format of aerosol file do not allowed vertical interpolation' + CALL abort_gcm('readaerosol_interp', 'Old aerosol file not possible',1) + END IF + + ELSE + vert_interp = .TRUE. + END IF + +! Calendar initialisation +! + DO i = 2, 13 + month_len(i) = REAL(ioget_mon_len(year_cur, i-1)) + CALL ymds2ju(year_cur, i-1, 1, 0.0, month_start(i)) + ENDDO + month_len(1) = REAL(ioget_mon_len(year_cur-1, 12)) + CALL ymds2ju(year_cur-1, 12, 1, 0.0, month_start(1)) + month_len(14) = REAL(ioget_mon_len(year_cur+1, 1)) + CALL ymds2ju(year_cur+1, 1, 1, 0.0, month_start(14)) + month_mid(:) = month_start (:) + month_len(:)/2. + + if (debug) then + write(lunout,*)' month_len = ',month_len + write(lunout,*)' month_mid = ',month_mid + endif + + END IF ! IF ( (first .OR. iday==0) .AND. lnewday ) THEN + +!**************************************************************************************** +! - 2) Interpolate to the actual day. +! - 3) Interpolate to the model vertical grid. +! +!**************************************************************************************** + + IF (lnewday) THEN ! only if new day +!**************************************************************************************** +! 2) Interpolate to the actual day +! +!**************************************************************************************** + ! Find which months and days to use for time interpolation + nbr_tsteps = 12 + IF (nbr_tsteps == 12) then + IF (jDay < month_mid(im+1)) THEN + im2=im-1 + day2 = month_mid(im2+1) + day1 = month_mid(im+1) + IF (im2 <= 0) THEN + ! the month is january, thus the month before december + im2=12 + END IF + ELSE + ! the second half of the month + im2=im+1 + day2 = month_mid(im+1) + day1 = month_mid(im2+1) + IF (im2 > 12) THEN + ! the month is december, the following thus january + im2=1 + ENDIF + END IF + ELSE IF (nbr_tsteps == 14) then + im = im + 1 + IF (jDay < month_mid(im)) THEN + ! in the first half of the month use month before and actual month + im2=im-1 + day2 = month_mid(im2) + day1 = month_mid(im) + ELSE + ! the second half of the month + im2=im+1 + day2 = month_mid(im) + day1 = month_mid(im2) + END IF + ELSE + CALL abort_gcm('readaerosol_interp', 'number of months undefined',1) + ENDIF + if (debug) then + write(lunout,*)' jDay, day1, day2, im, im2 = ', jDay, day1, day2, im, im2 + endif + + + ! Time interpolation, still on vertical source grid + ALLOCATE(tmp1(klon,klev_src), tmp2(klon,klev_src),stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 7',1) + + ALLOCATE(pplay_src(klon,klev_src), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 8',1) + + + DO k=1,klev_src + DO i=1,klon + tmp1(i,k) = & + var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero)) + + tmp2(i,k) = & + pi_var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero)) + END DO + END DO + + ! Time interpolation for pressure at surface, still on vertical source grid + DO i=1,klon + psurf_day(i) = & + psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (psurf_year(i,im2,id_aero) - psurf_year(i,im,id_aero)) + + pi_psurf_day(i) = & + pi_psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (pi_psurf_year(i,im2,id_aero) - pi_psurf_year(i,im,id_aero)) + END DO + + ! Time interpolation for the load, still on vertical source grid + DO i=1,klon + load_src(i) = & + load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (load_year(i,im2,id_aero) - load_year(i,im,id_aero)) + + pi_load_src(i) = & + pi_load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * & + (pi_load_year(i,im2,id_aero) - pi_load_year(i,im,id_aero)) + END DO + +!**************************************************************************************** +! 3) Interpolate to the model vertical grid (target grid) +! +!**************************************************************************************** + + IF (vert_interp) THEN + + ! - Interpolate variable tmp1 (on source grid) to var_day (on target grid) + !******************************************************************************** + ! a) calculate pression at vertical levels for the source grid using the + ! hybrid-sigma coordinates ap and b and the surface pressure, variables from file. + DO k = 1, klev_src + DO i = 1, klon + pplay_src(i,k)= pt_ap(k) + pt_b(k)*psurf_day(i) + END DO + END DO + + IF (debug) THEN + CALL writefield_phy('psurf_day_src',psurf_day(:),1) + CALL writefield_phy('pplay_src',pplay_src(:,:),klev_src) + CALL writefield_phy('pplay',pplay(:,:),klev) + CALL writefield_phy('day_src',tmp1,klev_src) + CALL writefield_phy('pi_day_src',tmp2,klev_src) + END IF + + ! b) vertical interpolation on pressure leveles + CALL pres2lev(tmp1(:,:), var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, & + 1, klon, .FALSE.) + + IF (debug) CALL writefield_phy('day_tgt',var_day(:,:,id_aero),klev) + + ! c) adjust to conserve total aerosol mass load in the vertical pillar + ! Calculate the load in the actual pillar and compare with the load + ! read from aerosol file. + + ! Find the pressure difference in each model layer + DO k = 1, klev + DO i = 1, klon + delp(i,k) = paprs(i,k) - paprs (i,k+1) + END DO + END DO + + ! Find the mass load in the actual pillar, on target grid + load_tgt(:) = 0. + DO k= 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt(i) = load_tgt(i) + 1/RG * volm *delp(i,k) + END DO + END DO + + ! Adjust, uniform + DO k = 1, klev + DO i = 1, klon + var_day(i,k,id_aero) = var_day(i,k,id_aero)*load_src(i)/load_tgt(i) + END DO + END DO + + IF (debug) THEN + load_tgt_test(:) = 0. + DO k= 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt_test(i) = load_tgt_test(i) + 1/RG * volm*delp(i,k) + END DO + END DO + + CALL writefield_phy('day_tgt2',var_day(:,:,id_aero),klev) + CALL writefield_phy('load_tgt',load_tgt(:),1) + CALL writefield_phy('load_tgt_test',load_tgt_test(:),1) + CALL writefield_phy('load_src',load_src(:),1) + END IF + + ! - Interpolate variable tmp2 (source grid) to pi_var_day (target grid) + !******************************************************************************** + ! a) calculate pression at vertical levels at source grid + DO k = 1, klev_src + DO i = 1, klon + pplay_src(i,k)= pt_ap(k) + pt_b(k)*pi_psurf_day(i) + END DO + END DO + + IF (debug) THEN + CALL writefield_phy('pi_psurf_day_src',pi_psurf_day(:),1) + CALL writefield_phy('pi_pplay_src',pplay_src(:,:),klev_src) + END IF + + ! b) vertical interpolation on pressure leveles + CALL pres2lev(tmp2(:,:), pi_var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, & + 1, klon, .FALSE.) + + IF (debug) CALL writefield_phy('pi_day_tgt',pi_var_day(:,:,id_aero),klev) + + ! c) adjust to conserve total aerosol mass load in the vertical pillar + ! Calculate the load in the actual pillar and compare with the load + ! read from aerosol file. + + ! Find the load in the actual pillar, on target grid + load_tgt(:) = 0. + DO k = 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt(i) = load_tgt(i) + 1/RG * volm * delp(i,k) + END DO + END DO + + DO k = 1, klev + DO i = 1, klon + pi_var_day(i,k,id_aero) = pi_var_day(i,k,id_aero)*pi_load_src(i)/load_tgt(i) + END DO + END DO + + IF (debug) THEN + load_tgt_test(:) = 0. + DO k = 1, klev + DO i = 1, klon + zrho = pplay(i,k)/t_seri(i,k)/RD ! [kg/m3] + volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg] + load_tgt_test(i) = load_tgt_test(i) + 1/RG * volm * delp(i,k) + END DO + END DO + CALL writefield_phy('pi_day_tgt2',pi_var_day(:,:,id_aero),klev) + CALL writefield_phy('pi_load_tgt',load_tgt(:),1) + CALL writefield_phy('pi_load_tgt_test',load_tgt_test(:),1) + CALL writefield_phy('pi_load_src',pi_load_src(:),1) + END IF + + + ELSE ! No vertical interpolation done + + var_day(:,:,id_aero) = tmp1(:,:) + pi_var_day(:,:,id_aero) = tmp2(:,:) + + END IF ! vert_interp + + + ! Deallocation + DEALLOCATE(tmp1, tmp2, pplay_src, stat=ierr) + +!**************************************************************************************** +! 4) Test for negative mass values +! +!**************************************************************************************** + IF (MINVAL(var_day(:,:,id_aero)) < 0.) THEN + DO k=1,klev + DO i=1,klon + ! Test for var_day + IF (var_day(i,k,id_aero) < 0.) THEN + IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2 + IF (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero) < 0.) THEN + WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', & + trim(name_aero(id_aero)),'(i,k,im)=', & + var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero) + END IF + WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero) + WRITE(lunout,*) 'day1, day2, jDay = ', day1, day2, jDay + CALL abort_gcm('readaerosol_interp','Error in interpolation 1',1) + END IF + END DO + END DO + END IF + + IF (MINVAL(pi_var_day(:,:,id_aero)) < 0. ) THEN + DO k=1, klev + DO i=1,klon + ! Test for pi_var_day + IF (pi_var_day(i,k,id_aero) < 0.) THEN + IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2 + IF (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero) < 0.) THEN + WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', & + trim(name_aero(id_aero)),'(i,k,im)=', & + pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero) + END IF + + WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero) + CALL abort_gcm('readaerosol_interp','Error in interpolation 2',1) + END IF + END DO + END DO + END IF + + END IF ! lnewday + +!**************************************************************************************** +! Copy output from saved variables +! +!**************************************************************************************** + + mass_out(:,:) = var_day(:,:,id_aero) + pi_mass_out(:,:) = pi_var_day(:,:,id_aero) + +END SUBROUTINE readaerosol_interp Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol_optic.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol_optic.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/readaerosol_optic.F90 (revision 1634) @@ -0,0 +1,224 @@ +! $Id$ +! +SUBROUTINE readaerosol_optic(debut, new_aod, flag_aerosol, itap, rjourvrai, & + pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & + mass_solu_aero, mass_solu_aero_pi, & + tau_aero, piz_aero, cg_aero, & + tausum_aero, tau3d_aero ) + +! This routine will : +! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol +! 2) calculate the optical properties for the aerosols +! + + USE dimphy + USE aero_mod + USE phys_local_var_mod, only: sconcso4,sconcoa,sconcbc,sconcss,sconcdust, & + concso4,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, & + load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7 + IMPLICIT NONE + +! Input arguments +!**************************************************************************************** + LOGICAL, INTENT(IN) :: debut + LOGICAL, INTENT(IN) :: new_aod + INTEGER, INTENT(IN) :: flag_aerosol + INTEGER, INTENT(IN) :: itap + REAL, INTENT(IN) :: rjourvrai + REAL, INTENT(IN) :: pdtphys + REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri + REAL, DIMENSION(klon,klev), INTENT(IN) :: rhcl ! humidite relative ciel clair + REAL, DIMENSION(klev), INTENT(IN) :: presnivs + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero ! Total mass for all soluble aerosols + REAL, DIMENSION(klon,klev), INTENT(OUT) :: mass_solu_aero_pi ! -"- preindustrial values + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: tau_aero ! Aerosol optical thickness + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: piz_aero ! Single scattering albedo aerosol + REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: cg_aero ! asymmetry parameter aerosol + REAL, DIMENSION(klon,nwave,naero_spc), INTENT(OUT) :: tausum_aero + REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(OUT) :: tau3d_aero + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: aerindex ! POLDER aerosol index + REAL, DIMENSION(klon,klev) :: sulfate ! SO4 aerosol concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcsol ! BC soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: bcins ! BC insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomsol ! POM soluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: pomins ! POM insoluble concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: cidust ! DUST aerosol concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sscoarse ! SS Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sssupco ! SS Super Coarse concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: ssacu ! SS Acumulation concentration [ug/m3] + REAL, DIMENSION(klon,klev) :: sulfate_pi + REAL, DIMENSION(klon,klev) :: bcsol_pi + REAL, DIMENSION(klon,klev) :: bcins_pi + REAL, DIMENSION(klon,klev) :: pomsol_pi + REAL, DIMENSION(klon,klev) :: pomins_pi + REAL, DIMENSION(klon,klev) :: cidust_pi + REAL, DIMENSION(klon,klev) :: sscoarse_pi + REAL, DIMENSION(klon,klev) :: sssupco_pi + REAL, DIMENSION(klon,klev) :: ssacu_pi + REAL, DIMENSION(klon,klev) :: pdel + REAL, DIMENSION(klon,klev,naero_spc) :: m_allaer + REAL, DIMENSION(klon,klev,naero_spc) :: m_allaer_pi !RAF +! REAL, DIMENSION(klon,naero_tot) :: fractnat_allaer !RAF delete?? + + INTEGER :: k, i + +!**************************************************************************************** +! 1) Get aerosol mass +! +!**************************************************************************************** +! Read and interpolate sulfate + IF ( flag_aerosol .EQ. 1 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_ASSO4M, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfate, sulfate_pi,loadso4) + ELSE + sulfate(:,:) = 0. ; sulfate_pi(:,:) = 0. + loadso4=0. + END IF + +! Read and interpolate bcsol and bcins + IF ( flag_aerosol .EQ. 2 .OR. & + flag_aerosol .EQ. 6 ) THEN + + ! Get bc aerosol distribution + CALL readaerosol_interp(id_ASBCM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1 ) + CALL readaerosol_interp(id_AIBCM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2 ) + loadbc(:)=load_tmp1(:)+load_tmp2(:) + ELSE + bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0. + bcins(:,:) = 0. ; bcins_pi(:,:) = 0. + loadbc=0. + END IF + + +! Read and interpolate pomsol and pomins + IF ( flag_aerosol .EQ. 3 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_ASPOMM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3) + CALL readaerosol_interp(id_AIPOMM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4) + loadoa(:)=load_tmp3(:)+load_tmp4(:) + ELSE + pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0. + pomins(:,:) = 0. ; pomins_pi(:,:) = 0. + loadoa=0. + END IF + + +! Read and interpolate csssm, ssssm, assssm + IF (flag_aerosol .EQ. 4 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_SSSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sssupco, sssupco_pi, load_tmp5) + CALL readaerosol_interp(id_CSSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) + CALL readaerosol_interp(id_ASSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, ssacu, ssacu_pi, load_tmp7) + loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:) + ELSE + sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. + ssacu(:,:) = 0. ; ssacu_pi(:,:) = 0. + sssupco(:,:) = 0. ; sssupco_pi = 0. + loadss=0. + ENDIF + +! Read and interpolate cidustm + IF (flag_aerosol .EQ. 5 .OR. & + flag_aerosol .EQ. 6 ) THEN + + CALL readaerosol_interp(id_CIDUSTM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) + + ELSE + cidust(:,:) = 0. ; cidust_pi(:,:) = 0. + loaddust=0. + ENDIF + +! +! Store all aerosols in one variable +! + m_allaer(:,:,id_ASBCM) = bcsol(:,:) ! ASBCM + m_allaer(:,:,id_ASPOMM) = pomsol(:,:) ! ASPOMM + m_allaer(:,:,id_ASSO4M) = sulfate(:,:) ! ASSO4M (= SO4) + m_allaer(:,:,id_CSSO4M) = 0. ! CSSO4M + m_allaer(:,:,id_SSSSM) = sssupco(:,:) ! SSSSM + m_allaer(:,:,id_CSSSM) = sscoarse(:,:) ! CSSSM + m_allaer(:,:,id_ASSSM) = ssacu(:,:) ! ASSSM + m_allaer(:,:,id_CIDUSTM)= cidust(:,:) ! CIDUSTM + m_allaer(:,:,id_AIBCM) = bcins(:,:) ! AIBCM + m_allaer(:,:,id_AIPOMM) = pomins(:,:) ! AIPOMM + +!RAF + m_allaer_pi(:,:,1) = bcsol_pi(:,:) ! ASBCM pre-ind + m_allaer_pi(:,:,2) = pomsol_pi(:,:) ! ASPOMM pre-ind + m_allaer_pi(:,:,3) = sulfate_pi(:,:) ! ASSO4M (= SO4) pre-ind + m_allaer_pi(:,:,4) = 0. ! CSSO4M pre-ind + m_allaer_pi(:,:,5) = sssupco_pi(:,:) ! SSSSM pre-ind + m_allaer_pi(:,:,6) = sscoarse_pi(:,:) ! CSSSM pre-ind + m_allaer_pi(:,:,7) = ssacu_pi(:,:) ! ASSSM pre-ind + m_allaer_pi(:,:,8) = cidust_pi(:,:) ! CIDUSTM pre-ind + m_allaer_pi(:,:,9) = bcins_pi(:,:) ! AIBCM pre-ind + m_allaer_pi(:,:,10) = pomins_pi(:,:) ! AIPOMM pre-ind + +! +! Calculate the total mass of all soluble aersosols +! + mass_solu_aero(:,:) = sulfate(:,:) + bcsol(:,:) + pomsol(:,:) ! + & +! sscoarse(:,:) + ssacu(:,:) + sssupco(:,:) + mass_solu_aero_pi(:,:) = sulfate_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) ! + & +! sscoarse_pi(:,:) + ssacu_pi(:,:) + sssupco_pi(:,:) + +!**************************************************************************************** +! 2) Calculate optical properties for the aerosols +! +!**************************************************************************************** + DO k = 1, klev + DO i = 1, klon + pdel(i,k) = paprs(i,k) - paprs (i,k+1) + END DO + END DO + + IF (new_aod) THEN + +! RAF delete?? fractnat_allaer(:,:) = 0. +! RAF fractnat_allaer -> m_allaer_pi + + CALL aeropt_2bands( & + pdel, m_allaer, pdtphys, rhcl, & + tau_aero, piz_aero, cg_aero, & + m_allaer_pi, flag_aerosol, & + pplay, t_seri, presnivs) + + ! aeropt_5wv only for validation and diagnostics. + CALL aeropt_5wv( & + pdel, m_allaer, & + pdtphys, rhcl, aerindex, & + flag_aerosol, pplay, t_seri, & + tausum_aero, tau3d_aero, presnivs) + ELSE + + CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl, & + tau_aero(:,:,id_ASSO4M,:), piz_aero(:,:,id_ASSO4M,:), cg_aero(:,:,id_ASSO4M,:), aerindex) + + END IF + + +! Diagnostics calculation for CMIP5 protocol + sconcso4(:)=m_allaer(:,1,id_ASSO4M)*1.e-9 + sconcoa(:)=(m_allaer(:,1,id_ASPOMM)+m_allaer(:,1,id_AIPOMM))*1.e-9 + sconcbc(:)=(m_allaer(:,1,id_ASBCM)+m_allaer(:,1,id_AIBCM))*1.e-9 + sconcss(:)=(m_allaer(:,1,id_ASSSM)+m_allaer(:,1,id_CSSSM)+m_allaer(:,1,id_SSSSM))*1.e-9 + sconcdust(:)=m_allaer(:,1,id_CIDUSTM)*1.e-9 + concso4(:,:)=m_allaer(:,:,id_ASSO4M)*1.e-9 + concoa(:,:)=(m_allaer(:,:,id_ASPOMM)+m_allaer(:,:,id_AIPOMM))*1.e-9 + concbc(:,:)=(m_allaer(:,:,id_ASBCM)+m_allaer(:,:,id_AIBCM))*1.e-9 + concss(:,:)=(m_allaer(:,:,id_ASSSM)+m_allaer(:,:,id_CSSSM)+m_allaer(:,:,id_SSSSM))*1.e-9 + concdust(:,:)=m_allaer(:,:,id_CIDUSTM)*1.e-9 + + +END SUBROUTINE readaerosol_optic Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regdim.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regdim.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regdim.h (revision 1634) @@ -0,0 +1,16 @@ +! +! $Header$ +! + INTEGER i1_deb, i1_fin + INTEGER i2_deb, i2_fin +ccc PARAMETER (i1_deb=21, i1_fin=40) +ccc PARAMETER (i2_deb=41, i2_fin=44) +cccc PARAMETER (i1_deb=47, i1_fin=77) +cccc PARAMETER (i2_deb=78, i2_fin=79) + PARAMETER (i1_deb=16, i1_fin=30) + PARAMETER (i2_deb=31, i2_fin=33) +c + INTEGER j_deb, j_fin +ccc PARAMETER (j_deb=29, j_fin=61) +cccc PARAMETER (j_deb=21, j_fin=51) + PARAMETER (j_deb=18, j_fin=39) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_lat_time_climoz_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_lat_time_climoz_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_lat_time_climoz_m.F90 (revision 1634) @@ -0,0 +1,456 @@ +! $Id$ +module regr_lat_time_climoz_m + + ! Author: Lionel GUEZ + + implicit none + + private + public regr_lat_time_climoz + +contains + + subroutine regr_lat_time_climoz(read_climoz) + + ! "regr_lat_time_climoz" stands for "regrid latitude time + ! climatology ozone". + + ! This procedure reads a climatology of ozone from a NetCDF file, + ! regrids it in latitude and time, and writes the regridded field + ! to a new NetCDF file. + + ! The input field depends on time, pressure level and latitude. + + ! If the input field has missing values, they must be signaled by + ! the "missing_value" attribute. + + ! We assume that the input field is a step function of latitude + ! and that the input latitude coordinate gives the centers of steps. + ! Regridding in latitude is made by averaging, with a cosine of + ! latitude factor. + ! The target LMDZ latitude grid is the "scalar" grid: "rlatu". + ! The values of "rlatu" are taken to be the centers of intervals. + + ! We assume that in the input file: + + ! -- Latitude is in degrees. + + ! -- Latitude and pressure are strictly monotonic (as all NetCDF + ! coordinate variables should be). + + ! -- The time coordinate is in ascending order (even though we do + ! not use its values). + ! The input file may contain either values for 12 months or values + ! for 14 months. + ! If there are 14 months then we assume that we have (in that order): + ! December, January, February, ..., November, December, January + + ! -- Missing values are contiguous, at the bottom of + ! the vertical domain and at the latitudinal boundaries. + + ! If values are all missing at a given latitude and date, then we + ! replace those missing values by values at the closest latitude, + ! equatorward, with valid values. + ! Then, at each latitude and each date, the missing values are replaced + ! by the lowest valid value above missing values. + + ! Regridding in time is by linear interpolation. + ! Monthly values are processed to get daily values, on the basis + ! of a 360-day calendar. + ! If there are 14 months, we use the first December value to + ! interpolate values between January 1st and mid-January. + ! We use the last January value to interpolate values between + ! mid-December and end of December. + ! If there are only 12 months in the input file then we assume + ! periodicity for interpolation at the beginning and at the end of the + ! year. + + use regr1_step_av_m, only: regr1_step_av + use regr3_lint_m, only: regr3_lint + use netcdf95, only: handle_err, nf95_close, nf95_get_att, nf95_gw_var, & + nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, nf95_open, & + nf95_put_var + use netcdf, only: nf90_get_att, nf90_get_var, nf90_noerr, nf90_nowrite + use assert_m, only: assert + + integer, intent(in):: read_climoz ! read ozone climatology + ! Allowed values are 1 and 2 + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + + ! Variables local to the procedure: + + include "dimensions.h" + ! (for "jjm") + include "paramet.h" + ! (for the other included files) + include "comgeom2.h" + ! (for "rlatv") + include "comconst.h" + ! (for "pi") + + integer n_plev ! number of pressure levels in the input data + integer n_lat ! number of latitudes in the input data + integer n_month ! number of months in the input data + + real, pointer:: latitude(:) + ! (of input data, converted to rad, sorted in strictly ascending order) + + real, allocatable:: lat_in_edg(:) + ! (edges of latitude intervals for input data, in rad, in strictly + ! ascending order) + + real, pointer:: plev(:) + ! pressure levels of input data, sorted in strictly ascending + ! order, converted to hPa + + logical desc_lat ! latitude in descending order in the input file + logical desc_plev ! pressure levels in descending order in the input file + + real, allocatable:: o3_in(:, :, :, :) + ! (n_lat, n_plev, n_month, read_climoz) + ! ozone climatologies from the input file + ! "o3_in(j, k, :, :)" is at latitude "latitude(j)" and pressure + ! level "plev(k)". + ! Third dimension is month index, first value may be December or January. + ! "o3_in(:, :, :, 1)" is for the day- night average, "o3_in(:, :, :, 2)" + ! is for daylight. + + real missing_value + + real, allocatable:: o3_regr_lat(:, :, :, :) + ! (jjm + 1, n_plev, 0:13, read_climoz) + ! mean of "o3_in" over a latitude interval of LMDZ + ! First dimension is latitude interval. + ! The latitude interval for "o3_regr_lat(j,:, :, :)" contains "rlatu(j)". + ! If "j" is between 2 and "jjm" then the interval is: + ! [rlatv(j), rlatv(j-1)] + ! If "j" is 1 or "jjm + 1" then the interval is: + ! [rlatv(1), pi / 2] + ! or: + ! [- pi / 2, rlatv(jjm)] + ! respectively. + ! "o3_regr_lat(:, k, :, :)" is for pressure level "plev(k)". + ! Third dimension is month number, 1 for January. + ! "o3_regr_lat(:, :, :, 1)" is average day and night, + ! "o3_regr_lat(:, :, :, 2)" is for daylight. + + real, allocatable:: o3_out(:, :, :, :) + ! (jjm + 1, n_plev, 360, read_climoz) + ! regridded ozone climatology + ! "o3_out(j, k, l, :)" is at latitude "rlatu(j)", pressure + ! level "plev(k)" and date "January 1st 0h" + "tmidday(l)", in a + ! 360-day calendar. + ! "o3_out(:, :, :, 1)" is average day and night, + ! "o3_out(:, :, :, 2)" is for daylight. + + integer j, k, l,m + + ! For NetCDF: + integer ncid_in, ncid_out ! IDs for input and output files + integer varid_plev, varid_time, varid, ncerr, dimid + character(len=80) press_unit ! pressure unit + + integer varid_in(read_climoz), varid_out(read_climoz) + ! index 1 is for average ozone day and night, index 2 is for + ! daylight ozone. + + real, parameter:: tmidmonth(0:13) = (/(-15. + 30. * l, l = 0, 13)/) + ! (time to middle of month, in days since January 1st 0h, in a + ! 360-day calendar) + ! (We add values -15 and 375 so that, for example, day 3 of the year is + ! interpolated between the December and the January value.) + + real, parameter:: tmidday(360) = (/(l + 0.5, l = 0, 359)/) + ! (time to middle of day, in days since January 1st 0h, in a + ! 360-day calendar) + + !--------------------------------- + + print *, "Call sequence information: regr_lat_time_climoz" + call assert(read_climoz == 1 .or. read_climoz == 2, "regr_lat_time_climoz") + + call nf95_open("climoz.nc", nf90_nowrite, ncid_in) + + ! Get coordinates from the input file: + + call nf95_inq_varid(ncid_in, "latitude", varid) + call nf95_gw_var(ncid_in, varid, latitude) + ! Convert from degrees to rad, because we will take the sine of latitude: + latitude = latitude / 180. * pi + n_lat = size(latitude) + ! We need to supply the latitudes to "regr1_step_av" in + ! ascending order, so invert order if necessary: + desc_lat = latitude(1) > latitude(n_lat) + if (desc_lat) latitude = latitude(n_lat:1:-1) + + ! Compute edges of latitude intervals: + allocate(lat_in_edg(n_lat + 1)) + lat_in_edg(1) = - pi / 2 + forall (j = 2:n_lat) lat_in_edg(j) = (latitude(j - 1) + latitude(j)) / 2 + lat_in_edg(n_lat + 1) = pi / 2 + deallocate(latitude) ! pointer + + call nf95_inq_varid(ncid_in, "plev", varid) + call nf95_gw_var(ncid_in, varid, plev) + n_plev = size(plev) + ! We only need the pressure coordinate to copy it to the output file. + ! The program "gcm" will assume that pressure levels are in + ! ascending order in the regridded climatology so invert order if + ! necessary: + desc_plev = plev(1) > plev(n_plev) + if (desc_plev) plev = plev(n_plev:1:-1) + call nf95_get_att(ncid_in, varid, "units", press_unit) + if (press_unit == "Pa") then + ! Convert to hPa: + plev = plev / 100. + elseif (press_unit /= "hPa") then + print *, "regr_lat_time_climoz: the only recognized units are Pa " & + // "and hPa." + stop 1 + end if + + ! Create the output file and get the variable IDs: + call prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & + varid_time) + + ! Write remaining coordinate variables: + call nf95_put_var(ncid_out, varid_plev, plev) + call nf95_put_var(ncid_out, varid_time, tmidday) + + deallocate(plev) ! pointer + + ! Get the number of months: + call nf95_inq_dimid(ncid_in, "time", dimid) + call nf95_inquire_dimension(ncid_in, dimid, len=n_month) + + allocate(o3_in(n_lat, n_plev, n_month, read_climoz)) + + call nf95_inq_varid(ncid_in, "tro3", varid_in(1)) + ncerr = nf90_get_var(ncid_in, varid_in(1), o3_in(:, :, :, 1)) + call handle_err("regr_lat_time_climoz nf90_get_var tro3", ncerr, ncid_in) + + if (read_climoz == 2) then + call nf95_inq_varid(ncid_in, "tro3_daylight", varid_in(2)) + ncerr = nf90_get_var(ncid_in, varid_in(2), o3_in(:, :, :, 2)) + call handle_err("regr_lat_time_climoz nf90_get_var tro3_daylight", & + ncerr, ncid_in, varid_in(2)) + end if + + if (desc_lat) o3_in = o3_in(n_lat:1:-1, :, :, :) + if (desc_plev) o3_in = o3_in(:, n_plev:1:-1, :, :) + + do m = 1, read_climoz + ncerr = nf90_get_att(ncid_in, varid_in(m), "missing_value", & + missing_value) + if (ncerr == nf90_noerr) then + do l = 1, n_month + ! Take care of latitudes where values are all missing: + + ! Next to the south pole: + j = 1 + do while (o3_in(j, 1, l, m) == missing_value) + j = j + 1 + end do + if (j > 1) o3_in(:j-1, :, l, m) = & + spread(o3_in(j, :, l, m), dim=1, ncopies=j-1) + + ! Next to the north pole: + j = n_lat + do while (o3_in(j, 1, l, m) == missing_value) + j = j - 1 + end do + if (j < n_lat) o3_in(j+1:, :, l, m) = & + spread(o3_in(j, :, l, m), dim=1, ncopies=n_lat-j) + + ! Take care of missing values at high pressure: + do j = 1, n_lat + ! Find missing values, starting from top of atmosphere + ! and going down. + ! We have already taken care of latitudes full of + ! missing values so the highest level has a valid value. + k = 2 + do while (o3_in(j, k, l, m) /= missing_value .and. k < n_plev) + k = k + 1 + end do + ! Replace missing values with the valid value at the + ! lowest level above missing values: + if (o3_in(j, k, l, m) == missing_value) & + o3_in(j, k:n_plev, l, m) = o3_in(j, k-1, l, m) + end do + end do + else + print *, "regr_lat_time_climoz: field ", m, & + ", no missing value attribute" + end if + end do + + call nf95_close(ncid_in) + + allocate(o3_regr_lat(jjm + 1, n_plev, 0:13, read_climoz)) + allocate(o3_out(jjm + 1, n_plev, 360, read_climoz)) + + ! Regrid in latitude: + ! We average with respect to sine of latitude, which is + ! equivalent to weighting by cosine of latitude: + if (n_month == 12) then + print *, & + "Found 12 months in ozone climatologies, assuming periodicity..." + o3_regr_lat(jjm+1:1:-1, :, 1:12, :) = regr1_step_av(o3_in, & + xs=sin(lat_in_edg), xt=sin((/- pi / 2, rlatv(jjm:1:-1), pi / 2/))) + ! (invert order of indices in "o3_regr_lat" because "rlatu" is + ! in descending order) + + ! Duplicate January and December values, in preparation of time + ! interpolation: + o3_regr_lat(:, :, 0, :) = o3_regr_lat(:, :, 12, :) + o3_regr_lat(:, :, 13, :) = o3_regr_lat(:, :, 1, :) + else + print *, "Using 14 months in ozone climatologies..." + o3_regr_lat(jjm+1:1:-1, :, :, :) = regr1_step_av(o3_in, & + xs=sin(lat_in_edg), xt=sin((/- pi / 2, rlatv(jjm:1:-1), pi / 2/))) + ! (invert order of indices in "o3_regr_lat" because "rlatu" is + ! in descending order) + end if + + ! Regrid in time by linear interpolation: + o3_out = regr3_lint(o3_regr_lat, tmidmonth, tmidday) + + ! Write to file: + do m = 1, read_climoz + call nf95_put_var(ncid_out, varid_out(m), o3_out(jjm+1:1:-1, :, :, m)) + ! (The order of "rlatu" is inverted in the output file) + end do + + call nf95_close(ncid_out) + + end subroutine regr_lat_time_climoz + + !******************************************** + + subroutine prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & + varid_time) + + ! This subroutine creates the NetCDF output file, defines + ! dimensions and variables, and writes one of the coordinate variables. + + use netcdf95, only: nf95_create, nf95_def_dim, nf95_def_var, & + nf95_put_att, nf95_enddef, nf95_copy_att, nf95_put_var + use netcdf, only: nf90_clobber, nf90_float, nf90_global + + integer, intent(in):: ncid_in, n_plev + integer, intent(out):: ncid_out, varid_plev, varid_time + + integer, intent(out):: varid_out(:) ! dim(1 or 2) + ! "varid_out(1)" is for average ozone day and night, + ! "varid_out(2)" is for daylight ozone. + + ! Variables local to the procedure: + + include "dimensions.h" + ! (for "jjm") + include "paramet.h" + ! (for the other included files) + include "comgeom2.h" + ! (for "rlatu") + include "comconst.h" + ! (for "pi") + + integer ncerr + integer dimid_rlatu, dimid_plev, dimid_time + integer varid_rlatu + + !--------------------------- + + print *, "Call sequence information: prepare_out" + + call nf95_create("climoz_LMDZ.nc", nf90_clobber, ncid_out) + + ! Dimensions: + call nf95_def_dim(ncid_out, "time", 360, dimid_time) + call nf95_def_dim(ncid_out, "plev", n_plev, dimid_plev) + call nf95_def_dim(ncid_out, "rlatu", jjm + 1, dimid_rlatu) + + ! Define coordinate variables: + + call nf95_def_var(ncid_out, "time", nf90_float, dimid_time, varid_time) + call nf95_put_att(ncid_out, varid_time, "units", "days since 2000-1-1") + call nf95_put_att(ncid_out, varid_time, "calendar", "360_day") + call nf95_put_att(ncid_out, varid_time, "standard_name", "time") + + call nf95_def_var(ncid_out, "plev", nf90_float, dimid_plev, varid_plev) + call nf95_put_att(ncid_out, varid_plev, "units", "millibar") + call nf95_put_att(ncid_out, varid_plev, "standard_name", "air_pressure") + call nf95_put_att(ncid_out, varid_plev, "long_name", "air pressure") + + call nf95_def_var(ncid_out, "rlatu", nf90_float, dimid_rlatu, varid_rlatu) + call nf95_put_att(ncid_out, varid_rlatu, "units", "degrees_north") + call nf95_put_att(ncid_out, varid_rlatu, "standard_name", "latitude") + + ! Define the primary variables: + + call nf95_def_var(ncid_out, "tro3", nf90_float, & + (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(1)) + call nf95_put_att(ncid_out, varid_out(1), "long_name", & + "ozone mole fraction") + call nf95_put_att(ncid_out, varid_out(1), "standard_name", & + "mole_fraction_of_ozone_in_air") + + if (size(varid_out) == 2) then + call nf95_def_var(ncid_out, "tro3_daylight", nf90_float, & + (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(2)) + call nf95_put_att(ncid_out, varid_out(2), "long_name", & + "ozone mole fraction in daylight") + end if + + ! Global attributes: + + ! The following commands, copying attributes, may fail. + ! That is OK. + ! It should just mean that the attribute is not defined in the input file. + + call nf95_copy_att(ncid_in, nf90_global, "Conventions", ncid_out, & + nf90_global, ncerr) + call handle_err_copy_att("Conventions") + + call nf95_copy_att(ncid_in, nf90_global, "title", ncid_out, nf90_global, & + ncerr) + call handle_err_copy_att("title") + + call nf95_copy_att(ncid_in, nf90_global, "institution", ncid_out, & + nf90_global, ncerr) + call handle_err_copy_att("institution") + + call nf95_copy_att(ncid_in, nf90_global, "source", ncid_out, nf90_global, & + ncerr) + call handle_err_copy_att("source") + + call nf95_put_att(ncid_out, nf90_global, "comment", "Regridded for LMDZ") + + call nf95_enddef(ncid_out) + + ! Write one of the coordinate variables: + call nf95_put_var(ncid_out, varid_rlatu, rlatu(jjm+1:1:-1) / pi * 180.) + ! (convert from rad to degrees and sort in ascending order) + + contains + + subroutine handle_err_copy_att(att_name) + + use netcdf, only: nf90_noerr, nf90_strerror + + character(len=*), intent(in):: att_name + + !---------------------------------------- + + if (ncerr /= nf90_noerr) then + print *, "regr_lat_time_climoz_m prepare_out nf95_copy_att " & + // att_name // " -- " // trim(nf90_strerror(ncerr)) + end if + + end subroutine handle_err_copy_att + + end subroutine prepare_out + +end module regr_lat_time_climoz_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_lat_time_coefoz_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_lat_time_coefoz_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_lat_time_coefoz_m.F90 (revision 1634) @@ -0,0 +1,357 @@ +! $Id$ +module regr_lat_time_coefoz_m + + ! Author: Lionel GUEZ + + implicit none + + private + public regr_lat_time_coefoz + +contains + + subroutine regr_lat_time_coefoz + + ! "regr_lat_time_coefoz" stands for "regrid latitude time + ! coefficients ozone". + + ! This procedure reads from a NetCDF file coefficients for ozone + ! chemistry, regrids them in latitude and time, and writes the + ! regridded fields to a new NetCDF file. + + ! The input fields depend on time, pressure level and latitude. + ! We assume that the input fields are step functions of latitude. + ! Regridding in latitude is made by averaging, with a cosine of + ! latitude factor. + ! The target LMDZ latitude grid is the "scalar" grid: "rlatu". + ! The values of "rlatu" are taken to be the centers of intervals. + ! Regridding in time is by linear interpolation. + ! Monthly values are processed to get daily values, on the basis + ! of a 360-day calendar. + + ! We assume that in the input file: + ! -- the latitude is in degrees and strictly monotonic (as all + ! NetCDF coordinate variables should be); + ! -- time increases from January to December (even though we do + ! not use values of the input time coordinate); + ! -- pressure is in hPa and in strictly ascending order (even + ! though we do not use pressure values here, we write the unit of + ! pressure in the NetCDF header, and we will use the assumptions later, + ! when we regrid in pressure). + + use regr1_step_av_m, only: regr1_step_av + use regr3_lint_m, only: regr3_lint + use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, handle_err, & + nf95_put_var, nf95_gw_var + use netcdf, only: nf90_nowrite, nf90_get_var + + ! Variables local to the procedure: + + include "dimensions.h" + ! (for "jjm") + include "paramet.h" + include "comgeom2.h" + ! (for "rlatv") + include "comconst.h" + ! (for "pi") + + integer ncid_in, ncid_out ! NetCDF IDs for input and output files + integer n_plev ! number of pressure levels in the input data + integer n_lat! number of latitudes in the input data + + real, pointer:: latitude(:) + ! (of input data, converted to rad, sorted in strictly ascending order) + + real, allocatable:: lat_in_edg(:) + ! (edges of latitude intervals for input data, in rad, in strictly + ! ascending order) + + real, pointer:: plev(:) ! pressure level of input data + logical desc_lat ! latitude in descending order in the input file + + real, allocatable:: o3_par_in(:, :, :) ! (n_lat, n_plev, 12) + ! (ozone parameter from the input file) + ! ("o3_par_in(j, l, month)" is at latitude "latitude(j)" and pressure + ! level "plev(l)". "month" is between 1 and 12.) + + real, allocatable:: v_regr_lat(:, :, :) ! (jjm + 1, n_plev, 0:13) + ! (mean of a variable "v" over a latitude interval) + ! (First dimension is latitude interval. + ! The latitude interval for "v_regr_lat(j,:, :)" contains "rlatu(j)". + ! If "j" is between 2 and "jjm" then the interval is: + ! [rlatv(j), rlatv(j-1)] + ! If "j" is 1 or "jjm + 1" then the interval is: + ! [rlatv(1), pi / 2] + ! or: + ! [- pi / 2, rlatv(jjm)] + ! respectively. + ! "v_regr_lat(:, l, :)" is for pressure level "plev(l)". + ! Last dimension is month number.) + + real, allocatable:: o3_par_out(:, :, :) ! (jjm + 1, n_plev, 360) + ! (regridded ozone parameter) + ! ("o3_par_out(j, l, day)" is at latitude "rlatu(j)", pressure + ! level "plev(l)" and date "January 1st 0h" + "tmidday(day)", in a + ! 360-day calendar.) + + integer j + integer i_v ! index of ozone parameter + integer, parameter:: n_o3_param = 8 ! number of ozone parameters + + character(len=11) name_in(n_o3_param) + ! (name of NetCDF primary variable in the input file) + + character(len=9) name_out(n_o3_param) + ! (name of NetCDF primary variable in the output file) + + integer varid_in(n_o3_param), varid_out(n_o3_param), varid_plev, varid_time + integer ncerr, varid + ! (for NetCDF) + + real, parameter:: tmidmonth(0:13) = (/(-15. + 30. * j, j = 0, 13)/) + ! (time to middle of month, in days since January 1st 0h, in a + ! 360-day calendar) + ! (We add values -15 and 375 so that, for example, day 3 of the year is + ! interpolated between the December and the January value.) + + real, parameter:: tmidday(360) = (/(j + 0.5, j = 0, 359)/) + ! (time to middle of day, in days since January 1st 0h, in a + ! 360-day calendar) + + !--------------------------------- + + print *, "Call sequence information: regr_lat_time_coefoz" + + ! Names of ozone parameters: + i_v = 0 + + i_v = i_v + 1 + name_in(i_v) = "P_net" + name_out(i_v) = "P_net_Mob" + + i_v = i_v + 1 + name_in(i_v) = "a2" + name_out(i_v) = "a2" + + i_v = i_v + 1 + name_in(i_v) = "tro3" + name_out(i_v) = "r_Mob" + + i_v = i_v + 1 + name_in(i_v) = "a4" + name_out(i_v) = "a4" + + i_v = i_v + 1 + name_in(i_v) = "temperature" + name_out(i_v) = "temp_Mob" + + i_v = i_v + 1 + name_in(i_v) = "a6" + name_out(i_v) = "a6" + + i_v = i_v + 1 + name_in(i_v) = "Sigma" + name_out(i_v) = "Sigma_Mob" + + i_v = i_v + 1 + name_in(i_v) = "R_Het" + name_out(i_v) = "R_Het" + + call nf95_open("coefoz.nc", nf90_nowrite, ncid_in) + + ! Get coordinates from the input file: + + call nf95_inq_varid(ncid_in, "latitude", varid) + call nf95_gw_var(ncid_in, varid, latitude) + ! Convert from degrees to rad, because "rlatv" is in rad: + latitude = latitude / 180. * pi + n_lat = size(latitude) + ! We need to supply the latitudes to "regr1_step_av" in + ! ascending order, so invert order if necessary: + desc_lat = latitude(1) > latitude(n_lat) + if (desc_lat) latitude = latitude(n_lat:1:-1) + + ! Compute edges of latitude intervals: + allocate(lat_in_edg(n_lat + 1)) + lat_in_edg(1) = - pi / 2 + forall (j = 2:n_lat) lat_in_edg(j) = (latitude(j - 1) + latitude(j)) / 2 + lat_in_edg(n_lat + 1) = pi / 2 + deallocate(latitude) ! pointer + + call nf95_inq_varid(ncid_in, "plev", varid) + call nf95_gw_var(ncid_in, varid, plev) + n_plev = size(plev) + ! (We only need the pressure coordinate to copy it to the output file.) + + ! Get the IDs of ozone parameters in the input file: + do i_v = 1, n_o3_param + call nf95_inq_varid(ncid_in, trim(name_in(i_v)), varid_in(i_v)) + end do + + ! Create the output file and get the variable IDs: + call prepare_out(ncid_in, varid_in, n_plev, name_out, ncid_out, & + varid_out, varid_plev, varid_time) + + ! Write remaining coordinate variables: + call nf95_put_var(ncid_out, varid_time, tmidday) + call nf95_put_var(ncid_out, varid_plev, plev) + + deallocate(plev) ! pointer + + allocate(o3_par_in(n_lat, n_plev, 12)) + allocate(v_regr_lat(jjm + 1, n_plev, 0:13)) + allocate(o3_par_out(jjm + 1, n_plev, 360)) + + do i_v = 1, n_o3_param + ! Process ozone parameter "name_in(i_v)" + + ncerr = nf90_get_var(ncid_in, varid_in(i_v), o3_par_in) + call handle_err("nf90_get_var", ncerr, ncid_in) + + if (desc_lat) o3_par_in = o3_par_in(n_lat:1:-1, :, :) + + ! Regrid in latitude: + ! We average with respect to sine of latitude, which is + ! equivalent to weighting by cosine of latitude: + v_regr_lat(jjm+1:1:-1, :, 1:12) = regr1_step_av(o3_par_in, & + xs=sin(lat_in_edg), xt=sin((/- pi / 2, rlatv(jjm:1:-1), pi / 2/))) + ! (invert order of indices in "v_regr_lat" because "rlatu" is + ! in descending order) + + ! Duplicate January and December values, in preparation of time + ! interpolation: + v_regr_lat(:, :, 0) = v_regr_lat(:, :, 12) + v_regr_lat(:, :, 13) = v_regr_lat(:, :, 1) + + ! Regrid in time by linear interpolation: + o3_par_out = regr3_lint(v_regr_lat, tmidmonth, tmidday) + + ! Write to file: + call nf95_put_var(ncid_out, varid_out(i_v), & + o3_par_out(jjm+1:1:-1, :, :)) + ! (The order of "rlatu" is inverted in the output file) + end do + + call nf95_close(ncid_out) + call nf95_close(ncid_in) + + end subroutine regr_lat_time_coefoz + + !******************************************** + + subroutine prepare_out(ncid_in, varid_in, n_plev, name_out, ncid_out, & + varid_out, varid_plev, varid_time) + + ! This subroutine creates the NetCDF output file, defines + ! dimensions and variables, and writes one of the coordinate variables. + + use assert_eq_m, only: assert_eq + + use netcdf95, only: nf95_create, nf95_def_dim, nf95_def_var, & + nf95_put_att, nf95_enddef, nf95_copy_att, nf95_put_var + use netcdf, only: nf90_clobber, nf90_float, nf90_copy_att, nf90_global + + integer, intent(in):: ncid_in, varid_in(:), n_plev + character(len=*), intent(in):: name_out(:) ! of NetCDF variables + integer, intent(out):: ncid_out, varid_out(:), varid_plev, varid_time + + ! Variables local to the procedure: + + include "dimensions.h" + ! (for "jjm") + include "paramet.h" + include "comgeom2.h" + ! (for "rlatu") + include "comconst.h" + ! (for "pi") + + integer ncerr + integer dimid_rlatu, dimid_plev, dimid_time + integer varid_rlatu + integer i, n_o3_param + + !--------------------------- + + print *, "Call sequence information: prepare_out" + n_o3_param = assert_eq(size(varid_in), size(varid_out), & + size(name_out), "prepare_out") + + call nf95_create("coefoz_LMDZ.nc", nf90_clobber, ncid_out) + + ! Dimensions: + call nf95_def_dim(ncid_out, "time", 360, dimid_time) + call nf95_def_dim(ncid_out, "plev", n_plev, dimid_plev) + call nf95_def_dim(ncid_out, "rlatu", jjm + 1, dimid_rlatu) + + ! Define coordinate variables: + + call nf95_def_var(ncid_out, "time", nf90_float, dimid_time, varid_time) + call nf95_put_att(ncid_out, varid_time, "units", "days since 2000-1-1") + call nf95_put_att(ncid_out, varid_time, "calendar", "360_day") + call nf95_put_att(ncid_out, varid_time, "standard_name", "time") + + call nf95_def_var(ncid_out, "plev", nf90_float, dimid_plev, varid_plev) + call nf95_put_att(ncid_out, varid_plev, "units", "millibar") + call nf95_put_att(ncid_out, varid_plev, "standard_name", "air_pressure") + call nf95_put_att(ncid_out, varid_plev, "long_name", "air pressure") + + call nf95_def_var(ncid_out, "rlatu", nf90_float, dimid_rlatu, varid_rlatu) + call nf95_put_att(ncid_out, varid_rlatu, "units", "degrees_north") + call nf95_put_att(ncid_out, varid_rlatu, "standard_name", "latitude") + + ! Define primary variables: + + do i = 1, n_o3_param + call nf95_def_var(ncid_out, name_out(i), nf90_float, & + (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(i)) + + ! The following commands may fail. That is OK. It should just + ! mean that the attribute is not defined in the input file. + + ncerr = nf90_copy_att(ncid_in, varid_in(i), "long_name",& + & ncid_out, varid_out(i)) + call handle_err_copy_att("long_name") + + ncerr = nf90_copy_att(ncid_in, varid_in(i), "units", ncid_out,& + & varid_out(i)) + call handle_err_copy_att("units") + + ncerr = nf90_copy_att(ncid_in, varid_in(i), "standard_name", ncid_out,& + & varid_out(i)) + call handle_err_copy_att("standard_name") + end do + + ! Global attributes: + call nf95_copy_att(ncid_in, nf90_global, "Conventions", ncid_out, & + nf90_global) + call nf95_copy_att(ncid_in, nf90_global, "title", ncid_out, nf90_global) + call nf95_copy_att(ncid_in, nf90_global, "source", ncid_out, nf90_global) + call nf95_put_att(ncid_out, nf90_global, "comment", "Regridded for LMDZ") + + call nf95_enddef(ncid_out) + + ! Write one of the coordinate variables: + call nf95_put_var(ncid_out, varid_rlatu, rlatu(jjm+1:1:-1) / pi * 180.) + ! (convert from rad to degrees and sort in ascending order) + + contains + + subroutine handle_err_copy_att(att_name) + + use netcdf, only: nf90_noerr, nf90_strerror + + character(len=*), intent(in):: att_name + + !---------------------------------------- + + if (ncerr /= nf90_noerr) then + print *, "prepare_out " // trim(name_out(i)) & + // " nf90_copy_att " // att_name // " -- " & + // trim(nf90_strerror(ncerr)) + end if + + end subroutine handle_err_copy_att + + end subroutine prepare_out + +end module regr_lat_time_coefoz_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_av_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_av_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_av_m.F90 (revision 1634) @@ -0,0 +1,122 @@ +! $Id$ +module regr_pr_av_m + + ! Author: Lionel GUEZ + + implicit none + +contains + + subroutine regr_pr_av(ncid, name, julien, press_in_edg, paprs, v3) + + ! "regr_pr_av" stands for "regrid pressure averaging". + ! In this procedure: + ! -- the root process reads 2D latitude-pressure fields from a + ! NetCDF file, at a given day. + ! -- the fields are packed to the LMDZ horizontal "physics" + ! grid and scattered to all threads of all processes; + ! -- in all the threads of all the processes, the fields are regridded in + ! pressure to the LMDZ vertical grid. + ! We assume that, in the input file, the fields have 3 dimensions: + ! latitude, pressure, julian day. + ! We assume that the input fields are already on the "rlatu" + ! latitudes, except that latitudes are in ascending order in the input + ! file. + ! We assume that all the inputs fields have the same coordinates. + + ! The target vertical LMDZ grid is the grid of layer boundaries. + ! Regridding in pressure is done by averaging a step function of pressure. + + ! All the fields are regridded as a single multi-dimensional array + ! so it saves CPU time to call this procedure once for several NetCDF + ! variables rather than several times, each time for a single + ! NetCDF variable. + + use dimphy, only: klon + use netcdf95, only: nf95_inq_varid, handle_err + use netcdf, only: nf90_get_var + use assert_m, only: assert + use assert_eq_m, only: assert_eq + use regr1_step_av_m, only: regr1_step_av + use mod_phys_lmdz_mpi_data, only: is_mpi_root + + use mod_phys_lmdz_transfert_para, only: scatter2d + ! (pack to the LMDZ horizontal "physics" grid and scatter) + + integer, intent(in):: ncid ! NetCDF ID of the file + character(len=*), intent(in):: name(:) ! of the NetCDF variables + integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 + + real, intent(in):: press_in_edg(:) + ! edges of pressure intervals for input data, in Pa, in strictly + ! ascending order + + real, intent(in):: paprs(:, :) ! (klon, llm + 1) + ! (pression pour chaque inter-couche, en Pa) + + real, intent(out):: v3(:, :, :) ! (klon, llm, size(name)) + ! regridded fields on the partial "physics" grid + ! "v3(i, k, l)" is at longitude "xlon(i)", latitude + ! "xlat(i)", in pressure interval "[paprs(i, k+1), paprs(i, k)]", + ! for NetCDF variable "name(l)". + + ! Variables local to the procedure: + + include "dimensions.h" + integer varid, ncerr ! for NetCDF + + real v1(iim, jjm + 1, size(press_in_edg) - 1, size(name)) + ! input fields at day "julien", on the global "dynamics" horizontal grid + ! First dimension is for longitude. + ! The values are the same for all longitudes. + ! "v1(:, j, k, l)" is at latitude "rlatu(j)", for + ! pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and + ! NetCDF variable "name(l)". + + real v2(klon, size(press_in_edg) - 1, size(name)) + ! fields scattered to the partial "physics" horizontal grid + ! "v2(i, k, l)" is at longitude "xlon(i)", latitude "xlat(i)", + ! for pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and + ! NetCDF variable "name(l)". + + integer i, n_var + + !-------------------------------------------- + + call assert(size(v3, 1) == klon, size(v3, 2) == llm, "regr_pr_av v3 klon") + n_var = assert_eq(size(name), size(v3, 3), "regr_pr_av v3 n_var") + call assert(shape(paprs) == (/klon, llm+1/), "regr_pr_av paprs") + + !$omp master + if (is_mpi_root) then + do i = 1, n_var + call nf95_inq_varid(ncid, trim(name(i)), varid) + + ! Get data at the right day from the input file: + ncerr = nf90_get_var(ncid, varid, v1(1, :, :, i), & + start=(/1, 1, julien/)) + call handle_err("regr_pr_av nf90_get_var " // trim(name(i)), ncerr, & + ncid) + end do + + ! Latitudes are in ascending order in the input file while + ! "rlatu" is in descending order so we need to invert order: + v1(1, :, :, :) = v1(1, jjm+1:1:-1, :, :) + + ! Duplicate on all longitudes: + v1(2:, :, :, :) = spread(v1(1, :, :, :), dim=1, ncopies=iim-1) + end if + !$omp end master + + call scatter2d(v1, v2) + + ! Regrid in pressure at each horizontal position: + do i = 1, klon + v3(i, llm:1:-1, :) = regr1_step_av(v2(i, :, :), press_in_edg, & + paprs(i, llm+1:1:-1)) + ! (invert order of indices because "paprs" is in descending order) + end do + + end subroutine regr_pr_av + +end module regr_pr_av_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_comb_coefoz_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_comb_coefoz_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_comb_coefoz_m.F90 (revision 1634) @@ -0,0 +1,163 @@ +! $Id$ +module regr_pr_comb_coefoz_m + + implicit none + + ! The five module variables declared here are on the partial + ! "physics" grid. + ! The value of each variable for index "(i, k)" is at longitude + ! "rlon(i)", latitude "rlat(i)" and middle of layer "k". + + real, allocatable, save:: c_Mob(:, :) + ! (sum of Mobidic terms in the net mass production rate of ozone + ! by chemistry, per unit mass of air, in s-1) + + real, allocatable, save:: a2(:, :) + ! (derivative of mass production rate of ozone per unit mass of + ! air with respect to ozone mass fraction, in s-1) + + real, allocatable, save:: a4_mass(:, :) + ! (derivative of mass production rate of ozone per unit mass of + ! air with respect to temperature, in s-1 K-1) + + real, allocatable, save:: a6_mass(:, :) + ! (derivative of mass production rate of ozone per unit mass of + ! air with respect to mass column-density of ozone above, in m2 s-1 kg-1) + + real, allocatable, save:: r_het_interm(:, :) + ! (net mass production rate by heterogeneous chemistry, per unit + ! mass of ozone, corrected for chlorine content and latitude, but + ! not for temperature and sun direction, in s-1) + + !$omp threadprivate(c_Mob, a2, a4_mass, a6_mass, r_het_interm) + +contains + + subroutine alloc_coefoz + + ! This procedure is called once per run. + ! It allocates module variables. + + use dimphy, only: klon + + ! Variables local to the procedure: + include "dimensions.h" + + !--------------------------------------- + + !$omp master + print *, "Call sequence information: alloc_coefoz" + !$omp end master + allocate(c_Mob(klon, llm), a2(klon, llm), a4_mass(klon, llm)) + allocate(a6_mass(klon, llm), r_het_interm(klon, llm)) + + end subroutine alloc_coefoz + + !******************************************************* + + subroutine regr_pr_comb_coefoz(julien, rlat, paprs, pplay) + + ! "regr_pr_comb_coefoz" stands for "regrid pressure combine + ! coefficients ozone". + + ! In this subroutine: + ! -- the master thread of the root process reads from a file all + ! eight coefficients for ozone chemistry, at the current day; + ! -- the coefficients are packed to the "physics" horizontal grid + ! and scattered to all threads of all processes; + ! -- in all the threads of all the processes, the coefficients are + ! regridded in pressure to the LMDZ vertical grid; + ! -- in all the threads of all the processes, the eight + ! coefficients are combined to define the five module variables. + + use netcdf95, only: nf95_open, nf95_close + use netcdf, only: nf90_nowrite + use assert_m, only: assert + use dimphy, only: klon + use mod_phys_lmdz_mpi_data, only: is_mpi_root + use regr_pr_av_m, only: regr_pr_av + use regr_pr_int_m, only: regr_pr_int + use press_coefoz_m, only: press_in_edg, plev + + integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 + + REAL, intent(in):: rlat(:) + ! (latitude on the partial "physics" grid, in degrees) + + real, intent(in):: paprs(:, :) ! (klon, llm + 1) + ! (pression pour chaque inter-couche, en Pa) + + real, intent(in):: pplay(:, :) ! (klon, llm) + ! (pression pour le mileu de chaque couche, en Pa) + + ! Variables local to the procedure: + + include "dimensions.h" + integer ncid ! for NetCDF + + real coefoz(klon, llm, 7) + ! (temporary storage for 7 ozone coefficients) + ! (On the partial "physics" grid. + ! "coefoz(i, k, :)" is at longitude "rlon(i)", latitude "rlat(i)", + ! middle of layer "k".) + + real a6(klon, llm) + ! (derivative of "P_net_Mob" with respect to column-density of ozone + ! above, in cm2 s-1) + ! (On the partial "physics" grid. + ! "a6(i, k)" is at longitude "rlon(i)", latitude "rlat(i)", + ! middle of layer "k".) + + real, parameter:: amu = 1.6605402e-27 ! atomic mass unit, in kg + + real, parameter:: Clx = 3.8e-9 + ! (total chlorine content in the upper stratosphere) + + integer k + + !------------------------------------ + + !!print *, "Call sequence information: regr_pr_comb_coefoz" + call assert((/size(rlat), size(paprs, 1), size(pplay, 1)/) == klon, & + "regr_pr_comb_coefoz klon") + call assert((/size(paprs, 2) - 1, size(pplay, 2)/) == llm, & + "regr_pr_comb_coefoz llm") + + !$omp master + if (is_mpi_root) call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid) + !$omp end master + + call regr_pr_av(ncid, (/"a2 ", "a4 ", "a6 ", & + "P_net_Mob", "r_Mob ", "temp_Mob ", "R_Het "/), julien, & + press_in_edg, paprs, coefoz) + a2 = coefoz(:, :, 1) + a4_mass = coefoz(:, :, 2) * 48. / 29. + + ! Compute "a6_mass" avoiding underflow, do not divide by 1e4 + ! before dividing by molecular mass: + a6_mass = coefoz(:, :, 3) / (1e4 * 29. * amu) + ! (factor 1e4: conversion from cm2 to m2) + + ! We can overwrite "coefoz(:, :, 1)", which was saved to "a2": + call regr_pr_int(ncid, "Sigma_Mob", julien, plev, pplay, top_value=0., & + v3=coefoz(:, :, 1)) + + ! Combine coefficients to get "c_Mob": + c_mob = (coefoz(:, :, 4) - a2 * coefoz(:, :, 5) & + - coefoz(:, :, 3) * coefoz(:, :, 1)) * 48. / 29. & + - a4_mass * coefoz(:, :, 6) + + r_het_interm = coefoz(:, :, 7) + ! Heterogeneous chemistry is only at high latitudes: + forall (k = 1: llm) + where (abs(rlat) <= 45.) r_het_interm(:, k) = 0. + end forall + r_het_interm = r_het_interm * (Clx / 3.8e-9)**2 + + !$omp master + if (is_mpi_root) call nf95_close(ncid) + !$omp end master + + end subroutine regr_pr_comb_coefoz + +end module regr_pr_comb_coefoz_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_int_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_int_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_int_m.F90 (revision 1634) @@ -0,0 +1,106 @@ +! $Id$ +module regr_pr_int_m + + ! Author: Lionel GUEZ + + implicit none + +contains + + subroutine regr_pr_int(ncid, name, julien, plev, pplay, top_value, v3) + + ! "regr_pr_int" stands for "regrid pressure interpolation". + ! In this procedure: + ! -- the root process reads a 2D latitude-pressure field from a + ! NetCDF file, at a given day. + ! -- the field is packed to the LMDZ horizontal "physics" + ! grid and scattered to all threads of all processes; + ! -- in all the threads of all the processes, the field is regridded in + ! pressure to the LMDZ vertical grid. + ! We assume that, in the input file, the field has 3 dimensions: + ! latitude, pressure, julian day. + ! We assume that latitudes are in ascending order in the input file. + ! The target vertical LMDZ grid is the grid of mid-layers. + ! Regridding is by linear interpolation. + + use dimphy, only: klon + use netcdf95, only: nf95_inq_varid, handle_err + use netcdf, only: nf90_get_var + use assert_m, only: assert + use regr1_lint_m, only: regr1_lint + use mod_phys_lmdz_mpi_data, only: is_mpi_root + + use mod_phys_lmdz_transfert_para, only: scatter2d + ! (pack to the LMDZ horizontal "physics" grid and scatter) + + integer, intent(in):: ncid ! NetCDF ID of the file + character(len=*), intent(in):: name ! of the NetCDF variable + integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 + + real, intent(in):: plev(:) + ! (pressure level of input data, in Pa, in strictly ascending order) + + real, intent(in):: pplay(:, :) ! (klon, llm) + ! (pression pour le mileu de chaque couche, en Pa) + + real, intent(in):: top_value + ! (extra value of field at 0 pressure) + + real, intent(out):: v3(:, :) ! (klon, llm) + ! (regridded field on the partial "physics" grid) + ! ("v3(i, k)" is at longitude "xlon(i)", latitude + ! "xlat(i)", middle of layer "k".) + + ! Variables local to the procedure: + + include "dimensions.h" + integer varid, ncerr ! for NetCDF + + real v1(iim, jjm + 1, 0:size(plev)) + ! (input field at day "julien", on the global "dynamics" horizontal grid) + ! (First dimension is for longitude. + ! The value is the same for all longitudes. + ! "v1(:, j, k >=1)" is at latitude "rlatu(j)" and pressure "plev(k)".) + + real v2(klon, 0:size(plev)) + ! (field scattered to the partial "physics" horizontal grid) + ! "v2(i, k >= 1)" is at longitude "xlon(i)", latitude "xlat(i)" + ! and pressure "plev(k)".) + + integer i + + !-------------------------------------------- + + call assert(shape(v3) == (/klon, llm/), "regr_pr_int v3") + call assert(shape(pplay) == (/klon, llm/), "regr_pr_int pplay") + + !$omp master + if (is_mpi_root) then + call nf95_inq_varid(ncid, name, varid) + + ! Get data at the right day from the input file: + ncerr = nf90_get_var(ncid, varid, v1(1, :, 1:), start=(/1, 1, julien/)) + call handle_err("regr_pr_int nf90_get_var " // name, ncerr, ncid) + ! Latitudes are in ascending order in the input file while + ! "rlatu" is in descending order so we need to invert order: + v1(1, :, 1:) = v1(1, jjm+1:1:-1, 1:) + + ! Complete "v1" with the value at 0 pressure: + v1(1, :, 0) = top_value + + ! Duplicate on all longitudes: + v1(2:, :, :) = spread(v1(1, :, :), dim=1, ncopies=iim-1) + end if + !$omp end master + + call scatter2d(v1, v2) + + ! Regrid in pressure at each horizontal position: + do i = 1, klon + v3(i, llm:1:-1) = regr1_lint(v2(i, :), (/0., plev/), pplay(i, llm:1:-1)) + ! (invert order of indices because "pplay" is in descending order) + end do + + end subroutine regr_pr_int + +end module regr_pr_int_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_o3_m.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_o3_m.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/regr_pr_o3_m.F90 (revision 1634) @@ -0,0 +1,103 @@ +! $Id$ +module regr_pr_o3_m + + implicit none + +contains + + subroutine regr_pr_o3(p3d, o3_mob_regr) + + ! "regr_pr_o3" stands for "regrid pressure ozone". + ! This procedure reads Mobidic ozone mole fraction from + ! "coefoz_LMDZ.nc" at the initial day of the run and regrids it in + ! pressure. + ! Ozone mole fraction from "coefoz_LMDZ.nc" at the initial day is + ! a 2D latitude -- pressure variable. + ! The target horizontal LMDZ grid is the "scalar" grid: "rlonv", "rlatu". + ! The target vertical LMDZ grid is the grid of layer boundaries. + ! We assume that the input variable is already on the LMDZ "rlatu" + ! latitude grid. + ! The input variable does not depend on longitude, but the + ! pressure at LMDZ layers does. + ! Therefore, the values on the LMDZ grid do depend on longitude. + ! Regridding is by averaging, assuming a step function. + ! We assume that, in the input file, the pressure levels are in + ! hPa and strictly increasing. + + use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, handle_err + use netcdf, only: nf90_nowrite, nf90_get_var + use assert_m, only: assert + use regr1_step_av_m, only: regr1_step_av + use press_coefoz_m, only: press_in_edg + use control_mod, only: dayref + + REAL, intent(in):: p3d(:, :, :) ! pressure at layer interfaces, in Pa + ! ("p3d(i, j, l)" is at longitude "rlonv(i)", latitude "rlatu(j)", + ! for interface "l") + + real, intent(out):: o3_mob_regr(:, :, :) ! (iim + 1, jjm + 1, llm) + ! (ozone mole fraction from Mobidic adapted to the LMDZ grid) + ! ("o3_mob_regr(i, j, l)" is at longitude "rlonv(i)", latitude + ! "rlatu(j)" and pressure level "pls(i, j, l)") + + ! Variables local to the procedure: + + include "dimensions.h" + + integer ncid, varid, ncerr ! for NetCDF + integer i, j + + real r_mob(jjm + 1, size(press_in_edg) - 1) + ! (ozone mole fraction from Mobidic at day "dayref") + ! (r_mob(j, k) is at latitude "rlatu(j)", in pressure interval + ! "[press_in_edg(k), press_in_edg(k+1)]".) + + !------------------------------------------------------------ + + print *, "Call sequence information: regr_pr_o3" + call assert(shape(o3_mob_regr) == (/iim + 1, jjm + 1, llm/), & + "regr_pr_o3 o3_mob_regr") + call assert(shape(p3d) == (/iim + 1, jjm + 1, llm + 1/), "regr_pr_o3 p3d") + + call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid) + + call nf95_inq_varid(ncid, "r_Mob", varid) + ! Get data at the right day from the input file: + ncerr = nf90_get_var(ncid, varid, r_mob, start=(/1, 1, dayref/)) + call handle_err("nf90_get_var r_Mob", ncerr) + ! Latitudes are in ascending order in the input file while + ! "rlatu" is in descending order so we need to invert order: + r_mob = r_mob(jjm+1:1:-1, :) + + call nf95_close(ncid) + + ! Regrid in pressure by averaging a step function of pressure: + + ! Poles: + do j = 1, jjm + 1, jjm + o3_mob_regr(1, j, llm:1:-1) & + = regr1_step_av(r_mob(j, :), press_in_edg, p3d(1, j, llm+1:1:-1)) + ! (invert order of indices because "p3d" is in descending order) + end do + + ! Other latitudes: + do j = 2, jjm + do i = 1, iim + o3_mob_regr(i, j, llm:1:-1) & + = regr1_step_av(r_mob(j, :), press_in_edg, & + p3d(i, j, llm+1:1:-1)) + ! (invert order of indices because "p3d" is in descending order) + end do + end do + + ! Duplicate pole values on all longitudes: + o3_mob_regr(2:, 1, :) = spread(o3_mob_regr(1, 1, :), dim=1, ncopies=iim) + o3_mob_regr(2:, jjm + 1, :) & + = spread(o3_mob_regr(1, jjm + 1, :), dim=1, ncopies=iim) + + ! Duplicate first longitude to last longitude: + o3_mob_regr(iim + 1, 2:jjm, :) = o3_mob_regr(1, 2:jjm, :) + + end subroutine regr_pr_o3 + +end module regr_pr_o3_m Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/screenc.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/screenc.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/screenc.F90 (revision 1634) @@ -0,0 +1,84 @@ +! +! $Header$ +! + SUBROUTINE screenc(klon, knon, nsrf, zxli, & + speed, temp, q_zref, zref, & + ts, qsurf, rugos, psol, & + ustar, testar, qstar, okri, ri1, & + pref, delu, delte, delq) + IMPLICIT NONE +!----------------------------------------------------------------------- +! +! Objet : calcul "correcteur" des anomalies du vent, de la temperature +! potentielle et de l'humidite relative au niveau de reference zref et +! par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) +! a partir des equations de Louis. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +!----------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! speed---input-R- module du vent au 1er niveau du modele +! temp----input-R- temperature de l'air au 1er niveau du modele +! q_zref--input-R- humidite relative au 1er niveau du modele +! zref----input-R- altitude de reference +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! psol----input-R- pression au sol +! ustar---input-R- facteur d'echelle pour le vent +! testar--input-R- facteur d'echelle pour la temperature potentielle +! qstar---input-R- facteur d'echelle pour l'humidite relative +! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce +! et zref par rapport au Ri entre la sfce et la 1ere couche +! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche +! +! pref----input-R- pression au niveau de reference +! delu----input-R- anomalie du vent par rapport au 1er niveau +! delte---input-R- anomalie de la temperature potentielle par rapport a la surface +! delq----input-R- anomalie de l'humidite relative par rapport a la surface +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli, okri + REAL, dimension(klon), intent(in) :: speed, temp, q_zref + REAL, intent(in) :: zref + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol + REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1 +! + REAL, dimension(klon), intent(out) :: pref, delu, delte, delq +!----------------------------------------------------------------------- + include "YOMCST.h" +! +! Variables locales + INTEGER :: i + REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref +! +!------------------------------------------------------------------------- + DO i=1, knon + gref(i) = zref*RG + ENDDO +! +! Richardson at reference level +! + CALL coefcdrag (klon, knon, nsrf, zxli, & + speed, temp, q_zref, gref, & + psol, ts, qsurf, rugos, & + okri, ri1, & + cdram, cdrah, cdran, zri1, & + pref) +! + DO i = 1, knon + delu(i) = ustar(i)/sqrt(cdram(i)) + delte(i)= (testar(i)* sqrt(cdram(i)))/ & + cdrah(i) + delq(i)= (qstar(i)* sqrt(cdram(i)))/ & + cdrah(i) + ENDDO +! + RETURN + END SUBROUTINE screenc Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/screenp.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/screenp.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/screenp.F90 (revision 1634) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE screenp(klon, knon, nsrf, & + & speed, tair, qair, & + & ts, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) + IMPLICIT none +!------------------------------------------------------------------------- +! +! Objet : calcul "predicteur" des anomalies du vent, de la temperature +! potentielle et de l'humidite relative au niveau de reference zref et +! par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) +! a partir des relations de Dyer-Businger. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! speed---input-R- module du vent au 1er niveau du modele +! tair----input-R- temperature de l'air au 1er niveau du modele +! qair----input-R- humidite relative au 1er niveau du modele +! ts------input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! lmon----input-R- longueur de Monin-Obukov +! ustar---input-R- facteur d'echelle pour le vent +! testar--input-R- facteur d'echelle pour la temperature potentielle +! qstar---input-R- facteur d'echelle pour l'humidite relative +! zref----input-R- altitude de reference +! +! delu----input-R- anomalie du vent par rapport au 1er niveau +! delte---input-R- anomalie de la temperature potentielle par rapport a la surface +! delq----input-R- anomalie de l'humidite relative par rapport a la surface +! + INTEGER, intent(in) :: klon, knon, nsrf + REAL, dimension(klon), intent(in) :: speed, tair, qair + REAL, dimension(klon), intent(in) :: ts, qsurf, rugos + DOUBLE PRECISION, dimension(klon), intent(in) :: lmon + REAL, dimension(klon), intent(in) :: ustar, testar, qstar + REAL, intent(in) :: zref +! + REAL, dimension(klon), intent(out) :: delu, delte, delq +! +!------------------------------------------------------------------------- +! Variables locales et constantes : + REAL, PARAMETER :: RKAR=0.40 + INTEGER :: i + REAL :: xtmp, xtmp0 +!------------------------------------------------------------------------- + DO i = 1, knon +! + IF (lmon(i).GE.0.) THEN +! +! STABLE CASE +! + IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0 & + & .AND. rugos(i).LE.1.0) THEN + delu(i) = (ustar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.d0, 5.0 *(zref - rugos(i))/lmon(i))) + delte(i) = (testar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.d0, 5.0 * (zref - rugos(i))/lmon(i))) + delq(i) = (qstar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) + & + min(5.d0, 5.0 * (zref - rugos(i))/lmon(i))) + ELSE + delu(i) = 0.1 * speed(i) + delte(i) = 0.1 * (tair(i) - ts(i) ) + delq(i) = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0)) + ENDIF + ELSE +! +! UNSTABLE CASE +! + IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN + xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.) + xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.) + delu(i) = (ustar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.*log(0.5*(1. + xtmp)) & + + 2.*log(0.5*(1. + xtmp0)) & + - log(0.5*(1. + xtmp*xtmp)) & + + log(0.5*(1. + xtmp0*xtmp0)) & + + 2.*atan(xtmp) - 2.*atan(xtmp0)) + delte(i) = (testar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.0 * log(0.5*(1. + xtmp*xtmp)) & + + 2.0 * log(0.5*(1. + xtmp0*xtmp0))) + delq(i) = (qstar(i)/RKAR)* & + (log(zref/(rugos(i))+1.) & + - 2.0 * log(0.5*(1. + xtmp*xtmp)) & + + 2.0 * log(0.5*(1. + xtmp0*xtmp0))) + ELSE + delu(i) = 0.5 * speed(i) + delte(i) = 0.5 * (tair(i) - ts(i) ) + delq(i) = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0)) + ENDIF + ENDIF +! + ENDDO + RETURN + END SUBROUTINE screenp Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/soil.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/soil.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/soil.F90 (revision 1634) @@ -0,0 +1,278 @@ +! +! $Header$ +! +SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, & + ptsoil, pcapcal, pfluxgrd) + + USE dimphy + USE mod_phys_lmdz_para + IMPLICIT NONE + +!======================================================================= +! +! Auteur: Frederic Hourdin 30/01/92 +! ------- +! +! Object: Computation of : the soil temperature evolution +! ------- the surfacic heat capacity "Capcal" +! the surface conduction flux pcapcal +! +! +! Method: Implicit time integration +! ------- +! Consecutive ground temperatures are related by: +! T(k+1) = C(k) + D(k)*T(k) (*) +! The coefficients C and D are computed at the t-dt time-step. +! Routine structure: +! 1) C and D coefficients are computed from the old temperature +! 2) new temperatures are computed using (*) +! 3) C and D coefficients are computed from the new temperature +! profile for the t+dt time-step +! 4) the coefficients A and B are computed where the diffusive +! fluxes at the t+dt time-step is given by +! Fdiff = A + B Ts(t+dt) +! or Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt +! with F0 = A + B (Ts(t)) +! Capcal = B*dt +! +! Interface: +! ---------- +! +! Arguments: +! ---------- +! ptimestep physical timestep (s) +! indice sub-surface index +! snow(klon) snow +! ptsrf(klon) surface temperature at time-step t (K) +! ptsoil(klon,nsoilmx) temperature inside the ground (K) +! pcapcal(klon) surfacic specific heat (W*m-2*s*K-1) +! pfluxgrd(klon) surface diffusive flux from ground (Wm-2) +! +!======================================================================= + INCLUDE "YOMCST.h" + INCLUDE "dimsoil.h" + INCLUDE "indicesol.h" + INCLUDE "comsoil.h" +!----------------------------------------------------------------------- +! Arguments +! --------- + REAL, INTENT(IN) :: ptimestep + INTEGER, INTENT(IN) :: indice, knon + REAL, DIMENSION(klon), INTENT(IN) :: snow + REAL, DIMENSION(klon), INTENT(IN) :: ptsrf + + REAL, DIMENSION(klon,nsoilmx), INTENT(INOUT) :: ptsoil + REAL, DIMENSION(klon), INTENT(OUT) :: pcapcal + REAL, DIMENSION(klon), INTENT(OUT) :: pfluxgrd + +!----------------------------------------------------------------------- +! Local variables +! --------------- + INTEGER :: ig, jk, ierr + REAL :: min_period,dalph_soil + REAL, DIMENSION(nsoilmx) :: zdz2 + REAL :: z1s + REAL, DIMENSION(klon) :: ztherm_i + REAL, DIMENSION(klon,nsoilmx,nbsrf) :: C_coef, D_coef + +! Local saved variables +! --------------------- + REAL, SAVE :: lambda +!$OMP THREADPRIVATE(lambda) + REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2 +!$OMP THREADPRIVATE(dz1,dz2) + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + +!----------------------------------------------------------------------- +! Depthts: +! -------- + REAL fz,rk,fz1,rk1,rk2 + fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.) + + +!----------------------------------------------------------------------- +! Calculation of some constants +! NB! These constants do not depend on the sub-surfaces +!----------------------------------------------------------------------- + + IF (firstcall) THEN +!----------------------------------------------------------------------- +! ground levels +! grnd=z/l where l is the skin depth of the diurnal cycle: +!----------------------------------------------------------------------- + + min_period=1800. ! en secondes + dalph_soil=2. ! rapport entre les epaisseurs de 2 couches succ. +!$OMP MASTER + IF (is_mpi_root) THEN + OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr) + IF (ierr == 0) THEN ! Read file only if it exists + READ(99,*) min_period + READ(99,*) dalph_soil + PRINT*,'Discretization for the soil model' + PRINT*,'First level e-folding depth',min_period, & + ' dalph',dalph_soil + CLOSE(99) + END IF + ENDIF +!$OMP END MASTER + CALL bcast(min_period) + CALL bcast(dalph_soil) + +! la premiere couche represente un dixieme de cycle diurne + fz1=SQRT(min_period/3.14) + + DO jk=1,nsoilmx + rk1=jk + rk2=jk-1 + dz2(jk)=fz(rk1)-fz(rk2) + ENDDO + DO jk=1,nsoilmx-1 + rk1=jk+.5 + rk2=jk-.5 + dz1(jk)=1./(fz(rk1)-fz(rk2)) + ENDDO + lambda=fz(.5)*dz1(1) + PRINT*,'full layers, intermediate layers (seconds)' + DO jk=1,nsoilmx + rk=jk + rk1=jk+.5 + rk2=jk-.5 + PRINT *,'fz=', & + fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14 + ENDDO + + firstcall =.FALSE. + END IF + + +!----------------------------------------------------------------------- +! Calcul de l'inertie thermique a partir de la variable rnat. +! on initialise a inertie_ice meme au-dessus d'un point de mer au cas +! ou le point de mer devienne point de glace au pas suivant +! on corrige si on a un point de terre avec ou sans glace +! +!----------------------------------------------------------------------- + IF (indice == is_sic) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_ice + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO + ELSE IF (indice == is_lic) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_ice + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO + ELSE IF (indice == is_ter) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_sol + IF (snow(ig) > 0.0) ztherm_i(ig) = inertie_sno + ENDDO + ELSE IF (indice == is_oce) THEN + DO ig = 1, knon + ztherm_i(ig) = inertie_ice + ENDDO + ELSE + PRINT*, "valeur d indice non prevue", indice + CALL abort + ENDIF + + +!----------------------------------------------------------------------- +! 1) +! Calculation of Cgrf and Dgrd coefficients using soil temperature from +! previous time step. +! +! These variables are recalculated on the local compressed grid instead +! of saved in restart file. +!----------------------------------------------------------------------- + DO jk=1,nsoilmx + zdz2(jk)=dz2(jk)/ptimestep + ENDDO + + DO ig=1,knon + z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) + C_coef(ig,nsoilmx-1,indice)= & + zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s + D_coef(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1s + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & + *(1.-D_coef(ig,jk,indice))) + C_coef(ig,jk-1,indice)= & + (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s + D_coef(ig,jk-1,indice)=dz1(jk-1)*z1s + ENDDO + ENDDO + +!----------------------------------------------------------------------- +! 2) +! Computation of the soil temperatures using the Cgrd and Dgrd +! coefficient computed above +! +!----------------------------------------------------------------------- + +! Surface temperature + DO ig=1,knon + ptsoil(ig,1)=(lambda*C_coef(ig,1,indice)+ptsrf(ig))/ & + (lambda*(1.-D_coef(ig,1,indice))+1.) + ENDDO + +! Other temperatures + DO jk=1,nsoilmx-1 + DO ig=1,knon + ptsoil(ig,jk+1)=C_coef(ig,jk,indice)+D_coef(ig,jk,indice) & + *ptsoil(ig,jk) + ENDDO + ENDDO + + IF (indice == is_sic) THEN + DO ig = 1 , knon + ptsoil(ig,nsoilmx) = RTT - 1.8 + END DO + ENDIF + +!----------------------------------------------------------------------- +! 3) +! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil +! temperature +!----------------------------------------------------------------------- + DO ig=1,knon + z1s = zdz2(nsoilmx)+dz1(nsoilmx-1) + C_coef(ig,nsoilmx-1,indice) = zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s + D_coef(ig,nsoilmx-1,indice) = dz1(nsoilmx-1)/z1s + ENDDO + + DO jk=nsoilmx-1,2,-1 + DO ig=1,knon + z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) & + *(1.-D_coef(ig,jk,indice))) + C_coef(ig,jk-1,indice) = & + (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s + D_coef(ig,jk-1,indice) = dz1(jk-1)*z1s + ENDDO + ENDDO + +!----------------------------------------------------------------------- +! 4) +! Computation of the surface diffusive flux from ground and +! calorific capacity of the ground +!----------------------------------------------------------------------- + DO ig=1,knon + pfluxgrd(ig) = ztherm_i(ig)*dz1(1)* & + (C_coef(ig,1,indice)+(D_coef(ig,1,indice)-1.)*ptsoil(ig,1)) + pcapcal(ig) = ztherm_i(ig)* & + (dz2(1)+ptimestep*(1.-D_coef(ig,1,indice))*dz1(1)) + z1s = lambda*(1.-D_coef(ig,1,indice))+1. + pcapcal(ig) = pcapcal(ig)/z1s + pfluxgrd(ig) = pfluxgrd(ig) & + + pcapcal(ig) * (ptsoil(ig,1) * z1s & + - lambda * C_coef(ig,1,indice) & + - ptsrf(ig)) & + /ptimestep + ENDDO + +END SUBROUTINE soil Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/solarlong.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/solarlong.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/solarlong.F (revision 1634) @@ -0,0 +1,134 @@ + SUBROUTINE solarlong(pday,psollong,pdist_sol) + + USE ioipsl + + IMPLICIT NONE + +c======================================================================= +c +c Objet: +c ------ +c +c Calcul de la distance soleil-planete et de la declinaison +c en fonction du jour de l'annee. +c +c +c Methode: +c -------- +c +c Calcul complet de l'elipse +c +c Interface: +c ---------- +c +c Uncommon comprenant les parametres orbitaux. +c +c Arguments: +c ---------- +c +c Input: +c ------ +c pday jour de l'annee (le jour 0 correspondant a l'equinoxe) +c lwrite clef logique pour sorties de controle +c +c Output: +c ------- +c pdist_sol distance entre le soleil et la planete +c ( en unite astronomique pour utiliser la constante +c solaire terrestre 1370 Wm-2 ) +c pdecli declinaison ( en radians ) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "planete.h" +#include "YOMCST.h" + include 'iniprint.h' + +c arguments: +c ---------- + + REAL pday,pdist_sol,pdecli,psollong + LOGICAL lwrite + +c Local: +c ------ + + REAL zanom,xref,zx0,zdx,zteta,zz,pi + INTEGER iter + REAL :: pyear_day,pperi_day + REAL :: jD_eq, jD_peri + LOGICAL,SAVE :: first=.TRUE. +c$OMP THREADPRIVATE(first) + +c----------------------------------------------------------------------- +c calcul de l'angle polaire et de la distance au soleil : +c ------------------------------------------------------- + +c Initialisation eventuelle: + if(first) then + call ioget_calendar(pyear_day) + call ymds2ju(2000, 3, 21, 0., jD_eq) + call ymds2ju(2001, 1, 4, 0., jD_peri) + pperi_day = jD_peri - jD_eq + pperi_day = R_peri + 180. + write(lunout,*)' Number of days in a year = ',pyear_day +c call iniorbit(249.22,206.66,669.,485.,25.2) + call iniorbit(152.59,146.61,pyear_day,pperi_day,R_incl) + first=.FALSE. + endif + +c calcul de l'zanomalie moyenne + + zz=(pday-peri_day)/year_day + pi=2.*asin(1.) + zanom=2.*pi*(zz-nint(zz)) + xref=abs(zanom) + +c resolution de l'equation horaire zx0 - e * sin (zx0) = xref +c methode de Newton + +! zx0=xref+e_elips*sin(xref) + zx0=xref+R_ecc*sin(xref) + DO 110 iter=1,10 +! zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0)) + zdx=-(zx0-R_ecc*sin(zx0)-xref)/(1.-R_ecc*cos(zx0)) + if(abs(zdx).le.(1.e-7)) goto 120 + zx0=zx0+zdx +110 continue +120 continue + zx0=zx0+zdx + if(zanom.lt.0.) zx0=-zx0 + +c zteta est la longitude solaire + +! zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.)) + zteta=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.)) + + psollong=zteta-timeperi + + IF(psollong.LT.0.) psollong=psollong+2.*pi + IF(psollong.GT.2.*pi) psollong=psollong-2.*pi + + psollong = psollong * 180. / pi + +c distance soleil + + pdist_sol = (1-R_ecc*R_ecc) + & /(1+R_ecc*COS(pi/180.*(psollong-(R_peri+180.0)))) +! pdist_sol = (1-e_elips*e_elips) +! & /(1+e_elips*COS(pi/180.*(psollong-(R_peri+180.0)))) +c----------------------------------------------------------------------- +c sorties eventuelles: +c --------------------- + +c IF (lwrite) THEN +c PRINT*,'jour de l"annee :',pday +c PRINT*,'distance au soleil (en unite astronomique) :',pdist_sol +c PRINT*,'declinaison (en degres) :',pdecli*180./pi +c ENDIF + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/statto.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/statto.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/statto.h (revision 1634) @@ -0,0 +1,34 @@ + +! statto: +! This include file controls the production of statistics. +! Some variables could be set in a namelist, but it is easier to +! do it here since arrays can then be dimensioned using parameters +! and values shouldn't have to change too often. SRL + +! Calculate stats every istats physics timesteps, starting at first +! call. If istats=0 then don't do statistics at all. Check value +! if number of physics timesteps changes. + integer istats + +! Calculate itime independent sums and sums of squares, +! example, istat=1,istime=1 gives a single time mean + integer, parameter :: istime=12 + +! Number of 2D and 3D variables on which to do statistics. + integer n2dvar, n3dvar + parameter (n2dvar = 8, n3dvar = 5) + +! Units for writing stats header and data + integer usdata + +! count tab to know the variable record + integer count(istime) + +! Record of the number of stores made for each time. + integer nstore(istime) + +! Size of the "controle" array + integer, parameter :: cntrlsize=15 + +! common /sttcom/ dummy,nstore,istats,usdata + common /sttcom/ nstore,istats,usdata,count Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/stdlevvar.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/stdlevvar.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/stdlevvar.F90 (revision 1634) @@ -0,0 +1,278 @@ +! +! $Header$ +! + SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, & + u1, v1, t1, q1, z1, & + ts1, qsurf, rugos, psol, pat1, & + t_2m, q_2m, t_10m, q_10m, u_10m, ustar) + IMPLICIT NONE +!------------------------------------------------------------------------- +! +! Objet : calcul de la temperature et l'humidite relative a 2m et du +! module du vent a 10m a partir des relations de Dyer-Businger et +! des equations de Louis. +! +! Reference : Hess, Colman et McAvaney (1995) +! +! I. Musat, 01.07.2002 +! +!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain +! +!------------------------------------------------------------------------- +! +! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude) +! knon----input-I- nombre de points pour un type de surface +! nsrf----input-I- indice pour le type de surface; voir indicesol.h +! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li +! u1------input-R- vent zonal au 1er niveau du modele +! v1------input-R- vent meridien au 1er niveau du modele +! t1------input-R- temperature de l'air au 1er niveau du modele +! q1------input-R- humidite relative au 1er niveau du modele +! z1------input-R- geopotentiel au 1er niveau du modele +! ts1-----input-R- temperature de l'air a la surface +! qsurf---input-R- humidite relative a la surface +! rugos---input-R- rugosite +! psol----input-R- pression au sol +! pat1----input-R- pression au 1er niveau du modele +! +! t_2m---output-R- temperature de l'air a 2m +! q_2m---output-R- humidite relative a 2m +! u_10m--output-R- vitesse du vent a 10m +!AM +! t_10m--output-R- temperature de l'air a 10m +! q_10m--output-R- humidite specifique a 10m +! ustar--output-R- u* +! + INTEGER, intent(in) :: klon, knon, nsrf + LOGICAL, intent(in) :: zxli + REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1 + REAL, dimension(klon), intent(in) :: qsurf, rugos + REAL, dimension(klon), intent(in) :: psol, pat1 +! + REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar + REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m +!------------------------------------------------------------------------- + include "YOMCST.h" +!IM PLUS + include "YOETHF.h" +! +! Quelques constantes et options: +! +! RKAR : constante de von Karman + REAL, PARAMETER :: RKAR=0.40 +! niter : nombre iterations calcul "corrector" +! INTEGER, parameter :: niter=6, ncon=niter-1 + INTEGER, parameter :: niter=2, ncon=niter-1 +! +! Variables locales + INTEGER :: i, n + REAL :: zref + REAL, dimension(klon) :: speed +! tpot : temperature potentielle + REAL, dimension(klon) :: tpot + REAL, dimension(klon) :: zri1, cdran + REAL, dimension(klon) :: cdram, cdrah +! ri1 : nb. de Richardson entre la surface --> la 1ere couche + REAL, dimension(klon) :: ri1 + REAL, dimension(klon) :: testar, qstar + REAL, dimension(klon) :: zdte, zdq +! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney + DOUBLE PRECISION, dimension(klon) :: lmon + DOUBLE PRECISION, parameter :: eps=1.0D-20 + REAL, dimension(klon) :: delu, delte, delq + REAL, dimension(klon) :: u_zref, te_zref, q_zref + REAL, dimension(klon) :: temp, pref + LOGICAL :: okri + REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p +!convertgence + REAL, dimension(klon) :: te_zref_con, q_zref_con + REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c + REAL, dimension(klon) :: ok_pred, ok_corr +! REAL, dimension(klon) :: conv_te, conv_q +!------------------------------------------------------------------------- + DO i=1, knon + speed(i)=SQRT(u1(i)**2+v1(i)**2) + ri1(i) = 0.0 + ENDDO +! + okri=.FALSE. + CALL coefcdrag(klon, knon, nsrf, zxli, & + & speed, t1, q1, z1, psol, & + & ts1, qsurf, rugos, okri, ri1, & + & cdram, cdrah, cdran, zri1, pref) +! +!---------Star variables---------------------------------------------------- +! + DO i = 1, knon + ri1(i) = zri1(i) + tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA + ustar(i) = sqrt(cdram(i) * speed(i) * speed(i)) + zdte(i) = tpot(i) - ts1(i) + zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0) +! +! +!IM BUG BUG BUG zdte(i) = max(zdte(i),1.e-10) + zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i)) +! + testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i) + qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i) + lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ & + & (RKAR * RG * testar(i)) + ENDDO +! +!----------First aproximation of variables at zref -------------------------- + zref = 2.0 + CALL screenp(klon, knon, nsrf, speed, tpot, q1, & + & ts1, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = max(qsurf(i),0.0) + delq(i) + te_zref(i) = ts1(i) + delte(i) + temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA) + q_zref_p(i) = q_zref(i) +! te_zref_p(i) = te_zref(i) + temp_p(i) = temp(i) + ENDDO +! +! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 +! + DO n = 1, niter +! + okri=.TRUE. + CALL screenc(klon, knon, nsrf, zxli, & + & u_zref, temp, q_zref, zref, & + & ts1, qsurf, rugos, psol, & + & ustar, testar, qstar, okri, ri1, & + & pref, delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = delq(i) + max(qsurf(i),0.0) + te_zref(i) = delte(i) + ts1(i) +! +! return to normal temperature +! + temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) +! +!IM +++ +! IF(temp(i).GT.350.) THEN +! WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i) +! ENDIF +!IM --- +! + IF(n.EQ.ncon) THEN + te_zref_con(i) = te_zref(i) + q_zref_con(i) = q_zref(i) + ENDIF +! + ENDDO +! + ENDDO +! +! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref +! +! DO i = 1, knon +! conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i) +! conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i) +!IM +++ +! IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN +! PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), & +! q_zref_con(i),q_zref(i),conv_q(i) +! ENDIF +!IM --- +! ENDDO +! + DO i = 1, knon + q_zref_c(i) = q_zref(i) + temp_c(i) = temp(i) +! +! IF(zri1(i).LT.0.) THEN +! IF(nsrf.EQ.1) THEN +! ok_pred(i)=1. +! ok_corr(i)=0. +! ELSE +! ok_pred(i)=0. +! ok_corr(i)=1. +! ENDIF +! ELSE +! ok_pred(i)=0. +! ok_corr(i)=1. +! ENDIF +! + ok_pred(i)=0. + ok_corr(i)=1. +! + t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i) + q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i) +!IM +++ +! IF(n.EQ.niter) THEN +! IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN +! PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) +! ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN +! PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) +! ENDIF +! ENDIF +!IM --- + ENDDO +! +! +!----------First aproximation of variables at zref -------------------------- +! + zref = 10.0 + CALL screenp(klon, knon, nsrf, speed, tpot, q1, & + & ts1, qsurf, rugos, lmon, & + & ustar, testar, qstar, zref, & + & delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = max(qsurf(i),0.0) + delq(i) + te_zref(i) = ts1(i) + delte(i) + temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) + u_zref_p(i) = u_zref(i) + ENDDO +! +! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 +! + DO n = 1, niter +! + okri=.TRUE. + CALL screenc(klon, knon, nsrf, zxli, & + & u_zref, temp, q_zref, zref, & + & ts1, qsurf, rugos, psol, & + & ustar, testar, qstar, okri, ri1, & + & pref, delu, delte, delq) +! + DO i = 1, knon + u_zref(i) = delu(i) + q_zref(i) = delq(i) + max(qsurf(i),0.0) + te_zref(i) = delte(i) + ts1(i) + temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA) +! temp(i) = te_zref(i) - (zref* RG)/RCPD/ & +! (1 + RVTMP2 * max(q_zref(i),0.0)) + ENDDO +! + ENDDO +! + DO i = 1, knon + u_zref_c(i) = u_zref(i) +! + u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i) +! +!AM + q_zref_c(i) = q_zref(i) + temp_c(i) = temp(i) + t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i) + q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i) +!MA + ENDDO +! + RETURN + END subroutine stdlevvar Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/stratocu_if.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/stratocu_if.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/stratocu_if.F90 (revision 1634) @@ -0,0 +1,78 @@ + SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t & +,seuil_inversion,weak_inversion,dthmin) +implicit none + +!====================================================================== +! J'introduit un peu de diffusion sauf dans les endroits +! ou une forte inversion est presente +! On peut dire qu'il represente la convection peu profonde +! +! Arguments: +! klon-----input-I- nombre de points a traiter +! paprs----input-R- pression a chaque intercouche (en Pa) +! pplay----input-R- pression au milieu de chaque couche (en Pa) +! t--------input-R- temperature (K) +! +! weak_inversion-----logical +!====================================================================== +! +! Arguments: +! + INTEGER, INTENT(IN) :: klon,klev + REAL, DIMENSION(klon, klev+1), INTENT(IN) :: paprs + REAL, DIMENSION(klon, klev), INTENT(IN) :: pplay + REAL, DIMENSION(klon, 4), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon, klev), INTENT(IN) :: t + + REAL, DIMENSION(klon), INTENT(OUT) :: weak_inversion +! +! Quelques constantes et options: +! + REAL seuil_inversion ! au-dela l'inversion est consideree trop faible +! PARAMETER (seuil=-0.1) + +! +! Variables locales: +! + INTEGER i, k, invb(klon) + REAL zl2(klon) + REAL dthmin(klon), zdthdp + + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! +! Chercher la zone d'inversion forte +! + + DO i = 1, klon + invb(i) = klev + dthmin(i)=0.0 + ENDDO + DO k = 2, klev/2-1 + DO i = 1, klon + zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) & + - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1) + zdthdp = zdthdp * 100.0 + IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. & + zdthdp.LT.dthmin(i) ) THEN + dthmin(i) = zdthdp + invb(i) = k + ENDIF + ENDDO + ENDDO + + +! +! Introduire une diffusion: +! + DO i = 1, klon + IF ( (pctsrf(i,is_oce) < 0.5) .OR. & + (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN + weak_inversion(i)=1. + ELSE + weak_inversion(i)=0. + ENDIF + ENDDO + + END SUBROUTINE stratocu_if Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/suphel.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/suphel.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/suphel.F (revision 1634) @@ -0,0 +1,211 @@ +! +! $Header$ +! + SUBROUTINE suphel +C +#include "YOMCST.h" +#include "YOETHF.h" +cIM cf. JLD + LOGICAL firstcall + SAVE firstcall +c$OMP THREADPRIVATE(firstcall) + DATA firstcall /.TRUE./ + + IF (firstcall) THEN + PRINT*, 'suphel initialise les constantes du GCM' + firstcall = .FALSE. + ELSE + PRINT*, 'suphel DEJA APPELE ' + RETURN + ENDIF +C ----------------------------------------------------------------- +C +C* 1. DEFINE FUNDAMENTAL CONSTANTS. +C ----------------------------- +C + WRITE(UNIT=6,FMT='(''0*** Constants of the ICM ***'')') + RPI=2.*ASIN(1.) + RCLUM=299792458. + RHPLA=6.6260755E-34 + RKBOL=1.380658E-23 + RNAVO=6.0221367E+23 + WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')') + WRITE(UNIT=6,FMT='('' PI = '',E13.7,'' -'')')RPI + WRITE(UNIT=6,FMT='('' c = '',E13.7,''m s-1'')') + S RCLUM + WRITE(UNIT=6,FMT='('' h = '',E13.7,''J s'')') + S RHPLA + WRITE(UNIT=6,FMT='('' K = '',E13.7,''J K-1'')') + S RKBOL + WRITE(UNIT=6,FMT='('' N = '',E13.7,''mol-1'')') + S RNAVO +C +C ---------------------------------------------------------------- +C +C* 2. DEFINE ASTRONOMICAL CONSTANTS. +C ------------------------------ +C + RDAY=86400. + REA=149597870000. + REPSM=0.409093 +C + RSIYEA=365.25*RDAY*2.*RPI/6.283076 + RSIDAY=RDAY/(1.+RDAY/RSIYEA) + ROMEGA=2.*RPI/RSIDAY +c +c exp1 R_ecc = 0.05 +c exp1 R_peri = 102.04 +c exp1 R_incl = 22.5 +c exp1 print*, 'Parametres orbitaux modifies' +c ref R_ecc = 0.016724 +c ref R_peri = 102.04 +c ref R_incl = 23.5 +c +cIM 161002 : pour avoir les ctes AMIP II +cIM 161002 R_ecc = 0.016724 +cIM 161002 R_peri = 102.04 +cIM 161002 R_incl = 23.5 +cIM on mets R_ecc, R_peri, R_incl dans conf_phys.F90 +c R_ecc = 0.016715 +c R_peri = 102.7 +c R_incl = 23.441 +c + WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')') + WRITE(UNIT=6,FMT='('' day = '',E13.7,'' s'')')RDAY + WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA + WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM + WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA + WRITE(UNIT=6,FMT='('' sideral day = '',E13.7,'' s'')')RSIDAY + WRITE(UNIT=6,FMT='('' omega = '',E13.7,'' s-1'')') + S ROMEGA +c write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc +c write(unit=6,fmt='('' equinoxe = '',e13.7,''-'')')R_peri +c write(unit=6,fmt='('' inclinaison = '',e13.7,''-'')')R_incl +C +C ------------------------------------------------------------------ +C +C* 3. DEFINE GEOIDE. +C -------------- +C + RG=9.80665 + RA=6371229. + R1SA=SNGL(1.D0/DBLE(RA)) + WRITE(UNIT=6,FMT='('' *** Geoide ***'')') + WRITE(UNIT=6,FMT='('' Gravity = '',E13.7,'' m s-2'')') + S RG + WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA + WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA +C +C ----------------------------------------------------------------- +C +C* 4. DEFINE RADIATION CONSTANTS. +C --------------------------- +C +c z.x.li RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3) + rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15. +cIM init. dans conf_phys.F90 RI0=1365. + WRITE(UNIT=6,FMT='('' *** Radiation ***'')') + WRITE(UNIT=6,FMT='('' Stefan-Bol. = '',E13.7,'' W m-2 K-4'' + S )') RSIGMA +cIM init. dans conf_phys.F90 WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')') +cIM init. dans conf_phys.F90 S RI0 +C +C ----------------------------------------------------------------- +C +C* 5. DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE. +C ------------------------------------------ +C + R=RNAVO*RKBOL + RMD=28.9644 + RMO3=47.9942 + RMV=18.0153 + RD=1000.*R/RMD + RV=1000.*R/RMV + RCPD=3.5*RD + RCVD=RCPD-RD + RCPV=4. *RV + RCVV=RCPV-RV + RKAPPA=RD/RCPD + RETV=RV/RD-1. + WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas ***'')') + WRITE(UNIT=6,FMT='('' Perfect gas = '',e13.7)') R + WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD + WRITE(UNIT=6,FMT='('' Ozone mass = '',e13.7)') RMO3 + WRITE(UNIT=6,FMT='('' Vapour mass = '',e13.7)') RMV + WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD + WRITE(UNIT=6,FMT='('' Vapour cst. = '',e13.7)') RV + WRITE(UNIT=6,FMT='('' Cpd = '',e13.7)') RCPD + WRITE(UNIT=6,FMT='('' Cvd = '',e13.7)') RCVD + WRITE(UNIT=6,FMT='('' Cpv = '',e13.7)') RCPV + WRITE(UNIT=6,FMT='('' Cvv = '',e13.7)') RCVV + WRITE(UNIT=6,FMT='('' Rd/Cpd = '',e13.7)') RKAPPA + WRITE(UNIT=6,FMT='('' Rv/Rd-1 = '',e13.7)') RETV +C +C ---------------------------------------------------------------- +C +C* 6. DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE. +C --------------------------------------------- +C + RCW=RCPV + WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid ***'')') + WRITE(UNIT=6,FMT='('' Cw = '',E13.7)') RCW +C +C ---------------------------------------------------------------- +C +C* 7. DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE. +C -------------------------------------------- +C + RCS=RCPV + WRITE(UNIT=6,FMT='('' *** thermodynamic, solid ***'')') + WRITE(UNIT=6,FMT='('' Cs = '',E13.7)') RCS +C +C ---------------------------------------------------------------- +C +C* 8. DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE. +C ---------------------------------------------------- +C + RTT=273.16 + RLVTT=2.5008E+6 + RLSTT=2.8345E+6 + RLMLT=RLSTT-RLVTT + RATM=100000. + WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans. ***'')') + WRITE(UNIT=6,FMT='('' Fusion point = '',E13.7)') RTT + WRITE(UNIT=6,FMT='('' RLvTt = '',E13.7)') RLVTT + WRITE(UNIT=6,FMT='('' RLsTt = '',E13.7)') RLSTT + WRITE(UNIT=6,FMT='('' RLMlt = '',E13.7)') RLMLT + WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM + WRITE(UNIT=6,FMT='('' Latent heat : '')') +C +C ---------------------------------------------------------------- +C +C* 9. SATURATED VAPOUR PRESSURE. +C -------------------------- +C + RESTT=611.14 + RGAMW=(RCW-RCPV)/RV + RBETW=RLVTT/RV+RGAMW*RTT + RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT) + RGAMS=(RCS-RCPV)/RV + RBETS=RLSTT/RV+RGAMS*RTT + RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT) + RGAMD=RGAMS-RGAMW + RBETD=RBETS-RBETW + RALPD=RALPS-RALPW +C +C ------------------------------------------------------------------ +c +c calculer les constantes pour les fonctions thermodynamiques +c + RVTMP2=RCPV/RCPD-1. + RHOH2O=RATM/100. + R2ES=RESTT*RD/RV + R3LES=17.269 + R3IES=21.875 + R4LES=35.86 + R4IES=7.66 + R5LES=R3LES*(RTT-R4LES) + R5IES=R3IES*(RTT-R4IES) +C + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_bucket_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_bucket_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_bucket_mod.F90 (revision 1634) @@ -0,0 +1,175 @@ +! +MODULE surf_land_bucket_mod +! +! Surface land bucket module +! +! This module is used when no external land model is choosen. +! + IMPLICIT NONE + +CONTAINS + + SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, & + spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, & + u1, v1, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0_new, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l) + + USE limit_read_mod + USE surface_data + USE fonte_neige_mod + USE calcul_fluxs_mod + USE cpl_mod + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para +!**************************************************************************************** +! Bucket calculations for surface. +! + INCLUDE "clesphys.h" + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: pref + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol + REAL, DIMENSION(klon) :: alb_neig, alb_lim + REAL, DIMENSION(klon) :: zfra + REAL, DIMENSION(klon) :: radsol ! total net radiance at surface + REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay + REAL, DIMENSION(klon) :: dummy_riverflow,dummy_coastalflow + INTEGER :: i +! +!**************************************************************************************** + + +! +!* Read from limit.nc : albedo(alb_lim), length of rugosity(z0_new) +! + CALL limit_read_rug_alb(itime, dtime, jour,& + knon, knindex, & + z0_new, alb_lim) +! +!* Calcultaion of fluxes +! + +! calculate total absorbed radiance at surface + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +! calculate constants + CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd) + +! calculate temperature, heat capacity and conduction flux in soil + IF (soil_model) THEN + CALL soil(dtime, is_ter, knon, snow, tsurf, tsoil, soilcap, soilflux) + DO i=1, knon + cal(i) = RCPD / soilcap(i) + radsol(i) = radsol(i) + soilflux(i) + END DO + ELSE + cal(:) = RCPD * capsol(:) + ENDIF + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_ter, dtime, & + tsurf, p1lay, cal, beta, tq_cdrag, pref, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + petAcoef, peqAcoef, petBcoef, peqBcoef, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + +! +!* Calculate snow height, run_off, age of snow +! + CALL fonte_neige( knon, is_ter, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) +! +!* Calculate the age of snow +! + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + + DO i=1, knon + zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0))) + alb_lim(i) = alb_neig(i) *zfra(i) + alb_lim(i)*(1.0-zfra(i)) + END DO + +! +!* Return albedo : +! alb1_new and alb2_new are here given the same values +! + alb1_new(:) = 0.0 + alb2_new(:) = 0.0 + alb1_new(1:knon) = alb_lim(1:knon) + alb2_new(1:knon) = alb_lim(1:knon) + +! +!* Calculate the rugosity +! + DO i = 1, knon + z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2)) + END DO + +!* Send to coupler +! The run-off from river and coast are not calculated in the bucket modele. +! For testing purpose of the coupled modele we put the run-off to zero. + IF (type_ocean=='couple') THEN + dummy_riverflow(:) = 0.0 + dummy_coastalflow(:) = 0.0 + CALL cpl_send_land_fields(itime, knon, knindex, & + dummy_riverflow, dummy_coastalflow) + ENDIF + +! +!* End +! + END SUBROUTINE surf_land_bucket +! +!**************************************************************************************** +! +END MODULE surf_land_bucket_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_mod.F90 (revision 1634) @@ -0,0 +1,178 @@ +! +MODULE surf_land_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, & + rlon, rlat, & + debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + pref, u1, v1, rugoro, pctsrf, & + lwdown_m, q2m, t2m, & + snow, qsol, agesno, tsoil, & + z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, & + qsurf, tsurf_new, dflux_s, dflux_l, & + flux_u1, flux_v1 ) + + USE dimphy + USE surface_data, ONLY : ok_veget + +#ifdef ORCHIDEE_NOOPENMP + USE surf_land_orchidee_noopenmp_mod +#else + USE surf_land_orchidee_mod +#endif + USE surf_land_bucket_mod + USE calcul_fluxs_mod + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: date0 + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + LOGICAL, INTENT(IN) :: debut, lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: zlev, ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet + REAL, DIMENSION(klon), INTENT(IN) :: albedo ! albedo for whole short-wave interval + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: pref ! pressure reference + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: lwdown_m ! downwelling longwave radiation at mean surface + ! corresponds to previous sollwdown + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! albdeo for shortwave interval 1(visible) + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! albedo for shortwave interval 2(near infrared) + REAL, DIMENSION(klon), INTENT(OUT) :: evap + REAL, DIMENSION(klon), INTENT(OUT) :: fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 ! flux for U and V at first model level + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: p1lay_tmp + REAL, DIMENSION(klon) :: pref_tmp + REAL, DIMENSION(klon) :: swdown ! downwelling shortwave radiation at land surface + REAL, DIMENSION(klon) :: lwdown ! downwelling longwave radiation at land surface + REAL, DIMENSION(klon) :: epot_air ! potential air temperature + REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used + REAL, DIMENSION(klon) :: u0, v0 ! surface speed + INTEGER :: i + + +!**************************************************************************************** +! Choice between call to vegetation model (ok_veget=true) or simple calculation below +! +!**************************************************************************************** + IF (ok_veget) THEN +!**************************************************************************************** +! Call model sechiba in model ORCHIDEE +! +!**************************************************************************************** + p1lay_tmp(:) = 0.0 + pref_tmp(:) = 0.0 + p1lay_tmp(1:knon) = p1lay(1:knon)/100. + pref_tmp(1:knon) = pref(1:knon)/100. +! +!* Calculate incoming flux for SW and LW interval: swdown, lwdown +! + swdown(:) = 0.0 + lwdown(:) = 0.0 + DO i = 1, knon + swdown(i) = swnet(i)/(1-albedo(i)) + lwdown(i) = lwnet(i) + RSIGMA*tsurf(i)**4 + END DO +! +!* Calculate potential air temperature +! + epot_air(:) = 0.0 + DO i = 1, knon + epot_air(i) = RCPD*temp_air(i)*(pref(i)/p1lay(i))**RKAPPA + END DO + + ! temporary for keeping same results using lwdown_m instead of lwdown + CALL surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, pctsrf, & + debut, lafin, & + zlev, u1, v1, temp_air, spechum, epot_air, ccanopy, & + cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, & + precip_rain, precip_snow, lwdown_m, swnet, swdown, & + pref_tmp, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0_new, qsurf) + +! +!* Add contribution of relief to surface roughness +! + DO i=1,knon + z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2)) + ENDDO + + ELSE ! not ok_veget +!**************************************************************************************** +! No extern vegetation model choosen, call simple bucket calculations instead. +! +!**************************************************************************************** + CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,& + tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, & + spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, & + u1, v1, rugoro, swnet, lwnet, & + snow, qsol, agesno, tsoil, & + qsurf, z0_new, alb1_new, alb2_new, evap, & + fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l) + + ENDIF ! ok_veget + +!**************************************************************************************** +! Calculation for all land models +! - Flux calculation at first modele level for U and V +!**************************************************************************************** +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + + END SUBROUTINE surf_land +! +!**************************************************************************************** +! +END MODULE surf_land_mod +! +!**************************************************************************************** +! Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_orchidee_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_orchidee_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_orchidee_mod.F90 (revision 1634) @@ -0,0 +1,649 @@ +! +MODULE surf_land_orchidee_mod +#ifndef ORCHIDEE_NOOPENMP +! +! This module controles the interface towards the model ORCHIDEE +! +! Subroutines in this module : surf_land_orchidee +! Init_orchidee_index +! Get_orchidee_communicator +! Init_neighbours + + USE dimphy +#ifdef CPP_VEGET + USE intersurf ! module d'ORCHIDEE +#endif + USE cpl_mod, ONLY : cpl_send_land_fields + USE surface_data, ONLY : type_ocean + USE comgeomphy, ONLY : cuphy, cvphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para, mpi_root_rank=>mpi_root + + IMPLICIT NONE + + PRIVATE + PUBLIC :: surf_land_orchidee + + LOGICAL, ALLOCATABLE, SAVE :: flag_omp(:) +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, pctsrf, & + debut, lafin, & + plev, u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & + tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + precip_rain, precip_snow, lwdown, swnet, swdown, & + ps, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0_new, qsurf) + + USE mod_surf_para + USE mod_synchro_omp + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl + +! +! Cette routine sert d'interface entre le modele atmospherique et le +! modele de sol continental. Appel a sechiba +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! dtime pas de temps de la physique (en s) +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points de la surface a traiter +! knindex index des points de la surface a traiter +! rlon longitudes de la grille entiere +! rlat latitudes de la grille entiere +! pctsrf tableau des fractions de surface de chaque maille +! debut logical: 1er appel a la physique (lire les restart) +! lafin logical: dernier appel a la physique (ecrire les restart) +! (si false calcul simplifie des fluxs sur les continents) +! plev hauteur de la premiere couche (Pa) +! u1_lay vitesse u 1ere couche +! v1_lay vitesse v 1ere couche +! temp_air temperature de l'air 1ere couche +! spechum humidite specifique 1ere couche +! epot_air temp pot de l'air +! ccanopy concentration CO2 canopee, correspond au co2_send de +! carbon_cycle_mod ou valeur constant co2_ppm +! tq_cdrag cdrag +! petAcoef coeff. A de la resolution de la CL pour t +! peqAcoef coeff. A de la resolution de la CL pour q +! petBcoef coeff. B de la resolution de la CL pour t +! peqBcoef coeff. B de la resolution de la CL pour q +! precip_rain precipitation liquide +! precip_snow precipitation solide +! lwdown flux IR descendant a la surface +! swnet flux solaire net +! swdown flux solaire entrant a la surface +! ps pression au sol +! radsol rayonnement net aus sol (LW + SW) +! +! +! output: +! evap evaporation totale +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! tsol_rad +! tsurf_new temperature au sol +! alb1_new albedo in visible SW interval +! alb2_new albedo in near IR interval +! emis_new emissivite +! z0_new surface roughness +! qsurf air moisture at surface +! + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + INCLUDE "dimensions.h" + +! +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, INTENT(IN) :: dtime + REAL, INTENT(IN) :: date0 + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut, lafin + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: plev + REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m + +! Parametres de sortie +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0_new + +! Local +!**************************************************************************************** + INTEGER :: ij, jj, igrid, ireal, index + INTEGER :: error + REAL, DIMENSION(klon) :: swdown_vrai + CHARACTER (len = 20) :: modname = 'surf_land_orchidee' + CHARACTER (len = 80) :: abort_message + LOGICAL,SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + +! type de couplage dans sechiba +! character (len=10) :: coupling = 'implicit' +! drapeaux controlant les appels dans SECHIBA +! type(control_type), save :: control_in +! Preserved albedo + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev + !$OMP THREADPRIVATE(albedo_keep,zlev) +! coordonnees geographiques + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo + !$OMP THREADPRIVATE(lalo) +! pts voisins + INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours + !$OMP THREADPRIVATE(neighbours) +! fractions continents + REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac + !$OMP THREADPRIVATE(contfrac) +! resolution de la grille + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution + !$OMP THREADPRIVATE(resolution) + + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat + !$OMP THREADPRIVATE(lon_scat,lat_scat) + + LOGICAL, SAVE :: lrestart_read = .TRUE. + !$OMP THREADPRIVATE(lrestart_read) + LOGICAL, SAVE :: lrestart_write = .FALSE. + !$OMP THREADPRIVATE(lrestart_write) + + REAL, DIMENSION(knon,2) :: albedo_out + +! Pb de nomenclature + REAL, DIMENSION(klon) :: petA_orc, peqA_orc + REAL, DIMENSION(klon) :: petB_orc, peqB_orc +! Pb de correspondances de grilles + INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg + !$OMP THREADPRIVATE(ig,jg) + INTEGER :: indi, indj + INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex + !$OMP THREADPRIVATE(ktindex) + +! Essai cdrag + REAL, DIMENSION(klon) :: cdrag + INTEGER,SAVE :: offset + !$OMP THREADPRIVATE(offset) + + REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g + INTEGER, SAVE :: orch_comm + !$OMP THREADPRIVATE(orch_comm) + + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow + !$OMP THREADPRIVATE(coastalflow) + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow + !$OMP THREADPRIVATE(riverflow) + + INTEGER :: orch_omp_rank + INTEGER :: orch_omp_size +! +! Fin definition +!**************************************************************************************** + + IF (check) WRITE(lunout,*)'Entree ', modname + +! Initialisation + + IF (debut) THEN +! Test of coherence between variable ok_veget and cpp key CPP_VEGET +#ifndef CPP_VEGET + abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.' + CALL abort_gcm(modname,abort_message,1) +#endif + + CALL Init_surf_para(knon) + ALLOCATE(ktindex(knon)) + IF ( .NOT. ALLOCATED(albedo_keep)) THEN +!ym ALLOCATE(albedo_keep(klon)) +!ym bizarre que non alloué en knon precedement + ALLOCATE(albedo_keep(knon)) + ALLOCATE(zlev(knon)) + ENDIF +! Pb de correspondances de grilles + ALLOCATE(ig(klon)) + ALLOCATE(jg(klon)) + ig(1) = 1 + jg(1) = 1 + indi = 0 + indj = 2 + DO igrid = 2, klon - 1 + indi = indi + 1 + IF ( indi > iim) THEN + indi = 1 + indj = indj + 1 + ENDIF + ig(igrid) = indi + jg(igrid) = indj + ENDDO + ig(klon) = 1 + jg(klon) = jjm + 1 + + IF ((.NOT. ALLOCATED(lalo))) THEN + ALLOCATE(lalo(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lalo' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lon_scat))) THEN + ALLOCATE(lon_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lon_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lat_scat))) THEN + ALLOCATE(lat_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lat_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + lon_scat = 0. + lat_scat = 0. + DO igrid = 1, knon + index = knindex(igrid) + lalo(igrid,2) = rlon(index) + lalo(igrid,1) = rlat(index) + ENDDO + + + + CALL Gather(rlon,rlon_g) + CALL Gather(rlat,rlat_g) + + IF (is_mpi_root) THEN + index = 1 + DO jj = 2, jjm + DO ij = 1, iim + index = index + 1 + lon_scat(ij,jj) = rlon_g(index) + lat_scat(ij,jj) = rlat_g(index) + ENDDO + ENDDO + lon_scat(:,1) = lon_scat(:,2) + lat_scat(:,1) = rlat_g(1) + lon_scat(:,jjm+1) = lon_scat(:,2) + lat_scat(:,jjm+1) = rlat_g(klon_glo) + ENDIF + + CALL bcast(lon_scat) + CALL bcast(lat_scat) +! +! Allouer et initialiser le tableau des voisins et des fraction de continents +! + IF ( (.NOT.ALLOCATED(neighbours))) THEN + ALLOCATE(neighbours(knon,8), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation neighbours' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + neighbours = -1. + IF (( .NOT. ALLOCATED(contfrac))) THEN + ALLOCATE(contfrac(knon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation contfrac' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + DO igrid = 1, knon + ireal = knindex(igrid) + contfrac(igrid) = pctsrf(ireal,is_ter) + ENDDO + + + CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter)) + +! +! Allocation et calcul resolutions + IF ( (.NOT.ALLOCATED(resolution))) THEN + ALLOCATE(resolution(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation resolution' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + DO igrid = 1, knon + ij = knindex(igrid) + resolution(igrid,1) = cuphy(ij) + resolution(igrid,2) = cvphy(ij) + ENDDO + + ALLOCATE(coastalflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation coastalflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + ALLOCATE(riverflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation riverflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF +! +! carbon_cycle_cpl not possible with this interface and version of ORHCHIDEE +! + IF (carbon_cycle_cpl) THEN + abort_message='carbon_cycle_cpl not yet possible with this interface of ORCHIDEE' + CALL abort_gcm(modname,abort_message,1) + END IF + + ENDIF ! (fin debut) + + +! +! Appel a la routine sols continentaux +! + IF (lafin) lrestart_write = .TRUE. + IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write + + petA_orc(1:knon) = petBcoef(1:knon) * dtime + petB_orc(1:knon) = petAcoef(1:knon) + peqA_orc(1:knon) = peqBcoef(1:knon) * dtime + peqB_orc(1:knon) = peqAcoef(1:knon) + + cdrag = 0. + cdrag(1:knon) = tq_cdrag(1:knon) + +! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665) + zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG) + + +! PF et PASB +! where(cdrag > 0.01) +! cdrag = 0.01 +! endwhere +! write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag) + + + IF (debut) THEN + CALL Init_orchidee_index(knon,knindex,offset,ktindex) + CALL Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank) + CALL Init_synchro_omp + + IF (knon > 0) THEN +#ifdef CPP_VEGET + CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm) +#endif + ENDIF + + + IF (knon > 0) THEN + +#ifdef CPP_VEGET + CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & + cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & + precip_rain, precip_snow, lwdown, swnet, swdown, ps, & + evap, fluxsens, fluxlat, coastalflow, riverflow, & + tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & + lon_scat, lat_scat, q2m, t2m) +#endif + ENDIF + + CALL Synchro_omp + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + + ENDIF + + +! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) + swdown_vrai(1:knon) = swdown(1:knon) + + IF (knon > 0) THEN +#ifdef CPP_VEGET + CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), & + cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), & + precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), & + evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & + tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), & + lon_scat, lat_scat, q2m, t2m) +#endif + ENDIF + + CALL Synchro_omp + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + +!* Send to coupler +! + IF (type_ocean=='couple') THEN + CALL cpl_send_land_fields(itime, knon, knindex, & + riverflow, coastalflow) + ENDIF + + alb1_new(1:knon) = albedo_out(1:knon,1) + alb2_new(1:knon) = albedo_out(1:knon,2) + +! Convention orchidee: positif vers le haut + fluxsens(1:knon) = -1. * fluxsens(1:knon) + fluxlat(1:knon) = -1. * fluxlat(1:knon) + +! evap = -1. * evap + + IF (debut) lrestart_read = .FALSE. + + IF (debut) CALL Finalize_surf_para + + + END SUBROUTINE surf_land_orchidee +! +!**************************************************************************************** +! + SUBROUTINE Init_orchidee_index(knon,knindex,offset,ktindex) + USE mod_surf_para + USE mod_grid_phy_lmdz + + INTEGER,INTENT(IN) :: knon + INTEGER,INTENT(IN) :: knindex(klon) + INTEGER,INTENT(OUT) :: offset + INTEGER,INTENT(OUT) :: ktindex(klon) + + INTEGER :: ktindex_glo(knon_glo) + INTEGER :: offset_para(0:omp_size*mpi_size-1) + INTEGER :: LastPoint + INTEGER :: task + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1 + + CALL gather_surf(ktindex(1:knon),ktindex_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + LastPoint=0 + DO Task=0,mpi_size*omp_size-1 + IF (knon_glo_para(Task)>0) THEN + offset_para(task)= LastPoint-MOD(LastPoint,nbp_lon) + LastPoint=ktindex_glo(knon_glo_end_para(task)) + ENDIF + ENDDO + ENDIF + + CALL bcast(offset_para) + + offset=offset_para(omp_size*mpi_rank+omp_rank) + + ktindex(1:knon)=ktindex(1:knon)-offset + + END SUBROUTINE Init_orchidee_index + +! +!************************* *************************************************************** +! + + SUBROUTINE Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank) + USE mod_surf_para + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + INTEGER,INTENT(OUT) :: orch_comm + INTEGER,INTENT(OUT) :: orch_omp_size + INTEGER,INTENT(OUT) :: orch_omp_rank + INTEGER :: color + INTEGER :: i,ierr +! +! End definition +!**************************************************************************************** + + + IF (is_omp_root) THEN + + IF (knon_mpi==0) THEN + color = 0 + ELSE + color = 1 + ENDIF + +#ifdef CPP_MPI + CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr) +#endif + + ENDIF + CALL bcast_omp(orch_comm) + + IF (knon_mpi /= 0) THEN + orch_omp_size=0 + DO i=0,omp_size-1 + IF (knon_omp_para(i) /=0) THEN + orch_omp_size=orch_omp_size+1 + IF (i==omp_rank) orch_omp_rank=orch_omp_size-1 + ENDIF + ENDDO + ENDIF + + + END SUBROUTINE Get_orchidee_communicator +! +!**************************************************************************************** +! + + SUBROUTINE Init_neighbours(knon,neighbours,knindex,pctsrf) + USE mod_grid_phy_lmdz + USE mod_surf_para + INCLUDE "indicesol.h" + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, DIMENSION(klon), INTENT(IN) :: pctsrf + +! Output arguments +!**************************************************************************************** + INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours + +! Local variables +!**************************************************************************************** + INTEGER :: i, igrid, jj, ij, iglob + INTEGER :: ierr, ireal, index + INTEGER, DIMENSION(8,3) :: off_ini + INTEGER, DIMENSION(8) :: offset + INTEGER, DIMENSION(nbp_lon,nbp_lat) :: correspond + INTEGER, DIMENSION(knon_glo) :: ktindex_glo + INTEGER, DIMENSION(knon_glo,8) :: neighbours_glo + REAL, DIMENSION(klon_glo) :: pctsrf_glo + INTEGER :: ktindex(klon) +! +! End definition +!**************************************************************************************** + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1 + + CALL gather_surf(ktindex(1:knon),ktindex_glo) + CALL gather(pctsrf,pctsrf_glo) + + IF (is_mpi_root .AND. is_omp_root) THEN + neighbours_glo(:,:)=-1 +! Initialisation des offset +! +! offset bord ouest + off_ini(1,1) = - nbp_lon ; off_ini(2,1) = - nbp_lon + 1 ; off_ini(3,1) = 1 + off_ini(4,1) = nbp_lon + 1 ; off_ini(5,1) = nbp_lon ; off_ini(6,1) = 2 * nbp_lon - 1 + off_ini(7,1) = nbp_lon -1 ; off_ini(8,1) = - 1 +! offset point normal + off_ini(1,2) = - nbp_lon ; off_ini(2,2) = - nbp_lon + 1 ; off_ini(3,2) = 1 + off_ini(4,2) = nbp_lon + 1 ; off_ini(5,2) = nbp_lon ; off_ini(6,2) = nbp_lon - 1 + off_ini(7,2) = -1 ; off_ini(8,2) = - nbp_lon - 1 +! offset bord est + off_ini(1,3) = - nbp_lon ; off_ini(2,3) = - 2 * nbp_lon + 1 ; off_ini(3,3) = - nbp_lon + 1 + off_ini(4,3) = 1 ; off_ini(5,3) = nbp_lon ; off_ini(6,3) = nbp_lon - 1 + off_ini(7,3) = -1 ; off_ini(8,3) = - nbp_lon - 1 +! +! +! Attention aux poles +! + DO igrid = 1, knon_glo + index = ktindex_glo(igrid) + jj = INT((index - 1)/nbp_lon) + 1 + ij = index - (jj - 1) * nbp_lon + correspond(ij,jj) = igrid + ENDDO + + DO igrid = 1, knon_glo + iglob = ktindex_glo(igrid) + + IF (MOD(iglob, nbp_lon) == 1) THEN + offset = off_ini(:,1) + ELSE IF(MOD(iglob, nbp_lon) == 0) THEN + offset = off_ini(:,3) + ELSE + offset = off_ini(:,2) + ENDIF + + DO i = 1, 8 + index = iglob + offset(i) + ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo)) + IF (pctsrf_glo(ireal) > EPSFRA) THEN + jj = INT((index - 1)/nbp_lon) + 1 + ij = index - (jj - 1) * nbp_lon + neighbours_glo(igrid, i) = correspond(ij, jj) + ENDIF + ENDDO + ENDDO + + ENDIF + + DO i = 1, 8 + CALL scatter_surf(neighbours_glo(:,i),neighbours(1:knon,i)) + ENDDO + END SUBROUTINE Init_neighbours + +! +!**************************************************************************************** +! +#endif +END MODULE surf_land_orchidee_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_land_orchidee_noopenmp_mod.F90 (revision 1634) @@ -0,0 +1,780 @@ +! +! $Header$ +! +MODULE surf_land_orchidee_noopenmp_mod +! +! This module is compiled only if CPP key ORCHIDEE_NOOPENMP is defined. +! This module should be used with ORCHIDEE sequentiel or parallele MPI version (not MPI-OpenMP mixte) + +#ifdef ORCHIDEE_NOOPENMP +! +! This module controles the interface towards the model ORCHIDEE +! +! Subroutines in this module : surf_land_orchidee +! Init_orchidee_index +! Get_orchidee_communicator +! Init_neighbours + USE dimphy +#ifdef CPP_VEGET + USE intersurf ! module d'ORCHIDEE +#endif + USE cpl_mod, ONLY : cpl_send_land_fields + USE surface_data, ONLY : type_ocean + USE comgeomphy, ONLY : cuphy, cvphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + + IMPLICIT NONE + + PRIVATE + PUBLIC :: surf_land_orchidee + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, & + knindex, rlon, rlat, pctsrf, & + debut, lafin, & + plev, u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & + tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & + precip_rain, precip_snow, lwdown, swnet, swdown, & + ps, q2m, t2m, & + evap, fluxsens, fluxlat, & + tsol_rad, tsurf_new, alb1_new, alb2_new, & + emis_new, z0_new, qsurf) +! +! Cette routine sert d'interface entre le modele atmospherique et le +! modele de sol continental. Appel a sechiba +! +! L. Fairhead 02/2000 +! +! input: +! itime numero du pas de temps +! dtime pas de temps de la physique (en s) +! nisurf index de la surface a traiter (1 = sol continental) +! knon nombre de points de la surface a traiter +! knindex index des points de la surface a traiter +! rlon longitudes de la grille entiere +! rlat latitudes de la grille entiere +! pctsrf tableau des fractions de surface de chaque maille +! debut logical: 1er appel a la physique (lire les restart) +! lafin logical: dernier appel a la physique (ecrire les restart) +! (si false calcul simplifie des fluxs sur les continents) +! plev hauteur de la premiere couche (Pa) +! u1_lay vitesse u 1ere couche +! v1_lay vitesse v 1ere couche +! temp_air temperature de l'air 1ere couche +! spechum humidite specifique 1ere couche +! epot_air temp pot de l'air +! ccanopy concentration CO2 canopee, correspond au co2_send de +! carbon_cycle_mod ou valeur constant co2_ppm +! tq_cdrag cdrag +! petAcoef coeff. A de la resolution de la CL pour t +! peqAcoef coeff. A de la resolution de la CL pour q +! petBcoef coeff. B de la resolution de la CL pour t +! peqBcoef coeff. B de la resolution de la CL pour q +! precip_rain precipitation liquide +! precip_snow precipitation solide +! lwdown flux IR descendant a la surface +! swnet flux solaire net +! swdown flux solaire entrant a la surface +! ps pression au sol +! radsol rayonnement net aus sol (LW + SW) +! +! +! output: +! evap evaporation totale +! fluxsens flux de chaleur sensible +! fluxlat flux de chaleur latente +! tsol_rad +! tsurf_new temperature au sol +! alb1_new albedo in visible SW interval +! alb2_new albedo in near IR interval +! emis_new emissivite +! z0_new surface roughness +! qsurf air moisture at surface +! + USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_land_inst, fco2_lu_inst + IMPLICIT NONE + + INCLUDE "indicesol.h" + INCLUDE "temps.h" + INCLUDE "YOMCST.h" + INCLUDE "iniprint.h" + INCLUDE "dimensions.h" + +! +! Parametres d'entree +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime + REAL, INTENT(IN) :: dtime + REAL, INTENT(IN) :: date0 + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: debut, lafin + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: plev + REAL, DIMENSION(klon), INTENT(IN) :: u1_lay, v1_lay + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: epot_air, ccanopy + REAL, DIMENSION(klon), INTENT(IN) :: tq_cdrag + REAL, DIMENSION(klon), INTENT(IN) :: petAcoef, peqAcoef + REAL, DIMENSION(klon), INTENT(IN) :: petBcoef, peqBcoef + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: lwdown, swnet, swdown, ps + REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m + +! Parametres de sortie +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat, qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: tsol_rad, tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new, alb2_new + REAL, DIMENSION(klon), INTENT(OUT) :: emis_new, z0_new + +! Local +!**************************************************************************************** + INTEGER :: ij, jj, igrid, ireal, index + INTEGER :: error + INTEGER, SAVE :: nb_fields_cpl ! number of fields for the climate-carbon coupling (between ATM and ORCHIDEE). + REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: fields_cpl ! Fluxes for the climate-carbon coupling + REAL, DIMENSION(klon) :: swdown_vrai + CHARACTER (len = 20) :: modname = 'surf_land_orchidee' + CHARACTER (len = 80) :: abort_message + LOGICAL,SAVE :: check = .FALSE. + !$OMP THREADPRIVATE(check) + +! type de couplage dans sechiba +! character (len=10) :: coupling = 'implicit' +! drapeaux controlant les appels dans SECHIBA +! type(control_type), save :: control_in +! Preserved albedo + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: albedo_keep, zlev + !$OMP THREADPRIVATE(albedo_keep,zlev) +! coordonnees geographiques + REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo + !$OMP THREADPRIVATE(lalo) +! pts voisins + INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours + !$OMP THREADPRIVATE(neighbours) +! fractions continents + REAL,ALLOCATABLE, DIMENSION(:), SAVE :: contfrac + !$OMP THREADPRIVATE(contfrac) +! resolution de la grille + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution + !$OMP THREADPRIVATE(resolution) + + REAL, ALLOCATABLE, DIMENSION (:,:), SAVE :: lon_scat, lat_scat + !$OMP THREADPRIVATE(lon_scat,lat_scat) + + LOGICAL, SAVE :: lrestart_read = .TRUE. + !$OMP THREADPRIVATE(lrestart_read) + LOGICAL, SAVE :: lrestart_write = .FALSE. + !$OMP THREADPRIVATE(lrestart_write) + + REAL, DIMENSION(knon,2) :: albedo_out + !$OMP THREADPRIVATE(albedo_out) + +! Pb de nomenclature + REAL, DIMENSION(klon) :: petA_orc, peqA_orc + REAL, DIMENSION(klon) :: petB_orc, peqB_orc +! Pb de correspondances de grilles + INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: ig, jg + !$OMP THREADPRIVATE(ig,jg) + INTEGER :: indi, indj + INTEGER, SAVE, ALLOCATABLE,DIMENSION(:) :: ktindex + !$OMP THREADPRIVATE(ktindex) + +! Essai cdrag + REAL, DIMENSION(klon) :: cdrag + INTEGER,SAVE :: offset + !$OMP THREADPRIVATE(offset) + + REAL, DIMENSION(klon_glo) :: rlon_g,rlat_g + INTEGER, SAVE :: orch_comm + !$OMP THREADPRIVATE(orch_comm) + + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: coastalflow + !$OMP THREADPRIVATE(coastalflow) + REAL, ALLOCATABLE, DIMENSION(:), SAVE :: riverflow + !$OMP THREADPRIVATE(riverflow) +! +! Fin definition +!**************************************************************************************** +#ifdef CPP_VEGET + + IF (check) WRITE(lunout,*)'Entree ', modname + +! Initialisation + + IF (debut) THEN +! Test de coherence +#ifndef ORCH_NEW + ! Compilation avec orchidee nouvelle version necessaire avec carbon_cycle_cpl=y + IF (carbon_cycle_cpl) THEN + abort_message='You must define preprossing key ORCH_NEW when running carbon_cycle_cpl=y' + CALL abort_gcm(modname,abort_message,1) + END IF +#endif + ALLOCATE(ktindex(knon)) + IF ( .NOT. ALLOCATED(albedo_keep)) THEN + ALLOCATE(albedo_keep(klon)) + ALLOCATE(zlev(knon)) + ENDIF +! Pb de correspondances de grilles + ALLOCATE(ig(klon)) + ALLOCATE(jg(klon)) + ig(1) = 1 + jg(1) = 1 + indi = 0 + indj = 2 + DO igrid = 2, klon - 1 + indi = indi + 1 + IF ( indi > iim) THEN + indi = 1 + indj = indj + 1 + ENDIF + ig(igrid) = indi + jg(igrid) = indj + ENDDO + ig(klon) = 1 + jg(klon) = jjm + 1 + + IF ((.NOT. ALLOCATED(lalo))) THEN + ALLOCATE(lalo(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lalo' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lon_scat))) THEN + ALLOCATE(lon_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lon_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + IF ((.NOT. ALLOCATED(lat_scat))) THEN + ALLOCATE(lat_scat(iim,jjm+1), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation lat_scat' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + lon_scat = 0. + lat_scat = 0. + DO igrid = 1, knon + index = knindex(igrid) + lalo(igrid,2) = rlon(index) + lalo(igrid,1) = rlat(index) + ENDDO + + + + CALL Gather(rlon,rlon_g) + CALL Gather(rlat,rlat_g) + + IF (is_mpi_root) THEN + index = 1 + DO jj = 2, jjm + DO ij = 1, iim + index = index + 1 + lon_scat(ij,jj) = rlon_g(index) + lat_scat(ij,jj) = rlat_g(index) + ENDDO + ENDDO + lon_scat(:,1) = lon_scat(:,2) + lat_scat(:,1) = rlat_g(1) + lon_scat(:,jjm+1) = lon_scat(:,2) + lat_scat(:,jjm+1) = rlat_g(klon_glo) + ENDIF + + CALL bcast(lon_scat) + CALL bcast(lat_scat) + +! +! Allouer et initialiser le tableau des voisins et des fraction de continents +! + IF ( (.NOT.ALLOCATED(neighbours))) THEN + ALLOCATE(neighbours(knon,8), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation neighbours' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + neighbours = -1. + IF (( .NOT. ALLOCATED(contfrac))) THEN + ALLOCATE(contfrac(knon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation contfrac' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + + DO igrid = 1, knon + ireal = knindex(igrid) + contfrac(igrid) = pctsrf(ireal,is_ter) + ENDDO + + + CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter)) + +! +! Allocation et calcul resolutions + IF ( (.NOT.ALLOCATED(resolution))) THEN + ALLOCATE(resolution(knon,2), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation resolution' + CALL abort_gcm(modname,abort_message,1) + ENDIF + ENDIF + DO igrid = 1, knon + ij = knindex(igrid) + resolution(igrid,1) = cuphy(ij) + resolution(igrid,2) = cvphy(ij) + ENDDO + + ALLOCATE(coastalflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation coastalflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF + + ALLOCATE(riverflow(klon), stat = error) + IF (error /= 0) THEN + abort_message='Pb allocation riverflow' + CALL abort_gcm(modname,abort_message,1) + ENDIF + +! +! Allocate variables needed for carbon_cycle_mod + IF ( carbon_cycle_cpl ) THEN + nb_fields_cpl=2 + ELSE + nb_fields_cpl=1 + END IF + + + IF (carbon_cycle_cpl) THEN + ALLOCATE(fco2_land_inst(klon),stat=error) + IF (error /= 0) CALL abort_gcm(modname,'Pb in allocation fco2_land_inst',1) + + ALLOCATE(fco2_lu_inst(klon),stat=error) + IF(error /=0) CALL abort_gcm(modname,'Pb in allocation fco2_lu_inst',1) + END IF + + ALLOCATE(fields_cpl(klon,nb_fields_cpl), stat = error) + IF (error /= 0) CALL abort_gcm(modname,'Pb in allocation fields_cpl',1) + + ENDIF ! (fin debut) + +! +! Appel a la routine sols continentaux +! + IF (lafin) lrestart_write = .TRUE. + IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write + + petA_orc(1:knon) = petBcoef(1:knon) * dtime + petB_orc(1:knon) = petAcoef(1:knon) + peqA_orc(1:knon) = peqBcoef(1:knon) * dtime + peqB_orc(1:knon) = peqAcoef(1:knon) + + cdrag = 0. + cdrag(1:knon) = tq_cdrag(1:knon) + +! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665) + zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG) + + +! PF et PASB +! where(cdrag > 0.01) +! cdrag = 0.01 +! endwhere +! write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag) + +! +! Init Orchidee +! +! if (pole_nord) then +! offset=0 +! ktindex(:)=ktindex(:)+iim-1 +! else +! offset = klon_mpi_begin-1+iim-1 +! ktindex(:)=ktindex(:)+MOD(offset,iim) +! offset=offset-MOD(offset,iim) +! endif + + IF (debut) THEN + CALL Get_orchidee_communicator(knon,orch_comm) + IF (knon /=0) THEN + CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex) + +#ifndef CPP_MPI + ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & + cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & + precip_rain, precip_snow, lwdown, swnet, swdown, ps, & + evap, fluxsens, fluxlat, coastalflow, riverflow, & + tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & + lon_scat, lat_scat, q2m, t2m & +#ifdef ORCH_NEW + , nb_fields_cpl, fields_cpl) +#else + ) +#endif + +#else + ! Interface for ORCHIDEE version 1.9 or later(1.9.2, 1.9.3, 1.9.4, 1.9.5) compiled in parallel mode(with preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, offset, knon, ktindex, & + orch_comm, dtime, lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), & + cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), & + precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), & + evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & + tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), & + lon_scat, lat_scat, q2m, t2m & +#ifdef ORCH_NEW + , nb_fields_cpl, fields_cpl(1:knon,:)) +#else + ) +#endif +#endif + + ENDIF + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + + ENDIF + +! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) + swdown_vrai(1:knon) = swdown(1:knon) + + IF (knon /=0) THEN +#ifndef CPP_MPI + ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, & + lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & + cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & + precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, & + evap, fluxsens, fluxlat, coastalflow, riverflow, & + tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & + lon_scat, lat_scat, q2m, t2m & +#ifdef ORCH_NEW + , nb_fields_cpl, fields_cpl) +#else + ) +#endif +#else + ! Interface for ORCHIDEE version 1.9 or later compiled in parallel mode(with preprocessing flag CPP_MPI) + CALL intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & + orch_comm,dtime, lrestart_read, lrestart_write, lalo, & + contfrac, neighbours, resolution, date0, & + zlev, u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), & + cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), & + precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), & + evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & + tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), & + lon_scat, lat_scat, q2m, t2m & +#ifdef ORCH_NEW + , nb_fields_cpl, fields_cpl(1:knon,:)) +#else + ) +#endif +#endif + ENDIF + + albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. + +!* Send to coupler +! + IF (type_ocean=='couple') THEN + CALL cpl_send_land_fields(itime, knon, knindex, & + riverflow, coastalflow) + ENDIF + + alb1_new(1:knon) = albedo_out(1:knon,1) + alb2_new(1:knon) = albedo_out(1:knon,2) + +! Convention orchidee: positif vers le haut + fluxsens(1:knon) = -1. * fluxsens(1:knon) + fluxlat(1:knon) = -1. * fluxlat(1:knon) + +! evap = -1. * evap + + IF (debut) lrestart_read = .FALSE. + +! Decompress variables for the module carbon_cycle_mod + IF (carbon_cycle_cpl) THEN + fco2_land_inst(:)=0. + fco2_lu_inst(:)=0. + + DO igrid = 1, knon + ireal = knindex(igrid) + fco2_land_inst(ireal) = fields_cpl(igrid,1) + fco2_lu_inst(ireal) = fields_cpl(igrid,2) + END DO + END IF + +#endif + END SUBROUTINE surf_land_orchidee +! +!**************************************************************************************** +! + SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex) + + INCLUDE "dimensions.h" + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, INTENT(IN) :: orch_comm + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + +! Output arguments +!**************************************************************************************** + INTEGER, INTENT(OUT) :: offset + INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex + +! Local varables +!**************************************************************************************** +#ifdef CPP_MPI + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status +#endif + + INTEGER :: MyLastPoint + INTEGER :: LastPoint + INTEGER :: mpi_rank_orch + INTEGER :: mpi_size_orch + INTEGER :: ierr +! +! End definition +!**************************************************************************************** + + MyLastPoint=klon_mpi_begin-1+knindex(knon)+iim-1 + + IF (is_parallel) THEN +#ifdef CPP_MPI + CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr) + CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr) +#endif + ELSE + mpi_rank_orch=0 + mpi_size_orch=1 + ENDIF + + IF (is_parallel) THEN + IF (mpi_rank_orch /= 0) THEN +#ifdef CPP_MPI + CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr) +#endif + ENDIF + + IF (mpi_rank_orch /= mpi_size_orch-1) THEN +#ifdef CPP_MPI + CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr) +#endif + ENDIF + ENDIF + + IF (mpi_rank_orch == 0) THEN + offset=0 + ELSE + offset=LastPoint-MOD(LastPoint,iim) + ENDIF + + ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+iim-1)-offset-1 + + + END SUBROUTINE Init_orchidee_index +! +!**************************************************************************************** +! + SUBROUTINE Get_orchidee_communicator(knon,orch_comm) + +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + + + INTEGER,INTENT(IN) :: knon + INTEGER,INTENT(OUT) :: orch_comm + + INTEGER :: color + INTEGER :: ierr +! +! End definition +!**************************************************************************************** + + IF (knon==0) THEN + color = 0 + ELSE + color = 1 + ENDIF + +#ifdef CPP_MPI + CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr) +#endif + + END SUBROUTINE Get_orchidee_communicator +! +!**************************************************************************************** +! + SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf) + + INCLUDE "indicesol.h" + INCLUDE "dimensions.h" +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: knon + INTEGER, DIMENSION(klon), INTENT(IN) :: ktindex + REAL, DIMENSION(klon), INTENT(IN) :: pctsrf + +! Output arguments +!**************************************************************************************** + INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours + +! Local variables +!**************************************************************************************** + INTEGER :: knon_g + INTEGER :: i, igrid, jj, ij, iglob + INTEGER :: ierr, ireal, index + INTEGER :: var_tmp + INTEGER, DIMENSION(0:mpi_size-1) :: knon_nb + INTEGER, DIMENSION(0:mpi_size-1) :: displs + INTEGER, DIMENSION(8,3) :: off_ini + INTEGER, DIMENSION(8) :: offset + INTEGER, DIMENSION(knon) :: ktindex_p + INTEGER, DIMENSION(iim,jjm+1) :: correspond + INTEGER, ALLOCATABLE, DIMENSION(:) :: ktindex_g + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g + REAL, DIMENSION(klon_glo) :: pctsrf_g + +! +! End definition +!**************************************************************************************** + + IF (is_sequential) THEN + knon_nb(:)=knon + ELSE + +#ifdef CPP_MPI + CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) +#endif + + ENDIF + + IF (is_mpi_root) THEN + knon_g=SUM(knon_nb(:)) + ALLOCATE(ktindex_g(knon_g)) + ALLOCATE(neighbours_g(knon_g,8)) + neighbours_g(:,:)=-1 + displs(0)=0 + DO i=1,mpi_size-1 + displs(i)=displs(i-1)+knon_nb(i-1) + ENDDO + ELSE + ALLOCATE(neighbours_g(1,8)) + ENDIF + + ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1 + + IF (is_sequential) THEN + ktindex_g(:)=ktindex_p(:) + ELSE + +#ifdef CPP_MPI + CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,& + displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) +#endif + + ENDIF + + CALL Gather(pctsrf,pctsrf_g) + + IF (is_mpi_root) THEN +! Initialisation des offset +! +! offset bord ouest + off_ini(1,1) = - iim ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1 + off_ini(4,1) = iim + 1; off_ini(5,1) = iim ; off_ini(6,1) = 2 * iim - 1 + off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1 +! offset point normal + off_ini(1,2) = - iim ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1 + off_ini(4,2) = iim + 1; off_ini(5,2) = iim ; off_ini(6,2) = iim - 1 + off_ini(7,2) = -1 ; off_ini(8,2) = - iim - 1 +! offset bord est + off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1 + off_ini(4,3) = 1 ; off_ini(5,3) = iim ; off_ini(6,3) = iim - 1 + off_ini(7,3) = -1 ; off_ini(8,3) = - iim - 1 +! +! +! Attention aux poles +! + DO igrid = 1, knon_g + index = ktindex_g(igrid) + jj = INT((index - 1)/iim) + 1 + ij = index - (jj - 1) * iim + correspond(ij,jj) = igrid + ENDDO + + DO igrid = 1, knon_g + iglob = ktindex_g(igrid) + IF (MOD(iglob, iim) == 1) THEN + offset = off_ini(:,1) + ELSE IF(MOD(iglob, iim) == 0) THEN + offset = off_ini(:,3) + ELSE + offset = off_ini(:,2) + ENDIF + DO i = 1, 8 + index = iglob + offset(i) + ireal = (MIN(MAX(1, index - iim + 1), klon_glo)) + IF (pctsrf_g(ireal) > EPSFRA) THEN + jj = INT((index - 1)/iim) + 1 + ij = index - (jj - 1) * iim + neighbours_g(igrid, i) = correspond(ij, jj) + ENDIF + ENDDO + ENDDO + + ENDIF + + DO i=1,8 + IF (is_sequential) THEN + neighbours(:,i)=neighbours_g(:,i) + ELSE +#ifdef CPP_MPI + IF (knon > 0) THEN + ! knon>0, scattter global field neighbours_g from master process to local process + CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) + ELSE + ! knon=0, no need to save the field for this process + CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,var_tmp,knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) + END IF +#endif + ENDIF + ENDDO + + END SUBROUTINE Init_neighbours +! +!**************************************************************************************** +! + +#endif +END MODULE surf_land_orchidee_noopenmp_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_landice_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_landice_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_landice_mod.F90 (revision 1634) @@ -0,0 +1,205 @@ +! +MODULE surf_landice_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_landice(itime, dtime, knon, knindex, & + swnet, lwnet, tsurf, p1lay, & + cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, rugoro, pctsrf, & + snow, qsurf, qsol, agesno, & + tsoil, z0_new, alb1, alb2, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, & + flux_u1, flux_v1) + + USE dimphy + USE surface_data, ONLY : type_ocean, calice, calsno + USE fonte_neige_mod, ONLY : fonte_neige, run_off_lic + USE cpl_mod, ONLY : cpl_send_landice_fields + USE calcul_fluxs_mod + USE phys_output_var_mod + + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + INCLUDE "YOMCST.h" + INCLUDE "clesphys.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, knon + INTEGER, DIMENSION(klon), INTENT(in) :: knindex + REAL, INTENT(in) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiance + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiance + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: qsurf + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1 ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2 ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + +! Local variables +!**************************************************************************************** + REAL, DIMENSION(klon) :: soilcap, soilflux + REAL, DIMENSION(klon) :: cal, beta, dif_grnd + REAL, DIMENSION(klon) :: zfra, alb_neig + REAL, DIMENSION(klon) :: radsol + REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay + INTEGER :: i,j + +! End definition +!**************************************************************************************** +! +! Initialize output variables + alb2(:) = 999999. + alb1(:) = 999999. + +!**************************************************************************************** +! Calculate total absorbed radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +!**************************************************************************************** +! Soil calculations +! +!**************************************************************************************** + IF (soil_model) THEN + CALL soil(dtime, is_lic, knon, snow, tsurf, tsoil, soilcap, soilflux) + cal(1:knon) = RCPD / soilcap(1:knon) + radsol(1:knon) = radsol(1:knon) + soilflux(1:knon) + ELSE + cal = RCPD * calice + WHERE (snow > 0.0) cal = RCPD * calsno + ENDIF + + +!**************************************************************************************** +! Calulate fluxes +! +!**************************************************************************************** + beta(:) = 1.0 + dif_grnd(:) = 0.0 + +! Suppose zero surface speed + u0(:)=0.0 + v0(:)=0.0 + u1_lay(:) = u1(:) - u0(:) + v1_lay(:) = v1(:) - v0(:) + + CALL calcul_fluxs(knon, is_lic, dtime, & + tsurf, p1lay, cal, beta, cdragh, ps, & + precip_rain, precip_snow, snow, qsurf, & + radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) + + CALL calcul_flux_wind(knon, dtime, & + u0, v0, u1, v1, cdragm, & + AcoefU, AcoefV, BcoefU, BcoefV, & + p1lay, temp_air, & + flux_u1, flux_v1) + +!**************************************************************************************** +! Calculate snow height, age, run-off,.. +! +!**************************************************************************************** + CALL fonte_neige( knon, is_lic, knindex, dtime, & + tsurf, precip_rain, precip_snow, & + snow, qsol, tsurf_new, evap) + + +!**************************************************************************************** +! Calculate albedo +! +!**************************************************************************************** + CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:)) + WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0. + zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0))) + alb1(1:knon) = alb_neig(1:knon)*zfra(1:knon) + & + 0.6 * (1.0-zfra(1:knon)) +! +!IM: plusieurs choix/tests sur l'albedo des "glaciers continentaux" +! alb1(1 : knon) = 0.6 !IM cf FH/GK +! alb1(1 : knon) = 0.82 +! alb1(1 : knon) = 0.77 !211003 Ksta0.77 +! alb1(1 : knon) = 0.8 !KstaTER0.8 & LMD_ARMIP5 +!IM: KstaTER0.77 & LMD_ARMIP6 + +! Attantion: alb1 and alb2 are the same! + alb1(1:knon) = 0.77 + alb2(1:knon) = alb1(1:knon) + + +!**************************************************************************************** +! Rugosity +! +!**************************************************************************************** + z0_new(:) = MAX(1.E-3,rugoro(:)) + +!**************************************************************************************** +! Send run-off on land-ice to coupler if coupled ocean. +! run_off_lic has been calculated in fonte_neige +! +!**************************************************************************************** + IF (type_ocean=='couple') THEN + CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic) + ENDIF + +!**************************************************************************************** + snow_o=0. + zfra_o = 0. + DO j = 1, knon + i = knindex(j) + snow_o(i) = snow(j) + zfra_o(i) = zfra(j) + ENDDO + +!**************************************************************************************** + snow_o=0. + zfra_o = 0. + DO j = 1, knon + i = knindex(j) + snow_o(i) = snow(j) + zfra_o(i) = zfra(j) + ENDDO + + + END SUBROUTINE surf_landice +! +!**************************************************************************************** +! +END MODULE surf_landice_mod + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_ocean_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_ocean_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_ocean_mod.F90 (revision 1634) @@ -0,0 +1,170 @@ +! +MODULE surf_ocean_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_ocean(rlon, rlat, swnet, lwnet, alb1, & + rugos, windsp, rmu0, fder, tsurf_in, & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, rugoro, pctsrf, & + snow, qsurf, agesno, & + z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, lmt_bils, & + flux_u1, flux_v1) + + USE dimphy + USE surface_data, ONLY : type_ocean + USE ocean_forced_mod, ONLY : ocean_forced_noice + USE ocean_slab_mod, ONLY : ocean_slab_noice + USE ocean_cpl_mod, ONLY : ocean_cpl_noice +! +! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, +! slab or couple). The calculations of albedo and rugosity for the ocean surface are +! done in here because they are identical for the different modes of ocean. +! + INCLUDE "indicesol.h" + INCLUDE "YOMCST.h" + +! Input variables +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: rugos + REAL, DIMENSION(klon), INTENT(IN) :: windsp + REAL, DIMENSION(klon), INTENT(IN) :: rmu0 + REAL, DIMENSION(klon), INTENT(IN) :: fder + REAL, DIMENSION(klon), INTENT(IN) :: tsurf_in + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh + REAL, DIMENSION(klon), INTENT(IN) :: cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow + REAL, DIMENSION(klon), INTENT(INOUT) :: qsurf + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + +! Output variables +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + +! Local variables +!**************************************************************************************** + INTEGER :: i + REAL :: tmp + REAL, PARAMETER :: cepdu2=(0.1)**2 + REAL, DIMENSION(klon) :: alb_eau + REAL, DIMENSION(klon) :: radsol + +! End definition +!**************************************************************************************** + + +!**************************************************************************************** +! Calculate total net radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +!**************************************************************************************** +! Switch according to type of ocean (couple, slab or forced) +!**************************************************************************************** + SELECT CASE(type_ocean) + CASE('couple') + CALL ocean_cpl_noice( & + swnet, lwnet, alb1, & + windsp, fder, & + itime, dtime, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow,temp_air,spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + + CASE('slab') + CALL ocean_slab_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, tsurf_in, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l, lmt_bils) + + CASE('force') + CALL ocean_forced_noice( & + itime, dtime, jour, knon, knindex, & + p1lay, cdragh, cdragm, precip_rain, precip_snow, & + temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, agesno, & + qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + END SELECT + +!**************************************************************************************** +! Calculate albedo +! +!**************************************************************************************** + IF ( MINVAL(rmu0) == MAXVAL(rmu0) .AND. MINVAL(rmu0) == -999.999 ) THEN + CALL alboc(REAL(jour),rlat,alb_eau) + ELSE ! diurnal cycle + CALL alboc_cd(rmu0,alb_eau) + ENDIF + + DO i =1, knon + alb1_new(i) = alb_eau(knindex(i)) + ENDDO + alb2_new(1:knon) = alb1_new(1:knon) + +!**************************************************************************************** +! Calculate the rugosity +! +!**************************************************************************************** + DO i = 1, knon + tmp = MAX(cepdu2,u1(i)**2+v1(i)**2) + z0_new(i) = 0.018*cdragm(i) * (u1(i)**2+v1(i)**2)/RG & + + 0.11*14e-6 / SQRT(cdragm(i) * tmp) + z0_new(i) = MAX(1.5e-05,z0_new(i)) + ENDDO +! +!**************************************************************************************** +! + END SUBROUTINE surf_ocean +! +!**************************************************************************************** +! +END MODULE surf_ocean_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_seaice_mod.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_seaice_mod.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surf_seaice_mod.F90 (revision 1634) @@ -0,0 +1,146 @@ +! +MODULE surf_seaice_mod + + IMPLICIT NONE + +CONTAINS +! +!**************************************************************************************** +! + SUBROUTINE surf_seaice( & + rlon, rlat, swnet, lwnet, alb1, fder, & + itime, dtime, jour, knon, knindex, & + lafin, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, & + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, rugoro, pctsrf, & + snow, qsurf, qsol, agesno, tsoil, & + z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, & + tsurf_new, dflux_s, dflux_l, & + flux_u1, flux_v1) + + USE dimphy + USE surface_data + USE ocean_forced_mod, ONLY : ocean_forced_ice + USE ocean_cpl_mod, ONLY : ocean_cpl_ice + +! +! This subroutine will make a call to ocean_XXX_ice according to the ocean mode (force, +! slab or couple). The calculation of rugosity for the sea-ice surface is also done +! in here because it is the same calculation for the different modes of ocean. +! + INCLUDE "indicesol.h" + INCLUDE "dimsoil.h" + +! Input arguments +!**************************************************************************************** + INTEGER, INTENT(IN) :: itime, jour, knon + INTEGER, DIMENSION(klon), INTENT(IN) :: knindex + LOGICAL, INTENT(IN) :: lafin + REAL, INTENT(IN) :: dtime + REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat + REAL, DIMENSION(klon), INTENT(IN) :: swnet ! net shortwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: lwnet ! net longwave radiation at surface + REAL, DIMENSION(klon), INTENT(IN) :: alb1 ! albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(IN) :: fder + REAL, DIMENSION(klon), INTENT(IN) :: tsurf + REAL, DIMENSION(klon), INTENT(IN) :: p1lay + REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm + REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow + REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum + REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ + REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV + REAL, DIMENSION(klon), INTENT(IN) :: ps + REAL, DIMENSION(klon), INTENT(IN) :: u1, v1 + REAL, DIMENSION(klon), INTENT(IN) :: rugoro + REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf + +! In/Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsurf, qsol + REAL, DIMENSION(klon), INTENT(INOUT) :: agesno + REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil + +! Output arguments +!**************************************************************************************** + REAL, DIMENSION(klon), INTENT(OUT) :: z0_new + REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! new albedo in visible SW interval + REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! new albedo in near IR interval + REAL, DIMENSION(klon), INTENT(OUT) :: evap, fluxsens, fluxlat + REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new + REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l + REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 + +! Local arguments +!**************************************************************************************** + REAL, DIMENSION(klon) :: radsol + +! +! End definitions +!**************************************************************************************** + + +!**************************************************************************************** +! Calculate total net radiance at surface +! +!**************************************************************************************** + radsol(:) = 0.0 + radsol(1:knon) = swnet(1:knon) + lwnet(1:knon) + +!**************************************************************************************** +! Switch according to type of ocean (couple, slab or forced) +! +!**************************************************************************************** + IF (type_ocean == 'couple') THEN + + CALL ocean_cpl_ice( & + rlon, rlat, swnet, lwnet, alb1, & + fder, & + itime, dtime, knon, knindex, & + lafin,& + p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, pctsrf, & + radsol, snow, qsurf, & + alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + + ELSE IF (type_ocean == 'force' .OR. (type_ocean == 'slab' .AND. version_ocean=='sicOBS')) THEN + CALL ocean_forced_ice( & + itime, dtime, jour, knon, knindex, & + tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,& + AcoefH, AcoefQ, BcoefH, BcoefQ, & + AcoefU, AcoefV, BcoefU, BcoefV, & + ps, u1, v1, & + radsol, snow, qsol, agesno, tsoil, & + qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, & + tsurf_new, dflux_s, dflux_l) + + ELSE IF (type_ocean == 'slab') THEN +!!$ CALL ocean_slab_ice( & +!!$ itime, dtime, jour, knon, knindex, & +!!$ debut, & +!!$ tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, spechum,& +!!$ AcoefH, AcoefQ, BcoefH, BcoefQ, & +!!$ ps, u1, v1, pctsrf, & +!!$ radsol, snow, qsurf, qsol, agesno, tsoil, & +!!$ alb1_new, alb2_new, evap, fluxsens, fluxlat, & +!!$ tsurf_new, dflux_s, dflux_l) + + END IF + +!**************************************************************************************** +! Calculate rugosity +! +!**************************************************************************************** + z0_new = 0.002 + z0_new = SQRT(z0_new**2+rugoro**2) + + END SUBROUTINE surf_seaice +! +!**************************************************************************************** +! +END MODULE surf_seaice_mod + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surface_data.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surface_data.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/surface_data.F90 (revision 1634) @@ -0,0 +1,21 @@ +! +! $Header$ +! +MODULE surface_data + + REAL, PARAMETER :: calice=1.0/(5.1444e+06*0.15) + REAL, PARAMETER :: tau_gl=86400.*5. + REAL, PARAMETER :: calsno=1./(2.3867e+06*.15) + + LOGICAL, SAVE :: ok_veget ! true for use of vegetation model ORCHIDEE + !$OMP THREADPRIVATE(ok_veget) + + CHARACTER(len=6), SAVE :: type_ocean ! force/slab/couple + !$OMP THREADPRIVATE(type_ocean) + + ! if type_ocean=couple : version_ocean=opa8 ou nemo + ! if type_ocean=slab : version_ocean=sicOBS + CHARACTER(len=6), SAVE :: version_ocean + !$OMP THREADPRIVATE(version_ocean) + +END MODULE surface_data Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/sw_aeroAR4.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/sw_aeroAR4.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/sw_aeroAR4.F90 (revision 1634) @@ -0,0 +1,568 @@ +! +! $Id$ +! +SUBROUTINE SW_AEROAR4(PSCT, PRMU0, PFRAC, & + PPMB, PDP, & + PPSOL, PALBD, PALBP,& + PTAVE, PWV, PQS, POZON, PAER,& + PCLDSW, PTAU, POMEGA, PCG,& + PHEAT, PHEAT0,& + PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,& + ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,& + tauaero, pizaero, cgaero,& + PTAUA, POMEGAA,& + PTOPSWADAERO,PSOLSWADAERO,& + PTOPSWAD0AERO,PSOLSWAD0AERO,& + PTOPSWAIAERO,PSOLSWAIAERO,& + PTOPSWAERO,PTOPSW0AERO,& + PSOLSWAERO,PSOLSW0AERO,& + PTOPSWCFAERO,PSOLSWCFAERO,& + ok_ade, ok_aie ) + + USE dimphy + + IMPLICIT NONE + +#include "YOMCST.h" +#include "clesphys.h" + ! + ! ------------------------------------------------------------------ + ! + ! PURPOSE. + ! -------- + ! + ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO + ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). + ! + ! METHOD. + ! ------- + ! + ! 1. COMPUTES ABSORBER AMOUNTS (SWU) + ! 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) + ! 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) + ! + ! REFERENCE. + ! ---------- + ! + ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT + ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) + ! + ! AUTHOR. + ! ------- + ! JEAN-JACQUES MORCRETTE *ECMWF* + ! + ! MODIFICATIONS. + ! -------------- + ! ORIGINAL : 89-07-14 + ! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo + ! 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER) + ! 09-04 A. COZIC - C.DEANDREIS Indroduce NAT/BC/POM/DUST/SS aerosol forcing + ! ------------------------------------------------------------------ + ! + !* ARGUMENTS: + ! + REAL(KIND=8) PSCT ! constante solaire (valeur conseillee: 1370) + + REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (PA) + REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA) + REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) + + REAL(KIND=8) PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE + REAL(KIND=8) PFRAC(KDLON) ! fraction de la journee + + REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) + REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFI! HUMIDITY (KG/KG) + REAL(KIND=8) PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG) + REAL(KIND=8) POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG) + REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS + + REAL(KIND=8) PALBD(KDLON,2) ! albedo du sol (lumiere diffuse) + REAL(KIND=8) PALBP(KDLON,2) ! albedo du sol (lumiere parallele) + + REAL(KIND=8) PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION + REAL(KIND=8) PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS + REAL(KIND=8) PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR + REAL(KIND=8) POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO + + REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY) + REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky + REAL(KIND=8) PALBPLA(KDLON) ! PLANETARY ALBEDO + REAL(KIND=8) PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A. + REAL(KIND=8) PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE + REAL(KIND=8) PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) + REAL(KIND=8) PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) + ! + !* LOCAL VARIABLES: + ! + real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 + + REAL(KIND=8) ZOZ(KDLON,KFLEV) + ! column-density of ozone in layer, in kilo-Dobsons + + REAL(KIND=8) ZAKI(KDLON,2) + REAL(KIND=8) ZCLD(KDLON,KFLEV) + REAL(KIND=8) ZCLEAR(KDLON) + REAL(KIND=8) ZDSIG(KDLON,KFLEV) + REAL(KIND=8) ZFACT(KDLON) + REAL(KIND=8) ZFD(KDLON,KFLEV+1) + REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1) + REAL(KIND=8) ZFU(KDLON,KFLEV+1) + REAL(KIND=8) ZFUP(KDLON,KFLEV+1) + REAL(KIND=8) ZRMU(KDLON) + REAL(KIND=8) ZSEC(KDLON) + REAL(KIND=8) ZUD(KDLON,5,KFLEV+1) + REAL(KIND=8) ZCLDSW0(KDLON,KFLEV) + + REAL(KIND=8) ZFSUP(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN(KDLON,KFLEV+1) + REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1) + REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1) + + INTEGER inu, jl, jk, i, k, kpl1 + + INTEGER swpas ! Every swpas steps, sw is calculated + PARAMETER(swpas=1) + + INTEGER, SAVE :: itapsw = 0 + !$OMP THREADPRIVATE(itapsw) + LOGICAL, SAVE :: appel1er = .TRUE. + !$OMP THREADPRIVATE(appel1er) + LOGICAL, SAVE :: initialized = .FALSE. + !$OMP THREADPRIVATE(initialized) + + !jq-Introduced for aerosol forcings + REAL(KIND=8), SAVE :: flag_aer + !$OMP THREADPRIVATE(flag_aer) + + LOGICAL ok_ade, ok_aie ! use aerosol forcings or not? + REAL(KIND=8) tauaero(kdlon,kflev,9,2) ! aerosol optical properties + REAL(KIND=8) pizaero(kdlon,kflev,9,2) ! (see aeropt.F) + REAL(KIND=8) cgaero(kdlon,kflev,9,2) ! -"- + REAL(KIND=8) PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value) + REAL(KIND=8) POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO + REAL(KIND=8) PTOPSWADAERO(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) + REAL(KIND=8) PSOLSWADAERO(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) + REAL(KIND=8) PTOPSWAD0AERO(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) + REAL(KIND=8) PSOLSWAD0AERO(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) + REAL(KIND=8) PTOPSWAIAERO(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) + REAL(KIND=8) PSOLSWAIAERO(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) + REAL(KIND=8) PTOPSWAERO(KDLON,9) ! SW TOA AS DRF nat & ant + REAL(KIND=8) PTOPSW0AERO(KDLON,9) ! SW SRF AS DRF nat & ant + REAL(KIND=8) PSOLSWAERO(KDLON,9) ! SW TOA CS DRF nat & ant + REAL(KIND=8) PSOLSW0AERO(KDLON,9) ! SW SRF CS DRF nat & ant + REAL(KIND=8) PTOPSWCFAERO(KDLON,3) ! SW TOA AS cloudRF nat & ant + REAL(KIND=8) PSOLSWCFAERO(KDLON,3) ! SW SRF AS cloudRF nat & ant + + !jq - Fluxes including aerosol effects + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD_AERO(:,:) + !$OMP THREADPRIVATE(ZFSUPAD_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD_AERO(:,:) + !$OMP THREADPRIVATE(ZFSDNAD_AERO) + !jq - Fluxes including aerosol effects + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD0_AERO(:,:) + !$OMP THREADPRIVATE(ZFSUPAD0_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD0_AERO(:,:) + !$OMP THREADPRIVATE(ZFSDNAD0_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAI_AERO(:,:) + !$OMP THREADPRIVATE(ZFSUPAI_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAI_AERO(:,:) + !$OMP THREADPRIVATE(ZFSDNAI_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUP_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSUP_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDN_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSDN_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUP0_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSUP0_AERO) + REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDN0_AERO(:,:,:) + !$OMP THREADPRIVATE(ZFSDN0_AERO) + +! Key to define the aerosol effect acting on climate +! 0: aerosol feedback active according to ok_ade, ok_aie DEFAULT +! 1: no feedback , zero aerosol fluxes are used for climate, diagnostics according to ok_ade_ok_aie +! 2: feedback according to total aerosol direct effect used for climate, diagnostics according to ok_ade, ok_aie +! 3: feedback according to natural aerosol direct effect used for climate, diagnostics according to ok_ade_ok_aie + + INTEGER,SAVE :: AEROSOLFEEDBACK_ACTIVE = 0 +!$OMP THREADPRIVATE(AEROSOLFEEDBACK_ACTIVE) + + CHARACTER (LEN=20) :: modname='sw_aeroAR4' + CHARACTER (LEN=80) :: abort_message + + IF ((.not. ok_ade) .and. (AEROSOLFEEDBACK_ACTIVE .ge. 2)) THEN + abort_message ='Error: direct effect is not activated but assumed to be active - see sw_aeroAR4.F90' + CALL abort_gcm (modname,abort_message,1) + ENDIF + AEROSOLFEEDBACK_ACTIVE=MIN(MAX(AEROSOLFEEDBACK_ACTIVE,0),3) + IF (AEROSOLFEEDBACK_ACTIVE .gt. 3) THEN + abort_message ='Error: AEROSOLFEEDBACK_ACTIVE options go only until 3' + CALL abort_gcm (modname,abort_message,1) + ENDIF + + IF(.NOT.initialized) THEN + flag_aer=0. + initialized=.TRUE. + ALLOCATE(ZFSUPAD_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSDNAD_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSUPAD0_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSDNAD0_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSUPAI_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSDNAI_AERO(KDLON,KFLEV+1)) + ALLOCATE(ZFSUP_AERO (KDLON,KFLEV+1,9)) + ALLOCATE(ZFSDN_AERO (KDLON,KFLEV+1,9)) + ALLOCATE(ZFSUP0_AERO(KDLON,KFLEV+1,9)) + ALLOCATE(ZFSDN0_AERO(KDLON,KFLEV+1,9)) + ZFSUPAD_AERO(:,:)=0. + ZFSDNAD_AERO(:,:)=0. + ZFSUPAD0_AERO(:,:)=0. + ZFSDNAD0_AERO(:,:)=0. + ZFSUPAI_AERO(:,:)=0. + ZFSDNAI_AERO(:,:)=0. + ZFSUP_AERO (:,:,:)=0. + ZFSDN_AERO (:,:,:)=0. + ZFSUP0_AERO(:,:,:)=0. + ZFSDN0_AERO(:,:,:)=0. + ENDIF + + IF (appel1er) THEN + PRINT*, 'SW calling frequency : ', swpas + PRINT*, " In general, it should be 1" + appel1er = .FALSE. + ENDIF + ! ------------------------------------------------------------------ + IF (MOD(itapsw,swpas).EQ.0) THEN + + DO JK = 1 , KFLEV + DO JL = 1, KDLON + ZCLDSW0(JL,JK) = 0.0 + ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG & + *PDP(JL,JK)*(101325.0/PPSOL(JL)) + ENDDO + ENDDO + +! clear sky is either computed IF no direct effect is asked for, or for extended diag) + IF (( lev_histmth .ge. 4 ) .or. ( .not. ok_ade )) THEN + + ! clear-sky: zero aerosol effect + flag_aer=0.0 + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU,PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0_AERO(JL,JK,1) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + +! cloudy sky is either computed IF no indirect effect is asked for, or for extended diag) + IF (( lev_histmth .ge. 4 ) .or. ( .not. ok_aie )) THEN + ! cloudy-sky: zero aerosol effect + flag_aer=0.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer, & + tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,1) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + + + IF (ok_ade) THEN + + ! clear sky (Anne Cozic 03/07/2007) direct effect of total aerosol + ! CAS AER (2) + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0_AERO(JL,JK,2) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + +! cloudy sky is either computed IF no indirect effect is asked for, or for extended diag) + IF (( lev_histmth .ge. 2 ) .or. (.not. ok_aie)) THEN + ! cloudy-sky aerosol direct effect of total aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,2) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + +! natural aeroosl clear sky is computed for extended diag) + IF ( lev_histmth .ge. 4 ) THEN + ! clear sky direct effect natural aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP0_AERO(JL,JK,3) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN0_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + +! cloud sky natural is for extended diagnostics + IF ( lev_histmth .ge. 2 ) THEN + ! cloudy-sky direct effect natural aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,3) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF + + ENDIF ! ok_ade + +! cloudy sky needs to be computed in all cases IF ok_aie is activated + IF (ok_aie) THEN + !jq cloudy-sky + aerosol direct + aerosol indirect of total aerosol + flag_aer=1.0 + CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,& + PRMU0,PFRAC,PTAVE,PWV,& + ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) + INU = 1 + CALL SW1S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,& + ZFD, ZFU) + INU = 2 + CALL SW2S_LMDAR4(INU, PAER, flag_aer,& + tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),& + ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,& + ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,& + PWV, PQS,& + ZFDOWN, ZFUP) + DO JK = 1 , KFLEV+1 + DO JL = 1, KDLON + ZFSUP_AERO(JL,JK,4) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) + ZFSDN_AERO(JL,JK,4) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) + ENDDO + ENDDO + ENDIF ! ok_aie + + itapsw = 0 + ENDIF + itapsw = itapsw + 1 + + IF ( AEROSOLFEEDBACK_ACTIVE .eq. 0) THEN + IF ( ok_ade .and. ok_aie ) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,4) + ZFSDN(:,:) = ZFSDN_AERO(:,:,4) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,2) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,2) + ENDIF + IF ( ok_ade .and. (.not. ok_aie) ) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,2) + ZFSDN(:,:) = ZFSDN_AERO(:,:,2) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,2) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,2) + ENDIF + + IF ( (.not. ok_ade) .and. ok_aie ) THEN + print*,'Warning: indirect effect in cloudy regions includes direct aerosol effect' + ZFSUP(:,:) = ZFSUP_AERO(:,:,4) + ZFSDN(:,:) = ZFSDN_AERO(:,:,4) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,1) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,1) + ENDIF + IF ((.not. ok_ade) .and. (.not. ok_aie)) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,1) + ZFSDN(:,:) = ZFSDN_AERO(:,:,1) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,1) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,1) + ENDIF + +! MS the following allows to compute the forcing diagostics without +! letting the aerosol forcing act on the meteorology +! SEE logic above + ELSEIF ( AEROSOLFEEDBACK_ACTIVE .gt. 0) THEN + ZFSUP(:,:) = ZFSUP_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ZFSDN(:,:) = ZFSDN_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ZFSUP0(:,:) = ZFSUP0_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ZFSDN0(:,:) = ZFSDN0_AERO(:,:,AEROSOLFEEDBACK_ACTIVE) + ENDIF + + + DO k = 1, KFLEV + kpl1 = k+1 + DO i = 1, KDLON + PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))-(ZFSDN(i,k)-ZFSDN(i,kpl1)) + PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k) + PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))-(ZFSDN0(i,k)-ZFSDN0(i,kpl1)) + PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k) + ENDDO + ENDDO + + DO i = 1, KDLON +! effective SW surface albedo calculation + PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20) + +! clear sky net fluxes at TOA and SRF + PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1) + PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1) + +! cloudy sky net fluxes at TOA and SRF + PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1) + PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1) + + +! net anthropogenic forcing direct and 1st indirect effect diagnostics +! requires a natural aerosol field read and used +! Difference of net fluxes from double call to radiation + + +IF (ok_ade) THEN + +! indices 1: natural; 2 anthropogenic +! TOA/SRF all sky natural forcing + PSOLSWAERO(i,1) = (ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))-(ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1)) + PTOPSWAERO(i,1) = (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))- (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1)) + +! TOA/SRF all sky anthropogenic forcing + PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3)) + PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))- (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3)) + +! TOA/SRF clear sky natural forcing + PSOLSW0AERO(i,1) = (ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1)) + PTOPSW0AERO(i,1) = (ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))-(ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1)) + +! TOA/SRF clear sky anthropogenic forcing + PSOLSW0AERO(i,2) = (ZFSDN0_AERO(i,1,2) - ZFSUP0_AERO(i,1,2))-(ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3)) + PTOPSW0AERO(i,2) = (ZFSDN0_AERO(i,KFLEV+1,2) - ZFSUP0_AERO(i,KFLEV+1,2))-(ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3)) + +! Cloud forcing indices 1: natural; 2 anthropogenic; 3: zero aerosol direct effect +! Instantaneously computed cloudy sky direct aerosol effect, cloud forcing due to aerosols above clouds +! natural + PSOLSWCFAERO(i,1) = PSOLSWAERO(i,1) - PSOLSW0AERO(i,1) + PTOPSWCFAERO(i,1) = PTOPSWAERO(i,1) - PTOPSW0AERO(i,1) + +! Instantaneously computed cloudy SKY DIRECT aerosol effect, cloud forcing due to aerosols above clouds +! anthropogenic + PSOLSWCFAERO(i,2) = PSOLSWAERO(i,2) - PSOLSW0AERO(i,2) + PTOPSWCFAERO(i,2) = PTOPSWAERO(i,2) - PTOPSW0AERO(i,2) + +! Cloudforcing without aerosol +! zero + PSOLSWCFAERO(i,3) = (ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1)) + PTOPSWCFAERO(i,3) = (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))- (ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1)) + +! direct anthropogenic forcing , as in old LMDzT, however differences of net fluxes + PSOLSWADAERO(i) = PSOLSWAERO(i,2) + PTOPSWADAERO(i) = PTOPSWAERO(i,2) + PSOLSWAD0AERO(i) = PSOLSW0AERO(i,2) + PTOPSWAD0AERO(i) = PTOPSW0AERO(i,2) + +ENDIF + + +IF (ok_aie) THEN + PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2)) + PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))-(ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2)) +ENDIF + + ENDDO +END SUBROUTINE SW_AEROAR4 Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/tetalevel.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/tetalevel.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/tetalevel.F (revision 1634) @@ -0,0 +1,141 @@ +! +! $Header$ +! +c================================================================ +c================================================================ + SUBROUTINE tetalevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) +c================================================================ +c================================================================ + USE dimphy + IMPLICIT none + +cym#include "dimensions.h" +cym#include "dimphy.h" + +c================================================================ +c +c Interpoler des champs 3-D u, v et g du modele a un niveau de +c pression donnee (pres) +c +c INPUT: ilon ----- nombre de points +c ilev ----- nombre de couches +c lnew ----- true si on doit reinitialiser les poids +c pgcm ----- pressions modeles +c pres ----- pression vers laquelle on interpolle +c Qgcm ----- champ GCM +c Qpres ---- champ interpolle au niveau pres +c +c================================================================ +c +c arguments : +c ----------- + + INTEGER ilon, ilev + logical lnew + + REAL pgcm(ilon,ilev) + REAL Qgcm(ilon,ilev) + real pres + REAL Qpres(ilon) + +c local : +c ------- +c +cym#include "paramet.h" +c + INTEGER,ALLOCATABLE,SAVE :: lt(:), lb(:) + REAL,ALLOCATABLE,SAVE :: aist(:), aisb(:) + REAL,SAVE :: ptop, pbot + LOGICAL,SAVE :: first = .TRUE. +c$OMP THREADPRIVATE(lt,lb,aist,aisb,ptop, pbot,first) + + INTEGER i, k +c +c PRINT*,'tetalevel pres=',pres + IF (first) THEN + ALLOCATE(lt(ilon), lb(ilon)) + ALLOCATE(aist(ilon), aisb(ilon)) + + first=.FALSE. + ENDIF +c===================================================================== + if (lnew) then +c on r�nitialise les r�ndicages et les poids +c===================================================================== + + +c Chercher les 2 couches les plus proches du niveau a obtenir +c +c Eventuellement, faire l'extrapolation a partir des deux couches +c les plus basses ou les deux couches les plus hautes: + DO 130 i = 1, ilon +cIM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. + . ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF +cIM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', +cIM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + 130 CONTINUE + DO 150 k = 1, ilev-1 + DO 140 i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) +cIM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + 140 CONTINUE + 150 CONTINUE +c +c Interpolation lineaire: +c + DO i = 1, ilon +c interpolation en logarithme de pression: +c +c ... Modif . P. Le Van ( 20/01/98) .... +c Modif Fr��ic Hourdin (3/01/02) + +c IF(pgcm(i,lb(i)).NE.0.OR. +c $ pgcm(i,lt(i)).NE.0.) THEN +c +c PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), +c . lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres +c + aist(i) = LOG( pgcm(i,lb(i))/ pres ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) + . / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + +c====================================================================== +c inteprollation +c====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) +cIM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), +cIM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo +c +c Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon +cIM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN +c Qpres(i)=1e33 + Qpres(i)=1e+20 +cIM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell.F (revision 1634) @@ -0,0 +1,1284 @@ +! +! $Id$ +! + SUBROUTINE calcul_sec(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi,zlev + s ,pu,pv,pt,po + s ,zmax,wmax,zw2,lmix +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di + REAL tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zw2(klon,klev+1),ztva(klon,klev) + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) +! real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time +! integer isplit,nsplit + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real zalim(klon) + integer lalim(klon) + real norme(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical therm + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) +cRC + + character*2 str2 + character*10 str10 + + character (len=20) :: modname='calcul_sec' + character (len=80) :: abort_message + + +! LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + +c print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + therm=.false. + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k+1 + therm=.true. + endif + enddo + enddo +climitation de la valeur du lentr +c do ig=1,ngrid +c lentr(ig)=min(5,lentr(ig)) +c enddo +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +cinitialisations + do ig=1,ngrid + zalim(ig)=0. + norme(ig)=0. + lalim(ig)=1 + enddo + do k=1,klev-1 + do ig=1,ngrid + zalim(ig)=zalim(ig)+zlev(ig,k)*MAX(0.,(ztv(ig,k)-ztv(ig,k+1)) + s /(zlev(ig,k+1)-zlev(ig,k))) +c s *(zlev(ig,k+1)-zlev(ig,k)) + norme(ig)=norme(ig)+MAX(0.,(ztv(ig,k)-ztv(ig,k+1)) + s /(zlev(ig,k+1)-zlev(ig,k))) +c s *(zlev(ig,k+1)-zlev(ig,k)) + enddo + enddo + do ig=1,ngrid + if (norme(ig).gt.1.e-10) then + zalim(ig)=max(10.*zalim(ig)/norme(ig),zlev(ig,2)) +c zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig))) + endif + enddo +cdétermination du lalim correspondant + do k=1,klev-1 + do ig=1,ngrid + if ((zalim(ig).gt.zlev(ig,k)).and.(zalim(ig).le.zlev(ig,k+1))) + s then + lalim(ig)=k + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.lt.lentr(ig)) then + entr_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) +c s *(zlev(ig,l+1)-zlev(ig,l)) + s *sqrt(zlev(ig,l+1)) +cautre def +c entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) +c s /zlev(ig,lentr(ig)+2)))**(3./2.) + endif + enddo + enddo +cnouveau test +c if (therm) then + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lalim(ig) + s .and.zalim(ig).gt.1.e-10) then +c if (l.le.lentr(ig)) then +c entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) +c s /zalim(ig)))**(3./2.) +c write(10,*)zlev(ig,l),entr_star(ig,l) + endif + enddo + enddo +c endif +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.5) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c Calcul entrainement normalise + do ig=1,ngrid + if (entr_star_tot(ig).gt.1.e-10) then +c do l=1,lentr(ig) + do l=1,klev +cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta + entr_star(ig,l)=entr_star(ig,l)/entr_star_tot(ig) + enddo + endif + enddo +c +c print*,'fin calcul entr_star' + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) + s *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then +ctest + if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then +c print*,'pb linter' + endif + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + if (zw2(ig,l+1).lt.0.) then +c print*,'pb1 zw2<0' + endif + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) +c lmax(ig)=lalim(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 +c do l=nlay,lalim(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.5) then + lmax(ig)=1 + lmin(ig)=1 + lentr(ig)=1 + lalim(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then +c print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + do ig=1,ngrid +c write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig) + enddo +con stope après les calculs de zmax et wmax + RETURN + +c print*,'avant fermeture' +c Fermeture,determination de f +cAttention! entrainement normalisé ou pas? + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) +c do k=lmin(ig),lalim(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect + s *entr_star2(ig)) +c s *entr_star_tot(ig) +ctest +c if (first) then + f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) + s *wmax(ig)) +c endif + endif + f0(ig)=f(ig) +c first=.true. + enddo +c print*,'apres fermeture' +con stoppe après la fermeture + RETURN +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +con stoppe après le calcul de entr +c RETURN +cCR:test pour entrainer moins que la masse +c do ig=1,ngrid +c do l=1,lentr(ig) +c if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then +c entr(ig,l+1)=entr(ig,l+1)+entr(ig,l) +c s -0.9*masse(ig,l)/ptimestep +c entr(ig,l)=0.9*masse(ig,l)/ptimestep +c endif +c enddo +c enddo +cCR: fin test +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then +c print*,'pb l_mix*zlev<0' + endif +cCR: test: nouvelle def de lambda +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + if (zw2(ig,l).gt.1.e-10) then + larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + else + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + endif +cRC +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) +c print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).lt.0.) then + zmix(ig)=0.99*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + +c print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + abort_message = 'fracd trop petit' + CALL abort_gcm (modname,abort_message,1) + + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) + fm(ig,l+1)=fm(ig,l)+entr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo +cRC + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/tho + entr0=entr0+ptimestep*(entr-entr0)/tho + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +#define troisD +#ifdef troisD +c if (sorties) then +c print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif +c print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + + SUBROUTINE fermeture_seche(ngrid,nlay + s ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk + s ,alim_star,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect + s ,zmax,wmax) + + USE dimphy + IMPLICIT NONE + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + + INTEGER ngrid,nlay + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + real zlev(klon,klev+1) + real alim_star(klon,klev) + real f0(klon) + integer lentr(klon) + integer lmin(klon) + real zmax(klon) + real wmax(klon) + real nu_min + real nu_max + real r_aspect + real rhobarz(klon,klev+1) + REAL zh(klon,klev) + real zo(klon,klev) + real zpspsk(klon,klev) + + integer ig,l + + real f_star(klon,klev+1) + real detr_star(klon,klev) + real entr_star(klon,klev) + real zw2(klon,klev+1) + real linter(klon) + integer lmix(klon) + integer lmax(klon) + real zlevinter(klon) + real wa_moy(klon,klev+1) + real wmaxa(klon) + REAL ztv(klon,klev) + REAL ztva(klon,klev) + real nu(klon,klev) +! real zmax0_sec(klon) +! save zmax0_sec + REAL, SAVE, ALLOCATABLE :: zmax0_sec(:) +c$OMP THREADPRIVATE(zmax0_sec) + logical, save :: first = .true. +c$OMP THREADPRIVATE(first) + + if (first) then + allocate(zmax0_sec(klon)) + first=.false. + endif + + do l=1,nlay + do ig=1,ngrid + ztv(ig,l)=zh(ig,l)/zpspsk(ig,l) + ztv(ig,l)=ztv(ig,l)*(1.+RETV*zo(ig,l)) + enddo + enddo + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.alim_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=alim_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then +cestimation du detrainement a partir de la geometrie du pas precedent +ctests sur la definition du detr + nu(ig,l)=(nu_min+nu_max)/2. + s *(1.-(nu_max-nu_min)/(nu_max+nu_min) + s *tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005))) + + detr_star(ig,l)=rhobarz(ig,l) + s *sqrt(zw2(ig,l)) + s /(r_aspect*zmax0_sec(ig))* +c s /(r_aspect*zmax0(ig))* + s (sqrt(nu(ig,l)*zlev(ig,l+1) + s /sqrt(zw2(ig,l))) + s -sqrt(nu(ig,l)*zlev(ig,l) + s /sqrt(zw2(ig,l)))) + detr_star(ig,l)=detr_star(ig,l)/f0(ig) + if ((detr_star(ig,l)).gt.f_star(ig,l)) then + detr_star(ig,l)=f_star(ig,l) + endif + entr_star(ig,l)=0.9*detr_star(ig,l) + if ((l.lt.lentr(ig))) then + entr_star(ig,l)=0. +c detr_star(ig,l)=0. + endif +c print*,'ok detr_star' +cprise en compte du detrainement dans le calcul du flux + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) + s -detr_star(ig,l) +ctest sur le signe de f_star + if ((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10) then +cAM on melange Tl et qt du thermique + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig,l) + s +alim_star(ig,l)) + s *ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l)) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l) + s /(f_star(ig,l+1)+detr_star(ig,l)))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif + endif +c + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. +c print*,'linter=',linter(ig) + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + lentr(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then +c print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) +cpour le cas ou on prend tjs lmin=1 +c zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) + zmax0_sec(ig)=zmax(ig) + enddo + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell.h (revision 1634) @@ -0,0 +1,16 @@ + integer :: iflag_thermals,nsplit_thermals + real,parameter :: r_aspect_thermals=2.,l_mix_thermals=30. + real :: alp_bl_k + real :: tau_thermals + integer,parameter :: w2di_thermals=1 + integer :: isplit + + integer :: iflag_coupl,iflag_clos,iflag_wake + integer :: iflag_thermals_ed,iflag_thermals_optflux + + common/ctherm1/iflag_thermals,nsplit_thermals + common/ctherm2/tau_thermals,alp_bl_k + common/ctherm4/iflag_coupl,iflag_clos,iflag_wake + common/ctherm5/iflag_thermals_ed,iflag_thermals_optflux + +!$OMP THREADPRIVATE(/ctherm1/,/ctherm2/,/ctherm4/,/ctherm5/) Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcellV0_main.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcellV0_main.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcellV0_main.F90 (revision 1634) @@ -0,0 +1,2101 @@ +! +! $Id$ +! + SUBROUTINE thermcellV0_main(itap,ngrid,nlay,ptimestep & + & ,pplay,pplev,pphi,debut & + & ,pu,pv,pt,po & + & ,pduadj,pdvadj,pdtadj,pdoadj & + & ,fm0,entr0,detr0,zqta,zqla,lmax & + & ,ratqscth,ratqsdiff,zqsatth & + & ,r_aspect,l_mix,tau_thermals & + & ,Ale_bl,Alp_bl,lalim_conv,wght_th & + & ,zmax0, f0,zw2,fraca) + + USE dimphy + USE comgeomphy , ONLY:rlond,rlatd + IMPLICIT NONE + +!======================================================================= +! Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu +! Version du 09.02.07 +! Calcul du transport vertical dans la couche limite en presence +! de "thermiques" explicitement representes avec processus nuageux +! +! Réécriture à partir d'un listing papier à Habas, le 14/02/00 +! +! le thermique est supposé homogène et dissipé par mélange avec +! son environnement. la longueur l_mix contrôle l'efficacité du +! mélange +! +! Le calcul du transport des différentes espèces se fait en prenant +! en compte: +! 1. un flux de masse montant +! 2. un flux de masse descendant +! 3. un entrainement +! 4. un detrainement +! +!======================================================================= + +!----------------------------------------------------------------------- +! declarations: +! ------------- + +#include "dimensions.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" + +! arguments: +! ---------- + +!IM 140508 + INTEGER itap + + INTEGER ngrid,nlay,w2di + real tau_thermals + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + +! local: +! ------ + + integer icount + data icount/0/ + save icount +!$OMP THREADPRIVATE(icount) + + integer,save :: igout=1 +!$OMP THREADPRIVATE(igout) + integer,save :: lunout1=6 +!$OMP THREADPRIVATE(lunout1) + integer,save :: lev_out=10 +!$OMP THREADPRIVATE(lev_out) + + INTEGER ig,k,l,ll + real zsortie1d(klon) + INTEGER lmax(klon),lmin(klon),lalim(klon) + INTEGER lmix(klon) + INTEGER lmix_bis(klon) + real linter(klon) + real zmix(klon) + real zmax(klon),zw2(klon,klev+1),ztva(klon,klev),zw_est(klon,klev+1) +! real fraca(klon,klev) + + real zmax_sec(klon) +!on garde le zmax du pas de temps precedent + real zmax0(klon) +!FH/IM save zmax0 + + real lambda + + real zlev(klon,klev+1),zlay(klon,klev) + real deltaz(klon,klev) + REAL zh(klon,klev) + real zthl(klon,klev),zdthladj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + real zl(klon,klev) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zta(klon,klev) + real zha(klon,klev) + real fraca(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev) + real q2(klon,klev) +! FH probleme de dimensionnement avec l'allocation dynamique +! common/comtherm/thetath2,wth2 + + real ratqscth(klon,klev) + real var + real vardiff + real ratqsdiff(klon,klev) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev),masse(klon,klev) + real zpspsk(klon,klev) + + real wmax(klon) + real wmax_sec(klon) + real fm0(klon,klev+1),entr0(klon,klev),detr0(klon,klev) + real fm(klon,klev+1),entr(klon,klev),detr(klon,klev) + + real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev) +!niveau de condensation + integer nivcon(klon) + real zcon(klon) + REAL CHI + real zcon2(klon) + real pcon(klon) + real zqsat(klon,klev) + real zqsatth(klon,klev) + + real f_star(klon,klev+1),entr_star(klon,klev) + real detr_star(klon,klev) + real alim_star_tot(klon),alim_star2(klon) + real alim_star(klon,klev) + real f(klon), f0(klon) +!FH/IM save f0 + real zlevinter(klon) + logical debut + real seuil + +! Declaration uniquement pour les sorties dans thermcell_out3d. +! Inutilise en 3D + real wthl(klon,klev) + real wthv(klon,klev) + real wq(klon,klev) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +! + !nouvelles variables pour la convection + real Ale_bl(klon) + real Alp_bl(klon) + real alp_int(klon) + real ale_int(klon) + integer n_int(klon) + real fm_tot(klon) + real wght_th(klon,klev) + integer lalim_conv(klon) +!v1d logical therm +!v1d save therm + + character*2 str2 + character*10 str10 + + character (len=20) :: modname='thermcellV0_main' + character (len=80) :: abort_message + + EXTERNAL SCOPY +! + +!----------------------------------------------------------------------- +! initialisation: +! --------------- +! + + seuil=0.25 + + if (debut) then + fm0=0. + entr0=0. + detr0=0. + + +#undef wrgrads_thermcell +#ifdef wrgrads_thermcell +! Initialisation des sorties grads pour les thermiques. +! Pour l'instant en 1D sur le point igout. +! Utilise par thermcell_out3d.h + str10='therm' + call inigrads(1,1,rlond(igout),1.,-180.,180.,jjm, & + & rlatd(igout),-90.,90.,1.,llm,pplay(igout,:),1., & + & ptimestep,str10,'therm ') +#endif + + + + endif + + fm=0. ; entr=0. ; detr=0. + + icount=icount+1 + +!IM 090508 beg +!print*,'=====================================================================' +!print*,'=====================================================================' +!print*,' PAS ',icount,' PAS ',icount,' PAS ',icount,' PAS ',icount +!print*,'=====================================================================' +!print*,'=====================================================================' +!IM 090508 end + + if (prt_level.ge.1) print*,'thermcell_main V4' + + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +! +!Initialisation +! + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main f0=max(f0,1.e-2)' + do ig=1,klon + f0(ig)=max(f0(ig),1.e-2) + enddo + +!----------------------------------------------------------------------- +! Calcul de T,q,ql a partir de Tl et qT dans l environnement +! -------------------------------------------------------------------- +! + CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & + & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env' + +!------------------------------------------------------------------------ +! -------------------- +! +! +! + + + + + + + + + + + +! +! +! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +! wh,wt,wo ... +! +! + + + + + + + + + + + zh,zu,zv,zo,rho +! +! +! -------------------- zlev(1) +! \\\\\\\\\\\\\\\\\\\\ +! +! + +!----------------------------------------------------------------------- +! Calcul des altitudes des couches +!----------------------------------------------------------------------- + + do l=2,nlay + zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG + enddo + zlev(:,1)=0. + zlev(:,nlay+1)=(2.*pphi(:,klev)-pphi(:,klev-1))/RG + do l=1,nlay + zlay(:,l)=pphi(:,l)/RG + enddo +!calcul de l epaisseur des couches + do l=1,nlay + deltaz(:,l)=zlev(:,l+1)-zlev(:,l) + enddo + +! print*,'2 OK convect8' +!----------------------------------------------------------------------- +! Calcul des densites +!----------------------------------------------------------------------- + + do l=1,nlay + rho(:,l)=pplay(:,l)/(zpspsk(:,l)*RD*ztv(:,l)) + enddo + +!IM + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main rhobarz(:,1)=rho(:,1)' + rhobarz(:,1)=rho(:,1) + + do l=2,nlay + rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1)) + enddo + +!calcul de la masse + do l=1,nlay + masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG + enddo + + if (prt_level.ge.1) print*,'thermcell_main apres initialisation' + +!------------------------------------------------------------------ +! +! /|\ +! -------- | F_k+1 ------- +! ----> D_k +! /|\ <---- E_k , A_k +! -------- | F_k --------- +! ----> D_k-1 +! <---- E_k-1 , A_k-1 +! +! +! +! +! +! --------------------------- +! +! ----- F_lmax+1=0 ---------- \ +! lmax (zmax) | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | E +! --------------------------- | D +! | +! --------------------------- | +! | +! --------------------------- \ | +! lalim | | +! --------------------------- | | +! | | +! --------------------------- | | +! | A | +! --------------------------- | | +! | | +! --------------------------- | | +! lmin (=1 pour le moment) | | +! ----- F_lmin=0 ------------ / / +! +! --------------------------- +! ////////////////////////// +! +! +!============================================================================= +! Calculs initiaux ne faisant pas intervenir les changements de phase +!============================================================================= + +!------------------------------------------------------------------ +! 1. alim_star est le profil vertical de l'alimentation à la base du +! panache thermique, calculé à partir de la flotabilité de l'air sec +! 2. lmin et lalim sont les indices inferieurs et superieurs de alim_star +!------------------------------------------------------------------ +! + entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0. + CALL thermcellV0_init(ngrid,nlay,ztv,zlay,zlev, & + & lalim,lmin,alim_star,alim_star_tot,lev_out) + +call testV0_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lmin ') +call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lalim ') + + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_init' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 1' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star thetav' + write(lunout1,'(i6,i4,2e15.5)') (igout,l,alim_star(igout,l) & + & ,ztv(igout,l),l=1,lalim(igout)+4) + endif + +!v1d do ig=1,klon +!v1d if (alim_star(ig,1).gt.1.e-10) then +!v1d therm=.true. +!v1d endif +!v1d enddo +!----------------------------------------------------------------------------- +! 3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un +! panache sec conservatif (e=d=0) alimente selon alim_star +! Il s'agit d'un calcul de type CAPE +! zmax_sec est utilisé pour déterminer la géométrie du thermique. +!------------------------------------------------------------------------------ +! + CALL thermcellV0_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax_sec,wmax_sec,lev_out) + +call testV0_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lmin ') +call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lalim ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 1b' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) & + & ,l=1,lalim(igout)+4) + endif + + + +!--------------------------------------------------------------------------------- +!calcul du melange et des variables dans le thermique +!-------------------------------------------------------------------------------- +! + if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out +!IM 140508 CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & + CALL thermcellV0_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & + & zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot, & + & lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva, & + & ztla,zqla,zqta,zha,zw2,zw_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out + + call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ') + call testV0_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 2' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) & + & ,f_star(igout,l+1),l=1,nint(linter(igout))+5) + endif + +!------------------------------------------------------------------------------- +! Calcul des caracteristiques du thermique:zmax,zmix,wmax +!------------------------------------------------------------------------------- +! + CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2, & + & zlev,lmax,zmax,zmax0,zmix,wmax,lev_out) + + + call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ') + call testV0_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin ') + call testV0_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix ') + call testV0_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height' + +!------------------------------------------------------------------------------- +! Fermeture,determination de f +!------------------------------------------------------------------------------- +! +!avant closure: on redéfinit lalim, alim_star_tot et alim_star +! do ig=1,klon +! do l=2,lalim(ig) +! alim_star(ig,l)=entr_star(ig,l) +! entr_star(ig,l)=0. +! enddo +! enddo + + CALL thermcellV0_closure(ngrid,nlay,r_aspect,ptimestep,rho, & + & zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out) + + if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure' + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + f0=(1.-lambda)*f+lambda*f0 + else + f0=f + endif + +! Test valable seulement en 1D mais pas genant + if (.not. (f0(1).ge.0.) ) then + abort_message = 'Dans thermcell_main f0(1).lt.0 ' + CALL abort_gcm (modname,abort_message,1) + endif + +!------------------------------------------------------------------------------- +!deduction des flux +!------------------------------------------------------------------------------- + + CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,lev_out,lunout1,igout) +!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux' + call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ') + call testV0_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax ') + +!------------------------------------------------------------------ +! On ne prend pas directement les profils issus des calculs precedents +! mais on s'autorise genereusement une relaxation vers ceci avec +! une constante de temps tau_thermals (typiquement 1800s). +!------------------------------------------------------------------ + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + fm0=(1.-lambda)*fm+lambda*fm0 + entr0=(1.-lambda)*entr+lambda*entr0 +! detr0=(1.-lambda)*detr+lambda*detr0 + else + fm0=fm + entr0=entr + detr0=detr + endif + +!c------------------------------------------------------------------ +! calcul du transport vertical +!------------------------------------------------------------------ + + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse, & + & zthl,zdthladj,zta,lev_out) + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse, & + & po,pdoadj,zoa,lev_out) + +!------------------------------------------------------------------ +! Calcul de la fraction de l'ascendance +!------------------------------------------------------------------ + do ig=1,klon + fraca(ig,1)=0. + fraca(ig,nlay+1)=0. + enddo + do l=2,nlay + do ig=1,klon + if (zw2(ig,l).gt.1.e-10) then + fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l)) + else + fraca(ig,l)=0. + endif + enddo + enddo + +!------------------------------------------------------------------ +! calcul du transport vertical du moment horizontal +!------------------------------------------------------------------ + +!IM 090508 + if (1.eq.1) then +!IM 070508 vers. _dq +! if (1.eq.0) then + + +! Calcul du transport de V tenant compte d'echange par gradient +! de pression horizontal avec l'environnement + + call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,fraca,zmax & + & ,zu,zv,pduadj,pdvadj,zua,zva,lev_out) +!IM 050508 & ,zu,zv,pduadj,pdvadj,zua,zva,igout,lev_out) + else + +! calcul purement conservatif pour le transport de V + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,zu,pduadj,zua,lev_out) + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,zv,pdvadj,zva,lev_out) + endif + +! print*,'13 OK convect8' + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + if (prt_level.ge.1) print*,'14 OK convect8' +!------------------------------------------------------------------ +! Calculs de diagnostiques pour les sorties +!------------------------------------------------------------------ +!calcul de fraca pour les sorties + + if (sorties) then + if (prt_level.ge.1) print*,'14a OK convect8' +! calcul du niveau de condensation +! initialisation + do ig=1,ngrid + nivcon(ig)=0 + zcon(ig)=0. + enddo +!nouveau calcul + do ig=1,ngrid + CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1)) + pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI + enddo +!IM do k=1,nlay + do k=1,nlay-1 + do ig=1,ngrid + if ((pcon(ig).le.pplay(ig,k)) & + & .and.(pcon(ig).gt.pplay(ig,k+1))) then + zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100. + endif + enddo + enddo +!IM + do ig=1,ngrid + if (pcon(ig).le.pplay(ig,nlay)) then + zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100. + abort_message = 'thermcellV0_main: les thermiques vont trop haut ' + CALL abort_gcm (modname,abort_message,1) + endif + enddo + if (prt_level.ge.1) print*,'14b OK convect8' + do k=nlay,1,-1 + do ig=1,ngrid + if (zqla(ig,k).gt.1e-10) then + nivcon(ig)=k + zcon(ig)=zlev(ig,k) + endif + enddo + enddo + if (prt_level.ge.1) print*,'14c OK convect8' +!calcul des moments +!initialisation + do l=1,nlay + do ig=1,ngrid + q2(ig,l)=0. + wth2(ig,l)=0. + wth3(ig,l)=0. + ratqscth(ig,l)=0. + ratqsdiff(ig,l)=0. + enddo + enddo + if (prt_level.ge.1) print*,'14d OK convect8' + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main wth2=0. si zw2 > 1.e-10' + do l=1,nlay + do ig=1,ngrid + zf=fraca(ig,l) + zf2=zf/(1.-zf) +! + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2 + if(zw2(ig,l).gt.1.e-10) then + wth2(ig,l)=zf2*(zw2(ig,l))**2 + else + wth2(ig,l)=0. + endif +! print*,'wth2=',wth2(ig,l) + wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l)) & + & *zw2(ig,l)*zw2(ig,l)*zw2(ig,l) + q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 +!test: on calcul q2/po=ratqsc + ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.)) + enddo + enddo + + if (prt_level.ge.10) then + print*,'14e OK convect8 ig,l,zf,zf2',ig,l,zf,zf2 + ig=igout + do l=1,nlay + print*,'14f OK convect8 ig,l,zha zh zpspsk ',ig,l,zha(ig,l),zh(ig,l),zpspsk(ig,l) + enddo + do l=1,nlay + print*,'14g OK convect8 ig,l,po',ig,l,po(ig,l) + enddo + endif + + do ig=1,ngrid + alp_int(ig)=0. + ale_int(ig)=0. + n_int(ig)=0 + enddo +! + do l=1,nlay + do ig=1,ngrid + if(l.LE.lmax(ig)) THEN + alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l) + ale_int(ig)=ale_int(ig)+0.5*zw2(ig,l)**2 + n_int(ig)=n_int(ig)+1 + endif + enddo + enddo +! print*,'avant calcul ale et alp' +!calcul de ALE et ALP pour la convection + do ig=1,ngrid +! Alp_bl(ig)=0.5*rhobarz(ig,lmix_bis(ig))*wth3(ig,lmix(ig)) +! Alp_bl(ig)=0.5*rhobarz(ig,nivcon(ig))*wth3(ig,nivcon(ig)) +! Alp_bl(ig)=0.5*rhobarz(ig,lmix(ig))*wth3(ig,lmix(ig)) +! & *0.1 +!valeur integree de alp_bl * 0.5: + if (n_int(ig).gt.0) then + Alp_bl(ig)=0.5*alp_int(ig)/n_int(ig) +! if (Alp_bl(ig).lt.0.) then +! Alp_bl(ig)=0. + endif +! endif +! write(18,*),'rhobarz,wth3,Alp',rhobarz(ig,nivcon(ig)), +! s wth3(ig,nivcon(ig)),Alp_bl(ig) +! write(18,*),'ALP_BL',Alp_bl(ig),lmix(ig) +! Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2 +! if (nivcon(ig).eq.1) then +! Ale_bl(ig)=0. +! else +!valeur max de ale_bl: + Ale_bl(ig)=0.5*zw2(ig,lmix(ig))**2 +! & /2. +! & *0.1 +! Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2 +! if (n_int(ig).gt.0) then +! Ale_bl(ig)=ale_int(ig)/n_int(ig) +! Ale_bl(ig)=4. +! endif +! endif +! Ale_bl(ig)=0.5*wth2(ig,lmix_bis(ig)) +! Ale_bl(ig)=wth2(ig,nivcon(ig)) +! write(19,*),'wth2,ALE_BL',wth2(ig,nivcon(ig)),Ale_bl(ig) + enddo +!test:calcul de la ponderation des couches pour KE +!initialisations +! print*,'ponderation' + do ig=1,ngrid + fm_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + wght_th(ig,k)=1. + enddo + enddo + do ig=1,ngrid +! lalim_conv(ig)=lmix_bis(ig) +!la hauteur de la couche alim_conv = hauteur couche alim_therm + lalim_conv(ig)=lalim(ig) +! zentr(ig)=zlev(ig,lalim(ig)) + enddo + do ig=1,ngrid + do k=1,lalim_conv(ig) + fm_tot(ig)=fm_tot(ig)+fm(ig,k) + enddo + enddo + do ig=1,ngrid + do k=1,lalim_conv(ig) + if (fm_tot(ig).gt.1.e-10) then +! wght_th(ig,k)=fm(ig,k)/fm_tot(ig) + endif +!on pondere chaque couche par a* + if (alim_star(ig,k).gt.1.e-10) then + wght_th(ig,k)=alim_star(ig,k) + else + wght_th(ig,k)=1. + endif + enddo + enddo +! print*,'apres wght_th' +!test pour prolonger la convection + do ig=1,ngrid +!v1d if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then + if ((alim_star(ig,1).lt.1.e-10)) then + lalim_conv(ig)=1 + wght_th(ig,1)=1. +! print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1) + endif + enddo + +!calcul du ratqscdiff + if (prt_level.ge.1) print*,'14e OK convect8' + var=0. + vardiff=0. + ratqsdiff(:,:)=0. + do ig=1,ngrid + do l=1,lalim(ig) + var=var+alim_star(ig,l)*zqta(ig,l)*1000. + enddo + enddo + if (prt_level.ge.1) print*,'14f OK convect8' + do ig=1,ngrid + do l=1,lalim(ig) + zf=fraca(ig,l) + zf2=zf/(1.-zf) + vardiff=vardiff+alim_star(ig,l) & + & *(zqta(ig,l)*1000.-var)**2 +! ratqsdiff=ratqsdiff+alim_star(ig,l)* +! s (zqta(ig,l)*1000.-po(ig,l)*1000.)**2 + enddo + enddo + if (prt_level.ge.1) print*,'14g OK convect8' + do l=1,nlay + do ig=1,ngrid + ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.) +! write(11,*)'ratqsdiff=',ratqsdiff(ig,l) + enddo + enddo +!-------------------------------------------------------------------- +! +!ecriture des fichiers sortie +! print*,'15 OK convect8' + + if (prt_level.ge.1) print*,'thermcell_main sorties 3D' +#ifdef wrgrads_thermcell +#include "thermcell_out3d.h" +#endif + + endif + + if (prt_level.ge.1) print*,'thermcell_main FIN OK' + +! if(icount.eq.501) stop'au pas 301 dans thermcell_main' + return + end + +!----------------------------------------------------------------------------- + + subroutine testV0_ltherm(klon,klev,pplev,pplay,long,seuil,ztv,po,ztva,zqla,f_star,zw2,comment) + IMPLICIT NONE +#include "iniprint.h" + + integer i, k, klon,klev + real pplev(klon,klev+1),pplay(klon,klev) + real ztv(klon,klev) + real po(klon,klev) + real ztva(klon,klev) + real zqla(klon,klev) + real f_star(klon,klev) + real zw2(klon,klev) + integer long(klon) + real seuil + character*21 comment + + if (prt_level.ge.1) THEN + print*,'WARNING !!! TEST ',comment + endif + return + +! test sur la hauteur des thermiques ... + do i=1,klon +!IMtemp if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then + if (prt_level.ge.10) then + print*,'WARNING ',comment,' au point ',i,' K= ',long(i) + print*,' K P(MB) THV(K) Qenv(g/kg)THVA QLA(g/kg) F* W2' + do k=1,klev + write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k) + enddo + endif + enddo + + + return + end + +!============================================================================== + SUBROUTINE thermcellV0_closure(ngrid,nlay,r_aspect,ptimestep,rho, & + & zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out) + +!------------------------------------------------------------------------- +!thermcell_closure: fermeture, determination de f +!------------------------------------------------------------------------- + IMPLICIT NONE + +#include "iniprint.h" +#include "thermcell.h" + INTEGER ngrid,nlay + INTEGER ig,k + REAL r_aspect,ptimestep + integer lev_out ! niveau pour les print + + INTEGER lalim(ngrid) + REAL alim_star(ngrid,nlay) + REAL alim_star_tot(ngrid) + REAL rho(ngrid,nlay) + REAL zlev(ngrid,nlay) + REAL zmax(ngrid),zmax_sec(ngrid) + REAL wmax(ngrid),wmax_sec(ngrid) + real zdenom + + REAL alim_star2(ngrid) + + REAL f(ngrid) + + character (len=20) :: modname='thermcellV0_main' + character (len=80) :: abort_message + + do ig=1,ngrid + alim_star2(ig)=0. + enddo + do ig=1,ngrid + if (alim_star(ig,1).LT.1.e-10) then + f(ig)=0. + else + do k=1,lalim(ig) + alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2 & + & /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo + zdenom=max(500.,zmax(ig))*r_aspect*alim_star2(ig) + if (zdenom<1.e-14) then + print*,'ig=',ig + print*,'alim_star2',alim_star2(ig) + print*,'zmax',zmax(ig) + print*,'r_aspect',r_aspect + print*,'zdenom',zdenom + print*,'alim_star',alim_star(ig,:) + print*,'zmax_sec',zmax_sec(ig) + print*,'wmax_sec',wmax_sec(ig) + abort_message = 'zdenom<1.e-14' + CALL abort_gcm (modname,abort_message,1) + endif + if ((zmax_sec(ig).gt.1.e-10).and.(iflag_thermals_ed.eq.0)) then + f(ig)=wmax_sec(ig)*alim_star_tot(ig)/(max(500.,zmax_sec(ig))*r_aspect & + & *alim_star2(ig)) +! f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ & +! & zmax_sec(ig))*wmax_sec(ig)) + if(prt_level.GE.10) write(lunout,*)'closure dry',f(ig),wmax_sec(ig),alim_star_tot(ig),zmax_sec(ig) + else + f(ig)=wmax(ig)*alim_star_tot(ig)/zdenom +! f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ & +! & zmax(ig))*wmax(ig)) + if(prt_level.GE.10) print*,'closure moist',f(ig),wmax(ig),alim_star_tot(ig),zmax(ig) + endif + endif +! f0(ig)=f(ig) + enddo + if (prt_level.ge.1) print*,'apres fermeture' + +! + return + end +!============================================================================== + SUBROUTINE thermcellV0_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz, & + & zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot, & + & lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva, & + & ztla,zqla,zqta,zha,zw2,w_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + +!-------------------------------------------------------------------------- +!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance +!-------------------------------------------------------------------------- + + IMPLICIT NONE + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +#include "thermcell.h" + + INTEGER itap + INTEGER lunout1,igout + INTEGER ngrid,klev + REAL ptimestep + REAL ztv(ngrid,klev) + REAL zthl(ngrid,klev) + REAL po(ngrid,klev) + REAL zl(ngrid,klev) + REAL rhobarz(ngrid,klev) + REAL zlev(ngrid,klev+1) + REAL pplev(ngrid,klev+1) + REAL pphi(ngrid,klev) + REAL zpspsk(ngrid,klev) + REAL alim_star(ngrid,klev) + REAL zmax_sec(ngrid) + REAL f0(ngrid) + REAL l_mix + REAL r_aspect + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + real zcon2(ngrid) + + real alim_star_tot(ngrid) + + REAL ztva(ngrid,klev) + REAL ztla(ngrid,klev) + REAL zqla(ngrid,klev) + REAL zqla0(ngrid,klev) + REAL zqta(ngrid,klev) + REAL zha(ngrid,klev) + + REAL detr_star(ngrid,klev) + REAL coefc + REAL detr_stara(ngrid,klev) + REAL detr_starb(ngrid,klev) + REAL detr_starc(ngrid,klev) + REAL detr_star0(ngrid,klev) + REAL detr_star1(ngrid,klev) + REAL detr_star2(ngrid,klev) + + REAL entr_star(ngrid,klev) + REAL entr_star1(ngrid,klev) + REAL entr_star2(ngrid,klev) + REAL detr(ngrid,klev) + REAL entr(ngrid,klev) + + REAL zw2(ngrid,klev+1) + REAL w_est(ngrid,klev+1) + REAL f_star(ngrid,klev+1) + REAL wa_moy(ngrid,klev+1) + + REAL ztva_est(ngrid,klev) + REAL zqla_est(ngrid,klev) + REAL zqsatth(ngrid,klev) + REAL zta_est(ngrid,klev) + + REAL linter(ngrid) + INTEGER lmix(ngrid) + INTEGER lmix_bis(ngrid) + REAL wmaxa(ngrid) + + INTEGER ig,l,k + + real zcor,zdelta,zcvm5,qlbef + real Tbef,qsatbef + real dqsat_dT,DT,num,denom + REAL REPS,RLvCp,DDT0 + PARAMETER (DDT0=.01) + logical Zsat + REAL fact_gamma,fact_epsilon + REAL c2(ngrid,klev) + + Zsat=.false. +! Initialisation + RLvCp = RLVTT/RCPD + + if (iflag_thermals_ed==0) then + fact_gamma=1. + fact_epsilon=1. + else if (iflag_thermals_ed==1) then + fact_gamma=1. + fact_epsilon=1. + else if (iflag_thermals_ed==2) then + fact_gamma=1. + fact_epsilon=2. + endif + + do l=1,klev + do ig=1,ngrid + zqla_est(ig,l)=0. + ztva_est(ig,l)=ztva(ig,l) + zqsatth(ig,l)=0. + enddo + enddo + +!CR: attention test couche alim +! do l=2,klev +! do ig=1,ngrid +! alim_star(ig,l)=0. +! enddo +! enddo +!AM:initialisations du thermique + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + ztla(ig,k)=zthl(ig,k) + zqla(ig,k)=0. + zqta(ig,k)=po(ig,k) +! + ztva(ig,k) = ztla(ig,k)*zpspsk(ig,k)+RLvCp*zqla(ig,k) + ztva(ig,k) = ztva(ig,k)/zpspsk(ig,k) + zha(ig,k) = ztva(ig,k) +! + enddo + enddo + do k=1,klev + do ig=1,ngrid + detr_star(ig,k)=0. + entr_star(ig,k)=0. + + detr_stara(ig,k)=0. + detr_starb(ig,k)=0. + detr_starc(ig,k)=0. + detr_star0(ig,k)=0. + zqla0(ig,k)=0. + detr_star1(ig,k)=0. + detr_star2(ig,k)=0. + entr_star1(ig,k)=0. + entr_star2(ig,k)=0. + + detr(ig,k)=0. + entr(ig,k)=0. + enddo + enddo + if (prt_level.ge.1) print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + w_est(ig,k)=0. + f_star(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + + if (prt_level.ge.1) print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmix(ig)=1 + lmix_bis(ig)=2 + wmaxa(ig)=0. + enddo + +!----------------------------------------------------------------------------------- +!boucle de calcul de la vitesse verticale dans le thermique +!----------------------------------------------------------------------------------- + do l=1,klev-1 + do ig=1,ngrid + + + +! Calcul dans la premiere couche active du thermique (ce qu'on teste +! en disant que la couche est instable et que w2 en bas de la couche +! est nulle. + + if (ztv(ig,l).gt.ztv(ig,l+1) & + & .and.alim_star(ig,l).gt.1.e-10 & + & .and.zw2(ig,l).lt.1e-10) then + + +! Le panache va prendre au debut les caracteristiques de l'air contenu +! dans cette couche. + ztla(ig,l)=zthl(ig,l) + zqta(ig,l)=po(ig,l) + zqla(ig,l)=zl(ig,l) + f_star(ig,l+1)=alim_star(ig,l) + + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) & + & *(zlev(ig,l+1)-zlev(ig,l)) & + & *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + w_est(ig,l+1)=zw2(ig,l+1) +! + + + else if ((zw2(ig,l).ge.1e-10).and. & + & (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then +!estimation du detrainement a partir de la geometrie du pas precedent +!tests sur la definition du detr +!calcul de detr_star et entr_star + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH le test miraculeux de Catherine ? Le bout du tunel ? +! w_est(ig,3)=zw2(ig,2)* & +! & ((f_star(ig,2))**2) & +! & /(f_star(ig,2)+alim_star(ig,2))**2+ & +! & 2.*RG*(ztva(ig,1)-ztv(ig,2))/ztv(ig,2) & +! & *(zlev(ig,3)-zlev(ig,2)) +! if (l.gt.2) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +! Premier calcul de la vitesse verticale a partir de la temperature +! potentielle virtuelle + +! FH CESTQUOI CA ???? +#define int1d2 +!#undef int1d2 +#ifdef int1d2 + if (l.ge.2) then +#else + if (l.gt.2) then +#endif + + if (1.eq.1) then + w_est(ig,3)=zw2(ig,2)* & + & ((f_star(ig,2))**2) & + & /(f_star(ig,2)+alim_star(ig,2))**2+ & + & 2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) & +! & *1./3. & + & *(zlev(ig,3)-zlev(ig,2)) + endif + + +!--------------------------------------------------------------------------- +!calcul de l entrainement et du detrainement lateral +!--------------------------------------------------------------------------- +! +!test:estimation de ztva_new_est sans entrainement + + Tbef=ztla(ig,l-1)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + Zsat = (max(0.,zqta(ig,l-1)-qsatbef) .gt. 1.e-10) + if (Zsat) then + qlbef=max(0.,zqta(ig,l-1)-qsatbef) + DT = 0.5*RLvCp*qlbef + do while (abs(DT).gt.DDT0) + Tbef=Tbef+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=zqta(ig,l-1)-qsatbef + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef) + dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor) + num=-Tbef+ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo + zqla_est(ig,l) = max(0.,zqta(ig,l-1)-qsatbef) + endif + ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) + zta_est(ig,l)=ztva_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & + & -zqla_est(ig,l))-zqla_est(ig,l)) + + w_est(ig,l+1)=zw2(ig,l)* & + & ((f_star(ig,l))**2) & + & /(f_star(ig,l)+alim_star(ig,l))**2+ & + & 2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & +! & *1./3. & + & *(zlev(ig,l+1)-zlev(ig,l)) + if (w_est(ig,l+1).lt.0.) then + w_est(ig,l+1)=zw2(ig,l) + endif +! +!calcul du detrainement +!======================= + +!CR:on vire les modifs + if (iflag_thermals_ed==0) then + +! Modifications du calcul du detrainement. +! Dans la version de la these de Catherine, on passe brusquement +! de la version seche a la version nuageuse pour le detrainement +! ce qui peut occasioner des oscillations. +! dans la nouvelle version, on commence par calculer un detrainement sec. +! Puis un autre en cas de nuages. +! Puis on combine les deux lineairement en fonction de la quantite d'eau. + +#define int1d3 +!#undef int1d3 +#define RIO_TH +#ifdef RIO_TH +!1. Cas non nuageux +! 1.1 on est sous le zmax_sec et w croit + if ((w_est(ig,l+1).gt.w_est(ig,l)).and. & + & (zlev(ig,l+1).lt.zmax_sec(ig)).and. & +#ifdef int1d3 + & (zqla_est(ig,l).lt.1.e-10)) then +#else + & (zqla(ig,l-1).lt.1.e-10)) then +#endif + detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1) & + & *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1)) & + & -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l))) & + & /(r_aspect*zmax_sec(ig))) + detr_stara(ig,l)=detr_star(ig,l) + + if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l',ig,l + +! 1.2 on est sous le zmax_sec et w decroit + else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and. & +#ifdef int1d3 + & (zqla_est(ig,l).lt.1.e-10)) then +#else + & (zqla(ig,l-1).lt.1.e-10)) then +#endif + detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig)) & + & /(rhobarz(ig,lmix(ig))*wmaxa(ig))* & + & (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1)) & + & *((zmax_sec(ig)-zlev(ig,l+1))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2. & + & -rhobarz(ig,l)*sqrt(w_est(ig,l)) & + & *((zmax_sec(ig)-zlev(ig,l))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.) + detr_starb(ig,l)=detr_star(ig,l) + + if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l',ig,l + + else + +! 1.3 dans les autres cas + detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + detr_starc(ig,l)=detr_star(ig,l) + + if (prt_level.ge.20) print*,'coucou calcul detr 3 n: ig, l',ig, l + + endif + +#else + +! 1.1 on est sous le zmax_sec et w croit + if ((w_est(ig,l+1).gt.w_est(ig,l)).and. & + & (zlev(ig,l+1).lt.zmax_sec(ig)) ) then + detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1) & + & *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1)) & + & -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l))) & + & /(r_aspect*zmax_sec(ig))) + + if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l + +! 1.2 on est sous le zmax_sec et w decroit + else if ((zlev(ig,l+1).lt.zmax_sec(ig)) ) then + detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig)) & + & /(rhobarz(ig,lmix(ig))*wmaxa(ig))* & + & (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1)) & + & *((zmax_sec(ig)-zlev(ig,l+1))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2. & + & -rhobarz(ig,l)*sqrt(w_est(ig,l)) & + & *((zmax_sec(ig)-zlev(ig,l))/ & + & ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.) + if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l + + else + detr_star=0. + endif + +! 1.3 dans les autres cas + detr_starc(ig,l)=0.002*f0(ig)*f_star(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + + coefc=min(zqla(ig,l-1)/1.e-3,1.) + if (zlev(ig,l+1).ge.zmax_sec(ig)) coefc=1. + coefc=1. +! il semble qu'il soit important de baser le calcul sur +! zqla_est(ig,l-1) plutot que sur zqla_est(ig,l) + detr_star(ig,l)=detr_starc(ig,l)*coefc+detr_star(ig,l)*(1.-coefc) + + if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l', ig, l + +#endif + + + if (prt_level.ge.20) print*,'coucou calcul detr 444: ig, l', ig, l +!IM 730508 beg +! if(itap.GE.7200) THEN +! print*,'th_plume ig,l,itap,zqla_est=',ig,l,itap,zqla_est(ig,l) +! endif +!IM 730508 end + + zqla0(ig,l)=zqla_est(ig,l) + detr_star0(ig,l)=detr_star(ig,l) +!IM 060508 beg +! if(detr_star(ig,l).GT.1.) THEN +! print*,'th_plumeBEF ig l detr_star detr_starc coefc',ig,l,detr_star(ig,l) & +! & ,detr_starc(ig,l),coefc +! endif +!IM 060508 end +!IM 160508 beg +!IM 160508 IF (f0(ig).NE.0.) THEN + detr_star(ig,l)=detr_star(ig,l)/f0(ig) +!IM 160508 ELSE IF(detr_star(ig,l).EQ.0.) THEN +!IM 160508 print*,'WARNING1 : th_plume f0=0, detr_star=0: ig, l, itap',ig,l,itap +!IM 160508 ELSE +!IM 160508 print*,'WARNING2 : th_plume f0=0, ig, l, itap, detr_star',ig,l,itap,detr_star(ig,l) +!IM 160508 ENDIF +!IM 160508 end +!IM 060508 beg +! if(detr_star(ig,l).GT.1.) THEN +! print*,'th_plumeAFT ig l detr_star f0 1/f0',ig,l,detr_star(ig,l),f0(ig), & +! & REAL(1)/f0(ig) +! endif +!IM 060508 end + if (prt_level.ge.20) print*,'coucou calcul detr 445: ig, l', ig, l +! +!calcul de entr_star + +! #undef test2 +! #ifdef test2 +! La version test2 destabilise beaucoup le modele. +! Il semble donc que ca aide d'avoir un entrainement important sous +! le nuage. +! if (zqla_est(ig,l-1).ge.1.e-10.and.l.gt.lalim(ig)) then +! entr_star(ig,l)=0.4*detr_star(ig,l) +! else +! entr_star(ig,l)=0. +! endif +! #else +! +! Deplacement du calcul de entr_star pour eviter d'avoir aussi +! entr_star > fstar. +! Redeplacer suite a la transformation du cas detr>f +! FH + + if (prt_level.ge.20) print*,'coucou calcul detr 446: ig, l', ig, l +#define int1d +!FH 070508 #define int1d4 +!#undef int1d4 +! L'option int1d4 correspond au choix dans le cas ou le detrainement +! devient trop grand. + +#ifdef int1d + +#ifdef int1d4 +#else + detr_star(ig,l)=min(detr_star(ig,l),f_star(ig,l)) +!FH 070508 plus + detr_star(ig,l)=min(detr_star(ig,l),1.) +#endif + + entr_star(ig,l)=max(0.4*detr_star(ig,l)-alim_star(ig,l),0.) + + if (prt_level.ge.20) print*,'coucou calcul detr 447: ig, l', ig, l +#ifdef int1d4 +! Si le detrainement excede le flux en bas + l'entrainement, le thermique +! doit disparaitre. + if (detr_star(ig,l)>f_star(ig,l)+entr_star(ig,l)) then + detr_star(ig,l)=f_star(ig,l)+entr_star(ig,l) + f_star(ig,l+1)=0. + linter(ig)=l+1 + zw2(ig,l+1)=-1.e-10 + endif +#endif + + +#else + + if (prt_level.ge.20) print*,'coucou calcul detr 448: ig, l', ig, l + if(l.gt.lalim(ig)) then + entr_star(ig,l)=0.4*detr_star(ig,l) + else + +! FH : +! Cette ligne doit permettre de garantir qu'on a toujours un flux = 1 +! en haut de la couche d'alimentation. +! A remettre en questoin a la premiere occasion mais ca peut aider a +! ecrire un code robuste. +! Que ce soit avec ca ou avec l'ancienne facon de faire (e* = 0 mais +! d* non nul) on a une discontinuité de e* ou d* en haut de la couche +! d'alimentation, ce qui n'est pas forcement heureux. + + if (prt_level.ge.20) print*,'coucou calcul detr 449: ig, l', ig, l +#undef pre_int1c +#ifdef pre_int1c + entr_star(ig,l)=max(detr_star(ig,l)-alim_star(ig,l),0.) + detr_star(ig,l)=entr_star(ig,l) +#else + entr_star(ig,l)=0. +#endif + + endif + +#endif + + if (prt_level.ge.20) print*,'coucou calcul detr 440: ig, l', ig, l + entr_star1(ig,l)=entr_star(ig,l) + detr_star1(ig,l)=detr_star(ig,l) +! + +#ifdef int1d +#else + if (detr_star(ig,l).gt.f_star(ig,l)) then + +! Ce test est là entre autres parce qu'on passe par des valeurs +! delirantes de detr_star. +! ca vaut sans doute le coup de verifier pourquoi. + + detr_star(ig,l)=f_star(ig,l) +#ifdef pre_int1c + if (l.gt.lalim(ig)+1) then + entr_star(ig,l)=0. + alim_star(ig,l)=0. +! FH ajout pour forcer a stoper le thermique juste sous le sommet +! de la couche (voir calcul de finter) + zw2(ig,l+1)=-1.e-10 + linter(ig)=l+1 + else + entr_star(ig,l)=0.4*detr_star(ig,l) + endif +#else + entr_star(ig,l)=0.4*detr_star(ig,l) +#endif + endif +#endif + + else !l > 2 + detr_star(ig,l)=0. + entr_star(ig,l)=0. + endif + + entr_star2(ig,l)=entr_star(ig,l) + detr_star2(ig,l)=detr_star(ig,l) + if (prt_level.ge.20) print*,'coucou calcul detr 450: ig, l', ig, l + + endif ! iflag_thermals_ed==0 + +!CR:nvlle def de entr_star et detr_star + if (iflag_thermals_ed>=1) then +! if (l.lt.lalim(ig)) then +! if (l.lt.2) then +! entr_star(ig,l)=0. +! detr_star(ig,l)=0. +! else +! if (0.001.gt.(RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))/(2.*w_est(ig,l+1)))) then +! entr_star(ig,l)=0.001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) +! else +! entr_star(ig,l)= & +! & f_star(ig,l)/(2.*w_est(ig,l+1)) & +! & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)) & +! & *(zlev(ig,l+1)-zlev(ig,l)) + + + entr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)), & + & f_star(ig,l)/(2.*w_est(ig,l+1)) & + & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l))) & + & +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + + if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then + alim_star_tot(ig)=alim_star_tot(ig)+entr_star(ig,l) + lalim(ig)=lmix_bis(ig) + if(prt_level.GE.10) print*,'alim_star_tot',alim_star_tot(ig),entr_star(ig,l) + endif + + if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then +! c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l)) + c2(ig,l)=0.001 + detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)), & + & c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) & + & -f_star(ig,l)/(2.*w_est(ig,l+1)) & + & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l))) & + & +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + + else +! c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l)) + c2(ig,l)=0.003 + + detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)), & + & c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) & + & -f_star(ig,l)/(2.*w_est(ig,l+1)) & + & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l))) & + & +0.0002*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + endif + + +! detr_star(ig,l)=detr_star(ig,l)*3. +! if (l.lt.lalim(ig)) then +! entr_star(ig,l)=0. +! endif +! if (l.lt.2) then +! entr_star(ig,l)=0. +! detr_star(ig,l)=0. +! endif + + +! endif +! else if ((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10) then +! entr_star(ig,l)=MAX(0.,0.8*f_star(ig,l)/(2.*w_est(ig,l+1)) & +! & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! detr_star(ig,l)=0.002*f_star(ig,l) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! else +! entr_star(ig,l)=0.001*f_star(ig,l) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! detr_star(ig,l)=MAX(0.,-0.2*f_star(ig,l)/(2.*w_est(ig,l+1)) & +! & *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)) & +! & *(zlev(ig,l+1)-zlev(ig,l)) & +! & +0.002*f_star(ig,l) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +! endif + + endif ! iflag_thermals_ed==1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH inutile si on conserve comme on l'a fait plus haut entr=detr +! dans la couche d'alimentation +!pas d entrainement dans la couche alim +! if ((l.le.lalim(ig))) then +! entr_star(ig,l)=0. +! endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!prise en compte du detrainement et de l entrainement dans le calcul du flux + + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & + & -detr_star(ig,l) + +!test sur le signe de f_star + if (prt_level.ge.20) print*,'coucou calcul detr 451: ig, l', ig, l + if (f_star(ig,l+1).gt.1.e-10) then +!---------------------------------------------------------------------------- +!calcul de la vitesse verticale en melangeant Tl et qt du thermique +!--------------------------------------------------------------------------- +! + Zsat=.false. + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) +! + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) +! + Tbef=ztla(ig,l)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + Zsat = (max(0.,zqta(ig,l)-qsatbef) .gt. 1.e-10) + if (Zsat) then + qlbef=max(0.,zqta(ig,l)-qsatbef) + DT = 0.5*RLvCp*qlbef + do while (abs(DT).gt.DDT0) + Tbef=Tbef+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=zqta(ig,l)-qsatbef + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef) + dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor) + num=-Tbef+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo + zqla(ig,l) = max(0.,qlbef) + endif +! + if (prt_level.ge.20) print*,'coucou calcul detr 4512: ig, l', ig, l +! on ecrit de maniere conservative (sat ou non) +! T = Tl +Lv/Cp ql + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +!on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & + & -zqla(ig,l))-zqla(ig,l)) + +!on ecrit zqsat + zqsatth(ig,l)=qsatbef +!calcul de vitesse + zw2(ig,l+1)=zw2(ig,l)* & + & ((f_star(ig,l))**2) & +! Tests de Catherine +! & /(f_star(ig,l+1)+detr_star(ig,l))**2+ & + & /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-fact_epsilon))**2+ & + & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *fact_gamma & + & *(zlev(ig,l+1)-zlev(ig,l)) +!prise en compte des forces de pression que qd flottabilité<0 +! zw2(ig,l+1)=zw2(ig,l)* & +! & 1./(1.+2.*entr_star(ig,l)/f_star(ig,l)) + & +! & (f_star(ig,l))**2 & +! & /(f_star(ig,l)+entr_star(ig,l))**2+ & +! & (f_star(ig,l)-2.*entr_star(ig,l))**2/(f_star(ig,l)+2.*entr_star(ig,l))**2+ & +! & /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-2.))**2+ & +! & /(f_star(ig,l)**2+2.*2.*detr_star(ig,l)*f_star(ig,l)+2.*entr_star(ig,l)*f_star(ig,l))+ & +! & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & +! & *1./3. & +! & *(zlev(ig,l+1)-zlev(ig,l)) + +! write(30,*),l+1,zw2(ig,l+1)-zw2(ig,l), & +! & -2.*entr_star(ig,l)/f_star(ig,l)*zw2(ig,l), & +! & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + + +! zw2(ig,l+1)=zw2(ig,l)* & +! & (2.-2.*entr_star(ig,l)/f_star(ig,l)) & +! & -zw2(ig,l-1)+ & +! & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & +! & *1./3. & +! & *(zlev(ig,l+1)-zlev(ig,l)) + + endif + endif + if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l +! +!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max + + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then + print*,'On tombe sur le cas particulier de thermcell_plume' + zw2(ig,l+1)=0. + linter(ig)=l+1 + endif + +! if ((zw2(ig,l).gt.0.).and. (zw2(ig,l+1).le.0.)) then + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum +!on rajoute le calcul de lmix_bis + if (zqla(ig,l).lt.1.e-10) then + lmix_bis(ig)=l+1 + endif + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + +!on remplace a* par e* ds premiere couche +! if (iflag_thermals_ed.ge.1) then +! do ig=1,ngrid +! do l=2,klev +! if (l.lt.lalim(ig)) then +! alim_star(ig,l)=entr_star(ig,l) +! endif +! enddo +! enddo +! do ig=1,ngrid +! lalim(ig)=lmix_bis(ig) +! enddo +! endif + if (iflag_thermals_ed.ge.1) then + do ig=1,ngrid + do l=2,lalim(ig) + alim_star(ig,l)=entr_star(ig,l) + entr_star(ig,l)=0. + enddo + enddo + endif + if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l + +! print*,'thermcell_plume OK' + + return + end +!============================================================================== + SUBROUTINE thermcellV0_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax,wmax,lev_out) + +!-------------------------------------------------------------------------- +!thermcell_dry: calcul de zmax et wmax du thermique sec +!-------------------------------------------------------------------------- + IMPLICIT NONE +#include "YOMCST.h" +#include "iniprint.h" + INTEGER l,ig + + INTEGER ngrid,nlay + REAL zlev(ngrid,nlay+1) + REAL pphi(ngrid,nlay) + REAl ztv(ngrid,nlay) + REAL alim_star(ngrid,nlay) + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + + REAL zmax(ngrid) + REAL wmax(ngrid) + +!variables locales + REAL zw2(ngrid,nlay+1) + REAL f_star(ngrid,nlay+1) + REAL ztva(ngrid,nlay+1) + REAL wmaxa(ngrid) + REAL wa_moy(ngrid,nlay+1) + REAL linter(ngrid),zlevinter(ngrid) + INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid) + +!initialisations + do ig=1,ngrid + do l=1,nlay+1 + zw2(ig,l)=0. + wa_moy(ig,l)=0. + enddo + enddo + do ig=1,ngrid + do l=1,nlay + ztva(ig,l)=ztv(ig,l) + enddo + enddo + do ig=1,ngrid + wmax(ig)=0. + wmaxa(ig)=0. + enddo +!calcul de la vitesse a partir de la CAPE en melangeant thetav + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! A eliminer +! Ce if complique etait fait pour reperer la premiere couche instable +! Ici, c'est lmin. +! +! do l=1,nlay-2 +! do ig=1,ngrid +! if (ztv(ig,l).gt.ztv(ig,l+1) & +! & .and.alim_star(ig,l).gt.1.e-10 & +! & .and.zw2(ig,l).lt.1e-10) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +! Calcul des F^*, integrale verticale de E^* + f_star(:,1)=0. + do l=1,nlay + f_star(:,l+1)=f_star(:,l)+alim_star(:,l) + enddo + +! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise + linter(:)=0. + +! couche la plus haute concernee par le thermique. + lmax(:)=1 + +! Le niveau linter est une variable continue qui se trouve dans la couche +! lmax + + do l=1,nlay-2 + do ig=1,ngrid + if (l.eq.lmin(ig).and.lalim(ig).gt.1) then + +!------------------------------------------------------------------------ +! Calcul de la vitesse en haut de la premiere couche instable. +! Premiere couche du panache thermique +!------------------------------------------------------------------------ + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) & + & *(zlev(ig,l+1)-zlev(ig,l)) & + & *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + +!------------------------------------------------------------------------ +! Tant que la vitesse en bas de la couche et la somme du flux de masse +! et de l'entrainement (c'est a dire le flux de masse en haut) sont +! positifs, on calcul +! 1. le flux de masse en haut f_star(ig,l+1) +! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l) +! 3. la vitesse au carré en haut zw2(ig,l+1) +!------------------------------------------------------------------------ + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! A eliminer : dans cette version, si zw2 est > 0 on a un therique. +! et donc, au dessus, f_star(ig,l+1) est forcement suffisamment +! grand puisque on n'a pas de detrainement. +! f_star est une fonction croissante. +! c'est donc vraiment sur zw2 uniquement qu'il faut faire le test. +! else if ((zw2(ig,l).ge.1e-10).and. & +! & (f_star(ig,l)+alim_star(ig,l).gt.1.e-10)) then +! f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + else if (zw2(ig,l).ge.1e-10) then + + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l) & + & *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ & + & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + endif +! determination de zmax continu par interpolation lineaire +!------------------------------------------------------------------------ + + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! print*,'On tombe sur le cas particulier de thermcell_dry' + zw2(ig,l+1)=0. + linter(ig)=l+1 + lmax(ig)=l + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmax(ig)=l + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + if (prt_level.ge.1) print*,'fin calcul zw2' +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! A eliminer : +! Ce calcul de lmax est fait en meme temps que celui de linter, plus haut +! Calcul de la couche correspondant a la hauteur du thermique +! do ig=1,ngrid +! lmax(ig)=lalim(ig) +! enddo +! do ig=1,ngrid +! do l=nlay,lalim(ig)+1,-1 +! if (zw2(ig,l).le.1.e-10) then +! lmax(ig)=l-1 +! endif +! enddo +! enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! +! Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +! Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +! calcul de zlevinter + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH A eliminer +! Simplification +! zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* & +! & linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) & +! & -zlev(ig,lmax(ig))) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + zlevinter(ig)=zlev(ig,lmax(ig)) + & + & (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + +! Verification que lalim<=lmax + do ig=1,ngrid + if(lalim(ig)>lmax(ig)) then + if ( prt_level > 1 ) THEN + print*,'WARNING thermcell_dry ig=',ig,' lalim=',lalim(ig),' lmax(ig)=',lmax(ig) + endif + lmax(ig)=lalim(ig) + endif + enddo + + RETURN + END +!============================================================================== + SUBROUTINE thermcellV0_init(ngrid,nlay,ztv,zlay,zlev, & + & lalim,lmin,alim_star,alim_star_tot,lev_out) + +!---------------------------------------------------------------------- +!thermcell_init: calcul du profil d alimentation du thermique +!---------------------------------------------------------------------- + IMPLICIT NONE +#include "iniprint.h" +#include "thermcell.h" + + INTEGER l,ig +!arguments d entree + INTEGER ngrid,nlay + REAL ztv(ngrid,nlay) + REAL zlay(ngrid,nlay) + REAL zlev(ngrid,nlay+1) +!arguments de sortie + INTEGER lalim(ngrid) + INTEGER lmin(ngrid) + REAL alim_star(ngrid,nlay) + REAL alim_star_tot(ngrid) + integer lev_out ! niveau pour les print + + REAL zzalim(ngrid) +!CR: ponderation entrainement des couches instables +!def des alim_star tels que alim=f*alim_star + + do l=1,nlay + do ig=1,ngrid + alim_star(ig,l)=0. + enddo + enddo +! determination de la longueur de la couche d entrainement + do ig=1,ngrid + lalim(ig)=1 + enddo + + if (iflag_thermals_ed.ge.1) then +!si la première couche est instable, on declenche un thermique + do ig=1,ngrid + if (ztv(ig,1).gt.ztv(ig,2)) then + lmin(ig)=1 + lalim(ig)=2 + alim_star(ig,1)=1. + alim_star_tot(ig)=alim_star(ig,1) + if(prt_level.GE.10) print*,'init',alim_star(ig,1),alim_star_tot(ig) + else + lmin(ig)=1 + lalim(ig)=1 + alim_star(ig,1)=0. + alim_star_tot(ig)=0. + endif + enddo + + else +!else iflag_thermals_ed=0 ancienne def de l alim + +!on ne considere que les premieres couches instables + do l=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. & + & ztv(ig,l+1).le.ztv(ig,l+2)) then + lalim(ig)=l+1 + endif + enddo + enddo + +! determination du lmin: couche d ou provient le thermique + + do ig=1,ngrid +! FH initialisation de lmin a nlay plutot que 1. +! lmin(ig)=nlay + lmin(ig)=1 + enddo + do l=nlay,2,-1 + do ig=1,ngrid + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +! + zzalim(:)=0. + do l=1,nlay-1 + do ig=1,ngrid + if (l1) then + zzalim(ig)=zlay(ig,1)+zzalim(ig)/(ztv(ig,1)-ztv(ig,lalim(ig))) + else + zzalim(ig)=zlay(ig,1) + endif + enddo + + if(prt_level.GE.10) print*,'ZZALIM LALIM ',zzalim,lalim,zlay(1,lalim(1)) + +! definition de l'entrainement des couches + if (1.eq.1) then + do l=1,nlay-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. & + & l.ge.lmin(ig).and.l.lt.lalim(ig)) then +!def possibles pour alim_star: zdthetadz, dthetadz, zdtheta + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & + & *sqrt(zlev(ig,l+1)) + endif + enddo + enddo + else + do l=1,nlay-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. & + & l.ge.lmin(ig).and.l.lt.lalim(ig)) then + alim_star(ig,l)=max(3.*zzalim(ig)-zlay(ig,l),0.) & + & *(zlev(ig,l+1)-zlev(ig,l)) + endif + enddo + enddo + endif + +! pas de thermique si couche 1 stable + do ig=1,ngrid +!CRnouveau test + if (alim_star(ig,1).lt.1.e-10) then + do l=1,nlay + alim_star(ig,l)=0. + enddo + lmin(ig)=1 + endif + enddo +! calcul de l alimentation totale + do ig=1,ngrid + alim_star_tot(ig)=0. + enddo + do l=1,nlay + do ig=1,ngrid + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + enddo + enddo +! +! Calcul entrainement normalise + do l=1,nlay + do ig=1,ngrid + if (alim_star_tot(ig).gt.1.e-10) then + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + endif + enddo + enddo + +!on remet alim_star_tot a 1 + do ig=1,ngrid + alim_star_tot(ig)=1. + enddo + + endif +!endif iflag_thermals_ed + return + end +!============================================================================== Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_closure.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_closure.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_closure.F90 (revision 1634) @@ -0,0 +1,82 @@ +! +! $Header$ +! + SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho, & + & zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out) + +!------------------------------------------------------------------------- +!thermcell_closure: fermeture, determination de f +! +! Modification 7 septembre 2009 +! 1. On enleve alim_star_tot des arguments pour le recalculer et etre ainis +! coherent avec l'integrale au numerateur. +! 2. On ne garde qu'une version des couples wmax,zmax et wmax_sec,zmax_sec +! l'idee etant que le choix se fasse a l'appel de thermcell_closure +! 3. Vectorisation en mettant les boucles en l l'exterieur avec des if +!------------------------------------------------------------------------- + IMPLICIT NONE + +#include "iniprint.h" +#include "thermcell.h" +INTEGER ngrid,nlay +INTEGER ig,k +REAL r_aspect,ptimestep +integer lev_out ! niveau pour les print + +INTEGER lalim(ngrid) +REAL alim_star(ngrid,nlay) +REAL f_star(ngrid,nlay+1) +REAL rho(ngrid,nlay) +REAL zlev(ngrid,nlay) +REAL zmax(ngrid) +REAL wmax(ngrid) +REAL zdenom(ngrid) +REAL alim_star2(ngrid) +REAL f(ngrid) + +REAL alim_star_tot(ngrid) +INTEGER llmax + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!print*,'THERMCELL CLOSURE 26E' + +alim_star2(:)=0. +alim_star_tot(:)=0. +f(:)=0. + +! Indice vertical max (max de lalim) atteint par les thermiques sur le domaine +llmax=1 +do ig=1,ngrid + if (lalim(ig)>llmax) llmax=lalim(ig) +enddo + + +! Calcul des integrales sur la verticale de alim_star et de +! alim_star^2/(rho dz) +do k=1,llmax-1 + do ig=1,ngrid + if (k1.e-10) then + f(ig)=wmax(ig)*alim_star_tot(ig)/ & +& (max(500.,zmax(ig))*r_aspect*alim_star2(ig)) + endif +enddo + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! TESTS POUR UNE NOUVELLE FERMETURE DANS LAQUELLE ALIM_STAR NE SERAIT +! PAS NORMALISE +! f(ig)=f(ig)*f_star(ig,2)/(f_star(ig,lalim(ig))) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_condens.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_condens.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_condens.F90 (revision 1634) @@ -0,0 +1,81 @@ +subroutine thermcell_condens(klon,active,zpspsk,pplev,ztla,zqta,zqla) +implicit none + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + + +!==================================================================== +! DECLARATIONS +!==================================================================== + +! Arguments +INTEGER klon +REAL zpspsk(klon),pplev(klon) +REAL ztla(klon),zqta(klon),zqla(klon) +LOGICAL active(klon) + +! Variables locales +INTEGER ig,iter +REAL Tbef(klon),DT(klon) +REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT +logical Zsat +REAL RLvCp +REAL, SAVE :: DDT0=.01 +LOGICAL afaire(klon),tout_converge + +!==================================================================== +! INITIALISATIONS +!==================================================================== + +RLvCp = RLVTT/RCPD +tout_converge=.false. +afaire(:)=.false. +DT(:)=0. + + +!==================================================================== +! Routine a vectoriser en copiant active dans converge et en mettant +! la boucle sur les iterations a l'exterieur est en mettant +! converge= false des que la convergence est atteinte. +!==================================================================== + +do ig=1,klon + if (active(ig)) then + Tbef(ig)=ztla(ig)*zpspsk(ig) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=max(0.,zqta(ig)-qsatbef) + DT(ig) = 0.5*RLvCp*qlbef + endif +enddo + +do iter=1,10 + afaire(:)=abs(DT(:)).gt.DDT0 + do ig=1,klon + if (afaire(ig)) then + Tbef(ig)=Tbef(ig)+DT(ig) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=zqta(ig)-qsatbef + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef,zcor) + num=-Tbef(ig)+ztla(ig)*zpspsk(ig)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + zqla(ig) = max(0.,zqta(ig)-qsatbef) + DT(ig)=num/denom + endif + enddo +enddo + +return +end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dq.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dq.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dq.F90 (revision 1634) @@ -0,0 +1,172 @@ + subroutine thermcell_dq(ngrid,nlay,ptimestep,fm,entr, & + & masse,q,dq,qa,lev_out) + implicit none + +#include "iniprint.h" +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +!======================================================================= + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + real dq(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) + + real zzm + + integer ig,k + real cfl + + real qold(ngrid,nlay) + real ztimestep + integer niter,iter + CHARACTER (LEN=20) :: modname='thermcell_dq' + CHARACTER (LEN=80) :: abort_message + + + +! Calcul du critere CFL pour l'advection dans la subsidence + cfl = 0. + do k=1,nlay + do ig=1,ngrid + zzm=masse(ig,k)/ptimestep + cfl=max(cfl,fm(ig,k)/zzm) + if (entr(ig,k).gt.zzm) then + print*,'entr dt > m ',entr(ig,k)*ptimestep,masse(ig,k) + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + endif + enddo + enddo + +!IM 090508 print*,'CFL CFL CFL CFL ',cfl + +#undef CFL +#ifdef CFL +! On subdivise le calcul en niter pas de temps. + niter=int(cfl)+1 +#else + niter=1 +#endif + + ztimestep=ptimestep/niter + qold=q + + +do iter=1,niter + if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' + +! calcul du detrainement + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) +! print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k) +!test + if (detr(ig,k).lt.0.) then + entr(ig,k)=entr(ig,k)-detr(ig,k) + detr(ig,k)=0. +! print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), +! s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) + endif + if (fm(ig,k+1).lt.0.) then +! print*,'fm2<0!!!' + endif + if (entr(ig,k).lt.0.) then +! print*,'entr2<0!!!' + endif + enddo + enddo + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ztimestep.gt. & + & 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +! print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +! print*,'q<0!!!' + endif + enddo + enddo + +! Calcul du flux subsident + + do k=2,nlay + do ig=1,ngrid +#undef centre +#ifdef centre + wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) +#else + +#define plusqueun +#ifdef plusqueun +! Schema avec advection sur plus qu'une maille. + zzm=masse(ig,k)/ztimestep + if (fm(ig,k)>zzm) then + wqd(ig,k)=zzm*q(ig,k)+(fm(ig,k)-zzm)*q(ig,k+1) + else + wqd(ig,k)=fm(ig,k)*q(ig,k) + endif +#else + wqd(ig,k)=fm(ig,k)*q(ig,k) +#endif +#endif + + if (wqd(ig,k).lt.0.) then +! print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & + & -wqd(ig,k)+wqd(ig,k+1)) & + & *ztimestep/masse(ig,k) +! if (dq(ig,k).lt.0.) then +! print*,'dq<0!!!' +! endif + enddo + enddo + + +enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep + q(ig,k)=qold(ig,k) + enddo + enddo + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dry.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dry.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dry.F90 (revision 1634) @@ -0,0 +1,166 @@ +! +! $Id$ +! + SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax,wmax,lev_out) + +!-------------------------------------------------------------------------- +!thermcell_dry: calcul de zmax et wmax du thermique sec +! Calcul de la vitesse maximum et de la hauteur maximum pour un panache +! ascendant avec une fonction d'alimentation alim_star et sans changement +! de phase. +! Le calcul pourrait etre sans doute simplifier. +! La temperature potentielle virtuelle dans la panache ascendant est +! la temperature potentielle virtuelle pondérée par alim_star. +!-------------------------------------------------------------------------- + + IMPLICIT NONE +#include "YOMCST.h" +#include "iniprint.h" + INTEGER l,ig + + INTEGER ngrid,nlay + REAL zlev(ngrid,nlay+1) + REAL pphi(ngrid,nlay) + REAl ztv(ngrid,nlay) + REAL alim_star(ngrid,nlay) + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + + REAL zmax(ngrid) + REAL wmax(ngrid) + +!variables locales + REAL zw2(ngrid,nlay+1) + REAL f_star(ngrid,nlay+1) + REAL ztva(ngrid,nlay+1) + REAL wmaxa(ngrid) + REAL wa_moy(ngrid,nlay+1) + REAL linter(ngrid),zlevinter(ngrid) + INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid) + CHARACTER (LEN=20) :: modname='thermcell_dry' + CHARACTER (LEN=80) :: abort_message + +!initialisations + do ig=1,ngrid + do l=1,nlay+1 + zw2(ig,l)=0. + wa_moy(ig,l)=0. + enddo + enddo + do ig=1,ngrid + do l=1,nlay + ztva(ig,l)=ztv(ig,l) + enddo + enddo + do ig=1,ngrid + wmax(ig)=0. + wmaxa(ig)=0. + enddo +!calcul de la vitesse a partir de la CAPE en melangeant thetav + + +! Calcul des F^*, integrale verticale de E^* + f_star(:,1)=0. + do l=1,nlay + f_star(:,l+1)=f_star(:,l)+alim_star(:,l) + enddo + +! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise + linter(:)=0. + +! couche la plus haute concernee par le thermique. + lmax(:)=1 + +! Le niveau linter est une variable continue qui se trouve dans la couche +! lmax + + do l=1,nlay-2 + do ig=1,ngrid + if (l.eq.lmin(ig).and.lalim(ig).gt.1) then + +!------------------------------------------------------------------------ +! Calcul de la vitesse en haut de la premiere couche instable. +! Premiere couche du panache thermique +!------------------------------------------------------------------------ + + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) & + & *(zlev(ig,l+1)-zlev(ig,l)) & + & *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + +!------------------------------------------------------------------------ +! Tant que la vitesse en bas de la couche et la somme du flux de masse +! et de l'entrainement (c'est a dire le flux de masse en haut) sont +! positifs, on calcul +! 1. le flux de masse en haut f_star(ig,l+1) +! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l) +! 3. la vitesse au carré en haut zw2(ig,l+1) +!------------------------------------------------------------------------ + + else if (zw2(ig,l).ge.1e-10) then + + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l) & + & *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ & + & 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + endif +! determination de zmax continu par interpolation lineaire +!------------------------------------------------------------------------ + + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_dry' + zw2(ig,l+1)=0. + linter(ig)=l+1 + lmax(ig)=l + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmax(ig)=l + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + if (prt_level.ge.1) print*,'fin calcul zw2' +! +! Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +! Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +! calcul de zlevinter + zlevinter(ig)=zlev(ig,lmax(ig)) + & + & (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dtke.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dtke.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dtke.F90 (revision 1634) @@ -0,0 +1,123 @@ + subroutine thermcell_dtke(ngrid,nlay,nsrf,ptimestep,fm0,entr0, & + & rg,pplev,tke) + implicit none + +#include "iniprint.h" +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +!======================================================================= + + integer ngrid,nlay,nsrf + + real ptimestep + real masse0(ngrid,nlay),fm0(ngrid,nlay+1),pplev(ngrid,nlay+1) + real entr0(ngrid,nlay),rg + real tke(ngrid,nlay,nsrf) + real detr0(ngrid,nlay) + + + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1) + + real zzm + + integer ig,k + integer isrf + + + lev_out=0 + + + if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0' + +! calcul du detrainement + do k=1,nlay + detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k) + masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG + enddo + + +! Decalage vertical des entrainements et detrainements. + masse(:,1)=0.5*masse0(:,1) + entr(:,1)=0.5*entr0(:,1) + detr(:,1)=0.5*detr0(:,1) + fm(:,1)=0. + do k=1,nlay-1 + masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1)) + entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1)) + detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1)) + fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k) + enddo + fm(:,nlay+1)=0. + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + + +do isrf=1,nsrf + + q(:,:)=tke(:,:,isrf) + + if (1==1) then + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. & + & 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +! print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +! print*,'q<0!!!' + endif + enddo + enddo + +! Calcul du flux subsident + + do k=2,nlay + do ig=1,ngrid + wqd(ig,k)=fm(ig,k)*q(ig,k) + if (wqd(ig,k).lt.0.) then +! print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + +! Calcul des tendances + do k=1,nlay + do ig=1,ngrid + q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) & + & -wqd(ig,k)+wqd(ig,k+1)) & + & *ptimestep/masse(ig,k) + enddo + enddo + + endif + + tke(:,:,isrf)=q(:,:) + +enddo + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dv2.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dv2.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_dv2.F90 (revision 1634) @@ -0,0 +1,193 @@ + subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse & + & ,fraca,larga & + & ,u,v,du,dv,ua,va,lev_out) + implicit none + +#include "iniprint.h" +!======================================================================= +! +! Calcul du transport verticale dans la couche limite en presence +! de "thermiques" explicitement representes +! calcul du dq/dt une fois qu'on connait les ascendances +! +! Vectorisation, FH : 2010/03/08 +! +!======================================================================= + + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real fraca(ngrid,nlay+1) + real larga(ngrid) + real entr(ngrid,nlay) + real u(ngrid,nlay) + real ua(ngrid,nlay) + real du(ngrid,nlay) + real v(ngrid,nlay) + real va(ngrid,nlay) + real dv(ngrid,nlay) + integer lev_out ! niveau pour les print + + real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2 + real wvd(ngrid,nlay+1),wud(ngrid,nlay+1) + real gamma0(ngrid,nlay+1),gamma(ngrid,nlay+1) + real ue(ngrid,nlay),ve(ngrid,nlay) + LOGICAL ltherm(ngrid,nlay) + real dua(ngrid,nlay),dva(ngrid,nlay) + integer iter + + integer ig,k,nlarga0 + +!------------------------------------------------------------------------- + +! calcul du detrainement +!--------------------------- + +! print*,'THERMCELL DV2 OPTIMISE 3' + + nlarga0=0. + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +! calcul de la valeur dans les ascendances + do ig=1,ngrid + ua(ig,1)=u(ig,1) + va(ig,1)=v(ig,1) + ue(ig,1)=u(ig,1) + ve(ig,1)=v(ig,1) + enddo + + IF(prt_level>9)WRITE(lunout,*) & + & 'WARNING on initialise gamma(1:ngrid,1)=0.' + gamma(1:ngrid,1)=0. + do k=2,nlay + do ig=1,ngrid + ltherm(ig,k)=(fm(ig,k+1)+detr(ig,k))*ptimestep > 1.e-5*masse(ig,k) + if(ltherm(ig,k).and.larga(ig)>0.) then + gamma0(ig,k)=masse(ig,k) & + & *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) & + & *0.5/larga(ig) & + & *1. + else + gamma0(ig,k)=0. + endif + if (ltherm(ig,k).and.larga(ig)<=0.) nlarga0=nlarga0+1 + enddo + enddo + + gamma(:,:)=0. + + do k=2,nlay + + do ig=1,ngrid + if (ltherm(ig,k)) then + dua(ig,k)=ua(ig,k-1)-u(ig,k-1) + dva(ig,k)=va(ig,k-1)-v(ig,k-1) + else + ua(ig,k)=u(ig,k) + va(ig,k)=v(ig,k) + ue(ig,k)=u(ig,k) + ve(ig,k)=v(ig,k) + endif + enddo + + +! Debut des iterations +!---------------------- +do iter=1,5 + do ig=1,ngrid +! Pour memoire : calcul prenant en compte la fraction reelle +! zf=0.5*(fraca(ig,k)+fraca(ig,k+1)) +! zf2=1./(1.-zf) +! Calcul avec fraction infiniement petite + zf=0. + zf2=1. + +! la première fois on multiplie le coefficient de freinage +! par le module du vent dans la couche en dessous. +! Mais pourquoi donc ??? + if (ltherm(ig,k)) then +! On choisit une relaxation lineaire. +! gamma(ig,k)=gamma0(ig,k) +! On choisit une relaxation quadratique. + gamma(ig,k)=gamma0(ig,k)*sqrt(dua(ig,k)**2+dva(ig,k)**2) + ua(ig,k)=(fm(ig,k)*ua(ig,k-1) & + & +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & + & +gamma(ig,k)) + va(ig,k)=(fm(ig,k)*va(ig,k-1) & + & +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k)) & + & /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 & + & +gamma(ig,k)) +! print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua(ig,k),dva(ig,k) + dua(ig,k)=ua(ig,k)-u(ig,k) + dva(ig,k)=va(ig,k)-v(ig,k) + ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2 + ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2 + endif + enddo +! Fin des iterations +!-------------------- +enddo + + enddo ! k=2,nlay + + +! Calcul du flux vertical de moment dans l'environnement. +!--------------------------------------------------------- + do k=2,nlay + do ig=1,ngrid + wud(ig,k)=fm(ig,k)*ue(ig,k) + wvd(ig,k)=fm(ig,k)*ve(ig,k) + enddo + enddo + do ig=1,ngrid + wud(ig,1)=0. + wud(ig,nlay+1)=0. + wvd(ig,1)=0. + wvd(ig,nlay+1)=0. + enddo + +! calcul des tendances. +!----------------------- + do k=1,nlay + do ig=1,ngrid + du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) & + & -(entr(ig,k)+gamma(ig,k))*ue(ig,k) & + & -wud(ig,k)+wud(ig,k+1)) & + & /masse(ig,k) + dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) & + & -(entr(ig,k)+gamma(ig,k))*ve(ig,k) & + & -wvd(ig,k)+wvd(ig,k+1)) & + & /masse(ig,k) + enddo + enddo + + +! Sorties eventuelles. +!---------------------- + + if(prt_level.GE.10) then + do k=1,nlay + do ig=1,ngrid + print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), & + & entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), & + & masse(ig,k) + enddo + enddo + endif +! + if (nlarga0>0) then + print*,'WARNING !!!!!! DANS THERMCELL_DV2 ' + print*,nlarga0,' points pour lesquels laraga=0. dans un thermique' + print*,'Il faudrait decortiquer ces points' + endif + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_env.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_env.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_env.F90 (revision 1634) @@ -0,0 +1,98 @@ + SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & + & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lev_out) + +!-------------------------------------------------------------- +!thermcell_env: calcule les caracteristiques de l environnement +!necessaires au calcul des proprietes dans le thermique +!-------------------------------------------------------------- + + IMPLICIT NONE + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" + + INTEGER ngrid,nlay + REAL po(ngrid,nlay) + REAL pt(ngrid,nlay) + REAL pu(ngrid,nlay) + REAL pv(ngrid,nlay) + REAL pplay(ngrid,nlay) + REAL pplev(ngrid,nlay+1) + integer lev_out ! niveau pour les print + + REAL zo(ngrid,nlay) + REAL zl(ngrid,nlay) + REAL zh(ngrid,nlay) + REAL ztv(ngrid,nlay) + REAL zthl(ngrid,nlay) + REAL zpspsk(ngrid,nlay) + REAL zu(ngrid,nlay) + REAL zv(ngrid,nlay) + REAL pqsat(ngrid,nlay) + + INTEGER ig,ll + + real dqsat_dT + real RLvCp + +logical mask(ngrid,nlay) + + +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +! Initialisations : +!------------------ + +mask(:,:)=.true. +RLvCp = RLVTT/RCPD + +! +! calcul des caracteristiques de l environnement + DO ll=1,nlay + DO ig=1,ngrid + zo(ig,ll)=po(ig,ll) + zl(ig,ll)=0. + zh(ig,ll)=pt(ig,ll) + EndDO + EndDO +! +! +! Condensation : +!--------------- +! Calcul de l'humidite a saturation et de la condensation + +call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat) +DO ll=1,nlay + DO ig=1,ngrid + zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll)) + zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) ! T = Tl + Lv/Cp ql + zo(ig,ll) = po(ig,ll)-zl(ig,ll) + ENDDO +ENDDO +! +! +!----------------------------------------------------------------------- + + if (prt_level.ge.1) print*,'0 OK convect8' + + DO ll=1,nlay + DO ig=1,ngrid + zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA + zu(ig,ll)=pu(ig,ll) + zv(ig,ll)=pv(ig,ll) +!attention zh est maintenant le profil de T et plus le profil de theta ! +! Quelle horreur ! A eviter. +! +! T-> Theta + ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll) +!Theta_v + ztv(ig,ll)=ztv(ig,ll)*(1.+RETV*(zo(ig,ll))-zl(ig,ll)) +!Thetal + zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll) +! + ENDDO + ENDDO + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_flux.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_flux.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_flux.F90 (revision 1634) @@ -0,0 +1,519 @@ +! +! $Id$ +! + + + SUBROUTINE thermcell_flux(ngrid,klev,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,zmax,lev_out,lunout1,igout) + + +!--------------------------------------------------------------------------- +!thermcell_flux: deduction des flux +!--------------------------------------------------------------------------- + + IMPLICIT NONE +#include "iniprint.h" + + INTEGER ig,l + INTEGER ngrid,klev + + REAL alim_star(ngrid,klev),entr_star(ngrid,klev) + REAL detr_star(ngrid,klev) + REAL zw2(ngrid,klev+1) + REAL zlev(ngrid,klev+1) + REAL masse(ngrid,klev) + REAL ptimestep + REAL rhobarz(ngrid,klev) + REAL f(ngrid) + INTEGER lmax(ngrid) + INTEGER lalim(ngrid) + REAL zqla(ngrid,klev) + REAL zmax(ngrid) + + integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha + integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8 + + + REAL entr(ngrid,klev),detr(ngrid,klev) + REAL fm(ngrid,klev+1) + REAL zfm + + integer igout + integer lev_out + integer lunout1 + + REAL f_old,ddd0,eee0,ddd,eee,zzz + + REAL fomass_max,alphamax + save fomass_max,alphamax +!$OMP THREADPRIVATE(fomass_max,alphamax) + + character (len=20) :: modname='thermcell_flux' + character (len=80) :: abort_message + + fomass_max=0.5 + alphamax=0.7 + + ncorecfm1=0 + ncorecfm2=0 + ncorecfm3=0 + ncorecfm4=0 + ncorecfm5=0 + ncorecfm6=0 + ncorecfm7=0 + ncorecfm8=0 + ncorecalpha=0 + +!initialisation + fm(:,:)=0. + + if (prt_level.ge.10) then + write(lunout,*) 'Dans thermcell_flux 0' + write(lunout,*) 'flux base ',f(igout) + write(lunout,*) 'lmax ',lmax(igout) + write(lunout,*) 'lalim ',lalim(igout) + write(lunout,*) 'ig= ',igout + write(lunout,*) ' l E* A* D* ' + write(lunout,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) & + & ,l=1,lmax(igout)) + endif + + +!------------------------------------------------------------------------- +! Verification de la nullite des entrainement et detrainement au dessus +! de lmax(ig) +!------------------------------------------------------------------------- + if ( prt_level > 1 ) THEN + do l=1,klev + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (entr_star(ig,l).gt.1.) then + print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + endif + else + if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then + print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + endif + endif + enddo + enddo + endif !( prt_level > 1 ) THEN +!------------------------------------------------------------------------- +! Multiplication par le flux de masse issu de la femreture +!------------------------------------------------------------------------- + + do l=1,klev + entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l)) + detr(:,l)=f(:)*detr_star(:,l) + enddo + + if (prt_level.ge.10) then + write(lunout,*) 'Dans thermcell_flux 1' + write(lunout,*) 'flux base ',f(igout) + write(lunout,*) 'lmax ',lmax(igout) + write(lunout,*) 'lalim ',lalim(igout) + write(lunout,*) 'ig= ',igout + write(lunout,*) ' l E D W2' + write(lunout,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) & + & ,zw2(igout,l+1),l=1,lmax(igout)) + endif + + fm(:,1)=0. + do l=1,klev + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + enddo + + + +! Test provisoire : pour comprendre pourquoi on corrige plein de fois +! le cas fm6, on commence par regarder une premiere fois avant les +! autres corrections. + + do l=1,klev + do ig=1,ngrid + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm8=ncorecfm8+1 +! igout=ig + endif + enddo + enddo + + if (prt_level.ge.10) & + & call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,'2 ') + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Version en cours de test; +! par rapport a thermcell_flux, on fait une grande boucle sur "l" +! et on modifie le flux avec tous les contr�les appliques d'affilee +! pour la meme couche +! Momentanement, on duplique le calcule du flux pour pouvoir comparer +! les flux avant et apres modif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do l=1,klev + + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + + +!------------------------------------------------------------------------- +! Verification de la positivite des flux de masse +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then +! print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1) + ncorecfm1=ncorecfm1+1 + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=entr(ig,l) + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!Test sur fraca croissant +!------------------------------------------------------------------------- + + + if (1.eq.1) then +! do l=1,klev + do ig=1,ngrid + if (l.ge.lalim(ig).and.l.le.lmax(ig) & + & .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then +! zzz est le flux en l+1 a frac constant + zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) & + & /(rhobarz(ig,l)*zw2(ig,l)) + if (fm(ig,l+1).gt.zzz) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz + fm(ig,l+1)=zzz + ncorecfm4=ncorecfm4+1 + endif + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + else + if (l.eq.1) then + print*,'Test sur les fractions croissantes inhibe dans thermcell_flux2' + endif + endif + + +!------------------------------------------------------------------------- +!test sur flux de masse croissant +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then + f_old=fm(ig,l+1) + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) + ncorecfm5=ncorecfm5+1 + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!detr ne peut pas etre superieur a fm +!------------------------------------------------------------------------- + + if(1.eq.1) then + +! do l=1,klev + do ig=1,ngrid + if (entr(ig,l)<0.) then + print*,'N1 ig,l,entr',ig,l,entr(ig,l) + abort_message = 'entr negatif' + CALL abort_gcm (modname,abort_message,1) + endif + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm6=ncorecfm6+1 + detr(ig,l)=fm(ig,l) +! entr(ig,l)=fm(ig,l+1) + +! Dans le cas ou on est au dessus de la couche d'alimentation et que le +! detrainement est plus fort que le flux de masse, on stope le thermique. + if (l.gt.lalim(ig)) then + lmax(ig)=l + fm(ig,l+1)=0. + entr(ig,l)=0. + else + ncorecfm7=ncorecfm7+1 + endif + endif + + if(l.gt.lmax(ig)) then + detr(ig,l)=0. + fm(ig,l+1)=0. + entr(ig,l)=0. + endif + + if (entr(ig,l).lt.0.) then + print*,'ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr(ig,l)',entr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell flux' + CALL abort_gcm (modname,abort_message,1) + endif + enddo +! enddo + endif + + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!fm ne peut pas etre negatif +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1) + fm(ig,l+1)=0. +! print*,'fm2<0',l+1,lmax(ig) + ncorecfm2=ncorecfm2+1 + endif + if (detr(ig,l).lt.0.) then + print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'detr(ig,l)',detr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell flux' + CALL abort_gcm (modname,abort_message,1) + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!----------------------------------------------------------------------- +!la fraction couverte ne peut pas etre superieure a 1 +!----------------------------------------------------------------------- + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Partie a revisiter. +! Il semble qu'etaient codees ici deux optiques dans le cas +! F/ (rho *w) > 1 +! soit limiter la hauteur du thermique en considerant que c'est +! la derniere chouche, soit limiter F a rho w. +! Dans le second cas, il faut en fait limiter a un peu moins +! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin +! dans thermcell_main et qu'il semble de toutes facons deraisonable +! d'avoir des fractions de 1.. +! Ci dessous, et dans l'etat actuel, le premier des deux if est +! sans doute inutile. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! do l=1,klev + do ig=1,ngrid + if (zw2(ig,l+1).gt.1.e-10) then + zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax + if ( fm(ig,l+1) .gt. zfm) then + f_old=fm(ig,l+1) + fm(ig,l+1)=zfm +! zw2(ig,l+1)=0. +! zqla(ig,l+1)=0. + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) +! lmax(ig)=l+1 +! zmax(ig)=zlev(ig,lmax(ig)) +! print*,'alpha>1',l+1,lmax(ig) + ncorecalpha=ncorecalpha+1 + endif + endif + enddo +! enddo +! + + + if (prt_level.ge.10) & + & write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +! Fin de la grande boucle sur les niveaux verticaux + enddo + + if (prt_level.ge.10) & + & call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,'8 ') + + +!----------------------------------------------------------------------- +! On fait en sorte que la quantite totale d'air entraine dans le +! panache ne soit pas trop grande comparee a la masse de la maille +!----------------------------------------------------------------------- + + if (1.eq.1) then + do l=1,klev-1 + do ig=1,ngrid + eee0=entr(ig,l) + ddd0=detr(ig,l) + eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep + ddd=detr(ig,l)-eee + if (eee.gt.0.) then + ncorecfm3=ncorecfm3+1 + entr(ig,l)=entr(ig,l)-eee + if ( ddd.gt.0.) then +! l'entrainement est trop fort mais l'exces peut etre compense par une +! diminution du detrainement) + detr(ig,l)=ddd + else +! l'entrainement est trop fort mais l'exces doit etre compense en partie +! par un entrainement plus fort dans la couche superieure + if(l.eq.lmax(ig)) then + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + if(l.ge.lmax(ig).and.0.eq.1) then + print*,'ig,l',ig,l + print*,'eee0',eee0 + print*,'ddd0',ddd0 + print*,'eee',eee + print*,'ddd',ddd + print*,'entr',entr(ig,l) + print*,'detr',detr(ig,l) + print*,'masse',masse(ig,l) + print*,'fomass_max',fomass_max + print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep + print*,'ptimestep',ptimestep + print*,'lmax(ig)',lmax(ig) + print*,'fm(ig,l+1)',fm(ig,l+1) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell_flux' + CALL abort_gcm (modname,abort_message,1) + endif + entr(ig,l+1)=entr(ig,l+1)-ddd + detr(ig,l)=0. + fm(ig,l+1)=fm(ig,l)+entr(ig,l) + detr(ig,l)=0. + endif + endif + endif + enddo + enddo + endif +! +! ddd=detr(ig)-entre +!on s assure que tout s annule bien en zmax + do ig=1,ngrid + fm(ig,lmax(ig)+1)=0. + entr(ig,lmax(ig))=0. + detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig)) + enddo + +!----------------------------------------------------------------------- +! Impression du nombre de bidouilles qui ont ete necessaires +!----------------------------------------------------------------------- + + if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then + if (prt_level.ge.10) then + print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',& + & ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', & + & ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', & + & ncorecfm6,'x fm6', & + & ncorecfm7,'x fm7', & + & ncorecfm8,'x fm8', & + & ncorecalpha,'x alpha' + endif + endif + + if (prt_level.ge.10) & + & call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,'fin') + + + return + end + + subroutine printflux(ngrid,klev,lunout,igout,f,lmax,lalim, & + & ptimestep,masse,entr,detr,fm,descr) + + implicit none + + integer ngrid,klev,lunout,igout,l,lm + + integer lmax(klev),lalim(klev) + real ptimestep,masse(ngrid,klev),entr(ngrid,klev),detr(ngrid,klev) + real fm(ngrid,klev+1),f(ngrid) + + character*3 descr + + character (len=20) :: modname='thermcell_flux' + character (len=80) :: abort_message + + lm=lmax(igout)+5 + if(lm.gt.klev) lm=klev + + print*,'Impression jusque lm=',lm + + write(lunout,*) 'Dans thermcell_flux '//descr + write(lunout,*) 'flux base ',f(igout) + write(lunout,*) 'lmax ',lmax(igout) + write(lunout,*) 'lalim ',lalim(igout) + write(lunout,*) 'ig= ',igout + write(lunout,'(a3,4a14)') 'l','M','E','D','F' + write(lunout,'(i4,4e14.4)') (l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l) & + & ,fm(igout,l+1),l=1,lm) + + + do l=lmax(igout)+1,klev + if (abs(entr(igout,l))+abs(detr(igout,l))+abs(fm(igout,l)).gt.0.) then + print*,'cas 1 : igout,l,lmax(igout)',igout,l,lmax(igout) + print*,'entr(igout,l)',entr(igout,l) + print*,'detr(igout,l)',detr(igout,l) + print*,'fm(igout,l)',fm(igout,l) + abort_message = '' + CALL abort_gcm (modname,abort_message,1) + endif + enddo + + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_flux2.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_flux2.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_flux2.F90 (revision 1634) @@ -0,0 +1,516 @@ +! +! $Id$ +! + SUBROUTINE thermcell_flux2(ngrid,klev,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,lev_out,lunout1,igout) +!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) + + +!--------------------------------------------------------------------------- +!thermcell_flux: deduction des flux +!--------------------------------------------------------------------------- + + IMPLICIT NONE +#include "iniprint.h" +#include "thermcell.h" + + INTEGER ig,l + INTEGER ngrid,klev + + REAL alim_star(ngrid,klev),entr_star(ngrid,klev) + REAL detr_star(ngrid,klev) + REAL zw2(ngrid,klev+1) + REAL zlev(ngrid,klev+1) + REAL masse(ngrid,klev) + REAL ptimestep + REAL rhobarz(ngrid,klev) + REAL f(ngrid) + INTEGER lmax(ngrid) + INTEGER lalim(ngrid) + REAL zqla(ngrid,klev) + REAL zmax(ngrid) + + integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha + integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8 + + + REAL entr(ngrid,klev),detr(ngrid,klev) + REAL fm(ngrid,klev+1) + REAL zfm + + integer igout,lout + integer lev_out + integer lunout1 + + REAL f_old,ddd0,eee0,ddd,eee,zzz + + REAL fomass_max,alphamax + save fomass_max,alphamax + + logical check_debug,labort_gcm + + character (len=20) :: modname='thermcell_flux2' + character (len=80) :: abort_message + + fomass_max=0.5 + alphamax=0.7 + + ncorecfm1=0 + ncorecfm2=0 + ncorecfm3=0 + ncorecfm4=0 + ncorecfm5=0 + ncorecfm6=0 + ncorecfm7=0 + ncorecfm8=0 + ncorecalpha=0 + +!initialisation + fm(:,:)=0. + + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_flux 0' + write(lunout1,*) 'flux base ',f(igout) + write(lunout1,*) 'lmax ',lmax(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) 'ig= ',igout + write(lunout1,*) ' l E* A* D* ' + write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) & + & ,l=1,lmax(igout)) + endif + + +!------------------------------------------------------------------------- +! Verification de la nullite des entrainement et detrainement au dessus +! de lmax(ig) +! Active uniquement si check_debug=.true. ou prt_level>=10 +!------------------------------------------------------------------------- + + check_debug=.false..or.prt_level>=10 + + if (check_debug) then + do l=1,klev + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (entr_star(ig,l).gt.1.) then + print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + endif + else + if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then + print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr_star(ig,l)',entr_star(ig,l) + print*,'alim_star(ig,l)',alim_star(ig,l) + print*,'detr_star(ig,l)',detr_star(ig,l) + abort_message = '' + labort_gcm=.true. + CALL abort_gcm (modname,abort_message,1) + endif + endif + enddo + enddo + endif + +!------------------------------------------------------------------------- +! Multiplication par le flux de masse issu de la femreture +!------------------------------------------------------------------------- + + do l=1,klev + entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l)) + detr(:,l)=f(:)*detr_star(:,l) + enddo + + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_flux 1' + write(lunout1,*) 'flux base ',f(igout) + write(lunout1,*) 'lmax ',lmax(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) 'ig= ',igout + write(lunout1,*) ' l E D W2' + write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) & + & ,zw2(igout,l+1),l=1,lmax(igout)) + endif + + fm(:,1)=0. + do l=1,klev + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + enddo + + + +! Test provisoire : pour comprendre pourquoi on corrige plein de fois +! le cas fm6, on commence par regarder une premiere fois avant les +! autres corrections. + + do l=1,klev + do ig=1,ngrid + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm8=ncorecfm8+1 +! igout=ig + endif + enddo + enddo + +! if (prt_level.ge.10) & +! & call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'2 ') + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Version en cours de test; +! par rapport a thermcell_flux, on fait une grande boucle sur "l" +! et on modifie le flux avec tous les contr�les appliques d'affilee +! pour la meme couche +! Momentanement, on duplique le calcule du flux pour pouvoir comparer +! les flux avant et apres modif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do l=1,klev + + do ig=1,ngrid + if (l.lt.lmax(ig)) then + fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l) + elseif(l.eq.lmax(ig)) then + fm(ig,l+1)=0. + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + fm(ig,l+1)=0. + endif + enddo + + +!------------------------------------------------------------------------- +! Verification de la positivite des flux de masse +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then +! print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1) + ncorecfm1=ncorecfm1+1 + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=entr(ig,l) + endif + enddo +! enddo + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!Test sur fraca croissant +!------------------------------------------------------------------------- + if (iflag_thermals_optflux==0) then +! do l=1,klev + do ig=1,ngrid + if (l.ge.lalim(ig).and.l.le.lmax(ig) & + & .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then +! zzz est le flux en l+1 a frac constant + zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) & + & /(rhobarz(ig,l)*zw2(ig,l)) + if (fm(ig,l+1).gt.zzz) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz + fm(ig,l+1)=zzz + ncorecfm4=ncorecfm4+1 + endif + endif + enddo +! enddo + endif + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + + +!------------------------------------------------------------------------- +!test sur flux de masse croissant +!------------------------------------------------------------------------- + if (iflag_thermals_optflux==0) then +! do l=1,klev + do ig=1,ngrid + if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then + f_old=fm(ig,l+1) + fm(ig,l+1)=fm(ig,l) + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) + ncorecfm5=ncorecfm5+1 + endif + enddo +! enddo + endif + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!fin 1.eq.0 +!------------------------------------------------------------------------- +!detr ne peut pas etre superieur a fm +!------------------------------------------------------------------------- + + if(1.eq.1) then + +! do l=1,klev + + + + labort_gcm=.false. + do ig=1,ngrid + if (entr(ig,l)<0.) then + labort_gcm=.true. + igout=ig + lout=l + endif + enddo + + if (labort_gcm) then + print*,'N1 ig,l,entr',igout,lout,entr(igout,lout) + abort_message = 'entr negatif' + CALL abort_gcm (modname,abort_message,1) + endif + + do ig=1,ngrid + if (detr(ig,l).gt.fm(ig,l)) then + ncorecfm6=ncorecfm6+1 + detr(ig,l)=fm(ig,l) + entr(ig,l)=fm(ig,l+1) + +! Dans le cas ou on est au dessus de la couche d'alimentation et que le +! detrainement est plus fort que le flux de masse, on stope le thermique. +!test:on commente +! if (l.gt.lalim(ig)) then +! lmax(ig)=l +! fm(ig,l+1)=0. +! entr(ig,l)=0. +! else +! ncorecfm7=ncorecfm7+1 +! endif + endif + + if(l.gt.lmax(ig)) then + detr(ig,l)=0. + fm(ig,l+1)=0. + entr(ig,l)=0. + endif + enddo + + labort_gcm=.false. + do ig=1,ngrid + if (entr(ig,l).lt.0.) then + labort_gcm=.true. + igout=ig + endif + enddo + if (labort_gcm) then + ig=igout + print*,'ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'entr(ig,l)',entr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell flux' + CALL abort_gcm (modname,abort_message,1) + endif + + +! enddo + endif + + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!------------------------------------------------------------------------- +!fm ne peut pas etre negatif +!------------------------------------------------------------------------- + +! do l=1,klev + do ig=1,ngrid + if (fm(ig,l+1).lt.0.) then + detr(ig,l)=detr(ig,l)+fm(ig,l+1) + fm(ig,l+1)=0. + ncorecfm2=ncorecfm2+1 + endif + enddo + + labort_gcm=.false. + do ig=1,ngrid + if (detr(ig,l).lt.0.) then + labort_gcm=.true. + igout=ig + endif + enddo + if (labort_gcm) then + ig=igout + print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig) + print*,'detr(ig,l)',detr(ig,l) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell flux' + CALL abort_gcm (modname,abort_message,1) + endif +! enddo + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +!----------------------------------------------------------------------- +!la fraction couverte ne peut pas etre superieure a 1 +!----------------------------------------------------------------------- + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FH Partie a revisiter. +! Il semble qu'etaient codees ici deux optiques dans le cas +! F/ (rho *w) > 1 +! soit limiter la hauteur du thermique en considerant que c'est +! la derniere chouche, soit limiter F a rho w. +! Dans le second cas, il faut en fait limiter a un peu moins +! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin +! dans thermcell_main et qu'il semble de toutes facons deraisonable +! d'avoir des fractions de 1.. +! Ci dessous, et dans l'etat actuel, le premier des deux if est +! sans doute inutile. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! do l=1,klev + do ig=1,ngrid + if (zw2(ig,l+1).gt.1.e-10) then + zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax + if ( fm(ig,l+1) .gt. zfm) then + f_old=fm(ig,l+1) + fm(ig,l+1)=zfm +! zw2(ig,l+1)=0. +! zqla(ig,l+1)=0. + detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1) +! lmax(ig)=l+1 +! zmax(ig)=zlev(ig,lmax(ig)) +! print*,'alpha>1',l+1,lmax(ig) + ncorecalpha=ncorecalpha+1 + endif + endif + enddo +! enddo +! + + + if (prt_level.ge.10) & + & write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, & + & entr(igout,l),detr(igout,l),fm(igout,l+1) + +! Fin de la grande boucle sur les niveaux verticaux + enddo + +! if (prt_level.ge.10) & +! & call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'8 ') + + +!----------------------------------------------------------------------- +! On fait en sorte que la quantite totale d'air entraine dans le +! panache ne soit pas trop grande comparee a la masse de la maille +!----------------------------------------------------------------------- + + if (1.eq.1) then + labort_gcm=.false. + do l=1,klev-1 + do ig=1,ngrid + eee0=entr(ig,l) + ddd0=detr(ig,l) + eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep + ddd=detr(ig,l)-eee + if (eee.gt.0.) then + ncorecfm3=ncorecfm3+1 + entr(ig,l)=entr(ig,l)-eee + if ( ddd.gt.0.) then +! l'entrainement est trop fort mais l'exces peut etre compense par une +! diminution du detrainement) + detr(ig,l)=ddd + else +! l'entrainement est trop fort mais l'exces doit etre compense en partie +! par un entrainement plus fort dans la couche superieure + if(l.eq.lmax(ig)) then + detr(ig,l)=fm(ig,l)+entr(ig,l) + else + if(l.ge.lmax(ig).and.0.eq.1) then + igout=ig + lout=l + labort_gcm=.true. + endif + entr(ig,l+1)=entr(ig,l+1)-ddd + detr(ig,l)=0. + fm(ig,l+1)=fm(ig,l)+entr(ig,l) + detr(ig,l)=0. + endif + endif + endif + enddo + enddo + if (labort_gcm) then + ig=igout + l=lout + print*,'ig,l',ig,l + print*,'eee0',eee0 + print*,'ddd0',ddd0 + print*,'eee',eee + print*,'ddd',ddd + print*,'entr',entr(ig,l) + print*,'detr',detr(ig,l) + print*,'masse',masse(ig,l) + print*,'fomass_max',fomass_max + print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep + print*,'ptimestep',ptimestep + print*,'lmax(ig)',lmax(ig) + print*,'fm(ig,l+1)',fm(ig,l+1) + print*,'fm(ig,l)',fm(ig,l) + abort_message = 'probleme dans thermcell_flux' + CALL abort_gcm (modname,abort_message,1) + endif + endif +! +! ddd=detr(ig)-entre +!on s assure que tout s annule bien en zmax + do ig=1,ngrid + fm(ig,lmax(ig)+1)=0. + entr(ig,lmax(ig))=0. + detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig)) + enddo + +!----------------------------------------------------------------------- +! Impression du nombre de bidouilles qui ont ete necessaires +!----------------------------------------------------------------------- + +!IM 090508 beg +! if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then +! +! print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',& +! & ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', & +! & ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', & +! & ncorecfm6,'x fm6', & +! & ncorecfm7,'x fm7', & +! & ncorecfm8,'x fm8', & +! & ncorecalpha,'x alpha' +! endif +!IM 090508 end + +! if (prt_level.ge.10) & +! & call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, & +! & ptimestep,masse,entr,detr,fm,'fin') + + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_height.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_height.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_height.F90 (revision 1634) @@ -0,0 +1,163 @@ + SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix, & + & zw2,zlev,lmax,zmax,zmax0,zmix,wmax,lev_out) + +!----------------------------------------------------------------------------- +!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix +!----------------------------------------------------------------------------- + IMPLICIT NONE +#include "iniprint.h" +#include "thermcell.h" + + INTEGER ig,l + INTEGER ngrid,nlay + INTEGER lalim(ngrid),lmin(ngrid) + INTEGER lmix(ngrid) + REAL linter(ngrid) + integer lev_out ! niveau pour les print + + REAL zw2(ngrid,nlay+1) + REAL zlev(ngrid,nlay+1) + + REAL wmax(ngrid) + INTEGER lmax(ngrid) + REAL zmax(ngrid) + REAL zmax0(ngrid) + REAL zmix(ngrid) + REAL num(ngrid) + REAL denom(ngrid) + + REAL zlevinter(ngrid) + +!calcul de la hauteur max du thermique + do ig=1,ngrid + lmax(ig)=lalim(ig) + enddo + do ig=1,ngrid + do l=nlay,lalim(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo + +! On traite le cas particulier qu'il faudrait éviter ou le thermique +! atteind le haut du modele ... + do ig=1,ngrid + if ( zw2(ig,nlay) > 1.e-10 ) then + print*,'WARNING !!!!! W2 thermiques non nul derniere couche ' + lmax(ig)=nlay + endif + enddo + +! pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + lalim(ig)=1 + endif + enddo +! +! Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then + print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +! Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + + if (iflag_thermals_ed.ge.1) then + + num(:)=0. + denom(:)=0. + do ig=1,ngrid + do l=1,nlay + num(ig)=num(ig)+zw2(ig,l)*zlev(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + denom(ig)=denom(ig)+zw2(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + enddo + enddo + do ig=1,ngrid + if (denom(ig).gt.1.e-10) then + zmax(ig)=2.*num(ig)/denom(ig) + zmax0(ig)=zmax(ig) + endif + enddo + + else + + do ig=1,ngrid +! calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* & + & linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) & + & -zlev(ig,lmax(ig))) +!pour le cas ou on prend tjs lmin=1 +! zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) + zmax0(ig)=zmax(ig) + enddo + + + endif +!endif iflag_thermals_ed +! +! def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1) then +! test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) & + & then +! + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) & + & /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) & + & *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) & + & -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) & + & *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) + print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +!test + if ((zmax(ig)-zmix(ig)).le.0.) then + zmix(ig)=0.9*zmax(ig) +! print*,'pb zmix>zmax' + endif + enddo +! +! calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,nlay + if (zmix(ig).ge.zlev(ig,l).and. & + & zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +! + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_init.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_init.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_init.F90 (revision 1634) @@ -0,0 +1,59 @@ +! +! $Header$ +! + SUBROUTINE thermcell_init(ngrid,nlay,ztv,zlay,zlev, & + & lalim,lmin,alim_star,alim_star_tot,lev_out) + +!---------------------------------------------------------------------- +!thermcell_init: calcul du profil d alimentation du thermique +!---------------------------------------------------------------------- + IMPLICIT NONE +#include "iniprint.h" +#include "thermcell.h" + + INTEGER l,ig +!arguments d entree + INTEGER ngrid,nlay + REAL ztv(ngrid,nlay) + REAL zlay(ngrid,nlay) + REAL zlev(ngrid,nlay+1) +!arguments de sortie + INTEGER lalim(ngrid) + INTEGER lmin(ngrid) + REAL alim_star(ngrid,nlay) + REAL alim_star_tot(ngrid) + integer lev_out ! niveau pour les print + + REAL zzalim(ngrid) +!CR: ponderation entrainement des couches instables +!def des alim_star tels que alim=f*alim_star + + + write(lunout,*)'THERM INIT V20C ' + + alim_star_tot(:)=0. + alim_star(:,:)=0. + lmin(:)=1 + lalim(:)=1 + + do l=1,nlay-1 + do ig=1,ngrid + if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & + & *sqrt(zlev(ig,l+1)) + lalim(:)=l+1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + endif + enddo + enddo + do l=1,nlay + do ig=1,ngrid + if (alim_star_tot(ig) > 1.e-10 ) then + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + endif + enddo + enddo + alim_star_tot(:)=1. + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_main.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_main.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_main.F90 (revision 1634) @@ -0,0 +1,859 @@ +! +! $Id$ +! + SUBROUTINE thermcell_main(itap,ngrid,nlay,ptimestep & + & ,pplay,pplev,pphi,debut & + & ,pu,pv,pt,po & + & ,pduadj,pdvadj,pdtadj,pdoadj & + & ,fm0,entr0,detr0,zqta,zqla,lmax & + & ,ratqscth,ratqsdiff,zqsatth & + & ,Ale_bl,Alp_bl,lalim_conv,wght_th & + & ,zmax0, f0,zw2,fraca,ztv & + & ,zpspsk,ztla,zthl) + + USE dimphy + USE comgeomphy , ONLY:rlond,rlatd + IMPLICIT NONE + +!======================================================================= +! Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu +! Version du 09.02.07 +! Calcul du transport vertical dans la couche limite en presence +! de "thermiques" explicitement representes avec processus nuageux +! +! Reecriture a partir d'un listing papier a Habas, le 14/02/00 +! +! le thermique est suppose homogene et dissipe par melange avec +! son environnement. la longueur l_mix controle l'efficacite du +! melange +! +! Le calcul du transport des differentes especes se fait en prenant +! en compte: +! 1. un flux de masse montant +! 2. un flux de masse descendant +! 3. un entrainement +! 4. un detrainement +! +!======================================================================= + +!----------------------------------------------------------------------- +! declarations: +! ------------- + +#include "dimensions.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +#include "thermcell.h" + +! arguments: +! ---------- + +!IM 140508 + INTEGER itap + + INTEGER ngrid,nlay + real ptimestep + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + +! local: +! ------ + + integer icount + data icount/0/ + save icount +!$OMP THREADPRIVATE(icount) + + integer,save :: igout=1 +!$OMP THREADPRIVATE(igout) + integer,save :: lunout1=6 +!$OMP THREADPRIVATE(lunout1) + integer,save :: lev_out=10 +!$OMP THREADPRIVATE(lev_out) + + INTEGER ig,k,l,ll,ierr + real zsortie1d(klon) + INTEGER lmax(klon),lmin(klon),lalim(klon) + INTEGER lmix(klon) + INTEGER lmix_bis(klon) + real linter(klon) + real zmix(klon) + real zmax(klon),zw2(klon,klev+1),ztva(klon,klev),zw_est(klon,klev+1),ztva_est(klon,klev) +! real fraca(klon,klev) + + real zmax_sec(klon) +!on garde le zmax du pas de temps precedent + real zmax0(klon) +!FH/IM save zmax0 + + real lambda + + real zlev(klon,klev+1),zlay(klon,klev) + real deltaz(klon,klev) + REAL zh(klon,klev) + real zthl(klon,klev),zdthladj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + real zl(klon,klev) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zta(klon,klev) + real zha(klon,klev) + real fraca(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev) + real q2(klon,klev) +! FH probleme de dimensionnement avec l'allocation dynamique +! common/comtherm/thetath2,wth2 + real wq(klon,klev) + real wthl(klon,klev) + real wthv(klon,klev) + + real ratqscth(klon,klev) + real var + real vardiff + real ratqsdiff(klon,klev) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev),masse(klon,klev) + real zpspsk(klon,klev) + + real wmax(klon) + real wmax_tmp(klon) + real wmax_sec(klon) + real fm0(klon,klev+1),entr0(klon,klev),detr0(klon,klev) + real fm(klon,klev+1),entr(klon,klev),detr(klon,klev) + + real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev) +!niveau de condensation + integer nivcon(klon) + real zcon(klon) + REAL CHI + real zcon2(klon) + real pcon(klon) + real zqsat(klon,klev) + real zqsatth(klon,klev) + + real f_star(klon,klev+1),entr_star(klon,klev) + real detr_star(klon,klev) + real alim_star_tot(klon) + real alim_star(klon,klev) + real alim_star_clos(klon,klev) + real f(klon), f0(klon) +!FH/IM save f0 + real zlevinter(klon) + logical debut + real seuil + real csc(klon,klev) + +! + !nouvelles variables pour la convection + real Ale_bl(klon) + real Alp_bl(klon) + real alp_int(klon),dp_int(klon),zdp + real ale_int(klon) + integer n_int(klon) + real fm_tot(klon) + real wght_th(klon,klev) + integer lalim_conv(klon) +!v1d logical therm +!v1d save therm + + character*2 str2 + character*10 str10 + + character (len=20) :: modname='thermcell_main' + character (len=80) :: abort_message + + EXTERNAL SCOPY +! + +!----------------------------------------------------------------------- +! initialisation: +! --------------- +! + + seuil=0.25 + + if (debut) then + fm0=0. + entr0=0. + detr0=0. + + +#undef wrgrads_thermcell +#ifdef wrgrads_thermcell +! Initialisation des sorties grads pour les thermiques. +! Pour l'instant en 1D sur le point igout. +! Utilise par thermcell_out3d.h + str10='therm' + call inigrads(1,1,rlond(igout),1.,-180.,180.,jjm, & + & rlatd(igout),-90.,90.,1.,llm,pplay(igout,:),1., & + & ptimestep,str10,'therm ') +#endif + + + + endif + + fm=0. ; entr=0. ; detr=0. + + + icount=icount+1 + +!IM 090508 beg +!print*,'=====================================================================' +!print*,'=====================================================================' +!print*,' PAS ',icount,' PAS ',icount,' PAS ',icount,' PAS ',icount +!print*,'=====================================================================' +!print*,'=====================================================================' +!IM 090508 end + + if (prt_level.ge.1) print*,'thermcell_main V4' + + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +! +! write(lunout,*)'WARNING thermcell_main f0=max(f0,1.e-2)' + do ig=1,klon + f0(ig)=max(f0(ig),1.e-2) + zmax0(ig)=max(zmax0(ig),40.) +!IMmarche pas ?! if (f0(ig)<1.e-2) f0(ig)=1.e-2 + enddo + + if (prt_level.ge.20) then + do ig=1,ngrid + print*,'th_main ig f0',ig,f0(ig) + enddo + endif +!----------------------------------------------------------------------- +! Calcul de T,q,ql a partir de Tl et qT dans l environnement +! -------------------------------------------------------------------- +! + CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay, & + & pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env' + +!------------------------------------------------------------------------ +! -------------------- +! +! +! + + + + + + + + + + + +! +! +! wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +! wh,wt,wo ... +! +! + + + + + + + + + + + zh,zu,zv,zo,rho +! +! +! -------------------- zlev(1) +! \\\\\\\\\\\\\\\\\\\\ +! +! + +!----------------------------------------------------------------------- +! Calcul des altitudes des couches +!----------------------------------------------------------------------- + + do l=2,nlay + zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG + enddo + zlev(:,1)=0. + zlev(:,nlay+1)=(2.*pphi(:,klev)-pphi(:,klev-1))/RG + do l=1,nlay + zlay(:,l)=pphi(:,l)/RG + enddo +!calcul de l epaisseur des couches + do l=1,nlay + deltaz(:,l)=zlev(:,l+1)-zlev(:,l) + enddo + +! print*,'2 OK convect8' +!----------------------------------------------------------------------- +! Calcul des densites +!----------------------------------------------------------------------- + + rho(:,:)=pplay(:,:)/(zpspsk(:,:)*RD*ztv(:,:)) + + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main rhobarz(:,1)=rho(:,1)' + rhobarz(:,1)=rho(:,1) + + do l=2,nlay + rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1)) + enddo + +!calcul de la masse + do l=1,nlay + masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG + enddo + + if (prt_level.ge.1) print*,'thermcell_main apres initialisation' + +!------------------------------------------------------------------ +! +! /|\ +! -------- | F_k+1 ------- +! ----> D_k +! /|\ <---- E_k , A_k +! -------- | F_k --------- +! ----> D_k-1 +! <---- E_k-1 , A_k-1 +! +! +! +! +! +! --------------------------- +! +! ----- F_lmax+1=0 ---------- \ +! lmax (zmax) | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | +! --------------------------- | +! | E +! --------------------------- | D +! | +! --------------------------- | +! | +! --------------------------- \ | +! lalim | | +! --------------------------- | | +! | | +! --------------------------- | | +! | A | +! --------------------------- | | +! | | +! --------------------------- | | +! lmin (=1 pour le moment) | | +! ----- F_lmin=0 ------------ / / +! +! --------------------------- +! ////////////////////////// +! +! +!============================================================================= +! Calculs initiaux ne faisant pas intervenir les changements de phase +!============================================================================= + +!------------------------------------------------------------------ +! 1. alim_star est le profil vertical de l'alimentation a la base du +! panache thermique, calcule a partir de la flotabilite de l'air sec +! 2. lmin et lalim sont les indices inferieurs et superieurs de alim_star +!------------------------------------------------------------------ +! + entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0. + lmin=1 + +!----------------------------------------------------------------------------- +! 3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un +! panache sec conservatif (e=d=0) alimente selon alim_star +! Il s'agit d'un calcul de type CAPE +! zmax_sec est utilise pour determiner la geometrie du thermique. +!------------------------------------------------------------------------------ +!--------------------------------------------------------------------------------- +!calcul du melange et des variables dans le thermique +!-------------------------------------------------------------------------------- +! + if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out +!IM 140508 CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & + +! Gestion temporaire de plusieurs appels à thermcell_plume au travers +! de la variable iflag_thermals + +! print*,'THERM thermcell_main iflag_thermals_ed=',iflag_thermals_ed + if (iflag_thermals_ed<=9) then +! print*,'THERM NOUVELLE/NOUVELLE Arnaud' + CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + + elseif (iflag_thermals_ed>9) then +! print*,'THERM RIO et al 2010, version d Arnaud' + CALL thermcellV1_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + + endif + + if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out + + call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 2' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) & + & ,f_star(igout,l+1),l=1,nint(linter(igout))+5) + endif + +!------------------------------------------------------------------------------- +! Calcul des caracteristiques du thermique:zmax,zmix,wmax +!------------------------------------------------------------------------------- +! + CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2, & + & zlev,lmax,zmax,zmax0,zmix,wmax,lev_out) +! Attention, w2 est transforme en sa racine carree dans cette routine +! Le probleme vient du fait que linter et lmix sont souvent égaux à 1. + wmax_tmp=0. + do l=1,nlay + wmax_tmp(:)=max(wmax_tmp(:),zw2(:,l)) + enddo +! print*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax + + + + call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height' + +!------------------------------------------------------------------------------- +! Fermeture,determination de f +!------------------------------------------------------------------------------- +! +! +!! write(lunout,*)'THERM NOUVEAU XXXXX' + CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star, & + & lalim,lmin,zmax_sec,wmax_sec,lev_out) + +call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lmin ') +call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry lalim ') + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry' + if (prt_level.ge.10) then + write(lunout1,*) 'Dans thermcell_main 1b' + write(lunout1,*) 'lmin ',lmin(igout) + write(lunout1,*) 'lalim ',lalim(igout) + write(lunout1,*) ' ig l alim_star entr_star detr_star f_star ' + write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) & + & ,l=1,lalim(igout)+4) + endif + + + + +! Choix de la fonction d'alimentation utilisee pour la fermeture. +! Apparemment sans importance + alim_star_clos(:,:)=alim_star(:,:) + alim_star_clos(:,:)=entr_star(:,:)+alim_star(:,:) + +! Appel avec la version seche + CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, & + & zlev,lalim,alim_star_clos,f_star,zmax_sec,wmax_sec,f,lev_out) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Appel avec les zmax et wmax tenant compte de la condensation +! Semble moins bien marcher +! CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho, & +! & zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure' + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + f0=(1.-lambda)*f+lambda*f0 + else + f0=f + endif + +! Test valable seulement en 1D mais pas genant + if (.not. (f0(1).ge.0.) ) then + abort_message = '.not. (f0(1).ge.0.)' + CALL abort_gcm (modname,abort_message,1) + endif + +!------------------------------------------------------------------------------- +!deduction des flux +!------------------------------------------------------------------------------- + + CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, & + & lalim,lmax,alim_star, & + & entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr, & + & detr,zqla,lev_out,lunout1,igout) +!IM 060508 & detr,zqla,zmax,lev_out,lunout,igout) + + if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux' + call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ') + call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax ') + +!------------------------------------------------------------------ +! On ne prend pas directement les profils issus des calculs precedents +! mais on s'autorise genereusement une relaxation vers ceci avec +! une constante de temps tau_thermals (typiquement 1800s). +!------------------------------------------------------------------ + + if (tau_thermals>1.) then + lambda=exp(-ptimestep/tau_thermals) + fm0=(1.-lambda)*fm+lambda*fm0 + entr0=(1.-lambda)*entr+lambda*entr0 + detr0=(1.-lambda)*detr+lambda*detr0 + else + fm0=fm + entr0=entr + detr0=detr + endif + +!c------------------------------------------------------------------ +! calcul du transport vertical +!------------------------------------------------------------------ + + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse, & + & zthl,zdthladj,zta,lev_out) + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse, & + & po,pdoadj,zoa,lev_out) + +!------------------------------------------------------------------ +! Calcul de la fraction de l'ascendance +!------------------------------------------------------------------ + do ig=1,klon + fraca(ig,1)=0. + fraca(ig,nlay+1)=0. + enddo + do l=2,nlay + do ig=1,klon + if (zw2(ig,l).gt.1.e-10) then + fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l)) + else + fraca(ig,l)=0. + endif + enddo + enddo + +!------------------------------------------------------------------ +! calcul du transport vertical du moment horizontal +!------------------------------------------------------------------ + +!IM 090508 + if (1.eq.1) then +!IM 070508 vers. _dq +! if (1.eq.0) then + + +! Calcul du transport de V tenant compte d'echange par gradient +! de pression horizontal avec l'environnement + + call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,fraca,zmax & + & ,zu,zv,pduadj,pdvadj,zua,zva,lev_out) + + else + +! calcul purement conservatif pour le transport de V + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,zu,pduadj,zua,lev_out) + call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse & + & ,zv,pdvadj,zva,lev_out) + endif + +! print*,'13 OK convect8' + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + if (prt_level.ge.1) print*,'14 OK convect8' +!------------------------------------------------------------------ +! Calculs de diagnostiques pour les sorties +!------------------------------------------------------------------ +!calcul de fraca pour les sorties + + if (sorties) then + if (prt_level.ge.1) print*,'14a OK convect8' +! calcul du niveau de condensation +! initialisation + do ig=1,ngrid + nivcon(ig)=0 + zcon(ig)=0. + enddo +!nouveau calcul + do ig=1,ngrid + CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1)) + pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI + enddo +!IM do k=1,nlay + do k=1,nlay-1 + do ig=1,ngrid + if ((pcon(ig).le.pplay(ig,k)) & + & .and.(pcon(ig).gt.pplay(ig,k+1))) then + zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100. + endif + enddo + enddo +!IM + ierr=0 + do ig=1,ngrid + if (pcon(ig).le.pplay(ig,nlay)) then + zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100. + ierr=1 + endif + enddo + if (ierr==1) then + abort_message = 'thermcellV0_main: les thermiques vont trop haut ' + CALL abort_gcm (modname,abort_message,1) + endif + + if (prt_level.ge.1) print*,'14b OK convect8' + do k=nlay,1,-1 + do ig=1,ngrid + if (zqla(ig,k).gt.1e-10) then + nivcon(ig)=k + zcon(ig)=zlev(ig,k) + endif + enddo + enddo + if (prt_level.ge.1) print*,'14c OK convect8' +!calcul des moments +!initialisation + do l=1,nlay + do ig=1,ngrid + q2(ig,l)=0. + wth2(ig,l)=0. + wth3(ig,l)=0. + ratqscth(ig,l)=0. + ratqsdiff(ig,l)=0. + enddo + enddo + if (prt_level.ge.1) print*,'14d OK convect8' + if (prt_level.ge.10)write(lunout,*) & + & 'WARNING thermcell_main wth2=0. si zw2 > 1.e-10' + do l=1,nlay + do ig=1,ngrid + zf=fraca(ig,l) + zf2=zf/(1.-zf) +! + thetath2(ig,l)=zf2*(ztla(ig,l)-zthl(ig,l))**2 + if(zw2(ig,l).gt.1.e-10) then + wth2(ig,l)=zf2*(zw2(ig,l))**2 + else + wth2(ig,l)=0. + endif + wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l)) & + & *zw2(ig,l)*zw2(ig,l)*zw2(ig,l) + q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 +!test: on calcul q2/po=ratqsc + ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.)) + enddo + enddo +!calcul des flux: q, thetal et thetav + do l=1,nlay + do ig=1,ngrid + wq(ig,l)=fraca(ig,l)*zw2(ig,l)*(zqta(ig,l)*1000.-po(ig,l)*1000.) + wthl(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztla(ig,l)-zthl(ig,l)) + wthv(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztva(ig,l)-ztv(ig,l)) + enddo + enddo +! + if (prt_level.ge.10) then + ig=igout + do l=1,nlay + print*,'14f OK convect8 ig,l,zha zh zpspsk ',ig,l,zha(ig,l),zh(ig,l),zpspsk(ig,l) + print*,'14g OK convect8 ig,l,po',ig,l,po(ig,l) + enddo + endif + +! print*,'avant calcul ale et alp' +!calcul de ALE et ALP pour la convection + Alp_bl(:)=0. + Ale_bl(:)=0. +! print*,'ALE,ALP ,l,zw2(ig,l),Ale_bl(ig),Alp_bl(ig)' + do l=1,nlay + do ig=1,ngrid + Alp_bl(ig)=max(Alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) ) + Ale_bl(ig)=max(Ale_bl(ig),0.5*zw2(ig,l)**2) +! print*,'ALE,ALP',l,zw2(ig,l),Ale_bl(ig),Alp_bl(ig) + enddo + enddo + +!test:calcul de la ponderation des couches pour KE +!initialisations + + fm_tot(:)=0. + wght_th(:,:)=1. + lalim_conv(:)=lalim(:) + + do k=1,klev + do ig=1,ngrid + if (k<=lalim_conv(ig)) fm_tot(ig)=fm_tot(ig)+fm(ig,k) + enddo + enddo + +! assez bizarre car, si on est dans la couche d'alim et que alim_star et +! plus petit que 1.e-10, on prend wght_th=1. + do k=1,klev + do ig=1,ngrid + if (k<=lalim_conv(ig).and.alim_star(ig,k)>1.e-10) then + wght_th(ig,k)=alim_star(ig,k) + endif + enddo + enddo + +! print*,'apres wght_th' +!test pour prolonger la convection + do ig=1,ngrid +!v1d if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then + if ((alim_star(ig,1).lt.1.e-10)) then + lalim_conv(ig)=1 + wght_th(ig,1)=1. +! print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1) + endif + enddo + +!------------------------------------------------------------------------ +! Modif CR/FH 20110310 : Alp integree sur la verticale. +! Integrale verticale de ALP. +! wth3 etant aux niveaux inter-couches, on utilise d play comme masse des +! couches +!------------------------------------------------------------------------ + + alp_int(:)=0. + dp_int(:)=0. + do l=2,nlay + do ig=1,ngrid + if(l.LE.lmax(ig)) THEN + zdp=pplay(ig,l-1)-pplay(ig,l) + alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)*zdp + dp_int(ig)=dp_int(ig)+zdp + endif + enddo + enddo + + if (iflag_coupl>=3 .and. iflag_coupl<=5) then + do ig=1,ngrid +!valeur integree de alp_bl * 0.5: + if (dp_int(ig)>0.) then + Alp_bl(ig)=alp_int(ig)/dp_int(ig) + endif + enddo! + endif + + +! Facteur multiplicatif sur Alp_bl + Alp_bl(:)=alp_bl_k*Alp_bl(:) + +!------------------------------------------------------------------------ + + +!calcul du ratqscdiff + if (prt_level.ge.1) print*,'14e OK convect8' + var=0. + vardiff=0. + ratqsdiff(:,:)=0. + + do l=1,klev + do ig=1,ngrid + if (l<=lalim(ig)) then + var=var+alim_star(ig,l)*zqta(ig,l)*1000. + endif + enddo + enddo + + if (prt_level.ge.1) print*,'14f OK convect8' + + do l=1,klev + do ig=1,ngrid + if (l<=lalim(ig)) then + zf=fraca(ig,l) + zf2=zf/(1.-zf) + vardiff=vardiff+alim_star(ig,l)*(zqta(ig,l)*1000.-var)**2 + endif + enddo + enddo + + if (prt_level.ge.1) print*,'14g OK convect8' + do l=1,nlay + do ig=1,ngrid + ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.) +! write(11,*)'ratqsdiff=',ratqsdiff(ig,l) + enddo + enddo +!-------------------------------------------------------------------- +! +!ecriture des fichiers sortie +! print*,'15 OK convect8 CCCCCCCCCCCCCCCCCCc' + +#ifdef wrgrads_thermcell + if (prt_level.ge.1) print*,'thermcell_main sorties 3D' +#include "thermcell_out3d.h" +#endif + + endif + + if (prt_level.ge.1) print*,'thermcell_main FIN OK' + + return + end + +!----------------------------------------------------------------------------- + + subroutine test_ltherm(klon,klev,pplev,pplay,long,seuil,ztv,po,ztva,zqla,f_star,zw2,comment) + IMPLICIT NONE +#include "iniprint.h" + + integer i, k, klon,klev + real pplev(klon,klev+1),pplay(klon,klev) + real ztv(klon,klev) + real po(klon,klev) + real ztva(klon,klev) + real zqla(klon,klev) + real f_star(klon,klev) + real zw2(klon,klev) + integer long(klon) + real seuil + character*21 comment + + if (prt_level.ge.1) THEN + print*,'WARNING !!! TEST ',comment + endif + return + +! test sur la hauteur des thermiques ... + do i=1,klon +!IMtemp if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then + if (prt_level.ge.10) then + print*,'WARNING ',comment,' au point ',i,' K= ',long(i) + print*,' K P(MB) THV(K) Qenv(g/kg)THVA QLA(g/kg) F* W2' + do k=1,klev + write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k) + enddo + endif + enddo + + + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_old.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_old.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_old.F (revision 1634) @@ -0,0 +1,6154 @@ + SUBROUTINE thermcell_2002(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di + REAL tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmax(klon,klev+1),lmaxa(klon),lmix(klon) + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + + real wmax(klon,klev),wmaxa(klon) + + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + + character (len=2) :: str2 + character (len=10) :: str10 + + character (len=20) :: modname='thermcell2002' + character (len=80) :: abort_message + + LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + + print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + + + do k=1,nlay-1 + do ig=1,ngrid + wa(ig,k,k)=0. + wa(ig,k,k+1)=2.*RG*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig,k+1) + s *(zlev(ig,k+1)-zlev(ig,k)) + enddo + do l=k+1,nlay-1 + do ig=1,ngrid + wa(ig,k,l+1)=wa(ig,k,l)+ + s 2.*RG*(ztv(ig,k)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + enddo + enddo + do ig=1,ngrid + wa(ig,k,nlay+1)=0. + enddo + enddo + +c print*,'4 OK convect8' +c Calcul de la couche correspondant a la hauteur du thermique + do k=1,nlay-1 + do ig=1,ngrid + lmax(ig,k)=k + enddo + do l=nlay,k+1,-1 + do ig=1,ngrid + if(wa(ig,k,l).le.1.e-10) lmax(ig,k)=l-1 + enddo + enddo + enddo + +c print*,'5 OK convect8' +c Calcule du w max du thermique + do k=1,nlay + do ig=1,ngrid + wmax(ig,k)=0. + enddo + enddo + + do k=1,nlay-1 + do l=k,nlay + do ig=1,ngrid + if (l.le.lmax(ig,k)) then + wa(ig,k,l)=sqrt(wa(ig,k,l)) + wmax(ig,k)=max(wmax(ig,k),wa(ig,k,l)) + else + wa(ig,k,l)=0. + endif + enddo + enddo + enddo + + do k=1,nlay-1 + do ig=1,ngrid + pu_therm(ig,k)=sqrt(wmax(ig,k)) + pv_therm(ig,k)=sqrt(wmax(ig,k)) + enddo + enddo + +c print*,'6 OK convect8' +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=500. + enddo +c print*,'LMAX LMAX LMAX ' + do k=1,nlay-1 + do ig=1,ngrid + zmax(ig)=max(zmax(ig),zlev(ig,lmax(ig,k))-zlev(ig,k)) + enddo +c print*,k,lmax(1,k) + enddo +c print*,'ZMAX ZMAX ZMAX ',zmax +c call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX ') + +c Calcul de l'entrainement. +c Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur +c de la couche d'alimentation en partant du principe que la vitesse +c maximum dans l'ascendance est la vitesse d'entrainement horizontale. + do k=1,nlay + do ig=1,ngrid + zzz=rho(ig,k)*wmax(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + s /(zmax(ig)*r_aspect) + if(w2di.eq.2) then + entr(ig,k)=entr(ig,k)+ + s ptimestep*(zzz-entr(ig,k))/tho + else + entr(ig,k)=zzz + endif + ztva(ig,k)=ztv(ig,k) + enddo + enddo + +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + + + do l=1,nlay-2 + do ig=1,ngrid +c if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then +c print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1) + if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr(ig,l).gt.1.e-10) then +c print*,'COUCOU cas 1' +c Initialisation de l'ascendance +c lmix(ig)=1 + ztva(ig,l)=ztv(ig,l) + fmc(ig,l)=0. + fmc(ig,l+1)=entr(ig,l) + zw2(ig,l)=0. +c if (.not.ztv(ig,l+1).gt.150.) then +c print*,'ig,l+1,ztv(ig,l+1)' +c print*, ig,l+1,ztv(ig,l+1) +c endif + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + larg_detr(ig,l)=0. + else if (zw2(ig,l).ge.1.e-10.and. + . fmc(ig,l)+entr(ig,l).gt.1.e-10) then +c Incrementation... + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) +c if (.not.fmc(ig,l+1).gt.1.e-15) then +c print*,'ig,l+1,fmc(ig,l+1)' +c print*, ig,l+1,fmc(ig,l+1) +c print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1) +c print*,'W2 ',(zw2(ig,ll),ll=1,klev+1) +c print*,'Tv ',(ztv(ig,ll),ll=1,klev) +c print*,'Entr ',(entr(ig,ll),ll=1,klev) +c endif + ztva(ig,l)=(fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l)) + s /fmc(ig,l+1) +c mise a jour de la vitesse ascendante (l'air entraine de la couche +c consideree commence avec une vitesse nulle). + zw2(ig,l+1)=zw2(ig,l)*(fmc(ig,l)/fmc(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif + if (zw2(ig,l+1).lt.0.) then + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif +c print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig) + enddo + enddo + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. + + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) + if(l.gt.lmix(ig)) then + xxx(ig,l)=(lmaxa(ig)+1.-l) / (lmaxa(ig)+1.-lmix(ig)) + if (idetr.eq.0) then + fraca(ig,l)=fraca(ig,lmix(ig)) + else if (idetr.eq.1) then + fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fraca(ig,lmix(ig))*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)**2 + endif + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo + +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + abort_message = 'fracd trop petit' + CALL abort_gcm (modname,abort_message,1) + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/tho + entr0=entr0+ptimestep*(entr-entr0)/tho + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + + SUBROUTINE thermcell_cld(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi,zlev,debut + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0,zqla,lmax + s ,zmax_sec,wmax_sec,zw_sec,lmix_sec + s ,ratqscth,ratqsdiff +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di + REAL tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) + real alpha + save alpha + data alpha/1./ +c$OMP THREADPRIVATE(alpha) + +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + real zmax_sec(klon) + real zmax_sec2(klon) + real zw_sec(klon,klev+1) + INTEGER lmix_sec(klon) + real w_est(klon,klev+1) +con garde le zmax du pas de temps precedent +c real zmax0(klon) +c save zmax0 +c real zmix0(klon) +c save zmix0 + REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:) +c$OMP THREADPRIVATE(zmax0, zmix0) + + real zlev(klon,klev+1),zlay(klon,klev) + real deltaz(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + real zthl(klon,klev),zdthladj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + real zl(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zta(klon,klev) + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev) + real q2(klon,klev) + real dtheta(klon,klev) +! common/comtherm/thetath2,wth2 + + real ratqscth(klon,klev) + real sum + real sumdiff + real ratqsdiff(klon,klev) + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wmax_sec(klon) + real wmax_sec2(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real massetot(klon,klev) + real detr0(klon,klev) + real alim0(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + + real zcor,zdelta,zcvm5,qlbef + real Tbef(klon),qsatbef(klon) + real dqsat_dT,DT,num,denom + REAL REPS,RLvCp,DDT0 + real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev) +cCR niveau de condensation + real nivcon(klon) + real zcon(klon) + real zqsat(klon,klev) + real zqsatth(klon,klev) + PARAMETER (DDT0=.01) + + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real detr_star(klon,klev) + real alim_star_tot(klon),alim_star2(klon) + real entr_star_tot(klon) + real detr_star_tot(klon) + real alim_star(klon,klev) + real alim(klon,klev) + real nu(klon,klev) + real nu_e(klon,klev) + real nu_min + real nu_max + real nu_r + real f(klon) +c real f(klon), f0(klon) +c save f0 + REAL,SAVE, ALLOCATABLE :: f0(:) +c$OMP THREADPRIVATE(f0) + + real f_old + real zlevinter(klon) + logical, save :: first = .true. +c$OMP THREADPRIVATE(first) +c data first /.false./ +c save first + logical nuage +c save nuage + logical boucle + logical therm + logical debut + logical rale + integer test(klon) + integer signe_zw2 +cRC + + character*2 str2 + character*10 str10 + + character (len=20) :: modname='thermcell_cld' + character (len=80) :: abort_message + + LOGICAL vtest(klon),down + LOGICAL Zsat(klon) + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c + +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + if (first) then + allocate(zmix0(klon)) + allocate(zmax0(klon)) + allocate(f0(klon)) + first=.false. + endif + + sorties=.false. +c print*,'NOUVEAU DETR PLUIE ' + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c Initialisation + RLvCp = RLVTT/RCPD + REPS = RD/RV +cinitialisations de zqsat + DO ll=1,nlay + DO ig=1,ngrid + zqsat(ig,ll)=0. + zqsatth(ig,ll)=0. + ENDDO + ENDDO +c +con met le first a true pour le premier passage de la journée + do ig=1,klon + test(ig)=0 + enddo + if (debut) then + do ig=1,klon + test(ig)=1 + f0(ig)=0. + zmax0(ig)=0. + enddo + endif + do ig=1,klon + if ((.not.debut).and.(f0(ig).lt.1.e-10)) then + test(ig)=1 + endif + enddo +c do ig=1,klon +c print*,'test(ig)',test(ig),zmax0(ig) +c enddo + nuage=.false. +c----------------------------------------------------------------------- +cAM Calcul de T,q,ql a partir de Tl et qT +c --------------------------------------------------- +c +c Pr Tprec=Tl calcul de qsat +c Si qsat>qT T=Tl, q=qT +c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) +c On cherche DDT < DDT0 +c +c defaut + DO ll=1,nlay + DO ig=1,ngrid + zo(ig,ll)=po(ig,ll) + zl(ig,ll)=0. + zh(ig,ll)=pt(ig,ll) + EndDO + EndDO + do ig=1,ngrid + Zsat(ig)=.false. + enddo +c +c + DO ll=1,nlay +c les points insatures sont definitifs + DO ig=1,ngrid + Tbef(ig)=pt(ig,ll) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 1.e-10) + EndDO + + DO ig=1,ngrid + if (Zsat(ig).and.(1.eq.1)) then + qlbef=max(0.,po(ig,ll)-qsatbef(ig)) +c si sature: ql est surestime, d'ou la sous-relax + DT = 0.5*RLvCp*qlbef +c write(18,*),'DT0=',DT +c on pourra enchainer 2 ou 3 calculs sans Do while + do while (abs(DT).gt.DDT0) +c il faut verifier si c,a conserve quand on repasse en insature ... + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor +c on veut le signe de qlbef + qlbef=po(ig,ll)-qsatbef(ig) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + if (denom.lt.1.e-10) then + print*,'pb denom' + endif + DT=num/denom + enddo +c on ecrit de maniere conservative (sat ou non) + zl(ig,ll) = max(0.,qlbef) +c T = Tl +Lv/Cp ql + zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) + zo(ig,ll) = po(ig,ll)-zl(ig,ll) + endif +con ecrit zqsat + zqsat(ig,ll)=qsatbef(ig) + EndDO + EndDO +cAM fin +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + +c print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA +c zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA +c zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) +c zo(ig,l)=po(ig,l) +c ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +cAM attention zh est maintenant le profil de T et plus le profil de theta ! +c +c T-> Theta + ztv(ig,l)=zh(ig,l)/zpspsk(ig,l) +cAM Theta_v + ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l)) + s -zl(ig,l)) +cAM Thetal + zthl(ig,l)=pt(ig,l)/zpspsk(ig,l) +c +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo +ccalcul de deltaz + do l=1,nlay + do ig=1,ngrid + deltaz(ig,l)=zlev(ig,l+1)-zlev(ig,l) + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid +c rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo +cCr:ajout:calcul de la masse + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des alim_star tels que alim=f*alim_star + do l=1,klev + do ig=1,ngrid + alim_star(ig,l)=0. + alim(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + therm=.false. + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k+1 + therm=.true. + endif + enddo + enddo +c +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.lt.lentr(ig)) then +cdef possibles pour alim_star: zdthetadz, dthetadz, zdtheta + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) +c s *(zlev(ig,l+1)-zlev(ig,l)) + s *sqrt(zlev(ig,l+1)) +c alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1) +c s /zlev(ig,lentr(ig)+2)))**(3./2.) + endif + enddo + enddo + +c pas de thermique si couche 1 stable + do ig=1,ngrid +c if (lmin(ig).gt.1) then +cCRnouveau test + if (alim_star(ig,1).lt.1.e-10) then + do l=1,klev + alim_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + alim_star_tot(ig)=0. + entr_star_tot(ig)=0. + detr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k) + enddo + enddo +c +c Calcul entrainement normalise + do ig=1,ngrid + if (alim_star_tot(ig).gt.1.e-10) then +c do l=1,lentr(ig) + do l=1,klev +cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + enddo + endif + enddo + +c print*,'fin calcul alim_star' + +cAM:initialisations + do k=1,nlay + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + ztla(ig,k)=zthl(ig,k) + zqla(ig,k)=0. + zqta(ig,k)=po(ig,k) + Zsat(ig) =.false. + enddo + enddo + do k=1,klev + do ig=1,ngrid + detr_star(ig,k)=0. + entr_star(ig,k)=0. + detr(ig,k)=0. + entr(ig,k)=0. + enddo + enddo +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +cn print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + + nu_min=l_mix + nu_max=1000. +c do ig=1,ngrid +c nu_max=wmax_sec(ig) +c enddo + do ig=1,ngrid + do k=1,klev + nu(ig,k)=0. + nu_e(ig,k)=0. + enddo + enddo +cCalcul de l'excès de température du à la diffusion turbulente + do ig=1,ngrid + do l=1,klev + dtheta(ig,l)=0. + enddo + enddo + do ig=1,ngrid + do l=1,lentr(ig)-1 + dtheta(ig,l)=sqrt(10.*0.4*zlev(ig,l+1)**2*1. + s *((ztv(ig,l+1)-ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2) + enddo + enddo +c do l=1,nlay-2 + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.alim_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then +cAM +ctest:on rajoute un excès de T dans couche alim +c ztla(ig,l)=zthl(ig,l)+dtheta(ig,l) + ztla(ig,l)=zthl(ig,l) +ctest: on rajoute un excès de q dans la couche alim +c zqta(ig,l)=po(ig,l)+0.001 + zqta(ig,l)=po(ig,l) + zqla(ig,l)=zl(ig,l) +cAM + f_star(ig,l+1)=alim_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + w_est(ig,l+1)=zw2(ig,l+1) + larg_detr(ig,l)=0. +c print*,'coucou boucle 1' + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then +c print*,'coucou boucle 2' +cestimation du detrainement a partir de la geometrie du pas precedent + if ((test(ig).eq.1).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then + detr_star(ig,l)=0. + entr_star(ig,l)=0. +c print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig) + else +c print*,'coucou debut detr' +ctests sur la definition du detr + if (zqla(ig,l-1).gt.1.e-10) then + nuage=.true. + endif + + w_est(ig,l+1)=zw2(ig,l)* + s ((f_star(ig,l))**2) + s /(f_star(ig,l)+alim_star(ig,l))**2+ + s 2.*RG*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + if (w_est(ig,l+1).lt.0.) then + w_est(ig,l+1)=zw2(ig,l) + endif + if (l.gt.2) then + if ((w_est(ig,l+1).gt.w_est(ig,l)).and. + s (zlev(ig,l+1).lt.zmax_sec(ig)).and. + s (zqla(ig,l-1).lt.1.e-10)) then + detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1) + s *sqrt(w_est(ig,l+1))*sqrt(nu(ig,l)*zlev(ig,l+1)) + s -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(nu(ig,l)*zlev(ig,l))) + s /(r_aspect*zmax_sec(ig))) + else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and. + s (zqla(ig,l-1).lt.1.e-10)) then + detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig)) + s /(rhobarz(ig,lmix(ig))*wmaxa(ig))* + s (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1)) + s *((zmax_sec(ig)-zlev(ig,l+1))/((zmax_sec(ig)-zlev(ig,lmix(ig))))) + s **2. + s -rhobarz(ig,l)*sqrt(w_est(ig,l)) + s *((zmax_sec(ig)-zlev(ig,l))/((zmax_sec(ig)-zlev(ig,lmix(ig))))) + s **2.) + else + detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + + endif + else + detr_star(ig,l)=0. + endif + + detr_star(ig,l)=detr_star(ig,l)/f0(ig) + if (nuage) then + entr_star(ig,l)=0.4*detr_star(ig,l) + else + entr_star(ig,l)=0.4*detr_star(ig,l) + endif + + if ((detr_star(ig,l)).gt.f_star(ig,l)) then + detr_star(ig,l)=f_star(ig,l) +c entr_star(ig,l)=0. + endif + + if ((l.lt.lentr(ig))) then + entr_star(ig,l)=0. +c detr_star(ig,l)=0. + endif + +c print*,'ok detr_star' + endif +cprise en compte du detrainement dans le calcul du flux + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) + s -detr_star(ig,l) +ctest +c if (f_star(ig,l+1).lt.0.) then +c f_star(ig,l+1)=0. +c entr_star(ig,l)=0. +c detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l) +c endif +ctest sur le signe de f_star + if (f_star(ig,l+1).gt.1.e-10) then +c then +ctest +c if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then +cAM on melange Tl et qt du thermique +con rajoute un excès de T dans la couche alim +c if (l.lt.lentr(ig)) then +c ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ +c s (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l))) +c s /(f_star(ig,l+1)+detr_star(ig,l)) +c else + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ + s (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) + s /(f_star(ig,l+1)+detr_star(ig,l)) +c s /(f_star(ig,l+1)) +c endif +con rajoute un excès de q dans la couche alim +c if (l.lt.lentr(ig)) then +c zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ +c s (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001)) +c s /(f_star(ig,l+1)+detr_star(ig,l)) +c else + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ + s (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) + s /(f_star(ig,l+1)+detr_star(ig,l)) +c s /(f_star(ig,l+1)) +c endif +cAM on en deduit thetav et ql du thermique +cCR test +c Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) + Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 1.e-10) + + if (Zsat(ig).and.(1.eq.1)) then + qlbef=max(0.,zqta(ig,l)-qsatbef(ig)) + DT = 0.5*RLvCp*qlbef +c write(17,*)'DT0=',DT + do while (abs(DT).gt.DDT0) +c print*,'aie' + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + qlbef=zqta(ig,l)-qsatbef(ig) + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + if (denom.lt.1.e-10) then + print*,'pb denom' + endif + DT=num/denom +c write(17,*)'DT=',DT + enddo + zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) + zqla(ig,l) = max(0.,qlbef) +c zqla(ig,l)=0. + endif +c zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) +c +c on ecrit de maniere conservative (sat ou non) +c T = Tl +Lv/Cp ql +cCR rq utilisation de humidite specifique ou rapport de melange? + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +con rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) +c if (l.lt.lentr(ig)) then +c ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) +c s -zqla(ig,l))-zqla(ig,l)) + 0.1 +c else + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) + s -zqla(ig,l))-zqla(ig,l)) +c endif +c ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) +c s /(1.-retv*zqla(ig,l)) +c ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +c ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) +c s /(1.-retv*zqta(ig,l)) +c s -zqla(ig,l)/(1.-retv*zqla(ig,l))) +c s -zqla(ig,l)/(1.-retv*zqla(ig,l))) +c write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l)) +con ecrit zqsat + zqsatth(ig,l)=qsatbef(ig) +c enddo +c DO ig=1,ngrid +c if (zw2(ig,l).ge.1.e-10.and. +c s f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then +c mise a jour de la vitesse ascendante (l'air entraine de la couche +c consideree commence avec une vitesse nulle). +c +c if (f_star(ig,l+1).gt.1.e-10) then + zw2(ig,l+1)=zw2(ig,l)* +c s ((f_star(ig,l)-detr_star(ig,l))**2) +c s /f_star(ig,l+1)**2+ + s ((f_star(ig,l))**2) + s /(f_star(ig,l+1)+detr_star(ig,l))**2+ +c s /(f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) +c s *(f_star(ig,l)/f_star(ig,l+1))**2 + + endif + endif +c + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. +c print*,'linter=',linter(ig) +c else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then +c linter(ig)=l+1 +c print*,'linter=l',zw2(ig,l),zw2(ig,l+1) + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) +c wa_moy(ig,l+1)=zw2(ig,l+1) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + lentr(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then + print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) +cpour le cas ou on prend tjs lmin=1 +c zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1)) + zmax0(ig)=zmax(ig) + write(11,*)'ig,lmax,linter',ig,lmax(ig),linter(ig) + write(12,*)'ig,zlevinter,zmax',ig,zmax(ig),zlevinter(ig) + enddo + +cCalcul de zmax_sec et wmax_sec + call fermeture_seche(ngrid,nlay + s ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk + s ,alim,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect + s ,zmax_sec2,wmax_sec2) + + print*,'avant fermeture' +c Fermeture,determination de f +c en lmax f=d-e + do ig=1,ngrid +c entr_star(ig,lmax(ig))=0. +c f_star(ig,lmax(ig)+1)=0. +c detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig)) +c s +alim_star(ig,lmax(ig)) + enddo +c + do ig=1,ngrid + alim_star2(ig)=0. + enddo +ccalcul de entr_star_tot + do ig=1,ngrid + do k=1,lmix(ig) + entr_star_tot(ig)=entr_star_tot(ig) +c s +entr_star(ig,k) + s +alim_star(ig,k) +c s -detr_star(ig,k) + detr_star_tot(ig)=detr_star_tot(ig) +c s +alim_star(ig,k) + s -detr_star(ig,k) + s +entr_star(ig,k) + enddo + enddo + + do ig=1,ngrid + if (alim_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else +c do k=lmin(ig),lentr(ig) + do k=1,lentr(ig) + alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo + if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then + f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect + s *alim_star2(ig)) + f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ + s zmax_sec(ig))*wmax_sec(ig)) + else + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig)) + f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/ + s zmax(ig))*wmax(ig)) + endif + endif + f0(ig)=f(ig) + enddo + print*,'apres fermeture' +c Calcul de l'entrainement + do ig=1,ngrid + do k=1,klev + alim(ig,k)=f(ig)*alim_star(ig,k) + enddo + enddo +cCR:test pour entrainer moins que la masse +c do ig=1,ngrid +c do l=1,lentr(ig) +c if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then +c alim(ig,l+1)=alim(ig,l+1)+alim(ig,l) +c s -0.9*masse(ig,l)/ptimestep +c alim(ig,l)=0.9*masse(ig,l)/ptimestep +c endif +c enddo +c enddo +c calcul du détrainement + do ig=1,klon + do k=1,klev + detr(ig,k)=f(ig)*detr_star(ig,k) + if (detr(ig,k).lt.0.) then +c print*,'detr1<0!!!' + endif + enddo + do k=1,klev + entr(ig,k)=f(ig)*entr_star(ig,k) + if (entr(ig,k).lt.0.) then +c print*,'entr1<0!!!' + endif + enddo + enddo +c +c do ig=1,ngrid +c do l=1,klev +c if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt. +c s (masse(ig,l))) then +c print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a=' +c s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l) +c endif +c enddo +c enddo +c Calcul des flux + + do ig=1,ngrid + do l=1,lmax(ig) +c do l=1,klev +c fmc(ig,l+1)=f(ig)*f_star(ig,l+1) + fmc(ig,l+1)=fmc(ig,l)+alim(ig,l)+entr(ig,l)-detr(ig,l) +c print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), +c s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), +c s 'f+1=',fmc(ig,l+1) + if (fmc(ig,l+1).lt.0.) then + print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1) + fmc(ig,l+1)=fmc(ig,l) + detr(ig,l)=alim(ig,l)+entr(ig,l) +c fmc(ig,l+1)=0. +c print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1) + endif +c if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then +c f_old=fmc(ig,l+1) +c fmc(ig,l+1)=fmc(ig,l) +c detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) +c endif + +c if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then +c f_old=fmc(ig,l+1) +c fmc(ig,l+1)=fmc(ig,l) +c detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l) +c endif +crajout du test sur alpha croissant +cif test +c if (1.eq.0) then + + if (l.eq.klev) then + print*,'THERMCELL PB ig=',ig,' l=',l + abort_message = 'THERMCELL PB' + CALL abort_gcm (modname,abort_message,1) + endif +! if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and. +! s (l.ge.lentr(ig)).and. + if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and. + s (l.ge.lentr(ig)) ) then + if ( ((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt. + s (fmc(ig,l)/(rhobarz(ig,l)*zw2(ig,l))))) then + f_old=fmc(ig,l+1) + fmc(ig,l+1)=fmc(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1) + s /(rhobarz(ig,l)*zw2(ig,l)) + detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) +c detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.) +c entr(ig,l)=0.4*detr(ig,l) +c entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l) + endif + endif + if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then + f_old=fmc(ig,l+1) + fmc(ig,l+1)=fmc(ig,l) + detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) + endif + if (detr(ig,l).gt.fmc(ig,l)) then + detr(ig,l)=fmc(ig,l) + entr(ig,l)=fmc(ig,l+1)-alim(ig,l) + endif + if (fmc(ig,l+1).lt.0.) then + detr(ig,l)=detr(ig,l)+fmc(ig,l+1) + fmc(ig,l+1)=0. + print*,'fmc2<0',l+1,lmax(ig) + endif + +ctest pour ne pas avoir f=0 et d=e/=0 +c if (fmc(ig,l+1).lt.1.e-10) then +c detr(ig,l+1)=0. +c entr(ig,l+1)=0. +c zqla(ig,l+1)=0. +c zw2(ig,l+1)=0. +c lmax(ig)=l+1 +c zmax(ig)=zlev(ig,lmax(ig)) +c endif + if (zw2(ig,l+1).gt.1.e-10) then + if ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt. + s 1.)) then + f_old=fmc(ig,l+1) + fmc(ig,l+1)=rhobarz(ig,l+1)*zw2(ig,l+1) + zw2(ig,l+1)=0. + zqla(ig,l+1)=0. + detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) + lmax(ig)=l+1 + zmax(ig)=zlev(ig,lmax(ig)) + print*,'alpha>1',l+1,lmax(ig) + endif + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cendif test +c endif + enddo + enddo + do ig=1,ngrid +c if (fmc(ig,lmax(ig)+1).ne.0.) then + fmc(ig,lmax(ig)+1)=0. + entr(ig,lmax(ig))=0. + detr(ig,lmax(ig))=fmc(ig,lmax(ig))+entr(ig,lmax(ig)) + s +alim(ig,lmax(ig)) +c endif + enddo +ctest sur le signe de fmc + do ig=1,ngrid + do l=1,klev+1 + if (fmc(ig,l).lt.0.) then + print*,'fm1<0!!!','ig=',ig,'l=',l,'a=',alim(ig,l-1),'e=' + s ,entr(ig,l-1),'f=',fmc(ig,l-1),'d=',detr(ig,l-1),'f+1=',fmc(ig,l) + endif + enddo + enddo +ctest de verification + do ig=1,ngrid + do l=1,lmax(ig) + if ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+detr(ig,l))) + s .gt.1.e-4) then +c print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig), +c s 'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l), +c s 'f+1=',fmc(ig,l+1) + endif + if (detr(ig,l).lt.0.) then + print*,'detrdemi<0!!!' + endif + enddo + enddo +c +cRC +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) + print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).le.0.) then + zmix(ig)=0.9*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo + do ig=1,klon + zmix0(ig)=zmix(ig) + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c +cne devrait pas arriver!!!!! + do ig=1,ngrid + do l=1,klev + if (detr(ig,l).gt.(fmc(ig,l)+alim(ig,l))+entr(ig,l)) then + print*,'detr2>fmc2!!!','ig=',ig,'l=',l,'d=',detr(ig,l), + s 'f=',fmc(ig,l),'lmax=',lmax(ig) +c detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l) +c entr(ig,l)=0. +c fmc(ig,l+1)=0. +c zw2(ig,l+1)=0. +c zqla(ig,l+1)=0. + print*,'pb!fm=0 et f_star>0',l,lmax(ig) +c lmax(ig)=l + endif + enddo + enddo + do ig=1,ngrid + do l=lmax(ig)+1,klev+1 +c fmc(ig,l)=0. +c detr(ig,l)=0. +c entr(ig,l)=0. +c zw2(ig,l)=0. +c zqla(ig,l)=0. + enddo + enddo + +cCalcul du detrainement lors du premier passage +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmax(ig).and.(test(ig).eq.1)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmax(ig).and.(test(ig).eq.1)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then + print*,'pb l_mix*zlev<0' + endif +cCR: test: nouvelle def de lambda +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + if (zw2(ig,l).gt.1.e-10) then + larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + else + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + endif +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c cal1cul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + if (test(ig).eq.1) then + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + endif + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + + print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + if (test(ig).eq.1) then + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (alim(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + endif + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1.and.(test(ig).eq.1)) then + abort_message = 'fracd trop petit' + CALL abort_gcm (modname,abort_message,1) + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay+1 + do ig=1,ngrid + if (test(ig).eq.0) then + fm(ig,l)=fmc(ig,l) + endif + enddo + enddo + +cfin du first + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + + print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then + print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' + s ,fm(ig,l+1)*ptimestep + s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if((alim(ig,l)+entr(ig,l))*ptimestep.gt.masse(ig,l)) then + print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' + s ,(entr(ig,l)+alim(ig,l))*ptimestep + s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.alim(ig,l).ge.0..or..not.alim(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr +cCR:test:on ne change pas la def du entr mais la def du fm + do l=1,nlay + do ig=1,ngrid + if (test(ig).eq.1) then + detr(ig,l)=fm(ig,l)+alim(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) + fm(ig,l+1)=fm(ig,l)+alim(ig,l) + detr(ig,l)=0. +c write(11,*)'l,ig,entr',l,ig,entr(ig,l) +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + endif + enddo + enddo +cRC + + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/tho + entr0=entr0+ptimestep*(alim+entr-entr0)/tho + else + fm0=fm + entr0=alim+entr + detr0=detr + alim0=alim +c zoa=zqta +c entr0=alim + endif + + if (1.eq.1) then +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zh,zdhadj,zha) +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zo,pdoadj,zoa) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse, + . zthl,zdthladj,zta) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse, + . po,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + +cCalcul des moments +c do l=1,nlay +c do ig=1,ngrid +c zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) +c zf2=zf/(1.-zf) +c thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 +c wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 +c enddo +c enddo + + + + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid +c pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + + print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ +ccalcul de fraca pour les sorties + do l=2,klev + do ig=1,klon + if (zw2(ig,l).gt.1.e-10) then + fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l)) + else + fraca(ig,l)=0. + endif + enddo + enddo + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo +c CR calcul du niveau de condensation +c initialisation + do ig=1,ngrid + nivcon(ig)=0. + zcon(ig)=0. + enddo + do k=nlay,1,-1 + do ig=1,ngrid + if (zqla(ig,k).gt.1e-10) then + nivcon(ig)=k + zcon(ig)=zlev(ig,k) + endif +c if (zcon(ig).gt.1.e-10) then +c nuage=.true. +c else +c nuage=.false. +c endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + zf=fraca(ig,l) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2 + wth2(ig,l)=zf2*(zw2(ig,l))**2 +c print*,'wth2=',wth2(ig,l) + wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l)) + s *zw2(ig,l)*zw2(ig,l)*zw2(ig,l) + q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2 +ctest: on calcul q2/po=ratqsc +c if (nuage) then + ratqscth(ig,l)=sqrt(q2(ig,l))/(po(ig,l)*1000.) +c else +c ratqscth(ig,l)=0. +c endif + enddo + enddo +ccalcul du ratqscdiff + sum=0. + sumdiff=0. + ratqsdiff(:,:)=0. + do ig=1,ngrid + do l=1,lentr(ig) + sum=sum+alim_star(ig,l)*zqta(ig,l)*1000. + enddo + enddo + do ig=1,ngrid + do l=1,lentr(ig) + zf=fraca(ig,l) + zf2=zf/(1.-zf) + sumdiff=sumdiff+alim_star(ig,l) + s *(zqta(ig,l)*1000.-sum)**2 +c ratqsdiff=ratqsdiff+alim_star(ig,l)* +c s (zqta(ig,l)*1000.-po(ig,l)*1000.)**2 + enddo + enddo + do l=1,klev + do ig=1,ngrid + ratqsdiff(ig,l)=sqrt(sumdiff)/(po(ig,l)*1000.) +c write(11,*)'ratqsdiff=',ratqsdiff(ig,l) + enddo + enddo +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' +c call wrgradsfi(1,nlay,wd,'wd ','wd ') +c call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') +c call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') +c call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy +c call wrgradsfi(1,nlay,zla,'la ','la ') +c call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,w_est,'w_est ','w_est ') +con sort les moments + call wrgradsfi(1,nlay,thetath2,'zh2 ','zh2 ') + call wrgradsfi(1,nlay,wth2,'w2 ','w2 ') + call wrgradsfi(1,nlay,wth3,'w3 ','w3 ') + call wrgradsfi(1,nlay,q2,'q2 ','q2 ') + call wrgradsfi(1,nlay,dtheta,'dT ','dT ') +c + call wrgradsfi(1,nlay,zw_sec,'zw_sec ','zw_sec ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + call wrgradsfi(1,nlay,nu,'nu ','nu ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,zoa,'zoa ','zoa ') +c call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') +c call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cAM:nouveaux diagnostiques + call wrgradsfi(1,nlay,zthl,'zthl ','zthl ') + call wrgradsfi(1,nlay,zta,'zta ','zta ') + call wrgradsfi(1,nlay,zl,'zl ','zl ') + call wrgradsfi(1,nlay,zdthladj,'zdthladj ', + s 'zdthladj ') + call wrgradsfi(1,nlay,ztla,'ztla ','ztla ') + call wrgradsfi(1,nlay,zqta,'zqta ','zqta ') + call wrgradsfi(1,nlay,zqla,'zqla ','zqla ') + call wrgradsfi(1,nlay,deltaz,'deltaz ','deltaz ') +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,detr_star ,'detr_star ','detr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,nlay,zqsat ,'zqsat ','zqsat ') + call wrgradsfi(1,nlay,zqsatth ,'qsath ','qsath ') + call wrgradsfi(1,nlay,alim_star ,'alim_star ','alim_star ') + call wrgradsfi(1,nlay,alim ,'alim ','alim ') + call wrgradsfi(1,1,f,'f ','f ') + call wrgradsfi(1,1,alim_star_tot,'a_s_t ','a_s_t ') + call wrgradsfi(1,1,alim_star2,'a_2 ','a_2 ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmax_sec,'z_sec ','z_sec ') +c call wrgradsfi(1,1,zmax_sec2,'zz_se ','zz_se ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + call wrgradsfi(1,1,nivcon,'nivcon ','nivcon ') + call wrgradsfi(1,1,zcon,'zcon ','zcon ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + call wrgradsfi(1,1,wmax_sec,'w_sec ','w_sec ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + + print*,'19 OK convect8' + return + end + SUBROUTINE thermcell_eau(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di + REAL tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + real zthl(klon,klev),zdthladj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + real zl(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zta(klon,klev) + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + + real zcor,zdelta,zcvm5,qlbef + real Tbef(klon),qsatbef(klon) + real dqsat_dT,DT,num,denom + REAL REPS,RLvCp,DDT0 + real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev) + + PARAMETER (DDT0=.01) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) + +cRC + + character*2 str2 + character*10 str10 + + character (len=20) :: modname='thermcell_eau' + character (len=80) :: abort_message + + LOGICAL vtest(klon),down + LOGICAL Zsat(klon) + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c + +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c Initialisation + RLvCp = RLVTT/RCPD + REPS = RD/RV +c +c----------------------------------------------------------------------- +cAM Calcul de T,q,ql a partir de Tl et qT +c --------------------------------------------------- +c +c Pr Tprec=Tl calcul de qsat +c Si qsat>qT T=Tl, q=qT +c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) +c On cherche DDT < DDT0 +c +c defaut + DO ll=1,nlay + DO ig=1,ngrid + zo(ig,ll)=po(ig,ll) + zl(ig,ll)=0. + zh(ig,ll)=pt(ig,ll) + EndDO + EndDO + do ig=1,ngrid + Zsat(ig)=.false. + enddo +c +c + DO ll=1,nlay +c les points insatures sont definitifs + DO ig=1,ngrid + Tbef(ig)=pt(ig,ll) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 0.00001) + EndDO + + DO ig=1,ngrid + if (Zsat(ig)) then + qlbef=max(0.,po(ig,ll)-qsatbef(ig)) +c si sature: ql est surestime, d'ou la sous-relax + DT = 0.5*RLvCp*qlbef +c on pourra enchainer 2 ou 3 calculs sans Do while + do while (DT.gt.DDT0) +c il faut verifier si c,a conserve quand on repasse en insature ... + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor +c on veut le signe de qlbef + qlbef=po(ig,ll)-qsatbef(ig) +c dqsat_dT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo +c on ecrit de maniere conservative (sat ou non) + zl(ig,ll) = max(0.,qlbef) +c T = Tl +Lv/Cp ql + zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll) + zo(ig,ll) = po(ig,ll)-zl(ig,ll) + endif + EndDO + EndDO +cAM fin +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + + print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA +c zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) +c zo(ig,l)=po(ig,l) +c ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +cAM attention zh est maintenant le profil de T et plus le profil de theta ! +c +c T-> Theta + ztv(ig,l)=zh(ig,l)/zpspsk(ig,l) +cAM Theta_v + ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l)) + s -zl(ig,l)) +cAM Thetal + zthl(ig,l)=pt(ig,l)/zpspsk(ig,l) +c +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid +c rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + do k=nlay-1,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).lt.ztv(ig,k+2)) then + lentr(ig)=k + endif + enddo + enddo + +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lentr(ig)) then + entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))* + s (zlev(ig,l+1)-zlev(ig,l)) + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +cAM:initialisations + do k=1,nlay + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + ztla(ig,k)=zthl(ig,k) + zqla(ig,k)=0. + zqta(ig,k)=po(ig,k) + Zsat(ig) =.false. + enddo + enddo +c +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then +cAM + ztla(ig,l)=zthl(ig,l) + zqta(ig,l)=po(ig,l) + zqla(ig,l)=zl(ig,l) +cAM + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) +c +cAM on melange Tl et qt du thermique + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l) + s *zthl(ig,l))/f_star(ig,l+1) + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l) + s *po(ig,l))/f_star(ig,l+1) +c +c ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) +c s *ztv(ig,l))/f_star(ig,l+1) +c +cAM on en deduit thetav et ql du thermique + Tbef(ig)=ztla(ig,l)*zpspsk(ig,l) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 0.00001) + endif + enddo + DO ig=1,ngrid + if (Zsat(ig)) then + qlbef=max(0.,zqta(ig,l)-qsatbef(ig)) + DT = 0.5*RLvCp*qlbef + do while (DT.gt.DDT0) + Tbef(ig)=Tbef(ig)+DT + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l) + qsatbef(ig)=MIN(0.5,qsatbef(ig)) + zcor=1./(1.-retv*qsatbef(ig)) + qsatbef(ig)=qsatbef(ig)*zcor + qlbef=zqta(ig,l)-qsatbef(ig) + + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta + zcor=1./(1.-retv*qsatbef(ig)) + dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor) + num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef + denom=1.+RLvCp*dqsat_dT + DT=num/denom + enddo + zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig)) + endif +c on ecrit de maniere conservative (sat ou non) +c T = Tl +Lv/Cp ql + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) + s -zqla(ig,l))-zqla(ig,l)) + + enddo + DO ig=1,ngrid + if (zw2(ig,l).ge.1.e-10.and. + s f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then +c mise a jour de la vitesse ascendante (l'air entraine de la couche +c consideree commence avec une vitesse nulle). +c + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=500. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + +c Fermeture,determination de f + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig)) + s *entr_star_tot(ig) +ctest + if (first) then + f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) + s *wmax(ig)) + endif + endif + f0(ig)=f(ig) + first=.true. + enddo + +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=0. + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + abort_message = 'fracd trop petit' + CALL abort_gcm (modname,abort_message,1) + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/tho + entr0=entr0+ptimestep*(entr-entr0)/tho + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zh,zdhadj,zha) +c call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse +c . ,zo,pdoadj,zoa) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zthl,zdthladj,zta) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,po,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid +c pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cAM:nouveaux diagnostiques + call wrgradsfi(1,nlay,zthl,'zthl ','zthl ') + call wrgradsfi(1,nlay,zta,'zta ','zta ') + call wrgradsfi(1,nlay,zl,'zl ','zl ') + call wrgradsfi(1,nlay,zdthladj,'zdthladj ', + s 'zdthladj ') + call wrgradsfi(1,nlay,ztla,'ztla ','ztla ') + call wrgradsfi(1,nlay,zqta,'zqta ','zqta ') + call wrgradsfi(1,nlay,zqla,'zqla ','zqla ') +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + + SUBROUTINE thermcell(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + USE dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di + REAL tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) +cRC + + character*2 str2 + character*10 str10 + + character (len=20) :: modname='thermcell' + character (len=80) :: abort_message + + LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + + print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + + print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k + endif + enddo + enddo + +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lentr(ig)) then + entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))* + s (zlev(ig,l+1)-zlev(ig,l)) + endif + enddo + enddo +c pas de thermique si couches 1->5 stables + do ig=1,ngrid + if (lmin(ig).gt.5) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c + print*,'fin calcul entr_star' + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) + s *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then +ctest + if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then + print*,'pb linter' + endif + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + if (zw2(ig,l+1).lt.0.) then + print*,'pb1 zw2<0' + endif + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo + print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couches 1->5 stables + do ig=1,ngrid + if (lmin(ig).gt.5) then + lmax(ig)=1 + lmin(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then + print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + + print*,'avant fermeture' +c Fermeture,determination de f + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect + s *entr_star2(ig))*entr_star_tot(ig) +ctest +c if (first) then +c f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) +c s *wmax(ig)) +c endif + endif +c f0(ig)=f(ig) +c first=.true. + enddo + print*,'apres fermeture' + +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then + print*,'pb l_mix*zlev<0' + endif + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) + print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).lt.0.) then + zmix(ig)=0.99*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + + print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + abort_message = 'fracd trop petit' + CALL abort_gcm (modname,abort_message,1) + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + + print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo +cRC + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/tho + entr0=entr0+ptimestep*(entr-entr0)/tho + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + + print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +#define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + + print*,'19 OK convect8' + return + end + + subroutine dqthermcell(ngrid,nlay,ptimestep,fm,entr, + . masse,q,dq,qa) + USE dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay) + real q(ngrid,nlay) + real dq(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1) + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) +ctest + if (detr(ig,k).lt.0.) then + entr(ig,k)=entr(ig,k)-detr(ig,k) + detr(ig,k)=0. +c print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k), +c s 'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k) + endif + if (fm(ig,k+1).lt.0.) then +c print*,'fm2<0!!!' + endif + if (entr(ig,k).lt.0.) then +c print*,'entr2<0!!!' + endif + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)) + else + qa(ig,k)=q(ig,k) + endif + if (qa(ig,k).lt.0.) then +c print*,'qa<0!!!' + endif + if (q(ig,k).lt.0.) then +c print*,'q<0!!!' + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid +c wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) + wqd(ig,k)=fm(ig,k)*q(ig,k) + if (wqd(ig,k).lt.0.) then +c print*,'wqd<0!!!' + endif + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k) + s -wqd(ig,k)+wqd(ig,k+1)) + s /masse(ig,k) +c if (dq(ig,k).lt.0.) then +c print*,'dq<0!!!' +c endif + enddo + enddo + + return + end + subroutine dvthermcell(ngrid,nlay,ptimestep,fm,entr,masse + . ,fraca,larga + . ,u,v,du,dv,ua,va) + USE dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real fraca(ngrid,nlay+1) + real larga(ngrid) + real entr(ngrid,nlay) + real u(ngrid,nlay) + real ua(ngrid,nlay) + real du(ngrid,nlay) + real v(ngrid,nlay) + real va(ngrid,nlay) + real dv(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev) + real wvd(klon,klev+1),wud(klon,klev+1) + real gamma0,gamma(klon,klev+1) + real dua,dva + integer iter + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + ua(ig,1)=u(ig,1) + va(ig,1)=v(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then +c On itère sur la valeur du coeff de freinage. +c gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + gamma0=masse(ig,k) + s *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) + s *0.5/larga(ig) +c gamma0=0. +c la première fois on multiplie le coefficient de freinage +c par le module du vent dans la couche en dessous. + dua=ua(ig,k-1)-u(ig,k-1) + dva=va(ig,k-1)-v(ig,k-1) + do iter=1,5 + gamma(ig,k)=gamma0*sqrt(dua**2+dva**2) + ua(ig,k)=(fm(ig,k)*ua(ig,k-1) + s +(entr(ig,k)+gamma(ig,k))*u(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) + va(ig,k)=(fm(ig,k)*va(ig,k-1) + s +(entr(ig,k)+gamma(ig,k))*v(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k)) +c print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva + dua=ua(ig,k)-u(ig,k) + dva=va(ig,k)-v(ig,k) + enddo + else + ua(ig,k)=u(ig,k) + va(ig,k)=v(ig,k) + gamma(ig,k)=0. + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid + wud(ig,k)=fm(ig,k)*u(ig,k) + wvd(ig,k)=fm(ig,k)*v(ig,k) + enddo + enddo + do ig=1,ngrid + wud(ig,1)=0. + wud(ig,nlay+1)=0. + wvd(ig,1)=0. + wvd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) + s -(entr(ig,k)+gamma(ig,k))*u(ig,k) + s -wud(ig,k)+wud(ig,k+1)) + s /masse(ig,k) + dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) + s -(entr(ig,k)+gamma(ig,k))*v(ig,k) + s -wvd(ig,k)+wvd(ig,k+1)) + s /masse(ig,k) + enddo + enddo + + return + end + subroutine dqthermcell2(ngrid,nlay,ptimestep,fm,entr,masse,frac + . ,q,dq,qa) + USE dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real entr(ngrid,nlay),frac(ngrid,nlay) + real q(ngrid,nlay) + real dq(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1) + real qe(klon,klev),zf,zf2 + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + qa(ig,1)=q(ig,1) + qe(ig,1)=q(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then + zf=0.5*(frac(ig,k)+frac(ig,k+1)) + zf2=1./(1.-zf) + qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2) + qe(ig,k)=(q(ig,k)-zf*qa(ig,k))*zf2 + else + qa(ig,k)=q(ig,k) + qe(ig,k)=q(ig,k) + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid +c wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k)) + wqd(ig,k)=fm(ig,k)*qe(ig,k) + enddo + enddo + do ig=1,ngrid + wqd(ig,1)=0. + wqd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k) + s -wqd(ig,k)+wqd(ig,k+1)) + s /masse(ig,k) + enddo + enddo + + return + end + subroutine dvthermcell2(ngrid,nlay,ptimestep,fm,entr,masse + . ,fraca,larga + . ,u,v,du,dv,ua,va) + use dimphy + implicit none + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c calcul du dq/dt une fois qu'on connait les ascendances +c +c======================================================================= + +#include "dimensions.h" +cccc#include "dimphy.h" + + integer ngrid,nlay + + real ptimestep + real masse(ngrid,nlay),fm(ngrid,nlay+1) + real fraca(ngrid,nlay+1) + real larga(ngrid) + real entr(ngrid,nlay) + real u(ngrid,nlay) + real ua(ngrid,nlay) + real du(ngrid,nlay) + real v(ngrid,nlay) + real va(ngrid,nlay) + real dv(ngrid,nlay) + + real qa(klon,klev),detr(klon,klev),zf,zf2 + real wvd(klon,klev+1),wud(klon,klev+1) + real gamma0,gamma(klon,klev+1) + real ue(klon,klev),ve(klon,klev) + real dua,dva + integer iter + + integer ig,k + +c calcul du detrainement + + do k=1,nlay + do ig=1,ngrid + detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k) + enddo + enddo + +c calcul de la valeur dans les ascendances + do ig=1,ngrid + ua(ig,1)=u(ig,1) + va(ig,1)=v(ig,1) + ue(ig,1)=u(ig,1) + ve(ig,1)=v(ig,1) + enddo + + do k=2,nlay + do ig=1,ngrid + if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt. + s 1.e-5*masse(ig,k)) then +c On itère sur la valeur du coeff de freinage. +c gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)) + gamma0=masse(ig,k) + s *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) ) + s *0.5/larga(ig) + s *1. +c s *0.5 +c gamma0=0. + zf=0.5*(fraca(ig,k)+fraca(ig,k+1)) + zf=0. + zf2=1./(1.-zf) +c la première fois on multiplie le coefficient de freinage +c par le module du vent dans la couche en dessous. + dua=ua(ig,k-1)-u(ig,k-1) + dva=va(ig,k-1)-v(ig,k-1) + do iter=1,5 +c On choisit une relaxation lineaire. + gamma(ig,k)=gamma0 +c On choisit une relaxation quadratique. + gamma(ig,k)=gamma0*sqrt(dua**2+dva**2) + ua(ig,k)=(fm(ig,k)*ua(ig,k-1) + s +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 + s +gamma(ig,k)) + va(ig,k)=(fm(ig,k)*va(ig,k-1) + s +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k)) + s /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2 + s +gamma(ig,k)) +c print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva + dua=ua(ig,k)-u(ig,k) + dva=va(ig,k)-v(ig,k) + ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2 + ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2 + enddo + else + ua(ig,k)=u(ig,k) + va(ig,k)=v(ig,k) + ue(ig,k)=u(ig,k) + ve(ig,k)=v(ig,k) + gamma(ig,k)=0. + endif + enddo + enddo + + do k=2,nlay + do ig=1,ngrid + wud(ig,k)=fm(ig,k)*ue(ig,k) + wvd(ig,k)=fm(ig,k)*ve(ig,k) + enddo + enddo + do ig=1,ngrid + wud(ig,1)=0. + wud(ig,nlay+1)=0. + wvd(ig,1)=0. + wvd(ig,nlay+1)=0. + enddo + + do k=1,nlay + do ig=1,ngrid + du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k) + s -(entr(ig,k)+gamma(ig,k))*ue(ig,k) + s -wud(ig,k)+wud(ig,k+1)) + s /masse(ig,k) + dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k) + s -(entr(ig,k)+gamma(ig,k))*ve(ig,k) + s -wvd(ig,k)+wvd(ig,k+1)) + s /masse(ig,k) + enddo + enddo + + return + end + SUBROUTINE thermcell_sec(ngrid,nlay,ptimestep + s ,pplay,pplev,pphi,zlev + s ,pu,pv,pt,po + s ,pduadj,pdvadj,pdtadj,pdoadj + s ,fm0,entr0 +c s ,pu_therm,pv_therm + s ,r_aspect,l_mix,w2di,tho) + + use dimphy + IMPLICIT NONE + +c======================================================================= +c +c Calcul du transport verticale dans la couche limite en presence +c de "thermiques" explicitement representes +c +c Réécriture à partir d'un listing papier à Habas, le 14/02/00 +c +c le thermique est supposé homogène et dissipé par mélange avec +c son environnement. la longueur l_mix contrôle l'efficacité du +c mélange +c +c Le calcul du transport des différentes espèces se fait en prenant +c en compte: +c 1. un flux de masse montant +c 2. un flux de masse descendant +c 3. un entrainement +c 4. un detrainement +c +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" + +c arguments: +c ---------- + + INTEGER ngrid,nlay,w2di + REAL tho + real ptimestep,l_mix,r_aspect + REAL pt(ngrid,nlay),pdtadj(ngrid,nlay) + REAL pu(ngrid,nlay),pduadj(ngrid,nlay) + REAL pv(ngrid,nlay),pdvadj(ngrid,nlay) + REAL po(ngrid,nlay),pdoadj(ngrid,nlay) + REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1) + real pphi(ngrid,nlay) + + integer idetr + save idetr + data idetr/3/ +c$OMP THREADPRIVATE(idetr) + +c local: +c ------ + + INTEGER ig,k,l,lmaxa(klon),lmix(klon) + real zsortie1d(klon) +c CR: on remplace lmax(klon,klev+1) + INTEGER lmax(klon),lmin(klon),lentr(klon) + real linter(klon) + real zmix(klon), fracazmix(klon) +c RC + real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz + + real zlev(klon,klev+1),zlay(klon,klev) + REAL zh(klon,klev),zdhadj(klon,klev) + REAL ztv(klon,klev) + real zu(klon,klev),zv(klon,klev),zo(klon,klev) + REAL wh(klon,klev+1) + real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1) + real zla(klon,klev+1) + real zwa(klon,klev+1) + real zld(klon,klev+1) + real zwd(klon,klev+1) + real zsortie(klon,klev) + real zva(klon,klev) + real zua(klon,klev) + real zoa(klon,klev) + + real zha(klon,klev) + real wa_moy(klon,klev+1) + real fraca(klon,klev+1) + real fracc(klon,klev+1) + real zf,zf2 + real thetath2(klon,klev),wth2(klon,klev) +! common/comtherm/thetath2,wth2 + + real count_time + integer isplit,nsplit,ialt + parameter (nsplit=10) + data isplit/0/ + save isplit +c$OMP THREADPRIVATE(isplit) + + logical sorties + real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev) + real zpspsk(klon,klev) + +c real wmax(klon,klev),wmaxa(klon) + real wmax(klon),wmaxa(klon) + real wa(klon,klev,klev+1) + real wd(klon,klev+1) + real larg_part(klon,klev,klev+1) + real fracd(klon,klev+1) + real xxx(klon,klev+1) + real larg_cons(klon,klev+1) + real larg_detr(klon,klev+1) + real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev) + real pu_therm(klon,klev),pv_therm(klon,klev) + real fm(klon,klev+1),entr(klon,klev) + real fmc(klon,klev+1) + +cCR:nouvelles variables + real f_star(klon,klev+1),entr_star(klon,klev) + real entr_star_tot(klon),entr_star2(klon) + real f(klon), f0(klon) + real zlevinter(klon) + logical first + data first /.false./ + save first +c$OMP THREADPRIVATE(first) +cRC + + character*2 str2 + character*10 str10 + + character (len=20) :: modname='thermcell_sec' + character (len=80) :: abort_message + + LOGICAL vtest(klon),down + + EXTERNAL SCOPY + + integer ncorrec,ll + save ncorrec + data ncorrec/0/ +c$OMP THREADPRIVATE(ncorrec) + +c +c----------------------------------------------------------------------- +c initialisation: +c --------------- +c + sorties=.true. + IF(ngrid.NE.klon) THEN + PRINT* + PRINT*,'STOP dans convadj' + PRINT*,'ngrid =',ngrid + PRINT*,'klon =',klon + ENDIF +c +c----------------------------------------------------------------------- +c incrementation eventuelle de tendances precedentes: +c --------------------------------------------------- + +c print*,'0 OK convect8' + + DO 1010 l=1,nlay + DO 1015 ig=1,ngrid + zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA + zh(ig,l)=pt(ig,l)/zpspsk(ig,l) + zu(ig,l)=pu(ig,l) + zv(ig,l)=pv(ig,l) + zo(ig,l)=po(ig,l) + ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l)) +1015 CONTINUE +1010 CONTINUE + +c print*,'1 OK convect8' +c -------------------- +c +c +c + + + + + + + + + + + +c +c +c wa, fraca, wd, fracd -------------------- zlev(2), rhobarz +c wh,wt,wo ... +c +c + + + + + + + + + + + zh,zu,zv,zo,rho +c +c +c -------------------- zlev(1) +c \\\\\\\\\\\\\\\\\\\\ +c +c + +c----------------------------------------------------------------------- +c Calcul des altitudes des couches +c----------------------------------------------------------------------- + + do l=2,nlay + do ig=1,ngrid + zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG + enddo + enddo + do ig=1,ngrid + zlev(ig,1)=0. + zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG + enddo + do l=1,nlay + do ig=1,ngrid + zlay(ig,l)=pphi(ig,l)/RG + enddo + enddo + +c print*,'2 OK convect8' +c----------------------------------------------------------------------- +c Calcul des densites +c----------------------------------------------------------------------- + + do l=1,nlay + do ig=1,ngrid + rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l)) + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1)) + enddo + enddo + + do k=1,nlay + do l=1,nlay+1 + do ig=1,ngrid + wa(ig,k,l)=0. + enddo + enddo + enddo + +c print*,'3 OK convect8' +c------------------------------------------------------------------ +c Calcul de w2, quarre de w a partir de la cape +c a partir de w2, on calcule wa, vitesse de l'ascendance +c +c ATTENTION: Dans cette version, pour cause d'economie de memoire, +c w2 est stoke dans wa +c +c ATTENTION: dans convect8, on n'utilise le calcule des wa +c independants par couches que pour calculer l'entrainement +c a la base et la hauteur max de l'ascendance. +c +c Indicages: +c l'ascendance provenant du niveau k traverse l'interface l avec +c une vitesse wa(k,l). +c +c -------------------- +c +c + + + + + + + + + + +c +c wa(k,l) ---- -------------------- l +c /\ +c /||\ + + + + + + + + + + +c || +c || -------------------- +c || +c || + + + + + + + + + + +c || +c || -------------------- +c ||__ +c |___ + + + + + + + + + + k +c +c -------------------- +c +c +c +c------------------------------------------------------------------ + +cCR: ponderation entrainement des couches instables +cdef des entr_star tels que entr=f*entr_star + do l=1,klev + do ig=1,ngrid + entr_star(ig,l)=0. + enddo + enddo +c determination de la longueur de la couche d entrainement + do ig=1,ngrid + lentr(ig)=1 + enddo + +con ne considere que les premieres couches instables + do k=nlay-2,1,-1 + do ig=1,ngrid + if (ztv(ig,k).gt.ztv(ig,k+1).and. + s ztv(ig,k+1).le.ztv(ig,k+2)) then + lentr(ig)=k + endif + enddo + enddo + +c determination du lmin: couche d ou provient le thermique + do ig=1,ngrid + lmin(ig)=1 + enddo + do ig=1,ngrid + do l=nlay,2,-1 + if (ztv(ig,l-1).gt.ztv(ig,l)) then + lmin(ig)=l-1 + endif + enddo + enddo +c +c definition de l'entrainement des couches + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1).and. + s l.ge.lmin(ig).and.l.le.lentr(ig)) then + entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))* +c s (zlev(ig,l+1)-zlev(ig,l)) + s *sqrt(zlev(ig,l+1)) + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + do l=1,klev + entr_star(ig,l)=0. + enddo + endif + enddo +c calcul de l entrainement total + do ig=1,ngrid + entr_star_tot(ig)=0. + enddo + do ig=1,ngrid + do k=1,klev + entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k) + enddo + enddo +c +c print*,'fin calcul entr_star' + do k=1,klev + do ig=1,ngrid + ztva(ig,k)=ztv(ig,k) + enddo + enddo +cRC +c print*,'7 OK convect8' + do k=1,klev+1 + do ig=1,ngrid + zw2(ig,k)=0. + fmc(ig,k)=0. +cCR + f_star(ig,k)=0. +cRC + larg_cons(ig,k)=0. + larg_detr(ig,k)=0. + wa_moy(ig,k)=0. + enddo + enddo + +c print*,'8 OK convect8' + do ig=1,ngrid + linter(ig)=1. + lmaxa(ig)=1 + lmix(ig)=1 + wmaxa(ig)=0. + enddo + +cCR: + do l=1,nlay-2 + do ig=1,ngrid + if (ztv(ig,l).gt.ztv(ig,l+1) + s .and.entr_star(ig,l).gt.1.e-10 + s .and.zw2(ig,l).lt.1e-10) then + f_star(ig,l+1)=entr_star(ig,l) +ctest:calcul de dteta + zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1) + s *(zlev(ig,l+1)-zlev(ig,l)) + s *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l)) + larg_detr(ig,l)=0. + else if ((zw2(ig,l).ge.1e-10).and. + s (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then + f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l) + ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l) + s *ztv(ig,l))/f_star(ig,l+1) + zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+ + s 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + s *(zlev(ig,l+1)-zlev(ig,l)) + endif +c determination de zmax continu par interpolation lineaire + if (zw2(ig,l+1).lt.0.) then +ctest + if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then +c print*,'pb linter' + endif + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) + s -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + lmaxa(ig)=l + else + if (zw2(ig,l+1).lt.0.) then +c print*,'pb1 zw2<0' + endif + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + endif + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +c lmix est le niveau de la couche ou w (wa_moy) est maximum + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + enddo +c print*,'fin calcul zw2' +c +c Calcul de la couche correspondant a la hauteur du thermique + do ig=1,ngrid + lmax(ig)=lentr(ig) + enddo + do ig=1,ngrid + do l=nlay,lentr(ig)+1,-1 + if (zw2(ig,l).le.1.e-10) then + lmax(ig)=l-1 + endif + enddo + enddo +c pas de thermique si couche 1 stable + do ig=1,ngrid + if (lmin(ig).gt.1) then + lmax(ig)=1 + lmin(ig)=1 + endif + enddo +c +c Determination de zw2 max + do ig=1,ngrid + wmax(ig)=0. + enddo + + do l=1,nlay + do ig=1,ngrid + if (l.le.lmax(ig)) then + if (zw2(ig,l).lt.0.)then +c print*,'pb2 zw2<0' + endif + zw2(ig,l)=sqrt(zw2(ig,l)) + wmax(ig)=max(wmax(ig),zw2(ig,l)) + else + zw2(ig,l)=0. + endif + enddo + enddo + +c Longueur caracteristique correspondant a la hauteur des thermiques. + do ig=1,ngrid + zmax(ig)=0. + zlevinter(ig)=zlev(ig,1) + enddo + do ig=1,ngrid +c calcul de zlevinter + zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))* + s linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1) + s -zlev(ig,lmax(ig))) + zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig))) + enddo + +c print*,'avant fermeture' +c Fermeture,determination de f + do ig=1,ngrid + entr_star2(ig)=0. + enddo + do ig=1,ngrid + if (entr_star_tot(ig).LT.1.e-10) then + f(ig)=0. + else + do k=lmin(ig),lentr(ig) + entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2 + s /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))) + enddo +c Nouvelle fermeture + f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect + s *entr_star2(ig))*entr_star_tot(ig) +ctest +c if (first) then +c f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig) +c s *wmax(ig)) +c endif + endif +c f0(ig)=f(ig) +c first=.true. + enddo +c print*,'apres fermeture' + +c Calcul de l'entrainement + do k=1,klev + do ig=1,ngrid + entr(ig,k)=f(ig)*entr_star(ig,k) + enddo + enddo +cCR:test pour entrainer moins que la masse + do ig=1,ngrid + do l=1,lentr(ig) + if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then + entr(ig,l+1)=entr(ig,l+1)+entr(ig,l) + s -0.9*masse(ig,l)/ptimestep + entr(ig,l)=0.9*masse(ig,l)/ptimestep + endif + enddo + enddo +cCR: fin test +c Calcul des flux + do ig=1,ngrid + do l=1,lmax(ig)-1 + fmc(ig,l+1)=fmc(ig,l)+entr(ig,l) + enddo + enddo + +cRC + + +c print*,'9 OK convect8' +c print*,'WA1 ',wa_moy + +c determination de l'indice du debut de la mixed layer ou w decroit + +c calcul de la largeur de chaque ascendance dans le cas conservatif. +c dans ce cas simple, on suppose que la largeur de l'ascendance provenant +c d'une couche est égale à la hauteur de la couche alimentante. +c La vitesse maximale dans l'ascendance est aussi prise comme estimation +c de la vitesse d'entrainement horizontal dans la couche alimentante. + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then + zw=max(wa_moy(ig,l),1.e-10) + larg_cons(ig,l)=zmax(ig)*r_aspect + s *fmc(ig,l)/(rhobarz(ig,l)*zw) + endif + enddo + enddo + + do l=2,nlay + do ig=1,ngrid + if (l.le.lmaxa(ig)) then +c if (idetr.eq.0) then +c cette option est finalement en dur. + if ((l_mix*zlev(ig,l)).lt.0.)then +c print*,'pb l_mix*zlev<0' + endif +cCR: test: nouvelle def de lambda +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + if (zw2(ig,l).gt.1.e-10) then + larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l)) + else + larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) + endif +cRC +c else if (idetr.eq.1) then +c larg_detr(ig,l)=larg_cons(ig,l) +c s *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig)) +c else if (idetr.eq.2) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *sqrt(wa_moy(ig,l)) +c else if (idetr.eq.4) then +c larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l)) +c s *wa_moy(ig,l) +c endif + endif + enddo + enddo + +c print*,'10 OK convect8' +c print*,'WA2 ',wa_moy +c calcul de la fraction de la maille concernée par l'ascendance en tenant +c compte de l'epluchage du thermique. +c +cCR def de zmix continu (profil parabolique des vitesses) + do ig=1,ngrid + if (lmix(ig).gt.1.) then +c test + if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10) + s then +c + zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2)) + s /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig))) + s *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1))) + s -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1)) + s *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig)))))) + else + zmix(ig)=zlev(ig,lmix(ig)) +c print*,'pb zmix' + endif + else + zmix(ig)=0. + endif +ctest + if ((zmax(ig)-zmix(ig)).lt.0.) then + zmix(ig)=0.99*zmax(ig) +c print*,'pb zmix>zmax' + endif + enddo +c +c calcul du nouveau lmix correspondant + do ig=1,ngrid + do l=1,klev + if (zmix(ig).ge.zlev(ig,l).and. + s zmix(ig).lt.zlev(ig,l+1)) then + lmix(ig)=l + endif + enddo + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then +c print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),' KKK' + fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l)) + s /(r_aspect*zmax(ig)) +c test + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + else +c wa_moy(ig,l)=0. + fraca(ig,l)=0. + fracc(ig,l)=0. + fracd(ig,l)=1. + endif + enddo + enddo +cCR: calcul de fracazmix + do ig=1,ngrid + fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/ + s (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig) + s +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1) + s -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig))) + enddo +c + do l=2,nlay + do ig=1,ngrid + if(larg_cons(ig,l).gt.1.) then + if (l.gt.lmix(ig)) then +ctest + if (zmax(ig)-zmix(ig).lt.1.e-10) then +c print*,'pb xxx' + xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig)) + else + xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig)) + endif + if (idetr.eq.0) then + fraca(ig,l)=fracazmix(ig) + else if (idetr.eq.1) then + fraca(ig,l)=fracazmix(ig)*xxx(ig,l) + else if (idetr.eq.2) then + fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2) + else + fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2 + endif +c print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL' + fraca(ig,l)=max(fraca(ig,l),0.) + fraca(ig,l)=min(fraca(ig,l),0.5) + fracd(ig,l)=1.-fraca(ig,l) + fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig)) + endif + endif + enddo + enddo + +c print*,'fin calcul fraca' +c print*,'11 OK convect8' +c print*,'Ea3 ',wa_moy +c------------------------------------------------------------------ +c Calcul de fracd, wd +c somme wa - wd = 0 +c------------------------------------------------------------------ + + + do ig=1,ngrid + fm(ig,1)=0. + fm(ig,nlay+1)=0. + enddo + + do l=2,nlay + do ig=1,ngrid + fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l) +cCR:test + if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1) + s .and.l.gt.lmix(ig)) then + fm(ig,l)=fm(ig,l-1) +c write(1,*)'ajustement fm, l',l + endif +c write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l) +cRC + enddo + do ig=1,ngrid + if(fracd(ig,l).lt.0.1) then + abort_message = 'fracd trop petit' + CALL abort_gcm (modname,abort_message,1) + else +c vitesse descendante "diagnostique" + wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l)) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid +c masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) + masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG + enddo + enddo + +c print*,'12 OK convect8' +c print*,'WA4 ',wa_moy +cc------------------------------------------------------------------ +c calcul du transport vertical +c------------------------------------------------------------------ + + go to 4444 +c print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep + do l=2,nlay-1 + do ig=1,ngrid + if(fm(ig,l+1)*ptimestep.gt.masse(ig,l) + s .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then +c print*,'WARN!!! FM>M ig=',ig,' l=',l,' FM=' +c s ,fm(ig,l+1)*ptimestep +c s ,' M=',masse(ig,l),masse(ig,l+1) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then +c print*,'WARN!!! E>M ig=',ig,' l=',l,' E==' +c s ,entr(ig,l)*ptimestep +c s ,' M=',masse(ig,l) + endif + enddo + enddo + + do l=1,nlay + do ig=1,ngrid + if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then +c print*,'WARN!!! fm exagere ig=',ig,' l=',l +c s ,' FM=',fm(ig,l) + endif + if(.not.masse(ig,l).ge.1.e-10 + s .or..not.masse(ig,l).le.1.e4) then +c print*,'WARN!!! masse exagere ig=',ig,' l=',l +c s ,' M=',masse(ig,l) +c print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)', +c s rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l) +c print*,'zlev(ig,l+1),zlev(ig,l)' +c s ,zlev(ig,l+1),zlev(ig,l) +c print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)' +c s ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1) + endif + if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then +c print*,'WARN!!! entr exagere ig=',ig,' l=',l +c s ,' E=',entr(ig,l) + endif + enddo + enddo + +4444 continue + +cCR:redefinition du entr + do l=1,nlay + do ig=1,ngrid + detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) + if (detr(ig,l).lt.0.) then + entr(ig,l)=entr(ig,l)-detr(ig,l) + detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l + endif + enddo + enddo +cRC + if (w2di.eq.1) then + fm0=fm0+ptimestep*(fm-fm0)/tho + entr0=entr0+ptimestep*(entr-entr0)/tho + else + fm0=fm + entr0=entr + endif + + if (1.eq.1) then + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zh,zdhadj,zha) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zo,pdoadj,zoa) + else + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zh,zdhadj,zha) + call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca + . ,zo,pdoadj,zoa) + endif + + if (1.eq.0) then + call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,fraca,zmax + . ,zu,zv,pduadj,pdvadj,zua,zva) + else + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zu,pduadj,zua) + call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse + . ,zv,pdvadj,zva) + endif + + do l=1,nlay + do ig=1,ngrid + zf=0.5*(fracc(ig,l)+fracc(ig,l+1)) + zf2=zf/(1.-zf) + thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2 + wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2 + enddo + enddo + + + +c print*,'13 OK convect8' +c print*,'WA5 ',wa_moy + do l=1,nlay + do ig=1,ngrid + pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l) + enddo + enddo + + +c do l=1,nlay +c do ig=1,ngrid +c if(abs(pdtadj(ig,l))*86400..gt.500.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdtadj=',pdtadj(ig,l) +c endif +c if(abs(pdoadj(ig,l))*86400..gt.1.) then +c print*,'WARN!!! ig=',ig,' l=',l +c s ,' pdoadj=',pdoadj(ig,l) +c endif +c enddo +c enddo + +c print*,'14 OK convect8' +c------------------------------------------------------------------ +c Calculs pour les sorties +c------------------------------------------------------------------ + + if(sorties) then + do l=1,nlay + do ig=1,ngrid + zla(ig,l)=(1.-fracd(ig,l))*zmax(ig) + zld(ig,l)=fracd(ig,l)*zmax(ig) + if(1.-fracd(ig,l).gt.1.e-10) + s zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l)) + enddo + enddo + +cdeja fait +c do l=1,nlay +c do ig=1,ngrid +c detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1) +c if (detr(ig,l).lt.0.) then +c entr(ig,l)=entr(ig,l)-detr(ig,l) +c detr(ig,l)=0. +c print*,'WARNING !!! detrainement negatif ',ig,l +c endif +c enddo +c enddo + +c print*,'15 OK convect8' + + isplit=isplit+1 + + +c #define und + goto 123 +#ifdef und + CALL writeg1d(1,nlay,wd,'wd ','wd ') + CALL writeg1d(1,nlay,zwa,'wa ','wa ') + CALL writeg1d(1,nlay,fracd,'fracd ','fracd ') + CALL writeg1d(1,nlay,fraca,'fraca ','fraca ') + CALL writeg1d(1,nlay,wa_moy,'wam ','wam ') + CALL writeg1d(1,nlay,zla,'la ','la ') + CALL writeg1d(1,nlay,zld,'ld ','ld ') + CALL writeg1d(1,nlay,pt,'pt ','pt ') + CALL writeg1d(1,nlay,zh,'zh ','zh ') + CALL writeg1d(1,nlay,zha,'zha ','zha ') + CALL writeg1d(1,nlay,zu,'zu ','zu ') + CALL writeg1d(1,nlay,zv,'zv ','zv ') + CALL writeg1d(1,nlay,zo,'zo ','zo ') + CALL writeg1d(1,nlay,wh,'wh ','wh ') + CALL writeg1d(1,nlay,wu,'wu ','wu ') + CALL writeg1d(1,nlay,wv,'wv ','wv ') + CALL writeg1d(1,nlay,wo,'w15uo ','wXo ') + CALL writeg1d(1,nlay,zdhadj,'zdhadj ','zdhadj ') + CALL writeg1d(1,nlay,pduadj,'pduadj ','pduadj ') + CALL writeg1d(1,nlay,pdvadj,'pdvadj ','pdvadj ') + CALL writeg1d(1,nlay,pdoadj,'pdoadj ','pdoadj ') + CALL writeg1d(1,nlay,entr ,'entr ','entr ') + CALL writeg1d(1,nlay,detr ,'detr ','detr ') + CALL writeg1d(1,nlay,fm ,'fm ','fm ') + + CALL writeg1d(1,nlay,pdtadj,'pdtadj ','pdtadj ') + CALL writeg1d(1,nlay,pplay,'pplay ','pplay ') + CALL writeg1d(1,nlay,pplev,'pplev ','pplev ') + +c recalcul des flux en diagnostique... +c print*,'PAS DE TEMPS ',ptimestep + call dt2F(pplev,pplay,pt,pdtadj,wh) + CALL writeg1d(1,nlay,wh,'wh2 ','wh2 ') +#endif +123 continue +! #define troisD +#ifdef troisD +c if (sorties) then + print*,'Debut des wrgradsfi' + +c print*,'16 OK convect8' + call wrgradsfi(1,nlay,wd,'wd ','wd ') + call wrgradsfi(1,nlay,zwa,'wa ','wa ') + call wrgradsfi(1,nlay,fracd,'fracd ','fracd ') + call wrgradsfi(1,nlay,fraca,'fraca ','fraca ') + call wrgradsfi(1,nlay,xxx,'xxx ','xxx ') + call wrgradsfi(1,nlay,wa_moy,'wam ','wam ') +c print*,'WA6 ',wa_moy + call wrgradsfi(1,nlay,zla,'la ','la ') + call wrgradsfi(1,nlay,zld,'ld ','ld ') + call wrgradsfi(1,nlay,pt,'pt ','pt ') + call wrgradsfi(1,nlay,zh,'zh ','zh ') + call wrgradsfi(1,nlay,zha,'zha ','zha ') + call wrgradsfi(1,nlay,zua,'zua ','zua ') + call wrgradsfi(1,nlay,zva,'zva ','zva ') + call wrgradsfi(1,nlay,zu,'zu ','zu ') + call wrgradsfi(1,nlay,zv,'zv ','zv ') + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,wh,'wh ','wh ') + call wrgradsfi(1,nlay,wu,'wu ','wu ') + call wrgradsfi(1,nlay,wv,'wv ','wv ') + call wrgradsfi(1,nlay,wo,'wo ','wo ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,nlay,zdhadj,'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj,'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj,'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj,'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr,'entr ','entr ') + call wrgradsfi(1,nlay,detr,'detr ','detr ') + call wrgradsfi(1,nlay,fm,'fm ','fm ') + call wrgradsfi(1,nlay,fmc,'fmc ','fmc ') + call wrgradsfi(1,nlay,zw2,'zw2 ','zw2 ') + call wrgradsfi(1,nlay,ztva,'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv,'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo,'zo ','zo ') + call wrgradsfi(1,nlay,larg_cons,'Lc ','Lc ') + call wrgradsfi(1,nlay,larg_detr,'Ldetr ','Ldetr ') + +cCR:nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star ,'entr_star ','entr_star ') + call wrgradsfi(1,nlay,f_star ,'f_star ','f_star ') + call wrgradsfi(1,1,zmax,'zmax ','zmax ') + call wrgradsfi(1,1,zmix,'zmix ','zmix ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d,'lmax ','lmax ') + call wrgradsfi(1,1,wmax,'wmax ','wmax ') + zsortie1d(:)=lmix(:) + call wrgradsfi(1,1,zsortie1d,'lmix ','lmix ') + zsortie1d(:)=lentr(:) + call wrgradsfi(1,1,zsortie1d,'lentr ','lentr ') + +c print*,'17 OK convect8' + + do k=1,klev/10 + write(str2,'(i2.2)') k + str10='wa'//str2 + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=wa(ig,k,l) + enddo + enddo + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + do l=1,nlay + do ig=1,ngrid + zsortie(ig,l)=larg_part(ig,k,l) + enddo + enddo + str10='la'//str2 + CALL wrgradsfi(1,nlay,zsortie,str10,str10) + enddo + + +c print*,'18 OK convect8' +c endif + print*,'Fin des wrgradsfi' +#endif + + endif + +c if(wa_moy(1,4).gt.1.e-10) stop + +c print*,'19 OK convect8' + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_out3d.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_out3d.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_out3d.h (revision 1634) @@ -0,0 +1,75 @@ +! if (sorties) then + +! print*,'16 OK convect8' + call wrgradsfi(1,nlay,pt(igout,1:klev),'pt ','pt ') + call wrgradsfi(1,nlay,fraca(igout,1:klev),'fraca ','fraca ') + call wrgradsfi(1,nlay,zh(igout,1:klev),'zh ','zh ') + call wrgradsfi(1,nlay,zha(igout,1:klev),'zha ','zha ') + call wrgradsfi(1,nlay,zua(igout,1:klev),'zua ','zua ') + call wrgradsfi(1,nlay,zva(igout,1:klev),'zva ','zva ') + call wrgradsfi(1,nlay,zu(igout,1:klev),'zu ','zu ') + call wrgradsfi(1,nlay,zv(igout,1:klev),'zv ','zv ') + call wrgradsfi(1,nlay,zo(igout,1:klev),'zo ','zo ') + call wrgradsfi(1,1,zmax(igout),'zmax ','zmax ') +! call wrgradsfi(1,nlay,zdhadj(igout,1:klev),'zdhadj ','zdhadj ') + call wrgradsfi(1,nlay,pduadj(igout,1:klev),'pduadj ','pduadj ') + call wrgradsfi(1,nlay,pdvadj(igout,1:klev),'pdvadj ','pdvadj ') + call wrgradsfi(1,nlay,pdoadj(igout,1:klev),'pdoadj ','pdoadj ') + call wrgradsfi(1,nlay,entr(igout,1:klev),'entr ','entr ') + call wrgradsfi(1,nlay,detr(igout,1:klev),'detr ','detr ') + call wrgradsfi(1,nlay,fm(igout,1:klev),'fm ','fm ') + call wrgradsfi(1,nlay,zw2(igout,1:klev),'zw2 ','zw2 ') + call wrgradsfi(1,nlay,zw_est(igout,1:klev),'w_est ','w_est ') +!on sort les moments + call wrgradsfi(1,nlay,thetath2(igout,1:klev),'zh2 ','zh2 ') + call wrgradsfi(1,nlay,wth2(igout,1:klev),'w2 ','w2 ') + call wrgradsfi(1,nlay,wth3(igout,1:klev),'w3 ','w3 ') + call wrgradsfi(1,nlay,q2(igout,1:klev),'q2 ','q2 ') +! +! + call wrgradsfi(1,nlay,wthl(igout,1:klev),'wthl ','wthl ') + call wrgradsfi(1,nlay,wthv(igout,1:klev),'wthv ','wthv ') + call wrgradsfi(1,nlay,wq(igout,1:klev),'wq ','wq ') + + call wrgradsfi(1,nlay,ztva(igout,1:klev),'ztva ','ztva ') + call wrgradsfi(1,nlay,ztv(igout,1:klev),'ztv ','ztv ') + + call wrgradsfi(1,nlay,zo(igout,1:klev),'zo ','zo ') + call wrgradsfi(1,nlay,zoa(igout,1:klev),'zoa ','zoa ') + +!nouveaux diagnostiques + call wrgradsfi(1,nlay,zthl(igout,1:klev),'zthl ','zthl ') + call wrgradsfi(1,nlay,zta(igout,1:klev),'zta ','zta ') + call wrgradsfi(1,nlay,zl(igout,1:klev),'zl ','zl ') + call wrgradsfi(1,nlay,zdthladj(igout,1:klev),'zdthladj ', & + & 'zdthladj ') + call wrgradsfi(1,nlay,ztla(igout,1:klev),'ztla ','ztla ') + call wrgradsfi(1,nlay,zqta(igout,1:klev),'zqta ','zqta ') + call wrgradsfi(1,nlay,zqla(igout,1:klev),'zqla ','zqla ') + call wrgradsfi(1,nlay,deltaz(igout,1:klev),'deltaz ','deltaz ') +!nouveaux diagnostiques + call wrgradsfi(1,nlay,entr_star (igout,1:klev),'entr_star ','entr_star ') + call wrgradsfi(1,nlay,detr_star (igout,1:klev),'detr_star ','detr_star ') + call wrgradsfi(1,nlay,f_star (igout,1:klev),'f_star ','f_star ') + call wrgradsfi(1,nlay,zqsat (igout,1:klev),'zqsat ','zqsat ') + call wrgradsfi(1,nlay,zqsatth (igout,1:klev),'qsath ','qsath ') + call wrgradsfi(1,nlay,alim_star (igout,1:klev),'alim_star ','alim_star ') +! call wrgradsfi(1,nlay,alim (igout,1:klev),'alim ','alim ') + call wrgradsfi(1,1,f(igout),'f ','f ') + call wrgradsfi(1,1,alim_star_tot(igout),'a_s_t ','a_s_t ') + call wrgradsfi(1,1,zmax(igout),'zmax ','zmax ') + call wrgradsfi(1,1,zmax_sec(igout),'z_sec ','z_sec ') + call wrgradsfi(1,1,zmix(igout),'zmix ','zmix ') +! call wrgradsfi(1,1,nivcon(igout),'nivcon ','nivcon ') + call wrgradsfi(1,1,zcon(igout),'zcon ','zcon ') + call wrgradsfi(1,1,zcon2(igout),'zcon2 ','zcon2 ') + zsortie1d(:)=lmax(:) + call wrgradsfi(1,1,zsortie1d(igout),'lmax ','lmax ') + call wrgradsfi(1,1,wmax(igout),'wmax ','wmax ') + call wrgradsfi(1,1,wmax_sec(igout),'w_sec ','w_sec ') +! zsortie1d(:)=lmix(:) +! call wrgradsfi(1,1,zsortie1d(igout),'lmix ','lmix ') +! zsortie1d(:)=lentr(:) +! call wrgradsfi(1,1,zsortie1d(igout),'lentr ','lentr ') + + print*,'Fin des wrgradsfi' Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_plume.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_plume.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_plume.F90 (revision 1634) @@ -0,0 +1,857 @@ +! +! $Id$ +! + SUBROUTINE thermcell_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz, & + & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & + & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & + & ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & + & ,lev_out,lunout1,igout) + +!-------------------------------------------------------------------------- +!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance +!-------------------------------------------------------------------------- + + IMPLICIT NONE + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +#include "thermcell.h" + + INTEGER itap + INTEGER lunout1,igout + INTEGER ngrid,klev + REAL ptimestep + REAL ztv(ngrid,klev) + REAL zthl(ngrid,klev) + REAL po(ngrid,klev) + REAL zl(ngrid,klev) + REAL rhobarz(ngrid,klev) + REAL zlev(ngrid,klev+1) + REAL pplev(ngrid,klev+1) + REAL pphi(ngrid,klev) + REAL zpspsk(ngrid,klev) + REAL alim_star(ngrid,klev) + REAL f0(ngrid) + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + integer nbpb + real zcon2(ngrid) + + real alim_star_tot(ngrid) + + REAL ztva(ngrid,klev) + REAL ztla(ngrid,klev) + REAL zqla(ngrid,klev) + REAL zqta(ngrid,klev) + REAL zha(ngrid,klev) + + REAL detr_star(ngrid,klev) + REAL coefc + REAL entr_star(ngrid,klev) + REAL detr(ngrid,klev) + REAL entr(ngrid,klev) + + REAL csc(ngrid,klev) + + REAL zw2(ngrid,klev+1) + REAL w_est(ngrid,klev+1) + REAL f_star(ngrid,klev+1) + REAL wa_moy(ngrid,klev+1) + + REAL ztva_est(ngrid,klev) + REAL zqla_est(ngrid,klev) + REAL zqsatth(ngrid,klev) + REAL zta_est(ngrid,klev) + REAL zdw2 + REAL zw2modif + REAL zeps + + REAL linter(ngrid) + INTEGER lmix(ngrid) + INTEGER lmix_bis(ngrid) + REAL wmaxa(ngrid) + + INTEGER ig,l,k + + real zdz,zfact,zbuoy,zalpha,zdrag + real zcor,zdelta,zcvm5,qlbef + real Tbef,qsatbef + real dqsat_dT,DT,num,denom + REAL REPS,RLvCp,DDT0 + PARAMETER (DDT0=.01) + logical Zsat + LOGICAL active(ngrid),activetmp(ngrid) + REAL fact_gamma,fact_epsilon,fact_gamma2 + REAL c2(ngrid,klev) + REAL a1,m + + REAL zw2fact,expa + Zsat=.false. +! Initialisation + RLvCp = RLVTT/RCPD + + + fact_epsilon=0.002 + a1=2./3. + fact_gamma=0.9 + zfact=fact_gamma/(1+fact_gamma) + fact_gamma2=zfact + expa=0. + + +! Initialisations des variables reeles +if (1==1) then + ztva(:,:)=ztv(:,:) + ztva_est(:,:)=ztva(:,:) + ztla(:,:)=zthl(:,:) + zqta(:,:)=po(:,:) + zha(:,:) = ztva(:,:) +else + ztva(:,:)=0. + ztva_est(:,:)=0. + ztla(:,:)=0. + zqta(:,:)=0. + zha(:,:) =0. +endif + + zqla_est(:,:)=0. + zqsatth(:,:)=0. + zqla(:,:)=0. + detr_star(:,:)=0. + entr_star(:,:)=0. + alim_star(:,:)=0. + alim_star_tot(:)=0. + csc(:,:)=0. + detr(:,:)=0. + entr(:,:)=0. + zw2(:,:)=0. + w_est(:,:)=0. + f_star(:,:)=0. + wa_moy(:,:)=0. + linter(:)=1. + linter(:)=1. + +! Initialisation des variables entieres + lmix(:)=1 + lmix_bis(:)=2 + wmaxa(:)=0. + lalim(:)=1 + +!------------------------------------------------------------------------- +! On ne considere comme actif que les colonnes dont les deux premieres +! couches sont instables. +!------------------------------------------------------------------------- + active(:)=ztv(:,1)>ztv(:,2) + +!------------------------------------------------------------------------- +! Definition de l'alimentation a l'origine dans thermcell_init +!------------------------------------------------------------------------- + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & + & *sqrt(zlev(ig,l+1)) + lalim(ig)=l+1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + endif + enddo + enddo + do l=1,klev + do ig=1,ngrid + if (alim_star_tot(ig) > 1.e-10 ) then + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + endif + enddo + enddo + alim_star_tot(:)=1. + + +!------------------------------------------------------------------------------ +! Calcul dans la premiere couche +! On decide dans cette version que le thermique n'est actif que si la premiere +! couche est instable. +! Pourrait etre change si on veut que le thermiques puisse se déclencher +! dans une couche l>1 +!------------------------------------------------------------------------------ +do ig=1,ngrid +! Le panache va prendre au debut les caracteristiques de l'air contenu +! dans cette couche. + if (active(ig)) then + ztla(ig,1)=zthl(ig,1) + zqta(ig,1)=po(ig,1) + zqla(ig,1)=zl(ig,1) +!cr: attention, prise en compte de f*(1)=1 + f_star(ig,2)=alim_star(ig,1) + zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & +& *(zlev(ig,2)-zlev(ig,1)) & +& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) + w_est(ig,2)=zw2(ig,2) + endif +enddo +! + +!============================================================================== +!boucle de calcul de la vitesse verticale dans le thermique +!============================================================================== +do l=2,klev-1 +!============================================================================== + + +! On decide si le thermique est encore actif ou non +! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test + do ig=1,ngrid + active(ig)=active(ig) & +& .and. zw2(ig,l)>1.e-10 & +& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 + enddo + + + +! Premier calcul de la vitesse verticale a partir de la temperature +! potentielle virtuelle +! if (1.eq.1) then +! w_est(ig,3)=zw2(ig,2)* & +! & ((f_star(ig,2))**2) & +! & /(f_star(ig,2)+alim_star(ig,2))**2+ & +! & 2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) & +! & *(zlev(ig,3)-zlev(ig,2)) +! endif + + +!--------------------------------------------------------------------------- +! calcul des proprietes thermodynamiques et de la vitesse de la couche l +! sans tenir compte du detrainement et de l'entrainement dans cette +! couche +! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer +! avant) a l'alimentation pour avoir un calcul plus propre +!--------------------------------------------------------------------------- + + call thermcell_condens(ngrid,active, & +& zpspsk(:,l),pplev(:,l),ztla(:,l-1),zqta(:,l-1),zqla_est(:,l)) + + do ig=1,ngrid + if(active(ig)) then + ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) + zta_est(ig,l)=ztva_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & + & -zqla_est(ig,l))-zqla_est(ig,l)) + + if (1.eq.0) then +!calcul de w_est sans prendre en compte le drag + w_est(ig,l+1)=zw2(ig,l)* & + & ((f_star(ig,l))**2) & + & /(f_star(ig,l)+alim_star(ig,l))**2+ & + & 2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) & + & *(zlev(ig,l+1)-zlev(ig,l)) + else + + zdz=zlev(ig,l+1)-zlev(ig,l) + zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l))/rhobarz(ig,l) + zbuoy=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + zdrag=fact_epsilon/(zalpha**expa) + zw2fact=zbuoy/zdrag*a1 + w_est(ig,l+1)=(w_est(ig,l)-zw2fact)*exp(-2.*zdrag/(1+fact_gamma)*zdz) & + & +zw2fact + + endif + + if (w_est(ig,l+1).lt.0.) then + w_est(ig,l+1)=zw2(ig,l) + endif + endif + enddo + +!------------------------------------------------- +!calcul des taux d'entrainement et de detrainement +!------------------------------------------------- + + do ig=1,ngrid + if (active(ig)) then + zdz=zlev(ig,l+1)-zlev(ig,l) + zbuoy=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + +! estimation de la fraction couverte par les thermiques + zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l))/rhobarz(ig,l) + +!calcul de la soumission papier +! Calcul du taux d'entrainement entr_star (epsilon) + entr_star(ig,l)=f_star(ig,l)*zdz * ( zfact * MAX(0., & + & a1*zbuoy/w_est(ig,l+1) & + & - fact_epsilon/zalpha**expa ) & + & +0. ) + +!calcul du taux de detrainment (delta) +! detr_star(ig,l)=f_star(ig,l)*zdz * ( & +! & MAX(1.e-3, & +! & -fact_gamma2*a1*zbuoy/w_est(ig,l+1) & +! & +0.01*(max(zqta(ig,l-1)-po(ig,l),0.)/(po(ig,l))/(w_est(ig,l+1)))**0.5 & +! & +0. )) + + m=0.5 + + detr_star(ig,l)=1.*f_star(ig,l)*zdz * & + & MAX(5.e-4,-fact_gamma2*a1*(1./w_est(ig,l+1))*((1.-(1.-m)/(1.+70*zqta(ig,l-1)))*zbuoy & + & -40*(1.-m)*(max(zqta(ig,l-1)-po(ig,l),0.))/(1.+70*zqta(ig,l-1)) ) ) + +! detr_star(ig,l)=f_star(ig,l)*zdz * ( & +! & MAX(0.0, & +! & -fact_gamma2*a1*zbuoy/w_est(ig,l+1) & +! & +20*(max(zqta(ig,l-1)-po(ig,l),0.))**1*(zalpha/w_est(ig,l+1))**0.5 & +! & +0. )) + + +! En dessous de lalim, on prend le max de alim_star et entr_star pour +! alim_star et 0 sinon + if (l.lt.lalim(ig)) then + alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) + entr_star(ig,l)=0. + endif + +!attention test +! if (detr_star(ig,l).gt.(f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l))) then +! detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) +! endif +! Calcul du flux montant normalise + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & + & -detr_star(ig,l) + + endif + enddo + +!---------------------------------------------------------------------------- +!calcul de la vitesse verticale en melangeant Tl et qt du thermique +!--------------------------------------------------------------------------- + activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 + do ig=1,ngrid + if (activetmp(ig)) then + Zsat=.false. + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + + endif + enddo + + call thermcell_condens(ngrid,activetmp,zpspsk(:,l),pplev(:,l),ztla(:,l),zqta(:,l),zqla(:,l)) + + + do ig=1,ngrid + if (activetmp(ig)) then +! on ecrit de maniere conservative (sat ou non) +! T = Tl +Lv/Cp ql + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +!on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & + & -zqla(ig,l))-zqla(ig,l)) + +!on ecrit zqsat + zqsatth(ig,l)=qsatbef + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! zw2(ig,l+1)=& +! & zw2(ig,l)*(1-fact_epsilon/(1.+fact_gamma)*2.*(zlev(ig,l+1)-zlev(ig,l))) & +! & +2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) & +! & *1./(1.+fact_gamma) & +! & *(zlev(ig,l+1)-zlev(ig,l)) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! La meme en plus modulaire : + zbuoy=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + + + zeps=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) + +!if (1==0) then +! zw2modif=zw2(ig,l)*(1-fact_epsilon/(1.+fact_gamma)*2.*zdz) +! zdw2=2.*zbuoy/(1.+fact_gamma)*zdz +! zw2(ig,l+1)=zw2modif+zdw2 +!else + zdrag=fact_epsilon/(zalpha**expa) + zw2fact=zbuoy/zdrag*a1 + zw2(ig,l+1)=(zw2(ig,l)-zw2fact)*exp(-2.*zdrag/(1+fact_gamma)*zdz) & + & +zw2fact +!endif + + endif + enddo + + if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l +! +!--------------------------------------------------------------------------- +!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max +!--------------------------------------------------------------------------- + + nbpb=0 + do ig=1,ngrid + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_plume' + nbpb=nbpb+1 + zw2(ig,l+1)=0. + linter(ig)=l+1 + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum +!on rajoute le calcul de lmix_bis + if (zqla(ig,l).lt.1.e-10) then + lmix_bis(ig)=l+1 + endif + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + + if (nbpb>0) then + print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' + endif + +!========================================================================= +! FIN DE LA BOUCLE VERTICALE + enddo +!========================================================================= + +!on recalcule alim_star_tot + do ig=1,ngrid + alim_star_tot(ig)=0. + enddo + do ig=1,ngrid + do l=1,lalim(ig)-1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + enddo + enddo + + + if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l + + + return + end + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE thermcellV1_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz, & +& zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & +& lalim,f0,detr_star,entr_star,f_star,csc,ztva, & +& ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter & +& ,lev_out,lunout1,igout) + +!-------------------------------------------------------------------------- +!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance +! Version conforme a l'article de Rio et al. 2010. +! Code ecrit par Catherine Rio, Arnaud Jam et Frederic Hourdin +!-------------------------------------------------------------------------- + + IMPLICIT NONE + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" +#include "iniprint.h" +#include "thermcell.h" + + INTEGER itap + INTEGER lunout1,igout + INTEGER ngrid,klev + REAL ptimestep + REAL ztv(ngrid,klev) + REAL zthl(ngrid,klev) + REAL po(ngrid,klev) + REAL zl(ngrid,klev) + REAL rhobarz(ngrid,klev) + REAL zlev(ngrid,klev+1) + REAL pplev(ngrid,klev+1) + REAL pphi(ngrid,klev) + REAL zpspsk(ngrid,klev) + REAL alim_star(ngrid,klev) + REAL f0(ngrid) + INTEGER lalim(ngrid) + integer lev_out ! niveau pour les print + integer nbpb + + real alim_star_tot(ngrid) + + REAL ztva(ngrid,klev) + REAL ztla(ngrid,klev) + REAL zqla(ngrid,klev) + REAL zqta(ngrid,klev) + REAL zha(ngrid,klev) + + REAL detr_star(ngrid,klev) + REAL coefc + REAL entr_star(ngrid,klev) + REAL detr(ngrid,klev) + REAL entr(ngrid,klev) + + REAL csc(ngrid,klev) + + REAL zw2(ngrid,klev+1) + REAL w_est(ngrid,klev+1) + REAL f_star(ngrid,klev+1) + REAL wa_moy(ngrid,klev+1) + + REAL ztva_est(ngrid,klev) + REAL zqla_est(ngrid,klev) + REAL zqsatth(ngrid,klev) + REAL zta_est(ngrid,klev) + REAL ztemp(ngrid),zqsat(ngrid) + REAL zdw2 + REAL zw2modif + REAL zw2fact + REAL zeps(ngrid,klev) + + REAL linter(ngrid) + INTEGER lmix(ngrid) + INTEGER lmix_bis(ngrid) + REAL wmaxa(ngrid) + + INTEGER ig,l,k + + real zdz,zbuoy(ngrid,klev),zalpha,gamma(ngrid,klev),zdqt(ngrid,klev),zw2m + real zbuoybis + real zcor,zdelta,zcvm5,qlbef,zdz2 + real betalpha,zbetalpha + real eps, afact + REAL REPS,RLvCp,DDT0 + PARAMETER (DDT0=.01) + logical Zsat + LOGICAL active(ngrid),activetmp(ngrid) + REAL fact_gamma,fact_epsilon,fact_gamma2,fact_epsilon2 + REAL c2(ngrid,klev) + Zsat=.false. +! Initialisation + + RLvCp = RLVTT/RCPD + fact_epsilon=0.002 + betalpha=0.9 + afact=2./3. + + zbetalpha=betalpha/(1.+betalpha) + + +! Initialisations des variables reeles +if (1==0) then + ztva(:,:)=ztv(:,:) + ztva_est(:,:)=ztva(:,:) + ztla(:,:)=zthl(:,:) + zqta(:,:)=po(:,:) + zha(:,:) = ztva(:,:) +else + ztva(:,:)=0. + ztva_est(:,:)=0. + ztla(:,:)=0. + zqta(:,:)=0. + zha(:,:) =0. +endif + + zqla_est(:,:)=0. + zqsatth(:,:)=0. + zqla(:,:)=0. + detr_star(:,:)=0. + entr_star(:,:)=0. + alim_star(:,:)=0. + alim_star_tot(:)=0. + csc(:,:)=0. + detr(:,:)=0. + entr(:,:)=0. + zw2(:,:)=0. + zbuoy(:,:)=0. + gamma(:,:)=0. + zeps(:,:)=0. + w_est(:,:)=0. + f_star(:,:)=0. + wa_moy(:,:)=0. + linter(:)=1. +! linter(:)=1. +! Initialisation des variables entieres + lmix(:)=1 + lmix_bis(:)=2 + wmaxa(:)=0. + lalim(:)=1 + + +!------------------------------------------------------------------------- +! On ne considere comme actif que les colonnes dont les deux premieres +! couches sont instables. +!------------------------------------------------------------------------- + active(:)=ztv(:,1)>ztv(:,2) + +!------------------------------------------------------------------------- +! Definition de l'alimentation a l'origine dans thermcell_init +!------------------------------------------------------------------------- + do l=1,klev-1 + do ig=1,ngrid + if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then + alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.) & + & *sqrt(zlev(ig,l+1)) + lalim(ig)=l+1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + endif + enddo + enddo + do l=1,klev + do ig=1,ngrid + if (alim_star_tot(ig) > 1.e-10 ) then + alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig) + endif + enddo + enddo + alim_star_tot(:)=1. + + + +!------------------------------------------------------------------------------ +! Calcul dans la premiere couche +! On decide dans cette version que le thermique n'est actif que si la premiere +! couche est instable. +! Pourrait etre change si on veut que le thermiques puisse se déclencher +! dans une couche l>1 +!------------------------------------------------------------------------------ +do ig=1,ngrid +! Le panache va prendre au debut les caracteristiques de l'air contenu +! dans cette couche. + if (active(ig)) then + ztla(ig,1)=zthl(ig,1) + zqta(ig,1)=po(ig,1) + zqla(ig,1)=zl(ig,1) +!cr: attention, prise en compte de f*(1)=1 + f_star(ig,2)=alim_star(ig,1) + zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2) & +& *(zlev(ig,2)-zlev(ig,1)) & +& *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1)) + w_est(ig,2)=zw2(ig,2) + endif +enddo +! + +!============================================================================== +!boucle de calcul de la vitesse verticale dans le thermique +!============================================================================== +do l=2,klev-1 +!============================================================================== + + +! On decide si le thermique est encore actif ou non +! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test + do ig=1,ngrid + active(ig)=active(ig) & +& .and. zw2(ig,l)>1.e-10 & +& .and. f_star(ig,l)+alim_star(ig,l)>1.e-10 + enddo + + + +!--------------------------------------------------------------------------- +! calcul des proprietes thermodynamiques et de la vitesse de la couche l +! sans tenir compte du detrainement et de l'entrainement dans cette +! couche +! C'est a dire qu'on suppose +! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1) +! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer +! avant) a l'alimentation pour avoir un calcul plus propre +!--------------------------------------------------------------------------- + + ztemp(:)=zpspsk(:,l)*ztla(:,l-1) + call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:)) + + do ig=1,ngrid +! print*,'active',active(ig),ig,l + if(active(ig)) then + zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig)) + ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l) + zta_est(ig,l)=ztva_est(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l) + ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1) & + & -zqla_est(ig,l))-zqla_est(ig,l)) + +!------------------------------------------------ +!AJAM:nouveau calcul de w² +!------------------------------------------------ + zdz=zlev(ig,l+1)-zlev(ig,l) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) + + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zdw2=(afact)*zbuoy(ig,l)/(fact_epsilon) + w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2) + + + if (w_est(ig,l+1).lt.0.) then + w_est(ig,l+1)=zw2(ig,l) + endif + endif + enddo + + +!------------------------------------------------- +!calcul des taux d'entrainement et de detrainement +!------------------------------------------------- + + do ig=1,ngrid + if (active(ig)) then + + zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1) + zw2m=w_est(ig,l+1) + zdz=zlev(ig,l+1)-zlev(ig,l) + zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l) +! zbuoybis=zbuoy(ig,l)+RG*0.1/300. + zbuoybis=zbuoy(ig,l) + zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l) + zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l) + + + entr_star(ig,l)=f_star(ig,l)*zdz* zbetalpha*MAX(0., & + & afact*zbuoybis/zw2m - fact_epsilon ) + + + detr_star(ig,l)=f_star(ig,l)*zdz & + & *MAX(1.e-3, -afact*zbetalpha*zbuoy(ig,l)/zw2m & + & + 0.012*(zdqt(ig,l)/zw2m)**0.5 ) + +! En dessous de lalim, on prend le max de alim_star et entr_star pour +! alim_star et 0 sinon + if (l.lt.lalim(ig)) then + alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l)) + entr_star(ig,l)=0. + endif + +! Calcul du flux montant normalise + f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l) & + & -detr_star(ig,l) + + endif + enddo + + +!---------------------------------------------------------------------------- +!calcul de la vitesse verticale en melangeant Tl et qt du thermique +!--------------------------------------------------------------------------- + activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10 + do ig=1,ngrid + if (activetmp(ig)) then + Zsat=.false. + ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+ & + & (alim_star(ig,l)+entr_star(ig,l))*po(ig,l)) & + & /(f_star(ig,l+1)+detr_star(ig,l)) + + endif + enddo + + ztemp(:)=zpspsk(:,l)*ztla(:,l) + call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l)) + + do ig=1,ngrid + if (activetmp(ig)) then +! on ecrit de maniere conservative (sat ou non) +! T = Tl +Lv/Cp ql + zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l)) + ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l) + ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l) +!on rajoute le calcul de zha pour diagnostiques (temp potentielle) + zha(ig,l) = ztva(ig,l) + ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l) & + & -zqla(ig,l))-zqla(ig,l)) + zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l) + zdz=zlev(ig,l+1)-zlev(ig,l) + zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz) + + zw2fact=fact_epsilon*2.*zdz/(1.+betalpha) + zdw2=afact*zbuoy(ig,l)/(fact_epsilon) + zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) + endif + enddo + + if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l +! +!--------------------------------------------------------------------------- +!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max +!--------------------------------------------------------------------------- + + nbpb=0 + do ig=1,ngrid + if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then +! stop'On tombe sur le cas particulier de thermcell_dry' +! print*,'On tombe sur le cas particulier de thermcell_plume' + nbpb=nbpb+1 + zw2(ig,l+1)=0. + linter(ig)=l+1 + endif + + if (zw2(ig,l+1).lt.0.) then + linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l)) & + & -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l)) + zw2(ig,l+1)=0. + endif + + wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) + + if (wa_moy(ig,l+1).gt.wmaxa(ig)) then +! lmix est le niveau de la couche ou w (wa_moy) est maximum +!on rajoute le calcul de lmix_bis + if (zqla(ig,l).lt.1.e-10) then + lmix_bis(ig)=l+1 + endif + lmix(ig)=l+1 + wmaxa(ig)=wa_moy(ig,l+1) + endif + enddo + + if (nbpb>0) then + print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume' + endif + +!========================================================================= +! FIN DE LA BOUCLE VERTICALE + enddo +!========================================================================= + +!on recalcule alim_star_tot + do ig=1,ngrid + alim_star_tot(ig)=0. + enddo + do ig=1,ngrid + do l=1,lalim(ig)-1 + alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l) + enddo + enddo + + + if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l + +#undef wrgrads_thermcell +#ifdef wrgrads_thermcell + call wrgradsfi(1,klev,entr_star(igout,1:klev),'esta ','esta ') + call wrgradsfi(1,klev,detr_star(igout,1:klev),'dsta ','dsta ') + call wrgradsfi(1,klev,zbuoy(igout,1:klev),'buoy ','buoy ') + call wrgradsfi(1,klev,zdqt(igout,1:klev),'dqt ','dqt ') + call wrgradsfi(1,klev,w_est(igout,1:klev),'w_est ','w_est ') + call wrgradsfi(1,klev,w_est(igout,2:klev+1),'w_es2 ','w_es2 ') + call wrgradsfi(1,klev,zw2(igout,1:klev),'zw2A ','zw2A ') +#endif + + + return + end + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_qsat.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_qsat.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/thermcell_qsat.F90 (revision 1634) @@ -0,0 +1,92 @@ +subroutine thermcell_qsat(klon,active,pplev,ztemp,zqta,zqsat) +implicit none + +#include "YOMCST.h" +#include "YOETHF.h" +#include "FCTTRE.h" + + +!==================================================================== +! DECLARATIONS +!==================================================================== + +! Arguments +INTEGER klon +REAL zpspsk(klon),pplev(klon) +REAL ztemp(klon),zqta(klon),zqsat(klon) +LOGICAL active(klon) + +! Variables locales +INTEGER ig,iter +REAL Tbef(klon),DT(klon) +REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT +logical Zsat +REAL RLvCp +REAL, SAVE :: DDT0=.01 +LOGICAL afaire(klon),tout_converge + +!==================================================================== +! INITIALISATIONS +!==================================================================== + +RLvCp = RLVTT/RCPD +tout_converge=.false. +afaire(:)=.false. +DT(:)=0. + + +!==================================================================== +! Routine a vectoriser en copiant active dans converge et en mettant +! la boucle sur les iterations a l'exterieur est en mettant +! converge= false des que la convergence est atteinte. +!==================================================================== + +do ig=1,klon + if (active(ig)) then + Tbef(ig)=ztemp(ig) + zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig))) + qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig) + qsatbef=MIN(0.5,qsatbef) + zcor=1./(1.-retv*qsatbef) + qsatbef=qsatbef*zcor + qlbef=max(0.,zqta(ig)-qsatbef) + DT(ig) = 0.5*RLvCp*qlbef + zqsat(ig)=qsatbef + endif +enddo + +! Traitement du cas ou il y a condensation mais faible +! On ne condense pas mais on dit que le qsat est le qta +do ig=1,klon + if (active(ig)) then + if (0.= 1 ) + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: fshtr ! Flux surfacique dans le reservoir de sol +!$OMP THREADPRIVATE(fshtr) + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: hsoltr ! Epaisseur equivalente du reservoir de sol +!$OMP THREADPRIVATE(hsoltr) +! +!Radioelements: +!-------------- +! + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tautr ! Constante de decroissance radioactive +!$OMP THREADPRIVATE(tautr) + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: vdeptr ! Vitesse de depot sec dans la couche Brownienne +!$OMP THREADPRIVATE(vdeptr) + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: scavtr ! Coefficient de lessivage +!$OMP THREADPRIVATE(scavtr) + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srcbe ! Production du beryllium7 dans l atmosphere (U/s/kgA) +!$OMP THREADPRIVATE(srcbe) + + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: radio ! radio(it) = true => decroisssance radioactive +!$OMP THREADPRIVATE(radio) + + REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: trs ! Conc. radon ds le sol +!$OMP THREADPRIVATE(trs) + + INTEGER,SAVE :: id_aga ! Identification number for tracer : Age of stratospheric air +!$OMP THREADPRIVATE(id_aga) + INTEGER,SAVE :: lev_1p5km ! Approximative vertical layer number at 1.5km above surface, used for calculation of the age of air. The result shouldn't be that sensible to the exactness of this value as long as it is in the lower troposphere. +!$OMP THREADPRIVATE(lev_1p5km) + + INTEGER,SAVE :: id_rn, id_pb ! Identification number for tracer : radon (Rn222), lead (Pb210) +!$OMP THREADPRIVATE(id_rn, id_pb) + + INTEGER,SAVE :: id_be ! Activation et position du traceur Be7 [ id_be=0 -> desactive ] +!$OMP THREADPRIVATE(id_be) + + INTEGER,SAVE :: id_pcsat, id_pcocsat, id_pcq ! traceurs pseudo-vapeur CL qsat, qsat_oc, q +!$OMP THREADPRIVATE(id_pcsat, id_pcocsat, id_pcq) + INTEGER,SAVE :: id_pcs0, id_pcos0, id_pcq0 ! traceurs pseudo-vapeur CL qsat, qsat_oc, q +! ! qui ne sont pas transportes par la convection +!$OMP THREADPRIVATE(id_pcs0, id_pcos0, id_pcq0) + + INTEGER, SAVE:: id_o3 +!$OMP THREADPRIVATE(id_o3) +! index of ozone tracer with Cariolle parameterization +! 0 means no ozone tracer + + LOGICAL,SAVE :: rnpb=.FALSE. ! Presence du couple Rn222, Pb210 +!$OMP THREADPRIVATE(rnpb) + + +CONTAINS + + SUBROUTINE traclmdz_from_restart(trs_in) + ! This subroutine initialize the module saved variable trs with values from restart file (startphy.nc). + ! This subroutine is called from phyetat0 after the field trs_in has been read. + + USE dimphy + USE infotrac + + ! Input argument + REAL,DIMENSION(klon,nbtr), INTENT(IN) :: trs_in + + ! Local variables + INTEGER :: ierr + + ! Allocate restart variables trs + ALLOCATE( trs(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_from_restart', 'pb in allocation 1',1) + + ! Initialize trs with values read from restart file + trs(:,:) = trs_in(:,:) + + END SUBROUTINE traclmdz_from_restart + + + SUBROUTINE traclmdz_init(pctsrf, ftsol, tr_seri, t_seri, pplay, sh, pdtphys, aerosol, lessivage) + ! This subroutine allocates and initialize module variables and control variables. + ! Initialization of the tracers should be done here only for those not found in the restart file. + USE dimphy + USE infotrac + USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz + USE press_coefoz_m, ONLY: press_coefoz + USE carbon_cycle_mod, ONLY : carbon_cycle_init, carbon_cycle_tr, carbon_cycle_cpl + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + + INCLUDE "indicesol.h" + INCLUDE "iniprint.h" +! Input variables + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol ! Temperature du sol (surf)(Kelvin) + REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri! Concentration Traceur [U/KgA] + REAL,DIMENSION(klon,klev),INTENT(IN) :: t_seri ! Temperature + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le mileu de chaque couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: sh ! humidite specifique + REAL,INTENT(IN) :: pdtphys ! Pas d'integration pour la physique (seconde) + +! Output variables + LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol + LOGICAL,INTENT(OUT) :: lessivage + +! Local variables + INTEGER :: ierr, it, iiq, i, k + REAL, DIMENSION(klon_glo,klev) :: varglo ! variable temporaire sur la grille global + REAL, DIMENSION(klev) :: mintmp, maxtmp + LOGICAL :: zero + +! -------------------------------------------- +! Allocation +! -------------------------------------------- + ALLOCATE( scavtr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 9',1) + scavtr(:)=1. + + ALLOCATE( radio(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 11',1) + radio(:) = .false. ! Par defaut pas decroissance radioactive + + ALLOCATE( masktr(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 2',1) + + ALLOCATE( fshtr(klon,nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 3',1) + + ALLOCATE( hsoltr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 4',1) + + ALLOCATE( tautr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 5',1) + tautr(:) = 0. + + ALLOCATE( vdeptr(nbtr), stat=ierr) + IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 6',1) + vdeptr(:) = 0. + + + lessivage = .TRUE. + aerosol(:) = .FALSE. ! Tous les traceurs sont des gaz par defaut + +! +! Recherche des traceurs connus : Be7, O3, CO2,... +! -------------------------------------------- + id_rn=0; id_pb=0; id_aga=0; id_be=0; id_o3=0 + id_pcsat=0; id_pcocsat=0; id_pcq=0; id_pcs0=0; id_pcos0=0; id_pcq0=0 + DO it=1,nbtr + iiq=niadv(it+2) + IF ( tname(iiq) == "RN" ) THEN + id_rn=it ! radon + ELSE IF ( tname(iiq) == "PB") THEN + id_pb=it ! plomb + ELSE IF ( tname(iiq) == "Aga" .OR. tname(iiq) == "AGA" ) THEN + ! Age of stratospheric air + id_aga=it + radio(id_aga) = .FALSE. + aerosol(id_aga) = .FALSE. + pbl_flg(id_aga) = 0 + + ! Find the first model layer above 1.5km from the surface + IF (klev>=30) THEN + lev_1p5km=6 ! NB! This value is for klev=39 + ELSE IF (klev>=10) THEN + lev_1p5km=5 ! NB! This value is for klev=19 + ELSE + lev_1p5km=klev/2 + END IF + ELSE IF ( tname(iiq) == "BE" .OR. tname(iiq) == "Be" .OR. & + tname(iiq) == "BE7" .OR. tname(iiq) == "Be7" ) THEN + ! Recherche du Beryllium 7 + id_be=it + ALLOCATE( srcbe(klon,klev) ) + radio(id_be) = .TRUE. + aerosol(id_be) = .TRUE. ! le Be est un aerosol + CALL init_be(pctsrf,masktr(:,id_be),tautr(id_be),vdeptr(id_be),scavtr(id_be),srcbe) + WRITE(lunout,*) 'Initialisation srcBe: OK' + ELSE IF (tname(iiq)=="O3" .OR. tname(iiq)=="o3") THEN + ! Recherche de l'ozone : parametrization de la chimie par Cariolle + id_o3=it + CALL alloc_coefoz ! allocate ozone coefficients + CALL press_coefoz ! read input pressure levels + ELSE IF ( tname(iiq) == "pcsat" .OR. tname(iiq) == "Pcsat" ) THEN + id_pcsat=it + ELSE IF ( tname(iiq) == "pcocsat" .OR. tname(iiq) == "Pcocsat" ) THEN + id_pcocsat=it + ELSE IF ( tname(iiq) == "pcq" .OR. tname(iiq) == "Pcq" ) THEN + id_pcq=it + ELSE IF ( tname(iiq) == "pcs0" .OR. tname(iiq) == "Pcs0" ) THEN + id_pcs0=it + conv_flg(it)=0 ! No transport by convection for this tracer + ELSE IF ( tname(iiq) == "pcos0" .OR. tname(iiq) == "Pcos0" ) THEN + id_pcos0=it + conv_flg(it)=0 ! No transport by convection for this tracer + ELSE IF ( tname(iiq) == "pcq0" .OR. tname(iiq) == "Pcq0" ) THEN + id_pcq0=it + conv_flg(it)=0 ! No transport by convection for this tracer + ELSE + WRITE(lunout,*) 'This is an unknown tracer in LMDZ : ', trim(tname(iiq)) + END IF + END DO + +! +! Valeurs specifiques pour les traceurs Rn222 et Pb210 +! ---------------------------------------------- + IF ( id_rn/=0 .AND. id_pb/=0 ) THEN + rnpb = .TRUE. + radio(id_rn)= .TRUE. + radio(id_pb)= .TRUE. + pbl_flg(id_rn) = 0 ! au lieu de clsol=true ! CL au sol calcule + pbl_flg(id_pb) = 0 ! au lieu de clsol=true + aerosol(id_rn) = .FALSE. + aerosol(id_pb) = .TRUE. ! le Pb est un aerosol + + CALL initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr) + END IF + +! +! Initialisation de module carbon_cycle_mod +! ---------------------------------------------- + IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN + CALL carbon_cycle_init(tr_seri, pdtphys, aerosol, radio) + END IF + +! Check if all tracers have restart values +! ---------------------------------------------- + DO it=1,nbtr + iiq=niadv(it+2) + ! Test if tracer is zero everywhere. + ! Done by master process MPI and master thread OpenMP + CALL gather(tr_seri(:,:,it),varglo) + IF (is_mpi_root .AND. is_omp_root) THEN + mintmp=MINVAL(varglo,dim=1) + maxtmp=MAXVAL(varglo,dim=1) + IF (MINVAL(mintmp,dim=1)==0. .AND. MAXVAL(maxtmp,dim=1)==0.) THEN + ! Tracer is zero everywhere + zero=.TRUE. + ELSE + zero=.FALSE. + END IF + END IF + + ! Distribute variable at all processes + CALL bcast(zero) + + ! Initalize tracer that was not found in restart file. + IF (zero) THEN + ! The tracer was not found in restart file or it was equal zero everywhere. + WRITE(lunout,*) "The tracer ",trim(tname(iiq))," will be initialized" + IF (it==id_pcsat .OR. it==id_pcq .OR. & + it==id_pcs0 .OR. it==id_pcq0) THEN + tr_seri(:,:,it) = 100. + ELSE IF (it==id_pcocsat .OR. it==id_pcos0) THEN + DO i = 1, klon + IF ( pctsrf (i, is_oce) == 0. ) THEN + tr_seri(i,:,it) = 0. + ELSE + tr_seri(i,:,it) = 100. + END IF + END DO + ELSE + ! No specific initialization exist for this tracer + tr_seri(:,:,it) = 0. + END IF + END IF + END DO + + END SUBROUTINE traclmdz_init + + SUBROUTINE traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, & + cdragh, coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon, couchelimite, sh, & + tr_seri, source, solsym, d_tr_cl, zmasse) + + USE dimphy + USE infotrac + USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz + USE o3_chem_m, ONLY: o3_chem + USE carbon_cycle_mod, ONLY : carbon_cycle, carbon_cycle_tr, carbon_cycle_cpl + INCLUDE "YOMCST.h" + INCLUDE "indicesol.h" + +!========================================================================== +! -- DESCRIPTION DES ARGUMENTS -- +!========================================================================== + +! Input arguments +! +!Configuration grille,temps: + INTEGER,INTENT(IN) :: nstep ! nombre d'appels de la physiq + INTEGER,INTENT(IN) :: julien ! Jour julien + REAL,INTENT(IN) :: gmtime + REAL,INTENT(IN) :: pdtphys ! Pas d'integration pour la physique (seconde) + REAL,DIMENSION(klon),INTENT(IN) :: xlat ! latitudes pour chaque point + REAL, INTENT(IN):: xlon(:) ! dim(klon) longitude + +! +!Physique: +!-------- + REAL,DIMENSION(klon,klev),INTENT(IN) :: t_seri ! Temperature + REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression pour chaque inter-couche (en Pa) + REAL,DIMENSION(klon,klev),INTENT(IN) :: pplay ! pression pour le mileu de chaque couche (en Pa) + REAL,intent(in):: zmasse (:, :) ! dim(klon,klev) density of air, in kg/m2 + + +!Couche limite: +!-------------- +! + REAL,DIMENSION(klon),INTENT(IN) :: cdragh ! coeff drag pour T et Q + REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh ! coeff melange CL (m**2/s) + REAL,DIMENSION(klon),INTENT(IN) :: yu1 ! vents au premier niveau + REAL,DIMENSION(klon),INTENT(IN) :: yv1 ! vents au premier niveau + LOGICAL,INTENT(IN) :: couchelimite + REAL,DIMENSION(klon,klev),INTENT(IN) :: sh ! humidite specifique + +! Arguments necessaires pour les sources et puits de traceur: + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol ! Temperature du sol (surf)(Kelvin) + REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol) + +! InOutput argument + REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA] + +! Output argument + CHARACTER(len=8),DIMENSION(nbtr), INTENT(OUT) :: solsym + REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: source ! a voir lorsque le flux de surface est prescrit + REAL,DIMENSION(klon,klev,nbtr), INTENT(OUT) :: d_tr_cl ! Td couche limite/traceur + +!======================================================================================= +! -- VARIABLES LOCALES TRACEURS -- +!======================================================================================= + + INTEGER :: i, k, it + INTEGER :: lmt_pas ! number of time steps of "physics" per day + + REAL,DIMENSION(klon) :: d_trs ! Td dans le reservoir + REAL,DIMENSION(klon,klev) :: qsat ! pression de la vapeur a saturation + REAL,DIMENSION(klon,klev,nbtr) :: d_tr_dec ! Td radioactive + REAL :: zrho ! Masse Volumique de l'air KgA/m3 + REAL :: amn, amx +! +!================================================================= +! Ajout de la production en Be7 (Beryllium) srcbe U/s/kgA +!================================================================= +! + IF ( id_be /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,id_be) = tr_seri(i,k,id_be)+srcbe(i,k)*pdtphys + END DO + END DO + WRITE(*,*) 'Ajout srcBe dans tr_seri: OK' + END IF + + +!================================================================= +! Update pseudo-vapor tracers +!================================================================= + + CALL q_sat(klon*klev,t_seri,pplay,qsat) + + IF ( id_pcsat /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + IF ( pplay(i,k).GE.85000.) THEN + tr_seri(i,k,id_pcsat) = qsat(i,k) + ELSE + tr_seri(i,k,id_pcsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcsat)) + END IF + END DO + END DO + END IF + + IF ( id_pcocsat /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + IF ( pplay(i,k).GE.85000.) THEN + IF ( pctsrf (i, is_oce) > 0. ) THEN + tr_seri(i,k,id_pcocsat) = qsat(i,k) + ELSE + tr_seri(i,k,id_pcocsat) = 0. + END IF + ELSE + tr_seri(i,k,id_pcocsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcocsat)) + END IF + END DO + END DO + END IF + + IF ( id_pcq /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + IF ( pplay(i,k).GE.85000.) THEN + tr_seri(i,k,id_pcq) = sh(i,k) + ELSE + tr_seri(i,k,id_pcq) = MIN (qsat(i,k), tr_seri(i,k,id_pcq)) + END IF + END DO + END DO + END IF + + + IF ( id_pcs0 /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + IF ( pplay(i,k).GE.85000.) THEN + tr_seri(i,k,id_pcs0) = qsat(i,k) + ELSE + tr_seri(i,k,id_pcs0) = MIN (qsat(i,k), tr_seri(i,k,id_pcs0)) + END IF + END DO + END DO + END IF + + + IF ( id_pcos0 /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + IF ( pplay(i,k).GE.85000.) THEN + IF ( pctsrf (i, is_oce) > 0. ) THEN + tr_seri(i,k,id_pcos0) = qsat(i,k) + ELSE + tr_seri(i,k,id_pcos0) = 0. + END IF + ELSE + tr_seri(i,k,id_pcos0) = MIN (qsat(i,k), tr_seri(i,k,id_pcos0)) + END IF + END DO + END DO + END IF + + + IF ( id_pcq0 /= 0 ) THEN + DO k = 1, klev + DO i = 1, klon + IF ( pplay(i,k).GE.85000.) THEN + tr_seri(i,k,id_pcq0) = sh(i,k) + ELSE + tr_seri(i,k,id_pcq0) = MIN (qsat(i,k), tr_seri(i,k,id_pcq0)) + END IF + END DO + END DO + END IF + +!================================================================= +! Update tracer : Age of stratospheric air +!================================================================= + IF (id_aga/=0) THEN + + ! Bottom layers + DO k = 1, lev_1p5km + tr_seri(:,k,id_aga) = 0.0 + END DO + + ! Layers above 1.5km + DO k = lev_1p5km+1,klev-1 + tr_seri(:,k,id_aga) = tr_seri(:,k,id_aga) + pdtphys + END DO + + ! Top layer + tr_seri(:,klev,id_aga) = tr_seri(:,klev-1,id_aga) + + END IF + +!====================================================================== +! -- Calcul de l'effet de la couche limite -- +!====================================================================== + + IF (couchelimite) THEN + source(:,:) = 0.0 + + IF (id_be /=0) THEN + DO i=1, klon + zrho = pplay(i,1)/t_seri(i,1)/RD + source(i,id_be) = - vdeptr(id_be)*tr_seri(i,1,id_be)*zrho + END DO + END IF + + END IF + + DO it=1, nbtr + IF (couchelimite .AND. pbl_flg(it) == 0 .AND. (it==id_rn .OR. it==id_pb)) THEN + ! couche limite avec quantite dans le sol calculee + CALL cltracrn(it, pdtphys, yu1, yv1, & + cdragh, coefh,t_seri,ftsol,pctsrf, & + tr_seri(:,:,it),trs(:,it), & + paprs, pplay, zmasse * rg, & + masktr(:,it),fshtr(:,it),hsoltr(it),& + tautr(it),vdeptr(it), & + xlat,d_tr_cl(:,:,it),d_trs) + + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it) + END DO + END DO + + ! Traceur dans le reservoir sol + DO i = 1, klon + trs(i,it) = trs(i,it) + d_trs(i) + END DO + END IF + END DO + + +!====================================================================== +! Calcul de l'effet du puits radioactif +!====================================================================== + CALL radio_decay (radio,rnpb,pdtphys,tautr,tr_seri,d_tr_dec) + + DO it=1,nbtr + WRITE(solsym(it),'(i2)') it + END DO + + DO it=1,nbtr + IF(radio(it)) then + DO k = 1, klev + DO i = 1, klon + tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it) + END DO + END DO + CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'puits rn it='//solsym(it)) + END IF + END DO + +!====================================================================== +! Parameterization of ozone chemistry +!====================================================================== + + IF (id_o3 /= 0) then + lmt_pas = NINT(86400./pdtphys) + IF (MOD(nstep - 1, lmt_pas) == 0) THEN + ! Once per day, update the coefficients for ozone chemistry: + CALL regr_pr_comb_coefoz(julien, xlat, paprs, pplay) + END IF + CALL o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, xlat, & + xlon, tr_seri(:, :, id_o3)) + END IF + +!====================================================================== +! Calcul de cycle de carbon +!====================================================================== + IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN + CALL carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source) + END IF + + END SUBROUTINE traclmdz + + + SUBROUTINE traclmdz_to_restart(trs_out) + ! This subroutine is called from phyredem.F where the module + ! variable trs is written to restart file (restartphy.nc) + USE dimphy + USE infotrac + + REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: trs_out + INTEGER :: ierr + + IF ( ALLOCATED(trs) ) THEN + trs_out(:,:) = trs(:,:) + ELSE + ! No previous allocate of trs. This is the case for create_etat0_limit. + trs_out(:,:) = 0.0 + END IF + + END SUBROUTINE traclmdz_to_restart + + +END MODULE traclmdz_mod Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/transp.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/transp.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/transp.F (revision 1634) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE transp (paprs,tsol, + e t, q, u, v, geom, + s vtran_e, vtran_q, utran_e, utran_q) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X.Li (LMD/CNRS) +c Date: le 25 avril 1994 +c Objet: Calculer le transport de l'energie et de la vapeur d'eau +c====================================================================== +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c + REAL paprs(klon,klev+1), tsol(klon) + REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev) + REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon) +c + INTEGER i, l +c ------------------------------------------------------------------ + REAL geom(klon,klev), e +c ------------------------------------------------------------------ + DO i = 1, klon + utran_e(i) = 0.0 + utran_q(i) = 0.0 + vtran_e(i) = 0.0 + vtran_q(i) = 0.0 + ENDDO +c + DO l = 1, klev + DO i = 1, klon + e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l) + utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG + utran_q(i)=utran_q(i)+ u(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG + vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/transp_lay.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/transp_lay.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/transp_lay.F (revision 1634) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE transp_lay (paprs,tsol, + e t, q, u, v, geom, + s vtran_e, vtran_q, utran_e, utran_q) +c + USE dimphy + IMPLICIT none +c====================================================================== +c Auteur(s): Z.X.Li (LMD/CNRS) +c Date: le 25 avril 1994 +c Objet: Calculer le transport de l'energie et de la vapeur d'eau +c====================================================================== +c +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c + REAL paprs(klon,klev+1), tsol(klon) + REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev) + REAL utran_e(klon,klev), utran_q(klon,klev) + REAL vtran_e(klon,klev), vtran_q(klon,klev) +c + INTEGER i, l +c ------------------------------------------------------------------ + REAL geom(klon,klev), esh +c ------------------------------------------------------------------ + DO l = 1, klev + DO i = 1, klon + utran_e(i,l) = 0.0 + utran_q(i,l) = 0.0 + vtran_e(i,l) = 0.0 + vtran_q(i,l) = 0.0 + ENDDO + ENDDO +c + DO l = 1, klev + DO i = 1, klon + esh = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l) + utran_e(i,l)=utran_e(i,l)+ u(i,l)*esh* + . (paprs(i,l)-paprs(i,l+1))/RG + utran_q(i,l)=utran_q(i,l)+ u(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + vtran_e(i,l)=vtran_e(i,l)+ v(i,l)*esh* + . (paprs(i,l)-paprs(i,l+1))/RG + vtran_q(i,l)=vtran_q(i,l)+ v(i,l)*q(i,l) + . *(paprs(i,l)-paprs(i,l+1))/RG + ENDDO + ENDDO +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/undefSTD.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/undefSTD.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/undefSTD.F (revision 1634) @@ -0,0 +1,100 @@ +! +! $Id$ +! + SUBROUTINE undefSTD(itap,freq_calNMC, read_climoz) + USE netcdf + USE dimphy + USE phys_state_var_mod ! Variables sauvegardees de la physique + IMPLICIT none +c +c==================================================================== +c +c I. Musat : 09.2004 +c +c Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef)) +c ou la variable tlevSTD est bien definie (.NE.missing_val), +c et +c * de la somme de tlevSTD => tsumSTD +c +c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps +c ! de la physique +c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps +c ! de la physique +c nout=3 !var. mensuelle "NMC" moyennee toutes les ecrit_hf +c +c +c NB: mettre "inst(X)" dans le write_hist*NMC.h ! +c==================================================================== +c +cym#include "dimensions.h" +cym integer jjmp1 +cym parameter (jjmp1=jjm+1-1/jjm) +cym#include "dimphy.h" +c variables Input +c +c INTEGER nlevSTD, klevSTD, itap +c PARAMETER(klevSTD=17) + INTEGER itap +c REAL dtime +c +c variables locales +c INTEGER i, k, nout, n +c PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC + INTEGER i, k, n + REAL freq_calNMC(nout) + INTEGER read_climoz +c +c variables Output +c REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout) +c LOGICAL oknondef(klon,klevSTD,nout) +c REAL tnondef(klon,klevSTD,nout) +c + REAL missing_val +c + missing_val=nf90_fill_real +c + DO n=1, nout +c +c +c calcul variables tous les freq_calNMC(n)/dtime pas de temps +c de la physique +c + IF(MOD(itap,NINT(freq_calNMC(n)/dtime)).EQ.0) THEN + DO k=1, nlevSTD + DO i=1, klon + IF(tlevSTD(i,k).EQ.missing_val) THEN +c IF(oknondef(i,k,n)) THEN + tnondef(i,k,n)=tnondef(i,k,n)+1. +c ENDIF !oknondef(i,k) +c + ELSE IF(tlevSTD(i,k).NE.missing_val) THEN + tsumSTD(i,k,n)=tsumSTD(i,k,n)+tlevSTD(i,k) + usumSTD(i,k,n)=usumSTD(i,k,n)+ulevSTD(i,k) + vsumSTD(i,k,n)=vsumSTD(i,k,n)+vlevSTD(i,k) + wsumSTD(i,k,n)=wsumSTD(i,k,n)+wlevSTD(i,k) + phisumSTD(i,k,n)=phisumSTD(i,k,n)+philevSTD(i,k) + qsumSTD(i,k,n)=qsumSTD(i,k,n)+qlevSTD(i,k) + rhsumSTD(i,k,n)=rhsumSTD(i,k,n)+rhlevSTD(i,k) + uvsumSTD(i,k,n)=uvsumSTD(i,k,n)+uvSTD(i,k) + vqsumSTD(i,k,n)=vqsumSTD(i,k,n)+vqSTD(i,k) + vTsumSTD(i,k,n)=vTsumSTD(i,k,n)+vTSTD(i,k) + wqsumSTD(i,k,n)=wqsumSTD(i,k,n)+wqSTD(i,k) + vphisumSTD(i,k,n)=vphisumSTD(i,k,n)+vphiSTD(i,k) + wTsumSTD(i,k,n)=wTsumSTD(i,k,n)+wTSTD(i,k) + u2sumSTD(i,k,n)=u2sumSTD(i,k,n)+u2STD(i,k) + v2sumSTD(i,k,n)=v2sumSTD(i,k,n)+v2STD(i,k) + T2sumSTD(i,k,n)=T2sumSTD(i,k,n)+T2STD(i,k) + O3sumSTD(i,k,n)=O3sumSTD(i,k,n)+O3STD(i,k) + IF (read_climoz==2) + & O3daysumSTD(i,k,n)=O3daysumSTD(i,k,n)+O3daySTD(i,k) + + ENDIF + ENDDO !i + ENDDO !k +c + ENDIF !MOD(itap,NINT(freq_calNMC(n)/dtime)).EQ.0 +c + ENDDO !n +c + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ustarhb.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ustarhb.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/ustarhb.F (revision 1634) @@ -0,0 +1,54 @@ +! +! $Header$ +! + SUBROUTINE ustarhb(knon,u,v,cd_m, ustar) + use dimphy + IMPLICIT none +c====================================================================== +c Laurent Li (LMD/CNRS), le 30 septembre 1998 +c Couche limite non-locale. Adaptation du code du CCM3. +c Code non teste, donc a ne pas utiliser. +c====================================================================== +c Nonlocal scheme that determines eddy diffusivities based on a +c diagnosed boundary layer height and a turbulent velocity scale. +c Also countergradient effects for heat and moisture are included. +c +c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993: +c Local versus nonlocal boundary-layer diffusion in a global climate +c model. J. of Climate, vol. 6, 1825-1842. +c====================================================================== +cym#include "dimensions.h" +cym#include "dimphy.h" +#include "YOMCST.h" +c +c Arguments: +c + INTEGER knon ! nombre de points a calculer + REAL u(klon,klev) ! vitesse U (m/s) + REAL v(klon,klev) ! vitesse V (m/s) + REAL cd_m(klon) ! coefficient de friction au sol pour vitesse + REAL ustar(klon) +c + INTEGER i, k + REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy + REAL zx_alf1, zx_alf2 ! parametres pour extrapolation + LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr + LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr + LOGICAL check(klon) ! True=>chk if Richardson no.>critcal +c +#include "YOETHF.h" +#include "FCTTRE.h" + DO i = 1, knon + zx_alf1 = 1.0 + zx_alf2 = 1.0 - zx_alf1 + zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2 + zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2 + zxmod = 1.0+SQRT(zxu**2+zxv**2) + taux = zxu *zxmod*cd_m(i) + tauy = zxv *zxmod*cd_m(i) + ustar(i) = SQRT(taux**2+tauy**2) +c print*,'Ust ',zxu,zxmod,taux,ustar(i) + ENDDO +c + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/vdif_kcay.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/vdif_kcay.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/vdif_kcay.F (revision 1634) @@ -0,0 +1,743 @@ +! +! $Header$ +! + SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar + s ,l_mix) + use dimphy + IMPLICIT NONE +c....................................................................... +cym#include "dimensions.h" +cym#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon),snstable + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1),q2s(klon,klev+1) + REAL q2diag(klon,klev+1) + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon) + + integer l_mix,iii +c....................................................................... +c +c nlay : nombre de couches +c nlev : nombre de niveaux +c ngrid : nombre de points de grille +c unsdz : 1 sur l'epaisseur de couche +c unsdzdec : 1 sur la distance entre le centre de la couche et le +c centre de la couche inferieure +c q : echelle de vitesse au bas de chaque couche +c (valeur a la fin du pas de temps) +c +c....................................................................... + INTEGER nlay,nlev,ngrid + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + REAL q(klon,klev+1) + +c....................................................................... +c +c kmpre : km au debut du pas de temps +c qcstat : q : solution stationnaire du probleme couple +c (valeur a la fin du pas de temps) +c q2cstat : q2 : solution stationnaire du probleme couple +c (valeur a la fin du pas de temps) +c +c....................................................................... + REAL kmpre(klon,klev+1) + REAL qcstat + REAL q2cstat + real sss,sssq +c....................................................................... +c +c long : longueur de melange calculee selon Blackadar +c +c....................................................................... + REAL long(klon,klev+1) +c....................................................................... +c +c kmq3 : terme en q^3 dans le developpement de km +c (valeur au debut du pas de temps) +c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c knq3 : terme en q^3 dans le developpement de kn +c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz} +c (valeur a la fin du pas de temps) +c m : valeur a la fin du pas de temps +c mpre : valeur au debut du pas de temps +c m2 : valeur a la fin du pas de temps +c n2 : valeur a la fin du pas de temps +c +c....................................................................... + REAL kmq3 + REAL kmcstat + REAL knq3 + REAL mcstat + REAL m2cstat + REAL m(klon,klev+1) + REAL mpre(klon,klev+1) + REAL m2(klon,klev+1) + REAL n2(klon,klev+1) +c....................................................................... +c +c gn : intermediaire pour les coefficients de stabilite +c gnmin : borne inferieure de gn (-0.23 ou -0.28) +c gnmax : borne superieure de gn (0.0233) +c gninf : vrai si gn est en dessous de sa borne inferieure +c gnsup : vrai si gn est en dessus de sa borne superieure +c gm : drole d'objet bien utile +c ri : nombre de Richardson +c sn : coefficient de stabilite pour n +c snq2 : premier terme du developement limite de sn en q2 +c sm : coefficient de stabilite pour m +c smq2 : premier terme du developement limite de sm en q2 +c +c....................................................................... + REAL gn + REAL gnmin + REAL gnmax + LOGICAL gninf + LOGICAL gnsup + REAL gm +c REAL ri(klon,klev+1) + REAL sn(klon,klev+1) + REAL snq2(klon,klev+1) + REAL sm(klon,klev+1) + REAL smq2(klon,klev+1) +c....................................................................... +c +c kappa : consatnte de Von Karman (0.4) +c long00 : longueur de reference pour le calcul de long (160) +c a1,a2,b1,b2,c1 : constantes d'origine pour les coefficients +c de stabilite (0.92/0.74/16.6/10.1/0.08) +c cn1,cn2 : constantes pour sn +c cm1,cm2,cm3,cm4 : constantes pour sm +c +c....................................................................... + REAL kappa + REAL long00 + REAL a1,a2,b1,b2,c1 + REAL cn1,cn2 + REAL cm1,cm2,cm3,cm4 +c....................................................................... +c +c termq : termes en $q$ dans l'equation de q2 +c termq3 : termes en $q^3$ dans l'equation de q2 +c termqm2 : termes en $q*m^2$ dans l'equation de q2 +c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2 +c +c....................................................................... + REAL termq + REAL termq3 + REAL termqm2 + REAL termq3m2 +c....................................................................... +c +c q2min : borne inferieure de q2 +c q2max : borne superieure de q2 +c +c....................................................................... + REAL q2min + REAL q2max +c....................................................................... +c knmin : borne inferieure de kn +c kmmin : borne inferieure de km +c....................................................................... + REAL knmin + REAL kmmin +c....................................................................... + INTEGER ilay,ilev,igrid + REAL tmp1,tmp2 +c....................................................................... + PARAMETER (kappa=0.4E+0) + PARAMETER (long00=160.E+0) +c PARAMETER (gnmin=-10.E+0) + PARAMETER (gnmin=-0.28) + PARAMETER (gnmax=0.0233E+0) + PARAMETER (a1=0.92E+0) + PARAMETER (a2=0.74E+0) + PARAMETER (b1=16.6E+0) + PARAMETER (b2=10.1E+0) + PARAMETER (c1=0.08E+0) + PARAMETER (knmin=1.E-5) + PARAMETER (kmmin=1.E-5) + PARAMETER (q2min=1.e-5) + PARAMETER (q2max=1.E+2) +cym PARAMETER (nlay=klev) +cym PARAMETER (nlev=klev+1) +c + PARAMETER ( + & cn1=a2*(1.E+0 -6.E+0 *a1/b1) + & ) + PARAMETER ( + & cn2=-3.E+0 *a2*(6.E+0 *a1+b2) + & ) + PARAMETER ( + & cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1) + & ) + PARAMETER ( + & cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1) + & -3.E+0 *c1*(b2+6.E+0 *a1))) + & ) + PARAMETER ( + & cm3=-3.E+0 *a2*(6.E+0 *a1+b2) + & ) + PARAMETER ( + & cm4=-9.E+0 *a1*a2 + & ) + + logical first + save first + data first/.true./ +c$OMP THREADPRIVATE(first) +c....................................................................... +c traitment des valeur de q2 en entree +c....................................................................... +c +c Initialisation de q2 + nlay=klev + nlev=klev+1 + + call yamada(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar + s ,l_mix) + if (first.and.1.eq.1) then + first=.false. + q2=q2diag + endif + + DO ilev=1,nlev + DO igrid=1,ngrid + q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min) + q(igrid,ilev)=sqrt(q2(igrid,ilev)) + ENDDO + ENDDO +c + DO igrid=1,ngrid + tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2) + q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1 + q2(igrid,1)=amax1(q2(igrid,1),q2min) + q(igrid,1)=sqrt(q2(igrid,1)) + ENDDO +c +c....................................................................... +c les increments verticaux +c....................................................................... +c +c!!!!! allerte !!!!!c +c!!!!! zlev n'est pas declare a nlev !!!!!c +c!!!!! ----> + DO igrid=1,ngrid + zlev(igrid,nlev)=zlay(igrid,nlay) + & +( zlay(igrid,nlay) - zlev(igrid,nlev-1) ) + ENDDO +c!!!!! <---- +c!!!!! allerte !!!!!c +c + DO ilay=1,nlay + DO igrid=1,ngrid + unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay)) + ENDDO + ENDDO + DO igrid=1,ngrid + unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1)) + ENDDO + DO ilay=2,nlay + DO igrid=1,ngrid + unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1)) + ENDDO + ENDDO + DO igrid=1,ngrid + unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay)) + ENDDO +c +c....................................................................... +c le cisaillement et le gradient de temperature +c....................................................................... +c + DO igrid=1,ngrid + m2(igrid,1)=(unsdzdec(igrid,1) + & *u(igrid,1))**2 + & +(unsdzdec(igrid,1) + & *v(igrid,1))**2 + m(igrid,1)=sqrt(m2(igrid,1)) + mpre(igrid,1)=m(igrid,1) + ENDDO +c +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + n2(igrid,ilev)=g*unsdzdec(igrid,ilev) + & *(teta(igrid,ilev)-teta(igrid,ilev-1)) + & /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0 +c n2(igrid,ilev)=0. +c +c ---> +c on ne sais traiter que les cas stratifies. et l'ajustement +c convectif est cense faire en sorte que seul des configurations +c stratifiees soient rencontrees en entree de cette routine. +c mais, bon ... on sait jamais (meme on sait que n2 prends +c quelques valeurs negatives ... parfois) alors : +c<--- +c + IF (n2(igrid,ilev).lt.0.E+0) THEN + n2(igrid,ilev)=0.E+0 + ENDIF +c + m2(igrid,ilev)=(unsdzdec(igrid,ilev) + & *(u(igrid,ilev)-u(igrid,ilev-1)))**2 + & +(unsdzdec(igrid,ilev) + & *(v(igrid,ilev)-v(igrid,ilev-1)))**2 + m(igrid,ilev)=sqrt(m2(igrid,ilev)) + mpre(igrid,ilev)=m(igrid,ilev) +c +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c + DO igrid=1,ngrid + m2(igrid,nlev)=m2(igrid,nlev-1) + m(igrid,nlev)=m(igrid,nlev-1) + mpre(igrid,nlev)=m(igrid,nlev) + ENDDO +c +c....................................................................... +c calcul des fonctions de stabilite +c....................................................................... +c + if (l_mix.eq.4) then + DO igrid=1,ngrid + sqz(igrid)=1.e-10 + sq(igrid)=1.e-10 + ENDDO + do ilev=2,nlev-1 + DO igrid=1,ngrid + zq=sqrt(q2(igrid,ilev)) + sqz(igrid) + . =sqz(igrid)+zq*zlev(igrid,ilev) + . *(zlay(igrid,ilev)-zlay(igrid,ilev-1)) + sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1)) + ENDDO + enddo + DO igrid=1,ngrid + long0(igrid)=0.2*sqz(igrid)/sq(igrid) + ENDDO + else if (l_mix.eq.3) then + long0(igrid)=long00 + endif + +c (abd 5 2) print*,'LONG0=',long0 + +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1)) + if (l_mix.ge.10) then + long(igrid,ilev)=l_mix + else + long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid)) + endif + long(igrid,ilev)=max(min(long(igrid,ilev) + s ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10))) + s ,5.) + + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + gm=long(igrid,ilev)**2 / q2(igrid,ilev) + & * m2(igrid,ilev) +c + gninf=.false. + gnsup=.false. + long(igrid,ilev)=long(igrid,ilev) + long(igrid,ilev)=long(igrid,ilev) +c + IF (gn.lt.gnmin) THEN + gninf=.true. + gn=gnmin + ENDIF +c + IF (gn.gt.gnmax) THEN + gnsup=.true. + gn=gnmax + ENDIF +c + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) ) +c + IF ((gninf).or.(gnsup)) THEN + snq2(igrid,ilev)=0.E+0 + smq2(igrid,ilev)=0.E+0 + ELSE + snq2(igrid,ilev)= + & -gn + & *(-cn1*cn2/(1.E+0 +cn2*gn)**2 ) + smq2(igrid,ilev)= + & -gn + & *( cm2*(1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) + & -( cm3*(1.E+0 +cm4*gn) + & +cm4*(1.E+0 +cm3*gn) ) + & *(cm1+cm2*gn) ) + & /( (1.E+0 +cm3*gn) + & *(1.E+0 +cm4*gn) )**2 + ENDIF +c +c abd +c if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) +c endif +c ---> +c la decomposition de Taylor en q2 n'a de sens que +c dans les cas stratifies ou sn et sm sont quasi +c proportionnels a q2. ailleurs on laisse le meme +c algorithme car l'ajustement convectif fait le travail. +c mais c'est delirant quand sn et snq2 n'ont pas le meme +c signe : dans ces cas, on ne fait pas la decomposition. +c<--- +c + IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0) + & snq2(igrid,ilev)=0.E+0 + IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0) + & smq2(igrid,ilev)=0.E+0 +c +C Correction pour les couches stables. +C Schema repris de JHoltzlag Boville, lui meme venant de... + + if (1.eq.1) then + snstable=1.-zlev(igrid,ilev) + s /(700.*max(ustar(igrid),0.0001)) + snstable=1.-zlev(igrid,ilev)/400. + snstable=max(snstable,0.) + snstable=snstable*snstable + +c abde print*,'SN ',ilev,sn(1,ilev),snstable + if (sn(igrid,ilev).lt.snstable) then + sn(igrid,ilev)=snstable + snq2(igrid,ilev)=0. + endif + + if (sm(igrid,ilev).lt.snstable) then + sm(igrid,ilev)=snstable + smq2(igrid,ilev)=0. + endif + + endif + +c sn : coefficient de stabilite pour n +c snq2 : premier terme du developement limite de sn en q2 +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c +c....................................................................... +c calcul de km et kn au debut du pas de temps +c....................................................................... +c + DO igrid=1,ngrid + kn(igrid,1)=knmin + km(igrid,1)=kmmin + kmpre(igrid,1)=km(igrid,1) + ENDDO +c +c----------------------------------------------------------------------- + DO ilev=2,nlev-1 + DO igrid=1,ngrid +c----------------------------------------------------------------------- +c + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sm(igrid,ilev) + kmpre(igrid,ilev)=km(igrid,ilev) +c +c----------------------------------------------------------------------- + ENDDO + ENDDO +c----------------------------------------------------------------------- +c + DO igrid=1,ngrid + kn(igrid,nlev)=kn(igrid,nlev-1) + km(igrid,nlev)=km(igrid,nlev-1) + kmpre(igrid,nlev)=km(igrid,nlev) + ENDDO +c +c....................................................................... +c boucle sur les niveaux 2 a nlev-1 +c....................................................................... +c +c----> + DO 10001 ilev=2,nlev-1 +c----> + DO 10002 igrid=1,ngrid +c +c....................................................................... +c +c calcul des termes sources et puits de l'equation de q2 +c ------------------------------------------------------ +c + knq3=kn(igrid,ilev)*snq2(igrid,ilev) + & /sn(igrid,ilev) + kmq3=km(igrid,ilev)*smq2(igrid,ilev) + & /sm(igrid,ilev) +c + termq=0.E+0 + termq3=0.E+0 + termqm2=0.E+0 + termq3m2=0.E+0 +c + tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev) + tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev) + termqm2=termqm2 + & +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev) + & -dt*2.E+0 *kmq3*m2(igrid,ilev) + termq3m2=termq3m2 + & +dt*2.E+0 *kmq3*m2(igrid,ilev) +c + termq=termq + & -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev) + & +dt*2.E+0 *knq3*n2(igrid,ilev) + termq3=termq3 + & -dt*2.E+0 *knq3*n2(igrid,ilev) +c + termq3=termq3 + & -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev)) +c +c....................................................................... +c +c resolution stationnaire couplee avec le gradient de vitesse local +c ----------------------------------------------------------------- +c +c -----{on cherche le cisaillement qui annule l'equation de q^2 +c supposee en q3} +c + tmp1=termq+termq3 + tmp2=termqm2+termq3m2 + m2cstat=m2(igrid,ilev) + & -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev)) + mcstat=sqrt(m2cstat) + +c abde print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat +c +c -----{puis on ecrit la valeur de q qui annule l'equation de m +c supposee en q3} +c + IF (ilev.eq.2) THEN + kmcstat=1.E+0 / mcstat + & *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1) + & *mpre(igrid,ilev+1) + & +unsdz(igrid,ilev-1) + & *cd(igrid) + & *( sqrt(u(igrid,3)**2+v(igrid,3)**2) + & -mcstat/unsdzdec(igrid,ilev) + & -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2) + & /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) ) + ELSE + kmcstat=1.E+0 / mcstat + & *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1) + & *mpre(igrid,ilev+1) + & +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1) + & *mpre(igrid,ilev-1) ) + & /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) ) + ENDIF + tmp2=kmcstat + & /( sm(igrid,ilev)/q2(igrid,ilev) ) + & /long(igrid,ilev) + qcstat=tmp2**(1.E+0/3.E+0) + q2cstat=qcstat**2 +c +c....................................................................... +c +c choix de la solution finale +c --------------------------- +c + q(igrid,ilev)=qcstat + q2(igrid,ilev)=q2cstat + m(igrid,ilev)=mcstat +c abd if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' M2=',m2(igrid,ilev),m2cstat, +c s 'N2=',n2(igrid,ilev) +c abd endif + m2(igrid,ilev)=m2cstat +c +c ---> +c pour des raisons simples q2 est minore +c<--- +c + IF (q2(igrid,ilev).lt.q2min) THEN + q2(igrid,ilev)=q2min + q(igrid,ilev)=sqrt(q2min) + ENDIF +c +c....................................................................... +c +c calcul final de kn et km +c ------------------------ +c + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + IF (gn.lt.gnmin) gn=gnmin + IF (gn.gt.gnmax) gn=gnmax + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) ) + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sm(igrid,ilev) +c abd +c if(ilev.le.57.and.ilev.ge.37) then +c print*,'L=',ilev,' GN=',gn,' SM=',sm(igrid,ilev) +c endif +c +c....................................................................... +c +10002 CONTINUE +c +10001 CONTINUE +c +c....................................................................... +c +c + DO igrid=1,ngrid + kn(igrid,1)=knmin + km(igrid,1)=kmmin +c kn(igrid,1)=cd(igrid) +c km(igrid,1)=cd(igrid) + q2(igrid,nlev)=q2(igrid,nlev-1) + q(igrid,nlev)=q(igrid,nlev-1) + kn(igrid,nlev)=kn(igrid,nlev-1) + km(igrid,nlev)=km(igrid,nlev-1) + ENDDO +c +c CALCUL DE LA DIFFUSION VERTICALE DE Q2 + if (1.eq.1) then + + do ilev=2,klev-1 + sss=sss+plev(1,ilev-1)-plev(1,ilev+1) + sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev) + enddo +c print*,'Q2moy avant',sssq/sss +c print*,'Q2q20 ',(q2(1,ilev),ilev=1,10) +c print*,'Q2km0 ',(km(1,ilev),ilev=1,10) +c ! C'est quoi ca qu'etait dans l'original??? +c do igrid=1,ngrid +c q2(igrid,1)=10. +c enddo +c q2s=q2 +c do iii=1,10 +c call vdif_q2(dt,g,rconst,plev,temp,km,q2) +c do ilev=1,klev+1 +c write(iii+49,*) q2(1,ilev),zlev(1,ilev) +c enddo +c enddo +c stop +c do ilev=1,klev +c print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev) +c enddo +c q2s=q2-q2s +c do ilev=1,klev +c print*,q2s(1,ilev),zlev(1,ilev) +c enddo + do ilev=2,klev-1 + sss=sss+plev(1,ilev-1)-plev(1,ilev+1) + sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev) + enddo + print*,'Q2moy apres',sssq/sss +c +c + do ilev=1,nlev + do igrid=1,ngrid + q2(igrid,ilev)=max(q2(igrid,ilev),q2min) + q(igrid,ilev)=sqrt(q2(igrid,ilev)) + +c....................................................................... +c +c calcul final de kn et km +c ------------------------ +c + gn=-long(igrid,ilev)**2 / q2(igrid,ilev) + & * n2(igrid,ilev) + IF (gn.lt.gnmin) gn=gnmin + IF (gn.gt.gnmax) gn=gnmax + sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn) + sm(igrid,ilev)= + & (cm1+cm2*gn) + & /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) ) +C Correction pour les couches stables. +C Schema repris de JHoltzlag Boville, lui meme venant de... + + if (1.eq.1) then + snstable=1.-zlev(igrid,ilev) + s /(700.*max(ustar(igrid),0.0001)) + snstable=1.-zlev(igrid,ilev)/400. + snstable=max(snstable,0.) + snstable=snstable*snstable + +c abde print*,'SN ',ilev,sn(1,ilev),snstable + if (sn(igrid,ilev).lt.snstable) then + sn(igrid,ilev)=snstable + snq2(igrid,ilev)=0. + endif + + if (sm(igrid,ilev).lt.snstable) then + sm(igrid,ilev)=snstable + smq2(igrid,ilev)=0. + endif + + endif + +c sn : coefficient de stabilite pour n + kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) + & *sn(igrid,ilev) + km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev) +c + enddo + enddo +c print*,'Q2km1 ',(km(1,ilev),ilev=1,10) + + endif + + RETURN + END Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wake.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wake.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wake.F (revision 1634) @@ -0,0 +1,2895 @@ +! +! $Id$ +! + Subroutine WAKE (p,ph,pi,dtime,sigd_con + : ,te0,qe0,omgb + : ,dtdwn,dqdwn,amdwn,amup,dta,dqa + : ,wdtPBL,wdqPBL,udtPBL,udqPBL + o ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl + o ,dtls,dqls + o ,ktopw,omgbdth,dp_omgb,wdens + o ,tu,qu + o ,dtKE,dqKE + o ,dtPBL,dqPBL + o ,omg,dp_deltomg,spread + o ,Cstar,d_deltat_gw + o ,d_deltatw2,d_deltaqw2) + + +*************************************************************** +* * +* WAKE * +* retour a un Pupper fixe * +* * +* written by : GRANDPEIX Jean-Yves 09/03/2000 * +* modified by : ROEHRIG Romain 01/29/2007 * +*************************************************************** +c + use dimphy + IMPLICIT none +c============================================================================ +C +C +C But : Decrire le comportement des poches froides apparaissant dans les +C grands systemes convectifs, et fournir l'energie disponible pour +C le declenchement de nouvelles colonnes convectives. +C +C Variables d'etat : deltatw : ecart de temperature wake-undisturbed area +C deltaqw : ecart d'humidite wake-undisturbed area +C sigmaw : fraction d'aire occupee par la poche. +C +C Variable de sortie : +c +c wape : WAke Potential Energy +c fip : Front Incident Power (W/m2) - ALP +c gfl : Gust Front Length per unit area (m-1) +C dtls : large scale temperature tendency due to wake +C dqls : large scale humidity tendency due to wake +C hw : hauteur de la poche +C dp_omgb : vertical gradient of large scale omega +C wdens : densite de poches +C omgbdth: flux of Delta_Theta transported by LS omega +C dtKE : differential heating (wake - unpertubed) +C dqKE : differential moistening (wake - unpertubed) +C omg : Delta_omg =vertical velocity diff. wake-undist. (Pa/s) +C dp_deltomg : vertical gradient of omg (s-1) +C spread : spreading term in dt_wake and dq_wake +C deltatw : updated temperature difference (T_w-T_u). +C deltaqw : updated humidity difference (q_w-q_u). +C sigmaw : updated wake fractional area. +C d_deltat_gw : delta T tendency due to GW +c +C Variables d'entree : +c +c aire : aire de la maille +c te0 : temperature dans l'environnement (K) +C qe0 : humidite dans l'environnement (kg/kg) +C omgb : vitesse verticale moyenne sur la maille (Pa/s) +C dtdwn: source de chaleur due aux descentes (K/s) +C dqdwn: source d'humidite due aux descentes (kg/kg/s) +C dta : source de chaleur due courants satures et detrain (K/s) +C dqa : source d'humidite due aux courants satures et detra (kg/kg/s) +C amdwn: flux de masse total des descentes, par unite de +C surface de la maille (kg/m2/s) +C amup : flux de masse total des ascendances, par unite de +C surface de la maille (kg/m2/s) +C p : pressions aux milieux des couches (Pa) +C ph : pressions aux interfaces (Pa) +C pi : (p/p_0)**kapa (adim) +C dtime: increment temporel (s) +c +C Variables internes : +c +c rhow : masse volumique de la poche froide +C rho : environment density at P levels +C rhoh : environment density at Ph levels +C te : environment temperature | may change within +C qe : environment humidity | sub-time-stepping +C the : environment potential temperature +C thu : potential temperature in undisturbed area +C tu : temperature in undisturbed area +C qu : humidity in undisturbed area +C dp_omgb: vertical gradient og LS omega +C omgbw : wake average vertical omega +C dp_omgbw: vertical gradient of omgbw +C omgbdq : flux of Delta_q transported by LS omega +C dth : potential temperature diff. wake-undist. +C th1 : first pot. temp. for vertical advection (=thu) +C th2 : second pot. temp. for vertical advection (=thw) +C q1 : first humidity for vertical advection +C q2 : second humidity for vertical advection +C d_deltatw : terme de redistribution pour deltatw +C d_deltaqw : terme de redistribution pour deltaqw +C deltatw0 : deltatw initial +C deltaqw0 : deltaqw initial +C hw0 : hw initial +C sigmaw0: sigmaw initial +C amflux : horizontal mass flux through wake boundary +C wdens_ref: initial number of wakes per unit area (3D) or per +C unit length (2D), at the beginning of each time step +C Tgw : 1 sur la période de onde de gravité +c Cgw : vitesse de propagation de onde de gravité +c LL : distance entre 2 poches + +c------------------------------------------------------------------------- +c Déclaration de variables +c------------------------------------------------------------------------- + +#include "dimensions.h" +#include "YOMCST.h" +#include "cvthermo.h" +#include "iniprint.h" + +c Arguments en entree +c-------------------- + + REAL, dimension(klon,klev) :: p, pi + REAL, dimension(klon,klev+1) :: ph, omgb + REAL dtime + REAL, dimension(klon,klev) :: te0,qe0 + REAL, dimension(klon,klev) :: dtdwn, dqdwn + REAL, dimension(klon,klev) :: wdtPBL,wdqPBL + REAL, dimension(klon,klev) :: udtPBL,udqPBL + REAL, dimension(klon,klev) :: amdwn, amup + REAL, dimension(klon,klev) :: dta, dqa + REAL, dimension(klon) :: sigd_con + +c Sorties +c-------- + + REAL, dimension(klon,klev) :: deltatw, deltaqw, dth + REAL, dimension(klon,klev) :: tu, qu + REAL, dimension(klon,klev) :: dtls, dqls + REAL, dimension(klon,klev) :: dtKE, dqKE + REAL, dimension(klon,klev) :: dtPBL, dqPBL + REAL, dimension(klon,klev) :: spread + REAL, dimension(klon,klev) :: d_deltatgw + REAL, dimension(klon,klev) :: d_deltatw2, d_deltaqw2 + REAL, dimension(klon,klev+1) :: omgbdth, omg + REAL, dimension(klon,klev) :: dp_omgb, dp_deltomg + REAL, dimension(klon,klev) :: d_deltat_gw + REAL, dimension(klon) :: hw, sigmaw, wape, fip, gfl, Cstar + REAL, dimension(klon) :: wdens + INTEGER, dimension(klon) :: ktopw + +c Variables internes +c------------------- + +c Variables à fixer + REAL ALON + REAL coefgw + REAL :: wdens_ref + REAL stark + REAL alpk + REAL delta_t_min + INTEGER nsub + REAL dtimesub + REAL sigmad, hwmin,wapecut + REAL :: sigmaw_max + REAL :: dens_rate + REAL wdens0 +cIM 080208 + LOGICAL, dimension(klon) :: gwake + +c Variables de sauvegarde + REAL, dimension(klon,klev) :: deltatw0 + REAL, dimension(klon,klev) :: deltaqw0 + REAL, dimension(klon,klev) :: te, qe + REAL, dimension(klon) :: sigmaw0, sigmaw1 + +c Variables pour les GW + REAL, DIMENSION(klon) :: LL + REAL, dimension(klon,klev) :: N2 + REAL, dimension(klon,klev) :: Cgw + REAL, dimension(klon,klev) :: Tgw + +c Variables liées au calcul de hw + REAL, DIMENSION(klon) :: ptop_provis, ptop, ptop_new + REAL, DIMENSION(klon) :: sum_dth + REAL, DIMENSION(klon) :: dthmin + REAL, DIMENSION(klon) :: z, dz, hw0 + INTEGER, DIMENSION(klon) :: ktop, kupper + +c Sub-timestep tendencies and related variables + REAL d_deltatw(klon,klev),d_deltaqw(klon,klev) + REAL d_te(klon,klev),d_qe(klon,klev) + REAL d_sigmaw(klon),alpha(klon) + REAL q0_min(klon),q1_min(klon) + LOGICAL wk_adv(klon), OK_qx_qw(klon) + REAL epsilon + DATA epsilon/1.e-15/ + +c Autres variables internes + INTEGER isubstep, k, i + + REAL, DIMENSION(klon) :: sum_thu, sum_tu, sum_qu,sum_thvu + REAL, DIMENSION(klon) :: sum_dq, sum_rho + REAL, DIMENSION(klon) :: sum_dtdwn, sum_dqdwn + REAL, DIMENSION(klon) :: av_thu, av_tu, av_qu, av_thvu + REAL, DIMENSION(klon) :: av_dth, av_dq, av_rho + REAL, DIMENSION(klon) :: av_dtdwn, av_dqdwn + + REAL, DIMENSION(klon,klev) :: rho, rhow + REAL, DIMENSION(klon,klev+1) :: rhoh + REAL, DIMENSION(klon,klev) :: rhow_moyen + REAL, DIMENSION(klon,klev) :: zh + REAL, DIMENSION(klon,klev+1) :: zhh + REAL, DIMENSION(klon,klev) :: epaisseur1, epaisseur2 + + REAL, DIMENSION(klon,klev) :: the, thu + +! REAL, DIMENSION(klon,klev) :: d_deltatw, d_deltaqw + + REAL, DIMENSION(klon,klev+1) :: 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) :: ff, gg + REAL, dimension(klon) :: wape2, Cstar2, heff + + REAL, DIMENSION(klon,klev) :: Crep + REAL Crep_upper, Crep_sol + + REAL, DIMENSION(klon,klev) :: ppi + +ccc nrlmd + real, dimension(klon) :: death_rate,nat_rate + real, dimension(klon,klev) :: entr + real, dimension(klon,klev) :: detr + +C------------------------------------------------------------------------- +c Initialisations +c------------------------------------------------------------------------- + +c print*, 'wake initialisations' + +c Essais d'initialisation avec sigmaw = 0.02 et hw = 10. +c------------------------------------------------------------------------- + + DATA wapecut,sigmad, hwmin /5.,.02,10./ +ccc nrlmd + DATA sigmaw_max /0.4/ + DATA dens_rate /0.1/ +ccc +C Longueur de maille (en m) +c------------------------------------------------------------------------- + +c ALON = 3.e5 + ALON = 1.e6 + + +C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei) +c +c coefgw : Coefficient pour les ondes de gravité +c stark : Coefficient k dans Cstar=k*sqrt(2*WAPE) +c wdens : Densité de poche froide par maille +c------------------------------------------------------------------------- + +ccc nrlmd coefgw=10 +c coefgw=1 +c wdens0 = 1.0/(alon**2) +ccc nrlmd wdens = 1.0/(alon**2) +ccc nrlmd stark = 0.50 +cCRtest +ccc nrlmd alpk=0.1 +c alpk = 1.0 +c alpk = 0.5 +c alpk = 0.05 +c + stark = 0.33 + Alpk = 0.25 + wdens_ref = 8.e-12 + coefgw = 4. + Crep_upper=0.9 + Crep_sol=1.0 + +ccc nrlmd Lecture du fichier wake_param.data + OPEN(99,file='wake_param.data',status='old', + $ form='formatted',err=9999) + READ(99,*,end=9998) stark + READ(99,*,end=9998) Alpk + READ(99,*,end=9998) wdens_ref + READ(99,*,end=9998) coefgw +9998 Continue + CLOSE(99) +9999 Continue +c +c Initialisation de toutes des densites a wdens_ref. +c Les densites peuvent evoluer si les poches debordent +c (voir au tout debut de la boucle sur les substeps) + wdens = wdens_ref +c +c print*,'stark',stark +c print*,'alpk',alpk +c print*,'wdens',wdens +c print*,'coefgw',coefgw +ccc +C Minimum value for |T_wake - T_undist|. Used for wake top definition +c------------------------------------------------------------------------- + + delta_t_min = 0.2 + +C 1. - Save initial values and initialize tendencies +C -------------------------------------------------- + + 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) + te(i,k) = te0(i,k) + qe(i,k) = qe0(i,k) + dtls(i,k) = 0. + dqls(i,k) = 0. + d_deltat_gw(i,k)=0. + d_te(i,k) = 0. + d_qe(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 + ENDDO + ENDDO +c sigmaw1=sigmaw +c IF (sigd_con.GT.sigmaw1) THEN +c print*, 'sigmaw,sigd_con', sigmaw, sigd_con +c ENDIF + DO i=1, klon +cc sigmaw(i) = amax1(sigmaw(i),sigd_con(i)) + sigmaw(i) = amax1(sigmaw(i),sigmad) + sigmaw(i) = amin1(sigmaw(i),0.99) + sigmaw0(i) = sigmaw(i) + wape(i) = 0. + wape2(i) = 0. + d_sigmaw(i) = 0. + ktopw(i) = 0 + ENDDO +C +C +C 2. - Prognostic part +C -------------------- +C +C +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + DO i=1, klon + z(i) = 0. + ktop(i)=0 + kupper(i) = 0 + sum_thu(i) = 0. + sum_tu(i) = 0. + sum_qu(i) = 0. + sum_thvu(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_rho(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thu(i) = 0. + av_tu(i) =0. + av_qu(i) =0. + av_thvu(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_rho(i) =0. + av_dtdwn(i) =0. + av_dqdwn(i) = 0. + ENDDO +c +c Distance between wakes + DO i = 1,klon + LL(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens(i)) + ENDDO +C Potential temperatures and humidity +c---------------------------------------------------------- + DO k =1,klev + DO i=1, klon +! write(*,*)'wake 1',i,k,rd,te(i,k) + rho(i,k) = p(i,k)/(rd*te(i,k)) +! write(*,*)'wake 2',rho(i,k) + IF(k .eq. 1) THEN +! write(*,*)'wake 3',i,k,rd,te(i,k) + rhoh(i,k) = ph(i,k)/(rd*te(i,k)) +! write(*,*)'wake 4',i,k,rd,te(i,k) + zhh(i,k)=0 + ELSE +! write(*,*)'wake 5',rd,(te(i,k)+te(i,k-1)) + rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(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) + ENDIF +! write(*,*)'wake 7',ppi(i,k) + the(i,k) = te(i,k)/ppi(i,k) + thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k) + tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i) + qu(i,k) = qe(i,k) - deltaqw(i,k)*sigmaw(i) +! write(*,*)'wake 8',(rd*(te(i,k)+deltatw(i,k))) + rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k))) + dth(i,k) = deltatw(i,k)/ppi(i,k) + ENDDO + ENDDO + + DO k = 1, klev-1 + DO i=1, klon + IF(k.eq.1) THEN + N2(i,k)=0 + ELSE + N2(i,k)=amax1(0.,-RG**2/the(i,k)*rho(i,k)*(the(i,k+1)- + $ the(i,k-1))/(p(i,k+1)-p(i,k-1))) + ENDIF + 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) + ENDDO + ENDDO + + DO i=1, klon + N2(i,klev)=0 + ZH(i,klev)=0 + Cgw(i,klev)=0 + Tgw(i,klev)=0 + ENDDO + +c Calcul de la masse volumique moyenne de la colonne (bdlmd) +c----------------------------------------------------------------- + + DO k=1,klev + DO i=1, klon + epaisseur1(i,k)=0. + epaisseur2(i,k)=0. + ENDDO + ENDDO + + DO i=1, klon + epaisseur1(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1. + epaisseur2(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1. + rhow_moyen(i,1) = rhow(i,1) + ENDDO + + DO k = 2, klev + DO i=1, klon + epaisseur1(i,k)= -(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg) +1. + epaisseur2(i,k)=epaisseur2(i,k-1)+epaisseur1(i,k) + rhow_moyen(i,k) = (rhow_moyen(i,k-1)*epaisseur2(i,k-1)+ + $ rhow(i,k)*epaisseur1(i,k))/epaisseur2(i,k) + ENDDO + ENDDO + +C +C Choose an integration bound well above wake top +c----------------------------------------------------------------- +c +C Pupper = 50000. ! melting level +c Pupper = 60000. +c Pupper = 80000. ! essais pour case_e + DO i = 1,klon + Pupper(i) = 0.6*ph(i,1) + Pupper(i) = max(Pupper(i), 45000.) +ccc Pupper(i) = 60000. + ENDDO + +C +C Determine Wake top pressure (Ptop) from buoyancy integral +C -------------------------------------------------------- +c +c-1/ Pressure of the level where dth becomes less than delta_t_min. + + DO i=1,klon + ptop_provis(i)=ph(i,1) + ENDDO + DO k= 2,klev + DO i=1,klon +c +cIM v3JYG; ptop_provis(i).LT. ph(i,1) +c + IF (dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min .and. + $ ptop_provis(i).EQ. ph(i,1)) THEN + ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) / + $ (dth(i,k) - dth(i,k-1)) + ENDIF + ENDDO + ENDDO + +c-2/ dth integral + + DO i=1,klon + sum_dth(i) = 0. + dthmin(i) = -delta_t_min + z(i) = 0. + ENDDO + + DO k = 1,klev + DO i=1,klon + dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i) + dthmin(i) = amin1(dthmin(i),dth(i,k)) + ENDIF + ENDDO + ENDDO + +c-3/ height of triangle with area= sum_dth and base = dthmin + + DO i=1,klon + hw0(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5) + hw0(i) = amax1(hwmin,hw0(i)) + ENDDO + +c-4/ now, get Ptop + + DO i=1,klon + z(i) = 0. + ptop(i) = ph(i,1) + ENDDO + + DO k = 1,klev + DO i=1,klon + dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg),hw0(i)-z(i)) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + ptop(i) = ph(i,k)-rho(i,k)*rg*dz(i) + ENDIF + ENDDO + ENDDO + + +C-5/ Determination de ktop et kupper + + DO k=klev,1,-1 + DO i=1,klon + IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k + IF (ph(i,k+1) .lt. pupper(i)) kupper(i)=k + ENDDO + ENDDO + +c On evite kupper = 1 + DO i=1,klon + kupper(i) = max(kupper(i),2) + ENDDO + + +c-6/ Correct ktop and ptop + + DO i = 1,klon + ptop_new(i)=ptop(i) + ENDDO + DO k= klev,2,-1 + DO i=1,klon + IF (k .LE. ktop(i) .and. + $ ptop_new(i) .EQ. ptop(i) .and. + $ dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min) THEN + ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) / + $ (dth(i,k) - dth(i,k-1)) + ENDIF + ENDDO + ENDDO + + DO i=1,klon + ptop(i) = ptop_new(i) + ENDDO + + DO k=klev,1,-1 + DO i=1,klon + IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k + ENDDO + ENDDO +c +c-5/ Set deltatw & deltaqw to 0 above kupper +c + DO k = 1,klev + DO i=1,klon + IF (k.GE. kupper(i)) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + ENDIF + ENDDO + ENDDO +c +C +C Vertical gradient of LS omega +C + DO k = 1,klev + DO i=1,klon + IF (k.LE. kupper(i)) THEN + dp_omgb(i,k) = (omgb(i,k+1) - omgb(i,k))/(ph(i,k+1)-ph(i,k)) + ENDIF + ENDDO + ENDDO +C +C Integrals (and wake top level number) +C -------------------------------------- +C +C Initialize sum_thvu to 1st level virt. pot. temp. + + DO i=1,klon + z(i) = 1. + dz(i) = 1. + sum_thvu(i) = thu(i,1)*(1.+eps*qu(i,1))*dz(i) + sum_dth(i) = 0. + ENDDO + + 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) .GT. 0) THEN + z(i) = z(i)+dz(i) + sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i) + sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i) + sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i) + sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(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_rho(i) = sum_rho(i) + rhow(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) + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + hw0(i) = z(i) + ENDDO +c +C +C 2.1 - WAPE and mean forcing computation +C --------------------------------------- +C +C --------------------------------------- +C +C Means + + DO i=1,klon + av_thu(i) = sum_thu(i)/hw0(i) + av_tu(i) = sum_tu(i)/hw0(i) + av_qu(i) = sum_qu(i)/hw0(i) + av_thvu(i) = sum_thvu(i)/hw0(i) +c av_thve = sum_thve/hw0 + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_rho(i) = sum_rho(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) + $ + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)* + $ av_dq(i) ))/av_thvu(i) + ENDDO +C +C 2.2 Prognostic variable update +C ------------------------------ +C +C Filter out bad wakes + + DO k = 1,klev + DO i=1,klon + IF ( wape(i) .LT. 0.) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + dth(i,k) = 0. + ENDIF + ENDDO + ENDDO +c + DO i=1,klon + IF ( wape(i) .LT. 0.) THEN + wape(i) = 0. + Cstar(i) = 0. + hw(i) = hwmin + sigmaw(i) = amax1(sigmad,sigd_con(i)) + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + Cstar(i) = stark*sqrt(2.*wape(i)) + gwake(i) = .TRUE. + ENDIF + ENDDO + +c +c Check qx and qw positivity +c -------------------------- + DO i = 1,klon + q0_min(i)=min( (qe(i,1)-sigmaw(i)*deltaqw(i,1)), + $ (qe(i,1)+(1.-sigmaw(i))*deltaqw(i,1)) ) + ENDDO + DO k = 2,klev + DO i = 1,klon + q1_min(i)=min( (qe(i,k)-sigmaw(i)*deltaqw(i,k)), + $ (qe(i,k)+(1.-sigmaw(i))*deltaqw(i,k)) ) + IF (q1_min(i).le.q0_min(i)) THEN + q0_min(i)=q1_min(i) + ENDIF + ENDDO + ENDDO +c + DO i = 1,klon + OK_qx_qw(i) = q0_min(i) .GE. 0. + alpha(i) = 1. + ENDDO +c +CC ----------------------------------------------------------------- +C Sub-time-stepping +C ----------------- +C + nsub=10 + dtimesub=dtime/nsub +c +c------------------------------------------------------------ + DO isubstep = 1,nsub +c------------------------------------------------------------ +c +c 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) .GE. 1. + ENDDO +c +ccc nrlmd Ajout d'un recalcul de wdens dans le cas d'un entrainement négatif de ktop à kupper -------- +ccc On calcule pour cela une densité wdens0 pour laquelle on aurait un entrainement nul --- + DO i=1,klon +cc print *,' isubstep,wk_adv(i),cstar(i),wape(i) ', +cc $ isubstep,wk_adv(i),cstar(i),wape(i) + IF (wk_adv(i) .AND. cstar(i).GT.0.01) THEN + omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i) + $ + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i)) + wdens0 = ( sigmaw(i) / (4.*3.14) ) * + $ ( (1.-sigmaw(i)) * omg(i,kupper(i)+1) / + $ ( (ph(i,1)-pupper(i)) * cstar(i) ) ) **(2) + IF ( wdens(i) .LE. wdens0*1.1 ) THEN + wdens(i) = wdens0 + ENDIF +cc print*,'omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i) +cc $ ,ph(i,1)-pupper(i)', +cc $ omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i) +cc $ ,ph(i,1)-pupper(i) + ENDIF + ENDDO + +ccc nrlmd + + DO i=1,klon + IF (wk_adv(i)) THEN + gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i)) + sigmaw(i)=amin1(sigmaw(i),sigmaw_max) + ENDIF + ENDDO + DO i=1,klon + IF (wk_adv(i)) THEN +ccc nrlmd Introduction du taux de mortalité des poches et test sur sigmaw_max=0.4 +ccc d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub + IF (sigmaw(i).ge.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 +c $ - nat_rate(i)*sigmaw(i)*dtimesub +cc print*, 'd_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i), +cc $ death_rate(i),ktop(i),kupper(i)', +cc $ d_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i), +cc $ death_rate(i),ktop(i),kupper(i) + +c sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub +c sigmaw(i) =min(sigmaw(i),0.99) !!!!!!!! +c wdens = wdens0/(10.*sigmaw) +c sigmaw =max(sigmaw,sigd_con) +c sigmaw =max(sigmaw,sigmad) + ENDIF + ENDDO +C +C +c calcul de la difference de vitesse verticale poche - zone non perturbee +cIM 060208 differences par rapport au code initial; init. a 0 dp_deltomg +cIM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit +cIM 060208 au niveau k=1..? + DO k= 1,klev + DO i = 1,klon + if (wk_adv(i)) THEN !!! nrlmd + dp_deltomg(i,k)=0. + end if + ENDDO + ENDDO + DO k= 1,klev+1 + DO i = 1,klon + if (wk_adv(i)) THEN !!! nrlmd + omg(i,k)=0. + end if + ENDDO + ENDDO +c + 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))) + ENDIF + ENDDO +c + DO k= 2,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. 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) + ENDIF + ENDDO + ENDDO +c + 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) + ENDIF + ENDDO +c +c ----------------- +c From m/s to Pa/s +c ----------------- +c + DO i=1,klon + IF (wk_adv(i)) THEN + omgtop(i) = -rho(i,ktop(i))*rg*omgtop(i) + dp_deltomg(i,1) = omgtop(i)/(ptop(i)-ph(i,1)) + ENDIF + ENDDO +c + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN + omg(i,k) = - rho(i,k)*rg*omg(i,k) + dp_deltomg(i,k) = dp_deltomg(i,1) + ENDIF + ENDDO + ENDDO +c +c raccordement lineaire de omg de ptop a pupper + + DO i=1,klon + IF ( wk_adv(i) .AND. kupper(i) .GT. ktop(i)) THEN + omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i) + $ + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i)) + dp_deltomg(i,kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/ + $ (ptop(i)-pupper(i)) + ENDIF + ENDDO +c +cc DO i=1,klon +cc print*,'Pente entre 0 et kupper (référence)' +cc $ ,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1)) +cc print*,'Pente entre ktop et kupper' +cc $ ,(omg(i,kupper(i)+1)-omgtop(i))/(pupper(i)-ptop(i)) +cc ENDDO +cc + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .GT. ktop(i) .AND. k .LE. 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)) + ENDIF + ENDDO + ENDDO +ccc nrlmd +cc DO i=1,klon +cc print*,'deltaw_ktop,deltaw_conv',omgtop(i),omg(i,kupper(i)+1) +cc END DO +ccc +c +c +c-- Compute wake average vertical velocity omgbw +c +c + DO k = 1,klev+1 + DO i=1,klon + IF ( wk_adv(i)) THEN + omgbw(i,k) = omgb(i,k)+(1.-sigmaw(i))*omg(i,k) + ENDIF + ENDDO + ENDDO +c-- and its vertical gradient dp_omgbw +c + DO k = 1,klev + 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)) + ENDIF + ENDDO + ENDDO +C +c-- Upstream coefficients for omgb velocity +c-- (alpha_up(k) is the coefficient of the value at level k) +c-- (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) .GT. 0.) alpha_up(i,k) = 1. + ENDIF + ENDDO + ENDDO + +c 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) + ENDIF + ENDDO + RRd1 = -1. + RRd2 = 1. +c +c-- Get [Th1,Th2], dth and [q1,q2] +c + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN + dth(i,k) = deltatw(i,k)/ppi(i,k) + Th1(i,k) = the(i,k) - sigmaw(i) *dth(i,k) ! undisturbed area + Th2(i,k) = the(i,k) + (1.-sigmaw(i))*dth(i,k) ! wake + q1(i,k) = qe(i,k) - sigmaw(i) *deltaqw(i,k) ! undisturbed area + q2(i,k) = qe(i,k) + (1.-sigmaw(i))*deltaqw(i,k) ! wake + ENDIF + ENDDO + ENDDO + + 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 + ENDDO + + DO k= 2,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. 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) + ENDIF + ENDDO + ENDDO + + DO i=1,klon + IF( wk_adv(i)) THEN + omgbdth(i,1) = 0. + omgbdq(i,1) = 0. + ENDIF + ENDDO + + DO k= 2,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. 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)) + ENDIF + ENDDO + ENDDO +c +c----------------------------------------------------------------- + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN +c----------------------------------------------------------------- +c +c Compute redistribution (advective) term +c + d_deltatw(i,k) = + $ dtimesub/(Ph(i,k)-Ph(i,k+1))*( + $ RRd1*omg(i,k )*sigmaw(i) *D_Th1(i,k) + $ -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) + $ -(1.-alpha_up(i,k))*omgbdth(i,k) - alpha_up(i,k+1)* + $ omgbdth(i,k+1))*ppi(i,k) +c print*,'d_deltatw=',d_deltatw(i,k) +c + d_deltaqw(i,k) = + $ dtimesub/(Ph(i,k)-Ph(i,k+1))*( + $ RRd1*omg(i,k )*sigmaw(i) *D_q1(i,k) + $ -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) + $ -(1.-alpha_up(i,k))*omgbdq(i,k) - alpha_up(i,k+1)* + $ omgbdq(i,k+1)) +c print*,'d_deltaqw=',d_deltaqw(i,k) +c +c and increment large scale tendencies +c + +c +C +CC ----------------------------------------------------------------- + d_te(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_Th1(i,k) + $ -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) ) + $ /(Ph(i,k)-Ph(i,k+1)) +ccc nrlmd $ -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*dp_deltomg(i,k) + $ -sigmaw(i)*(1.-sigmaw(i))*dth(i,k) + $ *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1)) +ccc + $ )*ppi(i,k) +c + d_qe(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_q1(i,k) + $ -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) ) + $ /(Ph(i,k)-Ph(i,k+1)) +ccc nrlmd $ -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*dp_deltomg(i,k) + $ -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k) + $ *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1)) +ccc + $ ) +ccc nrlmd + ELSE IF(wk_adv(i) .AND. k .EQ. kupper(i)) THEN + d_te(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_Th1(i,k) + $ /(Ph(i,k)-Ph(i,k+1))) + $ )*ppi(i,k) + + d_qe(i,k) = dtimesub*( + $ ( RRe1(i)*omg(i,k )*sigmaw(i) *D_q1(i,k) + $ /(Ph(i,k)-Ph(i,k+1))) + $ ) + + ENDIF +ccc + ENDDO + ENDDO +c------------------------------------------------------------------ +C +C Increment state variables + + DO k= 1,klev + DO i = 1,klon +ccc nrlmd IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN + IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN +ccc + + +c +c Coefficient de répartition + + 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))/(p(i,1)- + $ ph(i,kupper(i))) + + +c Reintroduce compensating subsidence term. + +c dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)) +c . /(1-sigmaw) +c +c dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k)) +c . /(1-sigmaw) + + dtKE(i,k)=(dtdwn(i,k)/sigmaw(i) - dta(i,k)/(1.-sigmaw(i))) + dqKE(i,k)=(dqdwn(i,k)/sigmaw(i) - dqa(i,k)/(1.-sigmaw(i))) +c print*,'dtKE= ',dtKE(i,k),' dqKE= ',dqKE(i,k) +c + dtPBL(i,k)=(wdtPBL(i,k)/sigmaw(i) - udtPBL(i,k)/(1.-sigmaw(i))) + dqPBL(i,k)=(wdqPBL(i,k)/sigmaw(i) - udqPBL(i,k)/(1.-sigmaw(i))) +c print*,'dtPBL= ',dtPBL(i,k),' dqPBL= ',dqPBL(i,k) +c +ccc nrlmd Prise en compte du taux de mortalité +ccc Définitions de entr, detr + detr(i,k)=0. + + entr(i,k)=detr(i,k)+gfl(i)*cstar(i)+ + $ sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i,k) + + spread(i,k) = (entr(i,k)-detr(i,k))/sigmaw(i) +ccc spread(i,k) = (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/ +ccc $ sigmaw(i) + + +c ajout d'un effet onde de gravité -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) + ff(i)=d_deltatw(i,k)/dtimesub + +c Sans GW +c +c deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) +c +c GW formule 1 +c +c deltatw(k) = deltatw(k)+dtimesub* +c $ (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) +c +c GW formule 2 + + IF (dtimesub*Tgw(i,k).lt.1.e-10) THEN + d_deltatw(i,k) = dtimesub* + $ (ff(i)+dtKE(i,k)+dtPBL(i,k) +ccc $ -spread(i,k)*deltatw(i,k) + $ - entr(i,k)*deltatw(i,k)/sigmaw(i) + $ - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k) + $ / (1.-sigmaw(i)) +ccc + $ -Tgw(i,k)*deltatw(i,k)) + ELSE + d_deltatw(i,k) = 1/Tgw(i,k)*(1-exp(-dtimesub* + $ Tgw(i,k)))* + $ (ff(i)+dtKE(i,k)+dtPBL(i,k) +ccc $ -spread(i,k)*deltatw(i,k) + $ - entr(i,k)*deltatw(i,k)/sigmaw(i) + $ - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k) + $ / (1.-sigmaw(i)) +ccc + $ -Tgw(i,k)*deltatw(i,k)) + ENDIF + + dth(i,k) = deltatw(i,k)/ppi(i,k) + + gg(i)=d_deltaqw(i,k)/dtimesub + + d_deltaqw(i,k) = dtimesub*(gg(i)+ dqKE(i,k)+dqPBL(i,k) +ccc $ -spread(i,k)*deltaqw(i,k)) + $ - entr(i,k)*deltaqw(i,k)/sigmaw(i) + $ - (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k) + $ /(1.-sigmaw(i))) +ccc + +ccc nrlmd +ccc d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k) +ccc d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k) +ccc + ENDIF + ENDDO + ENDDO + +C +C Scale tendencies so that water vapour remains positive in w and x. +C + call wake_vec_modulation(klon,klev,wk_adv,epsilon,qe,d_qe,deltaqw, + $ d_deltaqw,sigmaw,d_sigmaw,alpha) +c +ccc nrlmd +cc print*,'alpha' +cc do i=1,klon +cc print*,alpha(i) +cc end do +ccc + DO k = 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN + d_te(i,k)=alpha(i)*d_te(i,k) + d_qe(i,k)=alpha(i)*d_qe(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) + ENDIF + ENDDO + ENDDO + DO i = 1,klon + IF( wk_adv(i)) THEN + d_sigmaw(i)=alpha(i)*d_sigmaw(i) + ENDIF + ENDDO + +C Update large scale variables and wake variables +cIM 060208 manque DO i + remplace DO k=1,kupper(i) +cIM 060208 DO k = 1,kupper(i) + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN + dtls(i,k)=dtls(i,k)+d_te(i,k) + dqls(i,k)=dqls(i,k)+d_qe(i,k) +ccc 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) +ccc + ENDIF + ENDDO + ENDDO + DO k= 1,klev + DO i = 1,klon + IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN + te(i,k) = te0(i,k) + dtls(i,k) + qe(i,k) = qe0(i,k) + dqls(i,k) + the(i,k) = te(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) +cc print*,'k,qx,qw',k,qe(i,k)-sigmaw(i)*deltaqw(i,k) +cc $ ,qe(i,k)+(1-sigmaw(i))*deltaqw(i,k) + ENDIF + ENDDO + ENDDO + DO i = 1,klon + IF( wk_adv(i)) THEN + sigmaw(i) = sigmaw(i)+d_sigmaw(i) + ENDIF + ENDDO +c +C +c Determine Ptop from buoyancy integral +c --------------------------------------- +c +c- 1/ Pressure of the level where dth changes sign. +c + DO i=1,klon + IF ( wk_adv(i)) THEN + Ptop_provis(i)=ph(i,1) + ENDIF + ENDDO +c + DO k= 2,klev + DO i=1,klon + IF ( wk_adv(i) .AND. + $ Ptop_provis(i) .EQ. ph(i,1) .AND. + $ dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min) THEN + Ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k) + $ - dth(i,k-1)) + ENDIF + ENDDO + ENDDO +c +c- 2/ dth integral +c + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + sum_dth(i) = 0. + dthmin(i) = -delta_t_min + z(i) = 0. + end if + ENDDO + + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + dz(i) = -(amax1(ph(i,k+1),Ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i) + dthmin(i) = amin1(dthmin(i),dth(i,k)) + ENDIF + ENDIF + ENDDO + ENDDO +c +c- 3/ height of triangle with area= sum_dth and base = dthmin + + DO i=1,klon + IF ( wk_adv(i)) THEN + hw(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5) + hw(i) = amax1(hwmin,hw(i)) + ENDIF + ENDDO +c +c- 4/ now, get Ptop +c + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + ktop(i) = 0 + z(i)=0. + end if + ENDDO +c + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i)) THEN + dz(i) = amin1(-(ph(i,k+1)-Ph(i,k))/(rho(i,k)*rg),hw(i)-z(i)) + IF (dz(i) .gt. 0) THEN + z(i) = z(i)+dz(i) + Ptop(i) = Ph(i,k)-rho(i,k)*rg*dz(i) + ktop(i) = k + ENDIF + ENDIF + ENDDO + ENDDO +c +c 4.5/Correct ktop and ptop +c + DO i=1,klon + IF ( wk_adv(i)) THEN + Ptop_new(i)=ptop(i) + ENDIF + ENDDO +c + DO k= klev,2,-1 + DO i=1,klon +cIM v3JYG; IF (k .GE. ktop(i) + IF ( wk_adv(i) .AND. + $ k .LE. ktop(i) .AND. + $ ptop_new(i) .EQ. ptop(i) .AND. + $ dth(i,k) .GT. -delta_t_min .and. + $ dth(i,k-1).LT. -delta_t_min) THEN + Ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) + $ - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k) + $ - dth(i,k-1)) + ENDIF + ENDDO + ENDDO +c +c + DO i=1,klon + IF ( wk_adv(i)) THEN + ptop(i) = ptop_new(i) + ENDIF + ENDDO + + DO k=klev,1,-1 + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + IF (ph(i,k+1) .LT. ptop(i)) ktop(i)=k + end if + ENDDO + ENDDO +c +c 5/ Set deltatw & deltaqw to 0 above kupper +c + DO k = 1,klev + DO i=1,klon + IF ( wk_adv(i) .AND. k .GE. kupper(i)) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + ENDIF + ENDDO + ENDDO +c +C +c-------------Cstar computation--------------------------------- + DO i=1, klon + if (wk_adv(i)) then !!! nrlmd + sum_thu(i) = 0. + sum_tu(i) = 0. + sum_qu(i) = 0. + sum_thvu(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_rho(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thu(i) = 0. + av_tu(i) =0. + av_qu(i) =0. + av_thvu(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_rho(i) =0. + av_dtdwn(i) =0. + av_dqdwn(i) = 0. + end if + ENDDO +C +C Integrals (and wake top level number) +C -------------------------------------- +C +C Initialize sum_thvu to 1st level virt. pot. temp. + + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + z(i) = 1. + dz(i) = 1. + sum_thvu(i) = thu(i,1)*(1.+eps*qu(i,1))*dz(i) + sum_dth(i) = 0. + end if + ENDDO + + 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) .GT. 0) THEN + z(i) = z(i)+dz(i) + sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i) + sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i) + sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i) + sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(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_rho(i) = sum_rho(i) + rhow(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) + ENDIF + end if + ENDDO + ENDDO +c + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + hw0(i) = z(i) + end if + ENDDO +c +C +C - WAPE and mean forcing computation +C --------------------------------------- +C +C --------------------------------------- +C +C Means + + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + av_thu(i) = sum_thu(i)/hw0(i) + av_tu(i) = sum_tu(i)/hw0(i) + av_qu(i) = sum_qu(i)/hw0(i) + av_thvu(i) = sum_thvu(i)/hw0(i) + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_rho(i) = sum_rho(i)/hw0(i) + av_dtdwn(i) = sum_dtdwn(i)/hw0(i) + av_dqdwn(i) = sum_dqdwn(i)/hw0(i) +c + wape(i) = - rg*hw0(i)*(av_dth(i) + $ + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)* + $ av_dq(i) ))/av_thvu(i) + end if + ENDDO +C +C Filter out bad wakes + + DO k = 1,klev + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + IF ( wape(i) .LT. 0.) THEN + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + dth(i,k) = 0. + ENDIF + end if + ENDDO + ENDDO +c + DO i=1,klon + if (wk_adv(i)) then !!! nrlmd + IF ( wape(i) .LT. 0.) THEN + wape(i) = 0. + Cstar(i) = 0. + hw(i) = hwmin + sigmaw(i) = max(sigmad,sigd_con(i)) + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + Cstar(i) = stark*sqrt(2.*wape(i)) + gwake(i) = .TRUE. + ENDIF + end if + ENDDO + + ENDDO ! end sub-timestep loop +C +C ----------------------------------------------------------------- +c Get back to tendencies per second +c + DO k = 1,klev + DO i=1,klon + +ccc nrlmd IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN + IF ( OK_qx_qw(i) .AND. k .LE. kupper(i)) THEN +ccc + 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 +cc print*,'k,dqls,omg,entr,detr',k,dqls(i,k),omg(i,k),entr(i,k) +cc $ ,death_rate(i)*sigmaw(i) + ENDIF + ENDDO + ENDDO + +c +c---------------------------------------------------------- +c Determine wake final state; recompute wape, cstar, ktop; +c filter out bad wakes. +c---------------------------------------------------------- +c +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + DO i=1,klon +ccc nrlmd if (wk_adv(i)) then !!! nrlmd + if (OK_qx_qw(i)) then +ccc + z(i) = 0. + sum_thu(i) = 0. + sum_tu(i) = 0. + sum_qu(i) = 0. + sum_thvu(i) = 0. + sum_dth(i) = 0. + sum_dq(i) = 0. + sum_rho(i) = 0. + sum_dtdwn(i) = 0. + sum_dqdwn(i) = 0. + + av_thu(i) = 0. + av_tu(i) =0. + av_qu(i) =0. + av_thvu(i) = 0. + av_dth(i) = 0. + av_dq(i) = 0. + av_rho(i) =0. + av_dtdwn(i) =0. + av_dqdwn(i) = 0. + end if + ENDDO +C Potential temperatures and humidity +c---------------------------------------------------------- + + DO k =1,klev + DO i=1,klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + rho(i,k) = p(i,k)/(rd*te(i,k)) + IF(k .eq. 1) THEN + rhoh(i,k) = ph(i,k)/(rd*te(i,k)) + zhh(i,k)=0 + ELSE + rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1))) + zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1) + ENDIF + the(i,k) = te(i,k)/ppi(i,k) + thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k) + tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i) + qu(i,k) = qe(i,k) - deltaqw(i,k)*sigmaw(i) + rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k))) + dth(i,k) = deltatw(i,k)/ppi(i,k) + ENDIF + ENDDO + ENDDO + +C Integrals (and wake top level number) +C ----------------------------------------------------------- + +C Initialize sum_thvu to 1st level virt. pot. temp. + + DO i=1,klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + z(i) = 1. + dz(i) = 1. + sum_thvu(i) = thu(i,1)*(1.+eps*qu(i,1))*dz(i) + sum_dth(i) = 0. + ENDIF + ENDDO + + DO k = 1,klev + DO i=1,klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg) + IF (dz(i) .GT. 0) THEN + z(i) = z(i)+dz(i) + sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i) + sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i) + sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i) + sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(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_rho(i) = sum_rho(i) + rhow(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) + ENDIF + ENDIF + ENDDO + ENDDO +c + DO i=1,klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + hw0(i) = z(i) + ENDIF + ENDDO +c +C - WAPE and mean forcing computation +C------------------------------------------------------------- + +C Means + + DO i=1, klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + av_thu(i) = sum_thu(i)/hw0(i) + av_tu(i) = sum_tu(i)/hw0(i) + av_qu(i) = sum_qu(i)/hw0(i) + av_thvu(i) = sum_thvu(i)/hw0(i) + av_dth(i) = sum_dth(i)/hw0(i) + av_dq(i) = sum_dq(i)/hw0(i) + av_rho(i) = sum_rho(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) + $ + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i) + $ + av_dth(i)*av_dq(i) ))/av_thvu(i) + ENDIF + ENDDO + +C Prognostic variable update +C ------------------------------------------------------------ + +C Filter out bad wakes +c + DO k = 1,klev + DO i=1,klon +ccc nrlmd IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN + if (OK_qx_qw(i) .AND. wape2(i) .LT. 0.) then +ccc + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + dth(i,k) = 0. + ENDIF + ENDDO + ENDDO +c + + DO i=1, klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + IF ( wape2(i) .LT. 0.) THEN + wape2(i) = 0. + Cstar2(i) = 0. + hw(i) = hwmin + sigmaw(i) = amax1(sigmad,sigd_con(i)) + fip(i) = 0. + gwake(i) = .FALSE. + ELSE + if(prt_level.ge.10) print*,'wape2>0' + Cstar2(i) = stark*sqrt(2.*wape2(i)) + gwake(i) = .TRUE. + ENDIF + ENDIF + ENDDO +c + DO i=1, klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + ktopw(i) = ktop(i) + ENDIF + ENDDO +c + DO i=1, klon +ccc nrlmd IF ( wk_adv(i)) THEN + if (OK_qx_qw(i)) then +ccc + IF (ktopw(i) .gt. 0 .and. gwake(i)) then + +Cjyg1 Utilisation d'un h_efficace constant ( ~ feeding layer) +ccc heff = 600. +C Utilisation de la hauteur hw +cc 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) +Cjyg2 + ELSE + FIP(i) = 0. + ENDIF + ENDIF + ENDDO +c +C Limitation de sigmaw + +ccc nrlmd +c DO i=1,klon +c IF (OK_qx_qw(i)) THEN +c IF (sigmaw(i).GE.sigmaw_max) sigmaw(i)=sigmaw_max +c ENDIF +c ENDDO +ccc + DO k = 1,klev + DO i=1, klon + +ccc nrlmd On maintient désormais constant sigmaw en régime permanent +ccc IF ((sigmaw(i).GT.sigmaw_max).or. + IF ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or. + $ (ktopw(i).le.2) .OR. + $ .not. OK_qx_qw(i) ) THEN +ccc + dtls(i,k) = 0. + dqls(i,k) = 0. + deltatw(i,k) = 0. + deltaqw(i,k) = 0. + ENDIF + ENDDO + ENDDO +c +ccc nrlmd On maintient désormais constant sigmaw en régime permanent + DO i=1, klon + IF ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or. + $ (ktopw(i).le.2) .OR. + $ .not. OK_qx_qw(i) ) THEN + wape(i) = 0. + cstar(i)=0. + hw(i) = hwmin + sigmaw(i) = sigmad + fip(i) = 0. + ELSE + wape(i) = wape2(i) + cstar(i)=cstar2(i) + ENDIF +cc print*,'wape wape2 ktopw OK_qx_qw =', +cc $ wape(i),wape2(i),ktopw(i),OK_qx_qw(i) + ENDDO +c +c + RETURN + END + + SUBROUTINE wake_vec_modulation(nlon,nl,wk_adv,epsilon,qe,d_qe, + $ deltaqw,d_deltaqw,sigmaw,d_sigmaw,alpha) +c------------------------------------------------------ +cDtermination du coefficient alpha tel que les tendances +c corriges alpha*d_G, pour toutes les grandeurs G, correspondent +c a une humidite positive dans la zone (x) et dans la zone (w). +c------------------------------------------------------ +c + +c Input + REAL qe(nlon,nl),d_qe(nlon,nl) + REAL deltaqw(nlon,nl),d_deltaqw(nlon,nl) + REAL sigmaw(nlon),d_sigmaw(nlon) + LOGICAL wk_adv(nlon) + INTEGER nl,nlon +c Output + REAL alpha(nlon) +c Internal variables + REAL zeta(nlon,nl) + REAL alpha1(nlon) + REAL x,a,b,c,discrim + REAL epsilon +! DATA epsilon/1.e-15/ +c + DO k=1,nl + DO i = 1,nlon + IF (wk_adv(i)) THEN + IF ((deltaqw(i,k)+d_deltaqw(i,k)).ge.0.) then + zeta(i,k)=0. + ELSE + zeta(i,k)=1. + END IF + ENDIF + ENDDO + DO i = 1,nlon + IF (wk_adv(i)) THEN + x = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k) + $ + d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k) + $ - d_sigmaw(i)*(deltaqw(i,k)+d_deltaqw(i,k)) + a = -d_sigmaw(i)*d_deltaqw(i,k) + b = d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k) + $ - deltaqw(i,k)*d_sigmaw(i) + c = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k)+epsilon + discrim = b*b-4.*a*c +c print*, 'x, a, b, c, discrim', x, a, b, c, discrim + IF (a+b .GE. 0.) THEN !! Condition suffisante pour la positivité de ovap + alpha1(i)=1. + ELSE + IF (x .GE. 0.) THEN + alpha1(i)=1. + ELSE + IF (a .GT. 0.) THEN + alpha1(i)=0.9*min( (2.*c)/(-b+sqrt(discrim)), + $ (-b+sqrt(discrim))/(2.*a) ) + ELSE IF (a .eq. 0.) then + alpha1(i)=0.9*(-c/b) + ELSE +c print*,'a,b,c discrim',a,b,c discrim + alpha1(i)=0.9*max( (2.*c)/(-b+sqrt(discrim)), + $ (-b+sqrt(discrim))/(2.*a) ) + ENDIF + ENDIF + ENDIF + alpha(i) = min(alpha(i),alpha1(i)) + ENDIF + ENDDO + ENDDO +! + return + end + + Subroutine WAKE_scal (p,ph,ppi,dtime,sigd_con + : ,te0,qe0,omgb + : ,dtdwn,dqdwn,amdwn,amup,dta,dqa + : ,wdtPBL,wdqPBL,udtPBL,udqPBL + o ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl + o ,dtls,dqls + o ,ktopw,omgbdth,dp_omgb,wdens + o ,tu,qu + o ,dtKE,dqKE + o ,dtPBL,dqPBL + o ,omg,dp_deltomg,spread + o ,Cstar,d_deltat_gw + o ,d_deltatw2,d_deltaqw2) + +*************************************************************** +* * +* WAKE * +* retour a un Pupper fixe * +* * +* written by : GRANDPEIX Jean-Yves 09/03/2000 * +* modified by : ROEHRIG Romain 01/29/2007 * +*************************************************************** +c + USE dimphy + IMPLICIT none +c============================================================================ +C +C +C But : Decrire le comportement des poches froides apparaissant dans les +C grands systemes convectifs, et fournir l'energie disponible pour +C le declenchement de nouvelles colonnes convectives. +C +C Variables d'etat : deltatw : ecart de temperature wake-undisturbed area +C deltaqw : ecart d'humidite wake-undisturbed area +C sigmaw : fraction d'aire occupee par la poche. +C +C Variable de sortie : +c +c wape : WAke Potential Energy +c fip : Front Incident Power (W/m2) - ALP +c gfl : Gust Front Length per unit area (m-1) +C dtls : large scale temperature tendency due to wake +C dqls : large scale humidity tendency due to wake +C hw : hauteur de la poche +C dp_omgb : vertical gradient of large scale omega +C omgbdth: flux of Delta_Theta transported by LS omega +C dtKE : differential heating (wake - unpertubed) +C dqKE : differential moistening (wake - unpertubed) +C omg : Delta_omg =vertical velocity diff. wake-undist. (Pa/s) +C dp_deltomg : vertical gradient of omg (s-1) +C spread : spreading term in dt_wake and dq_wake +C deltatw : updated temperature difference (T_w-T_u). +C deltaqw : updated humidity difference (q_w-q_u). +C sigmaw : updated wake fractional area. +C d_deltat_gw : delta T tendency due to GW +c +C Variables d'entree : +c +c aire : aire de la maille +c te0 : temperature dans l'environnement (K) +C qe0 : humidite dans l'environnement (kg/kg) +C omgb : vitesse verticale moyenne sur la maille (Pa/s) +C dtdwn: source de chaleur due aux descentes (K/s) +C dqdwn: source d'humidite due aux descentes (kg/kg/s) +C dta : source de chaleur due courants satures et detrain (K/s) +C dqa : source d'humidite due aux courants satures et detra (kg/kg/s) +C amdwn: flux de masse total des descentes, par unite de +C surface de la maille (kg/m2/s) +C amup : flux de masse total des ascendances, par unite de +C surface de la maille (kg/m2/s) +C p : pressions aux milieux des couches (Pa) +C ph : pressions aux interfaces (Pa) +C ppi : (p/p_0)**kapa (adim) +C dtime: increment temporel (s) +c +C Variables internes : +c +c rhow : masse volumique de la poche froide +C rho : environment density at P levels +C rhoh : environment density at Ph levels +C te : environment temperature | may change within +C qe : environment humidity | sub-time-stepping +C the : environment potential temperature +C thu : potential temperature in undisturbed area +C tu : temperature in undisturbed area +C qu : humidity in undisturbed area +C dp_omgb: vertical gradient og LS omega +C omgbw : wake average vertical omega +C dp_omgbw: vertical gradient of omgbw +C omgbdq : flux of Delta_q transported by LS omega +C dth : potential temperature diff. wake-undist. +C th1 : first pot. temp. for vertical advection (=thu) +C th2 : second pot. temp. for vertical advection (=thw) +C q1 : first humidity for vertical advection +C q2 : second humidity for vertical advection +C d_deltatw : terme de redistribution pour deltatw +C d_deltaqw : terme de redistribution pour deltaqw +C deltatw0 : deltatw initial +C deltaqw0 : deltaqw initial +C hw0 : hw initial +C sigmaw0: sigmaw initial +C amflux : horizontal mass flux through wake boundary +C wdens : number of wakes per unit area (3D) or per +C unit length (2D) +C Tgw : 1 sur la période de onde de gravité +c Cgw : vitesse de propagation de onde de gravité +c LL : distance entre 2 poches + +c------------------------------------------------------------------------- +c Déclaration de variables +c------------------------------------------------------------------------- + +#include "dimensions.h" +cccc#include "dimphy.h" +#include "YOMCST.h" +#include "cvthermo.h" +#include "iniprint.h" + +c Arguments en entree +c-------------------- + + REAL p(klev),ph(klev+1),ppi(klev) + REAL dtime + REAL te0(klev),qe0(klev) + REAL omgb(klev+1) + REAL dtdwn(klev), dqdwn(klev) + REAL wdtPBL(klev),wdqPBL(klev) + REAL udtPBL(klev),udqPBL(klev) + REAL amdwn(klev), amup(klev) + REAL dta(klev), dqa(klev) + REAL sigd_con + +c Sorties +c-------- + + REAL deltatw(klev), deltaqw(klev), dth(klev) + REAL tu(klev), qu(klev) + REAL dtls(klev), dqls(klev) + REAL dtKE(klev), dqKE(klev) + REAL dtPBL(klev), dqPBL(klev) + REAL spread(klev) + REAL d_deltatgw(klev) + REAL d_deltatw2(klev), d_deltaqw2(klev) + REAL omgbdth(klev+1), omg(klev+1) + REAL dp_omgb(klev), dp_deltomg(klev) + REAL d_deltat_gw(klev) + REAL hw, sigmaw, wape, fip, gfl, Cstar + INTEGER ktopw + +c Variables internes +c------------------- + +c Variables à fixer + REAL ALON + REAL coefgw + REAL wdens0, wdens + REAL stark + REAL alpk + REAL delta_t_min + REAL Pupper + INTEGER nsub + REAL dtimesub + REAL sigmad, hwmin + +c Variables de sauvegarde + REAL deltatw0(klev) + REAL deltaqw0(klev) + REAL te(klev), qe(klev) + REAL sigmaw0, sigmaw1 + +c Variables pour les GW + REAL LL + REAL N2(klev) + REAL Cgw(klev) + REAL Tgw(klev) + +c Variables liées au calcul de hw + REAL ptop_provis, ptop, ptop_new + REAL sum_dth + REAL dthmin + REAL z, dz, hw0 + INTEGER ktop, kupper + +c Autres variables internes + INTEGER isubstep, k + + REAL sum_thu, sum_tu, sum_qu,sum_thvu + REAL sum_dq, sum_rho + REAL sum_dtdwn, sum_dqdwn + REAL av_thu, av_tu, av_qu, av_thvu + REAL av_dth, av_dq, av_rho + REAL av_dtdwn, av_dqdwn + + REAL rho(klev), rhoh(klev+1), rhow(klev) + REAL rhow_moyen(klev) + REAL zh(klev), zhh(klev+1) + REAL epaisseur1(klev), epaisseur2(klev) + + REAL the(klev), thu(klev) + + REAL d_deltatw(klev), d_deltaqw(klev) + + REAL omgbw(klev+1), omgtop + REAL dp_omgbw(klev) + REAL ztop, dztop + REAL alpha_up(klev) + + REAL RRe1, RRe2, RRd1, RRd2 + REAL Th1(klev), Th2(klev), q1(klev), q2(klev) + REAL D_Th1(klev), D_Th2(klev), D_dth(klev) + REAL D_q1(klev), D_q2(klev), D_dq(klev) + REAL omgbdq(klev) + + REAL ff, gg + REAL wape2, Cstar2, heff + + REAL Crep(klev) + REAL Crep_upper, Crep_sol + +C------------------------------------------------------------------------- +c Initialisations +c------------------------------------------------------------------------- + +c print*, 'wake initialisations' + +c Essais d'initialisation avec sigmaw = 0.02 et hw = 10. +c------------------------------------------------------------------------- + + DATA sigmad, hwmin /.02,10./ + +C Longueur de maille (en m) +c------------------------------------------------------------------------- + +c ALON = 3.e5 + ALON = 1.e6 + + +C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei) +c +c coefgw : Coefficient pour les ondes de gravité +c stark : Coefficient k dans Cstar=k*sqrt(2*WAPE) +c wdens : Densité de poche froide par maille +c------------------------------------------------------------------------- + + coefgw=10 +c coefgw=1 +c wdens0 = 1.0/(alon**2) + wdens = 1.0/(alon**2) + stark = 0.50 +cCRtest + alpk=0.1 +c alpk = 1.0 +c alpk = 0.5 +c alpk = 0.05 + Crep_upper=0.9 + Crep_sol=1.0 + + +C Minimum value for |T_wake - T_undist|. Used for wake top definition +c------------------------------------------------------------------------- + + delta_t_min = 0.2 + + +C 1. - Save initial values and initialize tendencies +C -------------------------------------------------- + + DO k=1,klev + deltatw0(k) = deltatw(k) + deltaqw0(k)= deltaqw(k) + te(k) = te0(k) + qe(k) = qe0(k) + dtls(k) = 0. + dqls(k) = 0. + d_deltat_gw(k)=0. + d_deltatw2(k)=0. + d_deltaqw2(k)=0. + ENDDO +c sigmaw1=sigmaw +c IF (sigd_con.GT.sigmaw1) THEN +c print*, 'sigmaw,sigd_con', sigmaw, sigd_con +c ENDIF + sigmaw = max(sigmaw,sigd_con) + sigmaw = max(sigmaw,sigmad) + sigmaw = min(sigmaw,0.99) + sigmaw0 = sigmaw +c wdens=wdens0/(10.*sigmaw) +c IF (sigd_con.GT.sigmaw1) THEN +c print*, 'sigmaw1,sigd1', sigmaw, sigd_con +c ENDIF + +C 2. - Prognostic part +C ========================================================= + +c print *, 'prognostic wake computation' + + +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + z = 0. + ktop=0 + kupper = 0 + sum_thu = 0. + sum_tu = 0. + sum_qu = 0. + sum_thvu = 0. + sum_dth = 0. + sum_dq = 0. + sum_rho = 0. + sum_dtdwn = 0. + sum_dqdwn = 0. + + av_thu = 0. + av_tu =0. + av_qu =0. + av_thvu = 0. + av_dth = 0. + av_dq = 0. + av_rho =0. + av_dtdwn =0. + av_dqdwn = 0. + +C Potential temperatures and humidity +c---------------------------------------------------------- + + DO k =1,klev + rho(k) = p(k)/(rd*te(k)) + IF(k .eq. 1) THEN + rhoh(k) = ph(k)/(rd*te(k)) + zhh(k)=0 + ELSE + rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1))) + zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1) + ENDIF + the(k) = te(k)/ppi(k) + thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k) + tu(k) = te(k) - deltatw(k)*sigmaw + qu(k) = qe(k) - deltaqw(k)*sigmaw + rhow(k) = p(k)/(rd*(te(k)+deltatw(k))) + dth(k) = deltatw(k)/ppi(k) + LL = (1-sqrt(sigmaw))/sqrt(wdens) + ENDDO + + DO k = 1, klev-1 + IF(k.eq.1) THEN + N2(k)=0 + ELSE + N2(k)=max(0.,-RG**2/the(k)*rho(k)*(the(k+1)-the(k-1)) + $ /(p(k+1)-p(k-1))) + ENDIF + ZH(k)=(zhh(k)+zhh(k+1))/2 + + Cgw(k)=sqrt(N2(k))*ZH(k) + Tgw(k)=coefgw*Cgw(k)/LL + ENDDO + + N2(klev)=0 + ZH(klev)=0 + Cgw(klev)=0 + Tgw(klev)=0 + +c Calcul de la masse volumique moyenne de la colonne +c----------------------------------------------------------------- + + DO k=1,klev + epaisseur1(k)=0. + epaisseur2(k)=0. + ENDDO + + epaisseur1(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1. + epaisseur2(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1. + rhow_moyen(1) = rhow(1) + + DO k = 2, klev + epaisseur1(k)= -(Ph(k+1)-Ph(k))/(rho(k)*rg) +1. + epaisseur2(k)=epaisseur2(k-1)+epaisseur1(k) + rhow_moyen(k) = (rhow_moyen(k-1)*epaisseur2(k-1)+ + $ rhow(k)*epaisseur1(k))/epaisseur2(k) + ENDDO + + +C Choose an integration bound well above wake top +c----------------------------------------------------------------- + +c Pupper = 50000. ! melting level + Pupper = 60000. +c Pupper = 70000. + + +C Determine Wake top pressure (Ptop) from buoyancy integral +C----------------------------------------------------------------- + +c-1/ Pressure of the level where dth becomes less than delta_t_min. + + Ptop_provis=ph(1) + DO k= 2,klev + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_provis = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 25 + ENDIF + ENDDO +25 CONTINUE + +c-2/ dth integral + + sum_dth = 0. + dthmin = -delta_t_min + z = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg) + IF (dz .le. 0) GO TO 40 + z = z+dz + sum_dth = sum_dth + dth(k)*dz + dthmin = min(dthmin,dth(k)) + ENDDO +40 CONTINUE + +c-3/ height of triangle with area= sum_dth and base = dthmin + + hw0 = 2.*sum_dth/min(dthmin,-0.5) + hw0 = max(hwmin,hw0) + +c-4/ now, get Ptop + + z = 0. + ptop = ph(1) + + DO k = 1,klev + dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw0-z) + IF (dz .le. 0) GO TO 45 + z = z+dz + Ptop = Ph(k)-rho(k)*rg*dz + ENDDO +45 CONTINUE + + +C-5/ Determination de ktop et kupper + + DO k=klev,1,-1 + IF (ph(k+1) .lt. ptop) ktop=k + IF (ph(k+1) .lt. pupper) kupper=k + ENDDO + +c-6/ Correct ktop and ptop + + Ptop_new=ptop + DO k= ktop,2,-1 + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_new = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 225 + ENDIF + ENDDO +225 CONTINUE + + ptop = ptop_new + + DO k=klev,1,-1 + IF (ph(k+1) .lt. ptop) ktop=k + ENDDO + +c Set deltatw & deltaqw to 0 above kupper +c----------------------------------------------------------- + + DO k = kupper,klev + deltatw(k) = 0. + deltaqw(k) = 0. + ENDDO + + +C Vertical gradient of LS omega +C------------------------------------------------------------ + + DO k = 1,kupper + dp_omgb(k) = (omgb(k+1) - omgb(k))/(ph(k+1)-ph(k)) + ENDDO + + +C Integrals (and wake top level number) +C ----------------------------------------------------------- + +C Initialize sum_thvu to 1st level virt. pot. temp. + + z = 1. + dz = 1. + sum_thvu = thu(1)*(1.+eps*qu(1))*dz + sum_dth = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg) + IF (dz .LE. 0) GO TO 50 + z = z+dz + sum_thu = sum_thu + thu(k)*dz + sum_tu = sum_tu + tu(k)*dz + sum_qu = sum_qu + qu(k)*dz + sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz + sum_dth = sum_dth + dth(k)*dz + sum_dq = sum_dq + deltaqw(k)*dz + sum_rho = sum_rho + rhow(k)*dz + sum_dtdwn = sum_dtdwn + dtdwn(k)*dz + sum_dqdwn = sum_dqdwn + dqdwn(k)*dz + ENDDO +50 CONTINUE + + hw0 = z + +C 2.1 - WAPE and mean forcing computation +C------------------------------------------------------------- + +C Means + + av_thu = sum_thu/hw0 + av_tu = sum_tu/hw0 + av_qu = sum_qu/hw0 + av_thvu = sum_thvu/hw0 +c av_thve = sum_thve/hw0 + av_dth = sum_dth/hw0 + av_dq = sum_dq/hw0 + av_rho = sum_rho/hw0 + av_dtdwn = sum_dtdwn/hw0 + av_dqdwn = sum_dqdwn/hw0 + + wape = - rg*hw0*(av_dth + $ + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu + +C 2.2 Prognostic variable update +C ------------------------------------------------------------ + +C Filter out bad wakes + + IF ( wape .LT. 0.) THEN + if(prt_level.ge.10) print*,'wape<0' + wape = 0. + hw = hwmin + sigmaw = max(sigmad,sigd_con) + fip = 0. + DO k = 1,klev + deltatw(k) = 0. + deltaqw(k) = 0. + dth(k) = 0. + ENDDO + ELSE + if(prt_level.ge.10) print*,'wape>0' + Cstar = stark*sqrt(2.*wape) + ENDIF + +C------------------------------------------------------------------ +C Sub-time-stepping +C------------------------------------------------------------------ + +c nsub=36 + nsub=10 + dtimesub=dtime/nsub + +c------------------------------------------------------------ + DO isubstep = 1,nsub +c------------------------------------------------------------ + +c print*,'---------------','substep=',isubstep,'-------------' + +c Evolution of sigmaw + + + gfl = 2.*sqrt(3.14*wdens*sigmaw) + + sigmaw =sigmaw + gfl*Cstar*dtimesub + sigmaw =min(sigmaw,0.99) !!!!!!!! +c wdens = wdens0/(10.*sigmaw) +c sigmaw =max(sigmaw,sigd_con) +c sigmaw =max(sigmaw,sigmad) + +c calcul de la difference de vitesse verticale poche - zone non perturbee + + z= 0. + dp_deltomg(1:klev)=0. + omg(1:klev+1)=0. + + omg(1) = 0. + dp_deltomg(1) = -(gfl*Cstar)/(sigmaw * (1-sigmaw)) + + DO k=2,ktop + dz = -(Ph(k)-Ph(k-1))/(rho(k-1)*rg) + z = z+dz + dp_deltomg(k)= dp_deltomg(1) + omg(k)= dp_deltomg(1)*z + ENDDO + + dztop=-(Ptop-Ph(ktop))/(rho(ktop)*rg) + ztop = z+dztop + omgtop=dp_deltomg(1)*ztop + + +c Conversion de la vitesse verticale de m/s a Pa/s + + omgtop = -rho(ktop)*rg*omgtop + dp_deltomg(1) = omgtop/(ptop-ph(1)) + + DO k = 1,ktop + omg(k) = - rho(k)*rg*omg(k) + dp_deltomg(k) = dp_deltomg(1) + ENDDO + +c raccordement lineaire de omg de ptop a pupper + + IF (kupper .GT. ktop) THEN + omg(kupper+1) = - Rg*amdwn(kupper+1)/sigmaw + $ + Rg*amup(kupper+1)/(1.-sigmaw) + dp_deltomg(kupper) = (omgtop-omg(kupper+1))/(Ptop-Pupper) + DO k=ktop+1,kupper + dp_deltomg(k) = dp_deltomg(kupper) + omg(k) = omgtop+(ph(k)-Ptop)*dp_deltomg(kupper) + ENDDO + ENDIF + +c Compute wake average vertical velocity omgbw + + DO k = 1,klev+1 + omgbw(k) = omgb(k)+(1.-sigmaw)*omg(k) + ENDDO + +c and its vertical gradient dp_omgbw + + DO k = 1,klev + dp_omgbw(k) = (omgbw(k+1)-omgbw(k))/(ph(k+1)-ph(k)) + ENDDO + + +c Upstream coefficients for omgb velocity +c-- (alpha_up(k) is the coefficient of the value at level k) +c-- (1-alpha_up(k) is the coefficient of the value at level k-1) + + DO k = 1,klev + alpha_up(k) = 0. + IF (omgb(k) .GT. 0.) alpha_up(k) = 1. + ENDDO + +c Matrix expressing [The,deltatw] from [Th1,Th2] + + RRe1 = 1.-sigmaw + RRe2 = sigmaw + RRd1 = -1. + RRd2 = 1. + +c Get [Th1,Th2], dth and [q1,q2] + + DO k = 1,kupper+1 + dth(k) = deltatw(k)/ppi(k) + Th1(k) = the(k) - sigmaw *dth(k) ! undisturbed area + Th2(k) = the(k) + (1.-sigmaw)*dth(k) ! wake + q1(k) = qe(k) - sigmaw *deltaqw(k) ! undisturbed area + q2(k) = qe(k) + (1.-sigmaw)*deltaqw(k) ! wake + ENDDO + + D_Th1(1) = 0. + D_Th2(1) = 0. + D_dth(1) = 0. + D_q1(1) = 0. + D_q2(1) = 0. + D_dq(1) = 0. + + DO k = 2,kupper+1 ! loop on interfaces + D_Th1(k) = Th1(k-1)-Th1(k) + D_Th2(k) = Th2(k-1)-Th2(k) + D_dth(k) = dth(k-1)-dth(k) + D_q1(k) = q1(k-1)-q1(k) + D_q2(k) = q2(k-1)-q2(k) + D_dq(k) = deltaqw(k-1)-deltaqw(k) + ENDDO + + omgbdth(1) = 0. + omgbdq(1) = 0. + + DO k = 2,kupper+1 ! loop on interfaces + omgbdth(k) = omgb(k)*( dth(k-1) - dth(k)) + omgbdq(k) = omgb(k)*(deltaqw(k-1) - deltaqw(k)) + ENDDO + + +c----------------------------------------------------------------- + DO k=1,kupper-1 +c----------------------------------------------------------------- +c +c Compute redistribution (advective) term +c + d_deltatw(k) = + $ dtimesub/(Ph(k)-Ph(k+1))*( + $ RRd1*omg(k )*sigmaw *D_Th1(k) + $ -RRd2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1) + $ -(1.-alpha_up(k))*omgbdth(k) - alpha_up(k+1)*omgbdth(k+1) + $ )*ppi(k) +c print*,'d_deltatw=',d_deltatw(k) +c + d_deltaqw(k) = + $ dtimesub/(Ph(k)-Ph(k+1))*( + $ RRd1*omg(k )*sigmaw *D_q1(k) + $ -RRd2*omg(k+1)*(1.-sigmaw)*D_q2(k+1) + $ -(1.-alpha_up(k))*omgbdq(k) - alpha_up(k+1)*omgbdq(k+1) + $ ) +c print*,'d_deltaqw=',d_deltaqw(k) +c +c and increment large scale tendencies +c + dtls(k) = dtls(k) + + $ dtimesub*( + $ ( RRe1*omg(k )*sigmaw *D_Th1(k) + $ -RRe2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1) ) + $ /(Ph(k)-Ph(k+1)) + $ -sigmaw*(1.-sigmaw)*dth(k)*dp_deltomg(k) + $ )*ppi(k) +c print*,'dtls=',dtls(k) +c + dqls(k) = dqls(k) + + $ dtimesub*( + $ ( RRe1*omg(k )*sigmaw *D_q1(k) + $ -RRe2*omg(k+1)*(1.-sigmaw)*D_q2(k+1) ) + $ /(Ph(k)-Ph(k+1)) + $ -sigmaw*(1.-sigmaw)*deltaqw(k)*dp_deltomg(k) + $ ) +c print*,'dqls=',dqls(k) + +c------------------------------------------------------------------- + ENDDO +c------------------------------------------------------------------ + +C Increment state variables + + DO k = 1,kupper-1 + +c Coefficient de répartition + + Crep(k)=Crep_sol*(ph(kupper)-ph(k))/(ph(kupper)-ph(1)) + Crep(k)=Crep(k)+Crep_upper*(ph(1)-ph(k))/(p(1)-ph(kupper)) + + +c Reintroduce compensating subsidence term. + +c dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)) +c . /(1-sigmaw) +c +c dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw +c dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k)) +c . /(1-sigmaw) +c dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw +c dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k)) +c . /(1-sigmaw) + + dtKE(k)=(dtdwn(k)/sigmaw - dta(k)/(1.-sigmaw)) + dqKE(k)=(dqdwn(k)/sigmaw - dqa(k)/(1.-sigmaw)) +c print*,'dtKE=',dtKE(k) +c print*,'dqKE=',dqKE(k) +c + dtPBL(k)=(wdtPBL(k)/sigmaw - udtPBL(k)/(1.-sigmaw)) + dqPBL(k)=(wdqPBL(k)/sigmaw - udqPBL(k)/(1.-sigmaw)) +c + spread(k) = (1.-sigmaw)*dp_deltomg(k)+gfl*Cstar/sigmaw +c print*,'spread=',spread(k) + + +c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei + + d_deltat_gw(k)=d_deltat_gw(k)-Tgw(k)*deltatw(k)* dtimesub +c print*,'d_delta_gw=',d_deltat_gw(k) + ff=d_deltatw(k)/dtimesub + +c Sans GW +c +c deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) +c +c GW formule 1 +c +c deltatw(k) = deltatw(k)+dtimesub* +c $ (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) +c +c GW formule 2 + + IF (dtimesub*Tgw(k).lt.1.e-10) THEN + deltatw(k) = deltatw(k)+dtimesub* + $ (ff+dtKE(k)+dtPBL(k) + $ - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) + ELSE + deltatw(k) = deltatw(k)+1/Tgw(k)*(1-exp(-dtimesub*Tgw(k)))* + $ (ff+dtKE(k)+dtPBL(k) + $ - spread(k)*deltatw(k)-Tgw(k)*deltatw(k)) + ENDIF + + dth(k) = deltatw(k)/ppi(k) + + gg=d_deltaqw(k)/dtimesub + + deltaqw(k) = deltaqw(k) + + $ dtimesub*(gg+ dqKE(k)+dqPBL(k) - spread(k)*deltaqw(k)) + + d_deltatw2(k)=d_deltatw2(k)+d_deltatw(k) + d_deltaqw2(k)=d_deltaqw2(k)+d_deltaqw(k) + ENDDO + +C And update large scale variables + + DO k = 1,kupper + te(k) = te0(k) + dtls(k) + qe(k) = qe0(k) + dqls(k) + the(k) = te(k)/ppi(k) + ENDDO + +c Determine Ptop from buoyancy integral +c---------------------------------------------------------------------- + +c-1/ Pressure of the level where dth changes sign. + + Ptop_provis=ph(1) + + DO k= 2,klev + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_provis = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 65 + ENDIF + ENDDO +65 CONTINUE + +c-2/ dth integral + + sum_dth = 0. + dthmin = -delta_t_min + z = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg) + IF (dz .le. 0) GO TO 70 + z = z+dz + sum_dth = sum_dth + dth(k)*dz + dthmin = min(dthmin,dth(k)) + ENDDO +70 CONTINUE + +c-3/ height of triangle with area= sum_dth and base = dthmin + + hw = 2.*sum_dth/min(dthmin,-0.5) + hw = max(hwmin,hw) + +c-4/ now, get Ptop + + ktop = 0 + z=0. + + DO k = 1,klev + dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw-z) + IF (dz .le. 0) GO TO 75 + z = z+dz + Ptop = Ph(k)-rho(k)*rg*dz + ktop = k + ENDDO +75 CONTINUE + +c-5/Correct ktop and ptop + + Ptop_new=ptop + + DO k= ktop,2,-1 + IF (dth(k) .GT. -delta_t_min .and. + $ dth(k-1).LT. -delta_t_min) THEN + Ptop_new = ((dth(k)+delta_t_min)*p(k-1) + $ - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1)) + GO TO 275 + ENDIF + ENDDO +275 CONTINUE + + ptop = ptop_new + + DO k=klev,1,-1 + IF (ph(k+1) .LT. ptop) ktop=k + ENDDO + +c-6/ Set deltatw & deltaqw to 0 above kupper + + DO k = kupper,klev + deltatw(k) = 0. + deltaqw(k) = 0. + ENDDO + +c------------------------------------------------------------------ + ENDDO ! end sub-timestep loop +C ----------------------------------------------------------------- + +c Get back to tendencies per second + + DO k = 1,kupper-1 + dtls(k) = dtls(k)/dtime + dqls(k) = dqls(k)/dtime + d_deltatw2(k)=d_deltatw2(k)/dtime + d_deltaqw2(k)=d_deltaqw2(k)/dtime + d_deltat_gw(k) = d_deltat_gw(k)/dtime + ENDDO + +C 2.1 - Undisturbed area and Wake integrals +C --------------------------------------------------------- + + z = 0. + sum_thu = 0. + sum_tu = 0. + sum_qu = 0. + sum_thvu = 0. + sum_dth = 0. + sum_dq = 0. + sum_rho = 0. + sum_dtdwn = 0. + sum_dqdwn = 0. + + av_thu = 0. + av_tu =0. + av_qu =0. + av_thvu = 0. + av_dth = 0. + av_dq = 0. + av_rho =0. + av_dtdwn =0. + av_dqdwn = 0. + +C Potential temperatures and humidity +c---------------------------------------------------------- + + DO k =1,klev + rho(k) = p(k)/(rd*te(k)) + IF(k .eq. 1) THEN + rhoh(k) = ph(k)/(rd*te(k)) + zhh(k)=0 + ELSE + rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1))) + zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1) + ENDIF + the(k) = te(k)/ppi(k) + thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k) + tu(k) = te(k) - deltatw(k)*sigmaw + qu(k) = qe(k) - deltaqw(k)*sigmaw + rhow(k) = p(k)/(rd*(te(k)+deltatw(k))) + dth(k) = deltatw(k)/ppi(k) + + ENDDO + +C Integrals (and wake top level number) +C ----------------------------------------------------------- + +C Initialize sum_thvu to 1st level virt. pot. temp. + + z = 1. + dz = 1. + sum_thvu = thu(1)*(1.+eps*qu(1))*dz + sum_dth = 0. + + DO k = 1,klev + dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg) + + IF (dz .LE. 0) GO TO 51 + z = z+dz + sum_thu = sum_thu + thu(k)*dz + sum_tu = sum_tu + tu(k)*dz + sum_qu = sum_qu + qu(k)*dz + sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz + sum_dth = sum_dth + dth(k)*dz + sum_dq = sum_dq + deltaqw(k)*dz + sum_rho = sum_rho + rhow(k)*dz + sum_dtdwn = sum_dtdwn + dtdwn(k)*dz + sum_dqdwn = sum_dqdwn + dqdwn(k)*dz + ENDDO + 51 CONTINUE + + hw0 = z + +C 2.1 - WAPE and mean forcing computation +C------------------------------------------------------------- + +C Means + + av_thu = sum_thu/hw0 + av_tu = sum_tu/hw0 + av_qu = sum_qu/hw0 + av_thvu = sum_thvu/hw0 + av_dth = sum_dth/hw0 + av_dq = sum_dq/hw0 + av_rho = sum_rho/hw0 + av_dtdwn = sum_dtdwn/hw0 + av_dqdwn = sum_dqdwn/hw0 + + wape2 = - rg*hw0*(av_dth + $ + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu + + +C 2.2 Prognostic variable update +C ------------------------------------------------------------ + +C Filter out bad wakes + + IF ( wape2 .LT. 0.) THEN + if(prt_level.ge.10) print*,'wape2<0' + wape2 = 0. + hw = hwmin + sigmaw = max(sigmad,sigd_con) + fip = 0. + DO k = 1,klev + deltatw(k) = 0. + deltaqw(k) = 0. + dth(k) = 0. + ENDDO + ELSE + if(prt_level.ge.10) print*,'wape2>0' + Cstar2 = stark*sqrt(2.*wape2) + + ENDIF + + ktopw = ktop + + IF (ktopw .gt. 0) then + +Cjyg1 Utilisation d'un h_efficace constant ( ~ feeding layer) +ccc heff = 600. +C Utilisation de la hauteur hw +cc heff = 0.7*hw + heff = hw + + FIP = 0.5*rho(ktopw)*Cstar2**3*heff*2*sqrt(sigmaw*wdens*3.14) + FIP = alpk * FIP +Cjyg2 + ELSE + FIP = 0. + ENDIF + + +C Limitation de sigmaw +c +C sécurité : si le wake occuppe plus de 90 % de la surface de la maille, +C alors il disparait en se mélangeant à la partie undisturbed + +! correction NICOLAS . ((wape.ge.wape2).and.(wape2.le.1.0))) THEN + IF ((sigmaw.GT.0.9).or. + . ((wape.ge.wape2).and.(wape2.le.1.0)).or.(ktopw.le.2)) THEN +cIM cf NR/JYG 251108 . ((wape.ge.wape2).and.(wape2.le.1.0))) THEN +c IF (sigmaw.GT.0.9) THEN + DO k = 1,klev + dtls(k) = 0. + dqls(k) = 0. + deltatw(k) = 0. + deltaqw(k) = 0. + ENDDO + wape = 0. + hw = hwmin + sigmaw = sigmad + fip = 0. + ENDIF + + RETURN + END + + + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wrgradsfi.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wrgradsfi.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wrgradsfi.F (revision 1634) @@ -0,0 +1,43 @@ +! +! $Header$ +! + subroutine wrgradsfi(if,nl,fieldfi_p,name,titlevar) + USE dimphy + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para + implicit none + +c Declarations + +#include "dimensions.h" +cym#include "dimphy.h" + +c arguments + integer if,nl + real fieldfi_p(klon,nl) + real fieldfi(klon_glo,nl) + real fielddyn((iim+1)*(jjm+1),llm) + character*10 name + character*10 titlevar + +c local + + integer lm,l,lnblnk + + + +c print*,'Transformation pour ',name + call Gather(fieldfi_p,fieldfi) + +c$OMP MASTER + if (is_mpi_root) then + call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn) + +c print*,'Transformation OK ' + call wrgrads(if,nl,fielddyn,name,titlevar) +c print*,'Ecriture ok' + endif +c$OMP END MASTER + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_bilKP_ave.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_bilKP_ave.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_bilKP_ave.h (revision 1634) @@ -0,0 +1,155 @@ +c +c $Header$ +c + IF (ok_journe) THEN +c + ndex2d = 0 + ndex3d = 0 +c +c Champs 2D: +c + itau_w = itau_phy + itap +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ue",itau_w,ue_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ve",itau_w,ve_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"uq",itau_w,uq_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vq",itau_w,vq_lay) +c +c Champs 3D: +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"temp",itau_w,t_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ovap",itau_w,qx(:,:,ivap)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"geop",itau_w,zphi) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vitu",itau_w,u_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vitv",itau_w,v_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"vitw",itau_w,omega) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"pres",itau_w,pplay) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"play",itau_w,paprs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"oliq",itau_w,cldliq) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtdyn",itau_w,d_t_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqdyn",itau_w,d_q_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtcon",itau_w,d_t_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"ducon",itau_w,d_u_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvcon",itau_w,d_v_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqcon",itau_w,d_q_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtlsc",itau_w,d_t_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqlsc",itau_w,d_q_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtvdf",itau_w,d_t_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqvdf",itau_w,d_q_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtajs",itau_w,d_t_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqajs",itau_w,d_q_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dteva",itau_w,d_t_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqeva",itau_w,d_q_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtswr",itau_w,heat) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtsw0",itau_w,heat0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtlwr",itau_w,cool) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtlw0",itau_w,cool0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"duvdf",itau_w,d_u_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvvdf",itau_w,d_v_vdf) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN +c + DO k = 1, klev + DO i = 1, klon + d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k) + d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k) + ENDDO + ENDDO +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"duoli",d_u_oli) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvoli",itau_w,d_v_oli) +c + ENDIF + ENDIF +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"duphy",itau_w,d_u) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dvphy",itau_w,d_v) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dtphy",itau_w,d_t) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), +cymf .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqphy",itau_w,d_qx(:,:,1)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), +cym .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPave,"dqlphy",itau_w,d_qx(:,:,2)) +c +C + if (ok_sync) then + call histsync(nid_bilKPave) + endif + ENDIF + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_bilKP_ins.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_bilKP_ins.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_bilKP_ins.h (revision 1634) @@ -0,0 +1,179 @@ + c +c $Header$ +c + IF (ok_journe) THEN +c + ndex2d = 0 + ndex3d = 0 +c + itau_w = itau_phy + itap +c +c Champs 3D: +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ue",itau_w,ue_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ve",itau_w,ve_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"uq",itau_w,uq_lay) +c +cym CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vq",itau_w,vq_lay) +c +c Champs 3D: +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"temp",itau_w,t_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ovap",itau_w,qx(:,:,ivap)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"geop",itau_w,zphi) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vitu",itau_w,u_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vitv",itau_w,v_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"vitw",itau_w,omega) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"pres",itau_w,pplay) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"play",itau_w,paprs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"oliq",itau_w,cldliq) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtdyn",itau_w,d_t_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqdyn",itau_w,d_q_dyn) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtcon",itau_w,d_t_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"ducon",itau_w,d_u_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvcon",itau_w,d_v_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqcon",itau_w,d_q_con) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtlsc",itau_w,d_t_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqlsc",itau_w,d_q_lsc) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtvdf",itau_w,d_t_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqvdf",itau_w,d_q_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtajs",itau_w,d_t_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqajs",itau_w,d_q_ajs) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dteva",itau_w,d_t_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqeva",itau_w,d_q_eva) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtswr",itau_w,heat) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtsw0",itau_w,heat0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtlwr",itau_w,cool) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtlw0",itau_w,cool0) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"duvdf",itau_w,d_u_vdf) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvvdf",itau_w,d_v_vdf) +c + IF (ok_orodr) THEN + IF (ok_orolf) THEN +c + DO k = 1, klev + DO i = 1, klon + d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k) + d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k) + ENDDO + ENDDO +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"duoli",itau_w,d_u_oli) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvoli",itau_w,d_v_oli) +c + ENDIF + ENDIF +C +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"duphy",itau_w,d_u) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dvphy",itau_w,d_v) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dtphy",itau_w,d_t) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), +cym .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqphy",itau_w,d_qx(:,:,1)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), +cym .zx_tmp_3d) + CALL histwrite_phy(nid_bilKPins,"dqlphy",itau_w,d_qx(:,:,2)) +c +cIM 280405 BEG +c +c Champs 2D: +c +c Ecriture de champs dynamiques sur des niveaux de pression +c DO k=1, nlevSTD + DO k=1, 12 +c + IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k) + IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k) +c + IF(bb2.EQ."850") THEN +c +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d) + CALL histwrite_phy(nid_bilKPins,"u"//bb2,itau_w,usumSTD(:,k,1)) +c +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d) + CALL histwrite_phy(nid_bilKPins,"v"//bb2,itau_w,vsumSTD(:,k,1)) +c + ENDIF !(bb2.EQ."850") +c + ENDDO !k=1, 12 +c +cIM 280405 END +C + if (ok_sync) then + call histsync(nid_bilKPins) + endif + ENDIF + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_field_phy.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_field_phy.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_field_phy.F90 (revision 1634) @@ -0,0 +1,36 @@ +! +! $Header$ +! +MODULE write_field_phy + + CONTAINS + + SUBROUTINE WriteField_phy(name,Field,ll) + USE dimphy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + USE Write_Field + + IMPLICIT NONE + include 'dimensions.h' + include 'paramet.h' + + character(len=*) :: name + INTEGER :: ll + real, dimension(klon_omp,ll) :: Field + real,save,allocatable :: Field_tmp(:,:) + real, dimension(klon_glo,ll):: New_Field + real, dimension(iim,jjp1,ll):: Field_2d + + CALL Gather(Field,New_Field) +!$OMP MASTER + IF (is_mpi_root) THEN + CALL Grid1Dto2D_glo(New_Field,Field_2D) + CALL WriteField(name,Field_2d) + ENDIF +!$OMP END MASTER + + + END SUBROUTINE WriteField_phy + + END MODULE write_field_phy Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histISCCP.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histISCCP.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histISCCP.h (revision 1634) @@ -0,0 +1,222 @@ +! +! $Id$ +! + IF (ok_isccp) THEN +c + IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN +c + ndex2d = 0 + ndex3d = 0 +c + itau_w = itau_phy + itap +c + IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN +c + DO n=1, napisccp +c + DO k=1,kmaxm1 + zx_tmp_fi3d(1:klon, 1:lmaxm1)=fq_isccp(1:klon,k,1:lmaxm1,n)*100. +cym CALL gr_fi_ecrit(lmaxm1,klon,iim,jjmp1,zx_tmp_fi3d, +cym . zx_tmp_3d) +c +cIM: champ 3d : (lon,lat,pres) pour un tau fixe +c + CALL histwrite_phy(nid_isccp,"cldISCCP_"//taulev(k)//verticaxe(n), + . itau_w,zx_tmp_fi3d) + ENDDO !k +c +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),itau_w, + . nbsunlit(1,:,n)) +c + CALL histwrite_phy(nid_isccp,"meantaucld"//verticaxe(n),itau_w, + . meantaucld(:,n)) +c + ENDDO ! n=1, napisccp + ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN +c + DO n=1, napisccp +c print*,'n=',n,' write_ISCCP avant fq_isccp' + DO k=1, kmaxm1 + DO l=1, lmaxm1 +c + IF(top_height.LE.2) THEN + DO i=1, klon +c281008 beg +c print*,'write_ISCCP i n nbsunlit',i,n,nbsunlit(1,i,n) +c281008 end +c + IF(nbsunlit(1,i,n).NE.0.) THEN + fq_is_true(i,k,l,n)= + $ fq_isccp(i,k,l,n)*100./nbsunlit(1,i,n) + ELSE + fq_is_true(i,k,l,n)=0 + ENDIF + ENDDO + ELSE IF(top_height.EQ.3) THEN + DO i=1, klon + fq_is_true(i,k,l,n) = fq_isccp(i,k,l,n)*100. + ENDDO + ENDIF +cym CALL gr_fi_ecrit(1,klon,iim,jjmp1,fq_is_true, +cym . zx_tmp_2d) +c +cIM: champ 2d : (lon,lat) pour un tau et une pc fixes +c + CALL histwrite_phy(nid_isccp,pclev(l)//taulev(k)//verticaxe(n), + . itau_w,fq_is_true(:,k,l,n)) + ENDDO !l + ENDDO !k +c +c print*,'n=',n,' write_ISCCP avant nbsunlit' +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n), + . itau_w,nbsunlit(1,:,n)) +c + CALL histwrite_phy(nid_isccp,"meantaucld"//verticaxe(n),itau_w, + . meantaucld(:,n)) +c + zx_tmp_fi2d(1:klon)=REAL(seed(1:klon,n)) +c +c print*,'n=',n,' write_ISCCP avant seed' +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"seed"//verticaxe(n), + . itau_w,zx_tmp_fi2d) +c +c 9types de nuages ISCCP-D2 +c fq_isccp(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l) + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) + + $ fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) + + $ fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"cirr",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) + + $ fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) + + $ fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"cist",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) + + $ fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) + + $ fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"deep",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) + + $ fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"alcu",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) + + $ fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"alst",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) + + $ fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"nist",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) + + $ fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"cumu",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) + + $ fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"stcu",itau_w,zx_tmp_fi2d) +c + DO i=1, klon + zx_tmp_fi2d(i)= + $ (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) + + $ fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite_phy(nid_isccp,"stra",itau_w,zx_tmp_fi2d) +c +c 3_tau_nuages x 3_levels +c fq_is_true(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l) + DO i=1, klon + cld_fi3d(i,1)= + $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) + + $ fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) + + $ fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) ) + cld_fi3d(i,2)= + $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) + + $ fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) ) + cld_fi3d(i,3)= + $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) + + $ fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(lmax3,klon,iim,jjmp1,cld_fi3d,cld_3d) + CALL histwrite_phy(nid_isccp,"thin",itau_w,cld_fi3d) +c + DO i=1, klon + cld_fi3d(i,1)= + $ (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) + + $ fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) + + $ fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) ) + cld_fi3d(i,2)= + $ (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) + + $ fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) ) + cld_fi3d(i,3)= + $ (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) + + $ fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d) + CALL histwrite_phy(nid_isccp,"mid",itau_w,cld_fi3d) +c + DO i=1, klon + cld_fi3d(i,1)= + $ (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) + + $ fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) + + $ fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) ) + cld_fi3d(i,2)= + $ (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) + + $ fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) ) + cld_fi3d(i,3)= + $ (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) + + $ fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) ) + ENDDO +cym CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d) + CALL histwrite_phy(nid_isccp,"thick",itau_w,cld_fi3d) +c + ENDDO ! n=1, napisccp +c + ENDIF +c + if (ok_sync) then +c$OMP MASTER + call histsync(nid_isccp) +c$OMP END MASTER + endif + + ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN + + ENDIF !ok_isccp Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histREGDYN.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histREGDYN.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histREGDYN.h (revision 1634) @@ -0,0 +1,63 @@ +! +! $Header$ +! + if (ok_regdyn) then + + if (is_sequential) then + + + ndex3d = 0 + itau_w = itau_phy + itap +c + CALL histwrite(nid_regdyn,"hw1",itau_w,histoW(:,:,:,1), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh1",itau_w,nhistoW(:,:,:,1), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht1",itau_w,nhistoWt(:,:,:,1), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw2",itau_w,histoW(:,:,:,2), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh2",itau_w,nhistoW(:,:,:,2), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht2",itau_w,nhistoWt(:,:,:,2), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw3",itau_w,histoW(:,:,:,3), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh3",itau_w,nhistoW(:,:,:,3), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht3",itau_w,nhistoWt(:,:,:,3), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw4",itau_w,histoW(:,:,:,4), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh4",itau_w,nhistoW(:,:,:,4), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht4",itau_w,nhistoWt(:,:,:,4), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"hw5",itau_w,histoW(:,:,:,5), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nh5",itau_w,nhistoW(:,:,:,5), + & kmaxm1*lmaxm1*iwmax,ndex3d) +c + CALL histwrite(nid_regdyn,"nht5",itau_w,nhistoWt(:,:,:,5), + & kmaxm1*lmaxm1*iwmax,ndex3d) + + if (ok_sync) then + call histsync(nid_regdyn) + endif + + endif ! is_sequential + + endif Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histdayNMC.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histdayNMC.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histdayNMC.h (revision 1634) @@ -0,0 +1,58 @@ +! +! $Header$ +! + IF (ok_histNMC(2)) THEN +c + ndex3d = 0 + itau_w = itau_phy + itap +ccc +c Champs interpolles sur des niveaux de pression du NMC +c +c PARAMETER(nout=3) +c nout=1 : in=pdtphys, out=mth +c nout=2 : in=pdtphys, out=day +c nout=3 : in=pdtphys, out=hf +ccc + IF(lev_histdayNMC.EQ.nlevSTD) THEN + CALL histwrite_phy(nid_daynmc,lNMC,"tnondef",itau_w, + $tnondef(:,:,2)) + CALL histwrite_phy(nid_daynmc,lNMC,"ta",itau_w, + $twriteSTD(:,:,2)) + CALL histwrite_phy(nid_daynmc,lNMC,"zg",itau_w, + $phiwriteSTD(:,:,2)) + CALL histwrite_phy(nid_daynmc,lNMC,"hus",itau_w, + $qwriteSTD(:,:,2)) + CALL histwrite_phy(nid_daynmc,lNMC,"hur",itau_w, + $rhwriteSTD(:,:,2)) + CALL histwrite_phy(nid_daynmc,lNMC,"ua",itau_w, + $uwriteSTD(:,:,2)) + CALL histwrite_phy(nid_daynmc,lNMC,"va",itau_w, + $vwriteSTD(:,:,2)) + CALL histwrite_phy(nid_daynmc,lNMC,"wap",itau_w, + $wwriteSTD(:,:,2)) + ELSE IF(lev_histdayNMC.EQ.nlevSTD8) THEN + CALL histwrite_phy(nid_daynmc,lNMC,"tnondef",itau_w, + $tnondefSTD8) + CALL histwrite_phy(nid_daynmc,lNMC,"ta",itau_w, + $twriteSTD8) + CALL histwrite_phy(nid_daynmc,lNMC,"zg",itau_w, + $phiwriteSTD8) + CALL histwrite_phy(nid_daynmc,lNMC,"hus",itau_w, + $qwriteSTD8) + CALL histwrite_phy(nid_daynmc,lNMC,"hur",itau_w, + $rhwriteSTD8) + CALL histwrite_phy(nid_daynmc,lNMC,"ua",itau_w, + $uwriteSTD8) + CALL histwrite_phy(nid_daynmc,lNMC,"va",itau_w, + $vwriteSTD8) + CALL histwrite_phy(nid_daynmc,lNMC,"wap",itau_w, + $wwriteSTD8) + ENDIF +c + if (ok_sync) then +c$OMP MASTER + call histsync(nid_daynmc) +c$OMP END MASTER + endif +c + ENDIF ! (ok_histNMC(2)) THEN Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histday_seri.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histday_seri.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histday_seri.h (revision 1634) @@ -0,0 +1,242 @@ +c +c $Header$ +c + IF (is_sequential) THEN + + IF (type_run.EQ."AMIP") THEN +c + ndex2d = 0 + itau_w = itau_phy + itap +c +c Champs 2D: +c + pi = ACOS(-1.) + pir = 4.0*ATAN(1.0) / 180.0 +c + DO i=1, klon + zx_tmp_fi2d(i)=(topsw(i)-toplw(i)) + ENDDO +c + ok_msk=.FALSE. + msk(1:klon)=pctsrf(1:klon,is_ter) + CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"bilTOA",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, bils, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"bils",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO k=1, klev + DO i=1, klon +cIM 080904 zx_tmp_fi3d(i,k)=u(i,k)**2+v(i,k)**2 + zx_tmp_fi3d(i,k)=(u(i,k)**2+v(i,k)**2)/2. + ENDDO + ENDDO +c + CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, + . airephy, paprs, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"ecin",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c +cIM 151004 BEG + IF(1.EQ.0) THEN +c + DO k=1, klev + DO i=1, klon + zx_tmp_fi3d(i,k)=u_seri(i,k)*RA*cos(pir* rlat(i)) + ENDDO + ENDDO +c + CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, + . airephy, paprs, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c friction torque +c + DO i=1, klon + zx_tmp_fi2d(i)=zxfluxu(i,1)*RA* cos(pir* rlat(i)) + ENDDO +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"frictor",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +c mountain torque +c +cIM 190504 BEG + CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn) + CALL gr_fi_dyn(klev+1,klon,iim+1,jjm+1,paprs,padyn) + CALL gr_fi_dyn(1,klon,iim+1,jjm+1,rlat,rlatdyn) + mountor=0. + airetot=0. + DO j = 1, jjmp1 + DO i = 1, iim+1 + ij=i+(iim+1)*(j-1) + zx_tmp(ij)=0. + DO k = 1, klev + zx_tmp(ij)=zx_tmp(ij)+dudyn(i,j,k)*airedyn(i,j)* + $ (padyn(i,j,k+1)-padyn(i,j,k))/RG + airetot=airetot+airedyn(i,j) + ENDDO +cIM 190504 mountor=mountor+zx_tmp(ij)*airedyn(i,j)*RA* + mountor=mountor+zx_tmp(ij)*RA* + $ cos(pir* rlatdyn(i,j)) + ENDDO + ENDDO +cIM 151004 BEG + IF(itap.EQ.1) PRINT*,'airetot=',airetot,airetot/klev +cIM 151004 END +cIM 190504 mountor=mountor/(airetot*airetot) + mountor=mountor/airetot +c +cIM 190504 END + zx_tmp_2d(1:iim,1:jjmp1)=mountor + CALL histwrite(nid_day_seri,"mountor",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + ENDIF !(1.EQ.0) THEN +c +c + CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn) + CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d) + airetot=0. +c DO j = 1, jjmp1 +c DO i = 1, iim+1 +c ij=i+(iim+1)*(j-1) +c DO k = 1, klev +c airetot=airetot+airedyn(i,j) +c airetot=airetot+airedyn(i,j) +c ENDDO !k +c ENDDO !i +c ENDDO !j +c + DO i=1, klon + airetot=airetot+airephy(i) + ENDDO +c IF(itap.EQ.1) PRINT*,'airetotphy=',airetot +c + airetot=0. + DO j=1, jjmp1 + DO i=1, iim + airetot=airetot+zx_tmp_2d(i,j) + ENDDO + ENDDO +c +c IF(itap.EQ.1) PRINT*,'airetotij=',airetot, +c $ '4piR2',4.*pi*RA*RA +c + zx_tmp_fi2d(1:klon)=aam/airetot + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c + zx_tmp_fi2d(1:klon)=torsfc/airetot + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"torsfc",itau_w,zx_tmp_2d, + . iim*jjmp1,ndex2d) +c +cIM 151004 END +c + CALL moyglo_pondmass(klon, klev, t_seri, + . airephy, paprs, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"tamv",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, paprs(:,1), airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"psol",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c + ok_msk=.FALSE. + CALL moyglo_pondaire(klon, evap, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d) + CALL histwrite(nid_day_seri,"evap",itau_w, + . zx_tmp_2d,iim*jjmp1,ndex2d) +c +c DO i=1, klon +c zx_tmp_fi2d(i)=SnowFrac(i,is_ter) +c ENDDO +c +c ok_msk=.TRUE. +c msk(1:klon)=pctsrf(1:klon,is_ter) +c CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, +c . ok_msk, msk, moyglo) +c zx_tmp_fi2d(1:klon)=moyglo +c +c CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_day_seri,"SnowFrac", +c . itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c DO i=1, klon +cIM 080904 zx_tmp_fi2d(i)=zsnow_mass(i)/330.*rowl +c zx_tmp_fi2d(i)=zsnow_mass(i) +c ENDDO +c +cIM 140904 ok_msk=.FALSE. +c ok_msk=.TRUE. +c msk(1:klon)=pctsrf(1:klon,is_ter) +c CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, +c . ok_msk, msk, moyglo) +c zx_tmp_fi2d(1:klon)=moyglo +c +c CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d) +c CALL histwrite(nid_day_seri,"snow_depth",itau_w, +c . zx_tmp_2d,iim*jjmp1,ndex2d) +c + DO i=1, klon + zx_tmp_fi2d(i)=ftsol(i,is_oce) + ENDDO +c + ok_msk=.TRUE. + msk(1:klon)=pctsrf(1:klon,is_oce) + CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, + . ok_msk, msk, moyglo) + zx_tmp_fi2d(1:klon)=moyglo +c + CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d) + CALL histwrite(nid_day_seri,"tsol_"//clnsurf(is_oce), + $ itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) +c +c================================================================= +c================================================================= +c================================================================= +c + if (ok_sync) then + call histsync(nid_day_seri) + endif +c + ENDIF !fin test sur type_run.EQ."AMIP" + + ENDIF ! mono_cpu Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histhf3d.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histhf3d.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histhf3d.h (revision 1634) @@ -0,0 +1,28 @@ + +c +c $Header$ +c +c + ndex2d = 0 + ndex3d = 0 +c + itau_w = itau_phy + itap +c +c Champs 3D: +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"temp",itau_w,t_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"ovap",itau_w,qx(:,:,ivap)) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"vitu",itau_w,u_seri) +c +cym CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d) + CALL histwrite_phy(nid_hf3d,"vitv",itau_w,v_seri) + if (ok_sync) then +c$OMP MASTER + call histsync(nid_hf3d) +c$OMP END MASTER + endif Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histhfNMC.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histhfNMC.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histhfNMC.h (revision 1634) @@ -0,0 +1,90 @@ +! +! $Header$ +! + IF (ok_histNMC(3)) THEN +c + ndex3d = 0 + itau_w = itau_phy + itap +ccc +c Champs interpolles sur des niveaux de pression du NMC +c +c PARAMETER(nout=3) +c nout=1 : in=pdtphys, out=mth +c nout=2 : in=pdtphys, out=day +c nout=3 : in=pdtphys, out=hf +ccc + CALL histwrite_phy(nid_hfnmc,lNMC,"tnondef",itau_w, + $tnondef(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"ta",itau_w, + $twriteSTD3) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"zg",itau_w, + $phiwriteSTD3) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"hus",itau_w, + $qwriteSTD3) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"hur",itau_w, + $rhwriteSTD3) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"ua",itau_w, + $uwriteSTD3) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"va",itau_w, + $vwriteSTD3) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"wap",itau_w, + $wwriteSTD3) +c + IF (1.EQ.0) THEN +c + DO k=1, nlevSTD + DO i=1, klon + IF(tnondef(i,k,3).NE.missing_val) THEN + zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,3))/freq_moyNMC(3) + ELSE + zx_tmp_fiNC(i,k) = missing_val + ENDIF + ENDDO + ENDDO !k=1, nlevSTD +c + CALL histwrite_phy(nid_hfnmc,lNMC,"psbg",itau_w, + $zx_tmp_fiNC) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"uv",itau_w, + $uvsumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"vq",itau_w, + $vqsumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"vT",itau_w, + $vTsumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"wq",itau_w, + $wqsumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"vphi",itau_w, + $vphisumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"wT",itau_w, + $wTsumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"uxu",itau_w, + $u2sumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"vxv",itau_w, + $v2sumSTD(:,:,3)) +c + CALL histwrite_phy(nid_hfnmc,lNMC,"TxT",itau_w, + $T2sumSTD(:,:,3)) +c + ENDIF !(1.EQ.0) THEN +c + if (ok_sync) then +c$OMP MASTER + call histsync(nid_hfnmc) +c$OMP END MASTER + endif +c + ENDIF ! (ok_histNMC(3)) THEN Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histmthNMC.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histmthNMC.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histmthNMC.h (revision 1634) @@ -0,0 +1,113 @@ +! +! $Id$ +! + IF (ok_histNMC(1)) THEN +c + ndex3d = 0 + itau_w = itau_phy + itap +ccc +c Champs interpolles sur des niveaux de pression du NMC +c +c PARAMETER(nout=3) +c nout=1 : in=pdtphys, out=mth +c nout=2 : in=pdtphys, out=day +c nout=3 : in=pdtphys, out=hf +ccc + CALL histwrite_phy(nid_mthnmc,lNMC,"tnondef",itau_w, + $tnondef(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"ta",itau_w, + $twriteSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"zg",itau_w, + $phiwriteSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"hus",itau_w, + $qwriteSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"hur",itau_w, + $rhwriteSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"ua",itau_w, + $uwriteSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"va",itau_w, + $vwriteSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"wap",itau_w, + $wwriteSTD(:,:,1)) +c + DO k=1, nlevSTD + DO i=1, klon + IF(tnondef(i,k,1).NE.missing_val) THEN + zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,1))/freq_moyNMC(1) + ELSE + zx_tmp_fiNC(i,k) = missing_val + ENDIF + ENDDO + ENDDO !k=1, nlevSTD +c + CALL histwrite_phy(nid_mthnmc,lNMC,"psbg",itau_w, + $zx_tmp_fiNC) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"uv",itau_w, + $uvsumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"vq",itau_w, + $vqsumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"vT",itau_w, + $vTsumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"wq",itau_w, + $wqsumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"vphi",itau_w, + $vphisumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"wT",itau_w, + $wTsumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"uxu",itau_w, + $u2sumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"vxv",itau_w, + $v2sumSTD(:,:,1)) +c + CALL histwrite_phy(nid_mthnmc,lNMC,"TxT",itau_w, + $T2sumSTD(:,:,1)) +c + DO k=1, nlevSTD + DO i=1, klon + IF(O3sumSTD(i,k,1).NE.missing_val) THEN + zx_tmp_fiNC(i,k) = O3sumSTD(i,k,1) * 1.e+9 + ELSE + zx_tmp_fiNC(i,k) = missing_val + ENDIF + ENDDO + ENDDO !k=1, nlevSTD + CALL histwrite_phy(nid_mthnmc,lNMC,"tro3",itau_w, + $ zx_tmp_fiNC) +c + if (read_climoz == 2) THEN + DO k=1, nlevSTD + DO i=1, klon + IF(O3daysumSTD(i,k,1).NE.missing_val) THEN + zx_tmp_fiNC(i,k) = O3daysumSTD(i,k,1) * 1.e+9 + ELSE + zx_tmp_fiNC(i,k) = missing_val + ENDIF + ENDDO + ENDDO !k=1, nlevSTD +c + CALL histwrite_phy(nid_mthnmc,lNMC,"tro3_daylight", + $itau_w, zx_tmp_fiNC) + endif +c + if (ok_sync) then +c$OMP MASTER + call histsync(nid_mthnmc) +c$OMP END MASTER + endif +c + ENDIF !(ok_histNMC(1)) THEN Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histrac.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histrac.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_histrac.h (revision 1634) @@ -0,0 +1,84 @@ +!$Id $ +!*************************************** +! ECRITURE DU FICHIER : histrac.nc +!*************************************** + IF (ecrit_tra > 0. .AND. config_inca == 'none') THEN + + itau_w = itau_phy + nstep + + CALL histwrite_phy(nid_tra,"phis",itau_w,pphis) + CALL histwrite_phy(nid_tra,"aire",itau_w,airephy) + CALL histwrite_phy(nid_tra,"zmasse",itau_w,zmasse) + +!TRACEURS +!---------------- + DO it=1,nbtr + iiq=niadv(it+2) + +! CONCENTRATIONS + CALL histwrite_phy(nid_tra,tname(iiq),itau_w,tr_seri(:,:,it)) + +! TD LESSIVAGE + IF (lessivage .AND. aerosol(it)) THEN + CALL histwrite_phy(nid_tra,"fl"//tname(iiq),itau_w,flestottr(:,:,it)) + ENDIF + +! TD THERMIQUES + IF (iflag_thermals.gt.0) THEN + CALL histwrite_phy(nid_tra,"d_tr_th_"//tname(iiq),itau_w,d_tr_th(:,:,it)) + ENDIF + +! TD CONVECTION + IF (iflag_con.GE.2) THEN + CALL histwrite_phy(nid_tra,"d_tr_cv_"//tname(iiq),itau_w,d_tr_cv(:,:,it)) + ENDIF + +! TD COUCHE-LIMITE + CALL histwrite_phy(nid_tra,"d_tr_cl_"//tname(iiq),itau_w,d_tr_cl(:,:,it)) + ENDDO +!--------------- +! +! +! VENT (niveau 1) + CALL histwrite_phy(nid_tra,"pyu1",itau_w,yu1) + CALL histwrite_phy(nid_tra,"pyv1",itau_w,yv1) +! +! TEMPERATURE DU SOL + zx_tmp_fi2d(:)=ftsol(:,1) + CALL histwrite_phy(nid_tra,"ftsol1",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=ftsol(:,2) + CALL histwrite_phy(nid_tra,"ftsol2",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=ftsol(:,3) + CALL histwrite_phy(nid_tra,"ftsol3",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=ftsol(:,4) + CALL histwrite_phy(nid_tra,"ftsol4",itau_w,zx_tmp_fi2d) +! +! NATURE DU SOL + zx_tmp_fi2d(:)=pctsrf(:,1) + CALL histwrite_phy(nid_tra,"psrf1",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=pctsrf(:,2) + CALL histwrite_phy(nid_tra,"psrf2",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=pctsrf(:,3) + CALL histwrite_phy(nid_tra,"psrf3",itau_w,zx_tmp_fi2d) + zx_tmp_fi2d(:)=pctsrf(:,4) + CALL histwrite_phy(nid_tra,"psrf4",itau_w,zx_tmp_fi2d) + +! DIVERS + CALL histwrite_phy(nid_tra,"pplay",itau_w,pplay) + CALL histwrite_phy(nid_tra,"T",itau_w,t_seri) + CALL histwrite_phy(nid_tra,"mfu",itau_w,pmfu) + CALL histwrite_phy(nid_tra,"mfd",itau_w,pmfd) + CALL histwrite_phy(nid_tra,"en_u",itau_w,pen_u) + CALL histwrite_phy(nid_tra,"en_d",itau_w,pen_d) + CALL histwrite_phy(nid_tra,"de_d",itau_w,pde_d) + CALL histwrite_phy(nid_tra,"de_u",itau_w,pde_u) + CALL histwrite_phy(nid_tra,"coefh",itau_w,coefh) + + IF (ok_sync) THEN +!$OMP MASTER + CALL histsync(nid_tra) +!$OMP END MASTER + ENDIF + + ENDIF !ecrit_tra>0. .AND. config_inca == 'none' + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_paramLMDZ_phy.h =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_paramLMDZ_phy.h (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/write_paramLMDZ_phy.h (revision 1634) @@ -0,0 +1,99 @@ +c +c calcul moyennes globales +c + zx_tmp_fi2d=bils*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gbils) + zx_tmp_fi2d=evap*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gevap) + zx_tmp_fi2d(:)=fevap(:, is_ter)*airephy(:) + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gevapt) + zx_tmp_fi2d=zxfluxlat*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,glat) + zx_tmp_fi2d=(topsw0-toplw0)*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gnet0) + zx_tmp_fi2d=(topsw-toplw)*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gnet) + zx_tmp_fi2d=(rain_fall+snow_fall)*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,grain) + zx_tmp_fi2d=zxtsol*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gtsol) + zx_tmp_fi2d=zt2m*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gt2m) + zx_tmp_fi2d=prw*airephy + CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gprw) +c +c$OMP MASTER + if (is_mpi_root) then +c + ndex2d = 0 + itau_w = itau_phy + itap +c +c Variables globales +c + zx_tmp_0d=R_ecc + CALL histwrite(nid_ctesGCM,"R_ecc",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=R_peri + CALL histwrite(nid_ctesGCM,"R_peri",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=R_incl + CALL histwrite(nid_ctesGCM,"R_incl",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=solaire + CALL histwrite(nid_ctesGCM,"solaire",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=co2_ppm + CALL histwrite(nid_ctesGCM,"co2_ppm",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=CH4_ppb + CALL histwrite(nid_ctesGCM,"CH4_ppb",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=N2O_ppb + CALL histwrite(nid_ctesGCM,"N2O_ppb",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=CFC11_ppt + CALL histwrite(nid_ctesGCM,"CFC11_ppt",itau_w, + . zx_tmp_0d,np,ndex2d) +c + zx_tmp_0d=CFC12_ppt + CALL histwrite(nid_ctesGCM,"CFC12_ppt",itau_w, + . zx_tmp_0d,np,ndex2d) +c +c================================================================= +c moyennes globales +c + CALL histwrite(nid_ctesGCM,"bils",itau_w, + . gbils,np,ndex2d) + CALL histwrite(nid_ctesGCM,"evap",itau_w, + . gevap,np,ndex2d) + CALL histwrite(nid_ctesGCM,"evap_land",itau_w, + . gevapt,np,ndex2d) + CALL histwrite(nid_ctesGCM,"flat",itau_w, + . glat,np,ndex2d) + CALL histwrite(nid_ctesGCM,"nettop0",itau_w, + . gnet0,np,ndex2d) + CALL histwrite(nid_ctesGCM,"nettop",itau_w, + . gnet,np,ndex2d) + CALL histwrite(nid_ctesGCM,"precip",itau_w, + . grain,np,ndex2d) + CALL histwrite(nid_ctesGCM,"tsol",itau_w, + . gtsol,np,ndex2d) + CALL histwrite(nid_ctesGCM,"t2m",itau_w, + . gt2m,np,ndex2d) + CALL histwrite(nid_ctesGCM,"prw",itau_w, + . gprw,np,ndex2d) +c================================================================= +c + if (ok_sync) then + call histsync(nid_ctesGCM) + endif +c + endif !(is_mpi_root) then +c$OMP END MASTER Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wstats.F90 =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wstats.F90 (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/wstats.F90 (revision 1634) @@ -0,0 +1,351 @@ +subroutine wstats(ngrid,nom,titre,unite,dim,px) + +implicit none + +#include "dimensions.h" +#include "statto.h" +#include "netcdf.inc" + +integer,intent(in) :: ngrid +character (len=*),intent(in) :: nom,titre,unite +integer,intent(in) :: dim +real, dimension(ngrid,llm),intent(in) :: px +integer,parameter :: iip1=iim+1 +integer,parameter :: jjp1=jjm+1 +real, dimension(iip1,jjp1,llm) :: mean3d,sd3d,dx3 +real, dimension(iip1,jjp1) :: mean2d,sd2d,dx2 +character (len=50) :: namebis +character (len=50), save :: firstvar +integer :: ierr,varid,nbdim,nid +integer :: meanid,sdid +integer, dimension(4) :: id,start,size +logical, save :: firstcall=.TRUE. +integer :: l,i,j,ig0 +integer,save :: index + +integer, save :: step=0 + + +if (firstcall) then + firstcall=.false. + firstvar=trim((nom)) + call inistats(ierr) +endif + +if (firstvar==nom) then ! If we're back to the first variable + step = step + 1 +endif + +if (mod(step,istats).ne.0) then + RETURN +endif + +ierr = NF_OPEN("stats.nc",NF_WRITE,nid) + +namebis=trim(nom) +ierr= NF_INQ_VARID(nid,namebis,meanid) + +if (ierr.ne.NF_NOERR) then + + if (firstvar==nom) then + index=1 + count=0 + endif + + +!declaration de la variable + +! choix du nom des coordonnees + ierr= NF_INQ_DIMID(nid,"longitude",id(1)) + ierr= NF_INQ_DIMID(nid,"latitude",id(2)) + if (dim.eq.3) then + ierr= NF_INQ_DIMID(nid,"altitude",id(3)) + ierr= NF_INQ_DIMID(nid,"Time",id(4)) + nbdim=4 + else if (dim==2) then + ierr= NF_INQ_DIMID(nid,"Time",id(3)) + nbdim=3 + endif + + write (*,*) "=====================" + write (*,*) "STATS: creation de ",nom + namebis=trim(nom) + call def_var_stats(nid,namebis,titre,unite,nbdim,id,meanid,ierr) + call inivar(nid,meanid,ngrid,dim,index,px,ierr) + namebis=trim(nom)//"_sd" + call def_var_stats(nid,namebis,trim(titre)//" total standard deviation over the season",unite,nbdim,id,sdid,ierr) + call inivar(nid,sdid,ngrid,dim,index,px,ierr) + + ierr= NF_CLOSE(nid) + return + +else + namebis=trim(nom)//"_sd" + ierr= NF_INQ_VARID(nid,namebis,sdid) + +endif + +if (firstvar==nom) then + count(index)=count(int(index))+1 + index=index+1 + if (index>istime) then + index=1 + endif +endif + +if (count(index)==0) then + if (dim.eq.3) then + start=(/1,1,1,index/) + size=(/iip1,jjp1,llm,1/) + mean3d=0 + sd3d=0 + else if (dim.eq.2) then + start=(/1,1,index,0/) + size=(/iip1,jjp1,1,0/) + mean2d=0 + sd2d=0 + endif +else + if (dim.eq.3) then + start=(/1,1,1,index/) + size=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,size,mean3d) + ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,size,sd3d) +#else + ierr = NF_GET_VARA_REAL(nid,meanid,start,size,mean3d) + ierr = NF_GET_VARA_REAL(nid,sdid,start,size,sd3d) +#endif + if (ierr.ne.NF_NOERR) then + write (*,*) NF_STRERROR(ierr) + stop "" + endif + + else if (dim.eq.2) then + start=(/1,1,index,0/) + size=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,size,mean2d) + ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,size,sd2d) +#else + ierr = NF_GET_VARA_REAL(nid,meanid,start,size,mean2d) + ierr = NF_GET_VARA_REAL(nid,sdid,start,size,sd2d) +#endif + if (ierr.ne.NF_NOERR) then + write (*,*) NF_STRERROR(ierr) + stop "" + endif + endif +endif + +if (dim.eq.3) then + +! Passage variable physique --> variable dynamique + + DO l=1,llm + DO i=1,iip1 + dx3(i,1,l)=px(1,l) + dx3(i,jjp1,l)=px(ngrid,l) + ENDDO + DO j=2,jjm + ig0= 1+(j-2)*iim + DO i=1,iim + dx3(i,j,l)=px(ig0+i,l) + ENDDO + dx3(iip1,j,l)=dx3(1,j,l) + ENDDO + ENDDO + + mean3d(:,:,:)= mean3d(:,:,:)+dx3(:,:,:) + sd3d(:,:,:)= sd3d(:,:,:)+dx3(:,:,:)**2 + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,size,mean3d) + ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,size,sd3d) +#else + ierr = NF_PUT_VARA_REAL(nid,meanid,start,size,mean3d) + ierr = NF_PUT_VARA_REAL(nid,sdid,start,size,sd3d) +#endif + if (ierr.ne.NF_NOERR) then + write (*,*) NF_STRERROR(ierr) + stop "" + endif + +else if (dim.eq.2) then + +! Passage variable physique --> physique dynamique + + DO i=1,iip1 + dx2(i,1)=px(1,1) + dx2(i,jjp1)=px(ngrid,1) + ENDDO + DO j=2,jjm + ig0= 1+(j-2)*iim + DO i=1,iim + dx2(i,j)=px(ig0+i,1) + ENDDO + dx2(iip1,j)=dx2(1,j) + ENDDO + + mean2d(:,:)= mean2d(:,:)+dx2(:,:) + sd2d(:,:)= sd2d(:,:)+dx2(:,:)**2 + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,size,mean2d) + ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,size,sd2d) +#else + ierr = NF_PUT_VARA_REAL(nid,meanid,start,size,mean2d) + ierr = NF_PUT_VARA_REAL(nid,sdid,start,size,sd2d) +#endif + if (ierr.ne.NF_NOERR) then + write (*,*) NF_STRERROR(ierr) + stop "" + endif + +endif + +ierr= NF_CLOSE(nid) + +end subroutine wstats + +!====================================================== +subroutine inivar(nid,varid,ngrid,dim,index,px,ierr) + +implicit none + +include "dimensions.h" +!!!!!!include "dimphys.h" +include "netcdf.inc" + +integer, intent(in) :: nid,varid,dim,index,ngrid +real, dimension(ngrid,llm), intent(in) :: px +integer, intent(out) :: ierr + +integer,parameter :: iip1=iim+1 +integer,parameter :: jjp1=jjm+1 + +integer :: l,i,j,ig0 +integer, dimension(4) :: start,size +real, dimension(iip1,jjp1,llm) :: dx3 +real, dimension(iip1,jjp1) :: dx2 + +if (dim.eq.3) then + + start=(/1,1,1,index/) + size=(/iip1,jjp1,llm,1/) + +! Passage variable physique --> variable dynamique + + DO l=1,llm + DO i=1,iip1 + dx3(i,1,l)=px(1,l) + dx3(i,jjp1,l)=px(ngrid,l) + ENDDO + DO j=2,jjm + ig0= 1+(j-2)*iim + DO i=1,iim + dx3(i,j,l)=px(ig0+i,l) + ENDDO + dx3(iip1,j,l)=dx3(1,j,l) + ENDDO + ENDDO + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,dx3) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,size,dx3) +#endif + +else if (dim.eq.2) then + + start=(/1,1,index,0/) + size=(/iip1,jjp1,1,0/) + +! Passage variable physique --> physique dynamique + + DO i=1,iip1 + dx2(i,1)=px(1,1) + dx2(i,jjp1)=px(ngrid,1) + ENDDO + DO j=2,jjm + ig0= 1+(j-2)*iim + DO i=1,iim + dx2(i,j)=px(ig0+i,1) + ENDDO + dx2(iip1,j)=dx2(1,j) + ENDDO + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,dx2) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,size,dx2) +#endif + +endif + +end subroutine inivar + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine def_var_stats(nid,name,title,units,nbdim,dimids,nvarid,ierr) + +! This subroutine defines variable 'name' in a (pre-existing and opened) +! NetCDF file (known from its NetCDF ID 'nid'). +! The number of dimensions 'nbdim' of the variable, as well as the IDs of +! corresponding dimensions must be set (in array 'dimids'). +! Upon successfull definition of the variable, 'nvarid' contains the +! NetCDF ID of the variable. +! The variables' attributes 'title' (Note that 'long_name' would be more +! appropriate) and 'units' are also set. + +implicit none + +#include "netcdf.inc" + +integer,intent(in) :: nid ! NetCDF file ID +character(len=*),intent(in) :: name ! the variable's name +character(len=*),intent(in) :: title ! 'title' attribute of variable +character(len=*),intent(in) :: units ! 'units' attribute of variable +integer,intent(in) :: nbdim ! number of dimensions of the variable +integer,dimension(nbdim),intent(in) :: dimids ! NetCDF IDs of the dimensions + ! the variable is defined along +integer,intent(out) :: nvarid ! NetCDF ID of the variable +integer,intent(out) :: ierr ! returned NetCDF staus code + +! 1. Switch to NetCDF define mode +ierr=NF_REDEF(nid) + +! 2. Define the variable +#ifdef NC_DOUBLE +ierr = NF_DEF_VAR (nid,adjustl(name),NF_DOUBLE,nbdim,dimids,nvarid) +#else +ierr = NF_DEF_VAR (nid,adjustl(name),NF_FLOAT,nbdim,dimids,nvarid) +#endif +if(ierr/=NF_NOERR) then + write(*,*) "def_var_stats: Failed defining variable "//trim(name) + write(*,*) NF_STRERROR(ierr) + stop "" +endif + +! 3. Write attributes +ierr=NF_PUT_ATT_TEXT(nid,nvarid,"title",& + len_trim(adjustl(title)),adjustl(title)) +if(ierr/=NF_NOERR) then + write(*,*) "def_var_stats: Failed writing title attribute for "//trim(name) + write(*,*) NF_STRERROR(ierr) + stop "" +endif + +ierr=NF_PUT_ATT_TEXT(nid,nvarid,"units",& + len_trim(adjustl(units)),adjustl(units)) +if(ierr/=NF_NOERR) then + write(*,*) "def_var_stats: Failed writing units attribute for "//trim(name) + write(*,*) NF_STRERROR(ierr) + stop "" +endif + +! 4. Switch out of NetCDF define mode +ierr = NF_ENDDEF(nid) + +end subroutine def_var_stats + Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/yamada.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/yamada.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/yamada.F (revision 1634) @@ -0,0 +1,174 @@ +! +! $Header$ +! + SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar + s ,l_mix) + use dimphy + IMPLICIT NONE +c....................................................................... +cym#include "dimensions.h" +cym#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon),snstable + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1) + REAL km(klon,klev+1) + REAL kn(klon,klev+1) + integer l_mix,ngrid + + + integer nlay,nlev +cym PARAMETER (nlay=klev) +cym PARAMETER (nlev=klev+1) + + logical first + save first + data first/.true./ +c$OMP THREADPRIVATE(first) + + integer ig,k + + real ri,zrif,zalpha,zsm + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + real l(klon,klev+1),l0(klon) + + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real ric,rifc,b1,kap + save ric,rifc,b1,kap + data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/ +c$OMP THREADPRIVATE(ric,rifc,b1,kap) + + real frif,falpha,fsm + + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + + nlay=klev + nlev=klev+1 + + if (0.eq.1.and.first) then + do ig=1,1000 + ri=(ig-800.)/500. + if (ri.lt.ric) then + zrif=frif(ri) + else + zrif=rifc + endif + if(zrif.lt.0.16) then + zalpha=falpha(zrif) + zsm=fsm(zrif) + else + zalpha=1.12 + zsm=0.085 + endif + print*,ri,rif,zalpha,zsm + enddo + first=.false. + endif + +c Correction d'un bug sauvage a verifier. +c do k=2,nlev + do k=2,nlay + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2) + s /(dz(ig,k)*dz(ig,k)) + n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1)) + s /(teta(ig,k-1)+teta(ig,k)) /dz(ig,k) + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k).lt.0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) + enddo + enddo + +c iterration pour determiner la longueur de melange + + do ig=1,ngrid + l0(ig)=100. + enddo + do k=2,klev-1 + do ig=1,ngrid + l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + enddo + enddo + + do iter=1,10 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) + enddo +c(abd 3 5 2) print*,'ITER=',iter,' L0=',l0 + + enddo + + do k=2,klev + do ig=1,ngrid + l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) + q2(ig,k)=l(ig,k)**2*zz(ig,k) + km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + kn(ig,k)=km(ig,k)*alpha(ig,k) + enddo + enddo + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/yamada4.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/yamada4.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/yamada4.F (revision 1634) @@ -0,0 +1,629 @@ +! +! $Header$ +! + SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp + s ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar + s ,iflag_pbl) + use dimphy + IMPLICIT NONE +#include "iniprint.h" +c....................................................................... +cym#include "dimensions.h" +cym#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps +c g : g +c zlev : altitude a chaque niveau (interface inferieure de la couche +c de meme indice) +c zlay : altitude au centre de chaque couche +c u,v : vitesse au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c teta : temperature potentielle au centre de chaque couche +c (en entree : la valeur au debut du pas de temps) +c cd : cdrag +c (en entree : la valeur au debut du pas de temps) +c q2 : $q^2$ au bas de chaque couche +c (en entree : la valeur au debut du pas de temps) +c (en sortie : la valeur a la fin du pas de temps) +c km : diffusivite turbulente de quantite de mouvement (au bas de chaque +c couche) +c (en sortie : la valeur a la fin du pas de temps) +c kn : diffusivite turbulente des scalaires (au bas de chaque couche) +c (en sortie : la valeur a la fin du pas de temps) +c +c iflag_pbl doit valoir entre 6 et 9 +c l=6, on prend systematiquement une longueur d'equilibre +c iflag_pbl=6 : MY 2.0 +c iflag_pbl=7 : MY 2.0.Fournier +c iflag_pbl=8 : MY 2.5 +c iflag_pbl>=9 : MY 2.5 avec diffusion verticale + +c....................................................................... + REAL dt,g,rconst + real plev(klon,klev+1),temp(klon,klev) + real ustar(klon) + real kmin,qmin,pblhmin(klon),coriol(klon) + REAL zlev(klon,klev+1) + REAL zlay(klon,klev) + REAL u(klon,klev) + REAL v(klon,klev) + REAL teta(klon,klev) + REAL cd(klon) + REAL q2(klon,klev+1),qpre + REAL unsdz(klon,klev) + REAL unsdzdec(klon,klev+1) + + REAL km(klon,klev+1) + REAL kmpre(klon,klev+1),tmp2 + REAL mpre(klon,klev+1) + REAL kn(klon,klev+1) + REAL kq(klon,klev+1) + real ff(klon,klev+1),delta(klon,klev+1) + real aa(klon,klev+1),aa0,aa1 + integer iflag_pbl,ngrid + + + integer nlay,nlev + + logical first + integer ipas + save first,ipas +cFH/IM data first,ipas/.true.,0/ + data first,ipas/.false.,0/ +c$OMP THREADPRIVATE( first,ipas) + + integer ig,k + + + real ri,zrif,zalpha,zsm,zsn + real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev) + + real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1) + real dtetadz(klon,klev+1) + real m2cstat,mcstat,kmcstat + real l(klon,klev+1) + real,allocatable,save :: l0(:) +c$OMP THREADPRIVATE(l0) + real sq(klon),sqz(klon),zz(klon,klev+1) + integer iter + + real ric,rifc,b1,kap + save ric,rifc,b1,kap + data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/ +c$OMP THREADPRIVATE(ric,rifc,b1,kap) + real frif,falpha,fsm + real fl,zzz,zl0,zq2,zn2 + + real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev) + s ,lyam(klon,klev),knyam(klon,klev) + s ,w2yam(klon,klev),t2yam(klon,klev) + logical,save :: firstcall=.true. +c$OMP THREADPRIVATE(firstcall) + frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156)) + falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri) + fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri)) + fl(zzz,zl0,zq2,zn2)= + s max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + s ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.) + + + nlay=klev + nlev=klev+1 + + if (firstcall) then + allocate(l0(klon)) + firstcall=.false. + endif + + + if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.10)) then + stop'probleme de coherence dans appel a MY' + endif + + ipas=ipas+1 + if (0.eq.1.and.first) then + do ig=1,1000 + ri=(ig-800.)/500. + if (ri.lt.ric) then + zrif=frif(ri) + else + zrif=rifc + endif + if(zrif.lt.0.16) then + zalpha=falpha(zrif) + zsm=fsm(zrif) + else + zalpha=1.12 + zsm=0.085 + endif +c print*,ri,rif,zalpha,zsm + enddo + endif + +c....................................................................... +c les increments verticaux +c....................................................................... +c +c!!!!! allerte !!!!!c +c!!!!! zlev n'est pas declare a nlev !!!!!c +c!!!!! ----> + DO ig=1,ngrid + zlev(ig,nlev)=zlay(ig,nlay) + & +( zlay(ig,nlay) - zlev(ig,nlev-1) ) + ENDDO +c!!!!! <---- +c!!!!! allerte !!!!!c +c + DO k=1,nlay + DO ig=1,ngrid + unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1)) + ENDDO + DO k=2,nlay + DO ig=1,ngrid + unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1)) + ENDDO + ENDDO + DO ig=1,ngrid + unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay)) + ENDDO +c +c....................................................................... + + do k=2,klev + do ig=1,ngrid + dz(ig,k)=zlay(ig,k)-zlay(ig,k-1) + m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2) + s /(dz(ig,k)*dz(ig,k)) + dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k) + n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k)) +c n2(ig,k)=0. + ri=n2(ig,k)/max(m2(ig,k),1.e-10) + if (ri.lt.ric) then + rif(ig,k)=frif(ri) + else + rif(ig,k)=rifc + endif + if(rif(ig,k).lt.0.16) then + alpha(ig,k)=falpha(rif(ig,k)) + sm(ig,k)=fsm(rif(ig,k)) + else + alpha(ig,k)=1.12 + sm(ig,k)=0.085 + endif + zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k) +c print*,'RIF L=',k,rif(ig,k),ri*alpha(ig,k) + + + enddo + enddo + + +c==================================================================== +c Au premier appel, on determine l et q2 de facon iterative. +c iterration pour determiner la longueur de melange + + + if (first.or.iflag_pbl.eq.6) then + do ig=1,ngrid + l0(ig)=10. + enddo + do k=2,klev-1 + do ig=1,ngrid + l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) + enddo + enddo + + do iter=1,10 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) +c l0(ig)=30. + enddo +c print*,'ITER=',iter,' L0=',l0 + + enddo + +c print*,'Fin de l initialisation de q2 et l0' + + endif ! first + +c==================================================================== +c Calcul de la longueur de melange. +c==================================================================== + +c Mise a jour de l0 + do ig=1,ngrid + sq(ig)=1.e-10 + sqz(ig)=1.e-10 + enddo + do k=2,klev-1 + do ig=1,ngrid + zq=sqrt(q2(ig,k)) + sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1)) + sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1)) + enddo + enddo + do ig=1,ngrid + l0(ig)=0.2*sqz(ig)/sq(ig) +c l0(ig)=30. + enddo +c print*,'ITER=',iter,' L0=',l0 +c calcul de l(z) + do k=2,klev + do ig=1,ngrid + l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k)) + if(first) then + q2(ig,k)=l(ig,k)**2*zz(ig,k) + endif + enddo + enddo + +c==================================================================== +c Yamada 2.0 +c==================================================================== + if (iflag_pbl.eq.6) then + + do k=2,klev + do ig=1,ngrid + q2(ig,k)=l(ig,k)**2*zz(ig,k) + enddo + enddo + + + else if (iflag_pbl.eq.7) then +c==================================================================== +c Yamada 2.Fournier +c==================================================================== + +c Calcul de l, km, au pas precedent + do k=2,klev + do ig=1,ngrid +c print*,'SMML=',sm(ig,k),l(ig,k) + delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k)) + kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + mpre(ig,k)=sqrt(m2(ig,k)) +c print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k) + enddo + enddo + + do k=2,klev-1 + do ig=1,ngrid + m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12) + mcstat=sqrt(m2cstat) + +c print*,'M2 L=',k,mpre(ig,k),mcstat +c +c -----{puis on ecrit la valeur de q qui annule l'equation de m +c supposee en q3} +c + IF (k.eq.2) THEN + kmcstat=1.E+0 / mcstat + & *( unsdz(ig,k)*kmpre(ig,k+1) + & *mpre(ig,k+1) + & +unsdz(ig,k-1) + & *cd(ig) + & *( sqrt(u(ig,3)**2+v(ig,3)**2) + & -mcstat/unsdzdec(ig,k) + & -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2) + & /( unsdz(ig,k)+unsdz(ig,k-1) ) + ELSE + kmcstat=1.E+0 / mcstat + & *( unsdz(ig,k)*kmpre(ig,k+1) + & *mpre(ig,k+1) + & +unsdz(ig,k-1)*kmpre(ig,k-1) + & *mpre(ig,k-1) ) + & /( unsdz(ig,k)+unsdz(ig,k-1) ) + ENDIF +c print*,'T2 L=',k,tmp2 + tmp2=kmcstat + & /( sm(ig,k)/q2(ig,k) ) + & /l(ig,k) + q2(ig,k)=max(tmp2,1.e-12)**(2./3.) +c print*,'Q2 L=',k,q2(ig,k) +c + enddo + enddo + + else if (iflag_pbl.ge.8) then +c==================================================================== +c Yamada 2.5 a la Didi +c==================================================================== + + +c Calcul de l, km, au pas precedent + do k=2,klev + do ig=1,ngrid +c print*,'SMML=',sm(ig,k),l(ig,k) + delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k)) + if (delta(ig,k).lt.1.e-20) then +c print*,'ATTENTION L=',k,' Delta=',delta(ig,k) + delta(ig,k)=1.e-20 + endif + km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k) + aa0= + s (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1) + aa1= + s (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1) +c abder print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20) + aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k)) +c print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k) + qpre=sqrt(q2(ig,k)) + if (iflag_pbl.eq.8 ) then + if (aa(ig,k).gt.0.) then + q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2 + else + q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 + endif + else ! iflag_pbl=9 + if (aa(ig,k)*qpre.gt.0.9) then + q2(ig,k)=(qpre*10.)**2 + else + q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2 + endif + endif + q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4) +c print*,'Q2 L=',k,q2(ig,k),qpre*qpre + enddo + enddo + + endif ! Fin du cas 8 + +c print*,'OK8' + +c==================================================================== +c Calcul des coefficients de m�ange +c==================================================================== + do k=2,klev +c print*,'k=',k + do ig=1,ngrid +cabde print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k) + zq=sqrt(q2(ig,k)) + km(ig,k)=l(ig,k)*zq*sm(ig,k) + kn(ig,k)=km(ig,k)*alpha(ig,k) + kq(ig,k)=l(ig,k)*zq*0.2 +c print*,'KML=',km(ig,k),kn(ig,k) + enddo + enddo + +! Transport diffusif vertical de la TKE. + if (iflag_pbl.ge.9) then +! print*,'YAMADA VDIF' + q2(:,1)=q2(:,2) + call vdif_q2(dt,g,rconst,ngrid,plev,temp,kq,q2) + endif + +c Traitement des cas noctrunes avec l'introduction d'une longueur +c minilale. + +c==================================================================== +c Traitement particulier pour les cas tres stables. +c D'apres Holtslag Boville. + + if (prt_level>1) THEN + print*,'YAMADA4 0' + endif !(prt_level>1) THEN + do ig=1,ngrid + coriol(ig)=1.e-4 + pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5) + enddo + +! print*,'pblhmin ',pblhmin +CTest a remettre 21 11 02 +c test abd 13 05 02 if(0.eq.1) then + if(1.eq.1) then + do k=2,klev + do ig=1,ngrid + if (teta(ig,2).gt.teta(ig,1)) then + qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2 + kmin=kap*zlev(ig,k)*qmin + else + kmin=-1. ! kmin n'est utilise que pour les SL stables. + endif + if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then +c print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k) +c s ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k) + kn(ig,k)=kmin + km(ig,k)=kmin + kq(ig,k)=kmin +c la longueur de melange est suposee etre l= kap z +c K=l q Sm d'ou q2=(K/l Sm)**2 + q2(ig,k)=(qmin/sm(ig,k))**2 + endif + enddo + enddo + endif + + if (prt_level>1) THEN + print*,'YAMADA4 1' + endif !(prt_level>1) THEN +c Diagnostique pour stokage + + if(1.eq.0)then + rino=rif + smyam(1:ngrid,1)=0. + styam(1:ngrid,1)=0. + lyam(1:ngrid,1)=0. + knyam(1:ngrid,1)=0. + w2yam(1:ngrid,1)=0. + t2yam(1:ngrid,1)=0. + + smyam(1:ngrid,2:klev)=sm(1:ngrid,2:klev) + styam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)*alpha(1:ngrid,2:klev) + lyam(1:ngrid,2:klev)=l(1:ngrid,2:klev) + knyam(1:ngrid,2:klev)=kn(1:ngrid,2:klev) + +c Estimations de w'2 et T'2 d'apres Abdela et McFarlane + + w2yam(1:ngrid,2:klev)=q2(1:ngrid,2:klev)*0.24 + s +lyam(1:ngrid,2:klev)*5.17*kn(1:ngrid,2:klev) + s *n2(1:ngrid,2:klev)/sqrt(q2(1:ngrid,2:klev)) + + t2yam(1:ngrid,2:klev)=9.1*kn(1:ngrid,2:klev) + s *dtetadz(1:ngrid,2:klev)**2 + s /sqrt(q2(1:ngrid,2:klev))*lyam(1:ngrid,2:klev) + endif + +c print*,'OKFIN' + first=.false. + return + end + SUBROUTINE vdif_q2(timestep,gravity,rconst,ngrid,plev,temp, + & kmy,q2) + use dimphy + IMPLICIT NONE +c....................................................................... +#include "dimensions.h" +cccc#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps + + real plev(klon,klev+1) + real temp(klon,klev) + real timestep + real gravity,rconst + real kstar(klon,klev+1),zz + real kmy(klon,klev+1) + real q2(klon,klev+1) + real deltap(klon,klev+1) + real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1) + integer ngrid + + integer i,k + +! print*,'RD=',rconst + do k=1,klev + do i=1,ngrid +c test +! print*,'i,k',i,k +! print*,'temp(i,k)=',temp(i,k) +! print*,'(plev(i,k)-plev(i,k+1))=',plev(i,k),plev(i,k+1) + zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k)) + kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz + s /(plev(i,k)-plev(i,k+1))*timestep + enddo + enddo + + do k=2,klev + do i=1,ngrid + deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1)) + enddo + enddo + do i=1,ngrid + deltap(i,1)=0.5*(plev(i,1)-plev(i,2)) + deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1)) + denom(i,klev+1)=deltap(i,klev+1)+kstar(i,klev) + alpha(i,klev+1)=deltap(i,klev+1)*q2(i,klev+1)/denom(i,klev+1) + beta(i,klev+1)=kstar(i,klev)/denom(i,klev+1) + enddo + + do k=klev,2,-1 + do i=1,ngrid + denom(i,k)=deltap(i,k)+(1.-beta(i,k+1))* + s kstar(i,k)+kstar(i,k-1) +c correction d'un bug 10 01 2001 + alpha(i,k)=(q2(i,k)*deltap(i,k) + s +kstar(i,k)*alpha(i,k+1))/denom(i,k) + beta(i,k)=kstar(i,k-1)/denom(i,k) + enddo + enddo + +c Si on recalcule q2(1) + if(1.eq.0) then + do i=1,ngrid + denom(i,1)=deltap(i,1)+(1-beta(i,2))*kstar(i,1) + q2(i,1)=(q2(i,1)*deltap(i,1) + s +kstar(i,1)*alpha(i,2))/denom(i,1) + enddo + endif +c sinon, on peut sauter cette boucle... + + do k=2,klev+1 + do i=1,ngrid + q2(i,k)=alpha(i,k)+beta(i,k)*q2(i,k-1) + enddo + enddo + + return + end + SUBROUTINE vdif_q2e(timestep,gravity,rconst,ngrid, + & plev,temp,kmy,q2) + use dimphy + IMPLICIT NONE +c....................................................................... +#include "dimensions.h" +cccc#include "dimphy.h" +c....................................................................... +c +c dt : pas de temps + + real plev(klon,klev+1) + real temp(klon,klev) + real timestep + real gravity,rconst + real kstar(klon,klev+1),zz + real kmy(klon,klev+1) + real q2(klon,klev+1) + real deltap(klon,klev+1) + real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1) + integer ngrid + + integer i,k + + do k=1,klev + do i=1,ngrid + zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k)) + kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz + s /(plev(i,k)-plev(i,k+1))*timestep + enddo + enddo + + do k=2,klev + do i=1,ngrid + deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1)) + enddo + enddo + do i=1,ngrid + deltap(i,1)=0.5*(plev(i,1)-plev(i,2)) + deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1)) + enddo + + do k=klev,2,-1 + do i=1,ngrid + q2(i,k)=q2(i,k)+ + s ( kstar(i,k)*(q2(i,k+1)-q2(i,k)) + s -kstar(i,k-1)*(q2(i,k)-q2(i,k-1)) ) + s /deltap(i,k) + enddo + enddo + + do i=1,ngrid + q2(i,1)=q2(i,1)+ + s ( kstar(i,1)*(q2(i,2)-q2(i,1)) + s ) + s /deltap(i,1) + q2(i,klev+1)=q2(i,klev+1)+ + s ( + s -kstar(i,klev)*(q2(i,klev+1)-q2(i,klev)) ) + s /deltap(i,klev+1) + enddo + + return + end Index: LMDZ5/branches/LMDZ5_AR5/libf/phylmd/zilch.F =================================================================== --- LMDZ5/branches/LMDZ5_AR5/libf/phylmd/zilch.F (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/libf/phylmd/zilch.F (revision 1634) @@ -0,0 +1,16 @@ +! +! $Header$ +! + subroutine zilch(x,m) +c +c Zero the real array x dimensioned m. +c + implicit none +c + integer m,i + real x(m) + do 1 i=1,m + x(i)= 0.0 + 1 continue + return + end Index: LMDZ5/branches/LMDZ5_AR5/makegcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/makegcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/makegcm (revision 1634) @@ -0,0 +1,1107 @@ +#!/bin/csh +# +# $Id$ +# +#set verbose echo +######################################################################## +# options par defaut pour la commande make +######################################################################## +set dim="96x71x19" +set physique=lmd +set phys="PHYS=$physique" +set include='-I$(LIBF)/grid -I$(LIBF)/bibio -I$(LIBF)/filtrez -I. ' +set filtre=filtrez +set grille=reg +set couple=false +set veget=false +set chimie=false +set psmile=true +set parallel=false +set vampir=false +set OPT_STACK='-Wf,-init stack=nan' +set OPT_STACK=' ' +set OPTIMI='-C debug -eC ' +set OPTIMI=' -ftrace ' +set OPT_LINUX="-O3 -fdefault-real-8" +set OPT_LINUX="-O3 -fdefault-real-8" +set io=ioipsl +set cosp=false + +set FC_LINUX=g95 +set FC_LINUX=gfortran +#set FC_LINUX=pgf90 +if ( $FC_LINUX == g95 ) then + set OPT_LINUX="-O3" +else if ( $FC_LINUX == gfortran ) then + set OPT_LINUX="-fdefault-real-8 -O3" +# set OPT_LINUX="-O3 -fno-second-underscore" + set OPT_LINUX="-O3 " +else +# pgf90 options + set OPT_LINUX="-i4 -r8 -O2 -Munroll -Mnoframe -Mautoinline -Mcache_align" +endif + +######################################################################## +# path a changer contenant les sources et les objets du modele +######################################################################## + +###### VERSION LMDZ.4 +set INCALIB=../INCA3/config/lib +set LMDGCM="`pwd`" +setenv LIBOGCM $LMDGCM/libo +# +# +setenv IOIPSLDIR /d4/fairhead/LMDZ20100928.trunk/modipsl/lib +setenv MODIPSLDIR /d4/fairhead/LMDZ20100928.trunk/modipsl/lib +setenv NCDFINC /d4/fairhead/LMDZ20100928.trunk/netcdf-4.0.1/include +setenv NCDFLIB /d4/fairhead/LMDZ20100928.trunk/netcdf-4.0.1/lib + + + + + +setenv localdir "`pwd`" +set MODIPSL=0 +echo $localdir | grep modipsl >& /dev/null +if ( ! $status ) then + set MODIPSL=1 + setenv LMDGCM $localdir + cd ../.. + setenv LIBOGCM "`pwd`/lib" + setenv IOIPSLDIR $LIBOGCM + setenv MODIPSLDIR $LIBOGCM + cd $localdir + if ( `hostname` == rhodes ) then + set NCDFINC=`grep sxnec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep sxnec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else + if ( `hostname` == nymphea0 ) then + set NCDFINC=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else if ( `hostname` == mercure ) then + set NCDFINC=`grep sx6nec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep sx6nec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else if ( `hostname` == brodie ) then + set NCDFINC=`grep sx8brodie ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"` + set NCDFLIB=`grep sx8brodie ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'` + else + echo 'Probleme de definition des variables NCDFINC et NCDFLIB' + endif + endif +else + if ( ! $?LMDGCM ) then + echo You must initialize the variable LMDGCM in your environnement + echo for instance: "setenv LMDGCM /usr/myself/supergcm" in .cshrc + exit + endif + if ( ! $?LIBOGCM ) then + set LIBOGCM=$LMDGCM/libo + endif + if ( ! $?IOIPSLDIR ) then + echo You must initialize the variable IOIPSLDIR in your environnement + echo for instance: "setenv IOIPSLDIR /usr/myself/ioipsl" in .cshrc + exit + else + setenv MODIPSLDIR $IOIPSLDIR + endif + if ( ! $?NCDFLIB ) then + echo You must initialize the variable NCDFLIB in your environnement + echo for instance: "setenv NCDFLIB /d4/fairhead/LMDZ20100928.trunk/netcdf-4.0.1/lib + exit + endif + if ( ! $?NCDFINC ) then + echo You must initialize the variable NCDFINC in your environnement + echo for instance: "setenv NCDFINC /d4/fairhead/LMDZ20100928.trunk/netcdf-4.0.1/include + exit + endif +endif +set model=$LMDGCM +set libo=$LIBOGCM + +######################################################################## +# Les differentes platformes reconnues +######################################################################## + +set HP=0 +set IBM=0 +set SUN=0 +set VPP=0 +set CRAY=0 +set DEC=0 +set LINUX=0 +set NEC=0 +set XNEC=0 +set X6NEC=0 +set X8BRODIE=0 +if ( `uname` == HP-UX ) then + set machine=HP + set HP=1 +else if (`uname` == UNIX_System_V ) then + set machine=VPP + set VPP=1 +else if (`uname` == SunOS ) then + set machine=SUN + set SUN=1 +else if ( `uname` == AIX ) then + set machine=IBM + set IBM=1 +else if ( `uname` == OSF1 ) then + set machine=ALPHA + set DEC=1 +else if ( `uname` == Linux && `hostname` != mercure && `hostname` != brodie ) then + set machine=LINUX + set LINUX=1 +else if ( `hostname` == atlas || `hostname` == axis || `hostname` == etoile ) then + set machine=CRAY + set CRAY=1 +else if ( `uname` == SUPER-UX ) then + set machine=NEC + set NEC=1 +else if ( `hostname` == rhodes) then + set machine=XNEC + set XNEC=1 +else if ( `hostname` == mercure) then + set machine=X6NEC + set X6NEC=1 +else if ( `hostname` == brodie) then + set machine=X8BRODIE + set X8BRODIE=1 +else + echo Vous travaillez sur une machine non prevue par le reglement + exit +endif + +if ( ! -d $libo ) then + mkdir $libo +endif + + +if $VPP then +set netcdf=netcdf_v +else +set netcdf=netcdf +endif +######################################################################## +# Quelques initialisations de variables du shell. +######################################################################## + +set dyn= +set opt_link="" +set adjnt="" +set lcosp="" +set opt_dep="" +set libchimie="" + +set optim="" +set optimbis="" +set optim90="" +set oplink="" + +######################################################################## +# Optimisations par defaut suivant les machines +######################################################################## + +echo "Optimisations par defaut suivant les machines" +set libf=$model/libf +#setenv localdir "LOCAL_DIR=`pwd`" +#setenv localdir "`pwd`" +cd $model +############# +if $CRAY then +############# +# set optim="-Wf'-ei' -dp -Wf'-a static'" + set optimbis=" -DCRAY " + set optim90="-Wp'-P' -DCRAY -p$IOIPSLDIR "'-p$(LIBO) -eiv ' + set optim="$optim90" + if ( $io == "ioipsl" ) then + set oplink="-Wl'-DSTACK=128 -f indef' -L$IOIPSLDIR -lioipsl -L$NCDFLIB -lnetcdf " + else + set oplink="-Wl'-DSTACK=128 -f indef' -L$IOIPSLDIR -L$NCDFLIB -lnetcdf " + endif + set mod_loc_dir=" " + set mod_suffix=" " +################# +else if $SUN then +################# + set optim=" -fast " + set optimbis=" " + set optim90=" -fast -fixed " + set optimtru90=" -fast -free " + if ( $io == "ioipsl" ) then + set opt_link="-lf77compat -L$MODIPSLDIR -lsechiba -lparameters -lstomate -lioipsl -L$NCDFLIB -lnetcdf " + else + set opt_link="-lf77compat -L$MODIPSLDIR -lsechiba -lparameters -lstomate -L$NCDFLIB -lnetcdf " + endif + set mod_loc_dir=$localdir + set mod_suffix=mod +################# +else if $HP then +################# + set optim=" +U77 -O +E1 " + set optimbis=" " +################# +else if $IBM then +################# + set optim=" -O3 -qtune=pwr2 -qarch=pwr2" + set optimbis=" " +################# +else if $VPP then +################# +# set optim="-Dasuxm -On, -g -Ad -Potilax -Eciplume -Si" +# set optimbis=" -Wv,-m3 -Wp,-DVPP -Z $LMDGCM/listage" + set optimbis=" -Wp,-DNC_DOUBLE -Ad -Z $LMDGCM/listage -X9" + set optim90="$optim $optimbis -X9 -w" + set mod_loc_dir=$MODIPSLDIR + set mod_suffix=mod +################# +else if $DEC then +################# + set optim=" " + set optimbis=" " +################# +else if $LINUX then +################# + if ( $FC_LINUX == pgf90 || $FC_LINUX == g95 || $FC_LINUX == gfortran ) then + set optim=" $OPT_LINUX " + set optim90=" $OPT_LINUX " + set optimtru90=" $OPT_LINUX " + else + echo 'compilateur linux non reconnu' + exit + endif + set mod_loc_dir=$MODIPSLDIR + set mod_suffix=mod +################# +else if $NEC then +################# + set optim90=' -clear -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "' + set optimtru90=' -clear -f4 -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "' + set optim="$optim90" + set optimbis=" " + if ( $io == "ioipsl" ) then + set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR -lioipsl $NCDFLIB -lnetcdf_i8r8_v " + else + set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR $NCDFLIB -lnetcdf_i8r8_v " + endif + set mod_loc_dir="." + set mod_suffix="mod" +################# +else if $XNEC then +################# + set optdbl='-dw -Wf\"-A dbl4\"' + set optim90=' -clear -float0 -f3 -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "' + set optimtru90=' -clear -f4 -float0 -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R2 -R3 -R4 -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"' + set optim="$optim90" + set optimbis=" " + set mod_suffix="mod" + set mod_loc_dir="./" +################# +else if $X6NEC then +################# + set optdbl='-dw -Wf\"-A dbl4\"' + set optim90=' -clear -float0 -size_t64 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "' + set optimtru90=' -clear -f4 -float0 -size_t64 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R2 -R3 -R4 -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"' + set optim="$optim90" + set optimbis=" " + set mod_suffix="mod" + set mod_loc_dir="./" +################# +else if $X8BRODIE then +################## + set optdbl='-dw -Wf\"-A dbl4\"' +# set optim90='-P stack -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -I/SX/usr/include' + set optim90='-C vopt -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -DNC_DOUBLE -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 noassume" -I/SX/usr/include' +# set optim90='-C vsafe -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -I/SX/usr/include' + set optimtru90="$optim90" + set optim90="$optim90" + set optim="$optim90" + set optimbis=" " + set mod_suffix="mod" + set mod_loc_dir="./" +else + set optim="" + set optimbis=" " +endif + +set nomlib=$machine + +######################################################################## +# lecture des options de mymake +######################################################################## + +top: +if ($#argv > 0) then + switch ($1:q) + + case -h: + +######################################################################## +# Manuel en ligne +######################################################################## +more <> tmp +end +set suf= +foreach i ( `sort tmp | uniq ` ) + set suf=$suf$i +end +if ( ! $IBM ) then + set nomlib="$nomlib$suf" +endif +if ( $DEC ) then + set nomlib=DEC +endif +if ( $IBM ) then + set dim=`echo $dim | sed -en 's/[^0-9]/ /g'` + set dim_=`echo $dim | sed -en 's/[^0-9]/_/g'` +else if ( $SUN ) then + set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` + set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'` +else + set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'` + set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` +endif +set nomlib=${nomlib}${physique}_${dim_}_$grille +## M-A-F nomlib trop long sur CRAY pour ar +if ( $CRAY ) then + set nomlib=F90_${dim_} +endif +if ( $NEC || $XNEC || $X6NEC || $X8BRODIE ) then + set nomlib=F90_${dim_}_'phy'${physique}${FLAG_PARA} +endif +echo calcul de la dimension +set dimc=`echo $dim | wc -w` + +if ( "$dimc" == "2" ) then +set include="$include "'-I$(LIBF)/dyn2d ' +set dimh=$dim +else +set include="$include "'-I$(LIBF)/dyn3d${FLAG_PARA} ' +set dimh=`echo $dim | awk ' { print $1 "." $2 } '` +endif +echo $dimc + +######################################################################## +# path pour les #include +######################################################################## + +if ( $XNEC ) then + set include="$include -I$NCDFINC -I$IOIPSLDIR" +else + set include="$include -I$NCDFINC -I$IOIPSLDIR" +endif +echo $include + +######################################################################## +# Gestion des dimensions du modele. +# on cree ou remplace le fichier des dimensions +######################################################################## + +cd $libf/grid +if ( -f dimensions.h ) then +echo 'ATTENTION: vous etes sans doute en train de compiler le modele par ailleurs' +echo "Attendez que la premiere compilation soit terminee pour relancer la suivante." +echo "Si vous etes sur que vous ne compilez pas le modele par ailleurs," +echo vous pouvez continuer en repondant oui. +echo "Voulez-vous vraiment continuer?" +if ( $< == "oui" ) then +\rm -f $libf/grid/dimensions.h +else +exit +endif +endif + +cd dimension +./makdim $dim +cat $libf/grid/dimensions.h + +cd $LMDGCM +set libo=$libo/$nomlib +if ( ! -d $libo ) then + mkdir $libo + cd $model +endif + +######################################################################## +# Differentes dynamiques (3d, 2d, 1d) +######################################################################## + +set dimension=`echo $dim | wc -w` +echo dimension $dimension +if ( $dimension == 1 ) then +echo pas de dynamique +set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique " +endif +endif +cd $model +if ( $dimension == 3 ) then +cd libf/grid +\rm fxyprim.h +cp -p fxy_${grille}.h fxyprim.h +endif + +###################################################################### +# Traitement special pour le nouveau rayonnement de Laurent Li. +###################################################################### + +#if ( -f $libf/phy$physique/raddim.h ) then +# if ( -f $libf/phy$physique/raddim.$dimh.h ) then +# \rm -f $libf/phy$physique/raddim.h +# cp -p $libf/phy$physique/raddim.$dimh.h $libf/phy$physique/raddim.h +# echo $libf/phy$physique/raddim.$dimh.h +# cat $libf/phy$physique/raddim.$dimh.h +# cat $libf/phy$physique/raddim.h +# else +# echo On peut diminuer la taille de l executable en creant +# echo le fichier $libf/phy$physique/raddim.$dimh.h +# \cp -p $libf/phy$physique/raddim.defaut.h $libf/phy$physique/raddim.h +# endif +#endif + +###################################################################### +# Gestion du filtre qui n'existe qu'en 3d. +###################################################################### + +if ( `expr $dimc \> 2` == 1 ) then + set filtre="FILTRE=$filtre" +else + set filtre="FILTRE= L_FILTRE= " +endif +echo MACRO FILTRE $filtre + +echo $dimc + +######################################################################## +# Avant de lancer le make, on recree le makefile si necessaire +######################################################################## +######################################################################## +# c'est a dire dans 3 cas: +# 1. si la liste des fichiers .F et .h a ete modifiee depuis la +# derniere creation du makefile +# 2. si le fichier contenant cette liste "liste_des_sources" +# n'existe pas. +# 3. Si le makefile n'existe pas. +######################################################################## +########################################## +# On adapte d'abord certains include à F90 +########################################## +########################################## +cd $model +find libf -name '*.[Fh]' -print >! tmp77 +find libf -name '*.[Fh]' -exec egrep -i " *use *ioipsl" {} \; -print >! tmp90 +find libf -name '*.[Fh]90' -print >> tmp90 + +if ( `diff tmp77 liste_des_sources_f77 | wc -w` \ + || `diff tmp90 liste_des_sources_f90 | wc -w` \ + || ! -f makefile \ + || ! -f liste_des_sources_f90 \ + || ! -f liste_des_sources_f77 ) then + echo les fichiers suivants ont ete crees ou detruits + echo ou les fichiers suivants sont passes ou ne sont plus en Fortran 90 + diff liste_des_sources_f77 tmp77 + diff liste_des_sources_f90 tmp90 + \cp tmp77 liste_des_sources_f77 + \cp tmp90 liste_des_sources_f90 + echo On recree le makefile + ./create_make_gcm >! tmp + \mv tmp makefile + echo Nouveau makefile cree. +endif + +######################################################################## +# Execution de la comande make +######################################################################## + +echo PHYSIQUE $phys +echo dynamique $dyn $dimension +echo OPTIM="$optim" $filtre LIBO=$libo $dyn PHYS=$phys DIM=$dimc PROG=$code +echo PATH pour les fichiers INCLUDE $include +echo OPLINK="$oplink" + +################# +if $HP then +################# + set f77='fort77 +OP' + set f90='jensaisrien' + set opt_link="$opt_link -lm" +################# +else if $VPP then +################# + set f77=frt + set f90=$f77 + if ($couple == true) then + set opt_link="-Wg,-c $MODIPSLDIR/liboasis2.4_mpi2.a /usr/lang/mpi2/lib64/libmpi.a /usr/lang/mpi2/lib64/libmp.a -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a" + set oplink="-Wl,-t,-P,-dy " + else + set opt_link="-Wg,-c -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a" + set oplink="-Wl,-t,-dy " + endif + if ($veget == true) then + set opt_link="$opt_link $link_veget -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a" + endif +################# +else if $CRAY then +################# + set f77=f90 + set f90=f90 +################# +else if $LINUX then +################# +# set f77=pgf90 +# set f90=pgf90 + set f77=$FC_LINUX + set f90=$FC_LINUX + if ( $FC_LINUX == 'pgf90' ) then + if ( $io == "ioipsl" ) then + set opt_link=" -L$MODIPSLDIR $link_veget -L$NCDFLIB -lioipsl -lnetcdf " + else + set opt_link=" -L$MODIPSLDIR $link_veget -L$NCDFLIB -lnetcdf " + endif + else if ($FC_LINUX == 'g95' || $FC_LINUX == 'gfortran' ) then + if ( $io == "ioipsl" ) then + set opt_link="-L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf -lioipsl -lnetcdf " + else + set opt_link="-L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf -lnetcdf " + endif + else + set opt_link=" " + endif +################# +else if $SUN then +################# + set f77=f90 + set f90=f90 + if ( $io == "ioipsl" ) then + set opt_link="-lf77compat -L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf " + else + set opt_link="-lf77compat -L$MODIPSLDIR $link_veget -L$NCDFLIB -lnetcdf " + endif +################# +else if $NEC then +################# + set f77=f90 -ftrace + set f90=f90 -ftrace + set opt_link="-L$MODIPSLDIR" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + set opt_link="$opt_link -lioipsl -loasis2.4_mpi2 -float0 -ew -P static $NCDFLIB " + else + set opt_link="$opt_link -L$MODIPSLDIR -lioipsl -float0 -ew -P static $NCDFLIB " + endif + set mod_loc_dir="./" +################# +else if $XNEC then +################# + set f77="sxmpif90 -ftrace" + set f90="sxmpif90 -ftrace" + if $MODIPSL then + set opt_link="-L$MODIPSLDIR" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + if ($psmile == true) then + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + else + set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 $optdbl -P static $NCDFLIB " + endif + else + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + endif + else + if ($couple == true) then + set opt_link="-L$MODIPSLDIR" + set opt_link="$opt_link $link_veget -lsxioipsl -loasis2.4_mpi2 -float0 $optdbl -P static $NCDFLIB " + else + set opt_link=" -C hopt -float0 $optdbl -P static -L$MODIPSLDIR $link_veget -lsxioipsl $NCDFLIB " + endif + endif + set mod_loc_dir="./" +################## +else if $X6NEC then +################## + set f77=sxmpif90 + set f90=sxmpif90 + if $MODIPSL then + set opt_link="$opt_link -L$MODIPSLDIR" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + if ($psmile == true) then + set opt_link="$opt_link -lsxioipsl -float0 -size_t64 $optdbl -P static $NCDFLIB " + else + set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 -size_t64 $optdbl -P static $NCDFLIB " + endif + else + set opt_link="$opt_link -lsxioipsl -float0 -size_t64 $optdbl -P static $NCDFLIB " + endif + else +# set opt_link=" -float0 -size_t64 $optdbl -P static -L$MODIPSLDIR -lsxsechiba -lsxparameters -lsxstomate -lsxioipsl $NCDFLIB " + set opt_link=" $opt_link -float0 -size_t64 $optdbl -P static -L$MODIPSLDIR -lsxioipsl $NCDFLIB " + + endif + set mod_loc_dir="./" +################## +else if $X8BRODIE then +################## + set f77=sxmpif90 + set f90=sxmpif90 + if $MODIPSL then + set opt_link="$opt_link -float0 -Wf,-A dbl4 -L$MODIPSLDIR -lblas" + if ($veget == true) then + set opt_link="$opt_link $link_veget" + endif + if ($couple == true) then + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + else + set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB " + endif + else +# set opt_link=" -float0 $optdbl -P static -L$MODIPSLDIR -lsxsechiba -lsxparameters -lsxstomate -lsxioipsl $NCDFLIB " + set opt_link=" -float0 $optdbl -P static -L$MODIPSLDIR -lsxioipsl $NCDFLIB -lblas" + + endif + set mod_loc_dir="./" +################# +else +################# + set f77=f77 + set f90=f90 +endif + +cd $model + +if $VPP then +set make="gmake RANLIB=ls" +else if $CRAY then +set make="make RANLIB=ls" +else if $NEC then +set make="make RANLIB=ls" +else if $LINUX then +set make="make -k RANLIB=ranlib" +else if $XNEC then +set make="gmake RANLIB=ls" +else if $X6NEC then +set make="gmake RANLIB=ls" +else if $X8BRODIE then +set make="gmake RANLIB=ls" +else +set make="make RANLIB=ranlib" +endif + + + + +# +# etat0_netcdf a besoin d'info de la physique +# A revoir +set include="$include"' -I$(LIBF)/phy'"$physique" +# +# le programme principal create_limit a besoin de l'info du module +# startvar: on met donc libo dans les include pour Nec +set include="$include"' -I$(LIBO)' + + +################################################################# +# Execution de la comande make... ENFIN! +################################################################# + +if $VPP then + set optim90=" $optim90 -Am -M$libo" + set optimtru90="$optim90" + \cp $IOIPSLDIR/*.mod $libo +else if $SUN then + set optim90=" $optim90 -M$libo -M$MODIPSLDIR " + set optimtru90=" $optimtru90 -M$libo -M$MODIPSLDIR " + set optim="$optim90" + \cp $IOIPSLDIR/*.mod $libo +else if $NEC then + set optim90=" $optim90 -I$libo " +else if $XNEC then + set optim90=" $optim90 -I$libo " + set optimtru90=" $optimtru90 -I$libo " +else if $X6NEC then + set optim90=" $optim90 -I$libo " + set optimtru90=" $optimtru90 -I$libo " +else if $X8BRODIE then + set optim90=" $optim90 -I$libo " + set optimtru90=" $optimtru90 -I$libo " +else if $LINUX then + if ( $FC_LINUX == "pgf90" ) then + set optimtru90=" $optimtru90 -module $libo " + set optim90=" $optim90 -module $libo " + else if ( $FC_LINUX == 'g95' ) then + set optimtru90=" $optimtru90 -fmod=$libo " + set optim90=" $optim90 -fmod=$libo " + else if ( $FC_LINUX == 'gfortran' ) then + set optimtru90=" $optimtru90 -M $libo " + set optim90=" $optim90 -M $libo " + endif + set optim="$optim90" + set mod_loc_dir=$libo +# \cp /d3/fairhead/sechiba/ioipsl/*.mod $libo +# \cp $IOIPSLDIR/*.mod $libo +endif + +set link="$f90 $optim90" + +set ar=ar + +if $XNEC then + set link="sxld $opt_link" + set link="$f90 " +# set ar=sxar +else if $X6NEC then + set link="sxld $opt_link" + set link="$f90 -Wl,-hlib_cyclic " +# set ar=sxar +else if $X8BRODIE then + set link="sxld $opt_link" + set link="$f90 -Wl,-hlib_cyclic " +# set ar=sxar +endif + + +cd $localdir + +set source_code=${code}.F +if ( -f $LMDGCM/libf/dyn${dimc}d${FLAG_PARA}/${code}.F90 ) then + set source_code=${code}.F90 +endif + +echo $make -f $LMDGCM/makefile \ +OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \ +OPTIM90="$optim90" \ +OPTIMTRU90="$optimtru90" \ +OPTIM="$optim$optimbis" \ +INCLUDE="$include" \ +$filtre \ +LIBO=$libo \ +$dyn \ +$phys \ +DIM=$dimc \ +FLAG_PARA="$FLAG_PARA"\ +L_ADJNT="$adjnt" \ +L_COSP="$lcosp" \ +L_CHIMIE="$libchimie" \ +LOCAL_DIR="$localdir" \ +F77="$f77" \ +F90="$f90" \ +OPLINK="$oplink" \ +LINK="$link" \ +GCM="$LMDGCM" \ +MOD_LOC_DIR=$mod_loc_dir \ +MOD_SUFFIX=$mod_suffix \ +AR=$ar \ +SOURCE=$source_code \ +PROG=$code + +$make -f $LMDGCM/makefile \ +OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \ +OPTIM90="$optim90" \ +OPTIMTRU90="$optimtru90" \ +OPTIM="$optim$optimbis" \ +INCLUDE="$include" \ +$filtre \ +LIBO=$libo \ +$dyn \ +$phys \ +DIM=$dimc \ +FLAG_PARA="$FLAG_PARA"\ +L_ADJNT="$adjnt" \ +L_COSP="$lcosp" \ +L_CHIMIE="$libchimie" \ +LOCAL_DIR="$localdir" \ +F77="$f77" \ +F90="$f90" \ +OPLINK="$oplink" \ +LINK="$link" \ +GCM="$LMDGCM" \ +MOD_LOC_DIR=$mod_loc_dir \ +MOD_SUFFIX=$mod_suffix \ +AR=$ar \ +SOURCE=$source_code \ +PROG=$code + +\rm -f $libf/grid/dimensions.h Index: LMDZ5/branches/LMDZ5_AR5/makelmdz =================================================================== --- LMDZ5/branches/LMDZ5_AR5/makelmdz (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/makelmdz (revision 1634) @@ -0,0 +1,606 @@ +#!/bin/bash +# +# $Id $ +# +# +######################################################################## +# for debug, uncomment line below +#set -xv +######################################################################## +# options par defaut pour la commande make +######################################################################## +dim="96x72x19" +physique=lmd +code=gcm +filtre=filtrez +grille=reg +couple=false +veget=false +chimie=false +parallel=none +compil_mod=prod +io=ioipsl +LIBPREFIX="" +fcm_path=none +cosp=false + +# guess a default 'arch' +arch="g95" # start with assuming we're on a Linux/Unix machine with g95 +## try to recognise machine and infer arch from it +machine=`hostname` +if [[ "$machine" == "brodie" ]] +then + arch="SX8_BRODIE" +fi +if [[ "${machine:0:6}" == "vargas" ]] +then + arch="PW6_VARGAS" +fi +if [[ "${machine:0:6}" == "ciclad" ]] +then + arch="AMD64_CICLAD" +fi +if [[ "${machine:0:7}" == "platine" ]] +then + arch="IA64_PLATINE" +fi +if [[ "${machine:0:6}" == "titane" ]] +then + arch="X64_TITANE" +fi +if [[ "${machine:0:8}" == "mercure1" ]] +then + arch="SX8_MERCURE" +fi +if [[ "${machine:0:8}" == "mercure2" ]] +then + arch="SX9_MERCURE" +fi + +LMDGCM=`pwd -P` +LIBFGCM=$LMDGCM/libf +LIBOGCM=$LMDGCM/libo +if [[ ! -d $LIBOGCM ]] +then + # create the directory + mkdir $LIBOGCM + if [[ ! $? ]] + then + echo "Failed to create directory $LIBOGCM" + exit + fi +fi +COSP_PATH=$LMDGCM/.void_dir + + + +localdir=`pwd -P` +######################################################################## +# Quelques initialisations de variables du shell. +######################################################################## + +CPP_KEY="" +INCLUDE='-I$(LIBF)/grid -I$(LIBF)/bibio -I$(LIBF)/filtrez -I. ' +LIB="" +adjnt="" +##COMPIL_FFLAGS="%PROD_FFLAGS" +PARA_FFLAGS="" +PARA_LD="" +EXT_SRC="" + +######################################################################## +# lecture des options +######################################################################## + +while (($# > 0)) + do + case $1 in + "-h") cat < .void_file +rm -rf .void_dir +mkdir .void_dir +rm -f arch.path +if [[ -r arch/arch-${arch}.path ]] +then + ln -s arch/arch-${arch}.path ./arch.path + source arch.path +else + echo "Error: missing arch/arch-${arch}.path file !" + exit +fi +rm -f arch.fcm +if [[ -r arch/arch-${arch}.fcm ]] +then + ln -s arch/arch-${arch}.fcm arch.fcm +else + echo "Error: missing arch/arch-${arch}.fcm file !" + exit +fi +######################################################################## +# Definition des clefs CPP, des chemins des includes et modules +# et des libraries +######################################################################## + +# basic compile flags from arch.fcm file +archfileline=$( grep -i '^%BASE_FFLAGS' arch.fcm ) +COMPIL_FFLAGS=$( echo ${archfileline##%BASE_FFLAGS} ) + +# other compile flags, depending on compilation mode +if [[ "$compil_mod" == "prod" ]] +then +## read COMPIL_FFLAGS from arch.fcm file + archfileline=$( grep -i '^%PROD_FFLAGS' arch.fcm ) + archfileopt=$( echo ${archfileline##%PROD_FFLAGS} ) + COMPIL_FFLAGS="${COMPIL_FFLAGS} ${archfileopt}" +elif [[ "$compil_mod" == "dev" ]] +then +## read %DEV_FFLAGS from arch.fcm file + archfileline=$( grep -i '^%DEV_FFLAGS' arch.fcm ) + archfileopt=$( echo ${archfileline##%DEV_FFLAGS} ) + COMPIL_FFLAGS="${COMPIL_FFLAGS} ${archfileopt}" +elif [[ "$compil_mod" == "debug" ]] +then +## read %DEBUG_FFLAGS from arch.fcm file + archfileline=$( grep -i '^%DEBUG_FFLAGS' arch.fcm ) + archfileopt=$( echo ${archfileline##%DEBUG_FFLAGS} ) + COMPIL_FFLAGS="${COMPIL_FFLAGS} ${archfileopt}" +fi + +# add CPP_KEY defined in arch.fcm file +archfileline=$( grep -i '^%FPP_DEF' arch.fcm ) +archfileopt=$( echo ${archfileline##%FPP_DEF} ) +CPP_KEY="$CPP_KEY ${archfileopt}" + +# get compiler name from arch.fcm file +archfileline=$( grep -i '^%COMPILER' arch.fcm ) +fcompiler=$( echo ${archfileline##%COMPILER} ) + +# get linker name from arch.fcm file +archfileline=$( grep -i '^%LINK' arch.fcm ) +linker=$( echo ${archfileline##%LINK} ) + +# get ar command from arch.fcm file +archfileline=$( grep -i '^%AR' arch.fcm ) +arcommand=$( echo ${archfileline##%AR} ) + +# get make utility from arch.fcm file +archfileline=$( grep -i '^%MAKE' arch.fcm ) +makecommand=$( echo ${archfileline##%MAKE} ) + +# get basic libraries to link with arch.fcm file +archfileline=$( grep -i '^%BASE_LD' arch.fcm ) +archfileopt=$( echo ${archfileline##%BASE_LD} ) +LIB="$LIB ${archfileopt}" + +if [[ "$physique" != "nophys" ]] +then + #Default planet type is Earth + CPP_KEY="$CPP_KEY CPP_EARTH" +fi + +if [[ "$chimie" == "INCA" ]] +then + CPP_KEY="$CPP_KEY INCA" + INCLUDE="$INCLUDE -I${INCA_INCDIR}" + LIB="$LIB -L${INCA_LIBDIR} -lchimie" + libchimie=" -L${INCA_LIBDIR} -lchimie" +fi + +if [[ "$couple" != "false" ]] +then + CPP_KEY="$CPP_KEY CPP_COUPLE" + INCLUDE="$INCLUDE -I${OASIS_INCDIR}" + LIB="$LIB -L${OASIS_LIBDIR} -lpsmile.${couple} -lmpp_io" +fi + +if [[ "$parallel" == "none" ]] +then + FLAG_PARA='' +else + FLAG_PARA="par" +fi + +if [[ "$parallel" == "mpi" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_MPI" + # MPI additional compilation options + archfileline=$( grep -i '^%MPI_FFLAGS' arch.fcm ) + PARA_FFLAGS=$( echo ${archfileline##%MPI_FFLAGS} ) + # MPI additional links + archfileline=$( grep -i '^%MPI_LD' arch.fcm ) + PARA_LD=$( echo ${archfileline##%MPI_LD} ) +elif [[ "$parallel" == "omp" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_OMP" + # OMP additional compilation options + archfileline=$( grep -i '^%OMP_FFLAGS' arch.fcm ) + PARA_FFLAGS=$( echo ${archfileline##%OMP_FFLAGS} ) + # OMP additional links + archfileline=$( grep -i '^%OMP_LD' arch.fcm ) + PARA_LD=$( echo ${archfileline##%OMP_LD} ) +elif [[ "$parallel" == "mpi_omp" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_MPI CPP_OMP" + # MPI additional compilation options + archfileline=$( grep -i '^%MPI_FFLAGS' arch.fcm ) + PARA_FFLAGS=$( echo ${archfileline##%MPI_FFLAGS} ) + # OMP additional compilation options + archfileline=$( grep -i '^%OMP_FFLAGS' arch.fcm ) + PARA_FFLAGS="${PARA_FFLAGS} "$( echo $archfileopt ${archfileline##%OMP_FFLAGS} ) + # MPI additional links + archfileline=$( grep -i '^%MPI_LD' arch.fcm ) + PARA_LD=$( echo ${archfileline##%MPI_LD} ) + # OMP additional links + archfileline=$( grep -i '^%OMP_LD' arch.fcm ) + PARA_LD="${PARA_LD} "$( echo $archfileopt ${archfileline##%OMP_LD} ) +fi + +if [[ ( "$parallel" == "omp" || "$parallel" == "mpi_omp" ) \ + && "$compil_mod" == "debug" ]] +then + echo "Usually, parallelization with OpenMP requires some optimization." + echo "We suggest switching to \"-dev\"." +fi + +if [[ "$veget" == "true" ]] +then + CPP_KEY="$CPP_KEY CPP_VEGET" + INCLUDE="${INCLUDE} -I${ORCH_INCDIR}" + LIB="${LIB} -L${ORCH_LIBDIR} -l${LIBPREFIX}sechiba -l${LIBPREFIX}parameters -l${LIBPREFIX}stomate -l${LIBPREFIX}parallel -l${LIBPREFIX}orglob" +fi + +if [[ $io == ioipsl ]] +then + CPP_KEY="$CPP_KEY CPP_IOIPSL" + INCLUDE="$INCLUDE -I${IOIPSL_INCDIR}" + LIB="$LIB -L${IOIPSL_LIBDIR} -l${LIBPREFIX}ioipsl" +fi + +if [[ "$cosp" == "true" ]] +then + CPP_KEY="$CPP_KEY CPP_COSP" + COSP_PATH="$LIBFGCM/cosp" +# LIB="${LIB} -l${LIBPREFIX}cosp" + opt_dep="$opt_dep cosp" + lcosp="-l${LIBPREFIX}cosp" + INCLUDE="$INCLUDE"' -I$(LIBF)/cosp' +fi + +INCLUDE="$INCLUDE ${NETCDF_INCDIR}" +LIB="$LIB ${NETCDF_LIBDIR}" + +######################################################################## +# calcul du nombre de dimensions +######################################################################## + + +dim_full=$dim +dim=`echo $dim | sed -e 's/[^0-9]/ /g'` +set $dim +dimc=$# +echo calcul de la dimension +echo dim $dim +echo dimc $dimc + + +######################################################################## +# Gestion des dimensions du modele. +# on cree ou remplace le fichier des dimensions +######################################################################## + +cd $LIBFGCM/grid/dimension +./makdim $dim +cat $LIBFGCM/grid/dimensions.h +cd $LMDGCM + + +######################################################################## +# Differentes dynamiques (3d, 2d, 1d) +######################################################################## + +dimension=`echo $dim | wc -w` +echo dimension $dimension + +if (( $dimension == 3 )) +then + cd $LIBFGCM/grid + \rm fxyprim.h + cp -p fxy_${grille}.h fxyprim.h +else + echo "Probleme dans les dimensions de la dynamique !!" + echo "Non reactive pour l'instant !!!" +fi + +###################################################################### +# Gestion du filtre qui n'existe qu'en 3d. +###################################################################### + +if (( `expr $dimc \> 2` == 1 )) +then + filtre="FILTRE=$filtre" +else + filtre="FILTRE= L_FILTRE= " +fi +echo MACRO FILTRE $filtre + +echo $dimc + +###################################################################### +# Creation du suffixe de la configuration +###################################################################### + + +SUFF_NAME=_${dim_full} +SUFF_NAME=${SUFF_NAME}_phy${physique} + +if [[ "$parallel" != "none" ]] +then + SUFF_NAME=${SUFF_NAME}_para + DYN=dyn${dimc}dpar +else + SUFF_NAME=${SUFF_NAME}_seq + DYN=dyn${dimc}d +fi + +if [[ $veget == "true" ]] +then + SUFF_NAME=${SUFF_NAME}_orch +fi + +if [[ $couple != "false" ]] +then + SUFF_NAME=${SUFF_NAME}_couple +fi + +if [[ $chimie == "INCA" ]] +then + SUFF_NAME=${SUFF_NAME}_inca +fi + +cd $LMDGCM + + +######################################################################## +# Avant de lancer le make, on recree le makefile si necessaire +######################################################################## +######################################################################## +# c'est a dire dans 3 cas: +# 1. si la liste des fichiers .F et .h a ete modifiee depuis la +# derniere creation du makefile +# 2. si le fichier contenant cette liste "liste_des_sources" +# n'existe pas. +# 3. Si le makefile n'existe pas. +######################################################################## +cd $LMDGCM +find libf -name '*.[Fh]' -print > tmp77 +find libf -name '*.[Fh]' -exec egrep -i " *use *ioipsl" {} \; -print > tmp90 +find libf -name '*.[Fh90]' -print >> tmp90 + +if [[ ! ( -r makefile ) || ! ( -r liste_des_sources_f90 ) || ! ( -r liste_des_sources_f77 ) || ` diff tmp77 liste_des_sources_f77 | wc -w ` -ne 0 || ` diff tmp90 liste_des_sources_f90 | wc -w ` -ne 0 ]] +then + echo "les fichiers suivants ont ete crees ou detruits" + echo "ou les fichiers suivants sont passes ou ne sont plus en Fortran 90" + diff liste_des_sources_f77 tmp77 + diff liste_des_sources_f90 tmp90 + \cp -f tmp77 liste_des_sources_f77 + \cp -f tmp90 liste_des_sources_f90 + echo "on recree le makefile" + ./create_make_gcm > tmp + \mv -f tmp makefile + echo "Nouveau makefile cree" +fi + +################################################################# +# Preparation de l'execution de la comande make +################################################################# + +source_code=${code}.F +if [[ -r $LMDGCM/libf/dyn${dimc}d${FLAG_PARA}/${code}.F90 ]] +then + source_code=${code}.F90 +fi + +# library directory name: +if [[ "$parallel" == "none" ]] +then + nomlib=${arch}_${physique}_${dim_full}_${grille}_${compil_mod} +else + nomlib=${arch}_${physique}_${dim_full}_${grille}_${compil_mod}_${FLAG_PARA} +fi + +if [[ ! -d "${LIBOGCM}/${nomlib}" ]] +then + mkdir ${LIBOGCM}/${nomlib} + # check we indeed managed to create the directory + if [[ ! $? ]] + then + echo "Error: could not create directory ${LIBOGCM}/${nomlib}" + exit + fi +fi + +# where module files are created +mod_loc_dir=$localdir + +if [[ "$physique" != "nophys" ]] +then + INCLUDE="$INCLUDE"' -I$(LIBF)/phy'"$physique" +fi +INCLUDE="$INCLUDE"' -I$(LIBF)/dyn'${dimc}'d'$FLAG_PARA' -I'${LIBOGCM}/${nomlib} + +# ranlib utility (check it exists or else default to ls) +if [[ `which ranlib > /dev/null 2>&1 ; echo $?` -eq 0 ]] +then + ranlib="ranlib" +else + ranlib="ls" +fi + +# add CPP keys to COMPIL_FLAGS +# (but first add -D before all CPP_KEY items) +cpp_definitions=`echo $CPP_KEY | sed -e 's/[A-Za-z_=0-9]*/-D&/g'` +# (but add a -WF,-D before all CPP_KEY items) => for xlf on Vargas +if [[ "${fcompiler:0:3}" == "xlf" ]] +then +cpp_definitions=`echo $CPP_KEY | sed -e 's/[A-Za-z_=0-9]*/-WF,-D&/g'` +fi +COMPIL_FFLAGS="${COMPIL_FFLAGS} ${cpp_definitions}" + +################################################################# +# Execution du make +################################################################# +echo $makecommand RANLIB=$ranlib -f $LMDGCM/makefile \ +OPTION_DEP="$opt_dep" OPTION_LINK="$LIB ${PARA_LD}" \ +OPTIM90="${COMPIL_FFLAGS} ${PARA_FFLAGS}" \ +OPTIMTRU90="${COMPIL_FFLAGS} ${PARA_FFLAGS}" \ +OPTIM="${COMPIL_FFLAGS} ${PARA_FFLAGS}" \ +INCLUDE="$INCLUDE" \ +$filtre \ +LIBO=${LIBOGCM}/${nomlib} \ +"PHYS=$physique" \ +DIM=$dimc \ +FLAG_PARA=$FLAG_PARA \ +L_ADJNT=$adjnt \ +L_COSP="$lcosp" \ +L_CHIMIE="$libchimie" \ +LOCAL_DIR="$localdir" \ +F77="$fcompiler" \ +F90="$fcompiler" \ +OPLINK="$LIB" \ +LINK="$linker" \ +GCM="$LMDGCM" \ +MOD_LOC_DIR=$mod_loc_dir \ +MOD_SUFFIX="mod" \ +AR=$arcommand \ +SOURCE=$source_code \ +PROG=$code + +$makecommand RANLIB=$ranlib -f $LMDGCM/makefile \ +OPTION_DEP="$opt_dep" OPTION_LINK="$LIB ${PARA_LD}" \ +OPTIM90="${COMPIL_FFLAGS} ${PARA_FFLAGS}" \ +OPTIMTRU90="${COMPIL_FFLAGS} ${PARA_FFLAGS}" \ +OPTIM="${COMPIL_FFLAGS} ${PARA_FFLAGS}" \ +INCLUDE="$INCLUDE" \ +$filtre \ +LIBO=${LIBOGCM}/${nomlib} \ +"PHYS=$physique" \ +DIM=$dimc \ +FLAG_PARA=$FLAG_PARA \ +L_ADJNT="$adjnt" \ +L_COSP="$lcosp" \ +L_CHIMIE="$libchimie" \ +LOCAL_DIR="$localdir" \ +F77="$fcompiler" \ +F90="$fcompiler" \ +OPLINK="$LIB" \ +LINK="$linker" \ +GCM="$LMDGCM" \ +MOD_LOC_DIR=$mod_loc_dir \ +MOD_SUFFIX="mod" \ +AR=$arcommand \ +SOURCE=$source_code \ +PROG=$code + +if [[ -r $libf/grid/dimensions.h ]] +then + # Cleanup: remove dimension.h file + \rm -f $libf/grid/dimensions.h +fi Index: LMDZ5/branches/LMDZ5_AR5/makelmdz_fcm =================================================================== --- LMDZ5/branches/LMDZ5_AR5/makelmdz_fcm (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/makelmdz_fcm (revision 1634) @@ -0,0 +1,412 @@ +#!/bin/bash +# $Id$ +# This is a script in Bash. + +# FH : on ne crée plus le fichier arch.mk qui est supposé exister par +# FH : ailleurs. +# FH : ulterieurement, ce fichier sera pré-existant pour une série +# FH : de configurations en versions optimisées et debug qui seront +# FH : liés (ln -s) avec arch.mk en fonction de l'architecture. +# FH : Pour le moment, cette version est en test et on peut créer les +# FH : arch.mk en lançant une première fois makegcm. +# +##set -x +######################################################################## +# options par defaut pour la commande make +######################################################################## + +dim="96x72x19" +physique=lmd +filtre=filtrez +grille=reg +couple=false +veget=false +chimie=false +parallel=none +compil_mod=prod +io=ioipsl +LIBPREFIX="" +fcm_path=none +cosp=false + +LMDGCM=`/bin/pwd` +LIBOGCM=$LMDGCM/libo +LIBFGCM=$LMDGCM/libf +COSP_PATH=$LMDGCM/.void_dir + +######################################################################## +# Quelques initialisations de variables du shell. +######################################################################## + +CPP_KEY="" +INCLUDE="" +LIB="" +adjnt="" +COMPIL_FFLAGS="%PROD_FFLAGS" +PARA_FFLAGS="" +PARA_LD="" +EXT_SRC="" + +######################################################################## +# lecture des options de mymake +######################################################################## + +while (($# > 0)) + do + case $1 in + "-h") cat < .void_file +rm -rf .void_dir +mkdir .void_dir +rm -f arch.path +ln -s arch/arch-${arch}.path ./arch.path +source arch.path + +######################################################################## +# Definition des clefs CPP, des chemins des includes et modules +# et des libraries +######################################################################## + +if [[ "$compil_mod" == "prod" ]] +then + COMPIL_FFLAGS="%PROD_FFLAGS" +elif [[ "$compil_mod" == "dev" ]] +then + COMPIL_FFLAGS="%DEV_FFLAGS" +elif [[ "$compil_mod" == "debug" ]] +then + COMPIL_FFLAGS="%DEBUG_FFLAGS" +fi + +if [[ "$physique" != "nophys" ]] +then + #Default planet type is Earth + CPP_KEY="$CPP_KEY CPP_EARTH" +fi + +if [[ "$chimie" == "INCA" ]] +then + CPP_KEY="$CPP_KEY INCA" + INCLUDE="$INCLUDE -I${INCA_INCDIR}" + LIB="$LIB -L${INCA_LIBDIR} -lchimie" +fi + +if [[ "$couple" != "false" ]] +then + CPP_KEY="$CPP_KEY CPP_COUPLE" + INCLUDE="$INCLUDE -I${OASIS_INCDIR}" + LIB="$LIB -L${OASIS_LIBDIR} -lpsmile.${couple} -lmpp_io" +fi + +if [[ "$parallel" == "mpi" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_MPI" + PARA_FFLAGS="%MPI_FFLAGS" + PARA_LD="%MPI_LD" +elif [[ "$parallel" == "omp" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_OMP" + PARA_FFLAGS="%OMP_FFLAGS" + PARA_LD="%OMP_LD" +elif [[ "$parallel" == "mpi_omp" ]] +then + CPP_KEY="$CPP_KEY CPP_PARA CPP_MPI CPP_OMP" + PARA_FFLAGS="%MPI_FFLAGS %OMP_FFLAGS" + PARA_LD="%MPI_LD %OMP_LD" +fi + +if [[ ( "$parallel" == "omp" || "$parallel" == "mpi_omp" ) \ + && "$compil_mod" == "debug" ]] +then + echo "Usually, parallelization with OpenMP requires some optimization." + echo "We suggest switching to \"-dev\"." +fi + +if [[ "$veget" == "true" ]] +then + CPP_KEY="$CPP_KEY CPP_VEGET" + INCLUDE="${INCLUDE} -I${ORCH_INCDIR}" + LIB="${LIB} -L${ORCH_LIBDIR} -l${LIBPREFIX}sechiba -l${LIBPREFIX}parameters -l${LIBPREFIX}stomate -l${LIBPREFIX}parallel -l${LIBPREFIX}orglob" +fi + +if [[ $io == ioipsl ]] +then + CPP_KEY="$CPP_KEY CPP_IOIPSL" + INCLUDE="$INCLUDE -I${IOIPSL_INCDIR}" + LIB="$LIB -L${IOIPSL_LIBDIR} -l${LIBPREFIX}ioipsl" +fi +if [[ "$cosp" == "true" ]] +then + CPP_KEY="$CPP_KEY CPP_COSP" + COSP_PATH="$LIBFGCM/cosp" +# LIB="${LIB} -l${LIBPREFIX}cosp" +fi + +INCLUDE="$INCLUDE ${NETCDF_INCDIR}" +LIB="$LIB ${NETCDF_LIBDIR}" + +######################################################################## +# calcul du nombre de dimensions +######################################################################## + + +dim_full=$dim +dim=`echo $dim | sed -e 's/[^0-9]/ /g'` +set $dim +dimc=$# +echo calcul de la dimension +echo dim $dim +echo dimc $dimc + + +######################################################################## +# Gestion des dimensions du modele. +# on cree ou remplace le fichier des dimensions +######################################################################## + +cd $LIBFGCM/grid/dimension +./makdim $dim +cat $LIBFGCM/grid/dimensions.h +cd $LMDGCM + + +######################################################################## +# Differentes dynamiques (3d, 2d, 1d) +######################################################################## + +dimension=`echo $dim | wc -w` +echo dimension $dimension + +if (( $dimension == 3 )) +then + cd $LIBFGCM/grid + \rm fxyprim.h + cp -p fxy_${grille}.h fxyprim.h +else + echo "Probleme dans les dimensions de la dynamique !!" + echo "Non reactive pour l'instant !!!" +fi + +###################################################################### +# Traitement special pour le nouveau rayonnement de Laurent Li. +# ---> YM desactive pour le traitemement en parallele +###################################################################### + +#if [[ -f $libf/phy$physique/raddim.h ]] +#then +# if [[ -f $libf/phy$physique/raddim.$dimh.h ]] +#then +# \rm -f $libf/phy$physique/raddim.h +# cp -p $libf/phy$physique/raddim.$dimh.h $libf/phy$physique/raddim.h +# echo $libf/phy$physique/raddim.$dimh.h +# cat $libf/phy$physique/raddim.h +# else +# echo On peut diminuer la taille de l executable en creant +# echo le fichier $libf/phy$physique/raddim.$dimh.h +# \cp -p $libf/phy$physique/raddim.defaut.h $libf/phy$physique/raddim.h +# fi +#fi + +###################################################################### +# Gestion du filtre qui n'existe qu'en 3d. +###################################################################### + +if (( `expr $dimc \> 2` == 1 )) +then + filtre="FILTRE=$filtre" +else + filtre="FILTRE= L_FILTRE= " +fi +echo MACRO FILTRE $filtre + +echo $dimc + + + +###################################################################### +# Creation du suffixe de la configuration +###################################################################### + + +SUFF_NAME=_${dim_full} +SUFF_NAME=${SUFF_NAME}_phy${physique} + +if [[ "$parallel" != "none" ]] +then + SUFF_NAME=${SUFF_NAME}_para + DYN=dyn${dimc}dpar +else + SUFF_NAME=${SUFF_NAME}_seq + DYN=dyn${dimc}d +fi + +if [[ $veget == "true" ]] +then + SUFF_NAME=${SUFF_NAME}_orch +fi + +if [[ $couple != "false" ]] +then + SUFF_NAME=${SUFF_NAME}_couple +fi + +if [[ $chimie == "INCA" ]] +then + SUFF_NAME=${SUFF_NAME}_inca +fi + +cd $LMDGCM +config_fcm="config.fcm" +rm -f $config_fcm +touch $config_fcm +rm -f bin/${code}${SUFF_NAME}.e +rm -f arch.fcm +rm -f arch.opt + +echo "%ARCH $arch" >> $config_fcm +echo "%INCDIR $INCLUDE" >> $config_fcm +echo "%LIB $LIB" >> $config_fcm +echo "%ROOT_PATH $PWD" >> $config_fcm +echo "%LIBF $LIBFGCM" >> $config_fcm +echo "%LIBO $LIBOGCM" >> $config_fcm +echo "%DYN $DYN" >> $config_fcm +echo "%PHYS phy${physique}" >> $config_fcm +echo "%COSP $COSP_PATH" >> $config_fcm +echo "%CPP_KEY $CPP_KEY" >> $config_fcm +echo "%EXEC $code" >> $config_fcm +echo "%SUFF_NAME $SUFF_NAME" >> $config_fcm +echo "%COMPIL_FFLAGS $COMPIL_FFLAGS" >> $config_fcm +echo "%PARA_FFLAGS $PARA_FFLAGS" >> $config_fcm +echo "%PARA_LD $PARA_LD" >> $config_fcm +echo "%EXT_SRC $EXT_SRC" >> $config_fcm + + + +ln -s arch/arch-${arch}.fcm arch.fcm +if test -f arch/arch-${arch}.opt && [ $compil_mod = "prod" ] + then + ln -s arch/arch-${arch}.opt arch.opt +else + ln -s .void_file arch.opt +fi + + +rm -f $LIBOGCM/${arch}${SUFF_NAME}/.config/fcm.bld.lock +./build_gcm + +rm -rf tmp_src +rm -rf config +ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config config +ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config/tmp tmp_src Index: LMDZ5/branches/LMDZ5_AR5/offline.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/offline.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/offline.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/offline.def Index: LMDZ5/branches/LMDZ5_AR5/orchidee.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/orchidee.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/orchidee.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/orchidee.def Index: LMDZ5/branches/LMDZ5_AR5/output.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/output.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/output.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/output.def Index: LMDZ5/branches/LMDZ5_AR5/physiq.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/physiq.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/physiq.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/physiq.def Index: LMDZ5/branches/LMDZ5_AR5/run.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/run.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/run.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/run.def Index: LMDZ5/branches/LMDZ5_AR5/traceur.def =================================================================== --- LMDZ5/branches/LMDZ5_AR5/traceur.def (revision 1634) +++ LMDZ5/branches/LMDZ5_AR5/traceur.def (revision 1634) @@ -0,0 +1,1 @@ +link DefLists/traceur.def