#!/bin/sh ############################################################################### # Apr 01/2015 - ML. --- v01 --- # 1. This file is the official CGCM basefile for frozen area version CanAM4.4 # (gcm18-based). ############################################################################### set -a . betapath2 # sets path for beta test version of new diagnostics package # * ........................... Parmsub Parameters ............................ runid=ctest5; uxxx=mc; prefix="${uxxx}_${runid}"; crawork=ctest5; RUNID=CTEST5; username=acrnrml; user=LAZARE; nqsprfx=''; nqsext="_${runid}"; modver=gcm18 gcmparm=gcmparm ; stime=900 ; memory1=1000mb lopgm=lopgm; oldiag=diag4; if [ 1 -eq 2 ]; then #=#=#=#=# Use when the AGCM is coupled with NEMO via CanCPL # NOTE: use_NEMO must be defined in the CPP_I section use_nemo=on use_cancpl=on nproc_a=4 nnode_a=16 nproc_o=1 nemo_jpni=8 nemo_jpnj=6 nnode_o=48 nproc_c=1 nnode_c=1 node1='('`perl -e'$a= 0; $b= 7; for($a..$b){if($_<$b){printf "%d,",$_}else{printf "%d",$_}}'`')' node2='('`perl -e'$a= 8; $b=15; for($a..$b){if($_<$b){printf "%d,",$_}else{printf "%d",$_}}'`')' if [ $nnode_o -eq 1 ]; then node3='(16,17)' else node3='('`perl -e'$a=16; $b=64; for($a..$b){if($_<$b){printf "%d,",$_}else{printf "%d",$_}}'`')' fi geometry='{'$node1$node2$node3'}' elif [ 1 -eq 1 ]; then #=#=#=#=# Use when the AGCM is coupled but atm boundary conditions are read from a file # NOTE: use_NEMO must not be defined in the CPP_I section use_nemo=off use_cancpl=on nproc_a=4 nnode_a=16 nproc_o=1 nnode_o=0 nproc_c=1 nnode_c=1 node1='('`perl -e'$a= 0; $b= 7; for($a..$b){if($_<$b){printf "%d,",$_}else{printf "%d",$_}}'`')' node2='('`perl -e'$a= 8; $b=16; for($a..$b){if($_<$b){printf "%d,",$_}else{printf "%d",$_}}'`')' geometry='{'$node1$node2'}' else #=#=#=#=# Use when the AGCM is coupled with CanOM # NOTE: use_NEMO must not be defined in the CPP_I section use_nemo=off nproc_a=4 nnode_a=16 nproc_o=32 nnode_o=1 nproc_c=1 if [ 1 -eq 1 ]; then # These values of nnode_c and geometry are required to run with the new coupler nnode_c=1 geometry='{(0,1,2,3,4,5,6,7)(8,9,10,11,12,13,14,15)(16,17)}' # use_cancpl = on means couple via CanCPL # NOTE: The preprocessor token use_cancpl must be defined in the CPP_I section use_cancpl=on else # These values for nnode_c and geometry are required to run with old coupler nnode_c=0 geometry='{(0,1,2,3,4,5,6,7)(8,9,10,11,12,13,14,15)(16)}' # use_cancpl = off means use the old coupler # NOTE: The preprocessor token use_cancpl must not be defined in the CPP_I section use_cancpl=off fi fi gcm_inpfls_extra=gcm_inpfls_extra2 # * ............................ Condef Parameters ............................ samerun=on openmp=on coupled=on parallel_io=off script=off noprint=on nextjob=on # Alternate path to a directory where .queue/.crawork will be found JHOME='' # Assign variables with the values of HOME and JHOME that have any # trailing slash removed, to be used in the following comparison jhomenoslash=`echo $JHOME|sed 's/\/$//'` homenoslash=`echo $HOME|sed 's/\/$//'` # If JHOME is set and not equal to HOME then JHOME is in use if [ -n "$JHOME" -a x"$jhomenoslash" != x"$homenoslash" ]; then # Allow optional reset of DATAPATH/RUNPATH JHOME_DATA='' DATAPATH=${JHOME_DATA:=$DATAPATH} RUNPATH=${JHOME_DATA:=$RUNPATH} fi # * ............................. Deck Definition ............................. # NOTE: Changes to multisub.cdk are required to pass nnode_c and nproc_c # to gcmjcl from gcmsub . gcmsub.dk cat > Model_Input <<'end_of_data' ### gcmparm ### ### parmsub ### . betapath2 # sets path for beta test version of new diagnostics package # Alternate path to a directory where .queue/.crawork will be found JHOME='' # Assign variables with the values of HOME and JHOME that have any # trailing slash removed, to be used in the following comparison jhomenoslash=`echo $JHOME|sed 's/\/$//'` homenoslash=`echo $HOME|sed 's/\/$//'` # If JHOME is set and not equal to HOME then JHOME is in use if [ -n "$JHOME" -a x"$jhomenoslash" != x"$homenoslash" ]; then # Allow optional reset of DATAPATH/RUNPATH JHOME_DATA='' DATAPATH=${JHOME_DATA:=$DATAPATH} RUNPATH=${JHOME_DATA:=$RUNPATH} fi # * ........................... Parmsub Parameters ........................... runid=job000; uxxx=mc; prefix="${uxxx}_${runid}"; crawork=${runid}_job; RUNID=`echo "${runid}"|tr '[a-z]' '[A-Z]'`; username="acrnxxx"; user="XXX"; nqsprfx=''; nqsext="_${runid}"; year="yyy"; mon="mm"; year_restart="yyy"; mon_restart="mm"; months=1; kfinal="0000000000"; model=${prefix}_${year}_m${mon}_; start=${prefix}_${year_restart}_m${mon_restart}_; job="$runid"; run="${RUNID}_${year}_M${mon}"; initime=1801; initmem="15000mb"; gcmtime=18000; gcmmem="15000mb"; iyear=" 1850"; iday=" 001"; gmt=" 0.00"; incd=" 1"; lopgm=lopgm; isoc=" 1"; ires=" 1"; ifdiff=" 0"; isen=" 1"; issp=" 24"; isgg=" 24"; israd=" 12"; isbeg=" 12"; jlatpr=" 0";icsw=" 4"; iclw=" 4"; iepr=" 0"; istr=" 24"; ishf=" 0"; # A netcdf file containing the horizontal grid description for the atm atm_grid_desc=grid_desc_t63_o_gcm3.5_landmask_128x64v5.nc # A netcdf file containing the horizontal grid description for the ocean # ocn_grid_desc=grid_desc_ocnt_o_uwl_canesm4_1_1_256x192l40_datadesc.nc ocn_grid_desc=grid_desc_orca1_nemo_3.4_orca1_coordinates_ukorca1_with_mask.nc # A netcdf file containing the horizontal grid description for the CanOM4 ocean # canom4_grid_desc=grid_desc_ocnt_o_uwl_canesm4_1_1_256x192l40_datadesc.nc # A restart from a CanESM4 coupled run # canesm4_cpl_restart=mc_cpl_gcm18_init_2320_m12_cs # Residual climatology resid=pa_gcm17_mix18_64bit_2004m01_2008m12_res; # "myrfile" is the name of the multi-year boundary forcing file if running # in that mode. One needs to set "myrssti=on" in the gcmjcl condef section # AND activate "#define myrssti"! # myrfile=ml_iflm1_caspian_orca_td_cfsrv2_128x64_1979m01_2014m05 myrfile=ml_iflm1_orca_td_cfsrv2_128x64_1979m01_2014m05 # myrfile=amipbc_ar5_128x64_1870_2010m03; # myrfile=td_cfsr-cfsv2-amip_197901_201405_gp_128_64; pakgcm=pakgcm9 icntrldat=icntrldat2 nlcjcl=nlcjcl2 gpinit=ie791gp inatmo=inatmo12 inphys=inphys19 llphys=iph18lp veg=glc2000_1_12x1_12_v2 soci=mksmksrf_soilcol_global_c090324_cccma oz=ozclim_zonal oz_chem=randel_ozclim_3d_1980_1999 # oz_rad_trans/oz_chem_trans are the names of the transient ozone concentration data # (rcp26,rcp45,rcp85 - choose one!). # NOTE!!! Use rcp45 for historical runs!!!! oz_rad_trans=rcp45_ozone_rad_1850_2100_monthly_128_64 oz_chem_trans=rcp45_ozone_chem_1850_2100_monthly_128_64 ssti=ssti_amip2_360_180 oxi=iphoxlp mtnfile=opt_phis_t63 spfilt=hoskfilt_r_12_n61_t63_tst maskfile=t63_to_orca1_grid_cell_fraction_129x64 flak=uva_lake_frac_t63_from_jos_aug_2016 subfle=etopo5_gau_020_opt_200_129_64 albtable=nasa_albedo_lookup_table_v3 snow_rt_lut=snow_rt_lut2 # files for PLA. actdat0=urks_actdat0 actdat1=urks_actdat1 coagdat=urks_coagdat amdat=urks_amdat4 ssdat=urks_ssdat # llchem is the name of the non-transient aerosol emissions forcing data. # llchem=ipemi_cl_128_64; # llchem=ipemi_cl_128_64_duemi_orilai; llchem=ipemi_cl_128_64_duemi_orilai_l10; # lltrans is the name of the transient aerosol emissions forcing data. # Historic+Future (IPCC) for RCP2.6, RCP4.5 and RCP8.5 (rcp26,rcp45,rcp85 - choose one!): # NOTE!!! Use rcp45 for historical runs!!!! lltrans=urks_ar5_rcp45_1850_2100_128_64_int; # lltrans=emi_ar5_rcp45_1850_2100_128_64; # Old Historic to 2005(IPCC): # lltrans=emi_ipcc_hist_128_64; # Historic (old approach): # lltrans=ipchmphs_tr_128_64; # The "em_aerosols" parameter determines the emissions to be used from sources # which **could** be transient in nature, as follows: # # em_aerosols = -1 continuously update aerosol emissions time series from data in the file "lltrans" # = -YYYYMM use an annual cycle from year abs(YYYYMM)/100 in the file "lltrans" # = 0 use AEROCOMM data which has repeated annual cycle # NOTE!!! For now, there must be a consistency between this switch and the cpp directive # "transient_aerosol_emissions" in the CPP_I section. That is, for em_aerosols=0, # one must use "#undef transient_aerosol_emissions" and alternatively otherwise, # "#def transient_aerosol_emissions". There is a consistency check done in the # AGCM driver to ensure that this does not slip under the radar. Once the # methodology is in place, the direct cpp directive will be removed and these # comments modified to reflect the documentation of how things are done. em_aerosols=-1 # The "conc_ozone" parameter determines concentrations which **could** be transient in nature, as follows: # # conc_ozone = -1 continuously update ozone concentrations form data in the file "oztrans" # = -YYYYMM use an annual cycle from year abs(YYYYMM)/100 in the file "oztrans" # = 0 use the data in the file "ozclim_zonal", which has repeated annual cycle # NOTE!!! For now, there must be a consistency between this switch and the cpp directive # "transient_ozone_concentrations" in the CPP_I section. That is, for conc_ozone=0, # one must use "#undef transient_ozone_concentrations" and alternatively otherwise, # "#def transient_ozone_concentrations". There is a consistency check done in the # AGCM driver to ensure that this does not slip under the radar. Once the # methodology is in place, the direct cpp directive will be removed and these # comments modified to reflect the documentation of how things are done. conc_ozone=-1 # ghg_scenario is the name of a file containing GHG time series data # If ghg_scenario is not set then GHG time series will be generated internally # ghg_scenario=ipcc4_ghg_a1b_1850-2100 # ghg_internal_init determines which scenario will be used when GHG time # series are initialized internally (when ghg_scenario is undefined or null) # ghg_internal_init=0 #=> SRES A1B # ghg_internal_init=1 #=> RCP-3PD # ghg_internal_init=2 #=> RCP-4.5 # ghg_internal_init=3 #=> RCP-8.5 # ghg_internal_init=4 #=> RCP-6.0 ghg_internal_init=2 # The ghg_xxx parameters determine how the data in ghg_scenario # is to be interpolated. ghg_xxx is one of # ghg_co2, ghg_ch4, ghg_n2o, ghg_cfc11, ghg_cfc12, ghg_cfc113, ghg_cfc114 # # ghg_xxx = -1 continuously update GHG time series from data in the file # = YYYYMMDD use a constant value from YYYY/MM/DD # = -YYYYMM use an annual cycle from year abs(YYYYMM)/100 # = 0 use a default constant value (the value set in radcons4) # The default value when ghg_xxx is not set is "0" ghg_co2=-1 ghg_ch4=-1 ghg_n2o=-1 ghg_cfc11=-1 ghg_cfc12=-1 # datadest=pollux; datadir=/data/ccrn/r04 # solvarfile contains time depent values of perturbations to the solar constant # broken down into separate values for radiation bands and sub bands solvarfile=hist_15g_solar_cmip5_lean_6may09_1850_2300_monthly_anom # Volcanic aerosol optical depths from Sato et al (4 lat bands, monthly) # vtaufile=ver_sol_2011_volcanic_tau_t63_1985_2022_monthly vtaufile=sato_volcanic_4_tau_t63_1850_2300_monthly # Tropopause climatology derived from a 5 year t63, 71 level gcm13d run tropclim=trop_clim_ms_z_t63_monthly # em_xxx = -1 continuously update emission from 1850 to 2100 # = yyyymmdd use the emission of day "dd" of month "mm" of the year "yyyy" # = -YYYYMM use an annual cycle from year abs(YYYYMM)/100 # = 0 turn it off # # em_xxx_offset = offset between model year and calendar year (model + offset = calendar) emis_co2_file="co2_nolu_rcp45_1850-2100_128x64_mm" em_co2=" 0"; em_co2_offset="00000"; # initpool = 0 initialize pools from zero # = year initialize pools from that year from file on disk # = negative value initialize pools from coupler restart file # # lndcvrmod = 12345 continuously update land cover from 1850 to 2100 # = year use the land cover of July of that year continously # # lndcvr_offset = offset between model year and calendar year (model + offset = calendar) # the following line initializes CTEM pools from zero # initpool="00000"; lndcvrmod="01850"; lndcvr_offset="00000"; initpool="-1000"; lndcvrmod="12345"; lndcvr_offset="00000"; ctem_an="uvalsml_t63_ctem_an_file_with_wetlands"; lndcvr="uvalsml_luh_av1_1850_2100_rcp45_land_cover_crops_linear_128_64"; # T63 iron mask ironmask="uwl_t63_ironmask_256x192l40_10_levels_only" # The following radiative forcing parameters are only used when # "#define radforce" is defined in the model update section below. # assign the radiative forcing scenario identifier # valid values :: SRESA1B SRESA2 SRESB1 2XCO2 4XCO2 2X4XCO2 CFMIPA RF_SCENARIO=CFMIPA #RF_SCENARIO=AERORF #RF_SCENARIO=PAMRF # trop_idx is the model level index at which the tropopause is assumed # to exist for the adjusted radiative forcing case. If trop_idx=0 then # instantaneous radiative forcing will be used. If trop_idx<0 then a # tropopause height will be generated internally by the model. trop_idx=-1 # adjusted radiative forcing # trop_idx=0 # instantaneous radiative forcing # start_year_r is the starting year for an IPCC experiment (e.g. 1850) # It is used only in certain scenarios, currently SRESA1B SRESA2 and SRESB1 start_year_r=1850 # NRFP is the number of secondary radiation calls that will be made # This must be consistent with the value of RF_SCENARIO case $RF_SCENARIO in SRESA1B|SRESA2|SRESB1) NRFP=1 start_year_r=1850 ;; 2XCO2) NRFP=1 ;; 2X4XCO2) NRFP=2 ;; CFMIPA) NRFP=3 ;; AERORF) NRFP=6 ;; PAMRF) NRFP=6 ;; *) NRFP=1 ;; esac # Required parmsub parameters for gcmparm # (* denotes a critical parameter which must appear in the ##PARC section) #ex * ilev = number of vertical model levels (e.g. 35) #ex * levs = number of vertical moisture levels (e.g. 35) #ex * lonsld = number of longitudes on the dynamics grid (e.g. 144) #ex * nlatd = number of gaussian latitudes on the dynamics grid (e.g. 72) #ex lond = number of grid points per slice for dynamics (e.g. 144) #ex * lonsl = number of longitudes on the physics grid (e.g. 96) #ex * nlat = number of gaussian latitudes on the physics grid (e.g. 48) #ex lon = number of grid points per slice for physics (e.g. 96) #ex * lmt = spectral truncation wave number (e.g. 47) #ex ioztyp = switch for input ozone distribution (e.g. 2) #ex * ntrac = total number of tracers in the model (e.g. 17) #ex * itraca = number of advected tracers in the model (e.g. 12) #ex nnode_a= number of smp nodes used to run atm (mpi for nnode_a>1) #ex ntld = number of land tiles in CLASS #ex ntlk = number of lake tiles in CLASS #ex ntwt = number of water tiles in CLASS #ex iflm = integer switch to control fractional land mask (iflm=1 -> on) # # nnode_a is defined before gcmsub at the top of this script # lon=" 128"; lond=" 192"; ioztyp=" 4"; # --------------- Coupled Model Parameters ----------------- # # # ocnmod: 0 = specified ocean temperature # 1 = slab ocean # 2 = NCOM 1.3 3D ocean model # # icemod: 0 = specified ice # 1 = thermodynamic + cavitating ice dynamics # # rivmod: 0 = no targetting of land runoff to oceans # 1 = targetting of land runoff using River Routing Scheme # # iflux: 0 = adaptation (climatology file required) # 1 = flux adjustment (flux correction file required) # 2 = no flux correction # # couplermod 0 = Standard mode # 1 = NCOM/Coupler only mode ocnmod="00002"; icemod="00001"; rivmod="00001"; iflux="00002"; couplermod="00000"; # --------------------- Time Parameters -------------------- # # ncount: Maximum number of coupling step before CGCM stops and then # resubmits itself to the NQS queue. # # atmsteps: Coupling Frequency for the Atmospheric model (in seconds) # # ocnsteps: Coupling Frequency for the Ocean model (in seconds) # # ksteps: Number of AGCM model time steps in a job (must be equal to # length of atmsteps) ncount="00032"; atmsteps=" 86400"; ocnsteps=" 86400"; # ksteps=" 96"; # ksteps=" 96" = 86400/900 = 96 loop=1; # ----------------------------------------------------------- iocean="00000"; if [ "$ocnmod" = "00001" ] ; then oceanslab=on; iocean="00001"; fi if [ "$ocnmod" = "00002" ] ; then oceanslab=off; iocean="00001"; fi if [ "$couplermod" = "00001" ] ; then oceanonly=on; else oceanonly=off; fi clim="udr_cgcm3.1_adaptation_256x192l29v1_v2"; ocnmix=uwl_e_mix_t63_tidal_eddy_v2.dat # Daily chlorophyll climatology on ocean grid clim_bch=uwm_seawifs_bch_day_256x192v1 # Flux added to heat and moisture fluxes; interpolated daily from mid-months values flux="mc_t63_zero_flux_year"; # Flux added to heat and moisture fluxes; constant value from mid-month to mid-month flux2="mc_t63_zero2_flux_year"; #target="uva_128_64_river_parameters_v6"; # target="uva_river_parameters_128_64_aug_2016_for_cmip6_canesm_runs"; # target="uva_river_parameters_128_64_nov_2016_for_cmip6_canesm_runs" target="uva_river_parameters_128_64_dec_2016_for_cmip6_canesm_runs" lakes="gcm3.5_128x64_v5_lake_parameters_v2"; # cgcm_source="/users/tor/acrn/src/source/lsocn/CanESM4.3_cmip6_start"; # user_source="/users/tor/acrn/src/source/lsocn/CanESM4.3_cmip6_p02_agcm_ctem_river_routing_salinity_drift_fix"; # * ............... CPP_I include file definition .................... # NOTE ###################################################### # To turn carbon on/off def/undef biogeochem and coupler_ctem # NOTE ###################################################### ##CPP_I_START cpp1 ---- Various model run-time parameters converted from update cpp1 directives cpp1 ---- Set the use of solar variability. #define with_solvar cpp1 ---- Set the use of explosive volcanoes. #define explvol cpp1 ---- Set the saving of extra chemical diagnostic fields. # define xtrachem cpp1 ---- Set the saving of extra convective diagnostic fields. # define xtraconv cpp1 ---- Set the saving of extra cloud microphysics diagnostic fields. #undef xtrals cpp1 ---- Set the use of McICA and or COSP #undef use_cosp # define use_mcica cpp1 ---- Set the calculation and saving of radiative forcing fields #undef radforce cpp1 ---- Set the use of relaxation/nudging #undef relax cpp1 ---- Set the saving of results for aerosol optical calculations. #define aodpth cpp1 ---- Set the saving of diagnostics for updated dust emission scheme. #undef xtradust #if defined xtradust || defined aodpth cpp1 ---- Include extra chemical diagnostic code in AGCM for consistency # define xtrachem #endif cpp1 ---- Set the choice for surface albedo calculation (NOTE: cpp1 mutually exclusive!). # define salbtable #undef salbform1 cpp1 ---- Set the use of AMIP vs climatological boundary layer cpp1 ---- forcing (NB: non-coupled runs only!!!). #undef myrssti cpp1 ---- Set the saving of fields with date/time stamps. #undef isavdts cpp1 ---- Use new snow albedo paramterization (defined) or CLASS 3.6 parameterization (undef) # define isnoalb #undef xtrasulf cpp1 ---- Use PAM aerosol model. #undef pla #if defined pla cpp1 ---- Use aerosol and cloud droplet forcing data set. #undef pfrc cpp1 ---- Switches for individual forcing agents. #undef amradfrc #undef ssradfrc #undef dsradfrc #undef bcradfrc #undef ocradfrc #undef cdncfrc #undef bcicfrc #undef bcdpfrc cpp1 ---- Set the saving of results for extra PLA output. #undef xtraplafrc #undef xtrapla1 #undef xtrapla2 #endif #undef tprhs #undef qprhs #undef uprhs #undef vprhs #undef xprhs #undef tprhsc #undef qprhsc #undef uprhsc #undef vprhsc #undef xprhsc #undef rcm #undef mam #undef mamchem #undef x01 #undef x02 #undef x03 #undef x04 #undef x05 #undef x06 #undef x07 #undef x08 #undef x09 #undef timers #undef parallel_io cpp1 ---- Select one (only) of the following for model resolution. #undef model192x96v5 #undef model192x96l29_3x3v2 #undef model256x192l29 #undef model256x192l33v1 # define model256x192l40v1 #undef model256x192l45v1 cpp1 ---- Select operating mode(s) for the coupler # define coupler_cgcm #undef coupler_sa #undef coupler_debug cpp1 ---- Flag for selecting use of the biogeochem option cpp1 # define biogeochem cpp1 ---- Flag for using the ctem code #undef agcm_ctem cpp1 ---- Flag for using river routing scheme in AGCM #undef agcm_river_routing cpp1 ---- Check to see if either of the above options are set to run in cpp1 ---- carbon cycle mode. If so, set the "carbon" flag #undef carbon #if defined biogeochem || defined coupler_ctem || defined agcm_ctem cpp1 ---- Include carbon model specific code in AGCM # define carbon cpp1 ---- Flag for using cmoc cholorophyll for solar heating (defined) cpp1 ---- or not. If cmoc is not defined, then the observed chlorophyll cpp1 ---- will be used (read from file). # define bio_cmoc_chl_solar_heating cpp1 ---- Flag for running free-co2 but specifying CO2 in lowest level (only) cpp1 ---- based on specified CO2 concentrations and a correction for the cpp1 ---- annual mean. NOTE! **NOT** to be run with "specified_co2"!! cpp1 ---- NOTE! For this option, or for "free_co2", one must "deke" the cpp1 ---- the conservation constants for CO2 if starting from a cpp1 ---- "specified_co2" restart!!!!!!!!!!!!!!! #undef specified_anncycle_co2_lowlev cpp1 ---- Flag for using inverse calculation of emissions from concentrations cpp1 ---- NOTE: Only active when "carbon" switch is!!! # define specified_co2 cpp1 ---- Flag for using decoupled radiation (ie GHG constant) in full cpp1 ---- carbon cycle model cpp1 ---- NOTE: Only active when "carbon" switch is!!! #undef decoupled_rad_co2 #endif cpp1 ---- Flag to set instantaneous doubling of CO2 #undef co2_x2 cpp1 ---- Flag to set instantaneous quadrupiling of CO2 #undef co2_x4 cpp1 ---- Flag to set instantaneous octupling of CO2 #undef co2_x8 cpp1 ---- Flag to set 1% per year increase of CO2 #undef co2_1ppy #undef histemi # define emists cpp1 ---- transient aerosols switch. cpp1 ---- NOTE! There must be consistency with the above parmsub variable cpp1 ---- "em_aerosols" as noted in the comments in that section. #undef transient_aerosol_emissions #if defined emists || defined histemi cpp1 ---- Include transient_aerosol_emissions model specific code in AGCM # define transient_aerosol_emissions #endif # define histoz cpp1 ---- transient ozone switch. cpp1 ---- NOTE! There must be consistency with the above parmsub variable cpp1 ---- "conc_ozone" as noted in the comments in that section. #undef transient_ozone_concentrations #if defined histoz cpp1 ---- Include transient_ozone_concentrations model specific code in AGCM # define transient_ozone_concentrations #endif cpp1 ---- Select whether specified aerosol loading or not ***through coupler*** #undef coupler_aerosols cpp1 ---- Select greenhouse gas code for coupler #undef coupler_ghg # define cfc11_effective #ifdef cfc11_effective cpp1 ---- Use "effective" CFC11 concentrations that are representative of cpp1 ---- a combination of CFC11 and a number of other GHGs whose effects cpp1 ---- are not explicit in the model #endif cpp1 ---- Read specified boundary conditions from a file in the coupler cpp1 ---- The 3D ocean code will not run (=> no gz,cm,os files are created) cpp1 ---- The value of this macro determines the type of boundary conditions cpp1 ---- 0 - Do not read boundary conditions from a file cpp1 ---- 1 - climatological boundary conditions (12 monthly averages) cpp1 ---- 2 - climatological boundary conditions (365 daily averages) cpp1 ---- 3 - multi-year boundary conditions (monthly averages) cpp1 ---- 4 - multi-year boundary conditions (daily averages) # define coupler_specified_bc 3 cpp1 ---- If defined, coupler_specified_bc_file must be the name of the file cpp1 ---- containing specified boundary conditions read through the coupler. cpp1 ---- If coupler_specified_bc_file is not defined and monthly averaged cpp1 ---- climatological boundary conditions are used (coupler_specified_bc = 1) cpp1 ---- then the "AN" file will be used, otherwise a runtime error will occur. cpp1 ---- Choose one of the following if activating: #define coupler_specified_bc_file amipbc_ar5_128x64_1870_2010m03 !info #define coupler_specified_bc_file td_cfsr-cfsv2-amip_197901_201405_gp_128_64 cpp1#undef coupler_specified_bc_file ml_iflm1_caspian_orca_td_cfsrv2_128x64_1979m01_2014m05 cpp1 ---- If defined, ctem_write_spec_file forms part of a file name for a file cpp1 ---- containing the daily CTEM data that is passed back to the atm at each cpp1 ---- coupling interval. This file name will be the value of ctem_write_spec_file cpp1 ---- appended with either "_YYYY_mMM" (for monthly) or "_YYYY" (for yearly) cpp1 ---- depending on the value of ctem_write_spec_type cpp1#undef ctem_write_spec_file mc_eau_ctem_daily_data cpp1 ---- ctem_write_spec_type determines the type of file created when cpp1 ---- ctem_write_spec_file is defined cpp1 ---- The default is 1 if ctem_write_spec_type is not defined cpp1 ---- ctem_write_spec_type = 1 means write yearly files of daily data cpp1 ---- ctem_write_spec_type = 2 means write monthly files of daily data cpp1#undef ctem_write_spec_type 1 cpp1 ---- If defined, ctem_read_spec_file forms part or all of a file name for a file cpp1 ---- containing daily CTEM data that is read read from a file in the coupler. cpp1 ---- This daily CTEM data is passed to the atm and will replace similar fields cpp1 ---- that would normally be created in the coupler then passed to the atm. cpp1 ---- The name of the file that is read will be the value of ctem_read_spec_file cpp1 ---- when ctem_read_spec_type = 1 cpp1 ---- The name of the file that is read will be the value of ctem_read_spec_file cpp1 ---- appended with "_YYYY_mMM" when ctem_read_spec_type = 2 or the value cpp1 ---- of ctem_read_spec_file appended with "_YYYY" if ctem_read_spec_type = 3 cpp1#undef ctem_read_spec_file mc_eau_ctem_daily_clim_1971_2030 cpp1 ---- ctem_read_spec_type determines the type of file read when cpp1 ---- ctem_read_spec_file is defined cpp1 ---- The default is 1 if ctem_read_spec_type is not defined cpp1 ---- ctem_read_spec_type = 1 means read a yearly climatology of daily data cpp1 ---- ctem_read_spec_type = 2 means read daily data ...one month per file cpp1 ---- ctem_read_spec_type = 3 means read daily data ...one year per file cpp1#undef ctem_read_spec_type 1 cpp1 --- If use_cancpl is defined then use the CanCPL coupler #define use_cancpl cpp1 --- If use_NEMO is defined then the ocean model is NEMO #undef use_NEMO ##CPP_I_END # ----------------------------------------------------------- # * .................... Begin Critical Parameters ........................... ##PARC lmt=" 63" ; nlatd=" 96" ; lonsld=" 192" ; nlat=" 64" ; lonsl=" 128" ; delt=" 900.0" ; lay=" 2" ; ilev=" 49" ; levs=" 49" ; ntrac=" 16" ; itraca=" 12" ; coord=" ET15" ; plid=" 50.0"; moist=" QHYB" ; itrvar="QHYB" ; ntld=" 1"; ntlk=" 0"; ntwt=" 2"; iflm=" 1"; g01="-0108"; g02="-0144"; g03="-0190"; g04="-0250"; g05="-0327"; g06="-0426"; g07="-0550"; g08="-0708"; g09="-0904"; g10=" 11"; g11=" 15"; g12=" 18"; g13=" 23"; g14=" 28"; g15=" 35"; g16=" 43"; g17=" 52"; g18=" 64"; g19=" 77"; g20=" 92"; g21=" 110"; g22=" 131"; g23=" 154"; g24=" 181"; g25=" 211"; g26=" 245"; g27=" 283"; g28=" 325"; g29=" 370"; g30=" 420"; g31=" 474"; g32=" 531"; g33=" 592"; g34=" 648"; g35=" 698"; g36=" 742"; g37=" 780"; g38=" 813"; g39=" 841"; g40=" 865"; g41=" 885"; g42=" 902"; g43=" 916"; g44=" 930"; g45=" 944"; g46=" 958"; g47=" 972"; g48=" 986"; g49=" 995"; g50=" "; h01="-0108"; h02="-0144"; h03="-0190"; h04="-0250"; h05="-0327"; h06="-0426"; h07="-0550"; h08="-0708"; h09="-0904"; h10=" 11"; h11=" 15"; h12=" 18"; h13=" 23"; h14=" 28"; h15=" 35"; h16=" 43"; h17=" 52"; h18=" 64"; h19=" 77"; h20=" 92"; h21=" 110"; h22=" 131"; h23=" 154"; h24=" 181"; h25=" 211"; h26=" 245"; h27=" 283"; h28=" 325"; h29=" 370"; h30=" 420"; h31=" 474"; h32=" 531"; h33=" 592"; h34=" 648"; h35=" 698"; h36=" 742"; h37=" 780"; h38=" 813"; h39=" 841"; h40=" 865"; h41=" 885"; h42=" 902"; h43=" 916"; h44=" 930"; h45=" 944"; h46=" 958"; h47=" 972"; h48=" 986"; h49=" 995"; h50=" "; # namelists sref=" 7.18E-3"; spow=" 1."; ilaun=0; # tracer names it01=LWC; it02=IWC; it03=BCO; it04=BCY; it05=OCO; it06=OCY; it07=SSA; it08=SSC; it09=DUA; it10=DUC; it11=DMS; it12=SO2; it13=SO4; it14=HPO; it15=H2O; it16=CO2; # tracer reference values (default=0 for all tracers) xref01=0. # LWC xref02=0. # IWC xref03=5.03e-10 # BCO xref04=3.93e-10 # BCY xref05=2.27e-09 # OCO xref06=3.35e-09 # OCY xref07=1.35e-08 # SSA xref08=1.07e-07 # SSC xref09=3.57e-06 # DUA xref10=2.79e-05 # DUC xref11=2.91e-10 # DMS xref12=5.72e-09 # SO2 xref13=1.41e-09 # SO4 xref14=0.0 # HPO xref15=0.0 # H2O xref16=0.0 # CO2 # tracer power values (default=1 for all tracers) # tracer advection: 1/0 flag for tracer advection (on/off) adv01=0; adv02=0; adv03=1; adv04=1; adv05=1; adv06=1; adv07=1; adv08=1; adv09=1; adv10=1; adv11=1; adv12=1; adv13=1; adv14=0; adv15=0; adv16=1; # tracer physics: 1/0 flag for physics on tracer turned on/off # phxx=1 by default for all tracers phs01=0; phs02=0; phs15=-1; # molecular weights in g/mole (-1 means no chemistry and not used) mw01=18.015; mw02=18.015; mw03=-1.; mw04=-1.; mw05=-1.; mw06=-1.; mw07=58.443; mw08=58.443; mw09=-1.; mw10=-1.; mw11=32.064; mw12=32.064; mw13=32.064; mw14=-1.; mw15=18.015; mw16=44.011; # tracer surface flux: srf01=0; srf02=0; srf03=0; srf04=0; srf05=0; srf06=0; srf07=0; srf08=0; srf09=0; srf10=0; srf11=0; srf12=0; srf13=0; srf14=0; srf15=0; srf16=2; # wet deposition (default=0 for all tracers) wet01=0; wet02=0; wet03=-1; wet04=1; wet05=-1; wet06=1; wet07=1; wet08=1; wet09=1; wet10=1; wet11=0; wet12=1; wet13=1; wet14=0; wet15=0; wet16=0; # dry deposition (default=0 for all tracers) dry01=0; dry02=0; dry03=1; dry04=1; dry05=1; dry06=1; dry07=1; dry08=1; dry09=1; dry10=1; dry11=0; dry12=1; dry13=1; dry14=0; dry15=0; dry16=0; # convective chemistry (default=0 for all tracers) cch01=0; cch02=0; cch03=-1; cch04=1; cch05=-1; cch06=1; cch07=1; cch08=1; cch09=1; cch10=1; cch11=0; cch12=1; cch13=1; cch14=1; cch15=0; cch16=0; # boundary condition concentrations (ppm) # initial data for tracer? sdn=" 0" # tile names ilt01=GEN; ikt01=GEN; iwt01=WAT; iwt02=SIC; #/ Commonly used COSP options #/ ISCCP simulator #/ By default these ISCCP simulator options are true when #/ COSP turned on Lisccp_sim=.false. Lalbisccp=.true. #/ Cloud albedo Lcltisccp=.true. #/ Total cloud fraction Lpctisccp=.true. #/ Cloud top pressure Ltauisccp=.true. #/ Cloud optical thickness (linear average) Lclisccp=.true. #/ Cloud top pressure/optical thickness frequency # CALIPSO #/ By default CALIPSO is turned off Llidar_sim=.false. Lclcalipso=.true. #/ Cloud amount profile from lidar Lclcalipsoliq=.true. #/ Cloud phase profiles from lidar Lclcalipsoice=.true. Lclcalipsoun=.true. Lclcalipsotmp=.true. Lclcalipsotmpliq=.true. Lclcalipsotmpice=.true. Lclcalipsotmpun=.true. Lclhcalipso=.true. #/ High cloud fraction lidar Lclmcalipso=.true. #/ Middle cloud fraction lidar Lcllcalipso=.true. #/ Low cloud fraction lidar Lcltcalipso=.true. #/ Total cloud fraction lidar Lclhcalipsoliq=.true. #/ Liquid, ice and undefined cloud fractions Lcllcalipsoliq=.true. Lclmcalipsoliq=.true. Lclhcalipsoliq=.true. Lcltcalipsoliq=.true. Lclhcalipsoice=.true. Lcllcalipsoice=.true. Lclmcalipsoice=.true. Lclhcalipsoice=.true. Lcltcalipsoice=.true. Lclhcalipsoun=.true. Lcllcalipsoun=.true. Lclmcalipsoun=.true. Lclhcalipsoun=.true. Lcltcalipsoun=.true. LparasolRefl=.true. #/ Parasol reflectances at 5 angles LcfadLidarsr532=.true. #/ Backscatter-height histogram # CloudSat #/ By default CloudSat is turned off #/ !!!WARNING!!! Turning this on is VERY expensive Lradar_sim=.false. Lclcalipso2=.false. #/ Cloud fraction detected by lidar but not radar Lcltlidarradar=.false. #/ Total cloud detected by lidar and radar LcfadDbze94=.false. #/ Radar reflectivity-height histogram #/ MISR #/ By default the MISR simulator is turned off Lmisr_sim=.false. LclMISR=.true. #/ .true. turns on all of the MISR output #/ MODIS #/ By default the MODIS simulator is turned off Lmodis_sim=.false. Lcltmodis=.true. #/ Total cloud fraction Lclwmodis=.true. #/ Water cloud fraction Lclimodis=.true. #/ Ice cloud fraction Lclhmodis=.true. #/ High cloud fraction Lclmmodis=.true. #/ Middle cloud fraction Lcllmodis=.true. #/ Low cloud fraction Ltautmodis=.true. #/ Total optical thickness (linear) Ltauwmodis=.true. #/ Water optical thickness (linear) Ltauimodis=.true. #/ Ice optical thickness (linear) Ltautlogmodis=.true. #/ Total optical thickness (log) Ltauwlogmodis=.true. #/ Water optical thickness (log) Ltauilogmodis=.true. #/ Ice optical thickness (log) Lreffclwmodis=.true. #/ Liquid particle size Lreffclimodis=.true. #/ Ice particle size Lpctmodis=.true. #/ Cloud top pressure Llwpmodis=.true. #/ Liquid water path Liwpmodis=.true. #/ Ice water path Lclmodis=.true. #/ Pressure-tau histogram Llcdncmodis=.true. #/ Liquid cloud droplet number concentration Lsimplereffmodis=.true. #/ How to compute effective radii in the MODIS simulator Ltwotaumodis=.true. #/ How optical thicknesses are passed to the MODIS simulator #/ CERES simulator Lceres_sim=.false. #/ If set to .true. then Lisccp_sim is also set to .true. #/ and all of the output from the simulator is saved. #/ Extra fields #/ Lswath=.false. #/ Sampling along an orbital "swath" (dummy variable for now) use_vgrid=.true. #/ True interpolates vertical profiles to heights for Calipso and CloudSat #/ Linstant=.false. #/ Instantaneous sampling of the fields #/ COSP calling frequency ISCOSP=4 # * ...................... End Critical Parameters ........................... ### condef ### parc_check=off float1=off initsp=off myrssti=off openmp=on slab=off coupled=on noprint=on nolist=off acctcom=on xmu=off pakjob=off debug=off noxlfimp=off noxlfqinitauto=on nextjob=on f90mod=on xlf12104=off p5lib=on plaforce=off shortermdir=on masterdir=off keeprs=off # --- CanCPL coupler related parameters --- use_cancpl=$use_cancpl cancpl_ver='' cancpl_repo='' # build_cpl_opts="-k xlfimp=on " # Read the coupler restart or not read_cplrs=off # cpl_rs_abort_if_missing_field = .false. means that the coupler will not abort # when it encounters a missing field in the coupler restat file. # The default is to abort in this situation. # The only valid values for cpl_rs_abort_if_missing_field are .true. or .false. cpl_rs_abort_if_missing_field='' # Is a bulk formulation used in the coupler to define fields sent to NEMO # The only valid values for bulk_in_cpl are .true. or .false. bulk_in_cpl='' # couple_serial = .true. means couple in serial mode (the agcm runs then the ocean runs) # This should never be set unless debugging requires serial mode # The only valid values for couple_serial are .true. or .false. (default .false.) couple_serial='' # Save coupler history files to DATAPATH save_cplhist='' save_cplhist_tavg='' # When cpl_zero_runoff = on then runoff will zeroed in the coupler before being sent to the ocean cpl_zero_runoff='' # Generate coupler run time diagnostics cpl_rtd=on # When cpl_new_rtd is on any rtd file found in the coupler restart # will be ignored and a new rtd file will be started cpl_new_rtd=off # A value to add to the year (coupler time) when reading AGCM specified boundary conditions # (GT, SIC, SICN) from a file to get a different year from the file # specified_bc_year_offset is added to the current year, as determined by the coupler, # so a negative value will be subtracted specified_bc_year_offset='' # --- NEMO related parameters --- # If use_nemo = on then the NEMO ocean will be coupled with the AGCM use_nemo=$use_nemo # If defined, nemo_rebuild_rsin is the name of a NEMO restart tarball that will be # used to initialize fields that are sent from the coupler to the agcm on the first # coupling interval. This restart will be rebuilt on the global ORCA grid prior to model # execution and then read by the coupler to extract the relevant fields. nemo_rebuild_rsin='' # nemo_exec, nemo_ver, nemo_repo, nemo_build_opts are only used when nemo_compile = on # If nemo_exec is defined then a nemo executable by that name must be saved on DATAPATH # and this executable will be accessed and use when nemo_compile = off # If nemo_exec is not defined then a nemo executable will be compiled using information # from the variables nemo_ver, nemo_repo and nemo_build_opts when nemo_compile = on nemo_exec='' nemo_ver='' nemo_repo='' nemo_build_opts="arch=xlf_aix-cancpl refcfg=CCC_CANCPL_ORCA1_LIM cfg=CCC_CANCPL_ORCA1_LIM" nemo_compile=off # nemo_config identifies a particular configuration (e.g. CCC_CANCPL_ORCA1_LIM) nemo_config='' # Namelists for NEMO IO nemo_iodef=cancpl_orca1_lim_iodef.xml nemo_xmlio_server_def=cancpl_orca1_lim_xmlio_server.def nemo_jpni='' nemo_jpnj='' nemo_jpnij='' # output the initial state (nemo_nn_istate = 1) or not (nemo_nn_istate = 0) nemo_nn_istate='' # time steps between creation of NEMO restart files (modulo referenced to 1) nemo_nn_stock='' # nemo_from_rest is used to flag starting nemo from rest rather than a restart # If nemo_from_rest = on then nemo_restart must be undefined # If nemo_from_rest = on then nemo_namelist and nemo_namelist_ice must be defined nemo_from_rest='' # The name of a tar file containing the NEMO restart files # This must be set for the first job of a run unless nemo_from_rest = on # Restart files created by the submission job will have names of the form # ${uxxx}_${runid}_YYYYMMDD_restart.tar nemo_restart='' # nemo_carbon = off means use physical ocean only # nemo_carbon = on means include PISCES nemo_carbon=off # nemo_cmoc = off means use PISCES # nemo_cmoc = on means use CMOC nemo_cmoc=off # nemo_pisces_offline = off means use online model # nemo_pisces_offline = on means use offline model with prescribed velocities nemo_pisces_offline=off # Identify files containing namelist input for NEMO (namelist) and LIM or CICE (namelist_ice) # These namelist files are only used when starting from rest or when nemo_force_namelist = on # These files must be saved on DATAPATH nemo_namelist=cancpl_orca1_lim_namelist nemo_namelist_ice=cancpl_orca1_lim_namelist_ice nemo_force_namelist=on nemo_ln_rnf=.true. nemo_ln_rnf_emp=.true. nemo_runoff_core_monthly='' nemo_1y_suffix_list='' nemo_1m_suffix_list='icemod grid_T grid_U grid_V grid_W' nemo_1d_suffix_list='' nemo_5d_suffix_list='' nemo_3h_suffix_list='xxx' nemo_other_hist_suffix_list='' nemo_other_rs_suffix_list='' # Concatenate nemo history files yearly # nemo_ann_cat is depreciated and should be left null nemo_ann_cat='' # Generate nemo run time diagnostics nemo_rtd=on # When nemo_new_rtd is on any rtd file found in the NEMO restart # will be ignored and a new rtd file will be started nemo_new_rtd=off # Specify the RTD executables nemo_physical_rtd_exe="nemo_physical_rtd_v03c_exe" nemo_carbon_rtd_exe="nemo_carbon-cmoc_rtd_v03c_exe" nemo_ice_rtd_exe="nemo_ice_rtd_v03c_exe" # Set start year for rtd nemo_rtdiag_start_year=1 # nemo_steps_in_job is the number of NEMO time steps to run # This number is determined internally and so is not normally set here # but it may be used for debugging (caveat lector) nemo_steps_in_job='' # Save NEMO history files to DATAPATH nemo_save_hist=on # Dump NEMO history files to cfs nemo_dump_hist=off # Optionally delete NEMO history files from DATAPATH nemo_del_hist=off # Save NEMO restart files to DATAPATH nemo_save_rs=on # Dump NEMO restart archives to cfs nemo_dump_rs=off # Delete the previous nemo restart tar archive from DATAPATH. nemo_del_rs=off # NEMO time step in seconds nemo_rn_rdt=3600 # remove (nemo_nn_closea = 0) or keep (nemo_nn_closea = 1) closed seas and lakes (ORCA) nemo_nn_closea=0 # The index of the first NEMO time step nemo_nn_it000='' # nemo_nn_ice identifies the ice model used in NEMO # nemo_nn_ice = 0 mean no sea ice # nemo_nn_ice = 2 mean LIM2 # nemo_nn_ice = 4 mean CICE nemo_nn_ice=2 # nemo_ln_ctl toggles printing of diagnostic messages from NEMO # nemo_ln_ctl must be either .false. or .true. (ie a fortran logical constant) # since it is read from a fortran namelist nemo_ln_ctl=.true. # nn_fsbc is the number of NEMO time steps between each call to the surface # boundary condition routines (including the sea ice model) nemo_nn_fsbc=24 # nemo_nn_msh determines if NEMO will create (=1) a mesh file or not (=0) nemo_nn_msh=1 # CICE time step in seconds # cice_dt=900 # The number of CICE time steps for each call to CICE_Run # cice_npt=24 # The value of "year_init" in the CICE namelist (0) # cice_year_init='' # The value of "runtype" in the CICE namelist (initial or continue) # cice_runtype='' # The value of "ice_ic" in the CICE namelist (none, default, ice ic file name) # cice_ice_ic='' # The value of "restart" in the CICE namelist (.true. or .false.) # cice_restart='' # These variables are set when the job string is created previous_year=NotSet previous_month=NotSet current_year=NotSet current_month=NotSet next_year=NotSet next_month=NotSet run_start_year=NotSet run_start_month=NotSet run_stop_year=NotSet run_stop_month=NotSet ### update script ### %c gcmjcl %c compile_cgcm #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # New coupler related mods #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %i compile_cgcm.15 if [ -s libcplcom.a ]; then cplcom=`pwd`/libcplcom.a LOCOMM_ocn="$cplcom $LOCOMM_ocn" fi %i compile_cgcm.20 if [ "x$use_canom4" = "xon" ]; then %i compile_cgcm.69 else $F77 $QSRC $PROF -o AB source.o $HORNEL $LOMODEL_ver $LOCOMM fi %i gcmjcl.25 nnode_c=${nnode_c:=0} nproc_c=${nproc_c:=1} %d gcmjcl.32 nnode_def=$nnode nnode=`expr $nnode_a + $nnode_o` nnode=`expr $nnode + $nnode_c` [ -n "$nnode_def" ] && nnode=$nnode_def %d gcmjcl.147 [ "x$use_canom4" = "xon" ] && access OB ${start}ob %d gcmjcl.177 if [ "x$use_cancpl" = "xon" ]; then build-cpl $build_cpl_opts ver=$cancpl_ver if [ -s libcplcom.a ]; then cplcom=`pwd`/libcplcom.a LOCOMM="$cplcom $LOCOMM" LOCOMM_ocn="$cplcom $LOCOMM_ocn" else echo "Missing libcplcom.a" exit 1 fi access OLDcpl.exe ${model}cpl.exe na save cpl_main ${model}cpl.exe delete OLDcpl.exe na fi if [ "x$use_nemo" = "xon" ]; then if [ "x$nemo_compile" = "xon" ]; then # Compile NEMO and save the executable as ${start}nemo.exe on DATAPATH if [ -z "$nemo_repo" -o -z "$nemo_ver" ]; then echo "Both nemo_repo and nemo_ver must be defined when compiling NEMO" exit 1 fi if [ -z "$nemo_build_opts" ]; then echo "nemo_build_opts must be defined when compiling NEMO" exit 1 fi BUILD_NEMO=$nemo_repo/bin/build-nemo [ -x "$BUILD_NEMO" ] || exit 1 $BUILD_NEMO $nemo_build_opts repo=$nemo_repo ver=$nemo_ver exec=${start}nemo.exe fi fi if [ "$coupled" = on -a "x$use_canom4" = "xon" ] ; then %d gcmjcl.257 [ "x$use_canom4" = "xon" ] && access OB ${start}ob %d gcmjcl.285,287 if [ "x$use_canom4" = "xon" ]; then access OLDOB ${model}ob na save OB ${model}ob delete OLDOB na fi %d gcmjcl.366 access ST_nmf ${start}rs_nmf na ; access TS_nmf ${start}ts_nmf na %d gcmjcl.378 fi ; if [ ! -f TS_nmf ] ; then access TS ${start}ts na ; if [ -s TS ] ; then unpakrs${FLTEXTNSN} TS TS_nmf ; tsnmf=yes ; fi ; fi %d gcmjcl.381 fi ; if [ "$start" != "$model" -a ! -f TS -a -s TS_nmf ] ; then cp TS_nmf TS ; fi ; if [ -s TS_nmf ] ; then release new_TS_nmf ; cp TS_nmf new_TS_nmf ; fi %d gcmjcl.386 save new_ST_nmf ${model}rs_nmf ; delete ST_nmf na ; release ST_nmf ; mv new_ST_nmf ST_nmf ; if [ -s new_TS_nmf ] ; then save new_TS_nmf ${model}ts_nmf ; delete TS_nmf na ; release TS_nmf ; mv new_TS_nmf TS_nmf ; fi %d gcmjcl.388,390 if [ -f .new_ST_nmf_Link -o -L .new_ST_nmf_Link ] ; then mv .new_ST_nmf_Link .ST_nmf_Link ; fi ; if [ -f .new_TS_nmf_Link -o -L .new_TS_nmf_Link ] ; then mv .new_TS_nmf_Link .TS_nmf_Link ; fi else if [ -f .new_ST_nmf_Link ] ; then mv .new_ST_nmf_Link .ST_nmf_Link ; fi ; if [ -f .new_TS_nmf_Link ] ; then mv .new_TS_nmf_Link .TS_nmf_Link ; fi ; fi rsnmf=no ; tsnmf=no %d gcmjcl.392 rm ST_nmf .ST_nmf_Link ; mv new_ST_nmf ST_nmf ; rsnmf=yes ; if [ -s new_TS_nmf ] ; then rm TS_nmf .TS_nmf_Link ; mv new_TS_nmf TS_nmf ; tsnmf=yes ; fi %d gcmjcl.435,438 if [ "x$use_cancpl" != "xon" ]; then access OLDCS ${start}cs ; save OLDCS ${model}cs if [ "$slab" != 'on' -a \( -z "$ocnmod" -o \( -n "$ocnmod" -a "$ocnmod" -eq 2 \) \) ] ; then access OLDOS ${start}os na ; if [ -s "OLDOS" ] ; then save OLDOS ${model}os ; fi fi fi %d gcmjcl.462 fi ; if [ -s TS_nmf -a "$tsnmf" = yes ] ; then save TS_nmf ${model}ts_nmf ; fi %d gcmjcl.617 nproc_a=$nproc_a ; nproc_o=$nproc_o ; nproc_c=$nproc_c nnode_a=$nnode_a ; nnode_o=$nnode_o ; nnode_c=$nnode_c start=$start ; uxxx=$uxxx ; runid=$runid ; use_cancpl=$use_cancpl ; use_nemo=$use_nemo %i gcmjcl.625 cancpl_repo="$cancpl_repo" cancpl_ver="$cancpl_ver" cpl_rtd=$cpl_rtd cpl_new_rtd=$cpl_new_rtd save_cplhist=$save_cplhist save_cplhist_tavg=$save_cplhist_tavg read_cplrs="$read_cplrs" nemo_repo="$nemo_repo" nemo_ver="$nemo_ver" nemo_config="$nemo_config" nemo_from_rest="$nemo_from_rest" nemo_restart="$nemo_restart" nemo_exec="$nemo_exec" nemo_rebuild_rsin="$nemo_rebuild_rsin" nemo_forcing="$nemo_forcing" nemo_carbon="$nemo_carbon" nemo_cmoc="$nemo_cmoc" nemo_pisces_offline="$nemo_pisces_offline" nemo_namelist="$nemo_namelist" nemo_namelist_ice="$nemo_namelist_ice" nemo_iodef="$nemo_iodef" nemo_xmlio_server_def="$nemo_xmlio_server_def" nemo_force_namelist="$nemo_force_namelist" nemo_jpni="$nemo_jpni" nemo_jpnj="$nemo_jpnj" nemo_jpnij="$nemo_jpnij" nemo_nn_stock="$nemo_nn_stock" nemo_nn_istate="$nemo_nn_istate" nemo_nn_ice="$nemo_nn_ice" nemo_nn_fsbc="$nemo_nn_fsbc" nemo_nn_msh="$nemo_nn_msh" nemo_rn_rdt="$nemo_rn_rdt" nemo_nn_closea="$nemo_nn_closea" nemo_nn_it000="$nemo_nn_it000" nemo_steps_in_job="$nemo_steps_in_job" nemo_ln_ctl="$nemo_ln_ctl" nemo_nn_print="$nemo_nn_print" nemo_ln_rnf="$nemo_ln_rnf" nemo_ln_rnf_emp="$nemo_ln_rnf_emp" nemo_runoff_core_monthly="$nemo_runoff_core_monthly" cpl_zero_runoff="$cpl_zero_runoff" nemo_ln_tsd_init="$nemo_ln_tsd_init" nemo_1y_suffix_list="$nemo_1y_suffix_list" nemo_1m_suffix_list="$nemo_1m_suffix_list" nemo_1d_suffix_list="$nemo_1d_suffix_list" nemo_5d_suffix_list="$nemo_5d_suffix_list" nemo_3h_suffix_list="$nemo_3h_suffix_list" nemo_other_hist_suffix_list="$nemo_other_hist_suffix_list" nemo_other_rs_suffix_list="$nemo_other_rs_suffix_list" nemo_rtdiag_start_year=$nemo_rtdiag_start_year nemo_ann_cat=$nemo_ann_cat nemo_rtd=$nemo_rtd nemo_new_rtd=$nemo_new_rtd nemo_physical_rtd_exe=$nemo_physical_rtd_exe nemo_carbon_rtd_exe=$nemo_carbon_rtd_exe nemo_ice_rtd_exe=$nemo_ice_rtd_exe nemo_dump_hist=$nemo_dump_hist nemo_save_hist=$nemo_save_hist nemo_del_hist=$nemo_del_hist nemo_dump_rs=$nemo_dump_rs nemo_save_rs=$nemo_save_rs nemo_del_rs=$nemo_del_rs cice_year_init=$cice_year_init cice_runtype=$cice_runtype cice_ice_ic="$cice_ice_ic" cice_restart=$cice_restart cice_npt="$cice_npt" cice_dt="$cice_dt" previous_year="${previous_year:=NotSet}" previous_month="${previous_month:=NotSet}" current_year="${current_year:=NotSet}" current_month="${current_month:=NotSet}" next_year="${next_year:=NotSet}" next_month="${next_month:=NotSet}" run_start_year="${run_start_year:=NotSet}" run_start_month="${run_start_month:=NotSet}" run_stop_year="${run_stop_year:=NotSet}" run_stop_month="${run_stop_month:=NotSet}" shortermdir=$shortermdir masterdir=$masterdir sv=$sv besc=$besc %i gcmjcl.675 if [ "x$use_cancpl" = "xon" ]; then # cpl_prelude will set up the coupler for execution if [ ! -s cpl_prelude ]; then cancpl_repo=${cancpl_repo:-$CCRNSRC/coupler_dir/coupler.git} if [ -z "\$cancpl_repo" -o -z "\$cancpl_ver" ]; then echo "cancpl_repo and cancpl_ver must be defined when using cpl_prelude" exit 2 fi gitrip \$cancpl_ver cpl_prelude repo=\$cancpl_repo fi : ; . ./cpl_prelude fi if [ "x$use_canom4" != "xon" ]; then [ -s LAKES ] || access LAKES $lakes na [ -s TARGET ] || access TARGET $target na if [ -n "\$crnt_year" -a -n "\$crnt_monthd" ]; then # These values are used in nemo_prelude eval previous_year\=\$crnt_year eval previous_month\=\$crnt_monthd eval current_year\=\$crnt_year eval current_month\=\$crnt_monthd fi if [ "x$use_nemo" = "xon" ]; then # nemo_prelude will access NEMO related files and set up namelists etc if [ ! -s nemo_prelude ]; then if [ -z "\$nemo_repo" -o -z "\$nemo_ver" ]; then echo "nemo_repo and nemo_ver must be defined when using NEMO" exit 2 fi gitrip \$nemo_ver nemo_prelude repo=\$nemo_repo fi : ; . ./nemo_prelude fi else %i gcmjcl.689 fi # end if [ "x$use_canom4" != "xon" ]; then %d gcmjcl.771 access OLDRS \${model}rs_nmf ed=1 na ; if [ ! -f OLDRS ] ; then access OLDRS \${model}rs_nmf ; fi ; access OLDTS \${model}ts_nmf ed=1 na ; if [ ! -f OLDTS ] ; then access OLDTS \${model}ts_nmf na ; fi %d gcmjcl.792 release OLDRS ; mv NEWRS OLDRS ; if [ -s NEWTS ] ; then release OLDTS ; mv NEWTS OLDTS ; fi %d gcmjcl.796 fi ; if [ -f .NEWTS_Link -o -L .NEWTS_Link ] ; then mv .NEWTS_Link .OLDTS_Link ; fi %d gcmjcl.800 fi ; if [ -f .NEWTS_Link ] ; then mv .NEWTS_Link .OLDTS_Link ; fi %i gcmjcl.803 if [ "x\$use_cancpl" != "xon" ]; then %i gcmjcl.840 fi # end 803: if [ "x$use_cancpl" != "xon" ]; then # Rebuild NEMO history and restart files then save them to DATPATH %d gcmjcl.859,860 if [ "x\$use_cancpl" = "xon" ]; then if [ ! -s cpl_postlude ]; then if [ -z "\$cancpl_repo" -o -z "\$cancpl_ver" ]; then echo "cancpl_repo and cancpl_ver must be defined when using cpl_postlude" exit 2 fi gitrip \$cancpl_ver cpl_postlude repo=\$cancpl_repo fi : ; . ./cpl_postlude fi if [ "x\$use_nemo" = "xon" ]; then : ; . gcmpak.cdk release OLDRS NEWRS access OLDRS \${model}rs_nmf cp OLDRS NEWRS if [ "\$keeprs" != 'on' ] ; then save NEWRS \${model}rs else cp OLDRS RESTART save RESTART \${model}rs release RESTART fi delete OLDRS if [ ! -s nemo_postlude ]; then if [ -z "\$nemo_repo" -o -z "\$nemo_ver" ]; then echo "nemo_repo and nemo_ver must be defined when using NEMO" exit 2 fi gitrip \$nemo_ver nemo_postlude repo=\$nemo_repo fi : ; . ./nemo_postlude exit 1 else if [ "x\$use_cancpl" = "xon" ]; then : ; . gcmpak.cdk release OLDRS NEWRS access OLDRS \${model}rs_nmf cp OLDRS NEWRS if [ "\$keeprs" != 'on' ] ; then save NEWRS \${model}rs else cp OLDRS RESTART save RESTART \${model}rs release RESTART fi delete OLDRS exit 1 else : ; . cgcmpak.cdk (cat unit6_* || : ) ; if [ "$debug" != 'on' ] ; then (\rm -f unit6_* || : ) ; fi ; exit 1 fi fi %d gcmjcl.1126 delete OLDRS ; release OLDRS RESTART ; release NEWTS ; if [ -s OLDTS ] ; then cp OLDTS NEWTS ; cp OLDTS RESTARTTS ; save RESTARTTS \${model}ts ; delete OLDTS ; release OLDTS RESTARTTS ; fi # The file cpl_gcm_parallel_setup.cdk will eventually replace gcm_parallel_setup.cdk # It must exist in the invoking users ~/bin_aix dir as long as this update is here %d gcmjcl.716 : ; . cpl_gcm_parallel_setup.cdk # The file cpl_gcm_inpfls_extra.cdk will eventually replace gcm_inpfls_extra2.cdk # It must exist in the invoking users ~/bin_aix dir as long as this update is here %d gcmjcl.1229 . cpl_gcm_inpfls_extra.cdk # The file cpl_endgcm.cdk will eventually replace endgcm.cdk # NOTE: cpl_gcmnext.cdk sourced in cpl_endgcm.cdk will also replace gcmnext.cdk # These must exist in the invoking users ~/bin_aix dir as long as this update is here %d gcmjcl.1233 : ; . cpl_endgcm.cdk #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # End new coupler related mods #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# ### update model ### %c solvar2 %c msizes %c psizes_19 %c ghgts2_defs %c aerosol_defs %c ozone_defs %c cosp5 %c rad_force2 %c gcm18 %c core18p %c core15di %c physici %c rstarth %c dyncal4d %c sfcproc2 %c spec_fwd_xfer2 %c spec_bwd_xfer2 %c wrap_gather %c trinfo10 %c init_aerosol_scenario %c init_ghg_scenario2 %c init_ozone_scenario %c interp_ghg_scenario2 #%c restart_ctem %c ctem_mpi_putfld %c mpi_getcpl2 %c mpi_putggb2 #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # New coupler related mods #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %id new_coupler_related_mods %i gcm18.391 #ifdef use_cancpl !--- cpl_atm contains AGCM procedures used when coupled with CanCPL use cpl_atm #endif # TAGINFO_H5 is no longer required with the new CanCPL coupler %d gcm18.394 #ifndef use_cancpl *CALL TAGINFO_H5 #endif %i gcm18.869 #ifdef use_cancpl call define_group('atm', agcm_commwrld, group_member=member) coupler=cpl_master atmos=atm_master ocean=ocn_master #else %i gcm18.935 #endif %d gcm18.1369 !--- Remove this line in order to couple more frequently than 1 day C IF(MOD(KSTEPS, ISRAD).NE.0) CALL XIT ('GCM', -44) %i gcm18.2388 #ifdef use_cancpl !--- Coupler related initialization call coupler_atm_init(lon1,nlat,ilat,ijpak,kstart,ksteps, 1 kount,kfinal,delt,maskpak,flndpak) #endif %d gcm18.2399 #ifdef use_cancpl call recv_data_rec(msg, cpl_master, "MSG") #else call Recv_fld (MSG, JBUF, coupler, d_msg) #endif %i gcm18.4333 MSG(6) = nint(DELT) MSG(7) = KOUNT %d gcm18.4335 #ifdef use_cancpl call send_data_rec(msg, cpl_master, "MSG") #else call Send_fld (MSG, JBUF, coupler, d_msg) #endif %d physici.921 !DBG This needs to be call xit(..) !DBG CALL ABORT if ( sicnrow(i)<0.0 ) sicnrow(i)=0.0 if ( sicrow(i)<0.0 ) sicrow(i)=0.0 if ( snorow(i)<0.0 ) snorow(i)=0.0 %d coupling_h.9 character*8 member(0:63) %i mpi_getcpl2.8 #ifdef use_cancpl use com_cpl, only: Recv_fld #endif %i mpi_putggb2.16 #ifdef use_cancpl use com_cpl, only: Send_fld #endif %deck cplatminit module cpl_atm use com_cpl public contains !****************************************************************** !--- Define the list of variables received by the agcm from the coupler !****************************************************************** subroutine define_atm_recv_var(verbose) !--- Things common to all coupled component models use com_cpl integer :: verbose !--- Local integer :: indx character(32) :: tmp_var(100) tmp_var(:) = " " atm_n_recv_var = 0 if ( atm_forcing_from_file ) then !--- AGCM forcing data is being read from a file in the coupler !--- Ground cover atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "GC_atm" !--- Ground temperature atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "GT_atm" !--- Sea ice thickness atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SIC_atm" !--- Sea ice fraction atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SICN_atm" !--- Snow thickness atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SNO_atm" else !--- Ground temperature atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "GT_atm" #ifdef use_CanOM4 !--- GC is no longer used but is kept here !--- for backward compability atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "GC_atm" #endif !--- Sea ice thickness atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SIC_atm" !--- Sea ice fraction atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SICN_atm" !--- Snow thickness atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SNO_atm" #ifdef use_CanOM4 !--- Residual over lakes atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "RES_atm" #endif #if defined coupler_ctem && defined use_CanOM4 atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "FCANM_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "ZOLN_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "AIL_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "CMASV_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "ALVIS_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "ALNIR_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "CURF_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "AILC_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SLAI_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "RMAT_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "RMATCT_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "PAIC_atm" atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "SLAIC_atm" #endif #if defined biogeochem atm_n_recv_var = atm_n_recv_var + 1 tmp_var(atm_n_recv_var) = "CO2flx_atm" #endif endif !--- if(atm_forcing_from_file) if ( associated(atm_recv_var) ) deallocate(atm_recv_var) allocate( atm_recv_var(atm_n_recv_var) ) do indx=1,atm_n_recv_var atm_recv_var(indx) = tmp_var(indx) enddo if ( verbose > 0 ) then write(6,*)"define_atm_recv_var: atm_n_recv_var=", 1 atm_n_recv_var write(6,'(5(2x,a))')atm_recv_var(1:atm_n_recv_var) call flush(6) endif end subroutine define_atm_recv_var !****************************************************************** !--- Define the list of variables sent by the agcm to the coupler !****************************************************************** subroutine define_atm_send_var(verbose) !--- Things common to all coupled component models use com_cpl integer :: verbose !--- Local integer :: indx character(32) :: tmp_var(100) tmp_var(:) = " " atm_n_send_var = 0 if ( atm_forcing_from_file ) then !--- AGCM forcing data is being read from a file in the coupler !--- Ground cover atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "GC_atm" endif !xxx if ( atm_forcing_from_file ) then !xxx !--- AGCM forcing data is being read from a file in the coupler !xxx !xxx !--- Ground cover !xxx atm_n_send_var = atm_n_send_var + 1 !xxx tmp_var(atm_n_send_var) = "GC_atm" !xxx !xxx !--- Ground temperature !xxx atm_n_send_var = atm_n_send_var + 1 !xxx tmp_var(atm_n_send_var) = "GT_atm" !xxx !xxx !--- Sea ice thickness (IWE) !xxx atm_n_send_var = atm_n_send_var + 1 !xxx tmp_var(atm_n_send_var) = "SIC_atm" !xxx !xxx !--- Sea ice fraction !xxx atm_n_send_var = atm_n_send_var + 1 !xxx tmp_var(atm_n_send_var) = "SICN_atm" !xxx !xxx !--- Snow thickness (SWE) !xxx atm_n_send_var = atm_n_send_var + 1 !xxx tmp_var(atm_n_send_var) = "SNO_atm" !xxx !xxx else !--- Atmosphere-Ocean wind stress (X component) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "UFSO_atm" !--- Atmosphere-Ocean wind stress (Y component) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "VFSO_atm" !--- Atmosphere-Ice wind stress (X component) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "UFSI_atm" !--- Atmosphere-Ocean wind stress (Y component) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "VFSI_atm" #ifdef use_CanOM4 !--- Mixed total heat flux atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "OBEG_atm" !--- Mixed P-E atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "OBWG_atm" #endif !--- Runoff atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "RIVO_atm" #ifdef use_CanOM4 !--- GC is no longer used but is kept here for !--- backward compability atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "GC_atm" !--- Ground temperature atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "GT_atm" !--- Sea ice thickness (IWE) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SIC_atm" !--- Sea ice fraction atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SICN_atm" !--- Snow thickness (SWE) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SNO_atm" #endif !--- Solar heat flux over open ocean atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "FSGO_atm" !--- Solar heat flux over ice atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "FSGI_atm" #if defined biogeochem !--- Mean sea level pressure atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "PMSL_atm" #endif #if defined biogeochem || ! defined use_CanOM4 !--- 10 meter wind atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SWMX_atm" #endif #if defined biogeochem !--- Atmospheric CO2 atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "CO2_atm" #endif #ifndef use_CanOM4 !--- The folowing fields are required for NEMO !--- but are not used by the old ocean model (CanOM4) !--- Total heat flux over ocean atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "BEGO_atm" !--- P-E over ocean atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "BWGO_atm" !--- Total liquid precipitation atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "RAIN_atm" !--- Total solid precipitation atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SNOW_atm" !--- Lsat * sublimation over sea ice atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "HFLI_atm" !--- Total heat flux over sea ice atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "BEGI_atm" !CICE !--- Conductive heat flux over sea ice !CICE atm_n_send_var = atm_n_send_var + 1 !CICE tmp_var(atm_n_send_var) = "HSEA_atm" !--- Non-solar sensitivity to temperature (dQns/dT) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SLIM_atm" !???#define dbglps !???#ifdef dbglps !--- Term of Non-solar sensitivity to temperature (dQns/dT) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SLIMlw_atm" !--- Term of Non-solar sensitivity to temperature (dQns/dT) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SLIMsh_atm" !--- Term of Non-solar sensitivity to temperature (dQns/dT) atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "SLIMlh_atm" !???#endif !--- Surface temperature over sea ice atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "GTICE_atm" #endif #if defined coupler_ctem !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TA_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "FSNOW_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TCANO_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TCANS_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TBAR_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TBARC_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TBARCS_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TBARG_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "TBARGS_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "THLIQC_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "THLIQG_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "ANCS_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "ANCG_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "RMLCS_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "RMLCG_atm" !--- CTEM atm_n_send_var = atm_n_send_var + 1 tmp_var(atm_n_send_var) = "THICEC_atm" #endif !xxx endif !--- if(atm_forcing_from_file) if ( associated(atm_send_var) ) deallocate(atm_send_var) allocate( atm_send_var(atm_n_send_var) ) do indx=1,atm_n_send_var atm_send_var(indx) = tmp_var(indx) enddo if ( verbose > 0 ) then write(6,*)"define_atm_send_var: atm_n_send_var=", 1 atm_n_send_var write(6,'(5(2x,a))')atm_send_var(1:atm_n_send_var) call flush(6) endif end subroutine define_atm_send_var !****************************************************************** !--- Initialize atm specific coupler elements and define the list !--- of variables that are transfered (sent or received) between !--- the atm and the coupler !****************************************************************** subroutine coupler_atm_init(lon1,nlat,ilat,ijpak,kstart,ksteps, 1 kount,kfinal,delt,maskpak,flndpak) !--- Things common to all coupled component models use com_cpl integer, intent(in) :: lon1,nlat,ilat,ijpak integer, intent(in) :: kstart,ksteps,kount,kfinal real, intent(in) :: delt real :: maskpak(ijpak), flndpak(ijpak) !--- Local !--- wrks is required in the calls to MPI_PUTGGB2 but is not used !--- by MPI_PUTGGB2. MPI_PUTGGB2 should be modified for this and !--- other reasons (e.g. other input parameters are also not used) !--- and transfer via send_fld done in MPI_PUTGGB2 is depreciated. real :: wrks(1) real, pointer :: gll(:) real(kind=8), pointer :: sinl(:),wgt(:),cosl(:) real(kind=8), pointer :: rad(:),wocs(:) !--- These variables will be broadcast to all mpi tasks !--- in the following call to cpl_initialize_events atm_kstart = kstart atm_ksteps = ksteps atm_kount = kount atm_kfinal = kfinal atm_delt = nint(delt,8) atm_nlon = lon1 - 1 atm_nlat = nlat allocate( sinl(nlat), wgt(nlat), cosl(nlat) ) allocate( rad(nlat), wocs(nlat) ) call gaussg(nlat/2,sinl,wgt,cosl,rad,wocs) call trigl (nlat/2,sinl,wgt,cosl,rad,wocs) if ( associated(atm_wla) ) deallocate(atm_wla) allocate(atm_wla(nlat)) atm_wla(1:nlat) = wgt(1:nlat) if ( associated(atm_radla) ) deallocate(atm_radla) allocate(atm_radla(nlat)) atm_radla(1:nlat) = rad(1:nlat) deallocate(sinl,wgt,cosl,rad,wocs) !--- Define the list of fields sent and received by the atm !--- These lists will be broadcast to the coupler in the !--- following call to cpl_initialize_events call define_atm_send_var(0) call define_atm_recv_var(0) write(6,*)"coupler_atm_init: call cpl_initialize_events" call flush(6) !--- Initialize coupler variables, broadcast atm variables call cpl_initialize_events() !--- Temporary space for the following transfers allocate( gll(lon1*ilat) ) !--- Send the AGCM binary land mask to the coupler CALL MPI_PUTGGB2( MASKPAK,LON1,ILAT,0,0,1,0, 1 NC4TO8("MASK"),1,GLL,WRKS,a_mask) !--- Send the AGCM fractional land mask to the coupler CALL MPI_PUTGGB2( FLNDPAK,LON1,ILAT,0,0,1,0, 1 NC4TO8("FLND"),1,GLL,WRKS,a_flnd) deallocate( gll ) !--- Broadcast the initial date and time from the coupler to all tasks call bcastGroup(cpl_time_string, cpl_master, MPI_COMM_WORLD) end subroutine coupler_atm_init !****************************************************************** !--- Receive fields from the coupler !****************************************************************** subroutine coupler_in ( 1 gtpal,gcpak,sicpak,sicnpak,snopako,respak,xsfxpak, #ifdef coupler_ctem 2 cfcanpat,zolncpat,ailcpat,cmascpat,calvcpat,calicpat, 3 fcancpat,ailcgpat,slaipat,rmatcpat,rtctmpat, 4 paicpat,slaicpat, #endif 5 ntrac,ijpak,lon1,ilat,nlat,ntld,kount, 6 ignd,ican,icanp1,ictem,ico2) C C * April 22,2016 - L.Solheim C * Remove all externally defined tag arrays C * Complete rewrite to process atm_recv_var, an externally defined C * list of variables that are to be received by the atm C C * July 06,2015 - M.Lazare. C * !--- Coupler related variables and procedures use com_cpl implicit none C C * Fields read from coupler (depending on cpp directives): C real, dimension (ijpak,ntrac):: xsfxpak real, dimension (ijpak) :: gtpal,gcpak,sicpak,sicnpak, 1 snopako,respak #ifdef coupler_ctem real, dimension (ijpak,ntld,icanp1) :: 1 cfcanpat,calvcpat,calicpat real, dimension (ijpak,ntld,ictem) :: 1 fcancpat,ailcgpat,slaipat real, dimension (ijpak,ntld,ican,ignd) :: rmatcpat real, dimension (ijpak,ntld,ictem,ignd) :: rtctmpat real, dimension (ijpak,ntld,ican) :: 1 zolncpat,ailcpat,cmascpat, 2 paicpat,slaicpat #endif C C * Array sizes: C integer :: ntrac,ijpak,lon1,ilat,nlat,ntld,kount, 1 ignd,ican,icanp1,ictem,ico2 real :: wrks(1) real, pointer :: gll(:) C C * Local integers: C integer k,l,m,n,nam,idx,nc4to8 type(cpl_vinfo_t) :: curr_vinfo integer :: atag(3), mpitag !================================================================== !--- Temporary space for the following transfers allocate( gll(lon1*ilat) ) !--- Send a time and date string from the coupler to the agcm !--- cpl_time_string is found in the com_cpl module call bcast_inter(cpl_time_string, cpl_master, "atm") !--- Send elasped coupler time in seconds from the coupler to the atm !--- cpl_elapsed_time_secs is found in the com_cpl module call bcast_inter(cpl_elapsed_time_secs, cpl_master, "atm") if ( atm_n_recv_var > 0 ) then do idx=1,atm_n_recv_var !--- Get information about the current variable curr_vinfo = 1 find_cpl_vinfo(name=trim(adjustl(atm_recv_var(idx)))) !--- Define the tag array used by MPI_GETCPL2 mpitag = curr_vinfo%tag atag = (/ mpitag, mpitag, curr_vinfo%size /) select case ( trim(adjustl(atm_recv_var(idx))) ) case ("GT_atm") !--- Ground temperature CALL MPI_GETCPL2(GTPAL, LON1, NLAT, 1, atag) case ("GC_atm") !--- Ground cover mask CALL MPI_GETCPL2(GCPAK, LON1,NLAT, 1, atag) case ("SIC_atm") !--- Sea ice thickness (IWE) CALL MPI_GETCPL2(SICPAK, LON1, NLAT, 1, atag) case ("SICN_atm") !--- Sea ice fraction CALL MPI_GETCPL2(SICNPAK, LON1, NLAT, 1, atag) case ("SNO_atm") !--- Snow thickness (SWE) CALL MPI_GETCPL2(SNOPAKO, LON1, NLAT, 1, atag) case ("RES_atm") !--- Residual over lakes CALL MPI_GETCPL2(RESPAK, LON1, NLAT, 1, atag) #ifdef coupler_ctem case ("FCANM_atm") !--- CTEM DO K = 1, ICANP1 DO M = 1, NTLD CALL MPI_GETCPL2(CFCANPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("ZOLN_atm") !--- CTEM DO K = 1, ICAN DO M = 1, NTLD CALL MPI_GETCPL2(ZOLNCPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("AIL_atm") !--- CTEM DO K = 1, ICAN DO M = 1, NTLD CALL MPI_GETCPL2( AILCPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("CMASV_atm") !--- CTEM DO K = 1, ICAN DO M = 1, NTLD CALL MPI_GETCPL2(CMASCPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("ALVIS_atm") !--- CTEM DO K = 1, ICANP1 DO M = 1, NTLD CALL MPI_GETCPL2(CALVCPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("ALNIR_atm") !--- CTEM DO K = 1, ICANP1 DO M = 1, NTLD CALL MPI_GETCPL2(CALICPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("CURF_atm") !--- CTEM DO K = 1, ICTEM DO M = 1, NTLD CALL MPI_GETCPL2(FCANCPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("AILC_atm") !--- CTEM DO K = 1, ICTEM DO M = 1, NTLD CALL MPI_GETCPL2(AILCGPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("SLAI_atm") !--- CTEM DO K = 1, ICTEM DO M = 1, NTLD CALL MPI_GETCPL2(SLAIPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("RMAT_atm") !--- CTEM DO L = 1, IGND DO K = 1, ICAN DO M = 1, NTLD CALL MPI_GETCPL2(RMATCPAT(1,M,K,L), LON1,NLAT, 1 1,atag) ENDDO ENDDO ENDDO case ("RMATCT_atm") !--- CTEM DO L = 1, IGND DO K = 1, ICTEM DO M = 1, NTLD CALL MPI_GETCPL2(RTCTMPAT(1,M,K,L), LON1,NLAT, 1 1,atag) ENDDO ENDDO ENDDO case ("PAIC_atm") !--- CTEM DO K = 1, ICAN DO M = 1, NTLD CALL MPI_GETCPL2(PAICPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO case ("SLAIC_atm") !--- CTEM DO K = 1, ICAN DO M = 1, NTLD CALL MPI_GETCPL2(SLAICPAT(1,M,K), LON1,NLAT,1,atag) ENDDO ENDDO #endif case ("CO2flx_atm") !--- CO2 flux from the ocean CALL MPI_GETCPL2(XSFXPAK(1,ICO2),LON1,NLAT,1,atag) case default write(6,'(2a)')'coupler_in: Unknown variable name ', 1 trim(atm_recv_var(idx)) call xit("coupler_in",-1) end select enddo else write(6,'(a)')'coupler_in: atm_n_recv_var == 0' call xit("coupler_in",-1) endif deallocate( gll ) end subroutine coupler_in !****************************************************************** !--- Send fields to the coupler !****************************************************************** subroutine coupler_out ( 1 ufspal,vfspal,ufsopal,vfsopal,ufsipal,vfsipal, #ifdef agcm_river_routing X obegpal,obwgpal,rofopal,rivogrd, #else X obegpal,obwgpal,rofopal, #endif 2 gtpal,gcpak,sicpak,sicnpak,snopako,ofsgpal,fsgopal,fsgipal, 3 pmslpal,swapal,xsrfpal,slimpal, X SLIMPlw,SLIMPsh,SLIMPlh,GTPAX, 4 hseapal,begopal,begipal,rainspal,snowspal,bwgopal,hflipal, #ifdef coupler_ctem 5 taptl,fsnowptl,tcanoptl,tcansptl, 6 tbarptl,tbarcptl,tbarcsptl,tbargptl,tbargsptl,thicecptl, 7 thliqcptl,thliqgptl,ancsptl,ancgptl,rmlcsptl,rmlcgptl, #endif 8 gll,wrks, 9 ntrac,ijpak,lon1,ilat,nlat,mynode, a luia,khem,npgg,k,ngll, b ntld,ignd,ictem,ico2) C * April 22,2016 - L.Solheim C * Remove all externally defined tag arrays C * Complete rewrite to process atm_send_var, an externally defined C * list of variables that are to be sent by the atm C C * July 06,2015 - M.Lazare. C * !--- Coupler related variables and procedures use com_cpl implicit none C C * Fields read from coupler (depending on cpp directives): C !--- Tiled components of wind stress real, dimension (ijpak) :: ufsopal,vfsopal,ufsipal,vfsipal real, dimension (ijpak,ntrac):: xsrfpal real, dimension (ijpak) :: ufspal,vfspal,obegpal,obwgpal, 1 rofopal,pmslpal,swapal real, dimension (ijpak) :: gtpal,gcpak,sicpak,sicnpak, 1 snopako,ofsgpal,fsgopal,fsgipal, 2 hseapal,begopal,begipal,slimpal, 3 rainspal,snowspal,bwgopal,hflipal real, dimension (ijpak) :: SLIMPlw,SLIMPsh,SLIMPlh real, dimension (ijpak,3) :: GTPAX real, dimension(lon1,nlat) :: RIVOGRD #ifdef coupler_ctem real, dimension (ijpak,ntld) :: taptl,fsnowptl,tcanoptl,tcansptl real, dimension (ijpak,ntld,ignd) :: 1 tbarptl,tbarcptl,tbarcsptl, 2 tbargptl,tbargsptl,thicecptl real, dimension (ijpak,ntld,ictem) :: 1 thliqcptl,thliqgptl, 2 ancsptl,ancgptl,rmlcsptl,rmlcgptl #endif C C * Work array: C real wrks(1),gll(ngll) C C * Array sizes: C integer :: ntrac,ijpak,lon1,ilat,nlat,ntld,ignd,ictem, 1 luia,khem,npgg,k,ngll,ico2 integer*4 :: mynode C C * Local integers: C integer :: l, m, n, nam, idx, nc4to8 type(cpl_vinfo_t) :: curr_vinfo integer :: atag(3), mpitag !================================================================== if ( atm_n_send_var > 0 ) then do idx=1,atm_n_send_var !--- Get information about the current variable curr_vinfo = 1 find_cpl_vinfo(name=trim(adjustl(atm_send_var(idx)))) !--- Define the tag array used by MPI_PUTGGB2 mpitag = curr_vinfo%tag atag = (/ mpitag, mpitag, curr_vinfo%size /) select case ( trim(adjustl(atm_send_var(idx))) ) case ("OUFS_atm") !--- Mixed atmosphere-Ocean wind stress (X component) CALL MPI_PUTGGB2(UFSPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("OUFS"),1,GLL,WRKS,atag) UFSPAL = 0.0 case ("OVFS_atm") !--- Mixed atmosphere-Ocean wind stress (Y component) CALL MPI_PUTGGB2(VFSPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("OVFS"),1,GLL,WRKS,atag) VFSPAL = 0.0 case ("UFSO_atm") !--- Atmosphere-Ocean wind stress over ocean (X component) !--- Tiled ocean value CALL MPI_PUTGGB2(ufsopal,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("UFSO"),1,GLL,WRKS,atag) ufsopal = 0.0 case ("VFSO_atm") !--- Atmosphere-Ocean wind stress over ocean (Y component) !--- Tiled ocean value CALL MPI_PUTGGB2(vfsopal,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("VFSO"),1,GLL,WRKS,atag) vfsopal = 0.0 case ("UFSI_atm") !--- Atmosphere-Ice wind stress over ice (X component) !--- Tiled ice value CALL MPI_PUTGGB2(ufsipal,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("UFSI"),1,GLL,WRKS,atag) ufsipal = 0.0 case ("VFSI_atm") !--- Atmosphere-Ice wind stress over ice (Y component) !--- Tiled ice value CALL MPI_PUTGGB2(vfsipal,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("VFSI"),1,GLL,WRKS,atag) vfsipal = 0.0 case ("OBEG_atm") !--- Mixed total heat flux CALL MPI_PUTGGB2(OBEGPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("OBEG"),1,GLL,WRKS,atag) OBEGPAL = 0.0 case ("OBWG_atm") !--- Mixed P-E CALL MPI_PUTGGB2(OBWGPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("OBWG"),1,GLL,WRKS,atag) OBWGPAL = 0.0 case ("ROFO_atm") !--- Runoff over land CALL MPI_PUTGGB2(ROFOPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("ROFO"),1,GLL,WRKS,atag) ROFOPAL = 0.0 case ("RIVO_atm") !--- River runoff over land #ifndef agcm_river_routing RIVOGRD = 0.0 #endif if ( mynode == atm_master ) then call send_data_rec(rivogrd, cpl_master, "RIVO_atm") RIVOGRD = 0.0 endif case ("GC_atm") !--- Ground cover mask CALL MPI_PUTGGB2(GCPAK,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8(" GC"),1,GLL,WRKS,atag) case ("GT_atm") !--- Ground temperature CALL MPI_PUTGGB2(GTPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8(" GT"),1,GLL,WRKS,atag) case ("GTICE_atm") !--- Sea ice temperature CALL MPI_PUTGGB2(GTPAX(1,3),LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8(" GTI"),1,GLL,WRKS,atag) case ("SIC_atm") !--- Sea ice thickness (IWE) CALL MPI_PUTGGB2(SICPAK,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8(" SIC"),1,GLL,WRKS,atag) case ("SICN_atm") !--- Sea ice fraction CALL MPI_PUTGGB2(SICNPAK,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("SICN"),1,GLL,WRKS,atag) case ("SNO_atm") !--- Snow thickness (SWE) CALL MPI_PUTGGB2(SNOPAKO,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8(" SNO"),1,GLL,WRKS,atag) case ("OFSG_atm") !--- Mixed solar heat flux over ocean and ice CALL MPI_PUTGGB2(OFSGPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("OFSG"),1,GLL,WRKS,atag) OFSGPAL = 0.0 case ("FSGO_atm") !--- Solar heat flux over ocean CALL MPI_PUTGGB2(fsgopal,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("FSGO"),1,GLL,WRKS,atag) fsgopal = 0.0 case ("FSGI_atm") !--- Solar heat flux over ice CALL MPI_PUTGGB2(fsgipal,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("FSGI"),1,GLL,WRKS,atag) fsgipal = 0.0 case ("SWMX_atm") !--- 10 meter wind CALL MPI_PUTGGB2(SWAPAL ,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("SWMX"),1,GLL,WRKS,atag) SWAPAL = 0.0 case ("BEGO_atm") !--- Total heat flux over ocean CALL MPI_PUTGGB2(BEGOPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("BEGO"),1,GLL,WRKS,atag) BEGOPAL = 0.0 case ("BWGO_atm") !--- P-E over ocean CALL MPI_PUTGGB2(BWGOPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("BWGO"),1,GLL,WRKS,atag) BWGOPAL = 0.0 case ("RAIN_atm") !--- Total liquid precipitation CALL MPI_PUTGGB2(RAINSPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("RAIN"),1,GLL,WRKS,atag) RAINSPAL = 0.0 case ("SNOW_atm") !--- Total solid precipitation CALL MPI_PUTGGB2(SNOWSPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("SNOW"),1,GLL,WRKS,atag) SNOWSPAL = 0.0 case ("HFLI_atm") !--- Lsat * (sublimation over sea ice) CALL MPI_PUTGGB2(HFLIPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("HFLI"),1,GLL,WRKS,atag) HFLIPAL = 0.0 case ("BEGI_atm") !--- Total heat flux over sea ice CALL MPI_PUTGGB2(BEGIPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("BEGI"),1,GLL,WRKS,atag) BEGIPAL = 0.0 case ("HSEA_atm") !--- Conductive heat flux over sea ice CALL MPI_PUTGGB2(HSEAPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("HSEA"),1,GLL,WRKS,atag) HSEAPAL = 0.0 case ("SLIM_atm") !--- Non-solar sensitivity to temperature (dQns/dT) CALL MPI_PUTGGB2(SLIMPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("SLIM"),1,GLL,WRKS,atag) SLIMPAL = 0.0 case ("SLIMlw_atm") !--- Term of Non-solar sensitivity to temperature (dQns/dT) CALL MPI_PUTGGB2(SLIMPlw,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("SLIM"),1,GLL,WRKS,atag) SLIMPlw = 0.0 case ("SLIMsh_atm") !--- Term of Non-solar sensitivity to temperature (dQns/dT) CALL MPI_PUTGGB2(SLIMPsh,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("SLIM"),1,GLL,WRKS,atag) SLIMPsh = 0.0 case ("SLIMlh_atm") !--- Term of Non-solar sensitivity to temperature (dQns/dT) CALL MPI_PUTGGB2(SLIMPlh,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("SLIM"),1,GLL,WRKS,atag) SLIMPlh = 0.0 case ("PMSL_atm") !--- Mean sea level pressure CALL MPI_PUTGGB2(PMSLPAL,LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("PMSL"),1,GLL,WRKS,atag) PMSLPAL = 0.0 case ("CO2_atm") !--- Atmospheric CO2 CALL NAME2(NAM,'XL',ICO2) CALL MPI_PUTGGB2(XSRFPAL(1,ICO2),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NAM,1,GLL,WRKS,atag) XSRFPAL = 0.0 #ifdef coupler_ctem case ("TA_atm") !--- CTEM DO M = 1, NTLD CALL MPI_PUTGGB2(TAPTL(1,M),LON1,ILAT,KHEM,NPGG,K,LUIA, 1 NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO TAPTL = 0.0 case ("FSNOW_atm") !--- CTEM DO M = 1, NTLD CALL MPI_PUTGGB2(FSNOWPTL(1,M),LON1,ILAT,KHEM,NPGG,K, 1 LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO FSNOWPTL = 0.0 case ("TCANO_atm") !--- CTEM DO M = 1, NTLD CALL MPI_PUTGGB2(TCANOPTL(1,M),LON1,ILAT,KHEM,NPGG,K, 1 LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO TCANOPTL = 0.0 case ("TCANS_atm") !--- CTEM DO M = 1, NTLD CALL MPI_PUTGGB2(TCANSPTL(1,M),LON1,ILAT,KHEM,NPGG,K, 1 LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO TCANSPTL = 0.0 case ("TBAR_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(TBARPTL(1,M,L),LON1,ILAT,KHEM,NPGG,K, 1 LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO TBARPTL = 0.0 case ("TBARC_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(TBARCPTL(1,M,L),LON1,ILAT,KHEM,NPGG,K, 1 LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO TBARCPTL = 0.0 case ("TBARCS_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(TBARCSPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO TBARCSPTL = 0.0 case ("TBARG_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(TBARGPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO TBARGPTL = 0.0 case ("TBARGS_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(TBARGSPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO TBARGSPTL = 0.0 case ("THLIQC_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(THLIQCPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO THLIQCPTL = 0.0 case ("THLIQG_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(THLIQGPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO THLIQGPTL = 0.0 case ("ANCS_atm") !--- CTEM DO L = 1, ICTEM DO M = 1, NTLD CALL MPI_PUTGGB2(ANCSPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO ANCSPTL = 0.0 case ("ANCG_atm") !--- CTEM DO L = 1, ICTEM DO M = 1, NTLD CALL MPI_PUTGGB2(ANCGPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO ANCGPTL = 0.0 case ("RMLCS_atm") !--- CTEM DO L = 1, ICTEM DO M = 1, NTLD CALL MPI_PUTGGB2(RMLCSPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO RMLCSPTL = 0.0 case ("RMLCG_atm") !--- CTEM DO L = 1, ICTEM DO M = 1, NTLD CALL MPI_PUTGGB2(RMLCGPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO RMLCGPTL = 0.0 case ("THICEC_atm") !--- CTEM DO L = 1, IGND DO M = 1, NTLD CALL MPI_PUTGGB2(THICECPTL(1,M,L),LON1,ILAT,KHEM,NPGG, 1 K,LUIA,NC4TO8("CTEM"),1,GLL,WRKS,atag) ENDDO ENDDO THICECPTL = 0.0 #endif case default write(6,'(2a)')'coupler_out: Unknown variable name ', 1 trim(atm_send_var(idx)) call xit("coupler_out",-1) end select enddo else write(6,'(a)')'coupler_out: atm_n_send_var == 0' call xit("coupler_out",-1) endif !--- These may not get zeroed above when coupled with NEMO/LIM2 OBEGPAL = 0.0 OBWGPAL = 0.0 PMSLPAL = 0.0 HSEAPAL = 0.0 XSRFPAL = 0.0 GTPAX = 0.0 !??? Should all input arrays be zeroed after each call to coupler_out ??? !??? As it stands now only those fields that are passed to the coupler are zeroed ??? #ifdef coupler_ctem TAPTL = 0. FSNOWPTL = 0. TCANOPTL = 0. TCANSPTL = 0. TBARPTL = 0. TBARCPTL = 0. TBARCSPTL = 0. TBARGPTL = 0. TBARGSPTL = 0. THLIQCPTL = 0. THLIQGPTL = 0. ANCSPTL = 0. ANCGPTL = 0. RMLCSPTL = 0. RMLCGPTL = 0. THICECPTL = 0. FSNOWPAT = 0. TCANOPAT = 0. TCANSPAT = 0. TBARCPAT = 0. TBARCSPAT = 0. TBARGPAT = 0. TBARGSPAT = 0. THLIQCPAT = 0. THLIQGPAT = 0. THICECPAT = 0. #endif end subroutine coupler_out end module cpl_atm #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # End new coupler related mods #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # Mike's nemo_cice updates #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %id remove_lakes %i gcm18.2354 WHERE (MASKPAK.EQ.2.) MASKPAK=0. ENDWHERE %id nemo_cice # Zero out lake temperatures # %i gcm18.2553 # WHERE(MASKPAK.EQ.2.) # GTPAL=273.16 # ENDWHERE %d gcm18.2436,2552 #if defined coupler_ghg !--- This will never be used IF(MYNODE.EQ.0) THEN call Recv_fld (GHG, JBUF, coupler, d_msg) END IF C IF (NNODE > 1) THEN CALL MPI_BCAST(GHG, 5_4, MY_REAL_TYPE, 0_4, + AGCM_COMMWRLD, ierr) END IF C CO2_PPM = GHG(1) CH4_PPM = GHG(2) N2O_PPM = GHG(3) C11_PPM = GHG(4) C12_PPM = GHG(5) #endif CALL COUPLER_IN( 1 GTPAL,GCPAK,SICPAK,SICNPAK,SNOPAKO,RESPAK,XSFXPAK, #ifdef coupler_ctem 2 CFCANPAT,ZOLNCPAT,AILCPAT,CMASCPAT,CALVCPAT,CALICPAT, 3 FCANCPAT,AILCGPAT,SLAIPAT,RMATCPAT,RTCTMPAT, 4 PAICPAT,SLAICPAT, #endif 5 NTRAC,IJPAK,LON1,ILAT,NLAT,NTLD,KOUNT, 6 IGND,ICAN,ICANP1,ICTEM,ICO2) #if defined (agcm_ctem) C C * ADD CO2 FLUX FROM CTEM TO THAT (PASSED FROM THE COUPLER) FOR THE OCEAN. C DO M=1,NTLD DO I=1,LONSL*ILAT XSFXPAK(I,ICO2) = XSFXPAK(I,ICO2) + (FCOLPAT(I,M)*0.044011)* 1 FAREPAT(I,M) ENDDO ENDDO #endif %d gcm18.4118,4172 CALL COUPLER_OUT( 1 UFSPAL,VFSPAL,ufsopal,vfsopal,ufsipal,vfsipal, #ifdef agcm_river_routing X OBEGPAL,OBWGPAL,ROFOPAL,RIVOGRD, #else X OBEGPAL,OBWGPAL,ROFOPAL, #endif 2 GTPAL,GCPAK,SICPAK,SICNPAK,SNOPAKO,OFSGPAL,FSGOPAL,FSGIPAL, 3 PMSLPAL,SWAPAL,XSRFPAL,SLIMPAL, X SLIMPlw,SLIMPsh,SLIMPlh,GTPAX, 4 HSEAPAL,BEGOPAL,BEGIPAL,RAINSPAL,SNOWSPAL,BWGOPAL,HFLIPAL, #ifdef coupler_ctem 5 TAPTL,FSNOWPTL,TCANOPTL,TCANSPTL, 6 TBARPTL,TBARCPTL,TBARCSPTL,TBARGPTL,TBARGSPTL,THICECPTL, 7 THLIQCPTL,THLIQGPTL,ANCSPTL,ANCGPTL,RMLCSPTL,RMLCGPTL, #endif 8 GLL,WRKS, 9 NTRAC,IJPAK,LON1,ILAT,nlat,mynode, A LUIA,KHEM,NPGG,K,NGLL, B NTLD,IGND,ICTEM,ICO2) C C ***** DO WE REALLY NEED TO DO THE FOLLOWING? TEST? ****** C CALL PKZEROS2( RESPAK, IJPAK, 1) CALL PKZEROS2(CBGOPAK, IJPAK, 1) #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # End Mike's nemo_cice updates #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # Accumulate tiled components found in GTROT (supplied by Mike) #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %id diagnostic_accumulated_gtpat %i compak12.317 COMMON /PAK/ GTPAX (IP0J,IM) %i comrow12.312 COMMON /ROW/ GTROX (ILG,IM) %i unpack10.386 GTROX (IL1:IL2,:)=GTPAX (IOFF+IL1:IOFF+IL2,:) %i pack10.395 GTPAX (IOFF+IL1:IOFF+IL2,:) = GTROX (IL1:IL2,:) %i init12.362 GTPAX=0. %i gcm18.2414 GTPAX=0. %i gcm18.4091 DO M=1,IM CALL PUTGGB3(GTPAX(1,M) ,LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8(" GTX"),LSWT(M),GLL,WRKS) ENDDO !--- Done in coupler_out --- GTPAX=0. %i rstarth.543 IBUF(3) = NC4TO8(" GTX") GTPAX = 0.0 C Until we get a restart containing SLIMPAL simply ignore this read C CALL RPKPHS4(LU, GTPAX, IM,IBUF,LONSL,NLAT,ILAT,LEV, C 1 LSWT,GLL,OK) C IF (.NOT.OK ) THEN C IBUFBAD=IBUF(3) C GO TO 500 C ENDIF %i rstarth.4379 IBUF(3) = NC4TO8(" GTX") CALL WPKPHS4(LU, GTPAX, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) %i physici.2914 DO M = 1, IM DO IL = IL1, IL2 GTROX (IL,M)=GTROX (IL,M)+GTROT(IL,M) *SAVEBEG ENDDO ENDDO #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # Mike's dQns/dT updates #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %id slim_lim2_sensitivity_field %i compak12.360 COMMON /PAK/ SLIMPAL(IP0J) COMMON /PAK/ SLIMPlw(IP0J),SLIMPsh(IP0J),SLIMPlh(IP0J) %i comrow12.352 COMMON /ROW/ SLIMROL (ILG) COMMON /ROW/ SLIMRlw(ILG),SLIMRsh(ILG),SLIMRlh(ILG) %i init12.363 CALL PKZEROS2(SLIMPAL,IJPAK, 1) CALL PKZEROS2(SLIMPlw,IJPAK, 1) CALL PKZEROS2(SLIMPsh,IJPAK, 1) CALL PKZEROS2(SLIMPlh,IJPAK, 1) %i unpack10.360 SLIMROL(I) = SLIMPAL(IOFF+I) SLIMRlw(I) = SLIMPlw(IOFF+I) SLIMRsh(I) = SLIMPsh(IOFF+I) SLIMRlh(I) = SLIMPlh(IOFF+I) %i pack10.367 SLIMPAL(IOFF+I) = SLIMROL(I) SLIMPlw(IOFF+I) = SLIMRlw(I) SLIMPsh(IOFF+I) = SLIMRsh(I) SLIMPlh(IOFF+I) = SLIMRlh(I) %i rstarth.2924 IBUF(3) = NC4TO8("SLIM") SLIMPAL = 0.0 SLIMPlw = 0.0 SLIMPsh = 0.0 SLIMPlh = 0.0 C Until we get a restart containing SLIMPAL simply ignore this read C CALL RPKPHS4(LU,SLIMPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, C 1 OK) C IF (.NOT.OK ) THEN C IBUFBAD=IBUF(3) C GO TO 500 C ENDIF %i rstarth.5420 IBUF(3) = NC4TO8("SLIM") CALL WPKPHS4(LU,SLIMPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) %i gcm18.2427 CALL PKZEROS2(SLIMPAL, IJPAK, 1) CALL PKZEROS2(SLIMPlw, IJPAK, 1) CALL PKZEROS2(SLIMPsh, IJPAK, 1) CALL PKZEROS2(SLIMPlh, IJPAK, 1) %i physici.2803 C C * ADD L/W CONTRIBUTION TO LIM SENSITIVITY FIELD (SLIM). C DO I=IL1,IL2 IF(SICNROW(I).GT.0.) THEN SLIMROL(I) = SLIMROL(I) - 4.*SBC*EMISROT(I,IOSIC)* 1 (GTROT(I,IOSIC)**3)*SAVEBEG SLIMRlw(I) = SLIMRlw(I) - 4.*SBC*EMISROT(I,IOSIC)* 1 (GTROT(I,IOSIC)**3)*SAVEBEG ENDIF ENDDO %d physici.2818 D BEGIROL,BEGOROL,OBEGROL, BEGROW,HFLIROL,SLIMROL, D SLIMRsh,SLIMRlh, %d sfcproc2.16 E BEGIROL,BEGOROL,OBEGROL, BEGROW,HFLIROL,SLIMROL, E SLIMRsh,SLIMRlh, %d sfcproc2.415 1 BEGIROL,BEGOROL,OBEGROL, BEGROW,HFLIROL,SLIMROL, 1 SLIMRsh,SLIMRlh, %i sfcproc2.684 REAL, DIMENSION(ILG) :: SLIM,SLIMsh,SLIMlh REAL, DIMENSION(ILGM) :: SLIMGAT %i sfcproc2.828 SLIM=0. ; SLIMsh=0. ; SLIMlh=0. %d sfcproc2.1894,1896 1 QFXGAT, CDHGAT, CDMGAT, SLIMGAT, 2 SFCTGAT, SFCUGAT, SFCVGAT, SFCQGAT, 3 SFCHGAT, DRGAT, GCGAT, ULGAT, %i sfcproc2.1910 SLIM(IWMOS(K)) = -SPHAIR*SLIMGAT(K) - 1 (CLHMLT+CLHVAP)*SLIMGAT(K)* 2 (CLHMLT+CLHVAP)*QGGAT(K)/ 3 (RGASV*(GTGAT(K)**2)) SLIMsh(IWMOS(K)) = -SPHAIR*SLIMGAT(K) SLIMlh(IWMOS(K)) = -(CLHMLT+CLHVAP)*SLIMGAT(K)* 2 (CLHMLT+CLHVAP)*QGGAT(K)/ 3 (RGASV*(GTGAT(K)**2)) if (abs(slim(iwmos(k))) > 1e10) then write(6,*)"kount=",kount," k=",k,iwmos(k),size(slim), 1 " SLIM=",slim(iwmos(k)), & " slimgat=",SLIMGAT(K)," qggat=",QGGAT(K)," gtgat=",GTGAT(K) endif %i sfcproc2.2134 SLIMROL(I) = SLIMROL(I) + SLIM (I) *SAVEBEG SLIMRsh(I) = SLIMRsh(I) + SLIMsh (I) *SAVEBEG SLIMRlh(I) = SLIMRlh(I) + SLIMlh (I) *SAVEBEG #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # End Mike's dQns/dT updates #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %id river_routing %i compak12.621 COMMON /PAK/ ROFPAL (IP0J) %i comrow12.610 COMMON /ROW/ ROFROL (ILG) %i unpack10.490 ROFROL (I) = ROFPAL (IOFF+I) %i pack10.469 ROFPAL (IOFF+I) = ROFROL (I) %i init12.347 CALL PKZEROS2(ROFPAL, IJPAK, 1) %i saveacc6.2188 CALL PUTGGB3(ROFPAL, LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8(" RFL") 1 ,1,GLL,WRKS) %i saveacc6.2222 CALL PKZEROS2(ROFPAL, IJPAK, 1) %i rstarth.2820 if(kount.gt.85848000) then IBUF(3) = NC4TO8(" RFL") CALL RPKPHS4(LU,ROFPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, 1 OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF endif %i rstarth.5381 IBUF(3) = NC4TO8(" RFL") CALL WPKPHS4(LU,ROFPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) %i gcm18.2429 CALL PKZEROS2(ROFPAL, IJPAK, 1) %i gcm18.4071 CALL PUTGGB3(ROFPAL, LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8(" RFL"),1,GLL,WRKS) %id bugfixes_new %d physici.1009,1010 %d physici.1014,1022 %i physici.2836 + FCANROW,LNZ0ROW, %i sfcproc2.34 + FCANROW,LNZ0ROW, %i sfcproc2.551 C C * ARRAYS USED FOR OTHER PURPOSES IN PHYSICS. C REAL, DIMENSION(ILG,ICANP1) :: FCANROW, LNZ0ROW %d sfcproc2.820 FNROL=0. ; SALBROL=0. ; CSALROL=0. ; HMFNROL=0. %i sfcproc2.1082 FCANROW=0. ; LNZ0ROW=0. %d sfcproc2.1106 HFCNROL=0. ; HFCVROL=0. ; HMFVROL=0. %i sfcproc2.1707 C C * Calculate diagnostic ICAN+1 fields to be used elsewhere in physics. C DO 412 L=1,ICANP1 DO 412 K=1,NML IF(FLNDROW(ILMOS(K)).GT.0.) THEN FAREA=FAREROT(ILMOS(K),JLMOS(K))/FLNDROW(ILMOS(K)) ELSE FAREA=0. ENDIF C FCANROW(ILMOS(K),L) = FCANROW(ILMOS(K),L)+FCANGAT(K,L)*FAREA LNZ0ROW(ILMOS(K),L) = LNZ0ROW(ILMOS(K),L)+LNZ0GAT(K,L)*FAREA 412 CONTINUE %id tile_vrt %i compak12.382 COMMON /PAK/ UFSIPAL(IP0J) COMMON /PAK/ UFSOPAL(IP0J) %i compak12.384 COMMON /PAK/ VFSIPAL(IP0J) COMMON /PAK/ VFSOPAL(IP0J) %i comrow12.374 COMMON /ROW/ UFSIROL(ILG) COMMON /ROW/ UFSOROL(ILG) %i comrow12.376 COMMON /ROW/ VFSIROL(ILG) COMMON /ROW/ VFSOROL(ILG) %i unpack10.381 UFSIROL(I) = UFSIPAL(IOFF+I) UFSOROL(I) = UFSOPAL(IOFF+I) %i unpack10.383 VFSIROL(I) = VFSIPAL(IOFF+I) VFSOROL(I) = VFSOPAL(IOFF+I) %i pack10.390 UFSIPAL(IOFF+I) = UFSIROL(I) UFSOPAL(IOFF+I) = UFSOROL(I) %i pack10.392 VFSIPAL(IOFF+I) = VFSIROL(I) VFSOPAL(IOFF+I) = VFSOROL(I) %i init12.350 CALL PKZEROS2(UFSIPAL,IJPAK, 1) CALL PKZEROS2(VFSIPAL,IJPAK, 1) CALL PKZEROS2(UFSOPAL,IJPAK, 1) CALL PKZEROS2(VFSOPAL,IJPAK, 1) %i saveacc6.2174 CALL PUTGGB3(UFSIPAL,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("UFSI") 1 ,1,GLL,WRKS) CALL PUTGGB3(VFSIPAL,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("VFSI") 1 ,1,GLL,WRKS) CALL PUTGGB3(UFSOPAL,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("UFSO") 1 ,1,GLL,WRKS) CALL PUTGGB3(VFSOPAL,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("VFSO") 1 ,1,GLL,WRKS) %i saveacc6.2215 CALL PKZEROS2(UFSIPAL,IJPAK, 1) CALL PKZEROS2(VFSIPAL,IJPAK, 1) CALL PKZEROS2(UFSOPAL,IJPAK, 1) CALL PKZEROS2(VFSOPAL,IJPAK, 1) %i rstarth.2844 C C * Read the label at the current file pointer then reposition the C * pointer at the start of this label. C CALL FBUFFIN (-LU,JBUF,-8,KK,KLEN) IF(KK.GE.0) GO TO 500 BACKSPACE (LU) IF (JBUF(3).NE.NC4TO8("UFSI")) THEN UFSIPAL=0. VFSIPAL=0. UFSOPAL=0. VFSOPAL=0. ELSE IBUF(3) = NC4TO8("UFSI") CALL RPKPHS4(LU,UFSIPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, 1 OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("VFSI") CALL RPKPHS4(LU,VFSIPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, 1 OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("UFSO") CALL RPKPHS4(LU,UFSOPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, 1 OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("VFSO") CALL RPKPHS4(LU,VFSOPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, 1 OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF ENDIF %i rstarth.5390 IBUF(3) = NC4TO8("UFSI") CALL WPKPHS4(LU,UFSIPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) IBUF(3) = NC4TO8("VFSI") CALL WPKPHS4(LU,VFSIPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) IBUF(3) = NC4TO8("UFSO") CALL WPKPHS4(LU,UFSOPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) IBUF(3) = NC4TO8("VFSO") CALL WPKPHS4(LU,VFSOPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) %i gcm18.2421 CALL PKZEROS2(UFSIPAL,IJPAK, 1) CALL PKZEROS2(VFSIPAL,IJPAK, 1) CALL PKZEROS2(UFSOPAL,IJPAK, 1) CALL PKZEROS2(VFSOPAL,IJPAK, 1) %i gcm18.4061 CALL PUTGGB3(UFSIPAL,LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8("UFSI"),1,GLL,WRKS) CALL PUTGGB3(VFSIPAL,LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8("VFSI"),1,GLL,WRKS) CALL PUTGGB3(UFSOPAL,LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8("UFSO"),1,GLL,WRKS) CALL PUTGGB3(VFSOPAL,LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8("VFSO"),1,GLL,WRKS) %d physici.645 REAL, DIMENSION(ILG) :: EFROW,QGROW,TSROW, %i physici.663 REAL, DIMENSION(ILG,IM) :: CDMROT,QGROT,HFSROT,QFSROT %d physici.668 %d physici.714,715 5 SUBROL , SEDIROL %d physici.1111,1114 %d physici.2805 CALL SFCPROC2( HFSROL, HFLROL, QFSROL,TFXROW, QFXROW, + HFSROT, CDMROT, QGROT, QFSROT, %d physici.2819 F BWGOROL,OBWGROL,BWGROW, + ROFROL, ROFROW, ROFOROL,ROFOROW, %d physici.3069,3082 CALL VRTDF22(THROW(1,2), QROW(1,2), UROW, VROW, XROW, 1 UTG, VTG, 2 UFSIROL, VFSIROL, UFSOROL, VFSOROL, 3 UFSROL, VFSROL, UFSROW, VFSROW, 4 ALMXROW, ALMCROW, PBLTROW, 5 CNDROL, DEPROL, WSUB, C C ------------- OUTPUTS OR UPDATED INPUTS ARE ABOVE THIS LINE, C ------------- INPUTS ARE BELOW. C 6 GTROT, QGROT, CDMROT, QFSROT, HFSROT, 7 GTROW, QGROW, CDM, QFSROL, HFSROL, 8 FAREROT, PRESSG, CHTOP, ZSPD, 9 CQFXROW, CHFXROW, A UTENDGW, VTENDGW, TSGB, TFROW, SGJ, B SGBJ, SHTXKJ, SHXKJ, SHTJ, SHTJ(1,2), C SHJ, DSGJ, DSHJ, CVSGROW, ZCLF, D ITRPHS, ILWC, IIWC, IOWAT, IOSIC, E DTADV, ILG, IL1, IL2, IM, F ILEV, ILEV+1, LEVS, NTRAC, IPAM, G ISAVLS, SAVERAD, SAVEBEG ) %d physici.3256 %d physici.3292,3297 %d sfcproc2.3 1 HFSROL, HFLROL, QFSROL, TFXROW, QFXROW, + HFSROT, CDMROT, QGROT, QFSROT, %d sfcproc2.17 F BWGOROL,OBWGROL,BWGROW, + ROFROL, ROFROW, ROFOROL,ROFOROW, %d sfcproc2.381 3 REFROT, BCSNROT, EMISROT, 4 CDMROT, QGROT, HFSROT, QFSROT %d sfcproc2.522,523 A QFGROW, QFNROW, QFVLROW, QFVFROW, + ROFROL, ROFROW, ROFOROL, ROFOROW, B ROFSROW, ROFBROW, ROFVROW, %d sfcproc2.817 QFXROW=0. ; HFLROL=0. ; EFROW=0. ; QGROW=0. %d sfcproc2.1138 QFXGAT=0. ; HFLGAT=0. ; EFGAT=0. ; QGGAT=0. %d sfcproc2.1154,1155 ROFGAT=0. ; ROFOGAT=0. ; ROFSGAT=0. ; ROFBGAT=0. ; TROFGAT=0. TROOGAT=0. ; TROSGAT=0. ; TROBGAT=0. ; ROFVGAT=0. ; ROVGGAT=0. %i sfcproc2.1469 4 CDMROT, QGROT, HFSROT, QFSROT, %d sfcproc2.1476 B REFGAT, BCSNGAT,EMISGAT,SALBGAT,CSALGAT, C CDMGAT, QGGAT, HFSGAT, QFSGAT ) %d sfcproc2.1673 ROFROW (ILMOS(K))=ROFROW (ILMOS(K))+ROFGAT (K)*FAREA*SAVERAD ROFROL (ILMOS(K))=ROFROL (ILMOS(K))+ROFGAT (K)*FAREA*SAVEBEG %d sfcproc2.1971 2 CDMROT, QGROT, HFSROT, QFSROT, SALBROT, CSALROT, %d sfcproc2.1976 7 CDMGAT, QGGAT, HFSGAT, QFSGAT, SALBGAT, CSALGAT) %d sfcproc2.2113 %id sic_gat %d sfcproc2.421 1 SFCUBSGAT, SFCVBSGAT, USTARBSGAT, 2 TISLGAT, HSEAGAT, CBGOGAT, DSICGAT, 3 BEGOGAT, BWGOGAT %d sfcproc2.1805 SALBGAT=0. ; CSALGAT=0. ZNGAT=0. ; SMLTGAT=0. ; FNGAT=0. ; DRGAT=0. ; DEPBGAT=0. SPCPGAT=0. ; RHSIGAT=0. ; TZSGAT=0. ; WTRNGAT=0.; WTRGGAT=0. ROFNGAT=0. %d sfcproc2.1815 VMODSOGAT=0.; TISLGAT=0.; HSEAGAT=0. ; CBGOGAT=0.; DSICGAT=0. BEGOGAT=0. ; BWGOGAT=0.; SLIMGAT=0. %i sfcproc2.1825 + DEPBGAT, SPCPGAT, RHSIGAT, PREGAT, %i sfcproc2.1836 + DEPBROW, SPCPROW, RHSIROW, PREROW, %i sfcproc2.1860 DSICGAT (K)=DSICROW(IWMOS(K))/SICNROW(IWMOS(K)) ! value over ice-covered portion %i sfcproc2.1864 DSICGAT (K)=0. %i sfcproc2.1965 C------------------------------------------------------------------------- C * SEA-ICE THERMODYNAMICS. C * ONLY TIME THIS IS **NOT** DONE IS WHEN RUNNING OLD COUPLED C * OCEAN MODEL (ICEFAC.NE.0). IN THAT CASE, OLD USUAL SECTION C * (NON-GATHERED) IS STILL DONE. C IF(ICEFAC.EQ.0) THEN C * INITIALIZE RUNOFF OVER ICE WITH RAINFALL. C DO K=1,NMW IF(GCGAT(K).EQ.1.) THEN ROFGAT(K)=RPREROW(IWMOS(K)) ENDIF ENDDO C C * GROUND ENERGY BALANCE, GROUND TEMPERATURE UPDATE AND C * THERMODYNAMIC SEA-ICE MODEL OVER SEA-ICE. C IF(NICE.GT.0) THEN CALL OIFPST10(GTGAT, SNOGAT, SICGAT, BEGOGAT, 1 BWGOGAT, ZNGAT, ANGAT, 2 DSICGAT, ROFGAT, GCGAT, PRESGAT, 3 GTAGAT, HSEAGAT, TAGAT, QAGAT, 4 HFSGAT, HFLGAT, FSGGAT, FLGGAT, 5 CBGOGAT, SMLTGAT, 6 WTRGGAT, WTRNGAT, TISLGAT, RHONGAT, 7 ROFNGAT, FNGAT, 8 DELT,ILGM,1,NMW ) ENDIF C C * THE REMAINING LOOPS ARE DONE IN "GAT" SPACE BECAUSE C * THEY ARE OUTPUT DIAGNOSTIC FIELDS AND NEED NO C * ASSOCIATED ROT ARRAYS. C * AS PART OF THE NEXT LOOP, THE FOLLOWING IS NEEDED: C * CALCULATE EFFECTIVE HEAT CAPACITY OF MIXED-LAYER SLAB. C * CPMIX: HEAT CAPACITY FOR DEP METERS OF SEA WATER (W M-2 K-1) C CPMIX=DNSW*DEP*CPW C DO K=1,NMW FAREA=FAREROT(IWMOS(K),JWMOS(K)) HSEAROL(IWMOS(K))=HSEAROL(IWMOS(K))+HSEAGAT(K)* SAVEBEG FNROW (IWMOS(K))=FNROW (IWMOS(K))+FNGAT (K)*FAREA*SAVERAD ZNROL (IWMOS(K))=ZNROL (IWMOS(K))+ZNGAT (K)*FAREA SMLTROL(IWMOS(K))=SMLTROL(IWMOS(K))+SMLTGAT(K)*FAREA WTRNROW(IWMOS(K))=WTRNROW(IWMOS(K))+WTRNGAT(K)*FAREA*SAVERAD WTRGROW(IWMOS(K))=WTRGROW(IWMOS(K))+WTRGGAT(K)*FAREA*SAVERAD CBGOROW(IWMOS(K))=CBGOROW(IWMOS(K))+CBGOGAT(K)*FAREA*SAVERAD C C * Energy and water balances and residual. C EA = QAGAT(K)*PRESGAT(K)/(0.622+0.378*QAGAT(K)) PADRY = PRESGAT(K)-EA CONST = PADRY/(RGAS*TAGAT(K))+EA/(RGASV*TAGAT(K)) PME = CONST*QFXGAT(K)+PREGAT(K) FACTADD = FSGGAT(K)+FLGGAT(K)-HFSGAT(K)-HFLGAT(K) C BEGROW (IWMOS(K))=BEGROW (IWMOS(K))+FACTADD *FAREA*SAVERAD IF(GCGAT(K).EQ.1.) THEN BEGIROL(IWMOS(K))=BEGIROL(IWMOS(K))+FACTADD *SAVEBEG HFLIROL(IWMOS(K))=HFLIROL(IWMOS(K))+HFLGAT(K) *SAVEBEG OBEGROL(IWMOS(K))=OBEGROL(IWMOS(K))+BEGOGAT(K)*FAREA*SAVEBEG OBWGROL(IWMOS(K))=OBWGROL(IWMOS(K))+BWGOGAT(K)*FAREA*SAVEBEG BWGROW (IWMOS(K))=BWGROW (IWMOS(K))+BWGOGAT(K)*FAREA*SAVERAD RESROW (IWMOS(K))=RESROW (IWMOS(K))-BEGOGAT(K)*FAREA*SAVEBEG C C * Lim2 sensitivity field (seaice only!). C SLIMFAC = -SPHAIR*SLIMGAT(K) - 1 (CLHMLT+CLHVAP)*SLIMGAT(K)* 2 (CLHMLT+CLHVAP)*QGGAT(K)/ 3 (RGASV*(GTGAT(K)**2)) SLIMSHFAC = -SPHAIR*SLIMGAT(K) SLIMLHFAC = -(CLHMLT+CLHVAP)*SLIMGAT(K)* 1 (CLHMLT+CLHVAP)*QGGAT(K)/ 2 (RGASV*(GTGAT(K)**2)) SLIMROL(IWMOS(K))=SLIMROL(IWMOS(K))+ SLIMFAC *SAVEBEG SLIMRsh(IWMOS(K))=SLIMRsh(IWMOS(K))+ SLIMSHFAC *SAVEBEG SLIMRlh(IWMOS(K))=SLIMRlh(IWMOS(K))+ SLIMLHFAC *SAVEBEG C ELSE IF(GCGAT(K).EQ.0.) THEN BEGOROL(IWMOS(K))=BEGOROL(IWMOS(K))+FACTADD *SAVEBEG EA = QAGAT(K)*PRESGAT(K)/(0.622+0.378*QAGAT(K)) PADRY = PRESGAT(K)-EA CONST = PADRY/(RGAS*TAGAT(K))+EA/(RGASV*TAGAT(K)) PME = CONST*QFXGAT(K)+PREGAT(K) BWGOROL(IWMOS(K))=BWGOROL(IWMOS(K))+PME *SAVEBEG OBEGROL(IWMOS(K))=OBEGROL(IWMOS(K))+FACTADD *FAREA*SAVEBEG OBWGROL(IWMOS(K))=OBWGROL(IWMOS(K))+PME *FAREA*SAVEBEG BWGROW (IWMOS(K))=BWGROW (IWMOS(K))+PME *FAREA*SAVERAD DFAC = CPMIX*(GTGAT(K)-GTPREV(IWMOS(K)))/DELT-FACTADD RESROW (IWMOS(K))=RESROW (IWMOS(K))+DFAC *FAREA*SAVEBEG ENDIF C PCSNGAT(K)=SPCPGAT(K)*RHSIGAT(K) C C * ENSURE CONSISTENCY BETWEEN SNO AND {AN,RHON}. C IF(SNOGAT(K).LE.0.) THEN ANGAT (K)=0. RHONGAT(K)=0. ENDIF C C * CALCULATE TN AND TZS. C IF(GCGAT(K).EQ.1. .AND. ZNGAT(K).GT.ZSNMIN) THEN TNGAT (K) = 0.50*(TISLGAT(K)+GTGAT(K)) TZSGAT(K) = ABS( (TISLGAT(K)-GTGAT(K))/ 1 MIN(2.E-1,ZNGAT(K))) ELSE TNGAT (K)=0. TZSGAT(K)=0. ENDIF ENDDO GCMIN=0.5 GCMAX=1.5 CALL RDSDRY(SNOGAT,TNGAT,ZNGAT,TZSGAT,RHONGAT,REFGAT, 1 GCGAT,DELT,ILGM,1,NMW,GCMIN,GCMAX) CALL RDSDPS(SNOGAT,ZNGAT,PCSNGAT,RHONGAT,REFGAT,GCGAT, 1 DELT,ZSNMIN,ZSNMAX2,ILGM,1,NMW,GCMIN,GCMAX) CALL BCCONC(ZNGAT,GCGAT,BCSNGAT,DEPBGAT,PCSNGAT,ROFNGAT, 1 RHONGAT,DELT,ZSNMIN,ZSNMAX1,ILGM,1,NMW, 2 GCMIN,GCMAX) ENDIF ! ICEFAC.EQ.0 C-------------------------------------------------------------- %d sfcproc2.2030,2033 %i sfcproc2.2036 IF(ICEFAC.NE.0) THEN %d sfcproc2.2143,2152 %i sfcproc2.2154 ENDIF ! ICEFAC.NE.0 %id rad_tiling %i compak12.246 COMMON /PAK/ CLBPAT (IP0J,IM) %i compak12.254 COMMON /PAK/ CSBPAT (IP0J,IM) %i compak12.255 COMMON /PAK/ CSDPAT (IP0J,IM) %i compak12.256 COMMON /PAK/ CSFPAT (IP0J,IM) %i compak12.268 COMMON /PAK/ FDLPAT (IP0J,IM) %i compak12.270 COMMON /PAK/ FDLCPAT(IP0J,IM) %i compak12.278 COMMON /PAK/ FLGPAT (IP0J,IM) %i compak12.287 COMMON /PAK/ FSDPAT (IP0J,IM) %i compak12.288 COMMON /PAK/ FSFPAT (IP0J,IM) %i compak12.291 COMMON /PAK/ FSGIPAL(IP0J) COMMON /PAK/ FSGOPAL(IP0J) COMMON /PAK/ FSGPAT (IP0J,IM) %i compak12.292 COMMON /PAK/ FSIPAT (IP0J,IM) %i compak12.304 COMMON /PAK/ FSVPAT (IP0J,IM) %i compak12.305 COMMON /PAK/ FSDBPAT (IP0J,IM,NBS) %i compak12.306 COMMON /PAK/ FSFBPAT (IP0J,IM,NBS) %i compak12.307 COMMON /PAK/ CSDBPAT (IP0J,IM,NBS) %i compak12.308 COMMON /PAK/ CSFBPAT (IP0J,IM,NBS) %i compak12.309 COMMON /PAK/ FSSBPAT (IP0J,IM,NBS) %i compak12.310 COMMON /PAK/ FSSCBPAT(IP0J,IM,NBS) %i compak12.333 COMMON /PAK/ PARPAT (IP0J,IM) %i compak12.799 COMMON /PAK/ CSBPAT_R (IP0J,IM,NRFP) COMMON /PAK/ CLBPAT_R (IP0J,IM,NRFP) COMMON /PAK/ FSGPAT_R (IP0J,IM,NRFP) COMMON /PAK/ FLGPAT_R (IP0J,IM,NRFP) %i comrow12.242 COMMON /ROW/ CLBROT (ILG,IM) %i comrow12.250 COMMON /ROW/ CSBROT (ILG,IM) %i comrow12.251 COMMON /ROW/ CSDROT (ILG,IM) %i comrow12.252 COMMON /ROW/ CSFROT (ILG,IM) %i comrow12.264 COMMON /ROW/ FDLROT (ILG,IM) %i comrow12.263 COMMON /ROW/ FDLCROT (ILG,IM) %i comrow12.273 COMMON /ROW/ FLGROT (ILG,IM) %i comrow12.281 COMMON /ROW/ FSDROT (ILG,IM) %i comrow12.283 COMMON /ROW/ FSFROT (ILG,IM) %i comrow12.285 COMMON /ROW/ FSGIROL(ILG) COMMON /ROW/ FSGOROL(ILG) COMMON /ROW/ FSGROT (ILG,IM) %i comrow12.287 COMMON /ROW/ FSIROT (ILG,IM) %i comrow12.299 COMMON /ROW/ FSVROT (ILG,IM) %i comrow12.300 COMMON /ROW/ FSDBROT (ILG,IM,NBS) %i comrow12.301 COMMON /ROW/ FSFBROT (ILG,IM,NBS) %i comrow12.302 COMMON /ROW/ CSDBROT (ILG,IM,NBS) %i comrow12.303 COMMON /ROW/ CSFBROT (ILG,IM,NBS) %i comrow12.304 COMMON /ROW/ FSSBROT (ILG,IM,NBS) %i comrow12.305 COMMON /ROW/ FSSCBROT(ILG,IM,NBS) %i comrow12.326 COMMON /ROW/ PARROT (ILG,IM) %i comrow12.745 COMMON /ROW/ CSBROT_R (ILG,IM,NRFP) COMMON /ROW/ CLBROT_R (ILG,IM,NRFP) COMMON /ROW/ FSGROT_R (ILG,IM,NRFP) COMMON /ROW/ FLGROT_R (ILG,IM,NRFP) %i unpack10.299 FSGIROL(I) = FSGIPAL(IOFF+I) FSGOROL(I) = FSGOPAL(IOFF+I) %i unpack10.400 CLBROT (IL1:IL2,:)=CLBPAT (IOFF+IL1:IOFF+IL2,:) CSBROT (IL1:IL2,:)=CSBPAT (IOFF+IL1:IOFF+IL2,:) CSDROT (IL1:IL2,:)=CSDPAT (IOFF+IL1:IOFF+IL2,:) CSFROT (IL1:IL2,:)=CSFPAT (IOFF+IL1:IOFF+IL2,:) FDLROT (IL1:IL2,:)=FDLPAT (IOFF+IL1:IOFF+IL2,:) FDLCROT(IL1:IL2,:)=FDLCPAT(IOFF+IL1:IOFF+IL2,:) FLGROT (IL1:IL2,:)=FLGPAT (IOFF+IL1:IOFF+IL2,:) FSDROT (IL1:IL2,:)=FSDPAT (IOFF+IL1:IOFF+IL2,:) FSFROT (IL1:IL2,:)=FSFPAT (IOFF+IL1:IOFF+IL2,:) FSGROT (IL1:IL2,:)=FSGPAT (IOFF+IL1:IOFF+IL2,:) FSIROT (IL1:IL2,:)=FSIPAT (IOFF+IL1:IOFF+IL2,:) FSVROT (IL1:IL2,:)=FSVPAT (IOFF+IL1:IOFF+IL2,:) PARROT (IL1:IL2,:)=PARPAT (IOFF+IL1:IOFF+IL2,:) C DO L = 1, NBS DO M = 1, IM DO I = IL1, IL2 FSDBROT (I,M,L) = FSDBPAT (IOFF+I,M,L) FSFBROT (I,M,L) = FSFBPAT (IOFF+I,M,L) CSDBROT (I,M,L) = CSDBPAT (IOFF+I,M,L) CSFBROT (I,M,L) = CSFBPAT (IOFF+I,M,L) FSSBROT (I,M,L) = FSSBPAT (IOFF+I,M,L) FSSCBROT(I,M,L) = FSSCBPAT(IOFF+I,M,L) END DO END DO END DO C %i unpack10.864 DO M = 1, IM CSBROT_R(IL1:IL2,M,1:NRFP) = CSBPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) CLBROT_R(IL1:IL2,M,1:NRFP) = CLBPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) FSGROT_R(IL1:IL2,M,1:NRFP) = FSGPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) FLGROT_R(IL1:IL2,M,1:NRFP) = FLGPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) END DO ! M %i pack10.308 FSGIPAL(IOFF+I) = FSGIROL(I) FSGOPAL(IOFF+I) = FSGOROL(I) %i pack10.409 CLBPAT (IOFF+IL1:IOFF+IL2,:)=CLBROT (IL1:IL2,:) CSBPAT (IOFF+IL1:IOFF+IL2,:)=CSBROT (IL1:IL2,:) CSDPAT (IOFF+IL1:IOFF+IL2,:)=CSDROT (IL1:IL2,:) CSFPAT (IOFF+IL1:IOFF+IL2,:)=CSFROT (IL1:IL2,:) FDLPAT (IOFF+IL1:IOFF+IL2,:)=FDLROT (IL1:IL2,:) FDLCPAT(IOFF+IL1:IOFF+IL2,:)=FDLCROT(IL1:IL2,:) FLGPAT (IOFF+IL1:IOFF+IL2,:)=FLGROT (IL1:IL2,:) FSDPAT (IOFF+IL1:IOFF+IL2,:)=FSDROT (IL1:IL2,:) FSFPAT (IOFF+IL1:IOFF+IL2,:)=FSFROT (IL1:IL2,:) FSGPAT (IOFF+IL1:IOFF+IL2,:)=FSGROT (IL1:IL2,:) FSIPAT (IOFF+IL1:IOFF+IL2,:)=FSIROT (IL1:IL2,:) FSVPAT (IOFF+IL1:IOFF+IL2,:)=FSVROT (IL1:IL2,:) PARPAT (IOFF+IL1:IOFF+IL2,:)=PARROT (IL1:IL2,:) C DO L = 1, NBS DO M = 1, IM DO I = IL1, IL2 FSDBPAT (IOFF+I,M,L) = FSDBROT (I,M,L) FSFBPAT (IOFF+I,M,L) = FSFBROT (I,M,L) CSDBPAT (IOFF+I,M,L) = CSDBROT (I,M,L) CSFBPAT (IOFF+I,M,L) = CSFBROT (I,M,L) FSSBPAT (IOFF+I,M,L) = FSSBROT (I,M,L) FSSCBPAT(IOFF+I,M,L) = FSSCBROT(I,M,L) END DO END DO END DO C %i pack10.853 DO M = 1, IM CSBPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) = CSBROT_R(IL1:IL2,M,1:NRFP) CLBPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) = CLBROT_R(IL1:IL2,M,1:NRFP) FSGPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) = FSGROT_R(IL1:IL2,M,1:NRFP) FLGPAT_R(IOFF+IL1:IOFF+IL2,M,1:NRFP) = FLGROT_R(IL1:IL2,M,1:NRFP) END DO ! M %i zeroacc4.629 C CSBPAT_R (:,:,:) = 0.0 CLBPAT_R (:,:,:) = 0.0 FSGPAT_R (:,:,:) = 0.0 FLGPAT_R (:,:,:) = 0.0 %i init12.309 C DO I=1,IJPAK DO M=1,NTLD CSALPAT(I,M,1)=ALSWPAK(I) SALBPAT(I,M,1)=ALSWPAK(I) CSALPAT(I,M,2)=ALLWPAK(I) SALBPAT(I,M,2)=ALLWPAK(I) CSALPAT(I,M,3)=ALLWPAK(I) SALBPAT(I,M,3)=ALLWPAK(I) CSALPAT(I,M,4)=ALLWPAK(I) SALBPAT(I,M,4)=ALLWPAK(I) ENDDO C c DO M=NTLD+1,NTLD+NTLK c IF(LICNPAK(I).GT.0.) THEN c CSALPAT(I,M,1)=0.778 c SALBPAT(I,M,1)=0.778 c CSALPAT(I,M,2)=0.443 c SALBPAT(I,M,2)=0.443 c CSALPAT(I,M,3)=0.055 c SALBPAT(I,M,3)=0.055 c CSALPAT(I,M,4)=0.036 c SALBPAT(I,M,4)=0.036 c ELSE c CSALPAT(I,M,1)=ALSWPAK(I) c SALBPAT(I,M,1)=ALSWPAK(I) c CSALPAT(I,M,2)=ALLWPAK(I) c SALBPAT(I,M,2)=ALLWPAK(I) c CSALPAT(I,M,3)=ALLWPAK(I) c SALBPAT(I,M,3)=ALLWPAK(I) c CSALPAT(I,M,4)=ALLWPAK(I) c SALBPAT(I,M,4)=ALLWPAK(I) c ENDIF c ENDDO C DO M=NTLD+NTLK+1,IM IF(SICNPAK(I).GT.0.) THEN CSALPAT(I,M,1)=0.778 SALBPAT(I,M,1)=0.778 CSALPAT(I,M,2)=0.443 SALBPAT(I,M,2)=0.443 CSALPAT(I,M,3)=0.055 SALBPAT(I,M,3)=0.055 CSALPAT(I,M,4)=0.036 SALBPAT(I,M,4)=0.036 ELSE CSALPAT(I,M,1)=ALSWPAK(I) SALBPAT(I,M,1)=ALSWPAK(I) CSALPAT(I,M,2)=ALLWPAK(I) SALBPAT(I,M,2)=ALLWPAK(I) CSALPAT(I,M,3)=ALLWPAK(I) SALBPAT(I,M,3)=ALLWPAK(I) CSALPAT(I,M,4)=ALLWPAK(I) SALBPAT(I,M,4)=ALLWPAK(I) ENDIF ENDDO ENDDO %i init12.358 CALL PKZEROS2(FSGIPAL,IJPAK, 1) CALL PKZEROS2(FSGOPAL,IJPAK, 1) %i saveacc6.2190 CALL PUTGGB3(FSGIPAL,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("FSGI") 1 ,1,GLL,WRKS) CALL PUTGGB3(FSGOPAL,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("FSGO") 1 ,1,GLL,WRKS) %i saveacc6.2223 CALL PKZEROS2(FSGIPAL,IJPAK, 1) CALL PKZEROS2(FSGOPAL,IJPAK, 1) %i rstarth.2884 C C * Read the label at the current file pointer then reposition the C * pointer at the start of this label. C CALL FBUFFIN (-LU,JBUF,-8,KK,KLEN) IF(KK.GE.0) GO TO 500 BACKSPACE (LU) IF (JBUF(3).NE.NC4TO8("FSGI")) THEN FSGIPAL=0. FSGOPAL=0. ELSE IBUF(3) = NC4TO8("FSGI") CALL RPKPHS4(LU,FSGIPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, 1 OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("FSGO") CALL RPKPHS4(LU,FSGOPAL, 1,IBUF,LONSL,NLAT,ILAT,LEV,LH,GLL, 1 OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF ENDIF %i rstarth.3004 C C * Read the label at the current file pointer then reposition the C * pointer at the start of this label. C CALL FBUFFIN (-LU,JBUF,-8,KK,KLEN) IF(KK.GE.0) GO TO 500 BACKSPACE (LU) IF (JBUF(3).NE.NC4TO8(" CLB")) THEN DO M=1,IM CLBPAT (:,M) = CLBPAL(:) CSBPAT (:,M) = CSBPAL(:) CSDPAT (:,M) = CSDPAL(:) CSFPAT (:,M) = CSFPAL (:) FDLPAT (:,M) = FDLPAL (:) FDLCPAT(:,M) = FDLCPAL(:) FLGPAT (:,M) = FLGPAL (:) FSDPAT (:,M) = FSDPAL (:) FSFPAT (:,M) = FSFPAL (:) FSGPAT (:,M) = FSGPAL (:) FSIPAT (:,M) = FSIPAL (:) FSVPAT (:,M) = FSVPAL (:) PARPAT (:,M) = PARPAL (:) C DO L=1,NBS FSDBPAT (:,M,L) = FSDBPAL (:,L) FSFBPAT (:,M,L) = FSFBPAL (:,L) FSSBPAT (:,M,L) = FSSBPAL (:,L) CSDBPAT (:,M,L) = CSDBPAL (:,L) CSFBPAT (:,M,L) = CSFBPAL (:,L) FSSCBPAT(:,M,L) = FSSCBPAL(:,L) ENDDO ENDDO GO TO 430 ELSE IBUF(3) = NC4TO8(" CLB") CALL RPKPHS4(LU, CLBPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LLWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" CSB") CALL RPKPHS4(LU, CSBPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" CSD") CALL RPKPHS4(LU, CSDPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" CSF") CALL RPKPHS4(LU, CSFPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" FDL") CALL RPKPHS4(LU, FDLPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LLWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("FDLC") CALL RPKPHS4(LU,FDLCPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LLWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" FLG") CALL RPKPHS4(LU, FLGPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LLWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" FSD") CALL RPKPHS4(LU, FSDPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" FSF") CALL RPKPHS4(LU, FSFPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" FSG") CALL RPKPHS4(LU, FSGPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" FSI") CALL RPKPHS4(LU, FSIPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" FSV") CALL RPKPHS4(LU, FSVPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8(" PAR") CALL RPKPHS4(LU, PARPAT, IM,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF NTBS=IM*NBS IBUF(3) = NC4TO8("FSDB") CALL RPKPHS4(LU,FSDBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("FSFB") CALL RPKPHS4(LU,FSFBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("FSSB") CALL RPKPHS4(LU,FSSBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("CSDB") CALL RPKPHS4(LU,CSDBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("CSFB") CALL RPKPHS4(LU,CSFBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF IBUF(3) = NC4TO8("FSCB") CALL RPKPHS4(LU,FSSCBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,LEV, 1 LSWT,GLL,OK) IF (.NOT.OK ) THEN IBUFBAD=IBUF(3) GO TO 500 ENDIF ENDIF 430 CONTINUE %i rstarth.5405 IBUF(3) = NC4TO8("FSGI") CALL WPKPHS4(LU,FSGIPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) IBUF(3) = NC4TO8("FSGO") CALL WPKPHS4(LU,FSGOPAL, 1,IBUF,LONSL,NLAT,ILAT,ILEV,LEV,LH) %i rstarth.5450 IBUF(3) = NC4TO8(" CLB") CALL WPKPHS4(LU, CLBPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LLWT) IBUF(3) = NC4TO8(" CSB") CALL WPKPHS4(LU, CSBPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" CSD") CALL WPKPHS4(LU, CSDPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" CSF") CALL WPKPHS4(LU, CSFPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" FDL") CALL WPKPHS4(LU, FDLPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LLWT) IBUF(3) = NC4TO8("FDLC") CALL WPKPHS4(LU,FDLCPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LLWT) IBUF(3) = NC4TO8(" FLG") CALL WPKPHS4(LU, FLGPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LLWT) IBUF(3) = NC4TO8(" FSD") CALL WPKPHS4(LU, FSDPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" FSF") CALL WPKPHS4(LU, FSFPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" FSG") CALL WPKPHS4(LU, FSGPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" FSI") CALL WPKPHS4(LU, FSIPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" FSV") CALL WPKPHS4(LU, FSVPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8(" PAR") CALL WPKPHS4(LU, PARPAT, IM,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) NTBS=IM*NBS IBUF(3) = NC4TO8("FSDB") CALL WPKPHS4(LU, FSDBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8("FSFB") CALL WPKPHS4(LU, FSFBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8("FSSB") CALL WPKPHS4(LU, FSSBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8("CSDB") CALL WPKPHS4(LU, CSDBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8("CSFB") CALL WPKPHS4(LU, CSFBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) IBUF(3) = NC4TO8("FSCB") CALL WPKPHS4(LU,FSSCBPAT,NTBS,IBUF,LONSL,NLAT,ILAT,ILEV, 1 LEV,LSWT) %i gcm18.2422 CALL PKZEROS2(FSGIPAL, IJPAK, 1) CALL PKZEROS2(FSGOPAL, IJPAK, 1) %i gcm18.4077 CALL PUTGGB3(FSGIPAL,LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8("FSGI"),1,GLL,WRKS) CALL PUTGGB3(FSGOPAL,LON1,ILAT,KHEM,NPGG,K,NUPR, 1 NC4TO8("FSGO"),1,GLL,WRKS) %d physici.655,656 8 SMFRAC,PBLHROL,CDH,CDM, %i physici.740 REAL, DIMENSION(ILG,IM) :: FSDROT_R, FSFROT_R, FSVROT_R, + FSIROT_R, FDLROT_R, FDLCROT_R, + PARROT_R, CSDROT_R, CSFROT_R REAL, DIMENSION(ILG,IM,NBS) :: FSDBROT_R, FSFBROT_R, CSDBROT_R, + CSFBROT_R, FSSBROT_R, FSSCBROT_R %i physici.2107 ITILERAD=1 IF(ITILERAD.EQ.0) CALL XIT('PHYSICI',-15) %i physici.2118 + FSGROT, FSDROT, FSFROT, FSVROT, FSIROT, + FDLROT, FLGROT, FDLCROT, CSBROT, CLBROT, + PARROT, CSDROT, CSFROT, + FSDBROT, FSFBROT, CSDBROT, CSFBROT, FSSBROT, + FSSCBROT, %d physici.2134,2136 U EMISROW, CLDTROL, RADJ, WCDW, V REL_SUB, REI_SUB, CLW_SUB, CIC_SUB, NCLDY, W SALBROT, CSALROT, EMISROT, GTROT, FAREROT, %d physici.2138 Y LCSW, LCLW, IL1, IL2, ILG, ILEV, LEV, NXLOC, IM, %d physici.2140 + MCICA, IRADFORCE, IACTIVE_RT, ITILERAD) %i physici.2377 ITILERAD=0 %i physici.2392 + FSGROT_R(1,1,NRF), FSDROT_R, FSFROT_R, FSVROT_R, + FSIROT_R, FDLROT_R, FLGROT_R(1,1,NRF), FDLCROT_R, + CSBROT_R(1,1,NRF), CLBROT_R(1,1,NRF), + PARROT_R, CSDROT_R, CSFROT_R, + FSDBROT_R, FSFBROT_R, CSDBROT_R, CSFBROT_R, + FSSBROT_R, FSSCBROT_R, %d physici.2410,2412 W EMISROW, CLDTROL, RADJ, WCDW, X REL_SUB, REI_SUB, CLW_SUB, CIC_SUB, NCLDY, Y SALBROT, CSALROT, EMISROT, GTROT, FAREROT, %d physici.2414 Y LCSW, LCLW, IL1, IL2, ILG, ILEV, LEV, NXLOC, IM, %d physici.2416 + MCICA, IRADFORCE, IACTIVE_RT, ITILERAD) %d physici.2438,2446 %i physici.2465 FSGIROL(IL)= FSGIROL(IL)+ FSGROT(IL,IOSIC)*SAVEBEG FSGOROL(IL)= FSGOROL(IL)+ FSGROT(IL,IOWAT)*SAVEBEG %d physici.2737 SICN_CRT=tiny(sicn_crt) %d physici.2806 1 QGROW, CDH, CDM, EFROW, %d physici.2809,2810 4 CSALROL,SALBROL,EMISROW,CSALROT,SALBROT,EMISROT, 5 GTROT, SNOROT, ANROT,RHONROT, %d physici.2839,2840 Y TBASROT, FNROW,PCPNROW, SMLT, + FSFROL, FDLROL, FSDROL, FSVROL, FSIROL, Z CSDROL, CSFROL, FSGROL, FLGROL, + FSFROT, FDLROT, FSDROT, FSVROT, FSIROT, + CSDROT, CSFROT, FSGROT, FLGROT, %d physici.2845,2847 + SNOROW, TVROW, WVLROW, WVFROW, TTROW, + MVROW,WSNOROW,FAREROT,FSDBROT,FSFBROT,FSSBROT, + CSDBROT,CSFBROT,WRKAROL,WRKBROL, %d sfcproc2.4 2 QGROW, CDHROW, CDMROW, EFROW, %d sfcproc2.7,8 5 CSALROL,SALBROL,EMISROW,CSALROT,SALBROT,EMISROT, 6 GTROT, SNOROT, ANROT,RHONROT, %d sfcproc2.37,38 Y TBASROT, FNROW,PCPNROW,SMLTROL, + FSFROL, FDLROL, FSDROL, FSVROL, FSIROL, Z CSDROL, CSFROL, FSGROL, FLGROL, + FSFROT, FDLROT, FSDROT, FSVROT, FSIROT, + CSDROT, CSFROT, FSGROT, FLGROT, %d sfcproc2.43,45 + SNOROW, TVROW, WVLROW, WVFROW, TTROW, + MVROW,WSNOROW,FAREROT,FSDBROT,FSFBROT,FSSBROT, + CSDBROT,CSFBROT,WRKAROL,WRKBROL, %d sfcproc2.482,483 1 ZRFMROW, ZRFHROW, ZDMROW, ZDHROW, ZBLDROW, 2 CSZROW, FDLROL, THLROW, ULROW, VLROW, %d sfcproc2.490,491 1 ZRFMGAT, ZRFHGAT, ZDMGAT, ZDHGAT, ZBLDGAT, 2 CSZGAT, FDLGAT, ULGAT, VLGAT, %d sfcproc2.488 7 VMODL, GUSTROL, CO2ROW %d sfcproc2.496 7 VMODGAT, GUSTGAT, CO2GAT %d sfcproc2.498,500 REAL, DIMENSION(ILG,IM,NBS) :: 1 FSFBROT, FSSBROT, FSDBROT, CSDBROT, CSFBROT REAL, DIMENSION(ILG,NBS) :: WRKAROL, WRKBROL %d sfcproc2.515 3 QGROW, %i sfcproc2.526 REAL, DIMENSION(ILG,IM) :: 1 FSGROT, FLGROT, FSFROT, FSVROT, FSIROT REAL, DIMENSION(ILG) :: 1 FSGROL, FLGROL, FSFROL, FSVROL, FSIROL %d sfcproc2.530 3 QGGAT, ALSWGAT, ALLWGAT, %i sfcproc2.541 REAL, DIMENSION(ILGM) :: 1 FSGGAT, FLGGAT, FSFGAT, FSVGAT, FSIGAT %i sfcproc2.593 REAL, DIMENSION(ILG,IM,NBS) :: LFSDBROT,LFSFBROT,LFSSBROT, + LCSDBROT,LCSFBROT %d sfcproc2.658 REAL, DIMENSION(ILG,IM) :: GCROT, FSDROT, CSDROT, CSFROT %d sfcproc2.871,909 DO IB = 1,NBS DO I = IL1,IL2 LFSDBROL(I,IB) = 0. LFSFBROL(I,IB) = 0. LCSDBROL(I,IB) = 0. LCSFBROL(I,IB) = 0. LFSSBROL(I,IB) = 0. ENDDO ENDDO C IF (ISNOALB .EQ. 0) THEN ! PUT THE TOTAL FLUX INTO THE BAND MEAN ARRAYS DO M = 1,IM DO IB = 1,NBS DO I = IL1,IL2 C C * ENSURE POSITIVE DEFINITE. C FSDROT(I,M) = MAX(FSDROT(I,M),0.) FSFROT(I,M) = MAX(FSFROT(I,M),0.) CSDROT(I,M) = MAX(CSDROT(I,M),0.) CSFROT(I,M) = MAX(CSFROT(I,M),0.) FSVROT(I,M) = MAX(FSVROT(I,M),0.) FSIROT(I,M) = MAX(FSIROT(I,M),0.) C LFSDBROT(I,M,IB) = FSDROT(I,M) LFSFBROT(I,M,IB) = FSFROT(I,M) LCSDBROT(I,M,IB) = CSDROT(I,M) LCSFBROT(I,M,IB) = CSFROT(I,M) IF (IB .EQ. 1) THEN LFSSBROT(I,M,IB) = FSVROT(I,M) ELSE LFSSBROT(I,M,IB) = FSIROT(I,M) END IF END DO ! I END DO ! IB END DO ! M ELSE IF (ISNOALB .EQ. 1) THEN ! USE THE BAND-BY-BAND RESULTS DO IB = 1,NBS DO M = 1,IM DO I = IL1,IL2 LFSDBROT(I,M,IB) = FSDBROT(I,M,IB) LFSFBROT(I,M,IB) = FSFBROT(I,M,IB) LCSDBROT(I,M,IB) = CSDBROT(I,M,IB) LCSFBROT(I,M,IB) = CSFBROT(I,M,IB) LFSSBROT(I,M,IB) = FSSBROT(I,M,IB) IF (FSFBROT(I,M,IB) .LT. 0.0 1 .OR. CSFBROT(I,M,IB) .LT. 0.0) THEN WRITE(6,*) I,IB,FSDBROT(I,M,IB),FSFBROT(I,M,IB), 1 CSDBROT(I,M,IB),CSFBROT(I,M,IB) CALL XIT('SFCPROC2',-22) END IF END DO ! I END DO ! IB END DO ! M END IF C DO IB = 1,NBS DO I = IL1,IL2 DO M = 1,IM LFSDBROL(I,IB) = LFSDBROL(I,IB) + 1 FAREROT(I,M)*LFSDBROT(I,M,IB) LFSFBROL(I,IB) = LFSFBROL(I,IB) + 1 FAREROT(I,M)*LFSFBROT(I,M,IB) LCSDBROL(I,IB) = LCSDBROL(I,IB) + 1 FAREROT(I,M)*LCSDBROT(I,M,IB) LCSFBROL(I,IB) = LCSFBROL(I,IB) + 1 FAREROT(I,M)*LCSFBROT(I,M,IB) LFSSBROL(I,IB) = LFSSBROL(I,IB) + 1 FAREROT(I,M)*LFSSBROT(I,M,IB) ENDDO ENDDO ENDDO %d sfcproc2.1185,1186 F ZRFMGAT,ZRFHGAT,ZDMGAT, ZDHGAT, FSVGAT, + FSIGAT, FSDBGAT,FSFBGAT,FSSBGAT,CSZGAT, %d sfcproc2.1209,1211 + ZRFMROW,ZRFHROW,ZDMROW, ZDHROW, FSVROT, + FSIROT, LFSDBROT, LFSFBROT, LFSSBROT, CSZROW, + FSGROT, FLGROT, FDLROT, ULROW, VLROW, %d sfcproc2.1244,1245 IF( ( FSVGAT(K)+FSIGAT(K) ).GT.0.0) THEN XDIFFUS(K)=FSFGAT(K) / ( FSVGAT(K)+FSIGAT(K) ) %d sfcproc2.1299 N FSVGAT,RADJGAT,DLONGAT,RHSIGAT,DELZ, DLZWGAT, %d sfcproc2.1336 F VPDGAT, TADPGAT,RHOAGAT,FSVGAT, FSIGAT, FDLGAT, ULGAT, VLGAT, %d sfcproc2.1834 F FSGROT, FLGROT, QAROW, THLROW, %d sfcproc2.1837 I LFSDBROT,LFSFBROT,LCSDBROT,LCSFBROT, %d sfcproc2.2059,2060 4 HFSI, HFLI, FSGROT(1,IOSIC), FLGROT(1,IOSIC), 5 RESROW, CBGO, SICNROW, SMLT, %d sfcproc2.2136 FACTADDO = FSGROT(I,IOWAT)+FLGROT(I,IOWAT)-HFSO(I)-HFLO(I) %id ctem_in_class %d gcm18.373 USE PSIZES_19 %d gcm18.559 INTEGER LCT(NTLD*ICANP1),LGT(NTLD*IGND),LCTEM(NTLD*ICTEMP1), 1 LCTG(NTLD*IGND*ICAN), LCTEMG(NTLD*IGND*ICTEM) %d gcm18.1553 CALL HYDLABT (LC,LG,LCT,LGT,LCTEM,LCTG,LCTEMG, 1 ICAN,ICANP1,IGND,ICTEM,ICTEMP1,NTLD) %d core18p.203 USE PSIZES_19 %d physici.514 USE PSIZES_19 %d rstarth.197 USE PSIZES_19 %d rstarth.247 INTEGER LCT(NTLD*ICANP1),LGT(NTLD*IGND),LCTEM(NTLD*ICTEMP1), %d sfcproc2.343 USE PSIZES_19 %d trinfo10.52 USE PSIZES_19 # # the following update set passes land area into physics and sfcproc2. %i com15i.200 COMMON /PARAM1/ PI, RVORD, TFREZ, HS, HV, DAYLNT %d core18p.263 REAL, DIMENSION(ILG) :: RADJN,AREAROW %i core18p.320 AREAROW(I) = 4.0*PI*(A**2)*WJ(I)*FLNDROW(I)/(2.0*REAL(LONSL)) !M^2 %d core18p.631 4 RADJN, AREAROW, ILSL, JL, DLON, %d physici.7 5 RADJ, AREAROW, ILSL, JL,DLONROW, %d physici.551 REAL, DIMENSION(ILG) :: RADJ,AREAROW,DLONROW %d physici.2848 + RADJ, AREAROW, ILSL, JL, %d sfcproc2.46 + RADJ, AREAROW, ILSL, JL, %d sfcproc2.479 REAL, DIMENSION(ILG) :: RADJ,AREAROW # # the following update set passes CTEM timekeeping from the AGCM driver # down to sfcproc2. %i gcm18.641 #if defined (agcm_ctem) %CALL CTEM_TIME #endif %i sfcproc2.717 #if defined (agcm_ctem) %CALL CTEM_TIME #endif C # # the following update set removes all the arrays like TCANOPAK/TCANOROW # which are no longer necessary because accumulation of fields over # course of one day to drive CTEM are now done with gathered fields # in sfcproc2. %d compak12.712 %d compak12.714 %d compak12.716 %d compak12.723 %d compak12.725 %d compak12.727 %d compak12.729 %d compak12.731 %d compak12.733 %d compak12.735 %d comrow12.671 %d comrow12.673 %d comrow12.675 %d comrow12.682 %d comrow12.684 %d comrow12.686 %d comrow12.688 %d comrow12.690 %d comrow12.692 %d comrow12.694 %d unpack10.549 %d unpack10.551 %d unpack10.553 %d unpack10.575 %d unpack10.577 %d unpack10.579 %d unpack10.581 %d unpack10.583 %d unpack10.585 %d unpack10.587 %d pack10.546 %d pack10.548 %d pack10.550 %d pack10.569 %d pack10.571 %d pack10.573 %d pack10.575 %d pack10.577 %d pack10.579 %d pack10.581 %d init12.414 #if defined (agcm_ctem) %d init12.418 %d init12.420 %d init12.422 %d init12.426 %d init12.428 %d init12.430 %d init12.432 %d init12.434 %d init12.436 %d init12.438 %d init12.444,445 C C * TIME VARYING. C SOILCPAT = 0. LITRCPAT = 0. ROOTCPAT = 0. STEMCPAT = 0. GLEAFCPAT = 0. BLEAFCPAT = 0. FALLHPAT = 0. POSPHPAT = 0. LEAFSPAT = 0. GROWTPAT = 0. LASTRPAT = 0. LASTSPAT = 0. THISYLPAT = 0. STEMHPAT = 0. ROOTHPAT = 0. TEMPCPAT = 0. AILCBPAT = 0. BMASVPAT = 0. VEGHPAT = 0. ROOTDPAT = 0. C PREFPAT = 0. NEWFPAT = 0. C CVEGPAT = 0. CDEBPAT = 0. CHUMPAT = 0. %d gcm18.2355 #if defined (agcm_ctem) %d gcm18.2376,2387 %d gcm18.2554,2610 %d gcm18.4297,4307 %d physici.642,644 %d physici.1033,1042 %d physici.2696 #if defined (agcm_ctem) %d physici.2728 #if defined (agcm_ctem) %d physici.2915,2997 # remove ctem stuff from agcm restart, now in ctem_restart %d rstarth.3333,3406 %d rstarth.5590,5616 # bugfix for GMT value at start of day %d physici.2881 IF(GMT.EQ.0. .OR. KOUNT.EQ.0) THEN %i gcm18.771 #if defined (agcm_ctem) C INTEGER START_DAYS_OF_MONTHS(12) DATA START_DAYS_OF_MONTHS /1,32,60,91,121,152,182,213,244,274, &305,335/ #endif %d compak12.658,690 #if defined (agcm_ctem) C C * CTEM RELATED VARIABLES C COMMON /PAK/ CFCANPAT (IP0J,NTLD,ICANP1) COMMON /PAK/ CALVCPAT (IP0J,NTLD,ICANP1) COMMON /PAK/ CALICPAT (IP0J,NTLD,ICANP1) COMMON /PAK/ ZOLNCPAT (IP0J,NTLD,ICAN) COMMON /PAK/ CMASCPAT (IP0J,NTLD,ICAN) %d compak12.697,699 %i compak12.700 COMMON /PAK/ TODFCPAT (IP0J,NTLD,ICTEM) %i compak12.736 C REAL LGHTPAK,LITRCPAT,LEAFSPAT,LASTRPAT,LASTSPAT,NEWFPAT C C * INVARIANT. C COMMON /PAK/ PEXFPAK (IP0J) COMMON /PAK/ PFHCPAK (IP0J) COMMON /PAK/ WETFPAK (IP0J) COMMON /PAK/ WETSPAK (IP0J) COMMON /PAK/ LGHTPAK (IP0J) C C * TIME VARYING. C COMMON /PAK/ SOILCPAT (IP0J,NTLD,ICTEMP1) COMMON /PAK/ LITRCPAT (IP0J,NTLD,ICTEMP1) COMMON /PAK/ ROOTCPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ STEMCPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ GLEAFCPAT(IP0J,NTLD,ICTEM) COMMON /PAK/ BLEAFCPAT(IP0J,NTLD,ICTEM) COMMON /PAK/ FALLHPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ POSPHPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ LEAFSPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ GROWTPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ LASTRPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ LASTSPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ THISYLPAT(IP0J,NTLD,ICTEM) COMMON /PAK/ STEMHPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ ROOTHPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ TEMPCPAT (IP0J,NTLD,2) COMMON /PAK/ AILCBPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ BMASVPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ VEGHPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ ROOTDPAT (IP0J,NTLD,ICTEM) C COMMON /PAK/ PREFPAT (IP0J,NTLD,ICTEM) COMMON /PAK/ NEWFPAT (IP0J,NTLD,ICTEM) C COMMON /PAK/ CVEGPAT (IP0J,NTLD) COMMON /PAK/ CDEBPAT (IP0J,NTLD) COMMON /PAK/ CHUMPAT (IP0J,NTLD) COMMON /PAK/ FCOLPAT (IP0J,NTLD) C C * CTEM DIAGNOSTIC OUTPUT FIELDS. C COMMON /PAK/ CVEGPAK(IP0J) COMMON /PAK/ CDEBPAK(IP0J) COMMON /PAK/ CHUMPAK(IP0J) COMMON /PAK/ CLAIPAK(IP0J) COMMON /PAK/ CFNPPAK(IP0J) COMMON /PAK/ CFNEPAK(IP0J) COMMON /PAK/ CFRVPAK(IP0J) COMMON /PAK/ CFGPPAK(IP0J) COMMON /PAK/ CFNBPAK(IP0J) COMMON /PAK/ CFFVPAK(IP0J) COMMON /PAK/ CFFDPAK(IP0J) COMMON /PAK/ CFLVPAK(IP0J) COMMON /PAK/ CFLDPAK(IP0J) COMMON /PAK/ CFLHPAK(IP0J) COMMON /PAK/ CBRNPAK(IP0J) COMMON /PAK/ CFRHPAK(IP0J) COMMON /PAK/ CFHTPAK(IP0J) COMMON /PAK/ CFLFPAK(IP0J) COMMON /PAK/ CFRDPAK(IP0J) COMMON /PAK/ CFRGPAK(IP0J) COMMON /PAK/ CFRMPAK(IP0J) COMMON /PAK/ CVGLPAK(IP0J) COMMON /PAK/ CVGSPAK(IP0J) COMMON /PAK/ CVGRPAK(IP0J) COMMON /PAK/ CFNLPAK(IP0J) COMMON /PAK/ CFNSPAK(IP0J) COMMON /PAK/ CFNRPAK(IP0J) COMMON /PAK/ CH4HPAK(IP0J) COMMON /PAK/ CH4NPAK(IP0J) COMMON /PAK/ WFRAPAK(IP0J) COMMON /PAK/ CW1DPAK(IP0J) COMMON /PAK/ CW2DPAK(IP0J) COMMON /PAK/ FCOLPAK(IP0J) COMMON /PAK/ CURFPAK(IP0J,ICTEM) %d comrow12.648,651 #if defined (agcm_ctem) C C * CTEM RELATED VARIABLES C COMMON /ROW/ CFCANROT (ILG,NTLD,ICANP1) COMMON /ROW/ CALVCROT (ILG,NTLD,ICANP1) COMMON /ROW/ CALICROT (ILG,NTLD,ICANP1) COMMON /ROW/ ZOLNCROT (ILG,NTLD,ICAN) COMMON /ROW/ CMASCROT (ILG,NTLD,ICAN) %i comrow12.659 COMMON /ROW/ TODFCROT (ILG,NTLD,ICTEM) %i comrow12.695 C REAL LGHTROW,LITRCROT,LEAFSROT,LASTRROT,LASTSROT,NEWFROT C C * INVARIANT. C COMMON /ROW/ PEXFROW (ILG) COMMON /ROW/ PFHCROW (ILG) COMMON /ROW/ WETFROW (ILG) COMMON /ROW/ WETSROW (ILG) COMMON /ROW/ LGHTROW (ILG) C C * TIME VARYING. C COMMON /ROW/ SOILCROT (ILG,NTLD,ICTEMP1) COMMON /ROW/ LITRCROT (ILG,NTLD,ICTEMP1) COMMON /ROW/ ROOTCROT (ILG,NTLD,ICTEM) COMMON /ROW/ STEMCROT (ILG,NTLD,ICTEM) COMMON /ROW/ GLEAFCROT(ILG,NTLD,ICTEM) COMMON /ROW/ BLEAFCROT(ILG,NTLD,ICTEM) COMMON /ROW/ FALLHROT (ILG,NTLD,ICTEM) COMMON /ROW/ POSPHROT (ILG,NTLD,ICTEM) COMMON /ROW/ LEAFSROT (ILG,NTLD,ICTEM) COMMON /ROW/ GROWTROT (ILG,NTLD,ICTEM) COMMON /ROW/ LASTRROT (ILG,NTLD,ICTEM) COMMON /ROW/ LASTSROT (ILG,NTLD,ICTEM) COMMON /ROW/ THISYLROT(ILG,NTLD,ICTEM) COMMON /ROW/ STEMHROT (ILG,NTLD,ICTEM) COMMON /ROW/ ROOTHROT (ILG,NTLD,ICTEM) COMMON /ROW/ TEMPCROT (ILG,NTLD,2) COMMON /ROW/ AILCBROT (ILG,NTLD,ICTEM) COMMON /ROW/ BMASVROT (ILG,NTLD,ICTEM) COMMON /ROW/ VEGHROT (ILG,NTLD,ICTEM) COMMON /ROW/ ROOTDROT (ILG,NTLD,ICTEM) C COMMON /ROW/ PREFROT (ILG,NTLD,ICTEM) COMMON /ROW/ NEWFROT (ILG,NTLD,ICTEM) C COMMON /ROW/ CVEGROT (ILG,NTLD) COMMON /ROW/ CDEBROT (ILG,NTLD) COMMON /ROW/ CHUMROT (ILG,NTLD) COMMON /ROW/ FCOLROT (ILG,NTLD) C C * CTEM DIAGNOSTIC OUTPUT FIELDS. C COMMON /ROW/ CVEGROW(ILG) COMMON /ROW/ CDEBROW(ILG) COMMON /ROW/ CHUMROW(ILG) COMMON /ROW/ CLAIROW(ILG) COMMON /ROW/ CFNPROW(ILG) COMMON /ROW/ CFNEROW(ILG) COMMON /ROW/ CFRVROW(ILG) COMMON /ROW/ CFGPROW(ILG) COMMON /ROW/ CFNBROW(ILG) COMMON /ROW/ CFFVROW(ILG) COMMON /ROW/ CFFDROW(ILG) COMMON /ROW/ CFLVROW(ILG) COMMON /ROW/ CFLDROW(ILG) COMMON /ROW/ CFLHROW(ILG) COMMON /ROW/ CBRNROW(ILG) COMMON /ROW/ CFRHROW(ILG) COMMON /ROW/ CFHTROW(ILG) COMMON /ROW/ CFLFROW(ILG) COMMON /ROW/ CFRDROW(ILG) COMMON /ROW/ CFRGROW(ILG) COMMON /ROW/ CFRMROW(ILG) COMMON /ROW/ CVGLROW(ILG) COMMON /ROW/ CVGSROW(ILG) COMMON /ROW/ CVGRROW(ILG) COMMON /ROW/ CFNLROW(ILG) COMMON /ROW/ CFNSROW(ILG) COMMON /ROW/ CFNRROW(ILG) COMMON /ROW/ CH4HROW(ILG) COMMON /ROW/ CH4NROW(ILG) COMMON /ROW/ WFRAROW(ILG) COMMON /ROW/ CW1DROW(ILG) COMMON /ROW/ CW2DROW(ILG) COMMON /ROW/ FCOLROW(ILG) COMMON /ROW/ CURFROW(ILG,ICTEM) %d unpack10.401,412 C C * LAND SURFACE ARRAYS. C ALICROT(IL1:IL2,:,:)=ALICPAT(IOFF+IL1:IOFF+IL2,:,:) ALVCROT(IL1:IL2,:,:)=ALVCPAT(IOFF+IL1:IOFF+IL2,:,:) FCANROT(IL1:IL2,:,:)=FCANPAT(IOFF+IL1:IOFF+IL2,:,:) LNZ0ROT(IL1:IL2,:,:)=LNZ0PAT(IOFF+IL1:IOFF+IL2,:,:) CMASROT(IL1:IL2,:,:)=CMASPAT(IOFF+IL1:IOFF+IL2,:,:) LAMNROT(IL1:IL2,:,:)=LAMNPAT(IOFF+IL1:IOFF+IL2,:,:) LAMXROT(IL1:IL2,:,:)=LAMXPAT(IOFF+IL1:IOFF+IL2,:,:) ROOTROT(IL1:IL2,:,:)=ROOTPAT(IOFF+IL1:IOFF+IL2,:,:) GFLXROW(IL1:IL2,:) =GFLXPAK (IOFF+IL1:IOFF+IL2,:) %d unpack10.544,547 #if defined (agcm_ctem) RMATCROT (IL1:IL2,:,:,:) = RMATCPAT (IOFF+IL1:IOFF+IL2,:,:,:) RTCTMROT (IL1:IL2,:,:,:) = RTCTMPAT (IOFF+IL1:IOFF+IL2,:,:,:) CFCANROT (IL1:IL2,:,:) = CFCANPAT (IOFF+IL1:IOFF+IL2,:,:) ZOLNCROT (IL1:IL2,:,:) = ZOLNCPAT (IOFF+IL1:IOFF+IL2,:,:) AILCROT (IL1:IL2,:,:) = AILCPAT (IOFF+IL1:IOFF+IL2,:,:) CMASCROT (IL1:IL2,:,:) = CMASCPAT (IOFF+IL1:IOFF+IL2,:,:) CALVCROT (IL1:IL2,:,:) = CALVCPAT (IOFF+IL1:IOFF+IL2,:,:) CALICROT (IL1:IL2,:,:) = CALICPAT (IOFF+IL1:IOFF+IL2,:,:) PAICROT (IL1:IL2,:,:) = PAICPAT (IOFF+IL1:IOFF+IL2,:,:) SLAICROT (IL1:IL2,:,:) = SLAICPAT (IOFF+IL1:IOFF+IL2,:,:) FCANCROT (IL1:IL2,:,:) = FCANCPAT (IOFF+IL1:IOFF+IL2,:,:) TODFCROT (IL1:IL2,:,:) = TODFCPAT (IOFF+IL1:IOFF+IL2,:,:) AILCGROT (IL1:IL2,:,:) = AILCGPAT (IOFF+IL1:IOFF+IL2,:,:) SLAIROT (IL1:IL2,:,:) = SLAIPAT (IOFF+IL1:IOFF+IL2,:,:) %d unpack10.558,564 %i unpack10.588 C C * INVARIANT. C PEXFROW (IL1:IL2) = PEXFPAK (IOFF+IL1:IOFF+IL2) PFHCROW (IL1:IL2) = PFHCPAK (IOFF+IL1:IOFF+IL2) WETFROW (IL1:IL2) = WETFPAK (IOFF+IL1:IOFF+IL2) WETSROW (IL1:IL2) = WETSPAK (IOFF+IL1:IOFF+IL2) LGHTROW (IL1:IL2) = LGHTPAK (IOFF+IL1:IOFF+IL2) C C * TIME VARYING. C SOILCROT (IL1:IL2,:,:) = SOILCPAT (IOFF+IL1:IOFF+IL2,:,:) LITRCROT (IL1:IL2,:,:) = LITRCPAT (IOFF+IL1:IOFF+IL2,:,:) ROOTCROT (IL1:IL2,:,:) = ROOTCPAT (IOFF+IL1:IOFF+IL2,:,:) STEMCROT (IL1:IL2,:,:) = STEMCPAT (IOFF+IL1:IOFF+IL2,:,:) GLEAFCROT (IL1:IL2,:,:) = GLEAFCPAT (IOFF+IL1:IOFF+IL2,:,:) BLEAFCROT (IL1:IL2,:,:) = BLEAFCPAT (IOFF+IL1:IOFF+IL2,:,:) FALLHROT (IL1:IL2,:,:) = FALLHPAT (IOFF+IL1:IOFF+IL2,:,:) POSPHROT (IL1:IL2,:,:) = POSPHPAT (IOFF+IL1:IOFF+IL2,:,:) LEAFSROT (IL1:IL2,:,:) = LEAFSPAT (IOFF+IL1:IOFF+IL2,:,:) GROWTROT (IL1:IL2,:,:) = GROWTPAT (IOFF+IL1:IOFF+IL2,:,:) LASTRROT (IL1:IL2,:,:) = LASTRPAT (IOFF+IL1:IOFF+IL2,:,:) LASTSROT (IL1:IL2,:,:) = LASTSPAT (IOFF+IL1:IOFF+IL2,:,:) THISYLROT (IL1:IL2,:,:) = THISYLPAT (IOFF+IL1:IOFF+IL2,:,:) STEMHROT (IL1:IL2,:,:) = STEMHPAT (IOFF+IL1:IOFF+IL2,:,:) ROOTHROT (IL1:IL2,:,:) = ROOTHPAT (IOFF+IL1:IOFF+IL2,:,:) TEMPCROT (IL1:IL2,:,:) = TEMPCPAT (IOFF+IL1:IOFF+IL2,:,:) AILCBROT (IL1:IL2,:,:) = AILCBPAT (IOFF+IL1:IOFF+IL2,:,:) BMASVROT (IL1:IL2,:,:) = BMASVPAT (IOFF+IL1:IOFF+IL2,:,:) VEGHROT (IL1:IL2,:,:) = VEGHPAT (IOFF+IL1:IOFF+IL2,:,:) ROOTDROT (IL1:IL2,:,:) = ROOTDPAT (IOFF+IL1:IOFF+IL2,:,:) C PREFROT (IL1:IL2,:,:) = PREFPAT (IOFF+IL1:IOFF+IL2,:,:) NEWFROT (IL1:IL2,:,:) = NEWFPAT (IOFF+IL1:IOFF+IL2,:,:) C CVEGROT (IL1:IL2,:) = CVEGPAT (IOFF+IL1:IOFF+IL2,:) CDEBROT (IL1:IL2,:) = CDEBPAT (IOFF+IL1:IOFF+IL2,:) CHUMROT (IL1:IL2,:) = CHUMPAT (IOFF+IL1:IOFF+IL2,:) FCOLROT (IL1:IL2,:) = FCOLPAT (IOFF+IL1:IOFF+IL2,:) C C * CTEM DIAGNOSTIC OUTPUT FIELDS. C * NOTE THAT SAMPLED FIELDS DON'T HAVE TO BE C * UNPACKED SINCE THEY ARE ZEROED OUT IN C * SFCPROC2 PRIOR TO ACCUMULATION OVER TILES! C CFNPROW(IL1:IL2) = CFNPPAK(IOFF+IL1:IOFF+IL2) CFNEROW(IL1:IL2) = CFNEPAK(IOFF+IL1:IOFF+IL2) CFRVROW(IL1:IL2) = CFRVPAK(IOFF+IL1:IOFF+IL2) CFGPROW(IL1:IL2) = CFGPPAK(IOFF+IL1:IOFF+IL2) CFNBROW(IL1:IL2) = CFNBPAK(IOFF+IL1:IOFF+IL2) CFFVROW(IL1:IL2) = CFFVPAK(IOFF+IL1:IOFF+IL2) CFFDROW(IL1:IL2) = CFFDPAK(IOFF+IL1:IOFF+IL2) CFLVROW(IL1:IL2) = CFLVPAK(IOFF+IL1:IOFF+IL2) CFLDROW(IL1:IL2) = CFLDPAK(IOFF+IL1:IOFF+IL2) CFLHROW(IL1:IL2) = CFLHPAK(IOFF+IL1:IOFF+IL2) CBRNROW(IL1:IL2) = CBRNPAK(IOFF+IL1:IOFF+IL2) CFRHROW(IL1:IL2) = CFRHPAK(IOFF+IL1:IOFF+IL2) CFHTROW(IL1:IL2) = CFHTPAK(IOFF+IL1:IOFF+IL2) CFLFROW(IL1:IL2) = CFLFPAK(IOFF+IL1:IOFF+IL2) CFRDROW(IL1:IL2) = CFRDPAK(IOFF+IL1:IOFF+IL2) CFRGROW(IL1:IL2) = CFRGPAK(IOFF+IL1:IOFF+IL2) CFRMROW(IL1:IL2) = CFRMPAK(IOFF+IL1:IOFF+IL2) CFNLROW(IL1:IL2) = CFNLPAK(IOFF+IL1:IOFF+IL2) CFNSROW(IL1:IL2) = CFNSPAK(IOFF+IL1:IOFF+IL2) CFNRROW(IL1:IL2) = CFNRPAK(IOFF+IL1:IOFF+IL2) CH4HROW(IL1:IL2) = CH4HPAK(IOFF+IL1:IOFF+IL2) CH4NROW(IL1:IL2) = CH4NPAK(IOFF+IL1:IOFF+IL2) WFRAROW(IL1:IL2) = WFRAPAK(IOFF+IL1:IOFF+IL2) CW1DROW(IL1:IL2) = CW1DPAK(IOFF+IL1:IOFF+IL2) CW2DROW(IL1:IL2) = CW2DPAK(IOFF+IL1:IOFF+IL2) FCOLROW(IL1:IL2) = FCOLPAK(IOFF+IL1:IOFF+IL2) %d pack10.544,545 #if defined (agcm_ctem) RMATCPAT (IOFF+IL1:IOFF+IL2,:,:,:) = RMATCROT (IL1:IL2,:,:,:) RTCTMPAT (IOFF+IL1:IOFF+IL2,:,:,:) = RTCTMROT (IL1:IL2,:,:,:) CFCANPAT (IOFF+IL1:IOFF+IL2,:,:) = CFCANROT (IL1:IL2,:,:) ZOLNCPAT (IOFF+IL1:IOFF+IL2,:,:) = ZOLNCROT (IL1:IL2,:,:) AILCPAT (IOFF+IL1:IOFF+IL2,:,:) = AILCROT (IL1:IL2,:,:) CMASCPAT (IOFF+IL1:IOFF+IL2,:,:) = CMASCROT (IL1:IL2,:,:) CALVCPAT (IOFF+IL1:IOFF+IL2,:,:) = CALVCROT (IL1:IL2,:,:) CALICPAT (IOFF+IL1:IOFF+IL2,:,:) = CALICROT (IL1:IL2,:,:) PAICPAT (IOFF+IL1:IOFF+IL2,:,:) = PAICROT (IL1:IL2,:,:) SLAICPAT (IOFF+IL1:IOFF+IL2,:,:) = SLAICROT (IL1:IL2,:,:) FCANCPAT (IOFF+IL1:IOFF+IL2,:,:) = FCANCROT (IL1:IL2,:,:) TODFCPAT (IOFF+IL1:IOFF+IL2,:,:) = TODFCROT (IL1:IL2,:,:) AILCGPAT (IOFF+IL1:IOFF+IL2,:,:) = AILCGROT (IL1:IL2,:,:) SLAIPAT (IOFF+IL1:IOFF+IL2,:,:) = SLAIROT (IL1:IL2,:,:) %d pack10.556,558 %i pack10.582 C C * TIME VARYING. C SOILCPAT (IOFF+IL1:IOFF+IL2,:,:) = SOILCROT (IL1:IL2,:,:) LITRCPAT (IOFF+IL1:IOFF+IL2,:,:) = LITRCROT (IL1:IL2,:,:) ROOTCPAT (IOFF+IL1:IOFF+IL2,:,:) = ROOTCROT (IL1:IL2,:,:) STEMCPAT (IOFF+IL1:IOFF+IL2,:,:) = STEMCROT (IL1:IL2,:,:) GLEAFCPAT (IOFF+IL1:IOFF+IL2,:,:) = GLEAFCROT (IL1:IL2,:,:) BLEAFCPAT (IOFF+IL1:IOFF+IL2,:,:) = BLEAFCROT (IL1:IL2,:,:) FALLHPAT (IOFF+IL1:IOFF+IL2,:,:) = FALLHROT (IL1:IL2,:,:) POSPHPAT (IOFF+IL1:IOFF+IL2,:,:) = POSPHROT (IL1:IL2,:,:) LEAFSPAT (IOFF+IL1:IOFF+IL2,:,:) = LEAFSROT (IL1:IL2,:,:) GROWTPAT (IOFF+IL1:IOFF+IL2,:,:) = GROWTROT (IL1:IL2,:,:) LASTRPAT (IOFF+IL1:IOFF+IL2,:,:) = LASTRROT (IL1:IL2,:,:) LASTSPAT (IOFF+IL1:IOFF+IL2,:,:) = LASTSROT (IL1:IL2,:,:) THISYLPAT (IOFF+IL1:IOFF+IL2,:,:) = THISYLROT (IL1:IL2,:,:) STEMHPAT (IOFF+IL1:IOFF+IL2,:,:) = STEMHROT (IL1:IL2,:,:) ROOTHPAT (IOFF+IL1:IOFF+IL2,:,:) = ROOTHROT (IL1:IL2,:,:) TEMPCPAT (IOFF+IL1:IOFF+IL2,:,:) = TEMPCROT (IL1:IL2,:,:) AILCBPAT (IOFF+IL1:IOFF+IL2,:,:) = AILCBROT (IL1:IL2,:,:) BMASVPAT (IOFF+IL1:IOFF+IL2,:,:) = BMASVROT (IL1:IL2,:,:) VEGHPAT (IOFF+IL1:IOFF+IL2,:,:) = VEGHROT (IL1:IL2,:,:) ROOTDPAT (IOFF+IL1:IOFF+IL2,:,:) = ROOTDROT (IL1:IL2,:,:) C PREFPAT (IOFF+IL1:IOFF+IL2,:,:) = PREFROT (IL1:IL2,:,:) NEWFPAT (IOFF+IL1:IOFF+IL2,:,:) = NEWFROT (IL1:IL2,:,:) C CVEGPAT (IOFF+IL1:IOFF+IL2,:) = CVEGROT (IL1:IL2,:) CDEBPAT (IOFF+IL1:IOFF+IL2,:) = CDEBROT (IL1:IL2,:) CHUMPAT (IOFF+IL1:IOFF+IL2,:) = CHUMROT (IL1:IL2,:) FCOLPAT (IOFF+IL1:IOFF+IL2,:) = FCOLROT (IL1:IL2,:) C C * CTEM DIAGNOSTIC OUTPUT FIELDS. C CVEGPAK(IOFF+IL1:IOFF+IL2) = CVEGROW(IL1:IL2) CDEBPAK(IOFF+IL1:IOFF+IL2) = CDEBROW(IL1:IL2) CHUMPAK(IOFF+IL1:IOFF+IL2) = CHUMROW(IL1:IL2) CLAIPAK(IOFF+IL1:IOFF+IL2) = CLAIROW(IL1:IL2) CFNPPAK(IOFF+IL1:IOFF+IL2) = CFNPROW(IL1:IL2) CFNEPAK(IOFF+IL1:IOFF+IL2) = CFNEROW(IL1:IL2) CFRVPAK(IOFF+IL1:IOFF+IL2) = CFRVROW(IL1:IL2) CFGPPAK(IOFF+IL1:IOFF+IL2) = CFGPROW(IL1:IL2) CFNBPAK(IOFF+IL1:IOFF+IL2) = CFNBROW(IL1:IL2) CFFVPAK(IOFF+IL1:IOFF+IL2) = CFFVROW(IL1:IL2) CFFDPAK(IOFF+IL1:IOFF+IL2) = CFFDROW(IL1:IL2) CFLVPAK(IOFF+IL1:IOFF+IL2) = CFLVROW(IL1:IL2) CFLDPAK(IOFF+IL1:IOFF+IL2) = CFLDROW(IL1:IL2) CFLHPAK(IOFF+IL1:IOFF+IL2) = CFLHROW(IL1:IL2) CBRNPAK(IOFF+IL1:IOFF+IL2) = CBRNROW(IL1:IL2) CFRHPAK(IOFF+IL1:IOFF+IL2) = CFRHROW(IL1:IL2) CFHTPAK(IOFF+IL1:IOFF+IL2) = CFHTROW(IL1:IL2) CFLFPAK(IOFF+IL1:IOFF+IL2) = CFLFROW(IL1:IL2) CFRDPAK(IOFF+IL1:IOFF+IL2) = CFRDROW(IL1:IL2) CFRGPAK(IOFF+IL1:IOFF+IL2) = CFRGROW(IL1:IL2) CFRMPAK(IOFF+IL1:IOFF+IL2) = CFRMROW(IL1:IL2) CVGLPAK(IOFF+IL1:IOFF+IL2) = CVGLROW(IL1:IL2) CVGSPAK(IOFF+IL1:IOFF+IL2) = CVGSROW(IL1:IL2) CVGRPAK(IOFF+IL1:IOFF+IL2) = CVGRROW(IL1:IL2) CFNLPAK(IOFF+IL1:IOFF+IL2) = CFNLROW(IL1:IL2) CFNSPAK(IOFF+IL1:IOFF+IL2) = CFNSROW(IL1:IL2) CFNRPAK(IOFF+IL1:IOFF+IL2) = CFNRROW(IL1:IL2) CH4HPAK(IOFF+IL1:IOFF+IL2) = CH4HROW(IL1:IL2) CH4NPAK(IOFF+IL1:IOFF+IL2) = CH4NROW(IL1:IL2) WFRAPAK(IOFF+IL1:IOFF+IL2) = WFRAROW(IL1:IL2) CW1DPAK(IOFF+IL1:IOFF+IL2) = CW1DROW(IL1:IL2) CW2DPAK(IOFF+IL1:IOFF+IL2) = CW2DROW(IL1:IL2) FCOLPAK(IOFF+IL1:IOFF+IL2) = FCOLROW(IL1:IL2) CURFPAK(IOFF+IL1:IOFF+IL2,:) = CURFROW(IL1:IL2,:) %d physici.2853,2859 + RMATCROT, RTCTMROT, AILCROT, PAICROT, + SLAICROT, FCANCROT, TODFCROT, + AILCGROT, SLAIROT, + CFCANROT, CALVCROT, CALICROT, + ZOLNCROT, CMASCROT, + CO2CG1ROT, CO2CG2ROT, CO2CS1ROT, CO2CS2ROT, + CFLUXCSROT,CFLUXCGROT, + TARTL, FSNOWRTL, TCANORTL, TCANSRTL, + TBARRTL, TBARCRTL, TBARCSRTL, TBARGRTL, + TBARGSRTL,THLIQCRTL,THLIQGRTL, THICECRTL, + ANCSRTL, ANCGRTL, RMLCSRTL, RMLCGRTL, + SOILCROT, LITRCROT, ROOTCROT, STEMCROT, + GLEAFCROT,BLEAFCROT,FALLHROT, POSPHROT, + LEAFSROT, GROWTROT, LASTRROT, LASTSROT, + THISYLROT,STEMHROT, ROOTHROT, TEMPCROT, + AILCBROT, BMASVROT, VEGHROT, ROOTDROT, + CVEGROT, CDEBROT, CHUMROT, + PREFROT, NEWFROT, FCOLROT, + CVEGROW, CDEBROW, CHUMROW, + CLAIROW, CFNPROW, CFNEROW, + CFRVROW, CFGPROW, CFNBROW, + CFFVROW, CFFDROW, CFLVROW, + CFLDROW, CFLHROW, CBRNROW, + CFRHROW, CFHTROW, CFLFROW, + CFRDROW, CFRGROW, CFRMROW, + CVGLROW, CVGSROW, CVGRROW, + CFNLROW, CFNSROW, CFNRROW, + CH4HROW, CH4NROW, WFRAROW, + CW1DROW, CW2DROW, FCOLROW, CURFROW, + PEXFROW, PFHCROW, WETFROW, WETSROW, LGHTROW, %d sfcproc2.51,57 + RMATCROT, RTCTMROT, AILCROT, PAICROT, + SLAICROT, FCANCROT, TODFCROT, + AILCGROT, SLAIROT, + CFCANROT, CALVCROT, CALICROT, + ZOLNCROT, CMASCROT, + CO2CG1ROT, CO2CG2ROT, CO2CS1ROT, CO2CS2ROT, + CFLUXCSROT,CFLUXCGROT, + TARTL, FSNOWRTL, TCANORTL, TCANSRTL, + TBARRTL, TBARCRTL, TBARCSRTL, TBARGRTL, + TBARGSRTL,THLIQCRTL,THLIQGRTL, THICECRTL, + ANCSRTL, ANCGRTL, RMLCSRTL, RMLCGRTL, + SOILCROT, LITRCROT, ROOTCROT, STEMCROT, + GLEAFCROT,BLEAFCROT,FALLHROT, POSPHROT, + LEAFSROT, GROWTROT, LASTRROT, LASTSROT, + THISYLROT,STEMHROT, ROOTHROT, TEMPCROT, + AILCBROT, BMASVROT, VEGHROT, ROOTDROT, + CVEGROT, CDEBROT, CHUMROT, + PREFROT, NEWFROT, FCOLROT, + CVEGROW, CDEBROW, CHUMROW, + CLAIROW, CFNPROW, CFNEROW, + CFRVROW, CFGPROW, CFNBROW, + CFFVROW, CFFDROW, CFLVROW, + CFLDROW, CFLHROW, CBRNROW, + CFRHROW, CFHTROW, CFLFROW, + CFRDROW, CFRGROW, CFRMROW, + CVGLROW, CVGSROW, CVGRROW, + CFNLROW, CFNSROW, CFNRROW, + CH4HROW, CH4NROW, WFRAROW, + CW1DROW, CW2DROW, FCOLROW, CURFROW, + PEXFROW, PFHCROW, WETFROW, WETSROW, LGHTROW, %i sfcproc2.457 REAL, DIMENSION(ILGM,IGND) :: SANDGAT,CLAYGAT %i sfcproc2.459 REAL, DIMENSION(ILGM) :: SDEPGAT %d sfcproc2.603,607 REAL RMATCROT(ILG,NTLD,ICAN,IGND) REAL RTCTMROT(ILG,NTLD,ICTEM,IGND) REAL CFCANROT(ILG,NTLD,ICANP1), CALVCROT (ILG,NTLD,ICANP1), 1 CALICROT(ILG,NTLD,ICANP1) REAL AILCROT (ILG,NTLD,ICAN), PAICROT (ILG,NTLD,ICAN), 1 SLAICROT (ILG,NTLD,ICAN), ZOLNCROT (ILG,NTLD,ICAN), 2 CMASCROT (ILG,NTLD,ICAN) %d sfcproc2.609,622 REAL FCANCROT (ILG,NTLD,ICTEM), TODFCROT (ILG,NTLD,ICTEM), 1 AILCGROT (ILG,NTLD,ICTEM), SLAIROT (ILG,NTLD,ICTEM), 2 CO2CG1ROT(ILG,NTLD,ICTEM), CO2CG2ROT(ILG,NTLD,ICTEM), 3 CO2CS1ROT(ILG,NTLD,ICTEM), CO2CS2ROT(ILG,NTLD,ICTEM) REAL CFLUXCSROT(ILG,NTLD), CFLUXCGROT(ILG,NTLD) C C * INPUT FIELDS TO MAIN CTEM ROUTINE FROM AVERAGE OVER C * COUPLING PERIOD OF PREVIOUS COUPLING CYCLE. C REAL TBARRTL (ILG,NTLD,IGND), TBARCRTL (ILG,NTLD,IGND), 1 TBARCSRTL(ILG,NTLD,IGND), TBARGRTL (ILG,NTLD,IGND), 2 TBARGSRTL(ILG,NTLD,IGND), THLIQCRTL(ILG,NTLD,IGND), 3 THLIQGRTL(ILG,NTLD,IGND), THICECRTL(ILG,NTLD,IGND) C REAL ANCSRTL (ILG,NTLD,ICTEM), ANCGRTL (ILG,NTLD,ICTEM), 1 RMLCSRTL (ILG,NTLD,ICTEM), RMLCGRTL (ILG,NTLD,ICTEM) C REAL TARTL (ILG,NTLD), FSNOWRTL (ILG,NTLD), 1 TCANORTL (ILG,NTLD), TCANSRTL (ILG,NTLD) C C * INPUT/OUTPUT FIELDS FROM MAIN CTEM ROUTINE. C REAL SOILCROT (ILG,NTLD,ICTEMP1), LITRCROT (ILG,NTLD,ICTEMP1), 1 ROOTCROT (ILG,NTLD,ICTEM), STEMCROT (ILG,NTLD,ICTEM), 2 GLEAFCROT(ILG,NTLD,ICTEM), BLEAFCROT(ILG,NTLD,ICTEM), 3 FALLHROT (ILG,NTLD,ICTEM), POSPHROT (ILG,NTLD,ICTEM), 4 LEAFSROT (ILG,NTLD,ICTEM), GROWTROT (ILG,NTLD,ICTEM), 5 LASTRROT (ILG,NTLD,ICTEM), LASTSROT (ILG,NTLD,ICTEM), 6 THISYLROT(ILG,NTLD,ICTEM), STEMHROT (ILG,NTLD,ICTEM), 7 ROOTHROT (ILG,NTLD,ICTEM), TEMPCROT (ILG,NTLD,2), 8 ROOTDROT (ILG,NTLD,ICTEM), AILCBROT (ILG,NTLD,ICTEM), 9 BMASVROT (ILG,NTLD,ICTEM), VEGHROT (ILG,NTLD,ICTEM) C REAL CVEGROT(ILG,NTLD), CDEBROT(ILG,NTLD), CHUMROT(ILG,NTLD), 1 FCOLROT(ILG,NTLD) C REAL CVEGROW(ILG), CDEBROW(ILG), CHUMROW(ILG), 1 CLAIROW(ILG), CFNPROW(ILG), CFNEROW(ILG), 2 CFRVROW(ILG), CFGPROW(ILG), CFNBROW(ILG), 3 CFFVROW(ILG), CFFDROW(ILG), CFLVROW(ILG), 4 CFLDROW(ILG), CFLHROW(ILG), CBRNROW(ILG), 5 CFRHROW(ILG), CFHTROW(ILG), CFLFROW(ILG), 6 CFRDROW(ILG), CFRGROW(ILG), CFRMROW(ILG), 7 CVGLROW(ILG), CVGSROW(ILG), CVGRROW(ILG), 8 CFNLROW(ILG), CFNSROW(ILG), CFNRROW(ILG), 9 CH4HROW(ILG), CH4NROW(ILG), WFRAROW(ILG), A CW1DROW(ILG), CW2DROW(ILG), FCOLROW(ILG) C REAL CURFROW(ILG,ICTEM) C REAL PEXFROW(ILG), PFHCROW(ILG), WETFROW(ILG), 1 WETSROW(ILG), LGHTROW(ILG) C C * CTEM PFT FRACTIONS. C REAL PREFROT(ILG,NTLD,ICTEM), NEWFROT(ILG,NTLD,ICTEM) %i sfcproc2.624 INTEGER SPINFAST,PHTSYNON,DYNVEGON,LNDUSEON REAL CTMDELTAT LOGICAL DOFIRE %d sfcproc2.627,646 #if defined (agcm_ctem) C C * CTEM GATHERED FIELDS (EXIST ONLY IF RUNNING CTEM). C REAL RMATCGAT(ILGM,ICAN,IGND) REAL RTCTMGAT(ILGM,ICTEM,IGND) REAL CFCANGAT(ILGM,ICAN), CALVCGAT(ILGM,ICAN), 1 CALICGAT(ILGM,ICAN) REAL AILCGAT (ILGM,ICAN), PAICGAT (ILGM,ICAN), 1 SLAICGAT(ILGM,ICAN), ZOLNCGAT(ILGM,ICAN), 2 CMASCGAT(ILGM,ICAN) REAL FCANCGAT (ILGM,ICTEM), TODFCGAT (ILGM,ICTEM), 1 AILCGGAT (ILGM,ICTEM), SLAIGAT (ILGM,ICTEM), 2 CO2CG1GAT(ILGM,ICTEM), CO2CG2GAT(ILGM,ICTEM), 3 CO2CS1GAT(ILGM,ICTEM), CO2CS2GAT(ILGM,ICTEM) REAL CFLUXCSGAT(ILGM), CFLUXCGGAT(ILGM) C C * INPUT FIELDS TO MAIN CTEM ROUTINE FROM AVERAGE OVER C * COUPLING PERIOD OF PREVIOUS COUPLING CYCLE. C REAL TBARGTL (ILGM,IGND), TBARCGTL (ILGM,IGND), 1 TBARCSGTL(ILGM,IGND), TBARGGTL (ILGM,IGND), 2 TBARGSGTL(ILGM,IGND), THLIQCGTL(ILGM,IGND), 3 THLIQGGTL(ILGM,IGND), THICECGTL(ILGM,IGND) C REAL ANCSGTL (ILGM,ICTEM), ANCGGTL (ILGM,ICTEM), 1 RMLCSGTL (ILGM,ICTEM), RMLCGGTL (ILGM,ICTEM) C REAL TAGTL (ILGM), FSNOWGTL (ILGM), 1 TCANOGTL (ILGM), TCANSGTL (ILGM) C C * INPUT/OUTPUT FIELDS FROM MAIN CTEM ROUTINE. C REAL SOILCGAT (ILGM,ICTEMP1), LITRCGAT (ILGM,ICTEMP1), 1 ROOTCGAT (ILGM,ICTEM), STEMCGAT (ILGM,ICTEM), 2 GLEAFCGAT(ILGM,ICTEM), BLEAFCGAT(ILGM,ICTEM), 3 FALLHGAT (ILGM,ICTEM), GROWTGAT (ILGM,ICTEM), 5 LASTRGAT (ILGM,ICTEM), LASTSGAT (ILGM,ICTEM), 6 THISYLGAT(ILGM,ICTEM), STEMHGAT (ILGM,ICTEM), 7 ROOTHGAT (ILGM,ICTEM), 8 ROOTDGAT (ILGM,ICTEM), AILCBGAT (ILGM,ICTEM), 9 BMASVGAT (ILGM,ICTEM), VEGHGAT (ILGM,ICTEM) INTEGER POSPHGAT (ILGM,ICTEM), LEAFSGAT (ILGM,ICTEM), 1 TEMPCGAT (ILGM,2) C REAL CVEGGAT(ILGM), CDEBGAT(ILGM), CHUMGAT(ILGM), 1 CLAIGAT(ILGM), CFNPGAT(ILGM), CFNEGAT(ILGM), 2 CFRVGAT(ILGM), CFGPGAT(ILGM), CFNBGAT(ILGM), 3 CFFVGAT(ILGM), CFFDGAT(ILGM), CFLVGAT(ILGM), 4 CFLDGAT(ILGM), CFLHGAT(ILGM), CBRNGAT(ILGM), 5 CFRHGAT(ILGM), CFHTGAT(ILGM), CFLFGAT(ILGM), 6 CFRDGAT(ILGM), CFRGGAT(ILGM), CFRMGAT(ILGM), 7 CVGLGAT(ILGM), CVGSGAT(ILGM), CVGRGAT(ILGM), 8 CFNLGAT(ILGM), CFNSGAT(ILGM), CFNRGAT(ILGM), 9 CH4HGAT(ILGM), CH4NGAT(ILGM), WFRAGAT(ILGM), A CW1DGAT(ILGM), CW2DGAT(ILGM), FCOLGAT(ILGM), B AREAGAT(ILGM) C REAL PEXFGAT(ILGM), PFHCGAT(ILGM), WETFGAT(ILGM), 1 WETSGAT(ILGM), LGHTGAT(ILGM) C C * CTEM PFT FRACTIONS. C REAL PREFGAT (ILGM,ICTEM), NEWFGAT (ILGM,ICTEM) C C * INTERNAL WORK FIELDS FOR MAIN CTEM SUBROUTINE. C REAL PFCANCMX(ILGM,ICTEM), NFCANCMX(ILGM,ICTEM), 1 TLTRLEAF(ILGM,ICTEM), TLTRROOT(ILGM,ICTEM), 2 TLTRSTEM(ILGM,ICTEM), LEAFLITR(ILGM,ICTEM), 3 ROOTTEMP(ILGM,ICTEM) REAL RML (ILGM), RMR (ILGM), 1 RMS (ILGM), PROBFIRE(ILGM), 2 HETRORES(ILGM), SOILRESP(ILGM) C C * INTERNAL WORK FIELDS FOR ACCUMULATING DIURNAL-AVERAGE C * FIELDS TO BE USED AT NEXT TIMESTEP FOR CLASS. C REAL ANCGGAT (ILGM,ICTEM), ANCSGAT (ILGM,ICTEM), 1 RMLCGGAT(ILGM,ICTEM), RMLCSGAT(ILGM,ICTEM) C C * OTHER INTERNAL WORK FIELDS FOR CTEM. C REAL XDIFFUS(ILGM), FRACSUM(ILGM), POPDIN(ILGM) %i sfcproc2.1083 C #if defined (agcm_ctem) CVEGROW=0. ; CDEBROW=0. ; CHUMROW=0. CLAIROW=0. CVGLROW=0. ; CVGSROW=0. ; CVGRROW=0. CURFROW=0. #endif %d sfcproc2.1163,1164 #if defined (agcm_ctem) C C * ZERO OUT INTERNAL WORK FIELDS FOR MAIN CTEM SUBROUTINE. C PFCANCMX =0. ; NFCANCMX=0. TLTRLEAF =0 ; TLTRROOT=0. ; TLTRSTEM=0. LEAFLITR =0. ; ROOTTEMP=0. C RML =0. ; RMR =0. ; RMS =0. PROBFIRE =0. ; HETRORES=0. ; SOILRESP=0. %d sfcproc2.1222 #if defined (agcm_ctem) %d sfcproc2.1227,1238 CALL CTEMG ( 1 CO2CG1GAT,CO2CG2GAT,CO2CS1GAT,CO2CS2GAT, 2 CFLUXCSGAT,CFLUXCGGAT,CO2GAT,FSFGAT, 3 LGHTGAT,PFHCGAT,PEXFGAT,WETFGAT,WETSGAT, 4 SOILCGAT,LITRCGAT,ROOTCGAT,STEMCGAT, 5 GLEAFCGAT,BLEAFCGAT,FALLHGAT,POSPHGAT, 6 LEAFSGAT,GROWTGAT,LASTRGAT,LASTSGAT, 7 THISYLGAT,STEMHGAT,ROOTHGAT,TEMPCGAT, 9 PREFGAT,NEWFGAT,AREAGAT, A SANDGAT,CLAYGAT,SDEPGAT, B TAGTL,FSNOWGTL,TCANOGTL,TCANSGTL, C TBARGTL,TBARCGTL,TBARCSGTL,TBARGGTL, D TBARGSGTL,THLIQCGTL,THLIQGGTL,THICECGTL, E ANCSGTL,ANCGGTL,RMLCSGTL,RMLCGGTL, F ILMOS,JLMOS, G NML,ILG,NTLD,IM,ILGM,IGND,ICAN,ICANP1, H ICTEM,ICTEMP1,KOUNT,GMT, J CO2CG1ROT,CO2CG2ROT,CO2CS1ROT,CO2CS2ROT, K CFLUXCSROT,CFLUXCGROT,CO2ROW,FSFROT, L LGHTROW,PFHCROW,PEXFROW,WETFROW,WETSROW, M SOILCROT,LITRCROT,ROOTCROT,STEMCROT, N GLEAFCROT,BLEAFCROT,FALLHROT,POSPHROT, O LEAFSROT,GROWTROT,LASTRROT,LASTSROT, P THISYLROT,STEMHROT,ROOTHROT,TEMPCROT, R PREFROT,NEWFROT,AREAROW, S SANDROT,CLAYROT,SDEPROT, T TARTL,FSNOWRTL,TCANORTL,TCANSRTL, U TBARRTL,TBARCRTL,TBARCSRTL,TBARGRTL, V TBARGSRTL,THLIQCRTL,THLIQGRTL,THICECRTL, W ANCSRTL,ANCGRTL,RMLCSRTL,RMLCGRTL ) C----------------------------------------------------------------------- C * SET POPULATION DENSITY TO ZERO BUT EVENTUALLY THIS NEEDS C * TO BE READ IN. C POPDIN=0. C----------------------------------------------------------------------- C * CTEM VEGETATION CLASS FRACTION INTERPOLATION (ONCE PER COUPLING C * CYCLE). C IF(GMT.EQ.0. .OR. KOUNT.EQ.KSTART) THEN CALL INTCTEMF (FCANCGAT,TODFCGAT,CFCANGAT, 1 NEWFGAT,PREFGAT,SANDGAT,SDEPGAT,NOL2PFTS, 2 C_CLIM_TIME,MONTH,IDAY,GMT,LNDCVRYR2, 3 ICAN,IGND,ICTEM,ILGM,1,NML) C DO L=1,ICAN DO K=1,NML IF(SANDGAT(K,1).EQ.-4.) CFCANGAT(K,L)=0. ENDDO ENDDO ELSE DO L=1,ICTEM DO K=1,NML FCANCGAT (K,L)=FCANCROT (ILMOS(K),JLMOS(K),L) TODFCGAT (K,L)=TODFCROT (ILMOS(K),JLMOS(K),L) ENDDO ENDDO C DO L=1,ICAN DO K=1,NML CFCANGAT (K,L)=CFCANROT(ILMOS(K),JLMOS(K),L) ENDDO ENDDO ENDIF C----------------------------------------------------------------------- IF(KOUNT.EQ.KSTART) THEN C C * DETERMINE STARTING VEGETATION CHARACTERISTICS FOR C * MONTH SIMULATION, SIMILAR TO WHAT WAS DONE IN C * CTEM_INIT. C C * FIRST, CALCULATE STORAGE TERMS OVER ALL CTEM CLASSES. C CVEGGAT=0. ! VEGETATION BIOMASS CDEBGAT=0. ! LITTER MASS CHUMGAT=0. ! SOIL C MASS C FRACSUM=0. DO L=1,ICTEM DO K=1,NML FRACSUM(K) = FRACSUM(K) + FCANCGAT(K,L) CVEGGAT(K) = CVEGGAT(K) + 1 (FCANCGAT(K,L)*(GLEAFCGAT(K,L)+ 2 STEMCGAT(K,L)+ROOTCGAT(K,L)+ 3 BLEAFCGAT(K,L))) CDEBGAT(K) = CDEBGAT(K) + 1 (FCANCGAT(K,L)*LITRCGAT(K,L)) CHUMGAT(K) = CHUMGAT(K) + 1 (FCANCGAT(K,L)*SOILCGAT(K,L)) ENDDO ENDDO C L=ICTEMP1 DO K=1,NML BAREFRAC = 1.0 - FRACSUM(K) CDEBGAT(K) = CDEBGAT(K) + 1 (BAREFRAC*LITRCGAT(K,L)) CHUMGAT(K) = CHUMGAT(K) + 1 (BAREFRAC*SOILCGAT(K,L)) ENDDO C C * NEXT, CONVERT BIOMASS TO STRUCTURAL ATTRIBUTES. C CALL BIO2STR(GLEAFCGAT,BLEAFCGAT, STEMCGAT, ROOTCGAT, 1 ICTEM, ILGM, 1, NML, 2 IGND, ICAN, FCANCGAT, ZBTWGAT, 3 DLZWGAT, NOL2PFTS, L2MAX, SDEPGAT, C 4-------- INPUTS ABOVE THIS LINE, OUTPUTS BELOW -------- 5 AILCGGAT, AILCBGAT, AILCGAT, ZOLNCGAT, 6 RMATCGAT, RTCTMGAT, SLAIGAT, BMASVGAT, 7 CMASCGAT, VEGHGAT, ROOTDGAT, CALVCGAT, 8 CALICGAT, PAICGAT, SLAICGAT) ELSE C C * DO GATHER OF BIO2STR OUTPUT FIELDS AT SUCCEEDING STEPS. C DO K=1,NML CVEGGAT (K)=CVEGROT (ILMOS(K),JLMOS(K)) CDEBGAT (K)=CDEBROT (ILMOS(K),JLMOS(K)) CHUMGAT (K)=CHUMROT (ILMOS(K),JLMOS(K)) ENDDO C DO J=1,IGND DO L=1,ICAN DO K=1,NML RMATCGAT(K,L,J)=RMATCROT(ILMOS(K),JLMOS(K),L,J) ENDDO ENDDO ENDDO C DO J=1,IGND DO L=1,ICTEM DO K=1,NML RTCTMGAT(K,L,J)=RTCTMROT(ILMOS(K),JLMOS(K),L,J) ENDDO ENDDO ENDDO C DO L=1,ICAN DO K=1,NML CALVCGAT (K,L)=CALVCROT(ILMOS(K),JLMOS(K),L) CALICGAT (K,L)=CALICROT(ILMOS(K),JLMOS(K),L) ENDDO ENDDO C DO L=1,ICAN DO K=1,NML ZOLNCGAT (K,L)=ZOLNCROT(ILMOS(K),JLMOS(K),L) CMASCGAT (K,L)=CMASCROT(ILMOS(K),JLMOS(K),L) AILCGAT (K,L)=AILCROT (ILMOS(K),JLMOS(K),L) PAICGAT (K,L)=PAICROT (ILMOS(K),JLMOS(K),L) SLAICGAT (K,L)=SLAICROT(ILMOS(K),JLMOS(K),L) ENDDO ENDDO C DO L=1,ICTEM DO K=1,NML AILCGGAT (K,L)=AILCGROT (ILMOS(K),JLMOS(K),L) SLAIGAT (K,L)=SLAIROT (ILMOS(K),JLMOS(K),L) AILCBGAT (K,L)=AILCBROT (ILMOS(K),JLMOS(K),L) BMASVGAT (K,L)=BMASVROT (ILMOS(K),JLMOS(K),L) VEGHGAT (K,L)=VEGHROT (ILMOS(K),JLMOS(K),L) ROOTDGAT (K,L)=ROOTDROT (ILMOS(K),JLMOS(K),L) ENDDO ENDDO ENDIF ! (KOUNT.EQ.KSTART) C----------------------------------------------------------------------- IF(ICTEMMOD.EQ.1) THEN C C * OVERRIDE GATHERED VEGETATION CHARACTERISTICS C * (UNPACKED/GATHERED FROM CLASS INVARIANT FIELDS) C * BY THOSE OF CTEM. C * ZERO OUT {PAMN,PAMX,ROOT} ONLY USED IN CLASSA/APREP FOR NON-CTEM. C * NOTE: WE ZERO OUT URBAN **FOR NOW**, AS HAS BEEN DONE HISTORICALLY C * UP TO THIS POINT, UNTIL VIVEK HAS THIS WORKING. C DO L=1,ICAN DO K=1,NML ALICGAT(K,L)=CALICGAT(K,L) ALVCGAT(K,L)=CALVCGAT(K,L) CMASGAT(K,L)=CMASCGAT(K,L) FCANGAT(K,L)=CFCANGAT(K,L) IF(SANDGAT(K,1).EQ.-4.) FCANGAT(K,L)=0. PAMNGAT(K,L)=0. PAMXGAT(K,L)=0. LNZ0GAT(K,L)=ZOLNCGAT(K,L) ROOTGAT(K,L)=0. ENDDO ENDDO C L=ICAN+1 DO K=1,NML ALICGAT(K,L)=0. ALVCGAT(K,L)=0. FCANGAT(K,L)=0. ENDDO ENDIF %d sfcproc2.1312,1319 %d sfcproc2.1352 V ICTEM, ICTEMMOD, RTCTMGAT, %i sfcproc2.1415 C--------------------------------------------------------------- #if defined (agcm_ctem) C C * ACCUMULATE CTEM VARIABLES OVER A DAY. C DO K = 1, NML IF(GMT.EQ.0. .OR. KOUNT.EQ.0) THEN TAGTL (K)=TAGAT (K)*DELT/DAYLNT FSNOWGTL(K)=FNGAT (K)*DELT/DAYLNT TCANOGTL(K)=TCANO (K)*DELT/DAYLNT TCANSGTL(K)=TCANS (K)*DELT/DAYLNT ELSE TAGTL (K)=TAGTL (K)+TAGAT (K)*DELT/DAYLNT FSNOWGTL(K)=FSNOWGTL(K)+FNGAT (K)*DELT/DAYLNT TCANOGTL(K)=TCANOGTL(K)+TCANO (K)*DELT/DAYLNT TCANSGTL(K)=TCANSGTL(K)+TCANS (K)*DELT/DAYLNT ENDIF ENDDO C DO L = 1, IGND DO K = 1, NML IF(GMT.EQ.0. .OR. KOUNT.EQ.0) THEN TBARGTL (K,L)=TGGAT (K,L)*DELT/DAYLNT c TBARCGTL (K,L)=(TBARC (K,L)+TFREZ)*DELT/DAYLNT c TBARCSGTL(K,L)=(TBARCS(K,L)+TFREZ)*DELT/DAYLNT c TBARGGTL (K,L)=(TBARG (K,L)+TFREZ)*DELT/DAYLNT c TBARGSGTL(K,L)=(TBARGS(K,L)+TFREZ)*DELT/DAYLNT TBARCGTL (K,L)=TGGAT (K,L)*DELT/DAYLNT TBARCSGTL(K,L)=TGGAT (K,L)*DELT/DAYLNT TBARGGTL (K,L)=TGGAT (K,L)*DELT/DAYLNT TBARGSGTL(K,L)=TGGAT (K,L)*DELT/DAYLNT THLIQCGTL(K,L)=THLIQC(K,L)*DELT/DAYLNT THLIQGGTL(K,L)=THLIQG(K,L)*DELT/DAYLNT THICECGTL(K,L)=THICEC(K,L)*DELT/DAYLNT ELSE TBARGTL (K,L)=TBARGTL (K,L) + TGGAT (K,L)*DELT/DAYLNT c TBARCGTL (K,L)=TBARCGTL (K,L) + c 1 (TBARC (K,L)+TFREZ)*DELT/DAYLNT c TBARCSGTL(K,L)=TBARCSGTL(K,L) + c 1 (TBARCS(K,L)+TFREZ)*DELT/DAYLNT c TBARGGTL (K,L)=TBARGGTL (K,L) + c 1 (TBARG (K,L)+TFREZ)*DELT/DAYLNT c TBARGSGTL(K,L)=TBARGSGTL(K,L) + c 1 (TBARGS(K,L)+TFREZ)*DELT/DAYLNT TBARCGTL (K,L)=TBARCGTL (K,L) + TGGAT (K,L)*DELT/DAYLNT TBARCSGTL(K,L)=TBARCSGTL(K,L) + TGGAT (K,L)*DELT/DAYLNT TBARGGTL (K,L)=TBARGGTL (K,L) + TGGAT (K,L)*DELT/DAYLNT TBARGSGTL(K,L)=TBARGSGTL(K,L) + TGGAT (K,L)*DELT/DAYLNT THLIQCGTL(K,L)=THLIQCGTL(K,L) + THLIQC(K,L)*DELT/DAYLNT THLIQGGTL(K,L)=THLIQGGTL(K,L) + THLIQG(K,L)*DELT/DAYLNT THICECGTL(K,L)=THICECGTL(K,L) + THICEC(K,L)*DELT/DAYLNT ENDIF ENDDO ENDDO C DO L = 1, ICTEM DO K = 1, NML IF(GMT.EQ.0. .OR. KOUNT.EQ.0) THEN ANCSGTL (K,L)=ANCSGAT (K,L)*DELT/DAYLNT ANCGGTL (K,L)=ANCGGAT (K,L)*DELT/DAYLNT RMLCSGTL(K,L)=RMLCSGAT(K,L)*DELT/DAYLNT RMLCGGTL(K,L)=RMLCGGAT(K,L)*DELT/DAYLNT ELSE ANCSGTL (K,L)=ANCSGTL (K,L) + ANCSGAT (K,L)*DELT/DAYLNT ANCGGTL (K,L)=ANCGGTL (K,L) + ANCGGAT (K,L)*DELT/DAYLNT RMLCSGTL(K,L)=RMLCSGTL(K,L) + RMLCSGAT(K,L)*DELT/DAYLNT RMLCGGTL(K,L)=RMLCGGTL(K,L) + RMLCGGAT(K,L)*DELT/DAYLNT ENDIF ENDDO ENDDO C----------------------------------------------------------------------- IF(GMT.EQ.DAYLNT-DELT) THEN ! end of coupling period only!!! C C * MAIN CTEM CALCULATIONS. C CFNPGAT=0. ; CFNEGAT=0. CFRVGAT=0. ; CFGPGAT=0. ; CFNBGAT=0. CFFVGAT=0. ; CFFDGAT=0. ; CFLVGAT=0. CFLDGAT=0. ; CFLHGAT=0. ; CBRNGAT=0. CFRHGAT=0. ; CFHTGAT=0. ; CFLFGAT=0. CFRDGAT=0. ; CFRGGAT=0. ; CFRMGAT=0. CFNLGAT=0. ; CFNSGAT=0. ; CFNRGAT=0. CH4HGAT=0. ; CH4NGAT=0. ; WFRAGAT=0. CW1DGAT=0. ; CW2DGAT=0. ; FCOLGAT=0. C DOFIRE = .FALSE. CTMDELTAT= 1. ! CTEM TIMESTEP PHTSYNON = 1 DYNVEGON = 1 LNDUSEON = 1 SPINFAST = 1 ! DEFAULT VALUE = 1. USE HIGHER VALUES FOR FASTER C ! SPIN UP OF SOIL C POOL C CALL CTEM (FCANCGAT, FSNOWGTL, SANDGAT, CLAYGAT, 2 ICAN, ILGM, 1, NML, 3 IGND, ICTEM, IDAY, RADJGAT, 4 TCANOGTL, TCANSGTL, TBARCGTL, TBARCSGTL, 5 TBARGGTL, TBARGSGTL, TAGTL, DLZWGAT, 6 ANCSGTL, ANCGGTL, RMLCSGTL, RMLCGGTL, 7 ZBTWGAT, THLIQCGTL, THLIQGGTL, CTMDELTAT, 8 VMODGAT, LGHTGAT, PFHCGAT, 9 PEXFGAT, TBARGTL, L2MAX, A NOL2PFTS, PFCANCMX, NFCANCMX, LNDUSEON, B THICECGTL, SDEPGAT, SPINFAST, TODFCGAT, C WETFGAT, WETSGAT, POPDIN, DOFIRE, D ISNDGAT, AREAGAT, C -------------- INPUTS USED BY CTEM ARE ABOVE THIS LINE --------- C STEMCGAT, ROOTCGAT, LITRCGAT, GLEAFCGAT, D BLEAFCGAT, SOILCGAT, AILCGGAT, AILCGAT, E ZOLNCGAT, RTCTMGAT, RMATCGAT, AILCBGAT, F FALLHGAT, POSPHGAT, LEAFSGAT, GROWTGAT, G LASTSGAT, LASTRGAT, THISYLGAT, CVEGGAT, H CDEBGAT, CHUMGAT, STEMHGAT, SLAIGAT, I BMASVGAT, CMASCGAT, TEMPCGAT, ROOTHGAT, J CFCANGAT, CALVCGAT, CALICGAT, CLAIGAT, K CVGLGAT, CVGRGAT, CVGSGAT, C -------------- INPUTS UPDATED BY CTEM ARE ABOVE THIS LINE ------ L CFNPGAT, CFNEGAT, HETRORES, CFRVGAT, M SOILRESP, CFRMGAT, CFRGGAT, CFNBGAT, N CFRDGAT, CFRHGAT, CFGPGAT, CFFVGAT, O CFLFGAT, CFHTGAT, VEGHGAT, ROOTDGAT, P RML, RMS, RMR, TLTRLEAF, Q TLTRSTEM, TLTRROOT, LEAFLITR, ROOTTEMP, R CBRNGAT, PROBFIRE, CFLVGAT, CFLDGAT, S CFLHGAT, CFFDGAT, CFNLGAT, CFNSGAT, T CFNRGAT, CH4HGAT, CH4NGAT, WFRAGAT, U CW1DGAT, CW2DGAT, PAICGAT, SLAICGAT) C ---------------- OUTPUTS ARE LISTED ABOVE THIS LINE ------------ C DO K=1,NML FCOLGAT(K) = -1.0*CFNBGAT(K)*1.e-6 ENDDO C C * CALCULATE THE DIAGNOSTIC OUTPUT RESULTS. C * FIRST, DETERMINE THE NUMBER OF TIMESTEPS TO NORMALIZE WITH. C * FOR NOW, THE CTEM FIELDS ARE ONLY CALCULATED ONCE PER C * DAY, SO SAVECTM=1. IF WE CHANGE THIS LATER TO CALCULATE AND C * SAVE EVERY TIMESTEP, WE NEED TO CHANGE TO SAVECTM=SAVEBEG. C C SAVECTM=SAVEBEG SAVECTM=1. C DO K=1,NML FAREA=FAREROT(ILMOS(K),JLMOS(K)) CVEGROW(ILMOS(K))=CVEGROW(ILMOS(K))+CVEGGAT(K)*FAREA CDEBROW(ILMOS(K))=CDEBROW(ILMOS(K))+CDEBGAT(K)*FAREA CHUMROW(ILMOS(K))=CHUMROW(ILMOS(K))+CHUMGAT(K)*FAREA CLAIROW(ILMOS(K))=CLAIROW(ILMOS(K))+CLAIGAT(K)*FAREA CFNPROW(ILMOS(K))=CFNPROW(ILMOS(K))+CFNPGAT(K)*FAREA*SAVECTM CFNEROW(ILMOS(K))=CFNEROW(ILMOS(K))+CFNEGAT(K)*FAREA*SAVECTM CFRVROW(ILMOS(K))=CFRVROW(ILMOS(K))+CFRVGAT(K)*FAREA*SAVECTM CFGPROW(ILMOS(K))=CFGPROW(ILMOS(K))+CFGPGAT(K)*FAREA*SAVECTM CFNBROW(ILMOS(K))=CFNBROW(ILMOS(K))+CFNBGAT(K)*FAREA*SAVECTM CFFVROW(ILMOS(K))=CFFVROW(ILMOS(K))+CFFVGAT(K)*FAREA*SAVECTM CFFDROW(ILMOS(K))=CFFDROW(ILMOS(K))+CFFDGAT(K)*FAREA*SAVECTM CFLVROW(ILMOS(K))=CFLVROW(ILMOS(K))+CFLVGAT(K)*FAREA*SAVECTM CFLDROW(ILMOS(K))=CFLDROW(ILMOS(K))+CFLDGAT(K)*FAREA*SAVECTM CFLHROW(ILMOS(K))=CFLHROW(ILMOS(K))+CFLHGAT(K)*FAREA*SAVECTM CBRNROW(ILMOS(K))=CBRNROW(ILMOS(K))+CBRNGAT(K)*FAREA*SAVECTM CFRHROW(ILMOS(K))=CFRHROW(ILMOS(K))+CFRHGAT(K)*FAREA*SAVECTM CFHTROW(ILMOS(K))=CFHTROW(ILMOS(K))+CFHTGAT(K)*FAREA*SAVECTM CFLFROW(ILMOS(K))=CFLFROW(ILMOS(K))+CFLFGAT(K)*FAREA*SAVECTM CFRDROW(ILMOS(K))=CFRDROW(ILMOS(K))+CFRDGAT(K)*FAREA*SAVECTM CFRGROW(ILMOS(K))=CFRGROW(ILMOS(K))+CFRGGAT(K)*FAREA*SAVECTM CFRMROW(ILMOS(K))=CFRMROW(ILMOS(K))+CFRMGAT(K)*FAREA*SAVECTM CVGLROW(ILMOS(K))=CVGLROW(ILMOS(K))+CVGLGAT(K)*FAREA CVGSROW(ILMOS(K))=CVGSROW(ILMOS(K))+CVGSGAT(K)*FAREA CVGRROW(ILMOS(K))=CVGRROW(ILMOS(K))+CVGRGAT(K)*FAREA CFNLROW(ILMOS(K))=CFNLROW(ILMOS(K))+CFNLGAT(K)*FAREA*SAVECTM CFNSROW(ILMOS(K))=CFNSROW(ILMOS(K))+CFNSGAT(K)*FAREA*SAVECTM CFNRROW(ILMOS(K))=CFNRROW(ILMOS(K))+CFNRGAT(K)*FAREA*SAVECTM CH4HROW(ILMOS(K))=CH4HROW(ILMOS(K))+CH4HGAT(K)*FAREA*SAVECTM CH4NROW(ILMOS(K))=CH4NROW(ILMOS(K))+CH4NGAT(K)*FAREA*SAVECTM WFRAROW(ILMOS(K))=WFRAROW(ILMOS(K))+WFRAGAT(K)*FAREA*SAVECTM CW1DROW(ILMOS(K))=CW1DROW(ILMOS(K))+CW1DGAT(K)*FAREA*SAVECTM CW2DROW(ILMOS(K))=CW2DROW(ILMOS(K))+CW2DGAT(K)*FAREA*SAVECTM FCOLROW(ILMOS(K))=FCOLROW(ILMOS(K))+FCOLGAT(K)*FAREA*SAVECTM ENDDO C DO L=1,ICTEM DO K=1,NML FAREA=FAREROT(ILMOS(K),JLMOS(K)) CURFROW(ILMOS(K),L)=CURFROW(ILMOS(K),L) + 1 FCANCGAT(K,L)*FAREA ENDDO ENDDO ENDIF #endif %d sfcproc2.1478,1492 #if defined (agcm_ctem) CALL CTEMS (RMATCROT,RTCTMROT, 1 AILCROT,PAICROT,SLAICROT, 2 FCANCROT,TODFCROT,AILCGROT,SLAIROT, 3 CFCANROT,CALVCROT,CALICROT, 4 ZOLNCROT,CMASCROT, 5 CFLUXCGROT,CFLUXCSROT, 6 CO2CG1ROT,CO2CG2ROT,CO2CS1ROT,CO2CS2ROT, 7 TARTL,FSNOWRTL,TCANORTL,TCANSRTL, 8 TBARRTL,TBARCRTL,TBARCSRTL,TBARGRTL, 9 TBARGSRTL,THLIQCRTL,THLIQGRTL,THICECRTL, A ANCSRTL,ANCGRTL,RMLCSRTL,RMLCGRTL, B SOILCROT,LITRCROT,ROOTCROT,STEMCROT, C GLEAFCROT,BLEAFCROT,FALLHROT,POSPHROT, D LEAFSROT,GROWTROT,LASTRROT,LASTSROT, E THISYLROT,STEMHROT,ROOTHROT,TEMPCROT, E AILCBROT,BMASVROT,VEGHROT,ROOTDROT, G CVEGROT,CDEBROT,CHUMROT,FCOLROT, H PREFROT,NEWFROT, I ILMOS,JLMOS, J NML,ILG,NTLD,ILGM,IGND,ICAN,ICANP1,ICTEM,ICTEMP1, K RMATCGAT,RTCTMGAT, L AILCGAT,PAICGAT,SLAICGAT, M FCANCGAT,TODFCGAT,AILCGGAT,SLAIGAT, N CFCANGAT,CALVCGAT,CALICGAT, O ZOLNCGAT,CMASCGAT, P CFLUXCGGAT,CFLUXCSGAT, Q CO2CG1GAT,CO2CG2GAT,CO2CS1GAT,CO2CS2GAT, R TAGTL,FSNOWGTL,TCANOGTL,TCANSGTL, S TBARGTL,TBARCGTL,TBARCSGTL,TBARGGTL, T TBARGSGTL,THLIQCGTL,THLIQGGTL,THICECGTL, U ANCSGTL,ANCGGTL,RMLCSGTL,RMLCGGTL, V SOILCGAT,LITRCGAT,ROOTCGAT,STEMCGAT, W GLEAFCGAT,BLEAFCGAT,FALLHGAT,POSPHGAT, X LEAFSGAT,GROWTGAT,LASTRGAT,LASTSGAT, Y THISYLGAT,STEMHGAT,ROOTHGAT,TEMPCGAT, Z AILCBGAT,BMASVGAT,VEGHGAT,ROOTDGAT, + CVEGGAT,CDEBGAT,CHUMGAT,FCOLGAT, + PREFGAT,NEWFGAT ) C C * ZERO OUT URBAN FIELDS FOR {CFCAN,CALVC,CALIC}. C * THESE ARE ALWAYS ZERO **FOR NOW**. C * NOTE: REMOVE THIS RESTRICTION AND GATHER/SCATTER OVER C * ICANP1 WHEN VIVEK HAS URBAN IN CTEM!!!!! C DO M=1,NTLD DO I=1,ILG CFCANROT(I,M,ICANP1)=0. CALVCROT(I,M,ICANP1)=0. CALICROT(I,M,ICANP1)=0. ENDDO ENDDO %id rename_lon # Rename LON to LONP in existing code to avoid conflict with # LON in CTEM code (LAT is ok!). %d msizes.69 INTEGER, PARAMETER :: LONP = $LON$ %d msizes.75 INTEGER, PARAMETER :: NLATJ = MAX(LONP/LONSL,1) %d msizes.83 C * ILG = LONP+1 for sublatitude case %d msizes.119 INTEGER, PARAMETER :: NTASK_P = LONSL*ILAT/LONP %i msizes.158 C C * ctem parameters from base file. C C C LNDCVRMOD ! = 12345 means continuously update land cover C from 1850 to 2100 C ! = 1990 or any other year means use land cover C ! for July of that year all the time. C C LNDCVR_OFFSET ! = offset to add to model year to get calendar C ! year to use for land cover when LNDCVRMOD = 12345 C C INITPOOL ! = -ve means, initialize pools from coupler restart file C ! = +ve means, initialize pools as below even if there are C values in the restart file. C ! = 0 means, initialize pools from zero C ! = 1850 or any other value means initialize pools from that year. C ! Of course, the relevant file must be present. C INTEGER, PARAMETER :: INITPOOL=$INITPOOL$ INTEGER, PARAMETER :: LNDCVRMOD=$LNDCVRMOD$ INTEGER, PARAMETER :: LNDCVR_OFFSET=$LNDCVR_OFFSET$ %d gcm18.363,364 C * LONP = NUMBER OF DISTINCT LONGITUDES. C * LON1 = NUMBER OF LONGITUDES SAVED IN HISTORY FILE, LON1=LONP+1. %d gcm18.3564 IF(LONP.LT.LONSL) CALL XIT('GCM',-27) %d gcm18.3568 IOFF=(J-1)*LONP %d gcm18.3571 IL2=LONP %d core18p.356 CALL IMVRAI2 (UG,VG,PSDLG,PSDPG,COSJ,ILG,LONP,ILEV,A) %d core18p.358 DO 120 I=1,LONP %d core18p.365 4 ILG, LONP, ILEV, %d core18p.849 5 MOIST,DSGJ,DSHJ,ILG,LONP,ILEV,LONSL,WJ,SC(IE(1)) ) %d core18p.853 CALL VRAIMAP(VTG,UTG,ILG,LONP,ILEV,COSJ,A) %id ctem_into_agcm %i compak12.1361 #if defined agcm_river_routing C C * RIVER ROUTING FIELDS PASSED THROUGH RESTART. C * NOTE!!! THESE MAY ULTIMATELY CONVERTED TO "PAK" FIELDS C * AT SOME POINT. C COMMON /GRDFULL/ YGWOGRD(LONSL+1,NLAT) COMMON /GRDFULL/ YGWSGRD(LONSL+1,NLAT) COMMON /GRDFULL/ YSWOGRD(LONSL+1,NLAT) COMMON /GRDFULL/ YSWSGRD(LONSL+1,NLAT) COMMON /GRDFULL/ YSWIGRD(LONSL+1,NLAT) COMMON /GRDFULL/ YDEPGRD(LONSL+1,NLAT) C C * RIVER ROUTING FIELDS SAVED TO HISTORY FILE. C * NOTE!!! THESE MAY ULTIMATELY CONVERTED TO "PAK" FIELDS C * AT SOME POINT. C COMMON /GRDFULL/ RVELGRD(LONSL+1,NLAT) COMMON /GRDFULL/ FOULGRD(LONSL+1,NLAT) C C * RIVER ROUTING FIELDS SAVED TO HISTORY FILE **AND** C * WRITTEN TO COUPLER. C * NOTE!!! THESE MAY ULTIMATELY CONVERTED TO "PAK" FIELDS C * AT SOME POINT. C COMMON /GRDFULL/ RIVOGRD(LONSL+1,NLAT) #endif %i rstarth.4075 #if defined agcm_river_routing CALL GETFLD2(LU,YGWOGRD,NC4TO8("GRID"),KOUNT,NC4TO8("YGWO"), 1 1,IBUF,NGLL,OK) if(.not.ok) then print *, '0no river routing fields in restart, so zeroed out!' ygwogrd=0. ygswgrd=0. yswogrd=0. yswsgrd=0. yswigrd=0. ydepgrd=0. else CALL GETFLD2(LU,YGWSGRD,NC4TO8("GRID"),KOUNT,NC4TO8("YGWS"), 1 1,IBUF,NGLL,OK) CALL GETFLD2(LU,YSWOGRD,NC4TO8("GRID"),KOUNT,NC4TO8("YSWO"), 1 1,IBUF,NGLL,OK) CALL GETFLD2(LU,YSWSGRD,NC4TO8("GRID"),KOUNT,NC4TO8("YSWS"), 1 1,IBUF,NGLL,OK) CALL GETFLD2(LU,YSWIGRD,NC4TO8("GRID"),KOUNT,NC4TO8("YSWI"), 1 1,IBUF,NGLL,OK) CALL GETFLD2(LU,YDEPGRD,NC4TO8("GRID"),KOUNT,NC4TO8("YDEP"), 1 1,IBUF,NGLL,OK) endif ok=.true. #endif %i rstarth.5948 #if defined agcm_river_routing C IF (MYNODE.EQ.0) THEN CALL SETLAB(IBUF,NC4TO8("GRID"),KOUNT,-1,1,LONSL+1,NLAT,10,0) IBUF(3) = NC4TO8("YGWO") CALL PUTFLD2(LU,YGWOGRD,IBUF,IP0F) IBUF(3) = NC4TO8("YGWS") CALL PUTFLD2(LU,YGWSGRD,IBUF,IP0F) IBUF(3) = NC4TO8("YSWO") CALL PUTFLD2(LU,YSWOGRD,IBUF,IP0F) IBUF(3) = NC4TO8("YSWS") CALL PUTFLD2(LU,YSWSGRD,IBUF,IP0F) IBUF(3) = NC4TO8("YSWI") CALL PUTFLD2(LU,YSWIGRD,IBUF,IP0F) IBUF(3) = NC4TO8("YDEP") CALL PUTFLD2(LU,YDEPGRD,IBUF,IP0F) ENDIF #endif %i gcm18.405 #if defined (agcm_ctem) C INTEGER TIMELABEL ! Timestamp to use in output file (YYYYMMDD) #endif #if defined agcm_river_routing C C * DIMENSIONS FOR RIVER ROUTING. C REAL, DIMENSION(LONSL+1,NLAT) :: ROF,ROFO,FLND,FLAK REAL, DIMENSION(LONSL,NLAT) :: 1 SLOPE,WIDTH,LENGTH,DIRECTION,GW_DELAY,GC, 2 LAT1X,LAT2X,LAT3X,LAT4X,LAT5X,LAT6X,LAT7X, 3 LON1X,LON2X,LON3X,LON4X,LON5X,LON6X,LON7X #endif %i gcm18.1088 C #if defined (agcm_ctem) C C * OPEN THE INPUT CTEM RESTART FILE. C LUTS=NEWUNIT(70) OPEN(LUTS,FILE='OLDTS',FORM='UNFORMATTED') C C * OPEN THE CTEM AN FILE. C NUCTEMAN=NEWUNIT(70) OPEN(NUCTEMAN,FILE='CTEM_AN_FILE',FORM='UNFORMATTED') C C * OPEN THE LAND-USE-CHANGE INPUT FILE. C NULUC=NEWUNIT(70) OPEN(NULUC,FILE='LNDCVR18502100',FORM='UNFORMATTED') C C * ASSIGN THE OUTPUT CTEM RESTART FILE UNIT NUMBER, C * FOR "OUTTS", IE "..._ts". C NUTS=NEWUNIT(70) C C * OPEN THE OUTPUT CTEM HISTORY FILE UNIT NUMBER, C * FOR "OUTTM", IE "..._tm". C NUTM=NEWUNIT(70) OPEN(NUTM,FILE='OUTTM',FORM='UNFORMATTED') #endif #if defined agcm_river_routing C C * OPEN THE FILE CONTAINING RIVER-ROUTING TARGET INFO. C NURT=NEWUNIT(80) OPEN(NURT,FILE='TARGET',FORM='UNFORMATTED') #endif %i gcm18.2136 #if defined agcm_river_routing C C * GET THE TARGETTING PARAMETERS USED TO MOVE LAND MOISTURE TO OCEANS. C CALL GETRPARM(NURT,SLOPE,WIDTH,LENGTH,DIRECTION,GW_DELAY, 1 LAT1X,LAT2X,LAT3X,LAT4X,LAT5X,LAT6X,LAT7X, 2 LON1X,LON2X,LON3X,LON4X,LON5X,LON6X,LON7X, 3 GC,LONSL,NLAT) #endif %i gcm18.2309 #if defined (agcm_ctem) C C * HERE ARE THE TIME VARIABLES USED FOR CTEM: C C MONTH ! Extended time month (1, 2, 3 ... 12) C TIMELABEL ! Timestamp to use in restart and output file (YYYYMMDD) C C MAXC=(LONSL+1)*NLAT MONTH=(IYMDH-1000000*IYEAR)/10000 TIMELABEL = IYMDH/100 C C * READ CTEM AN FILE. C CALL GETCTEMAN(NUCTEMAN,PEXFPAK,PFHCPAK,WETFPAK,WETSPAK,LGHTPAK, 1 MONTH,LON1,NLAT,IJPAK,GLL) C C * READ CTEM RESTART. C CALL RESTART_CTEM(+1, LUTS, 1 LCT, LGT, LCTEM, LCTG, LCTEMG, 2 LEV, IBUF, IDAT, TIMELABEL, KHEM, GLL) C C * INITIALIZE CTEM TIMEKEEPING VARIABLES. C LNDCVRYR2 = IYEAR + LNDCVR_OFFSET ! YEAR FOR WHICH WE WANT TO GET THE LAND COVER C CALL CTEM_INIT(NULUC,NEWFPAT,PREFPAT,C_CLIM_TIME, 1 MONTH,IYEAR,IDAY, 2 LNDCVRYR1,LNDCVRYR2,LNDCVRMOD,LNDCVR_OFFSET, 3 LCTEM,ICTEM,NTLD,LON1,NLAT,IJPAK,GLL) #endif %i gcm18.2700 #if defined (agcm_ctem) C C * GET NEW CTEM VEGEGATION FRACTION SET IF HAVE REACHED C * NEW MID-MONTH ON FINAL COUPLING STEP OF DAY. C IF(GMT.EQ.0. .AND. 1 IDAY.EQ.START_DAYS_OF_MONTHS(MONTH)+14 .AND. 2 LNDCVRMOD.EQ.12345) THEN CALL GETCTEMF (NULUC,NEWFPAT,PREFPAT,C_CLIM_TIME, 1 MONTH,IDAY, 2 LNDCVRYR1,LNDCVRYR2, 3 LCTEM,ICTEM,NTLD,LON1,NLAT,IJPAK,GLL) ENDIF #endif %d gcm18.3960,3967 C C * SAVE PREVIOUS VALUE OF "IYMDH" FOR USE IN SAVING C * ACCUMULATED FIELDS AT END OF A DAY IN "YYMMDD24" C * FORMAT IF RUNNING WITH "ISAVDTS". C * THIS IS ALSO USED GENERALLY FOR CTEM OUTPUT AND RESTART DATA. C IYMDHO=IYMDH %i gcm18.4052 #if defined agcm_river_routing C C * GET MODEL WATER BUDGET FIELDS REQUIRED FOR INPUT ON FULL GRID. C CALL CTEM_MPI_PUTFLD(ROF, ROFPAL, LON1,ILAT,NLAT,GLL) CALL CTEM_MPI_PUTFLD(ROFO,ROFOPAL,LON1,ILAT,NLAT,GLL) CALL CTEM_MPI_PUTFLD(FLND,FLNDPAK,LON1,ILAT,NLAT,GLL) c CALL CTEM_MPI_PUTFLD(FLAK,FLAKPAK,LON1,ILAT,NLAT,GLL) C----------------------------------------------------------------------- C * ONLY for testing with NEMO/CICE2 until have included lakes, C * at which time FLAK is obtained instead by line above! C C * open the fractional lake file. only needs to be done once per job! C if(icount.eq.1) then lufl=newunit(70) open(lufl,file='LAKEFILE',form='unformatted') call getfld2(lufl,FLAK,-1,-1,nc4to8("LFRC"),-1,ibuf,ngll,ok) if(.not.ok) then call xit('getlake',-1) endif endif C----------------------------------------------------------------------- C C * River Routing Scheme. C * NOTE: Although LON1 is passed in, calculations only C * go from 1->LONSL, so must add cyclic longitude C * explicitly afterward on output files! C IF(MYNODE.EQ.0) THEN CALL RIVER_ROUTING(RIVOGRD,FOULGRD,RVELGRD, 1 YGWSGRD,YSWSGRD,YSWOGRD, 2 YSWIGRD,YDEPGRD,YGWOGRD, 3 ROF,ROFO,FLND,FLAK, 4 SLOPE,WIDTH,LENGTH,DIRECTION,GW_DELAY, 5 LAT1X,LON1X,LAT2X,LON2X,LAT3X,LON3X, 6 LAT4X,LON4X,LAT5X,LON5X,LAT6X,LON6X, 7 LAT7X,LON7X,GC, 8 DELT,ISBEG,LONSL,LON1,NLAT) C C * Enforce cyclic conditions on river_routing variables. C DO J = 1, NLAT RIVOGRD(LON1,J) = RIVOGRD(1,J) FOULGRD(LON1,J) = FOULGRD(1,J) RVELGRD(LON1,J) = RVELGRD(1,J) YGWOGRD(LON1,J) = YGWOGRD(1,J) YGWSGRD(LON1,J) = YGWSGRD(1,J) YSWOGRD(LON1,J) = YSWOGRD(1,J) YSWSGRD(LON1,J) = YSWSGRD(1,J) YSWIGRD(LON1,J) = YSWIGRD(1,J) YDEPGRD(LON1,J) = YDEPGRD(1,J) END DO C C * Save to model output and zero out. C CALL SETLAB(IBUF,NC4TO8("GRID"),KOUNT,-1,1,LONSL+1,NLAT,10,0) IBUF(3) = NC4TO8("RIVO") CALL PUTFLD2(NUPR,RIVOGRD,IBUF,IP0F) IBUF(3) = NC4TO8("FOUL") CALL PUTFLD2(NUPR,FOULGRD,IBUF,IP0F) IBUF(3) = NC4TO8("RVEL") CALL PUTFLD2(NUPR,RVELGRD,IBUF,IP0F) C FOULGRD=0. RVELGRD=0. ENDIF #endif %d gcm18.4173,4279 #if defined (agcm_ctem) C C * DEFINE TIME LABEL FOR CTEM RESTART AND OUTPUT FILES. C TIMELABEL = IYMDHO/100 C %CALL SAVE_CTEM %i gcm18.4360 C #if defined (agcm_ctem) C C * WRITE OUT CTEM RESTART. C CALL RESTART_CTEM(-1, NUTS, 1 LCT, LGT, LCTEM, LCTG, LCTEMG, 2 LEV, IBUF, IDAT, TIMELABEL, KHEM, GLL) #endif %id fix_fland %d sfcproc2.928,937 IF(FWATROW(IL).EQ.0.) THEN GCPREV(IL)=-1. GCROT(IL,IOWAT)=-999. GCROT(IL,IOSIC)=-999. ELSE IF(SICNROW(IL).EQ.1.) THEN GCPREV(IL)=1. GCROT(IL,IOWAT)=-999. GCROT(IL,IOSIC)=1. ELSE IF(SICNROW(IL).LT.1. .AND. SICNROW(IL).GT.SICN_CRT)THEN GCPREV(IL)=1. GCROT(IL,IOWAT)=0. GCROT(IL,IOSIC)=1. ELSE GCPREV(IL)=0. GCROT(IL,IOWAT)=0. GCROT(IL,IOSIC)=-999. ENDIF ENDIF GCROW(IL)=GCPREV(IL) %d sfcproc2.946 3 GCPREV, GCROW, DSICROW, %d sfcproc2.975 CALL INTGTIO2(GTROT(1,IOWAT), GTROL, GCROT(1,IOWAT), %d sfcproc2.1000 IF(SICNROW(I).GT.SICN_CRT) THEN %d sfcproc2.1020,1049 if(sicnrow(i).gt.sicn_crt .and. sicrow(i).eq.0.) then print *, '0inconsistent sea-ice: i,sicnrow,sicrow = ', 1 i,sicnrow(i),sicrow(i) endif c IF(FLNDROW(I).EQ.0.) THEN DO N=1,NTLD FAREROT(I,N)=0. GCROT (I,N)=-999. GTROT (I,N)=0. SNOROT (I,N)=0. ENDDO ENDIF C IF(FWATROW(I).EQ.0.) THEN GCPREV(I)=-1. FAREROT(I,IOWAT)=0. FAREROT(I,IOSIC)=0. GCROT (I,IOWAT)=-999. GCROT (I,IOSIC)=-999. GTROT (I,IOWAT)=0. GTROT (I,IOSIC)=0. SNOROT(I,IOWAT)=0. SNOROT(I,IOSIC)=0. ELSE IF(SICNPREV(I).LE.SICN_CRT.AND.SICNROW(I).GT.SICN_CRT) THEN GTROT(I,IOSIC)=GTFSW ENDIF C IF(SICNROW(I).EQ.1.) THEN GCPREV(I)=1. FAREROT(I,IOWAT)=0. FAREROT(I,IOSIC)=FWATROW(I) GCROT(I,IOWAT)=-999. GCROT(I,IOSIC)=1. GTROT(I,IOWAT)=GTFSW ELSE IF(SICNROW(I).LT.1. .AND. SICNROW(I).GT.SICN_CRT)THEN GCPREV(I)=1. FAREROT(I,IOWAT)=(1.-SICNROW(I))*FWATROW(I) FAREROT(I,IOSIC)=SICNROW(I)*FWATROW(I) GCROT(I,IOWAT)=0. GCROT(I,IOSIC)=1. ELSE GCPREV(I)=0. FAREROT(I,IOWAT)=FWATROW(I) FAREROT(I,IOSIC)=0. GCROT(I,IOWAT)=0. GCROT(I,IOSIC)=-999. GTROT(I,IOSIC)=GTFSW ENDIF ENDIF GCROW(I)=GCPREV(I) C C * ENSURE SEAICE MASS EXISTS WHEN THERE IS A SEA-ICE FRACTION. C * THIS MIGHT HAVE COME ABOUT DUE TO INCONSISTENT INTERPOLATION C * OF BOUNDARY-LAYER FORCING, FOR SICN LESS THAN THE OLD C * MINIMUM VALUE OF 0.15. C IF(SICNROW(I).GT.0. .AND. SICROW(I).EQ.0.) THEN IF(SICNROW(I).GT.0.15) THEN CALL XIT('SFCPROC2',-54) ELSE SICROW(I)=300.*SICNROW(I) ENDIF ENDIF %d sfcproc2.1866 IF(SICNROW(IWMOS(K)).GT.SICN_CRT) THEN %d sfcproc2.2044 IF(SICNROW(I).GT.SICN_CRT) THEN %d sfcproc2.2057 2 DSICROW, ROF, GCROT(1,IOSIC), PRESROW, %d sfcproc2.2064 9 DELT,ICEFAC,ILG,IL1,IL2 ) %d sfcproc2.2067 C C * IF GCROT(IOSIC) HAS CHANGED, REVISE PROPER GCROT SETTINGS. C IF(GCROT(I,IOSIC).EQ.0.) THEN GCROT(I,IOSIC)=-999. GCROT(I,IOWAT)=0. ENDIF C IF(SICNROW(I).GT.SICN_CRT) THEN %d sfcproc2.2080 IF(GCROT(I,IOSIC).EQ.1. .AND. ZN(I).GT.ZSNMIN) THEN %d sfcproc2.2093 1 RHONROT(1,IOSIC),REFROT(1,IOSIC),GCROT(1,IOSIC), %d sfcproc2.2096 1 REFROT(1,IOSIC),GCROT(1,IOSIC), %d sfcproc2.2098 CALL BCCONC(ZN,GCROT(1,IOSIC),BCSNROT(1,IOSIC),DEPBROW,PCSN, %d sfcproc2.2129,2131 %d sfcproc2.2137,2138 %i sfcproc2.2182 C C * DEFINE DIAGNOSTIC GCROW ACCORDING TO C * MAX SURFACE CONDITION. C DO IL=IL1,IL2 IF(FLNDROW(IL).GE.0.50) THEN GCROW(IL)=-1. ELSE IF(SICNROW(IL).LE.SICN_CRT) THEN GCROW(IL)=0. ELSE GCROW(IL)=1. ENDIF ENDIF ENDDO %id high_freq %i compak12.338 COMMON /PAK/ PCPSPAK(IP0J) %i compak12.342 COMMON /PAK/ PSHFPAK(IP0J) %i comrow12.331 COMMON /ROW/ PCPSROW (ILG) %i comrow12.335 COMMON /ROW/ PSHFROW (ILG) %i zeroacc4.38 CALL PKZEROS2(PSHFPAK,IJPAK, 1) %i zeroacc4.74 CALL PKZEROS2(PCPSPAK,IJPAK, 1) %i unpack10.339 PCPSROW(I) = PCPSPAK(IOFF+I) %i unpack10.343 PSHFROW(I) = PSHFPAK(IOFF+I) %i pack10.347 PCPSPAK(IOFF+I) = PCPSROW(I) %i pack10.350 PSHFPAK(IOFF+I) = PSHFROW(I) %i saveacc6.116 CALL PUTGGB3(PSHFPAK,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("PSHF") 1 ,1,GLL,WRKS) %i saveacc6.118 CALL PKZEROS2(PSHFPAK,IJPAK, 1) %i saveacc6.228 CALL PUTGGB3(PCPSPAK,LON1,ILAT,KHEM,NPGG,K,NUPR,NC4TO8("PCPS") 1 ,1,GLL,WRKS) %i saveacc6.394 CALL PKZEROS2(PCPSPAK,IJPAK, 1) %d physici.1851,1852 PCPROW (I) = PCPROW (I) + PREROW(I)*SAVERAD PCPCROW(I) = PCPCROW(I) + RAINDC(I)*SAVERAD PCPSROW(I) = PCPSROW(I) + RAINSC(I)*SAVERAD %d physici.1867,1868 PCHFROW(I) = PCHFROW(I) + RAINDC(I)*SAVEHF PLHFROW(I) = PLHFROW(I) + RAINLS(I)*SAVEHF PSHFROW(I) = PSHFROW(I) + RAINSC(I)*SAVEHF %id fix_noland_fields %d sfcproc2.2028,2029 %i sfcproc2.2035 C DO K=1,NMW IF(FWATROW(IWMOS(K)).GT.0.) THEN FAREA=FAREROT(IWMOS(K),JWMOS(K))/FWATROW(IWMOS(K)) ELSE FAREA=0. ENDIF VMODSO (IWMOS(K)) = VMODSO (IWMOS(K)) + VMODSOGAT(K)*FAREA ENDDO %id no_wlost %d sfcproc2.564 2 THICEC, THICEG, FROOT, FROOTS, HCPC, HCPG, %d sfcproc2.1284,1285 8 CWLCPS, CWFCPS, RC, RCS, RBCOEF, FROOT, 9 FROOTS, ZPLIMC, ZPLIMG, ZPLMCS, ZPLMGS, ZNGAT, %d sfcproc2.1345 O TRSNOWC, TRSNOWG, ALSNO, FSSBGAT, FROOT, FROOTS, %d sfcproc2.1377,1378 E RAICAN, SNOCAN, RAICNS, SNOCNS, FSVF, FSVFS, F CWLCAP, CWFCAP, CWLCPS, CWFCPS, TCANO, %d sfcproc2.1384 L TCTOPC, TCBOTC, TCTOPG, TCBOTG, FROOT, FROOTS, ### update sub ### #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # Mike's dQns/dT updates #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %id slim_lim2_sensitivity_field %d oiflux11.3 1 CDH, CDM, SLIM, %d oiflux11.70 1 CDH,CDM,SLIM,ST,SU,SV,SQ,SRH,DRAG %i oiflux11.139 SLIM(I)=RHOAIR*CFLUX(I) if (abs(SLIM(I)) > 1e10) then write(6,*)"oiflux11: SLIM=",SLIM(I), 1 " CFLUX=",CFLUX(I)," rhoair=",rhoair endif #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # End Mike's dQns/dT updates #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# #xxx %d ingcm12.122 #xxx C This condition should exist with CanESM4 but not when coupled with NEMO #xxx C ---FIXME--- #xxx C IF (IOCEAN.NE.0 .AND. ISBEG.NE.KSTEPS) CALL XIT('INGCM12',-2) # NOTE!!!!!!!!!!!!!!!! # The following section is to be removed when replaced with lakes updates! # That is, it exists in there! %id lakes %d xtemiss10.225 1 SICNROW(IL).LE.SICN_CRT) THEN # %id river_routing %deck river_routing SUBROUTINE GETRPARM(NFL,SLOPE,WIDTH,LENGTH,DIRECTION,GW_DELAY, 1 LAT1,LAT2,LAT3,LAT4,LAT5,LAT6,LAT7, 2 LON1,LON2,LON3,LON4,LON5,LON6,LON7, 3 LANDMASK,NLON,NLAT) C C======================================================================= C * Aug 20/2016 - M.Lazare. Add in new LANDMASK ("GC") field and C * re-order to fit order within Vivek's C * new file. C * NOV 10/2015 - M.Lazare. Adapted from coupler routine for AGCM: C * - no CPP directives. C * - LON,LAT,MAXX passed in instead of C * PARAMETER statement. C * C * GET THE RIVER ROUTING PARAMETERS FROM THE PARAMETER FILE C * C======================================================================= IMPLICIT none INTEGER NLON INTEGER NLAT INTEGER NFL REAL SLOPE (NLON,NLAT) ! REAL WIDTH (NLON,NLAT) ! REAL LENGTH (NLON,NLAT) ! REAL DIRECTION (NLON,NLAT) ! REAL GW_DELAY (NLON,NLAT) ! REAL LAT1 (NLON,NLAT) ! REAL LAT2 (NLON,NLAT) ! REAL LAT3 (NLON,NLAT) ! REAL LAT4 (NLON,NLAT) ! REAL LAT5 (NLON,NLAT) ! REAL LAT6 (NLON,NLAT) ! REAL LAT7 (NLON,NLAT) ! REAL LON1 (NLON,NLAT) ! REAL LON2 (NLON,NLAT) ! REAL LON3 (NLON,NLAT) ! REAL LON4 (NLON,NLAT) ! REAL LON5 (NLON,NLAT) ! REAL LON6 (NLON,NLAT) ! REAL LON7 (NLON,NLAT) ! REAL LANDMASK (NLON,NLAT) ! INTEGER IBUF,IDAT,MACHINE,INTSIZE,MAXX INTEGER :: nc4to8 LOGICAL OK C COMMON /ICOM/ IBUF(8),IDAT(1) COMMON /MACHTYP/ MACHINE, INTSIZE C----------------------------------------------------------------------- MAXX=( NLON*NLAT + 8 )*MACHINE REWIND NFL CALL GETFLD2(NFL,DIRECTION,-1,-1,nc4to8("DIRE"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-1) ENDIF CALL GETFLD2(NFL,LENGTH, -1,-1,nc4to8("DIST"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-2) ENDIF CALL GETFLD2(NFL,LANDMASK, -1,-1,nc4to8(" GC"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-3) ENDIF CALL GETFLD2(NFL,GW_DELAY, -1,-1,nc4to8(" GW"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-4) ENDIF CALL GETFLD2(NFL,LAT1, -1,-1,nc4to8("LAT1"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-5) ENDIF CALL GETFLD2(NFL,LAT2, -1,-1,nc4to8("LAT2"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-6) ENDIF CALL GETFLD2(NFL,LAT3, -1,-1,nc4to8("LAT3"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-7) ENDIF CALL GETFLD2(NFL,LAT4, -1,-1,nc4to8("LAT4"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-8) ENDIF CALL GETFLD2(NFL,LAT5, -1,-1,nc4to8("LAT5"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-9) ENDIF CALL GETFLD2(NFL,LAT6, -1,-1,nc4to8("LAT6"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-10) ENDIF CALL GETFLD2(NFL,LAT7, -1,-1,nc4to8("LAT7"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-11) ENDIF CALL GETFLD2(NFL,LON1, -1,-1,nc4to8("LNG1"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-12) ENDIF CALL GETFLD2(NFL,LON2, -1,-1,nc4to8("LNG2"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-13) ENDIF CALL GETFLD2(NFL,LON3, -1,-1,nc4to8("LNG3"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-14) ENDIF CALL GETFLD2(NFL,LON4, -1,-1,nc4to8("LNG4"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-15) ENDIF CALL GETFLD2(NFL,LON5, -1,-1,nc4to8("LNG5"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-16) ENDIF CALL GETFLD2(NFL,LON6, -1,-1,nc4to8("LNG6"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-17) ENDIF CALL GETFLD2(NFL,LON7, -1,-1,nc4to8("LNG7"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-18) ENDIF CALL GETFLD2(NFL,SLOPE, -1,-1,nc4to8(" SLP"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-19) ENDIF CALL GETFLD2(NFL,WIDTH, -1,-1,nc4to8("WDTH"),-1,IBUF,MAXX,OK) IF(.NOT.OK) THEN CALL XIT('GETRPARM',-20) ENDIF RETURN END SUBROUTINE RIVER_ROUTING(FOUT,FOUT_LAND,VELOCITY, 1 PREVIOUS_GW_STORE,PREVIOUS_SW_STORE,PREVIOUS_SW_OUTFLOW, 2 PREVIOUS_SW_INFLOW,PREVIOUS_DEPTH,PREVIOUS_GW_OUTFLOW, 3 ROF,ROFO,FLND,FLAK,SLOPE,WIDTH,LENGTH,DIRECTION,GW_DELAY, 4 LAT1,LON1,LAT2,LON2,LAT3,LON3,LAT4,LON4,LAT5,LON5, 5 LAT6,LON6,LAT7,LON7,LANDMASK, 6 DELT,ISBEG,LONSL,LON,LAT) C======================================================================= C C * RIVER ROUTING ALGORITHM - VIVEK ARORA C C * Aug 2/2016 - M. Lazare - LONSL also passed in and used to dimension C all arrays except {ROF,ROFO,FLND,FLAK}. C - All references to "LON-1" (including do-loops) C changed to "LONSL". C - Re-ordering of subroutine statement to C better reflect what is output only, input C only, I/O and internal. C - FLAK used as well as FLND to define what is C ocean fraction (FOCN=1.-FLND-FLAK) and this is now C used instead of "1.-FLND". C - DELT and ISBEG passed in and used to calculate C DTCOUP, which replaces hardcoded 86400. (ie one day). C This is also passed to a new version of C DO_SURFACE_ROUTING. C - "YESTERDAYS" -> "PREVIOUS". C * AUG 2016 - V. ARORA Changes made by Vivek for switch over to CMIP6 C setup with NEMO ocean and new coupler. C Take out all flinging stuff from closed C oceans and lakes. Plus account for fractional C land. This code, therefore, now only routes C runoff to produce routed runoff that is dumped C into grid cells with land fraction less than 0.49. C C This routed runoff called FOUT is what will needed C to be passed to the coupler. C C * NOV 10/2015 - M.Lazare. Adapted from coupler routine for AGCM: C * - no CPP directives. C * - LON,LAT,MAXX passed in instead of C * PARAMETER statement. C C * 19/07/00 DY.Robitaille/V.Arora C Modified Great Lakes/St. Lawrence River code C Solved previous/current time step variable mix-up bug C C * S.Tinis C Modified for CGCM3 use C C * INPUT ROF TOTAL RUNOFF IN KG/M^2/S OVER LAND C * INPUT ROFO - OVERLAND RUNOFF IN KG/M^2/S C * INPUT FLND - FRACTION OF LAND IN EACH GRID CELL C * INPUT FLAK - FRACTION OF INLAND LAKE FRACTION C * OUTPUT FOUT FLUX IN KGM/M^2/S, AT THE MOUTH OF RIVERS ALL ALONG C * THE CONTINENTAL EDGES AND OVER INLAND WATER BODIES. C C * FOUT_LAND - OUTPUT FLUX IN M^3/S OVER LAND, USING THIS WE C * CAN SEE WHAT DOES THE RIVER DISCHARGE LOOKS LIKE AT ANY POINT WITHIN C * A RIVER BASIN, AS WELL AS FIND THE OUTFLOW INTO THE OCEAN CELLS C * ALONG THE CONTINENTAL EDGES, BUT FOUT_LAND CANNOT BE USED TO FIND C * FRESH WATER FLUX (P-E) OVER OCEAN CELLS. THUS THIS QUANTITY IS C * ESSENTIALLY FOR DIAGNOSTICS. THE ACTUAL FRESHWATER FLUX WHICH C * AFFECTS SALINITY IS GIVEN BY FOUT C C * DETAILS OF RIVER ROUTING PARAMETERS C C * SLOPE - THE SLOPE BETWEEN THE GRID CELLS FOUND USING THE MEAN C * ELEVATIONS C C * WIDTH - WIDTH OF THE RIVER ALONG THE VARIOUS SECTIONS OF THE C * DIGITAL RIVER NETWORK AT THE GCM RESOLUTION PARAMETERIZED C * USING A WIDTH-MEAN ANNUAL DISCHARGE RELATIONSHIP C C * LENGTH - DISTANCE BETWEEN THE UPSTREAM AND DOWNSTREAM CELL IN KM. C C * DIRECTION - DIRECTION OF RIVER FLOW C * 1 - NORTH, 2 - NE, 3 - EAST, 4 - SE, C * 5 - SOUTH, 6 - SW, 7 - WEST, 8 - NW C * 0 - INTERNALLY DRAINED CELL C * 9 - INTERNALLY DRAINED RIVER MOUTH C C * GW_DELAY - GROUND WATER DELAY FACTOR FOR THE GCM CELL, FUNCTION C * OF MAJOR SOIL TYPE IN THE GRID CELL C C * LAT1, LON1 - LATITUDE AND LONGITUDE OF NEIGHBOURING CELL WHICH C * DRAINS ITS WATER INTO THE GIVEN GCM CELL C * THERE ARE UPTO 7 NEIGHBOURING UPSTREAM CELLS AT 96X48 C * RESOLUTION, THAT IS WHY WE GO UPTO LAT7 & LON7 C C * LANDMASK - GROUND COVER EXTRACTED FROM MY ROUTING PARAMETER FILE, BASED C * ON WHICH ROUTING IS PERFORMED. THIS IS DIFFERENT FROM ANY GC C * IN THE AGCM AND BASED ON 0.49 FRACTIONAL LAND THRESHOLD. C * ALL GRID CELLS WITH LESS THAN 49% LAND ARE DEEMED WATER/OCEAN C * AS FAR AS RIVER ROUTING IS CONCERNED. C C======================================================================= IMPLICIT NONE INTEGER ISBEG, LONSL, LON, LAT C C * OUTPUT. C REAL FOUT (LON,LAT) REAL FOUT_LAND (LON,LAT) REAL VELOCITY (LON,LAT) C C * INPUT/OUTPUT. C REAL PREVIOUS_SW_INFLOW (LON,LAT) REAL PREVIOUS_DEPTH (LON,LAT) REAL PREVIOUS_SW_STORE (LON,LAT) REAL PREVIOUS_SW_OUTFLOW (LON,LAT) REAL PREVIOUS_GW_OUTFLOW (LON,LAT) REAL PREVIOUS_GW_STORE (LON,LAT) C C * INPUT. C REAL ROF (LON,LAT) REAL ROFO (LON,LAT) REAL FLND (LON,LAT) REAL FLAK (LON,LAT) REAL SLOPE (LONSL,LAT) REAL WIDTH (LONSL,LAT) REAL LENGTH (LONSL,LAT) REAL DIRECTION (LONSL,LAT) REAL GW_DELAY (LONSL,LAT) REAL LANDMASK (LONSL,LAT) REAL LAT1 (LONSL,LAT) REAL LAT2 (LONSL,LAT) REAL LAT3 (LONSL,LAT) REAL LAT4 (LONSL,LAT) REAL LAT5 (LONSL,LAT) REAL LAT6 (LONSL,LAT) REAL LAT7 (LONSL,LAT) REAL LON1 (LONSL,LAT) REAL LON2 (LONSL,LAT) REAL LON3 (LONSL,LAT) REAL LON4 (LONSL,LAT) REAL LON5 (LONSL,LAT) REAL LON6 (LONSL,LAT) REAL LON7 (LONSL,LAT) C C * INTERNAL. C REAL GCM_CELL_AREA (LONSL,LAT) REAL PERCOLATION (LONSL,LAT) REAL SURFACE_RUNOFF (LONSL,LAT) REAL NEIGHBOUR_INFLOW(LONSL,LAT) REAL SW_INFLOW (LONSL,LAT) REAL DEPTH (LONSL,LAT) REAL SW_STORE (LONSL,LAT) REAL SW_OUTFLOW (LONSL,LAT) REAL GW_OUTFLOW (LONSL,LAT) REAL GW_STORE (LONSL,LAT) REAL GW_INFLOW (LONSL,LAT) INTEGER NEIGHBOUR_LAT(7,LONSL,LAT) INTEGER NEIGHBOUR_LON(7,LONSL,LAT) REAL*8 PI REAL*8 WL(LAT),RADL(LAT), WOSSL(LAT) REAL*8 SL(LAT) REAL*8 CL(LAT) REAL*8 ML(LONSL) REAL EARTH_RADIUS REAL CC REAL DELT REAL PREV_DEPTH REAL PREV_GOING_IN REAL CUR_SLOPE REAL CUR_DISTANCE REAL CUR_WIDTH REAL VEL REAL CUR_DEPTH REAL GOING_IN REAL COMING_OUT REAL FOCN REAL DTCOUP REAL FWATER INTEGER LATH,I,J,DIR,N,N_LAT,N_LON INTEGER NWDMAX PARAMETER(NWDMAX=18528) PARAMETER(PI=3.1415926535898d0) PARAMETER(EARTH_RADIUS=6371.22) !KM C----------------------------------------------------------------------- C CALCULATE COUPLING TIME FREQUENCY IN SECONDS DTCOUP=DELT*REAL(ISBEG) C FIRST, INITIALIZE VELOCITY, FOUT AND FOUT_LAND TO ZERO DO J = 1,LAT DO I = 1,LONSL FOUT (I,J)=0.0 FOUT_LAND(I,J)=0.0 VELOCITY (I,J)=0.0 ENDDO ENDDO C GET THE GAUSSIAN WEIGHTS INTO WL SO THAT WE CAN FIND THE C AREAS OF THE GCM CELLS, WE NEED THESE AREAS BECAUSE THE ROUTING C ALGORITHM FINDS DISCHARGE IN M^3/S WHICH WE WILL LATER CONVERT TO C KG/M^2/S LATH = LAT/2 CALL GAUSSG(LATH,SL,WL,CL,RADL,WOSSL) CALL TRIGL(LATH,SL,WL,CL,RADL,WOSSL) C WL CONTAINS ZONAL WEIGHTS, LETS FIND MERIDIONAL WEIGHTS DO I = 1,LONSL ML(I) = 1.0/(REAL(LONSL)) ENDDO C FIND THE AREAS OF GCM CELLS IN KM^2 DO J = 1,LAT DO I = 1,LONSL GCM_CELL_AREA(I,J) = 4*PI*(EARTH_RADIUS**2)*WL(J)*ML(I)/2.0 C DIVIDING BY 2.0 BECAUSE WL(1 TO LAT) ADD TO 2.0 NOT 1.0 ENDDO ENDDO C OKAY NOW WE KNOW THE AREA OF GCM CELLS C ARRANGE LATS AND LONS OF NEIGHBOURING CELLS IN AN ARRAY DO J = 1,LAT DO I = 1,LONSL NEIGHBOUR_LAT(1,I,J)=NINT(LAT1(I,J)) NEIGHBOUR_LAT(2,I,J)=NINT(LAT2(I,J)) NEIGHBOUR_LAT(3,I,J)=NINT(LAT3(I,J)) NEIGHBOUR_LAT(4,I,J)=NINT(LAT4(I,J)) NEIGHBOUR_LAT(5,I,J)=NINT(LAT5(I,J)) NEIGHBOUR_LAT(6,I,J)=NINT(LAT6(I,J)) NEIGHBOUR_LAT(7,I,J)=NINT(LAT7(I,J)) NEIGHBOUR_LON(1,I,J)=NINT(LON1(I,J)) NEIGHBOUR_LON(2,I,J)=NINT(LON2(I,J)) NEIGHBOUR_LON(3,I,J)=NINT(LON3(I,J)) NEIGHBOUR_LON(4,I,J)=NINT(LON4(I,J)) NEIGHBOUR_LON(5,I,J)=NINT(LON5(I,J)) NEIGHBOUR_LON(6,I,J)=NINT(LON6(I,J)) NEIGHBOUR_LON(7,I,J)=NINT(LON7(I,J)) ENDDO ENDDO C THE LAND SURFACE SCHEME SAVES ROF - TOTAL RUNOFF AND ROFO - THE C OVERLAND RUNOFF. SO WE HAVE TO FIND DEEP SOIL PERCOLATION/BASE FLOW C OURSELVES FOR LAND CELLS ONLY DO J = 1,LAT DO I = 1,LONSL IF(LANDMASK(I,J).LT.-0.5)THEN PERCOLATION(I,J) = ROF(I,J) - ROFO(I,J) IF(PERCOLATION(I,J).LT.0.0)THEN PERCOLATION(I,J) = 0.0 ENDIF C TO DEAL WITH GREAT LAKES, AND ANY LARGE LAKES FOR THAT MATTER, C WHICH AFFECT RIVER FLOW WE NEED A SIMPLE MECHANISM TO INCREASE C THE RESIDENCE TIME OF WATER. E.G. THE RESIDENCE TIME OF WATER IN C LAKE SUPERIOR (THE LARGEST GREAT LAKE IS ~200 YRS) AND IN LAKE C ERIE IS AROUND 2-3 YRS. RESIDENCE TIME IN INLAND LAKES DEPENDS C ON LAKE VOLUME (WHICH, OF COURSE, DEPENDS ON LAKE DEPTH AND AREA). C WE DO HAVE LAKE DEPTH, BUT AREA IS TRICKY BECAUSE A LAKE MAYBE SPREAD C ACROSS MULTIPLE GRID CELLS. C C SO FOR NOW WE JUST ASSUME IF LAKE FRACTION IS GREATER THAN SOME C THRESHOLD THEN WE INCREASE THE GW_DELAY TO SOME RELATIVELY LARGER C NUMBER THAN OUR MAX. VALUE OF 60 DAYS C IF (FLAK(I,J) .GT. 0.4) THEN GW_DELAY(I,J)=300.0 ENDIF ENDIF ENDDO ENDDO C DO THE ROUTING BIT CELL BY CELL FOR EACH LAND CELL C & ADD P-E FOR OCEAN CELLS DO J = 1,LAT DO I = 1,LONSL C Set the temporary variables to zero before each new grid point calculations C PREV_DEPTH = 0. PREV_GOING_IN = 0. CUR_SLOPE = 0. CUR_DISTANCE = 0. CUR_WIDTH = 0. VEL = 0. CUR_DEPTH = 0. GOING_IN = 0. COMING_OUT = 0. IF(LANDMASK(I,J).LT.-0.5)THEN !DO ROUTING CALCULATION FOR LAND CELLS C !THIS MASK COMES FROM RIVER PARAMETERS FILE C !AND IS BASED ON FRACTIONAL LAND THRESHOLD C !OF 0.49 THAT VIVEK USED. DIR = NINT(DIRECTION(I,J)) IF(DIR.GE.1.AND.DIR.LE.8)THEN ! Ordinary land grid cells C CONVERT KG/M^2/S INTO M^3/S; THE CONVERSION FORMULA IS: C FLOW(M^3/S) = FLUX(KG/M^2/S)*AREA(KM^2)*10^6(M^2/KM^2)/DENSITY(=1000 KG/M^3) C * FLND SURFACE_RUNOFF(I,J) = ROFO(I,J)*FLND(I,J)* / GCM_CELL_AREA(I,J)*1000.0 GW_INFLOW(I,J)=PERCOLATION(I,J)*FLND(I,J)* / GCM_CELL_AREA(I,J)*1000.0 C SO FAR WE KNOW WHAT IS THE SURFACE RUNOFF AND GW_INFLOW, NOW WE C FIND THE INFLOW FROM NEIGHBOURING CELLS, WHICH COULD EVEN BE A LITTLE C FAR LOCATED INTERNALLY DRAINED CELLS NEIGHBOUR_INFLOW(I,J) = 0.0 DO N = 1,7 N_LAT = NEIGHBOUR_LAT(N,I,J) N_LON = NEIGHBOUR_LON(N,I,J) IF(N_LAT.NE.0.AND.N_LON.NE.0)THEN NEIGHBOUR_INFLOW(I,J)=NEIGHBOUR_INFLOW(I,J)+ / PREVIOUS_SW_OUTFLOW(N_LON,N_LAT) ENDIF ENDDO C FIND THE GW FACTOR USING THE GW DELAY FACTOR IF(GW_DELAY(I,J).EQ.0.0)CALL XIT('RIVER_ROUTING',-1) CC = EXP(-1.0/GW_DELAY(I,J)) C FIND THE GW OUTFLOW AND UPDATE THE GW STORE GW_OUTFLOW(I,J)=CC*PREVIOUS_GW_OUTFLOW(I,J)+ / (1.0-CC)*GW_INFLOW(I,J) GW_STORE(I,J)=PREVIOUS_GW_STORE(I,J)+GW_INFLOW(I,J)*DTCOUP / -GW_OUTFLOW(I,J)*DTCOUP C CHECK IF GW STORE GOES BELOW ZERO AND CORRECT ACCORDINGLY IF(GW_STORE(I,J).LT.0.0)THEN IF(PREVIOUS_GW_STORE(I,J).GT.0.0)THEN GW_OUTFLOW(I,J)=PREVIOUS_GW_STORE(I,J)/DTCOUP+ / GW_INFLOW(I,J)-0.05 IF(GW_OUTFLOW(I,J).LT.0.0)GW_OUTFLOW(I,J)=0.0 GW_STORE(I,J)=PREVIOUS_GW_STORE(I,J)+ / GW_INFLOW(I,J)*DTCOUP - GW_OUTFLOW(I,J)*DTCOUP ENDIF ENDIF C NOW WE ARE READY TO ROUTE THE WATER THRU THE RIVER CHANNEL C SO WE FIND WHAT GOES INTO THE RIVER CHANNEL SW_INFLOW(I,J) = SURFACE_RUNOFF(I,J) + GW_OUTFLOW(I,J) + / NEIGHBOUR_INFLOW(I,J) C PREPARE TO CALL THE SURFACE ROUTING SUBROUTINE GOING_IN = SW_INFLOW(I,J) PREV_GOING_IN = PREVIOUS_SW_INFLOW(I,J) PREV_DEPTH = PREVIOUS_DEPTH(I,J) CUR_SLOPE = SLOPE(I,J) CUR_DISTANCE = LENGTH(I,J)*1000. ! Conversion from Km to m CUR_WIDTH = WIDTH(I,J) C CHECK FOR -VE INFLOW IF(GOING_IN.LT.0.0)THEN WRITE(*,*)'FOR CELL (LONG,LAT) [',I,',',J,']' WRITE(*,*)'-VE FLOW GOING IN FOR SURFACE ROUTING = ',GOING_IN WRITE(*,*)'SURFACE RUNOFF = ',SURFACE_RUNOFF(I,J) WRITE(*,*)'GW_OUTFLOW = ',GW_OUTFLOW(I,J) WRITE(*,*)'NEIGHBOUR_INFLOW = ',NEIGHBOUR_INFLOW(I,J) CALL XIT('RIVER_ROUTING',-2) ENDIF C CALL THE SURFACE ROUTING SUBROUTINE CALL DO_SURFACE_ROUTING(GOING_IN,COMING_OUT,PREV_DEPTH, / CUR_SLOPE,CUR_DISTANCE,PREV_GOING_IN,CUR_DEPTH,VEL, / CUR_WIDTH,DTCOUP) C CHECK FOR -VE OUTFLOW IF(COMING_OUT.LT.0.0)THEN WRITE(*,*)'FOR CELL (LONG,LAT) [',I,',',J,']' WRITE(*,*)'-VE FLOW COMING OUT OF SURFACE ROUTING = ' / ,COMING_OUT WRITE(*,*)'COMING OUT= ',COMING_OUT CALL XIT('RIVER_ROUTING',-3) ENDIF SW_OUTFLOW(I,J) = COMING_OUT SW_STORE(I,J) = PREVIOUS_SW_STORE(I,J)+ / (SW_INFLOW(I,J)-SW_OUTFLOW(I,J))*DTCOUP C CHECK IF SW STORE GOES BELOW ZERO, CORRECT SW_OUTFLOW C AND ADJUST THE FLOW DEPTH ACCORDINGLY IF(SW_STORE(I,J).LT.0.0)THEN IF(PREVIOUS_SW_STORE(I,J).GT.0.0)THEN SW_OUTFLOW(I,J)=PREVIOUS_SW_STORE(I,J)/DTCOUP+ / SW_INFLOW(I,J)-0.1 IF(SW_OUTFLOW(I,J).LT.0.0)THEN SW_OUTFLOW(I,J)=0.0 ENDIF SW_STORE(I,J)=PREVIOUS_SW_STORE(I,J)+ / SW_INFLOW(I,J)*DTCOUP - SW_OUTFLOW(I,J)*DTCOUP C ALSO ADJUST THE FLOW DEPTH TO MATCH THE CORRECTED OUTFLOW C 0.040 IN THE EQN. BELOW IS MANNING N CUR_DEPTH = ((SW_OUTFLOW(I,J)*0.040)/ / (WIDTH(I,J)*SLOPE(I,J)**0.5))**(3./5.) C SAVE THE NEW VELOCITY AS WELL VEL=(1./0.040)*((CUR_DEPTH)**(2./3.))*(SLOPE(I,J)**0.5) ENDIF ENDIF VELOCITY(I,J) = VEL DEPTH(I,J) = CUR_DEPTH FOUT_LAND(I,J) = SW_OUTFLOW(I,J) ENDIF ! IF DIR is between 1 and 8 ie ordinary cells IF(DIR.EQ.0)THEN ! IF internally drained cells C IF INTERNALLY DRAINED CELL THEN EVERYTHING GOES INTO THE C GROUNDWATER STORE WHICH HAS A TIME DELAY OF 100 DAYS GW_INFLOW(I,J) = ROF(I,J)*FLND(I,J)* / GCM_CELL_AREA(I,J)*1000.0 NEIGHBOUR_INFLOW(I,J) = 0.0 DO N = 1,7 N_LAT = NEIGHBOUR_LAT(N,I,J) N_LON = NEIGHBOUR_LON(N,I,J) IF(N_LAT.NE.0.AND.N_LON.NE.0)THEN NEIGHBOUR_INFLOW(I,J)=NEIGHBOUR_INFLOW(I,J)+ / PREVIOUS_SW_OUTFLOW(N_LON,N_LAT) ENDIF ENDDO C ADD NEIGHBOUR INFLOW TO GW INFLOW AS WELL AND C FIND THE GW OUTFLOW AND UPDATE THE GW STORE GW_INFLOW(I,J) = GW_INFLOW(I,J) + NEIGHBOUR_INFLOW(I,J) C FIND THE GW OUTFLOW AND UPDATE THE GW STORE CC = EXP(-1./100.) GW_OUTFLOW(I,J)=CC*PREVIOUS_GW_OUTFLOW(I,J)+ / (1.0-CC)*GW_INFLOW(I,J) GW_STORE(I,J)=PREVIOUS_GW_STORE(I,J)+GW_INFLOW(I,J)*DTCOUP / -GW_OUTFLOW(I,J)*DTCOUP C CHECK IF GW STORE GOES BELOW ZERO AND CORRECT ACCORDINGLY IF(GW_STORE(I,J).LT.0.0)THEN IF(PREVIOUS_GW_STORE(I,J).GT.0.0)THEN GW_OUTFLOW(I,J)=PREVIOUS_GW_STORE(I,J)/DTCOUP+ / GW_INFLOW(I,J)-0.05 IF(GW_OUTFLOW(I,J).LT.0.0)GW_OUTFLOW(I,J)=0.0 GW_STORE(I,J)=PREVIOUS_GW_STORE(I,J)+ / GW_INFLOW(I,J)*DTCOUP - GW_OUTFLOW(I,J)*DTCOUP ENDIF ENDIF C AND THUS SURFACE WATER OUTFLOW FOR A INTERNALLY DRAINED CELL IS C NOTHING BUT ITS GW OUTFLOW AND THIS WILL BE MOVED TO NEAREST C OCEAN CELL OR NEAREST RIVER BASIN AS BASEFLOW. AND WHERE DOES C THIS IS TAKEN ACCOUNT OF - ITS TAKEN ACCOUNT OF IN NEIGHBOURS SW_OUTFLOW(I,J) = GW_OUTFLOW(I,J) FOUT_LAND(I,J) = SW_OUTFLOW(I,J) ENDIF ! IF DIR is 0 ie internally drained cells IF(DIR.EQ.9)THEN ! Internally drained river mouth C NOW WE DEAL WITH INTERNALLY DRAINED RIVER MOUTHS, THESE CELLS C GET WATER FROM NEIGHBOURING CELLS AND THERE OWN SURFACE RUNOFF + C DEEP SOIL PERCOLATION BUT EVERYTHING ENDS UP IN THE GW STORE GW_INFLOW(I,J) = ROF(I,J)*FLND(I,J)* / GCM_CELL_AREA(I,J)*1000.0 NEIGHBOUR_INFLOW(I,J) = 0.0 DO N = 1,7 N_LAT = NEIGHBOUR_LAT(N,I,J) N_LON = NEIGHBOUR_LON(N,I,J) IF(N_LAT.NE.0.AND.N_LON.NE.0)THEN NEIGHBOUR_INFLOW(I,J)=NEIGHBOUR_INFLOW(I,J)+ / PREVIOUS_SW_OUTFLOW(N_LON,N_LAT) ENDIF ENDDO C ADD NEIGHBOUR INFLOW TO GW INFLOW AS WELL AND C FIND THE GW OUTFLOW AND UPDATE THE GW STORE GW_INFLOW(I,J) = GW_INFLOW(I,J) + NEIGHBOUR_INFLOW(I,J) CC = EXP(-1./100.) GW_OUTFLOW(I,J)=CC*PREVIOUS_GW_OUTFLOW(I,J)+ / (1.0-CC)*GW_INFLOW(I,J) GW_STORE(I,J)=PREVIOUS_GW_STORE(I,J)+GW_INFLOW(I,J)*DTCOUP / -GW_OUTFLOW(I,J)*DTCOUP SW_OUTFLOW(I,J) = GW_OUTFLOW(I,J) FOUT_LAND(I,J) = SW_OUTFLOW(I,J) ENDIF ! IF DIR is 11 ie internally drained river mouths ELSE IF(LANDMASK(I,J).GT.-0.5)THEN !Take care of freshwater flux into the oceans C !THESE ARE GRID CELLS WITH LESS THAN 0.49 LAND C !FRACTION USED BY VIVEK TO FIND RIVER PARAMETERS. C C THESE GRID CELLS RECEIVE FRESHWASTER FROM ROUTED RUNOFF AT THE CONTINENTAL C EDGES, PLUS THEIR OWN ROF WITHOUT ANY ROUTING. E.G IF ONE OF THE HAWAIIAN C ISLANDS COVERS 0.48 FRACTION OF A GRID CELL, IT'S RUNOFF CONTRIBUTES TO FRESHWATER C TO THE OCEAN IN THE SAME GRID CELL. C THESE CELLS MAY ALSO RECEIVE ROUTED RUNOFF FROM FROM NEARBY C INTERNALLY DRAINED CELLS AND INTERNALLY DRAINED RIVER MOUTHS. C NOTE THAT WHEN ROUTED RUNOFF (M3/S) IS MOVED TO AN OCEAN CELL C IT NEEDS TO BE CONVERTED TO KG/(M^2.S) BY DIVISION WITH AGCM GRID CELL C AREA INTO WHICH THIS ROUTED RUNOFF IS BEING DUMPED. NEIGHBOUR_INFLOW(I,J) = 0.0 DO N = 1,7 N_LAT = NEIGHBOUR_LAT(N,I,J) N_LON = NEIGHBOUR_LON(N,I,J) IF(N_LAT.NE.0.AND.N_LON.NE.0)THEN NEIGHBOUR_INFLOW(I,J)=NEIGHBOUR_INFLOW(I,J)+ / PREVIOUS_SW_OUTFLOW(N_LON,N_LAT) ENDIF ENDDO C THIS TAKES CARE OF EVERYTHING THAT DRAINS INTO THE GIVEN OCEAN C CELL, NOW CONVERT THIS INTO KG/M^2/S BY DIVIDING BY THE GCM CELL C AREA, AND THIS IS WHAT THE AGCM GRID CELL FINALLY NEEDS. C NOTE THAT THIS WATER NEEDS TO BE SPREAD OVER THE WATER AREA C SO WE NEED TO MULTIPLY WITH (1-FLND-FLAK) C THE LOGIC IS THAT WE TRY TO SPREAD THE ROUTED WATER AND ANY C RUNOFF FROM THE SAME GRID CELL OVER THE OCN FRACTION. IN THE C EVENT THERE IS NO OCEAN IN THIS GRID CELL WE SPREAD THE WATER C OVER THE FLAK FRACTION. FOCN = MAX(0.,MIN(1.0-FLND(I,J)-FLAK(I,J),1.)) IF(FOCN.LT.1E-05)THEN ! NO OCEAN IN THIS GRID CELL C ! SPREAD ROUTED RUNOFF OVER FLAK IF(FLAK(I,J).GT.1E-5)THEN FWATER=FLAK(I,J) ELSE WRITE(*,*)'FOCN(',I,',',J,')=',FOCN WRITE(*,*)'FLAK(',I,',',J,')=',FLAK(I,J) WRITE(*,*)'FLND(',I,',',J,')=',FLND(I,J) WRITE(*,*)'WEIRD GRID CELL WITH LAND LIKELY LESS THAN' WRITE(*,*)'0.49 FRACTION, AND VERY LITTLE FOCN AND' WRITE(*,*)'FLAK.' WRITE(*,*)'AN INDICATION THAT RIVER PARAMETERS FILE' WRITE(*,*)'IS INCONSISTENT WITH FRACTIONAL LAND MASK' CALL XIT('RIVER_ROUTING',-4) ENDIF ELSE FWATER=FOCN ENDIF NEIGHBOUR_INFLOW(I,J) = NEIGHBOUR_INFLOW(I,J)/ / (GCM_CELL_AREA(I,J)*1000.0*FWATER) C ALSO ADD THIS GRID CELL'S OWN RUNOFF WITHOUT ANY ROUTING FOUT(I,J) = NEIGHBOUR_INFLOW(I,J) + ROF(I,J)* / FLND(I,J)/FWATER ENDIF ! This is IF LANDMASK = -1.0 or 0.0 loop ENDDO ! This is the DO I = 1,LONSL loop ENDDO ! This is the DO J = 1,LAT loop C NOW WE UPDATE ALL PREVIOUS STORES AND FLOWS DO J = 1,LAT DO I = 1,LONSL IF(LANDMASK(I,J).LT.-0.5)THEN !FOR LAND CELLS DIR = NINT(DIRECTION(I,J)) IF(DIR.GE.1.AND.DIR.LE.8)THEN ! Ordinary land grid cells PREVIOUS_GW_OUTFLOW(I,J) = GW_OUTFLOW(I,J) PREVIOUS_GW_STORE(I,J) = GW_STORE(I,J) PREVIOUS_SW_STORE(I,J) = SW_STORE(I,J) PREVIOUS_SW_OUTFLOW(I,J) = SW_OUTFLOW(I,J) PREVIOUS_SW_INFLOW(I,J) = SW_INFLOW(I,J) PREVIOUS_DEPTH(I,J) = DEPTH(I,J) ENDIF ! Ordinary land grid cells IF(DIR.EQ.0)THEN ! IF internally drained cells PREVIOUS_GW_OUTFLOW(I,J) = GW_OUTFLOW(I,J) PREVIOUS_GW_STORE(I,J) = GW_STORE(I,J) PREVIOUS_SW_OUTFLOW(I,J) = SW_OUTFLOW(I,J) ENDIF ! IF DIR is 0 ie internally drained cells IF(DIR.EQ.9)THEN ! Internally drained river mouth PREVIOUS_GW_OUTFLOW(I,J) = GW_OUTFLOW(I,J) PREVIOUS_GW_STORE(I,J) = GW_STORE(I,J) PREVIOUS_SW_OUTFLOW(I,J) = SW_OUTFLOW(I,J) ENDIF ! IF DIR is 11 ie internally drained river mouths ENDIF !IF LAND ENDDO ! This is the DO I = 1,LONSL loop ENDDO ! This is the DO J = 1,LAT loop RETURN END SUBROUTINE DO_SURFACE_ROUTING(GOING_IN,COMING_OUT,PREVIOUS_DEPTH, 1 CUR_SLOPE,CUR_DISTANCE,PREVIOUS_GOING_IN,CUR_DEPTH, 2 VEL,CUR_WIDTH,DTCOUP) C======================================================================= C * Aug 27/2016 - M.Lazare. Coupler code modified for use in AGCM: C * - no CPP diretives. C * - pass in DTCOUP and use instead of C * hardcoded 86400. C * - replace "NO_OF_STEPS_IN_A_DAY" by C * "NSTEPS". C======================================================================= IMPLICIT NONE REAL GOING_IN REAL COMING_OUT REAL PREVIOUS_DEPTH REAL CUR_SLOPE REAL CUR_DISTANCE REAL PREVIOUS_GOING_IN REAL CUR_DEPTH REAL VEL REAL CUR_WIDTH REAL DTCOUP REAL WIDTH REAL MANNINGSN REAL TIME_STEP REAL MULTIPLIER REAL INFLOW(55) REAL DEPTH(55) REAL D1 REAL D2 REAL RHS REAL RHS2 INTEGER NSTEPS INTEGER N WIDTH = CUR_WIDTH IF(WIDTH.LT.10.0)WIDTH=10.0 MANNINGSN = 0.040 CUR_SLOPE = CUR_SLOPE C TAKE INTO ACCOUNT THE MEANDERING OF THE RIVER CHANNEL CUR_DISTANCE = CUR_DISTANCE *1.40 C FOR STABLE SOLUTION OF THE FORWARD DIFF. EXPLICIT EQN. C DELTAT/(DISTANCE.WIDTH) MUST BE LESS THAN ABOUT 0.0004 (I FOUND THIS) C AND THEREFORE WE CAN USE THIS TO DETERMINE THE TIME STEPS WE C WILL USE OVER A PERIOD OF A DAY TIME_STEP = 0.0004*CUR_DISTANCE*WIDTH NSTEPS = NINT(DTCOUP/TIME_STEP) + 1 C HOWEVER, JUST TO BE ON THE SAFER SIDE LETS FIX THE NSTEPS C TO A MINIMUM OF 10 IF(NSTEPS.LT.10)NSTEPS=10 C BUT DO NOT LET THE NSTEPS INCREASE BEYOND 50 IF(NSTEPS.GT.50)NSTEPS = 50 TIME_STEP = DTCOUP/REAL(NSTEPS) MULTIPLIER = TIME_STEP/(CUR_DISTANCE*WIDTH) C INTERPOLATE INFLOW FOR ALL TIME STEPS BETWEEN GOING_IN AND C PREVIOUS_GOING_IN. IF WE HAVE 5 TIME STEPS IN A COUPLING FREQUENCY, THAT C MEANS WE NEED TO INTERPOLATE 4 VALUES IN BETWEEN PREVIOUS_GOING_IN AND C GOING_IN INFLOW(1) = PREVIOUS_GOING_IN INFLOW(NSTEPS+1) = GOING_IN DO N = 2,NSTEPS INFLOW(N) = ((GOING_IN-PREVIOUS_GOING_IN)*((N-1.)/ / NSTEPS))+PREVIOUS_GOING_IN ENDDO C NOW WE GO THRU ALL THE TIME STEPS AND FIND THE DEPTH C OF FLOW AT NSTEPS+1 TIME STEP, WHICH IS THE C DEPTH WE WILL USE TO FIND OUTFLOW DEPTH(1) = PREVIOUS_DEPTH DO N = 2,(NSTEPS+1) D1 = DEPTH(N-1) IF (D1 .LT. 1.E-20) D1 = 0. RHS2 = ((WIDTH**(5./3.))*(D1**(5./3.))* / (CUR_SLOPE**(0.5)))/(MANNINGSN*((WIDTH+2*D1)**(2./3.))) RHS = MULTIPLIER*(INFLOW(N-1)-RHS2) DEPTH(N) = DEPTH(N-1) + RHS IF (DEPTH(N).LT.0.0)THEN WRITE(*,*)' -VE FLOW DEPTH' CALL XIT('DO_SURFACE_ROUTING',-1) ENDIF ENDDO C NOW WE USE THE FINAL DEPTH TO FIND OUTFLOW D2 = DEPTH(NSTEPS+1) CUR_DEPTH = D2 VEL = (1/MANNINGSN)*(CUR_SLOPE**0.5)* / (((WIDTH*D2)/(WIDTH+2*D2))**(2./3.)) COMING_OUT = VEL*(WIDTH*D2) C D2 SHOULD NOT BE -VE, DEPTH CANNOT BE -VE, IF THAT HAPPENS C THEN EXIT IF (D2.LT.0.0) CALL XIT('DO_SURFACE_ROUTING',-2) RETURN END %id tile_vrt %i classs.6 4 CDMROT, QGROT, HFSROT, QFSROT, %d classs.13 B REFGAT, BCSNGAT,EMISGAT,SALBGAT,CSALGAT, C CDMGAT, QGGAT, HFSGAT, QFSGAT ) %d classs.71 6 EMISROT(NL,NM), CDMROT (NL,NM), QGROT (NL,NM), 7 HFSROT (NL,NM), QFSROT (NL,NM) %d classs.85 6 EMISGAT(ILG), CDMGAT (ILG), QGGAT (ILG), 7 HFSGAT (ILG), QFSGAT (ILG) %i classs.110 CDMROT (ILMOS(K),JLMOS(K))=CDMGAT (K) QGROT (ILMOS(K),JLMOS(K))=QGGAT (K) HFSROT (ILMOS(K),JLMOS(K))=HFSGAT (K) QFSROT (ILMOS(K),JLMOS(K))=QFSGAT (K) %d oceans.4 2 CDMROT, QGROT, HFSROT, QFSROT, + SALBROT, CSALROT, %d oceans.9 7 CDMGAT, QGGAT, HFSGAT, QFSGAT, + SALBGAT, CSALGAT) %d oceans.55 2 BCSNROT, REFROT, EMISROT, 3 CDMROT, QGROT, HFSROT, QFSROT %d oceans.59 2 BCSNGAT, REFGAT, EMISGAT, 3 CDMGAT, QGGAT, HFSGAT, QFSGAT %i oceans.73 CDMROT (IWMOS(K),JWMOS(K))=CDMGAT (K) QGROT (IWMOS(K),JWMOS(K))=QGGAT (K) HFSROT (IWMOS(K),JWMOS(K))=HFSGAT (K) QFSROT (IWMOS(K),JWMOS(K))=QFSGAT (K) %deck vrtdf22 SUBROUTINE VRTDF22( TIO, QIO, UIO, VIO, XIO, 1 UTG, VTG, 2 UFSIROL,VFSIROL,UFSOROL,VFSOROL, 3 UFSROL, VFSROL, UFS, VFS, 4 ALMX, ALMC, PBLT, 5 CNDROL, DEPROL, WSUB, C C -------------- OUTPUTS OR UPDATED INPUTS ARE ABOVE THIS LINE, C -------------- INPUTS ARE BELOW. C 6 GTROT, QGROT, CDMROT, QFSROT, HFSROT, 7 GTAGG, QGAGG, CDMAGG, QFSAGG, HFSAGG, 8 FAREROT, PRESSG, CRH, ZSPD, 9 CQFXROW,CHFXROW, A UTENDGW,VTENDGW, TSGB, TF, SGJ, B SGBJ, SHTXKJ, SHXKJ, SHTJ, SHBJ, C SHJ, DSGJ, DSHJ, CVSG, ZCLFC, D ITRPHS, ILWC, IIWC, IOWAT, IOSIC, E ZTMST, ILG, IL1, IL2, NTILE, F ILEV, LEV, LEVS, NTRAC, IPAM, G ISAVLS,SAVERAD,SAVEBEG ) C C * JUN 22/2016 - M.LAZARE. New tiled version for gcm19: C * - {GT,QG,QFS,HFS,CDM} are now tiled C * input and {UFSROL,VFSROL} are C * tiled output. Number of tiles C * (NTILE) and tile fractional area C * (FAREROT) are passed in. C * - {TH,Q,U,V,XROW} are now internal C * work arrays, set to incoming C * values {TIO,QIO,UIO,VIO,XIO} at C * the start of the tiling loop. For C * each pass through the tiling loop, C * tendencies are calculated for C * each tile and after the tiling loop, C * new values of {TIO,QIO,UIO,VIO,XIO} C * are determined by aggregating over C * the tiled tendencies weighted by C * the tile fractional area. C * - {UTG,VTG} are new output fields passed C * out after taking into account C * contributions from GWD and convection C * (in incoming {UTENDGW,VTENDGW} and C * this routine. The setting of C * {UTENDGW,VTENDGW} to {UTG,VTG} in the C * physics is therefore removed. C * - the diagnostic {UFS,VFS} is determined C * by also aggregating over the tile C * stresses and then the {UGWTS,VGWTS} C * contribution is added in. C * - all non-tile calculations are done C * first, before the tiled loop starts. C * - we have left in the option to revert C * to the old way with no tiling. Under C * that option, defined by ITILVRT=0, C * we use the non-tiled input fields C * and set the tile loop index to one. C * - RKXMIN now local and not passed in. C * - "PARAMS","PARAM1" AND "PARAM3" common C * blocks added, so {TFREZ,HS,HV,PI,CPRES} C * removed from call. C * - ITRAC removed from call after two C * IF conditional sections changed to always C * be true. C * - SAVEGG changed to real name SAVERAD C * (variable name in call). C * - {HFS,QFS} used directly instead of C * copied {SHFLX,SQFLX} in nlclmx8 call, C * so these two work arrays removed. C * - {PBLT,ALMX,ALMC} aggregated over tiles. C * - {XLWROL,XICROL} now internal work arrays. C * FEB 10/2015 - M.LAZARE/ Previous version vrtdf21 for gcm18: C * K.VONSALZEN: - Comment-out lower bound on total C * water (don't think we need it C * any more due to implemented C * improvements and bugfixes elsewhere). C * - Revised call to new NLCLMX8. C * JUL 31/2013 - M.LAZARE. Previous version VRTDF20 for gcm17: C * - STATCLD5 not done above 10 Hpa. C * - Print out warning if QTN<0 before C * calling statcld5, then limit C * it to be non-negative. C * - Pass in LVL and ICALL to statcld5 C * to aid in future debugging. C * JUN 26/2013 - K.VONSALZEN/ Previous version for gcm17: C * M.LAZARE. - Revise calls for new STATCLD5 and C * NLCLMX7. C * - Add the calculation of the subgrid- C * scale component of the vertical C * velocity (to determine aerosol C * activation). This is passed out C * as new i/o array WSUB. C * - Pass in IPAM to determine if bulk C * or pla aerosols are being used and C * choose between different calculations C * of cloudy asymptotic mixing length C * (ALMC) depending on choice of IPAM. C * - Don't call statcld above 10 mbs to C * avoid spurious crashes. C * APR 28/2012 - K.VONSALZEN/ PREVIOUS VERSION VRTDF19 FOR GCM16: C * M.LAZARE: - RKMIN,RKQMIN INCREASED FROM C * 0.01 TO 0.1. C * - STATISTICAL CLOUD SCHEME ONLY C * CALLED FOR L>LEV1 (DEFINED IN RAD C * AND PASSED IN ITOPLW COMMON BLOCK) C * AND EST<1.01*P. C * - REVISION OF SURFACE WIND STRESS C * CALCULATION TO REMOVE DOUBLE C * COUNTING OF VERTICAL DIFFUSION C * GOING INTO {UFS,VFS}. C * - CALLS NEW NLCLMX6 and STATCLD4. C * APR 21/2010 - M.LAZARE. PREVIOUS VERSION VRTDF18 FOR GCM15I: C * - REMOVE UNUSED CALCULATION OF "OMET" C * AND ACCORDINGLY FROM PHYSICS SO C * IT CAN BE USED IN THE NEW CORE15PI C * TO SAVE THE NEW VERTICAL VELOCITY C * DIAGNOSTIC FIELD. C * FEB 17/2009 - K.VONSALZEN/ PREVIOUS VERSION VRTDF17 FOR GCM15H: C * M.LAZARE. - MINIMUM RK'S REDUCED BY ORDER C * OF MAGNITUDE. C * - UNIFIED CLEAR/CLOUD MIXING LENGTHS. C * JAN 17/2008 - K.VONSALZEN/ PREVIOUS VERSION VRTDF16 FOR GCM15G: C * M.LAZARE. - CALLS NEW NLCLMX5 AND STATCLD3. C * - BUGFIX FOR CALCULATION OF ZF. C * - USES ROECKEL FRACTIONAL PROBABILITY C * OF WATER PHASE FUNCTION. C * - USES CLEAR-SKY AND ALL-SKY MIXING C * LENGTHS (ALMC AND ALMX, RESPECTIVELY) C * TO DEFINE A CONSISTENT TOTAL C * MIXING LENGTH (ALMIX) PASSED TO C * STATCLD3. C * - PASSES IN ADELT=2.*DELT FROM PHYSICS C * AS ZTMST WHICH IS USED THROUGHOUT C * ROUTINE IN PLACE OF HARD-CODED 2.*DELT. C * - CONSISTENT PBL USEAGE (LPBL=NINT(PBLT)). C * - GUSTINESS EFFECT NOW INCLUDED C * SINCE IS NOW ALREADY CONTAINED IN ZSPD C * FROM PHYSICS. C * JAN 13/2007 - K.VONSALZEN. PREVIOUS VERSTION VRTDF15 FOR GCM15F. C * - MODIFIED CALL TO STATCLD2, IN C * CONJUNCTION WITH CHANGES TO ADD C * "QCWVAR". C * NOV 28/2006 - M.LAZARE/ - ADD CALCULATION FOR CNDROL,DEPROL C * K.VONSALZEN. UNDER CONTROL OF "ISAVLS". C * - MOVE MIXING OF TRACERS TO BEFORE C * CALCULATION OF MLSE AND TOTAL C * WATER, SO PROFILES ARE WELL-MIXED C * BEFORE BEING PROCESSED. C * NOTE THAT NOW CLOUD WATER AND ICE C * ARE MIXED AS WELL, WHICH REQUIRED C * THAT RKX HAD TO BE DEFINED C * REGARDLESS OF WHETHER TRACER IS C * ADVECTED OR NOT. C * NOV 24/2006 - M.LAZARE. - REMOVE XFS FROM ROUTINE, AND C * DON'T PASS OUT RKMIN,RKQMIN C * (ALL NOT NEEDED). C * JUL 30/2006 - M.LAZARE. - BUGFIX: "IL"->"I" IN CALCULATION C * OF ALWC. C * JUN 30/2006 - M.LAZARE. - UPDATE AND PASS OUT {UTENDGW,VTENDGW} C * INSTEAD OF {UTG,VTG} SINCE THESE C * LATTER (TOTAL) TENDENCIES ARE C * CALCULATED SUBSEQUENTLY NOW IN THE C * PHYSICS DRIVER. C * - USE VARIABLE INSTEAD OF C * CONSTANT IN INTRINSICS SUCH AS "MAX", C * SO THAT CAN COMPILE IN 32-BIT MODE C * WITH REAL*8. C * - CALLS NEW STATCLD2 AND NLCLMX4. C * - WORK ARRAYS NOW LOCAL. C * - DEFINE ALMIX,DHLDZ,DRWDZ C * OUTSIDE OF CONDITIONAL TEST ON C * ES 0.) . C DO 220 I=IL1,IL2 DVDZ(I)=DVDS(I,L)*GRAV*SHBJ(I,L-1) / (RGAS*TF(I,L)) 220 CONTINUE C DO 250 I=IL1,IL2 FACT0=FACT*LOG(SHBJ(I,L-1)) SARI=SQRT(ABS(RI(I,L))) LPBL=NINT(PBLTX(I)) C C * LOWER CUTOFFS. C ALL=0.5*VKC*ZF(I,LPBL) XIMINT =MAX(75.*ALL/(75.+ALL),XLMIN) ALL=0.5*VKC*Z (I,L) XIMIN =MAX(75.*ALL/(75.+ALL),XLMIN) C C * EFFECTIVE MIXING LENGTHS AS FUNCTION OF MIXING C * LENGTHS FOR UP- AND DOWNWARD MIXING. C ALU=VKC*Z(I,L) ALD=VKC*(ZF(I,LPBL)-Z(I,L)) IF ( ALD.GT.0. ) THEN XINGLH=MAX(ALU*ALD/(ALU+ALD),XIMIN) XINGLM=MAX(ALU*ALD/(ALU+ALD),XIMIN) ALMCX(I,L)=XINGLH ELSE FAC=(P(I,L)/PF(I,LPBL))**2. XINGLH=10.+(XIMINT-10.)*FAC XINGLM=10.+(XIMINT-10.)*FAC IF ( IPAM.EQ.1 ) THEN ALMCX(I,L)=MIN(100.*FAC,VKC*(Z(I,L)-ZF(I,LPBL))) ELSE ALMCX(I,L)=MIN(600.*FAC,VKC*(Z(I,L)-ZF(I,LPBL))) ENDIF END IF ALMXX(I,L)=XINGLH ALMXT(I,L)=MAX(ALMXX(I,L),ALMCX(I,L),10.) XINGLH=(1.-ZCLFC(I,L))*XINGLH 1 +ZCLFC(I,L)*ALMXT(I,L) XINGLM=XINGLH C C DIFFUSION COEFFICIENTS. C ELH = XINGLH**2 EPSSH = 0. FACTH = 0.5*RI(I,L)*EPSSH*BEEM IF(FACTH.GT.1.) THEN XH = 0. ELSE XH = (1.-FACTH)**2 ENDIF ELM = XINGLM**2 EPSSM = 0. FACTM = 0.5*RI(I,L)*EPSSM*BEEM IF(FACTM.GT.1.) THEN XM = 0. ELSE XM = (1.-FACTM)**2 ENDIF IF(RI(I,L).LT.0.) THEN RKH(I,L) = ELH*DVDZ(I)*(1.-ALFAH*GAMRH*BEEM*RI(I,L) / 1 (GAMRH+ALFAH*BEEM*SARI)) RKM(I,L) = ELM*DVDZ(I)*(1.- GAMRM*BEEM*RI(I,L) / 1 (GAMRM+ BEEM*SARI)) ELSE RKH(I,L) = ELH*DVDZ(I)*XH/(1.+(1.-EPSSH)*BEEM*RI(I,L)) RKM(I,L) = ELM*DVDZ(I)*XM/(1.+(1.-EPSSM)*BEEM*RI(I,L)) ENDIF C C * PRANDTL NUMBER SCALING FOR EDDY MOMENTUM DIFFUSIVITY, C * BASED ON APPROACH SUGGESTED BY SCHUMANN AND GERZ (1995). C ATMP=0. IF ( RI(I,L).GT.0. ) THEN ATMP=RINEUT*EXP(-RI(I,L)/(RINEUT*RIINF)) ENDIF PRANDTL=ATMP+RI(I,L)/RIINF PRANDTL=MIN(MAX(PRANDTL,PRANDTL_MIN),PRANDTL_MAX) RKM(I,L)=RKM(I,L)*PRANDTL 250 CONTINUE 260 CONTINUE C DO 270 I=IL1,IL2 RKM(I,1)=RKM(I,2) RKH(I,1)=RKH(I,2) ALMCX(I,1)=XLMIN ALMXX(I,1)=XLMIN 270 CONTINUE C C * DEFINE RKQ ALSO AT ** TOP ** INTERFACE OF THERMODYNAMIC LAYERS. C DO 315 L=1,ILEV DO 315 I=IL1,IL2 RKQ(I,L)=RKH(I,L) 315 CONTINUE C C * DIAGNOSE SUBGRID-SCALE COMPONENT OF THE VERTICAL VELOCITY C * (STANDARD DEVIATION, GHAN ET AL., 1997). ACCORDING TO PENG C * ET AL. (2005), THE REPRESENTATIVE VERTICAL VELOCITY FOR C * AEROSOL ACTIVATION IS OBTAINED BY APPLYING A SCALING FACTOR C * TO THE VELOCITY STANDARD DEVIATION (SCALF). C SCALF=0.7 FACTS=SCALF*SQRT(2.*PI) DO L=1,ILEVM WSUBX(IL1:IL2,L)=FACTS*RKH(IL1:IL2,L) 1 /(ZF(IL1:IL2,L)-ZF(IL1:IL2,L+1)) ENDDO WSUBX(IL1:IL2,ILEV)=FACTS*RKH(IL1:IL2,ILEV)/ZF(IL1:IL2,ILEV) C C * INTERPOLATE RKM TO ** BOTTOM ** INTERFACE OF MOMENTUM LAYERS. C * THIS IS REQUIRED FOR USE IN THE ROUTINE "ABCVDM6" WHICH WAS C * ORIGINALLY WRITTEN FOR GCMI STAGGERED LAYER SCHEME AND WHICH C * REQUIRES RKM TO BE DEFINED AT THE BASE OF THE MOMENTUM LAYER. C DO 321 L=1,ILEVM DO 320 I=IL1,IL2 RKM(I,L)=(RKM(I,L )*(SHTJ (I,L+1)-SGBJ (I,L)) 1 +RKM(I,L+1)*(SGBJ (I, L)-SHTJ (I,L))) 2 / DSHJ (I, L) 320 CONTINUE 321 CONTINUE C C * SET A LOWER BOUND TO RK'S. C RKMN=0.1 RKHMN=0.1 RKQMN=0.1 RKXMIN(:)=0.1 C DO 330 L=1,ILEV DO 330 I=IL1,IL2 RKM(I,L)=MAX(RKMN ,RKM(I,L)) RKH(I,L)=MAX(RKHMN,RKH(I,L)) RKQ(I,L)=MAX(RKQMN,RKQ(I,L)) 330 CONTINUE C C * DEFINE THE MINIUMUM ("BACKGROUND") DIFFUSIVITIES FOR ALL THE C * TRACERS. C DO 350 N=1,NTRAC DO L=1,ILEV DO I=IL1,IL2 RKX(I,L,N)=MAX(RKXMIN(N),RKQ(I,L)) ENDDO ENDDO 350 CONTINUE C----------------------------------------------------------------------- C * CALCULATE THE TENDENCIES AND REFINE EVALUATION OF SFC FLUXES. C ------------------------------------------------------------- C * CALCULATE THE COEFFICIENT MATRIX FOR MOMENTUM DIFFUSION. C * GET TENDENCIES FROM MOMENTUM VERTICAL DIFFUSION. C * EVALUATE UFS AND VFS; SINCE THESE ARE TO BE SCALED BY THE SAVING C * INTERVAL, THEIR ACCUMULATION DONE INSIDE IMPLVDH MUST BE RE- C * DONE OUTSIDE. TODT=ZTMST CALL ABCVDM6 (A,B,C,CL,CDVLM,GRAV,IL1,IL2,ILG,ILEV, 1 RGAS,RKM,SGJ,SGBJ,SHJ,TSGB,TODT,.TRUE.) CALL IMPLVD7 (A,B,C,CL,U,CL,IL1,IL2,ILG,ILEV,TODT, 1 TEND,DSGJ,RAUS,WORK,VINT) C C * COMBINE THE TENDENCIES DUE TO MOMENTUM DIFFUSION. C DO 498 I=IL1,IL2 IF(FARE(I).GT.0.) THEN FACT = VINT(I)*RAUS(I) UFS (I) = UFS (I) + FARE(I)*FACT*SAVERAD UFSROL (I) = UFSROL (I) + FARE(I)*FACT*SAVEBEG IF(ITILVRT.EQ.1) THEN IF(NT.EQ.IOWAT) THEN UFSOROL(I) = UFSOROL(I) + FACT*SAVEBEG ELSE IF(NT.EQ.IOSIC) THEN UFSIROL(I) = UFSIROL(I) + FACT*SAVEBEG ENDIF ENDIF ENDIF 498 CONTINUE DO 500 L=1,ILEV DO 500 I=IL1,IL2 UTG(I,L) = UTG(I,L) + TEND(I,L)*FARE(I) U (I,L) = U (I,L) + TODT*TEND(I,L) 500 CONTINUE CALL IMPLVD7 (A,B,C,CL,V,CL,IL1,IL2,ILG,ILEV,TODT, 1 TEND,DSGJ,RAUS,WORK,VINT) DO 505 I=IL1,IL2 IF(FARE(I).GT.0.) THEN FACT = VINT(I)*RAUS(I) VFS (I) = VFS (I) + FARE(I)*FACT*SAVERAD VFSROL (I) = VFSROL (I) + FARE(I)*FACT*SAVEBEG IF(ITILVRT.EQ.1) THEN IF(NT.EQ.IOWAT) THEN VFSOROL(I) = VFSOROL(I) + FACT*SAVEBEG ELSE IF(NT.EQ.IOSIC) THEN VFSIROL(I) = VFSIROL(I) + FACT*SAVEBEG ENDIF ENDIF ENDIF 505 CONTINUE DO 510 L=1,ILEV DO 510 I=IL1,IL2 VTG(I,L) = VTG(I,L) + TEND(I,L)*FARE(I) V (I,L) = V (I,L) + TODT*TEND(I,L) 510 CONTINUE C-------------------------------------------------------------- C * LIQUID WATER STATIC ENERGY AND TOTAL WATER PROFILES. C DO L=1,ILEV DO IL=IL1,IL2 EST=(1.-CHI(IL,L))*ESW(TH(IL,L))+CHI(IL,L)*ESI(TH(IL,L)) IF ( EST < P(IL,L) ) THEN QCWX=(XROW(IL,L+1,ILWC)+XROW(IL,L+1,IIWC))*DSR(IL,L) QT(IL,L)=Q(IL,L)*DSR(IL,L)+QCWX HMN(IL,L)=CPM(IL,L)*TH(IL,L)+GRAV*Z(IL,L)-RRL(IL,L)*QCWX ELSE QT(IL,L)=Q(IL,L)*DSR(IL,L) HMN(IL,L)=CPM(IL,L)*TH(IL,L)+GRAV*Z(IL,L) ENDIF ENDDO ENDDO C C * LIQUID WATER STATIC ENERGY AND TOTAL WATER AT SURFACE. C L=ILEV DO IL=IL1,IL2 QTG(IL)=QG(IL)*DSR(IL,L) HMNG(IL)=CPM(IL,L)*GT(IL) ENDDO C C * CALCULATE THE COEFFICIENT MATRIX FOR TRACER DIFFUSION. C * GET TENDENCIES FROM VERTICAL TRACER DIFFUSION. C * EVALUATE TRACSFS. C DO 532 N=1,NTRAC IF (ITRPHS(N).NE.0 .OR. N.EQ.ILWC .OR. N.EQ.IIWC) THEN CALL ABCVDQ6 ( 1 A,B,C,CL, UN ,CDVLT,GRAV, 2 IL1,IL2,ILG,ILEV,ILEV+1,ILEV, 3 RGAS,RKX(1,1,N),SHTJ,SHJ,DSHJ, 4 TH(1,ILEV),TF,TODT) CALL IMPLVD7(A,B,C,CL,XROW(1,2,N),ZER,IL1,IL2,ILG,ILEV, 1 TODT,TEND,DSHJ,RAUS,WORK,VINT) C C * NOW APPLY THE TENDENCY COMPUTED IN IMPLVD7: C DO L=1,ILEV DO I=IL1,IL2 XROW(I,L+1,N)=XROW(I,L+1,N)+TODT*TEND(I,L) ENDDO ENDDO ENDIF 532 CONTINUE C C * SAVE CLOUD WATER/ICE PROFILES AFTER MIXING AS PASSIVE TRACERS. C IF ( ISAVLS.NE.0 ) THEN DO L=1,ILEV DO IL=IL1,IL2 XLWROL(IL,L)=XROW(IL,L+1,ILWC) XICROL(IL,L)=XROW(IL,L+1,IIWC) ENDDO ENDDO ENDIF C C * CALCULATE THE COEFFICIENT MATRIX FOR DIFFUSION OF LIQUID C * WATER STATIC ENERGY AND TOTAL WATER. GET TENDENCIES FROM C * VERTICAL DIFFUSION. C CALL ABCVDQ6 ( 1 A,B,C,CL,ZER ,CDVLH,GRAV, 2 IL1,IL2,ILG,ILEV,ILEV+1,ILEV, 3 RGAS,RKH,SHTJ,SHJ,DSHJ, 4 TH(1,ILEV),TF,TODT) CALL IMPLVD7(A,B,C,CL,HMN,HMNG,IL1,IL2,ILG,ILEV, 1 TODT,TEND,DSHJ,RAUS,WORK,VINT) C C * NOW APPLY THE TENDENCY COMPUTED IN IMPLVD7: C DO L=1,ILEV DO IL=IL1,IL2 HMN(IL,L)=HMN(IL,L)+TODT*TEND(IL,L) ENDDO ENDDO CALL ABCVDQ6 ( 1 A,B,C,CL,ZER ,CDVLH,GRAV, 2 IL1,IL2,ILG,ILEV,ILEV+1,ILEV, 3 RGAS,RKH,SHTJ,SHJ,DSHJ, 4 TH(1,ILEV),TF,TODT) CALL IMPLVD7(A,B,C,CL,QT,QTG,IL1,IL2,ILG,ILEV, 1 TODT,TEND,DSHJ,RAUS,WORK,VINT) C C * NOW APPLY THE TENDENCY COMPUTED IN IMPLVD7: C DO L=1,ILEV DO IL=IL1,IL2 QT(IL,L)=QT(IL,L)+TODT*TEND(IL,L) IF ( QT(IL,L).LE.0. ) CALL WRN('VRTDF20',-1) c QT(IL,L)=MAX(QT(IL,L),0.) ENDDO ENDDO C C * UNRAVEL LIQUID WATER STATIC ENERGY AND TOTAL WATER TO OBTAIN C * SPECIFIC HUMIDITY, TEMPERATURE, AND CLOUD WATER. C ICVSG=0 ISUBG=1 DO L=1,ILEV DO IL=IL1,IL2 IF(L.GT.1) THEN DZ =Z (IL,L-1)-Z (IL,L) DHLDZ(IL)=(HMN(IL,L-1)-HMN(IL,L))/DZ DRWDZ(IL)=(QT (IL,L-1)-QT (IL,L))/DZ ALMIX(IL)=ALMXT(IL,L) ELSE DHLDZ(IL)=0. DRWDZ(IL)=0. ALMIX(IL)=10. ENDIF C EST=(1.-CHI(IL,L))*ESW(TH(IL,L))+CHI(IL,L)*ESI(TH(IL,L)) IF(L.GT.LEV1 .AND. 1 EST.LT.P(IL,L) .AND. P(IL,L).GE.10.) THEN X(IL)=1. ELSE X(IL)=0. ENDIF ENDDO C IDUM=0 ICALL=2 CALL STATCLD5(QCW,ZCLF,SIGMA(1,L),ZCRAUT,WORK(1,1),SSH, 1 CVSG(1,L),QT(1,L),HMN(1,L),CHI(1,L),CPM(1,L), 2 P(1,L),Z(1,L),RRL(1,L),ZER,X, 3 ALMIX,DHLDZ,DRWDZ,IDUM, 4 GRAV,ZTMST,ILEV,ILG,IL1,IL2,ICVSG,ISUBG, 5 L,ICALL ) C DO IL=IL1,IL2 IF(X(IL).GT.0.) THEN QCWI=CHI(IL,L)*QCW(IL)/DSR(IL,L) QCWL=(1.-CHI(IL,L))*QCW(IL)/DSR(IL,L) C C * UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND CLOUD WATER. C TH(IL,L)=(HMN(IL,L)-GRAV*Z(IL,L)+RRL(IL,L)*QCW(IL))/CPM(IL,L) Q (IL,L)=(QT(IL,L)-QCW(IL))/DSR(IL,L) XROW(IL,L+1,ILWC)=QCWL XROW(IL,L+1,IIWC)=QCWI ELSE C C * UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND CLOUD WATER IN DRY C * LAYER NEAR TOP OF MODEL DOMAIN ASSUMING THAT THERE IS NO C * CONDENSATE. C TH(IL,L)=(HMN(IL,L)-GRAV*Z(IL,L))/CPM(IL,L) Q (IL,L)=QT(IL,L) XROW(IL,L+1,ILWC)=0. XROW(IL,L+1,IIWC)=0. ENDIF ENDDO ENDDO C C * SAVE CONDENSATION/DEPOSITION TENDENCIES. C IF ( ISAVLS.NE.0 ) THEN DO 575 L=1,ILEV DO 575 IL=IL1,IL2 CNDROLX(IL,L)=CNDROLX(IL,L) 1 +(XROW(IL,L+1,ILWC)-XLWROL(IL,L))/TODT DEPROLX(IL,L)=DEPROLX(IL,L) 1 +(XROW(IL,L+1,IIWC)-XICROL(IL,L))/TODT 575 CONTINUE ENDIF C C * AGGREGATE CHANGES OVER ALL TILES. C DO N=1,NTRAC DO L=1,LEV DO IL=IL1,IL2 CHGX(IL,L,N)= CHGX(IL,L,N) + (XROW(IL,L,N)-XIO(IL,L,N))*FARE(IL) ENDDO ENDDO ENDDO DO L=1,ILEV DO IL=IL1,IL2 CHGT(IL,L) = CHGT(IL,L) + (TH(IL,L)-TIO(IL,L))*FARE(IL) CHGQ(IL,L) = CHGQ(IL,L) + (Q (IL,L)-QIO(IL,L))*FARE(IL) CHGU(IL,L) = CHGU(IL,L) + (U (IL,L)-UIO(IL,L))*FARE(IL) CHGV(IL,L) = CHGV(IL,L) + (V (IL,L)-VIO(IL,L))*FARE(IL) C ALMX(IL,L) = ALMX(IL,L) + ALMXX(IL,L)*FARE(IL) ALMC(IL,L) = ALMC(IL,L) + ALMCX(IL,L)*FARE(IL) WSUB(IL,L) = WSUB(IL,L) + WSUBX(IL,L)*FARE(IL) IF ( ISAVLS.NE.0 ) THEN CNDROL(IL,L) = CNDROL(IL,L) + CNDROLX(IL,L)*FARE(IL) DEPROL(IL,L) = DEPROL(IL,L) + DEPROLX(IL,L)*FARE(IL) ENDIF ENDDO ENDDO C C * CALCULATE THE AGGREGATE PBL VERTICAL INDEX. C DO IL=IL1,IL2 PBLT(IL) = PBLT(IL) + PBLTX(IL)*FARE(IL) ENDDO 800 CONTINUE ! end of tiling loop! C C * CALCULATE THE NEW PROGNOSTIC THERMODYNAMIC VALUES. C DO N=1,NTRAC DO L=1,LEV DO IL=IL1,IL2 XIO(IL,L,N) = XIO(IL,L,N) + CHGX(IL,L,N) ENDDO ENDDO ENDDO DO L=1,ILEV DO IL=IL1,IL2 TIO(IL,L) = TIO(IL,L) + CHGT(IL,L) QIO(IL,L) = QIO(IL,L) + CHGQ(IL,L) UIO(IL,L) = UIO(IL,L) + CHGU(IL,L) VIO(IL,L) = VIO(IL,L) + CHGV(IL,L) ENDDO ENDDO RETURN C----------------------------------------------------------------------- END %id sic_gat %i oceang.8 + DEPBGAT, SPCPGAT, RHSIGAT, PREGAT, %i oceang.19 + DEPBROW, SPCPROW, RHSIROW, PREROW, %d oceang.76 5 ZRFMROW, ZRFHROW, ZDMROW, ZDHROW, DEPBROW, + SPCPROW, RHSIROW, PREROW %d oceang.86 5 ZRFMGAT, ZRFHGAT, ZDMGAT, ZDHGAT, DEPBGAT, + SPCPGAT, RHSIGAT, PREGAT %d oceang.120 DEPBGAT (K)=DEPBROW (IWMOS(K)) SPCPGAT (K)=SPCPROW (IWMOS(K)) RHSIGAT (K)=RHSIROW (IWMOS(K)) PREGAT (K)=PREROW (IWMOS(K)) %deck oifpst10 SUBROUTINE OIFPST10(GT,SNO,SIC,BEGO,BWGO,ZSNOW,ALBS,DELICE, 1 RUNOFF,GC,PRESS,GTA,HSEA,TS,QS,HSENS,HLAT, 2 FSG,FLG,CBGO,SNOM,WTRG,WTRS, 3 TISL,DENS,FFLXT,SNOFAC, 4 DELT,ILG,IS,IF) C....................................................................... C * JUN 02/16 - M.LAZARE. NEW VERSION FOR GCM19+: C * - CALLED FOR AMIP AND NEMO/CICE/LIM2, C * ON GATHERED GRID, WHILE OLD OIFPST9 C * STILL CALLED (FOR NOW) AS BEFORE. C * - SECTIONS WITH ICEMOD C * REMOVED, SINCE ONLY CALLED FOR C * "ICEFAC"=0. "IADJ" ALSO THUS REMOVED. C * - CALCULATIONS DONE OVER ICE TIME, SO C * "HSEA" CALCULATION SIMPLIFIED TO C * PACK ICE ONLY. C * - "ZERO" AND "ONE" REPLACED BY 0 AND 1, C * RESPECTIVELY. C * - "RES" REMOVED SINCE WAS IN ICEMOD>0 C * SECTION IN PREVIOUS VERSIONS. C * - ALSO "SICN","JL","ILSL" REMOVED SINCE C * NO LONGER RELEVANT. C * MAR 12/15 - G.FLATO. PREVIOUS VERSION OIFPST9 FOR GCM18. C * - "HOPEN" MODIFIED TO PROPERLY INCLUDE C * RESIDUAL. C * NOV 15/13 - M.LAZARE/ PREVIOUS VERSION OIFPST8 FOR GCM17: C * M.NAMAZI. - ADD CALCULATION OF "TISL". C * - SNOFAC PROMOTED TO ARRAY AND PASSED OUT. C * - CORRECT SNOM CALCULATION. C * APR 30/12 - M.LAZARE. PREVIOUS VERSION OIFPST7 FOR GCM16: C * - PASS IN AND USE FLGROL, RATHER THAN C * FDLROL AND USING SIGMA*T**4 (MORE C * ACCURATE). C * - HSEA PASSED OUT AND USED IN PHYSICS, C * RATHER THAN LEFT AS INTERNAL, IN C * CASE IT IS NEEDED LATER. C * JUN 15/06 - M.LAZARE. PREVIOUS VERSION OIFPST6 FOR GCM15F/G/H/I: C * - "ZERO","ONE" DATA CONSTANTS ADDED AND C * USED IN CALLS TO INTRINSICS. C * - USES INTERNAL WORK ARRAYS INSTEAD C * OF PASSING IN "WRK" WORKSPACE FROM C * PHYSICS. C * JAN 22/05 - D.ROBITAILLE.PREVIOUS VERSION OIFPST5 FOR GCM15C/D/E: C * - DEFAULT ISICN=1 NOW AND CONSISTENCY C * CHECK ADDED AT END OF LOOP 500 C * BETWEEN SIC AND SICN. C * NOV 01/04 - G.FLATO - PREVIOUS VERSION OIFPST4 FOR GCM15B. C C * PURPOSE: C * OVER SEA-ICE, EVALUATE THE GROUND ENERGY BALANCE, TAKING INTO C * ACCOUNT SOLAR FLUX, ATM. AND TERRESTRIAL FLUXES, SENSIBLE AND C * EVAPORATION HEAT LOSS, HEAT LOST TO UNDERLYING SEA WATER. C * METHOD: THERMAL-INERTIA. C * SCHEME: FORWARD 1-DELT STEP. C C * THIS IS FOLLOWED BY A THERMODYNAMIC SEA-ICE MODEL (AFTER C * SEMTNER, JPO MAY, 1976), WHICH DETERMINES CHANGES TO ICE AND C * SNOW AMOUNTS OVER PACK ICE. C C * FINALLY, CHANGE IN ICE CONCENTRATION IS COMPUTED (AFTER HIBLER, C * JPO, JULY, 1979) BASED ON GROWTH OR MELT. C C---------------------------------------------------------------------- C * DICTIONARY OF VARIABLES C C ALFA - leads fraction, i.e. (1.-sicn) C ASIC - initial sea ice amount in (kg m-2) C ASNO - initial snow amount (water equivalent) in (kg m-2) C AGT - initial ground temperature in (K) C BEGO - net energy balance at ice/ocean interface (W m-2) C BGT - snow (ground) temperature (K) after surface melt. C BSIC - sea ice amount (kg m-2) after sublimation/deposition but C before surface melt C BSNO - snow amount (kg m-2) after sublimation/deposition but C before surface melt C BWGO - contribution to net fresh water flux into ocean due to ice C growth or melt (kg m-2 s-1) C C - SQRT(2) times the 'average' heat capacity of the upper snow/ice C surface layer (J m-2 K-1). C CBGO - Energy removed at sea-ice/ocean interface to ensure that C no heat flow into ice-covered ocean occurs when sea-ice C mass is specified (W m-2) C CICE - SQRT(2) times CPACK (J m-2 K-1) C CONI - thermal conductivity of ice (W m K-1) C CONS - thermal conductivity of snow (W m K-1) C CPACK - heat capacity of 10cm 'upper layer' of pack ice (J m-2 K-1) C FLG - net l/w flux at surface (W m-2) C FSG - net solar flux absorbed at surface (W m-2) C DELE - EVAPR * DELT - total evaporation over time step (kg m-2) C DELICE- change in sea ice amount over time step (kg m-2) from C observations C DELM - equivalent heat available for surface melt (kg m-2) C DELSIC- scalar variable equivalent to input DELICE C DELT - model time step (s) C DENI - sea ice density (kg m-3) C DENS - snow density (kg m-3) C DFSIC - thickness of 'thin' ice, specified in SPWCON8 (m) C EVAPR - ground evaporation rate (kg m-2 s-1) C FFLXT - fresh water flux into ocean due to surface melt (kg m-2) C FFLXB - fresh water flux into ocean due to bottom growth or melt (kg m-2) C FO - heat flux from ocean, taken as max(0.,RES) to eliminate negative C values of RES C FSG - net absorbed solar flux at sfc (w m-2) C GC - ground cover type (1.=pack ice, 0.=open water, -1.=land) C GT - ground temperature (K) C GTA - diurnal average ground temperature (K) C GTFSW - freezing point of sea water (K) C GTMSI - melting point of sea ice = TFREZ - 0.1 (K) C H_0 - lead closing parameter (m) C HF - latent heat of fusion (J kg-1) of snow or sea ice = HS-HV C HLAT - latent heat flux (W m-2) C HOPEN - conductive heat flux up through 'thin' ice (W m-2) C HS - latent heat of sublimation (J kg-1) C HV - latent heat of vaporization (J kg-1) C HSEA - conductive heat flux up through sea ice (W m-2) C HSENS - sensible heat flux (W m-2) C QFN - snow evaporation rate (water equivilent) (kg m-2 s-1) C QS - lowest level specific humidity (kg/Kg) C RUNOFF- over ocean, freshwater supplied from liquid precipitation or C surface melt (kg m-2) C SIC - sea ice amount (kg m-2) C SICMIN- minimum sea ice amount, below which grid cell is considered to C be open water (kg m-2) C SMI - net source rate of ice mass (kg m-2 s-1) C SNO - snow amount (kg m-2) C SNOFAC- fraction of snow on seaice C SNOM - snow melting rate (water equivilent) (kg m-2 s-1) C TFREZ - freezing temperature of fresh water or melting point of snow (K) C TS - lowest level potential temperature (K) C WTRG - rate of increase of mass of sea-ice due to compacting of snow C (kg m-2 s-1) C WTRS - rate of decrease of mass of snow due to compacting into sea-ice C (kg m-2 s-1) C IMPLICIT REAL (A-H,O-Z), +INTEGER (I-N) C C * OUTPUT FIELDS: C REAL , DIMENSION(ILG) :: GT,SNO,SIC,BEGO,BWGO,ZSNOW,ALBS, 1 RUNOFF,SNOM,WTRG,WTRS,CBGO, 2 HSEA,TISL,SNOFAC,DENS,FFLXT C C * INPUT FIELDS: C REAL , DIMENSION(ILG) :: GC,PRESS,GTA,TS,QS,HSENS,HLAT,FSG,FLG, 1 DELICE C C * INTERNAL WORK FIELDS. C REAL , DIMENSION(ILG) :: C,EVAPR,DELE,DELM,ASIC,ASNO,AGT, 1 BSIC,BSNO,BGT,FFLXB,CSNOW,ZICE C COMMON /PARAMS/WW,TW,A,ASQ,GRAV,RGAS,RGOCP,RGOASQ,CPRES, 1 RGASV COMMON /PARAM1/PI,RVORD,TFREZ,HS,HV,DAYLNT COMMON /PARAM3/CSNO,CPACK,GTFSW,RKHI,SBC,SNOMAX COMMON /PARAM5/CONI,DENI,SICMIN,DFSIC,CONF C------------------------------------------------------------------- C SNOLIM=(DENI-275.)/0.54 DO 100 I=IS,IF IF(GC(I).GT.0.5) THEN C C * INITIALIZE VARIABLES. C ASIC(I)=SIC(I) ASNO(I)=SNO(I) AGT (I)=GT (I) C C * FRACTION OF SNOW COVER IN GRID SQUARE OVER SEA-ICE. C SNOFAC(I)=MIN(1.,SQRT(SNO(I)/SNOMAX)) C C * HEAT CAPACITY OF PACK ICE (NORMALIZED BY SQRT(2)). C C(I)=CPACK*SQRT(2.) C C * HEAT FLUX THROUGH PACK ICE FROM UNDERLYING SEA WATER (HSEA). C * SEE SUBROUTINE OIFPRP5 FOR SNOW DENSITY JUSTIFICATION COMMENTS. C * CONVERT ANY SNOW MASS HAVING DENSITY GREATER THAN DENI TO C * SEA-ICE (BASED ON USUAL EXPONENTIAL FORMULA WITH A=0.54 AND C * SURFACE DENSITY OF 275 KG/M3). C IF(SNO(I).GT.SNOLIM) THEN SIC(I)=SIC(I)+(SNO(I)-SNOLIM) SNO(I)=SNOLIM WTRG(I)=WTRG(I)+(SNO(I)-SNOLIM)/DELT WTRS(I)=WTRS(I)-(SNO(I)-SNOLIM)/DELT ENDIF IF(SNO(I).GT.SNOMAX) THEN DENS(I)=0.54*SNO(I)/LOG(1.+0.54*SNO(I)/275.) ELSE DENS(I)=275. ENDIF CONS=2.805E-6*DENS(I)**2 CSNOW(I)=CONS RCON=CONI/CONS DSNO=SNO(I)/DENS(I) ZSNOW(I)=DSNO DSIC=SIC(I)/DENI DSIC=MAX(DSIC,DFSIC) ZICE(I)=DSIC FACT=DSIC+RCON*DSNO HSEA(I)=CONI*(GTFSW-GTA(I))/FACT EVAPR(I)=HLAT(I)/HS C C * TIME STEP THE GROUND TEMPERATURE. C GT(I)=GT(I)+(FSG(I)+FLG(I)-HSENS(I)-HLAT(I)+HSEA(I)) * 1 DELT/C(I) ENDIF 100 CONTINUE C================================================================== C * THERMODYNAMIC ICE MODEL (AFTER SEMTNER). C NADJ=0 HF=HS-HV CICE=CPACK*SQRT(2.) GTMSI=TFREZ-0.1 DO 200 I=IS,IF IF(GC(I).GT.0.5) THEN C C * INITIALIZE VARIABLES. C * NOTE THAT RUNOFF=PCP(ABOVE TFREEZ) IS INITIALIZED IN C * SUBROUTINE OIFPRP5. C BEGO(I)=-1.*HSEA(I) BWGO(I)=RUNOFF(I) FFLXB(I)=0. FFLXT(I)=0. DELE(I)=0. DELM(I)=0. C C * SUBLIMATION/DEPOSITION. C DELE(I)=EVAPR(I)*DELT IF(SNO(I).GT.DELE(I)) THEN SNO(I)=SNO(I)-DELE(I) ELSE SIC(I)=SIC(I)-(DELE(I)-SNO(I)) SNO(I)=0. ENDIF SIC(I)=MAX(SIC(I),SICMIN) BSIC(I)=SIC(I) BSNO(I)=SNO(I) ENDIF 200 CONTINUE C C * CALCULATE MELTING AND RUNOFF IF GT IS GREATER THAN FREEZING C * AND ADJUST GT FOR LATENT HEAT LOSS. C DO 300 I=IS,IF IF(GC(I).GT.0.5) THEN IF(GT(I).GT.TFREZ .AND. SNO(I).GT.0.0) THEN C C * WHEN THERE IS SNOW THE SURFACE TEMPERATURE MUST BE ABOVE C * THE MELTING POINT OF SNOW (TFREZ) FOR MELTING TO OCCUR. C * IF ALL SNOW IS MELTED, THE RESULTING GT IS CALCULATED. C DELM(I)=(GT(I)-TFREZ)*C(I)/HF IF(SNO(I).GE.DELM(I)) THEN SNO(I)=SNO(I)-DELM(I) RUNOFF(I)=RUNOFF(I)+DELM(I)/DELT GT(I)=TFREZ ELSE RUNOFF(I)=RUNOFF(I)+SNO(I)/DELT GT(I)=GT(I)-HF*SNO(I)/C(I) SNO(I)=0.0 ENDIF ENDIF SNOM(I)=(BSNO(I)-SNO(I))/DELT BGT(I)=GT(I) C IF(GT(I).GT.GTMSI .AND. SNO(I).EQ.0.0) THEN C C * WHEN THERE ISN'T ANY SNOW THE SURFACE TEMPERATURE NEEDS ONLY C * BE ABOVE THE MELTING POINT OF ICE (GTMSI) FOR MELTING C * TO OCCUR. C DELM(I)=(GT(I)-GTMSI)*CICE/HF IF(DELM(I).LT.SIC(I)) THEN SIC(I)=SIC(I)-DELM(I) GT(I)=GTMSI ELSE GT(I)=GT(I)-HF*SIC(I)/CICE SIC(I)=0. ENDIF ENDIF ENDIF 300 CONTINUE C C * CALCULATE FRESH WATER FLUX DUE TO SURFACE MELT. C DO 350 I=IS,IF IF(GC(I).GT.0.5) THEN FFLXT(I)=((BSIC(I)-SIC(I))+(BSNO(I)-SNO(I)))/DELT ENDIF 350 CONTINUE C HFODT=HF/DELT DO 400 I=IS,IF IF(GC(I).GT.0.5) THEN C C * "DMELT" IS THE ICE-THICKNESS CHANGE FROM TOP. C DMELT=SIC(I)-ASIC(I) C C * "DELSIC" IS THE OBSERVED ICE MASS CHANGE. C DELSIC=DELICE(I) C C * CALCULATE FRESH WATER FLUX AT BOTTOM DUE TO GROWTH OR MELT. C * RESET SEA-ICE MASS TO INTERPOLATED VALUE COMING INTO C * THIS ROUTINE. C C * RESET FFLXT TO INCLUDE ONLY SNOWMELT FOR CORRECT DIAGNOSIS C * OF OBWG --G.FLATO - 15/FEB/01 C FFLXT(I)=(BSNO(I)-SNO(I))/DELT FFLXB(I)=(-DELSIC)/DELT ! freshwater flux due to SIC change SIC(I)=ASIC(I) C C * DIAGNOSTIC EQUATION FOR ENERGY BALANCE AT OCEAN INTERFACE, C * I.E. "BEGO". C * RESET GT TO VALUE PRIOR TO SEA-ICE MELTING. C BEGO(I) = BEGO(I) + HFODT*(DELSIC-DMELT) CBGO(I) = MIN(BEGO(I),0.) - BEGO(I) BEGO(I) = BEGO(I) + CBGO(I) ENDIF 400 CONTINUE C DO 550 I=IS,IF IF(GC(I).GT.0.5) THEN C C * CALCULATE CONTRIBUTION TO NET FRESH WATER FLUX INTO OCEAN. C BWGO(I)= BWGO(I) + (FFLXT(I)+FFLXB(I)) ENDIF 550 CONTINUE C C * UPDATE SNOW ALBEDO. C DO 600 I=IS,IF IF(GC(I).GT.0.5 .AND. SNO(I).GT.0.) THEN IF(GT(I).GE.TFREZ .AND. ALBS(I).GT.0.50) THEN TIMFAC=EXP(LOG((ALBS(I)-0.50)/0.34)- 1 2.778E-6*DELT) ALBS(I)=0.34*TIMFAC+0.50 ELSE IF(GT(I).LT.TFREZ .AND. ALBS(I).GT.0.70) THEN TIMFAC=EXP(LOG((ALBS(I)-0.70)/0.14)- 1 2.778E-6*DELT) ALBS(I)=0.14*TIMFAC+0.70 ENDIF ENDIF 600 CONTINUE C DO 800 I=IS,IF IF(GC(I).GT.0.5 .AND. SNO(I).GT.0.) THEN TISL(I)=(-CONI*ZSNOW(I)*GTFSW-CSNOW(I)*ZICE(I) 1 *GT(I))/(-CONI*ZSNOW(I)-CSNOW(I)*ZICE(I)) ENDIF 800 CONTINUE C----------------------------------------------------------------------- RETURN END %id sicn_crt_fix %d oifpst9.358,364 %d xtemiss10.278 IF(FWATROW(IL).GT.0. .AND. SICNROW(IL).LE.SICN_CRT) THEN #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# # New radiation tiling related mods #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# %id rad_tiling %d classg.17,18 F ZRFMGAT,ZRFHGAT,ZDMGAT, ZDHGAT, FSVGAT, G FSIGAT, FSDBGAT,FSFBGAT,FSSBGAT,CSZGAT, %d classg.41,43 + ZRFMROW,ZRFHROW,ZDMROW, ZDHROW, FSVROT, + FSIROT, FSDBROT,FSFBROT,FSSBROT,CSZROW, + FSGROT, FLGROT, FDLROT, ULROW, VLROW, %d classg.174,175 1 CSZROW ( NL), %d classg.183 REAL, DIMENSION(NL,NM,NBS) :: FSDBROT, FSFBROT, FSSBROT REAL, DIMENSION(NL,NM) :: FSVROT, FSIROT, FSGROT, FLGROT, 1 FDLROT %d classg.186 1 FSVGAT (ILG), FSIGAT (ILG), CSZGAT (ILG), %d classg.238,243 FSVGAT (K)=FSVROT (ILMOS(K),JLMOS(K)) FSIGAT (K)=FSIROT (ILMOS(K),JLMOS(K)) CSZGAT (K)=CSZROW (ILMOS(K)) FSGGAT (K)=FSGROT (ILMOS(K),JLMOS(K)) FLGGAT (K)=FLGROT (ILMOS(K),JLMOS(K)) FDLGAT (K)=FDLROT (ILMOS(K),JLMOS(K)) %d classg.320,322 FSDBGAT(K,L) = FSDBROT(ILMOS(K),JLMOS(K),L) FSFBGAT(K,L) = FSFBROT(ILMOS(K),JLMOS(K),L) FSSBGAT(K,L) = FSSBROT(ILMOS(K),JLMOS(K),L) %d snosica.160 X = LOG(MAX(HICE,0.01) + 1.E-10) %d oceang.17 F FSGROT, FLGROT, QAROW, THLROW, %d oceang.20 I FSDROT, FSFROT, CSDROT, CSFROT, %d oceang.60 2 REFROT, BCSNROT, GCROT, FSGROT, FLGROT %d oceang.68,69 REAL, DIMENSION(NL,NM,NBS) :: FSDROT, FSFROT, CSDROT, CSFROT REAL, DIMENSION(NL,NBS) :: WRKAROL,WRKBROL %d oceang.74 3 PRESROW, QAROW, %i oceang.100 FSGGAT (K)=FSGROT (IWMOS(K),JWMOS(K)) FLGGAT (K)=FLGROT (IWMOS(K),JWMOS(K)) %d oceang.111,112 %d oceang.125,128 FSDGAT (K,IB) = FSDROT (IWMOS(K),JWMOS(K),IB) FSFGAT (K,IB) = FSFROT (IWMOS(K),JWMOS(K),IB) CSDGAT (K,IB) = CSDROT (IWMOS(K),JWMOS(K),IB) CSFGAT (K,IB) = CSFROT (IWMOS(K),JWMOS(K),IB) #/ Fix for ODSV %d raddriv10.973 IF(IEXPLVOL.NE.0) THEN ODSV(I)=VTAU(I) ELSE ODSV(I)=0. ENDIF #/////////////////////////////////////////////////////////////////////// #/ Start updates to move the tiled RT calculations inside of #/ RADDRIV. Note that from RADDRIV we will provide the surface fluxes #/ for each tile and the average over all tiles for the atmosphere. #/////////////////////////////////////////////////////////////////////// %id tile_rad %i raddriv10.10 + FSGT, FSDT, FSFT, FSVT, FSIT, + FDLT, FLGT, FDLCT, CSBT, CLBT, + PART, CSDT, CSFT, + FSDBT, FSFBT, CSDBT, CSFBT, FSSBT, FSSCBT, #/ Merged with update '%d raddriv10.25,27' #%i raddriv10.28 # + SALBT, CSALT, EMIST, GTT, FARET, %d raddriv10.30,31 S NTILE, SOLAR_C, CLDWATMIN, IVERS, JLAT, KOUNT, T MCICA, IRADFORCE, IACTIVE_RT, ITILERAD) %i raddriv10.163 C C * TILED RADIATION ARRAYS. C C * INPUT: C REAL, DIMENSION(ILG,NTILE,NBS) :: SALBT, CSALT REAL, DIMENSION(ILG,NTILE) :: FARET, EM0T, GTT C C * OUTPUT: C REAL, DIMENSION(ILG,NTILE) :: FSGT, FSDT, FSFT, FSVT, FSIT, 1 FDLT, FLGT, FDLCT, CSBT, CLBT, 2 CSDT, CSFT, PART REAL, DIMENSION(ILG,NTILE,NBS) :: FSDBT, FSFBT, CSDBT, + CSFBT, FSSBT, FSSCBT C C * WORK ARRAYS. C REAL , DIMENSION(ILG,NTILE,LEV) :: FLXUT,FLXDT REAL , DIMENSION(ILG,NTILE,2,LEV) :: REFLT,TRANT REAL , DIMENSION(ILG,NTILE) :: ALBSURT, CSALGT REAL , DIMENSION(ILG,NTILE) :: BST,EM0TL,GTTL, FAREL REAL , DIMENSION(ILG,NTILE,NBS) :: SALBTL, CSALTL INTEGER, DIMENSION(ILG,NTILE) :: ITILE, ITILEG %i raddriv10.408 C------------------------------------------------------------------------C C Create mask indicating if calculation should be performed for current C C tile (1) or not (0). If ITILERAD=0 (no tiles) it defaults to only one C C tile, if ITILERAD=1 it uses FARET to decide if calculation should C C be performed and if ITILERAD=2 then tiles will be randomly sampled, C C as in McICA. C C------------------------------------------------------------------------C IF (ITILERAD .EQ. 0) THEN ! JNSC Add computation of the mean surface emissivity, albedo and skin temperature ITILE(IL1:IL2,1) = 1 DO K = 1, NTILE DO I = IL1, IL2 IF (K .EQ. 1) THEN ITILE(I,K) = 1 FAREL(I,K) = 1.0 ELSE ITILE(I,K) = 0 FAREL(I,K) = 0.0 END IF EM0TL(I,K) = EM0(I) GTTL(I,K) = GT(I) DO IB = 1, NBS SALBTL(I,K,IB) = SALB(I,IB) CSALTL(I,K,IB) = CSAL(I,IB) END DO ! IB END DO ! I END DO ! K ELSEIF (ITILERAD .EQ. 1) THEN DO K = 1, NTILE DO I = IL1, IL2 IF (FARET(I,K) .GT. 0.0) THEN ITILE(I,K) = 1 ELSE ITILE(I,K) = 0 END IF EM0TL(I,K) = EM0T(I,K) GTTL(I,K) = GTT(I,K) FAREL(I,K) = FARET(I,K) DO IB = 1, NBS SALBTL(I,K,IB) = SALBT(I,K,IB) CSALTL(I,K,IB) = CSALT(I,K,IB) END DO ! IB END DO ! I END DO ! K END IF #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #/ Start solar related updates #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %i raddriv10.1252 CSDT(IL1:IL2,1:NTILE)=0.0 CSFT(IL1:IL2,1:NTILE)=0.0 CSBT(IL1:IL2,1:NTILE)=0.0 FSGT(IL1:IL2,1:NTILE)=0.0 FSDT(IL1:IL2,1:NTILE)=0.0 FSFT(IL1:IL2,1:NTILE)=0.0 FSIT(IL1:IL2,1:NTILE)=0.0 FSVT(IL1:IL2,1:NTILE)=0.0 C CSDBT (IL1:IL2,1:NTILE,1:NBS) = 0.0 CSFBT (IL1:IL2,1:NTILE,1:NBS) = 0.0 FSDBT (IL1:IL2,1:NTILE,1:NBS) = 0.0 FSFBT (IL1:IL2,1:NTILE,1:NBS) = 0.0 FSSBT (IL1:IL2,1:NTILE,1:NBS) = 0.0 FSSCBT(IL1:IL2,1:NTILE,1:NBS) = 0.0 C REFLT (IL1:IL2,1:NTILE,1:2,1:LEV)=0.0 TRANT (IL1:IL2,1:NTILE,1:2,1:LEV)=0.0 %i raddriv10.1407 DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) ITILEG(I,M) = ITILE(J,M) END DO ! I END DO ! M %i raddriv10.1426 C CSD: DIRECT CLEAR SKY FLUX AT SURFACE. C C CSF: DIFFUSE CLEAR SKY FLUX AT SURFACE. C %i raddriv10.1433 C FLXUT: TILED ALL SKY SW UPWARD FLUX. C C FLXDT: TILED ALL SKY SW DOWNWARD FLUX. C C FSGT: TILED DOWNWARD FLUX ABSORBED BY GROUND. C C FSDT: TILED DIRECT DOWNWARD FLUX AT THE SURFACE. C C FSFT: TILED DIFFUSE DOWNWARD FLUX AT THE SURFACE. C C FSVT: TILED VISIBLE DOWNWARD FLUX AT THE SURFACE. C C FSIT: TILED NEAR INFRARED DOWNWARD FLUX AT THE SURFACE. C C CSBT: TILED NET CLEAR SKY FLUX AT SURFACE. C C CSDT: TILED DIRECT CLEAR SKY FLUX AT SURFACE. C C CSFT: TILED DIFFUSE CLEAR SKY FLUX AT SURFACE. C C CSDBT: TILED CLEAR SKY DIRECT DOWNWARD AT THE SURFACE C C FOR EACH BAND. C C CSFBT: TILED CLEAR SKY DIFFUSE DOWNWARD AT THE SURFACE C C FOR EACH BAND. C C FSDBT: TILED ALL SKY DIRECT DOWNWARD AT THE SURFACE C C FOR EACH BAND. C C FSFBT: TILED ALL SKY DIFFUSE DOWNWARD AT THE SURFACE C C FOR EACH BAND. C C FSSBT: TILED ALL SKY DOWNWARD AT THE SURFACE FOR EACH BAND. C C FSSCBT: TILED CLEAR SKY DOWNWARD AT THE SURFACE FOR EACH BAND. C %i raddriv10.1442 C C * INITIALIZE TILED WORK FIELDS. C DO 275 K = 1, LEV DO 275 M = 1,NTILE DO 275 I = IL1G, IL2G FLXUT(I,M,K) = 0. FLXDT(I,M,K) = 0. 275 CONTINUE %i raddriv10.1759 C DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN X = (1.0 - CLDT(J)) * CUMDTR(I,1,LEV) + 1 CLDT(J) * CUMDTR(I,2,LEV) FLXUT(I,M,LEV) = FLXUT(I,M,LEV) + REFLT(I,M,2,LEV) 1 * A1(I,2) FLXDT(I,M,LEV) = FLXDT(I,M,LEV) + TRANT(I,M,2,LEV) * 1 A1(I,2) FSDT(J,M) = FSDT(J,M) + X * BS(I) * A1(I,2) CSBT(J,M) = CSBT(J,M) + (TRANT(I,M,1,LEV) - 1 REFLT(I,M,1,LEV)) * A1(I,2) CSDT(J,M) = CSDT(J,M) + 1 CUMDTR(I,1,LEV) * BS(I) * A1(I,2) CSFT(J,M) = CSFT(J,M) + TRANT(I,M,1,LEV)*A1(I,2) FSDBT (J,M,IB) = FSDBT (J,M,IB) + X * BS(I) * A1(I,2) FSSBT (J,M,IB) = FSSBT (J,M,IB) + TRANT(I,M,2,LEV) * 1 A1(I,2) CSDBT (J,M,IB) = CSDBT (J,M,IB) + 1 CUMDTR(I,1,LEV) * BS(I) * A1(I,2) FSSCBT(J,M,IB) = FSSCBT(J,M,IB) + TRANT(I,M,1,LEV) * 1 A1(I,2) END IF ENDDO ENDDO %i raddriv10.1986 C DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN FLXDT(I,M,LEV) = FLXDT(I,M,LEV) + A1(I,2) * 1 TRANT(I,M,2,LEV) CSBT(J,M) = CSBT(J,M) + TRANT(I,M,1,LEV)*A1(I,2) END IF ENDDO ! I ENDDO ! M %i raddriv10.2156 C IF (IB .EQ. 1) THEN DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN FSVT(J,M) = FLXDT(I,M,LEV) END IF END DO END DO ENDIF %i raddriv10.2169 C DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN FSFBT(J,M,IB) = MAX(FSSBT (J,M,IB)-FSDBT(J,M,IB),ZERO) CSFBT(J,M,IB) = MAX(FSSCBT(J,M,IB)-CSDBT(J,M,IB),ZERO) END IF END DO ! I END DO ! M %i raddriv10.2185 DO 495 M = 1, NTILE DO 495 I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN FSGT(J,M) = FLXDT(I,M,LEV) - FLXUT(I,M,LEV) FSIT(J,M) = FLXDT(I,M,LEV) - FSVT(J,M) FSFT(J,M) = FLXDT(I,M,LEV) - FSDT(J,M) CSFT(J,M) = CSFT(J,M) - CSDT(J,M) END IF 495 CONTINUE #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #/ End solar related updates #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #/ Start thermal related updates #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %i raddriv10.2228 C FDLC: DOWN CLEAR-SKY LW FLUX RECEIVED AT THE GROUND. C C FLG: NET LW FLUX RECEIVED AT THE GROUND. C %i raddriv10.2232 C C FLXUT: TILED ALL SKY LW UPWARD FLUX. C C FLXTD: TILED ALL SKY LW DOWNWARD FLUX. C C FDLT: TILED DOWN LW FLUX RECEIVED AT THE GROUND. C C FDLCT: TILED DOWN CLEAR-SKY LW FLUX RECEIVED AT THE GROUND. C C FLGT: TILED NET LW FLUX RECEIVED AT THE GROUND. C C CLBT: TILED NET CLEAR SKY DOWNWARD FLUX AT THE SURFACE. C %i raddriv10.2291 C DO 530 M = 1, NTILE DO 530 I = IL1, IL2 CLBT (I,M) = 0.0 FDLCT(I,M) = 0.0 FLGT (I,M) = 0.0 530 CONTINUE C C * RE-INITIALIZE TILED WORK FIELDS. C DO 550 K = 1, LEV DO 550 M = 1, NTILE DO 550 I = IL1, IL2 FLXUT(I,M,K) = 0. FLXDT(I,M,K) = 0. 550 CONTINUE %i raddriv10.2509 C DO 665 M = 1, NTILE DO 665 I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FLXUT(I,M,LEV) = FLXUT(I,M,LEV) 1 + REFLT(I,M,2,LEV)*PGW FLXDT(I,M,LEV) = FLXDT(I,M,LEV) 1 + TRANT(I,M,2,LEV)*PGW FLGT (I,M) = FLGT(I,M) - 1 (REFLT(I,M,2,LEV)-TRANT(I,M,2,LEV)) 2 * PGW FDLCT(I,M) = FDLCT(I,M) + TRANT(I,M,1,LEV) 1 * PGW CLBT (I,M) = CLBT(I,M) - 1 (REFLT(I,M,1,LEV)-TRANT(I,M,1,LEV)) 2 * PGW END IF 665 CONTINUE %i raddriv10.2723 DO 760 M = 1, NTILE DO 760 I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FLXUT(I,M,LEV) = FLXUT(I,M,LEV) 1 + REFLT(I,M,2,LEV) * PGW FLXDT(I,M,LEV) = FLXDT(I,M,LEV) 1 + TRANT(I,M,2,LEV) * PGW FLGT(I,M) = FLGT(I,M) 1 -(REFLT(I,M,2,LEV)-TRANT(I,M,2,LEV)) 2 * PGW FDLCT(I,M) = FDLCT(I,M) + TRANT(I,M,1,LEV)* PGW CLBT(I,M) = CLBT(I,M) 1 -(REFLT(I,M,1,LEV)-TRANT(I,M,1,LEV)) 2 * PGW END IF 760 CONTINUE %i raddriv10.2819 C DO 975 M = 1, NTILE DO 975 I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FDLT(I,M) = FLXDT(I,M,LEV) END IF 975 CONTINUE #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #/ End thermal related updates #/~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #/////////////////////////////////////////////////////////////////////// #/ End updates to handle the tiled fluxes. #/ Note that from RADDRIV we will provide the surface fluxes for #/ each tile and the average over all tiles for the atmosphere. #/////////////////////////////////////////////////////////////////////// #/////////////////////////////////////////////////////////////////////// #/ Start what seems to be updates to remove code related to the #/ determinsitic RT code mixed with updates to handle tiling. #/////////////////////////////////////////////////////////////////////// %id nomcica %d raddriv10.25,27 N EM0, CLDT, RADJ, WCDW, O REL_SUB, REI_SUB, CLW_SUB, CIC_SUB, NCLDY, + SALBT, CSALT, EM0T, GTT, FARET, %d raddriv10.193,196 C C * INPUT ARRAY FOR BC CALCULATIONS. C REAL, DIMENSION(ILG,LAY) :: WCDW %d raddriv10.253 REAL , DIMENSION(ILG,2,LEV) :: CUMDTR %d raddriv10.508,527 C DEFINE THE SPECTRAL SAMPLING FOR THE SHORTWAVE AND LONGWAVE. C C----------------------------------------------------------------------C C CALL INITSPECSAMPL2(NSAMPLE_SW, NSAMPLE_LW, NBS, NBL, 1 MAXNG, IVERS, IRADFORCE, MAX_SAM) %d raddriv10.1476,1489 %d raddriv10.1509 %i raddriv10.1578 MCICA=1 %d raddriv10.1586,1590 DO K = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) ALBSURT(I,K) = SALBTL(J,K,IB) CSALGT (I,K) = CSALTL(J,K,IB) ENDDO END DO %d raddriv10.1595 #/ JNSC (change ALBSUR and CSALG to SALBTL and CSALTL) #/ For STRANUP, provide the REFL for each tile at #/ vertical grid "K+1". Want to compute the mean #/ reflection and transmission profiles in SWTRAN_MCICA #/ maybe in this loop. %d raddriv10.1628,1629 CALL STRANDN3(TRANT, BS, A1, RMUG, DP, DT, O3G, O2G, 1 A1(1,3),ITILEG, 2 IB, IG, LEV1, IL1G, IL2G, ILG, LAY, LEV, 3 NTILE) %d raddriv10.1640,1677 CALL SWTRAN_MCICA(REFLT, TRANT, ITILEG, 1 CUMDTR, BS, TAUA, TAUR, TAUG, 2 TAUOMA, TAUOMGA, F1, F2, TAUCSG, 3 TAUOMC, TAUOMGC, CLDG, 4 RMUG, C1, C2, ALBSURT, CSALGT, NCTG, 5 CUT, LEV1, IL1G, IL2G, ILG, LAY, LEV, 6 NTILE) C IF (LEV1 .GT. 1) THEN CALL STRANUP3(REFLT, ITILEG, DP, DT, O3G, O2G, IB, IG, 1 LEV1, IL1G, IL2G, ILG, LAY, LEV, NTILE) ENDIF C C----------------------------------------------------------------------C C Compute the gridbox mean REFL and TRAN using REFLT, TRANT and the C C fraction covered by each tile. C C----------------------------------------------------------------------C C REFL(IL1:IL2,1:2,1:LEV) = 0.0 TRAN(IL1:IL2,1:2,1:LEV) = 0.0 DO K = 1, LEV DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN REFL(I,1,K) = REFL(I,1,K) 1 + REFLT(I,M,1,K)*FAREL(J,M) REFL(I,2,K) = REFL(I,2,K) 1 + REFLT(I,M,2,K)*FAREL(J,M) TRAN(I,1,K) = TRAN(I,1,K) 1 + TRANT(I,M,1,K)*FAREL(J,M) TRAN(I,2,K) = TRAN(I,2,K) 1 + TRANT(I,M,2,K)*FAREL(J,M) END IF END DO ! I END DO ! M END DO ! K C * FOR THE TOTAL SKY FLUXES WEIGHT THE CLEAR AND CLOUDY SKY C * FLUXES BY THE TOTAL VERTICALLY PROJECTED CLOUD FRACTION. C DO K = 1, LEV DO I = IL1G, IL2G J = ISUN(I) IF (CLDT(J).LT.1.0) THEN REFL(I,2,K) = (1.0 - CLDT(J)) * REFL(I,1,K) + 1 CLDT(J) * REFL(I,2,K) TRAN(I,2,K) = (1.0 - CLDT(J)) * TRAN(I,1,K) + 1 CLDT(J) * TRAN(I,2,K) END IF END DO ! I END DO ! K C DO K = 1, LEV DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN IF (CLDT(J).LT.1.0) THEN REFLT(I,M,2,K) = (1.0-CLDT(J))*REFLT(I,M,1,K) 1 + CLDT(J)*REFLT(I,M,2,K) TRANT(I,M,2,K) = (1.0-CLDT(J))*TRANT(I,M,1,K) 1 + CLDT(J)*TRANT(I,M,2,K) END IF END IF END DO ! I END DO ! M END DO ! K %d raddriv10.1696,1704 X = (1.0 - CLDT(J)) * CUMDTR(I,1,LEV) + 1 CLDT(J) * CUMDTR(I,2,LEV) #/ JNSC - The assumption for the optically think g-points is that it #/ is total absorbed before interacting with the surface. There is #/ no need to account for surface variability effect on transmission. %d raddriv10.1921,1924 CALL STRANDNGH4(TRANT, ITILEG, 1 GWGH, A1, TAUA, TAUOMA, TAUCSG, TAUOMC, 2 CLDG, RMUG, DP, O3G, QG, CO2G, CH4G, O2G, IB, 3 IG, INPTG, OMCI, DT, LEV1, GH, CUT, 4 IL1G, IL2G, ILG, LAY, LEV, NTILE) %d raddriv10.1925,1939 C C----------------------------------------------------------------------C C Compute the gridbox mean REFL and TRAN using REFLT, TRANT and the C C fraction covered by each tile. C C----------------------------------------------------------------------C C REFL(IL1:IL2,1:2,1:LEV) = 0.0 TRAN(IL1:IL2,1:2,1:LEV) = 0.0 DO K = 1, LEV DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN TRAN(I,1,K) = TRAN(I,1,K) 1 + TRANT(I,M,1,K)*FAREL(J,M) TRAN(I,2,K) = TRAN(I,2,K) 1 + TRANT(I,M,2,K)*FAREL(J,M) END IF END DO ! I END DO ! M END DO ! K C C * FOR THE TOTAL SKY FLUXES WEIGHT THE CLEAR AND CLOUDY SKY C * FLUXES BY THE TOTAL VERTICALLY PROJECTED CLOUD FRACTION. C DO K = 1, LEV DO I = IL1G, IL2G J = ISUN(I) IF (CLDT(J).LT.1.0) THEN TRAN(I,2,K) = (1.0 - CLDT(J)) * TRAN(I,1,K) + 1 CLDT(J) * TRAN(I,2,K) END IF END DO ! I END DO ! K C DO K = 1, LEV DO M = 1, NTILE DO I = IL1G, IL2G J = ISUN(I) IF (ITILEG(I,M) .GT. 0) THEN IF (CLDT(J).LT.1.0) THEN TRANT(I,M,2,K) = (1.0-CLDT(J))*TRANT(I,M,1,K) 1 + CLDT(J) * TRANT(I,M,2,K) END IF END IF END DO ! I END DO ! M END DO ! K #/ JNSC - Modify loops near and below line 2145 to account for tiles... %d raddriv10.2339,2340 CALL PLANCK3(BF, BST, URBF, A1(1,2), A1(1,3), O3G, TFULL, GTTL, 1 IB, ITILE, 2 IL1, IL2, ILG, LAY, LEV, NTILE) %d raddriv10.2342,2346 %d raddriv10.2364 %d raddriv10.2435 %d raddriv10.2443,2468 CALL LWTRAN_MCICA2(REFLT, TRANT, 1 C1, TAUCI, OMCI, GCI, F2, TAUA, 2 TAUG, BF, BST, URBF, O3G, EM0TL, 3 CLDG, NCT, LEV1, CUT, MAXC, 4 ITILE, 5 IL1, IL2, ILG, LAY, LEV, 6 NTILE) C C----------------------------------------------------------------------C C Compute the gridbox mean REFL and TRAN using REFLT, TRANT and the C C fraction covered by each tile. C C----------------------------------------------------------------------C C REFL(IL1:IL2,1:2,1:LEV) = 0.0 TRAN(IL1:IL2,1:2,1:LEV) = 0.0 DO K = 1, LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN TRAN(I,1,K) = TRAN(I,1,K) 1 + TRANT(I,M,1,K)*FAREL(I,M) TRAN(I,2,K) = TRAN(I,2,K) 1 + TRANT(I,M,2,K)*FAREL(I,M) REFL(I,1,K) = REFL(I,1,K) 1 + REFLT(I,M,1,K)*FAREL(I,M) REFL(I,2,K) = REFL(I,2,K) 1 + REFLT(I,M,2,K)*FAREL(I,M) END IF END DO ! I END DO ! M END DO ! K C C * FOR THE TOTAL SKY FLUXES WEIGHT THE CLEAR AND CLOUDY SKY C * FLUXES BY THE TOTAL VERTICALLY PROJECTED CLOUD FRACTION. C DO K = LEV1,LEV DO I = IL1,IL2 IF (CLDT(I).LT.1.0) THEN REFL(I,2,K) = (1.0 - CLDT(I)) * REFL(I,1,K) + 1 CLDT(I) * REFL(I,2,K) TRAN(I,2,K) = (1.0 - CLDT(I)) * TRAN(I,1,K) + 1 CLDT(I) * TRAN(I,2,K) END IF END DO ! I END DO ! K C DO K = LEV1, LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN IF (CLDT(I).LT.1.0) THEN REFLT(I,M,2,K) = (1.0 - CLDT(I)) * REFLT(I,M,1,K) + 1 CLDT(I) * REFLT(I,M,2,K) TRANT(I,M,2,K) = (1.0 - CLDT(I)) * TRANT(I,M,1,K) + 1 CLDT(I) * TRANT(I,M,2,K) END IF END IF END DO ! I END DO ! M END DO ! K %d raddriv10.2624,2642 CALL LWTRAGH4(REFLT, TRANT, 1 C2, TAUCI, OMCI, TAUA, TAUG, 2 BF, URBF, CLDG, EM0TL, BST, ITILE, CUT, 3 IL1, IL2, ILG, LAY, LEV, 4 NTILE) C C----------------------------------------------------------------------C C Compute the gridbox mean REFL and TRAN using REFLT, TRANT and the C C fraction covered by each tile. C C----------------------------------------------------------------------C C REFL(IL1:IL2,1:2,1:LEV) = 0.0 TRAN(IL1:IL2,1:2,1:LEV) = 0.0 DO K = 1, LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN TRAN(I,1,K) = TRAN(I,1,K) 1 + TRANT(I,M,1,K)*FAREL(I,M) TRAN(I,2,K) = TRAN(I,2,K) 1 + TRANT(I,M,2,K)*FAREL(I,M) REFL(I,1,K) = REFL(I,1,K) 1 + REFLT(I,M,1,K)*FAREL(I,M) REFL(I,2,K) = REFL(I,2,K) 1 + REFLT(I,M,2,K)*FAREL(I,M) END IF END DO ! I END DO ! M END DO ! K C C * FOR THE TOTAL SKY FLUXES WEIGHT THE CLEAR AND CLOUDY SKY C * FLUXES BY THE TOTAL VERTICALLY PROJECTED CLOUD FRACTION. C DO K = 1, LEV DO I = IL1,IL2 IF (CLDT(I).LT.1.0) THEN REFL(I,2,K) = (1.0 - CLDT(I))*REFL(I,1,K) 1 + CLDT(I) * REFL(I,2,K) TRAN(I,2,K) = (1.0 - CLDT(I))*TRAN(I,1,K) 1 + CLDT(I) * TRAN(I,2,K) END IF END DO ! I END DO ! K C DO K = 1, LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN IF (CLDT(I).LT.1.0) THEN REFLT(I,M,2,K) = (1.0 - CLDT(I)) * REFLT(I,M,1,K) + 1 CLDT(I) * REFLT(I,M,2,K) TRANT(I,M,2,K) = (1.0 - CLDT(I)) * TRANT(I,M,1,K) + 1 CLDT(I) * TRANT(I,M,2,K) END IF END IF END DO ! I END DO ! M END DO ! K %d raddriv10.2698,2703 IF (CLDT(I).LT.1.0) THEN TOA_OLR(I,2) = (1.0-CLDT(I))*TOA_OLR(I,1) 1 + CLDT(I)*TOA_OLR(I,2) END IF #///////////////////////////////////////////////////////// #/ Modifications to the actual RT routines. #///////////////////////////////////////////////////////// #/ Solar #///////////////////////////////////////////////////////// %d swtran_mcica.2,6 SUBROUTINE SWTRAN_MCICA (REFL, TRAN, ITILE, 1 UCUMDTR, TRAN0, TAUA, TAUR, TAUG, 2 TAUOMA, TAUOMGA, F1, F2, TAUC, 3 TAUOMC, TAUOMGC, CLD, RMU, C1, C2, 4 ALBSURT, CSALBT, NCT, CUT, LEV1, 5 IL1, IL2, ILG, LAY, LEV, 6 NTILE) %d swtran_mcica.43,44 C REFLT: TILED REFLECTIVITY (1) CLEAR SKY; (2) ALL SKY C C TRANT: TILED TRANSMITIVITY C %d swtran_mcica.64,65 C ALBSURT: TILED ALL-SKY SURFACE ALBEDO C C CSALBT: TILED CLEAR-SKY SURFACE ALBEDO C C ITILE: INDICATOR IF CALCULATIONS IS TO BE PERFORMED ON TILE C #%i swtran_mcica.70 # REAL REFLT(ILG,NTILE,2,LEV), TRANT(ILG,NTILE,2,LEV) %d swtran_mcica.81,82 REAL CUMDTR(ILG,2,LEV), UCUMDTR(ILG,2,LEV),TRAN0(ILG) REAL REFL(ILG,NTILE,2,LEV), TRAN(ILG,NTILE,2,LEV), 1 ALBSURT(ILG,NTILE), CSALBT(ILG,NTILE) %d swtran_mcica.87,91 3 RMU(ILG), C1(ILG), C2(ILG) REAL*8 RDF(ILG,2,LAY), TDF(ILG,2,LAY), RDR(ILG,2,LAY), 1 TDR(ILG,2,LAY), DTR(ILG,2,LAY), UDTR(ILG,2,LAY) REAL*8 RMDF(ILG,NTILE,2,LEV), TMDR(ILG,NTILE,2,LEV), 1 RMUR(ILG,NTILE,2,LEV), RMUF(ILG,NTILE,2,LEV) %i swtran_mcica.92 INTEGER ITILE(ILG,NTILE) %d swtran_mcica.110,117 DO 10 K = LEV1, LEV DO 20 I = IL1,IL2 CUMDTR(I,1:2,K) = 0.0 UCUMDTR(I,1:2,K) = 0.0 20 CONTINUE 10 CONTINUE DO K = LEV1, LEV DO M = 1, NTILE DO I = IL1,IL2 REFL(I,M,1:2,K) = 0.0 TRAN(I,M,1:2,K) = 0.0 END DO ! I END DO ! M END DO ! K #///// #/ Clear sky calculations #///// %d swtran_mcica.175,192 DO 300 I = IL1, IL2 C C----------------------------------------------------------------------C C INITIALIZATION FOR THE FIRST LEVEL (LEV1). C C----------------------------------------------------------------------C C CUMDTR(I,1,LEV1) = TRAN0(I) UCUMDTR(I,1,LEV1) = TRAN0(I) 300 CONTINUE DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN C C----------------------------------------------------------------------C C INITIALIZATION FOR THE FIRST LEVEL (LEV1). C C----------------------------------------------------------------------C C TMDR(I,M,1,LEV1) = TRAN0(I) RMDF(I,M,1,LEV1) = 1.0 - TRAN0(I) C C----------------------------------------------------------------------C C INITIALIZATION FOR THE GROUND LAYER. C C----------------------------------------------------------------------C C RMUR(I,M,1,LEV) = CSALBT(I,M) RMUF(I,M,1,LEV) = CSALBT(I,M) END IF END DO ! I END DO ! M %d swtran_mcica.198,227 DO K = LEV1 + 1, LEV KM1 = K - 1 DO I = IL1, IL2 CUMDTR(I,1,K) = CUMDTR(I,1,KM1) * DTR(I,1,KM1) UCUMDTR(I,1,K) = UCUMDTR(I,1,KM1) * UDTR(I,1,KM1) END DO ! I END DO ! K DO 451 K = LEV1 + 1, LEV KM1 = K - 1 L = LEV - K + LEV1 LP1 = L + 1 DO 450 M = 1, NTILE DO 400 I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN DMM = TDF(I,1,KM1) / 1 (1.0 - RDF(I,1,KM1)*RMDF(I,M,1,KM1)) FMM = RMDF(I,M,1,KM1) * DMM TMDR(I,M,1,K) = CUMDTR(I,1,KM1) * (TDR(I,1,KM1) + 1 RDR(I,1,KM1) * FMM) + 2 (TMDR(I,M,1,KM1) - CUMDTR(I,1,KM1))* 3 DMM RMDF(I,M,1,K) = RDF(I,1,KM1) + TDF(I,1,KM1) * FMM C C----------------------------------------------------------------------C C ADD THE LAYERS UPWARD FROM ONE LAYER ABOVE SURFACE TO THE LEV1. C C----------------------------------------------------------------------C UMM = TDF(I,1,L) / 1 (1.0 - RDF(I,1,L) * RMUF(I,M,1,LP1)) FMM = RMUF(I,M,1,LP1) * UMM RMUR(I,M,1,L) = RDR(I,1,L) + DTR(I,1,L) * 1 RMUR(I,M,1,LP1) * UMM + 2 (TDR(I,1,L)-DTR(I,1,L)) * FMM RMUF(I,M,1,L) = RDF(I,1,L) + TDF(I,1,L) * FMM END IF 400 CONTINUE 450 CONTINUE 451 CONTINUE %d swtran_mcica.234,245 DO 550 K = LEV1, LEV KM1 = K - 1 DO 551 M = 1, NTILE DO 500 I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN DMM = 1.0 / 1 (1.0 - RMUF(I,M,1,K)*RMDF(I,M,1,K)) X = CUMDTR(I,1,K) * RMUR(I,M,1,K) Y = TMDR(I,M,1,K) - CUMDTR(I,1,K) TRAN(I,M,1,K) = CUMDTR(I,1,K) + 1 (X * RMDF(I,M,1,K) + Y) * DMM REFL(I,M,1,K) = (X + Y * RMUF(I,M,1,K)) * DMM END IF 500 CONTINUE 551 CONTINUE 550 CONTINUE #///// #/ All sky calculations #///// %d swtran_mcica.309,326 DO 700 I = IL1, IL2 C C----------------------------------------------------------------------C C INITIALIZATION FOR THE FIRST LEVEL (LEV1). C C----------------------------------------------------------------------C C CUMDTR(I,2,LEV1) = TRAN0(I) UCUMDTR(I,2,LEV1) = TRAN0(I) 700 CONTINUE DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN C C----------------------------------------------------------------------C C INITIALIZATION FOR THE FIRST LEVEL (LEV1). C C----------------------------------------------------------------------C C TMDR(I,M,2,LEV1) = TRAN0(I) RMDF(I,M,2,LEV1) = 1.0 - TRAN0(I) C C----------------------------------------------------------------------C C INITIALIZATION FOR THE GROUND LAYER. C C----------------------------------------------------------------------C C RMUR(I,M,2,LEV) = ALBSURT(I,M) RMUF(I,M,2,LEV) = ALBSURT(I,M) END IF END DO ! I END DO ! M %d swtran_mcica.331,376 DO K = LEV1 + 1, LEV KM1 = K - 1 DO I = IL1, IL2 IF (NCT(I) .LE. LAY) THEN IF (K .LE. NCT(I)) THEN CUMDTR(I,2,K) = CUMDTR(I,1,K) UCUMDTR(I,2,K)= UCUMDTR(I,1,K) ELSE CUMDTR(I,2,K) = CUMDTR(I,2,KM1)*DTR(I,2,KM1) UCUMDTR(I,2,K) = UCUMDTR(I,2,KM1)*UDTR(I,2,KM1) END IF ELSE CUMDTR(I,2,K) = 0.0 UCUMDTR(I,2,K) = 0.0 END IF END DO ! I END DO ! K DO 851 K = LEV1 + 1, LEV KM1 = K - 1 L = LEV - K + LEV1 LP1 = L + 1 DO 850 M = 1, NTILE DO 800 I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN IF (NCT(I) .LE. LAY) THEN IF (K .LE. NCT(I)) THEN TMDR(I,M,2,K) = TMDR(I,M,1,K) RMDF(I,M,2,K) = RMDF(I,M,1,K) ELSE DPP = TDF(I,2,KM1) / 1 (1.0 - RMDF(I,M,2,KM1)* 2 RDF(I,2,KM1)) FPP = RMDF(I,M,2,KM1) * DPP TMDR(I,M,2,K) = CUMDTR(I,2,KM1) * 1 (TDR(I,2,KM1) + 1 RDR(I,2,KM1) * FPP) + 2 (TMDR(I,M,2,KM1) - 3 CUMDTR(I,2,KM1))*DPP RMDF(I,M,2,K) = RDF(I,2,KM1) + 1 TDF(I,2,KM1) * FPP ENDIF C C----------------------------------------------------------------------C C ADD THE LAYERS UPWARD FROM ONE LAYER ABOVE SURFACE TO THE LEV1. C C----------------------------------------------------------------------C C UPP = TDF(I,2,L) / 1 (1.0 - RMUF(I,M,2,LP1) * 2 RDF(I,2,L)) FPP = RMUF(I,M,2,LP1) * UPP RMUR(I,M,2,L) = RDR(I,2,L) + DTR(I,2,L) * 1 RMUR(I,M,2,LP1)*UPP + 2 (TDR(I,2,L) - DTR(I,2,L))*FPP RMUF(I,M,2,L) = RDF(I,2,L) + TDF(I,2,L)*FPP ELSE TMDR(I,M,2,K) = 1.0 RMDF(I,M,2,K) = 0.0 RMUR(I,M,2,L) = 0.0 RMUF(I,M,2,L) = 0.0 ENDIF END IF 800 CONTINUE 850 CONTINUE 851 CONTINUE %i swtran_mcica.385 DO 951 M = 1, NTILE %d swtran_mcica.387,398 IF (ITILE(I,M) .GT. 0) THEN IF (NCT(I) .LE. LAY) THEN DPP = 1.0 / 1 (1.0-RMUF(I,M,2,K)*RMDF(I,M,2,K)) X = CUMDTR(I,2,K) * RMUR(I,M,2,K) Y = TMDR(I,M,2,K) - CUMDTR(I,2,K) TRAN(I,M,2,K) = CUMDTR(I,2,K) * + (X * RMDF(I,M,2,K) + Y) * DPP REFL(I,M,2,K) = (X + Y * RMUF(I,M,2,K)) * DPP ELSE TRAN(I,M,2,K) = TRAN(I,M,1,K) REFL(I,M,2,K) = REFL(I,M,1,K) ENDIF END IF %i swtran_mcica.399 951 CONTINUE %d strandn3.2,3 SUBROUTINE STRANDN3(TRANT, ATTN, ATTNTOP, RMU, DP, DT, O3, O2, 1 RMU3,ITILE, 2 IB, IG, LEV1, IL1, IL2, ILG, LAY, LEV, NTILE) %d strandn3.30,32 REAL TRANT(ILG,NTILE,2,LEV), TRAN(ILG,2,LEV), ATTN(ILG), 1 ATTNTOP(ILG), RMU(ILG), DP(ILG,LAY), DT(ILG,LAY), 2 O3(ILG,LAY), O2(ILG,LAY), RMU3(ILG) INTEGER ITILE(ILG,NTILE) %i strandn3.96 DO K = 1, LEV1 DO IT = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,IT) .GT. 0) THEN TRANT(I,IT,1,K) = TRAN(I,1,K) TRANT(I,IT,2,K) = TRAN(I,2,K) END IF END DO !I END DO ! IT END DO ! K %d stranup3.2,5 SUBROUTINE STRANUP3(REFL, ITILE, DP, DT, O3, O2, IB, IG, LEV1, 1 IL1, IL2, ILG, LAY, LEV, NTILE) C C * JUN 02,2015 - M.LAZARE/ NEW VERSION FOR GCM19: C * J.COLE: - ADD TILED RADIATION CALCULATIONS C * (IE "REFLT"), UNDER CONTROL OF C * "ITILRAD". C * FEB 09,2009 - J.LI. PREVIOUS VERSION STRANUP3 FOR GCM15H C * THROUGH GCM18: %d stranup3.28 REAL REFL(ILG,NTILE,2,LEV), DP(ILG,LAY), DT(ILG,LAY), O3(ILG,LAY), %i stranup3.29 INTEGER ITILE(ILG,NTILE) %i stranup3.40 DO 101 M = 1, NTILE %i stranup3.41 IF (ITILE(I,M) .GT. 0) THEN %d stranup3.47,48 REFL(I,M,1,K) = REFL(I,M,1,KP1) * DTR REFL(I,M,2,K) = REFL(I,M,2,KP1) * DTR END IF %i stranup3.49 101 CONTINUE %i stranup3.54 DO 111 M = 1, NTILE %i stranup3.55 IF (ITILE(I,M) .GT. 0) THEN %d stranup3.60,61 REFL(I,M,1,K) = REFL(I,M,1,KP1) * DTR REFL(I,M,2,K) = REFL(I,M,2,KP1) * DTR END IF %i stranup3.62 111 CONTINUE %i stranup3.70 DO 201 M = 1, NTILE %i stranup3.71 IF (ITILE(I,M) .GT. 0) THEN %d stranup3.72,73 REFL(I,M,1,K) = REFL(I,M,1,KP1) REFL(I,M,2,K) = REFL(I,M,2,KP1) END IF %i stranup3.74 201 CONTINUE %d strandngh4.2,7 SUBROUTINE STRANDNGH4 (TRANT, ITILE, 1 GWGH, ATTEN, TAUA, TAUOMA, TAUCS, 2 TAUOMC, CLD, RMU, DP, O3, Q, CO2, CH4, O2, 3 IB, IG, INPT, DIP, DT, LEV1, GH, CUT, 4 IL1, IL2, ILG, LAY, LEV, NTILE) C C * JUN 02,2015 - M.LAZARE/ NEW VERSION FOR GCM19: C * J.COLE: - ADD TILED RADIATION CALCULATIONS C * (IE "TRANT") C * FEB 09,2009 - J.LI. PREVIOUS VERSION STRANDNGH4 FOR GCM15H C * THROUGH GCM18: %i strandngh4.34 C TRANT: TILED DOWNWARD FLUX C C ITILE: FLAG INDICATING CALCULATION FOR PARTICULAR TILE. C %d strandngh4.52 REAL ATTEN(ILG), TAUA(ILG,LAY), TAUOMA(ILG,LAY), %i strandngh4.55 REAL TRANT(ILG,NTILE,2,LEV) INTEGER ITILE(ILG,NTILE) %d strandngh4.60 REAL TAUG(ILG,LAY),TRAN(ILG,2,LEV) %i strandngh4.261 DO K = 1, LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN TRANT(I,M,1,K) = TRAN(I,1,K) TRANT(I,M,2,K) = TRAN(I,2,K) END IF END DO ! I END DO ! M END DO ! K #///////////////////////////////////////////////////////// #/ Thermal #///////////////////////////////////////////////////////// %d planck3.2,3 SUBROUTINE PLANCK3(BF, BST, URBF, BF0, URBF0, DBF, TFULL, GTT, 1 IB, ITILE, 2 IL1, IL2, ILG, LAY, LEV, NTILE) %d planck3.16 C BS: THE BLACKBODY INTENSITY AT EACH TILED SURFACE. C %d planck3.33,34 REAL BF(ILG,LEV), BF0(ILG), URBF(ILG,LAY), URBF0(ILG), 1 DBF(ILG,LAY), TFULL(ILG,LEV) REAL BST(ILG,NTILE), GTT(ILG,NTILE) INTEGER ITILE(ILG,NTILE) %d planck3.62,67 %i planck3.88 DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN DT = GTT(I,M) * RTSTAND - 1.0 BST(I,M) = EXP( XP(1,IB) + 1 DT * (XP(2,IB) + DT * (XP(3,IB) + 2 DT * (XP(4,IB) + DT * (XP(5,IB) + 3 DT * XP(6,IB) )))) ) END IF END DO ! I END DO ! M %d lwtran_mcica2.2,10 SUBROUTINE LWTRAN_MCICA2(FUT, FDT, 1 SLWF, TAUC, OMC, GC, FL, TAUAL, 2 TAUG, BF, BST, URBF, DBF, EM0T, 3 CLD, NCT, LEV1, CUT, MAXC, 4 ITILE, 5 IL1, IL2, ILG, LAY, LEV, 6 NTILE) C C * JUN 02,2015 - M.LAZARE/ NEW VERSION FOR GCM19: C * J.COLE: - ADD TILED RADIATION CALCULATIONS C * (IE "FUT","FDT"), UNDER CONTROL OF C * "ITILRAD". C * FEB 11,2009 - J.COLE. PREVIOUS VERSION LWTRAN_MCICA2 FOR GCM15H C * THROUGH GCM18: %i lwtran_mcica2.39 C FUT: TILED UPWARD INFRARED FLUX C C FDT: TILED DOWNWARD INFRARED FLUX C %d lwtran_mcica2.51 C BST: THE BLACKBODY INTENSITY FOR EACH TILED SURFACE. C %d lwtran_mcica2.56 C EM0T: SURFACE EMISSION FOR EACH TILED SURFACE C %d lwtran_mcica2.76 REAL FUT(ILG,NTILE,2,LEV), FDT(ILG,NTILE,2,LEV) %d lwtran_mcica2.80 3 URBF(ILG,LAY), DBF(ILG,LAY), %i lwtran_mcica2.81 REAL BST(ILG,NTILE), EM0T(ILG,NTILE) INTEGER ITILE(ILG,NTILE) %d lwtran_mcica2.89 REAL EMBST(ILG,NTILE), ABSE0T(ILG,NTILE) REAL FD(ILG,2,LEV), FU(ILG,2,LEV) %d lwtran_mcica2.107,111 DO K = LEV1,LEV DO M = 1, NTILE DO I = IL1, IL2 FDT(I,M,1,K) = 0.0 FUT(I,M,1,K) = 0.0 FDT(I,M,2,K) = 0.0 FUT(I,M,2,K) = 0.0 END DO ! I END DO ! M END DO ! K DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN EMBST(I,M) = EM0T(I,M) * BST(I,M) ABSE0T(I,M) = 1.0 - EM0T(I,M) END IF END DO ! I END DO ! M %d lwtran_mcica2.144,145 %i lwtran_mcica2.164 DO K = LEV1,LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FDT(I,M,1,K) = FD(I,1,K) END IF END DO ! I END DO ! M END DO ! K %d lwtran_mcica2.170,181 DO M = 1, NTILE DO I = IL1,IL2 IF (ITILE(I,M) .GT. 0) THEN FUT(I,M,1,LEV) = EMBST(I,M) + ABSE0T(I,M)*FDT(I,M,1,LEV) END IF END DO ! I END DO ! M DO K = LEV-1, L1, -1 KP1 = K+1 DO M = 1, NTILE DO I = IL1,IL2 IF (ITILE(I,M) .GT. 0) THEN FUT(I,M,1,K) = FUT(I,M,1,KP1) * DTR(I,1,K) + 1 XU(I,1,K) END IF END DO ! I END DO ! M END DO ! K %i lwtran_mcica2.250 DO K = L1,LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FDT(I,M,2,K) = FD(I,2,K) END IF END DO ! I END DO ! M END DO ! K %d lwtran_mcica2.258,260 DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FUT(I,M,2,LEV) = EMBST(I,M) + ABSE0T(I,M)*FDT(I,M,2,LEV) END IF END DO ! I END DO ! M %d lwtran_mcica2.267,282 DO K = LEV - 1, MAXC, - 1 KP1 = K + 1 DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN IF (K .GE. NCT(I)) THEN IF (CLD(I,K) .LT. CUT) THEN FUT(I,M,2,K) = FUT(I,M,2,KP1) * DTR(I,1,K) + 1 XU(I,1,K) ELSE FUT(I,M,2,K) = FUT(I,M,2,KP1) * 1 (DTR(I,2,K) + SCATFW(I,K)) + 2 FDT(I,M,2,K) * SCATBK(I,K) + 3 SCATSM(I,2,K) + XU(I,2,K) ENDIF END IF END IF END DO ! I END DO ! M END DO ! K %d lwtran_mcica2.289,297 DO K = LEV - 1, L1, - 1 KP1 = K + 1 DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN IF (KP1 .LE. NCT(I)) THEN FUT(I,M,2,K) = FUT(I,M,2,KP1) * DTR(I,1,K) + 1 XU(I,1,K) ENDIF END IF END DO ! I END DO ! M END DO ! K %d lwtran_mcica2.303,318 DO K = MAXC + 1, LEV KM1 = K - 1 DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN IF (KM1 .GE. NCT(I)) THEN IF (CLD(I,KM1) .LT. CUT) THEN FDT(I,M,2,K) = FDT(I,M,2,KM1) * DTR(I,1,KM1) + 1 XD(I,1,KM1) ELSE FDT(I,M,2,K) = FDT(I,M,2,KM1) * 1 (DTR(I,2,KM1) + SCATFW(I,KM1)) + 2 FUT(I,M,2,K) * SCATBK(I,KM1) + 3 SCATSM(I,1,KM1) + XD(I,2,KM1) ENDIF ENDIF END IF END DO ! I END DO ! M END DO ! K %d lwtragh4.2,6 SUBROUTINE LWTRAGH4(FUT, FDT, 1 SLWF, TAUCI, OMCI, TAUAL, TAUG, BF, 2 URBF, CLD, EM0T, BST, ITILE, CUT, 3 IL1, IL2, ILG, LAY, LEV, 4 NTILE) C C * JUN 02,2015 - M.LAZARE/ NEW VERSION FOR GCM19: C * J.COLE: - ADD TILED RADIATION CALCULATIONS C * (IE "FUT","FDT") C * FEB 11,2009 - J.COLE. PREVIOUS VERSION LWTRAGH4 FOR GCM15H C * THROUGH GCM18: %d lwtragh4.32,33 C FUT: TILED UPWARD INFRARED FLUX C C FDT: TILED DOWNWARD INFRARED FLUX C %d lwtragh4.42 C BST: THE BLACKBODY INTENSITY FOR EACH TILED SURFACE. C %d lwtragh4.45 C EM0T: SURFACE EMISSION FOR EACH TILED SURFACE C %d lwtragh4.50,51 C FYT: UPWARD FLUX FOR PURE CLEAR PORTION (1) AND PURE CLOUD C C PORTION (2) FOR EACH TILE C %d lwtragh4.60 3 CLD(ILG,LAY) %d lwtragh4.61 REAL XU(ILG,2,LAY),XD(ILG,2,LAY),DTR(ILG,2,LAY), %i lwtragh4.62 REAL FUT(ILG,NTILE,2,LEV),FDT(ILG,NTILE,2,LEV), 1 FYT(ILG,NTILE,2,LEV) REAL EM0T(ILG,NTILE), BST(ILG,NTILE) INTEGER ITILE(ILG,NTILE) %d lwtragh4.203,251 DO K = 1, LEV DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FDT(I,M,1,K) = FD(I,1,K) FDT(I,M,2,K) = FD(I,2,K) END IF END DO ! I END DO ! M END DO ! K DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN EMBS = EM0T(I,M) * BST(I,M) ABSE0 = 1.0 - EM0T(I,M) FUT(I,M,1,LEV) = EMBS + ABSE0 * FDT(I,M,1,LEV) FYT(I,M,1,LEV) = EMBS + ABSE0 * FX(I,1,LEV) FYT(I,M,2,LEV) = EMBS + ABSE0 * FX(I,2,LEV) FUT(I,M,2,LEV) = FYT(I,M,1,LEV) + 1 CLD(I,LAY) * 2 (FYT(I,M,2,LEV) - FYT(I,M,1,LEV)) C FUT(I,M,1,LAY) = FUT(I,M,1,LEV) * DTR(I,1,LAY) + 1 XU(I,1,LAY) FYT(I,M,1,LAY) = FYT(I,M,1,LEV) * DTR(I,1,LAY) + 1 XU(I,1,LAY) C IF (CLD(I,LAY) .LT. CUT) THEN FYT(I,M,2,LAY) = FYT(I,M,2,LEV) * DTR(I,1,LAY) + 1 XU(I,1,LAY) FUT(I,M,2,LAY) = FYT(I,M,1,LAY) ELSE FYT(I,M,2,LAY) = FYT(I,M,2,LEV) * DTR(I,2,LAY) + 1 XU(I,2,LAY) FUT(I,M,2,LAY) = FYT(I,M,1,LAY) + 1 CLD(I,LAY) * 2 (FYT(I,M,2,LAY) - FYT(I,M,1,LAY)) ENDIF ENDIF END DO ! I END DO ! M C DO K = LEV - 2, 1, - 1 KP1 = K + 1 DO M = 1, NTILE DO I = IL1, IL2 IF (ITILE(I,M) .GT. 0) THEN FUT(I,M,1,K) = FUT(I,M,1,KP1) * DTR(I,1,K) + XU(I,1,K) C IF (CLD(I,K) .LT. CUT) THEN FUT(I,M,2,K) = FUT(I,M,2,KP1) * DTR(I,1,K) + 1 XU(I,1,K) FYT(I,M,1,K) = FUT(I,M,2,K) FYT(I,M,2,K) = FUT(I,M,2,K) ELSE IF (CLD(I,K) .LT. CLD(I,KP1)) THEN FYT(I,M,1,K) = (FYT(I,M,2,KP1) + (1.0 - CLD(I,KP1)) 1 / (1.0 - CLD(I,K)) * (FYT(I,M,1,KP1) 2 - FYT(I,M,2,KP1)) ) * DTR(I,1,K) 3 + XU(I,1,K) FYT(I,M,2,K) = FYT(I,M,2,KP1) * DTR(I,2,K) + 1 XU(I,2,K) ELSE FYT(I,M,1,K) = FYT(I,M,1,KP1) * DTR(I,1,K) + 1 XU(I,1,K) FYT(I,M,2,K) = (FYT(I,M,1,KP1) + CLD(I,KP1) 1 / CLD(I,K) 2 * (FYT(I,M,2,KP1) - FYT(I,M,1,KP1))) 3 * DTR(I,2,K) + XU(I,2,K) ENDIF C FUT(I,M,2,K) = FYT(I,M,1,K) + 1 CLD(I,K)*(FYT(I,M,2,K) - FYT(I,M,1,K)) ENDIF ENDIF END DO ! I END DO ! M END DO ! K #/////////////////////////////////////////////////////////////////////// #/ Start updates to get the tiling input, using the tiling information #/ or outputing tiled radiation. #/////////////////////////////////////////////////////////////////////// # Not sure about these updates. Likly overlap with what is currently # in the basefile. #/////////////////////////////////////////////////////////////////////// #/ End updates to get the tiling input, using the tiling information #/ or outputing tiled radiation. #/////////////////////////////////////////////////////////////////////// #/////////////////////////////////////////////////////////////////////// %id ctem_bugfixes %d allcar.2 SUBROUTINE ALLCAR(LFSTATUS, THLIQ, AILCG, %d allcar.34 %d allcar.74 REAL AILCG(ILG,ICC), THLIQ(ILG,IG), %d allcar.176,200 DO 140 J = 1,ICC DO 150 I = IL1, IL2 AFRLEAF(I,J)=0.0 !ALLOCATION FRACTION FOR LEAVES AFRSTEM(I,J)=0.0 !ALLOCATION FRACTION FOR STEM AFRROOT(I,J)=0.0 !ALLOCATION FRACTION FOR ROOT C ALEAF(I,J)=0.0 !TEMPORARY VARIABLE ASTEM(I,J)=0.0 !TEMPORARY VARIABLE AROOT(I,J)=0.0 !TEMPORARY VARIABLE C C !AVERAGED OVER THE ROOT ZONE AVWILTSM(I,J)=0.0 !WILTING POINT SOIL MOISTURE AFIELDSM(I,J)=0.0 !FIELD CAPACITY SOIL MOISTURE AVTHLIQ(I,J)=0.0 !LIQUID SOIL MOISTURE CONTENT C WTSTATUS(I,J)=0.0 !WATER STATUS LTSTATUS(I,J)=0.0 !LIGHT STATUS NSTATUS(I,J)=0.0 !NITROGEN STATUS, IF AND WHEN WE C !WILL HAVE N CYCLE IN THE MODEL WNSTATUS(I,J)=0.0 !MIN. OF WATER & N STATUS C MNSTRTMS(I,J)=0.0 !MIN. (STEM+ROOT) BIOMASS NEEDED TO C !SUPPORT LEAVES 150 CONTINUE 140 CONTINUE %d disturb.146 5 RMATCTEM(ILG,ICC,IG), THICE(ILG,IG), POPDIN(ILG), %d disturb.633 PRBFRHUC(I)=MIN(1.0,(POPDIN(I)/POPDTHRSHLD)**0.43) %d disturb.726 EXTNPROB(I)=MAX(0.0,0.9-EXP(-0.025*POPDIN(I))) %id ctem_in_class %DECK CTEM SUBROUTINE CTEM( FCANCMX, FSNOW, SAND, CLAY, 2 IC, ILG, IL1, IL2, 3 IG, ICC, IDAY, RADJ, 4 TCANO, TCANS, TBARC, TBARCS, 5 TBARG, TBARGS, TA, DELZW, 6 ANCSVEG, ANCGVEG, RMLCSVEG, RMLCGVEG, 7 ZBOTW, THLIQC, THLIQG, DELTAT, 8 VMOD, LIGHTNG, PRBFRHUC, 9 EXTNPROB, TBAR, L2MAX, A NOL2PFTS, PFCANCMX, NFCANCMX, LNDUSEON, B THICEC, SOILDPTH, SPINFAST, TODFRAC, C WETFRAC,WETFRAC_S, POPDIN, DOFIRE, D ISAND, AREA, C C -------------- INPUTS USED BY CTEM ARE ABOVE THIS LINE --------- C C STEMMASS, ROOTMASS, LITRMASS, GLEAFMAS, D BLEAFMAS, SOILCMAS, AILCG, AILC, E ZOLNC, RMATCTEM, RMATC, AILCB, F FLHRLOSS, PANDAYS, LFSTATUS, GRWTHEFF, G LYSTMMAS, LYROTMAS, TYMAXLAI, VGBIOMAS, H GAVGLTMS, GAVGSCMS, STMHRLOS, SLAI, I BMASVEG, CMASVEGC, COLDDAYS, ROTHRLOS, J FCANMX, ALVISC, ALNIRC, GAVGLAI, K GAVGLFMS, GAVGRTMS, GAVGSTMS, C C -------------- INPUTS UPDATED BY CTEM ARE ABOVE THIS LINE ------ C L NPP, NEP, HETRORES, AUTORES, M SOILRESP, RM, RG, NBP, N LITRES, SOCRES, GPP, DSTCEMLS1, O LITRFALL, HUMIFTRS, VEGHGHT, ROOTDPTH, P RML, RMS, RMR, TLTRLEAF, Q TLTRSTEM, TLTRROOT, LEAFLITR, ROOTTEMP, R BURNFRAC, PROBFIRE, LUCEMCOM, LUCLTRIN, S LUCSOCIN, DSTCEMLS3, GAVGNPLF, GAVGNPST, T GAVGNPRT, CH4WET1, CH4WET2, WETFDYN, U CH4DYN1, CH4DYN2, PAICGAT, SLAICGAT) C C ---------------- OUTPUTS ARE LISTED ABOVE THIS LINE ------------ C C C CANADIAN TERRESTRIAL ECOSYSTEM MODEL (CTEM) - V1.1 incomplete C C C 15 JUL 2016 - REMOVED UNUSED "CURLATNO". C 12 MAR 2015 - REMOVE ALL CODE RELATED TO CALCULATION OF GRCLAREA C M. LAZARE AND PASS IN "AREA" ARRAY WHICH HAS ALREADY BEEN C CALCULATED IN THE AGCM PHYSICS WRAPPER. C - "STDALN" OPTION REMOVED. C 31 OCT 2015 - INPUT {UWIND,VWIND} REPLACED BY VMOD IN CONJUNCTION C M. LAZARE WITH OTHER CHANGES TO USE PROPER WIND MAGNITUDE C AND NOT STRESSES. SEE ALSO ROUTINE "DISTURB". C 19 SEP. 2001 - THIS IS THE MAIN TERRESTRIAL CARBON MODEL SUBROUTINE C V. ARORA C ALL PRIMARY CTEM SUBROUTINES ARE CALLED FROM HERE, C EXCEPT PHTSYN WHICH IS CALLED FROM TSOLVC C C ----------------------------------------------------------------- C C INPUTS C C FCANCMX - MAX. FRACTIONAL COVERAGE OF CTEM's 9 PFTs, BUT THIS CAN BE C MODIFIED BY LAND-USE CHANGE, AND COMPETITION BETWEEN PFTs C FSNOW - FRACTION OF SNOW SIMULATED BY CLASS C SAND - PERCENTAGE SAND C CLAY - PERCENTAGE CLAY C AREA - FRACTION AREA OF LAND (FOR ROUTINE DISTURB, IE FOR FIRE) C ICC - NO OF PFTs FOR USE BY CTEM, CURRENTLY 9 C IC - NO OF PFTs FOR USE BY CLASS, CURRENTLY 4 C IG - NO. OF SOIL LAYERS, 3 C ILG - NO. OF GRID CELLS IN LATITUDE CIRCLE C IL1,IL2 - IL1=1, IL2=ILG C IDAY - DAY OF YEAR C RADJ - LATITUDE IN RADIANS C TCANO - CANOPY TEMPERATURE FOR CANOPY OVER GROUND SUBAREA, K C TCANS - CANOPY TEMPERATURE FOR CANOPY OVER SNOW SUBAREA C TBARC - SOIL TEMPERATURE FOR CANOPY OVER GROUND SUBAREA, K C TBARCS - SOIL TEMPERATURE FOR CANOPY OVER SNOW SUBAREA C TBARG - SOIL TEMPERATURE FOR GROUND SUBAREA C TBARGS - SOIL TEMPERATURE FOR SNOW OVER GROUND SUBAREA C TA - AIR TEMPERATURE, K C ANCSVEG - NET PHOTOSYNTHETIC RATE FOR CTEMs 9 PFTs FOR C CANOPY OVER SNOW SUBAREA C ANCGVEG - NET PHOTOSYNTHETIC RATE FOR CTEMs 9 PFTs FOR C CANOPY OVER GROUND SUBAREA C RMLCSVEG - LEAF RESPIRATION RATE FOR CTEMs 9 PFTs FOR C CANOPY OVER SNOW SUBAREA C RMLCGVEG - LEAF RESPIRATION RATE FOR CTEMs 9 PFTs FOR C CANOPY OVER GROUND SUBAREA C DELZW - THICKNESSES OF THE 3 SOIL LAYERS C ZBOTW - BOTTOM OF SOIL LAYERS C THLIQC - LIQUID MOIS. CONTENT OF 3 SOIL LAYERS, FOR CANOPY C OVER SNOW AND CANOPY OVER GROUND SUBAREAS C THLIQG - LIQUID MOIS. CONTENT OF 3 SOIL LAYERS, FOR GROUND C AND SNOW OVER GROUND SUBAREAS C DELTAT - CTEM TIME STEP IN DAYS C VMOD - WIND SPEED, M/S C LIGHTNG - TOTAL LIGHTNING FREQUENCY, FLASHES/KM2.YEAR C PRBFRHUC - PROBABILITY OF FIRE DUE TO HUMAN CAUSES C EXTNPROB - FIRE EXTINGUSINGING PROBABILITY C TBAR - SOIL TEMPERATURE, K C L2MAX - MAX. NUMBER OF LEVEL 2 CTEM PFTs C NOL2PFTS - NUMBER OF LEVEL 2 CTEM PFTs C PFCANCMX - PREVIOUS YEAR's FRACTIONAL COVERAGES OF PFTs C NFCANCMX - NEXT YEAR's FRACTIONAL COVERAGES OF PFTs C LNDUSEON - INTEGER SWITCH TO RUN THE LAND USE CHANGE SUBROUTINE C OR NOT. =1 MEANS YES. C THICEC - FROZEN MOIS. CONTENT OF 3 SOIL LAYERS, FOR CANOPY C OVER SNOW AND CANOPY OVER GROUND SUBAREAS C SOILDPTH - SOIL DEPTH (M) C SPINFAST - SPINUP FACTOR FOR SOIL CARBON WHOSE DEFAULT VALUE IS C 1. AS THIS FACTOR INCREASES THE SOIL C POOL WILL COME C INTO EQUILIBRIUM FASTER. REASONABLE VALUE FOR SPINFAST C IS BETWEEN 5 AND 10. WHEN SPINFAST.NE.1 THEN THE C BALCAR SUBROUTINE IS NOT RUN. C TODFRAC - MAX. FRACTIONAL COVERAGE OF CTEM's 9 PFTs BY THE END C OF THE DAY, FOR USE BY LAND USE SUBROUTINE C WETFRAC - SPECIFIED CONSTANT WETLAND FRACTION FOR NOW READ C FROM A FILE C WETFRAC_S - SLOPE BASED WETLAND FRACTION FOR ESTIMATING DYNAMIC C WETLAND FRACTION C POPDIN - POPULATION DENSITY (PEOPLE / KM^2) C C UPDATES C C STEMMASS - STEM MASS FOR EACH OF THE 9 CTEM PFTs, Kg C/M2 C ROOTMASS - ROOT MASS FOR EACH OF THE 9 CTEM PFTs, Kg C/M2 C GLEAFMAS - GREEN LEAF MASS FOR EACH OF THE 9 CTEM PFTs, Kg C/M2 C BLEAFMAS - BROWN LEAF MASS FOR EACH OF THE 9 CTEM PFTs, Kg C/M2 C LITRMASS - LITTER MASS FOR EACH OF THE 9 CTEM PFTs + BARE, Kg C/M2 C SOILCMAS - SOIL CARBON MASS FOR EACH OF THE 9 CTEM PFTs C + BARE, Kg C/M2 C AILCG - GREEN LAI FOR CTEM's 9 PFTs C AILC - LUMPED LAI FOR CLASS' 4 PFTs C ZOLNC - LUMPED LOG OF ROUGHNESS LENGTH FOR CLASS' 4 PFTs C RMATCTEM - FRACTION OF ROOTS FOR EACH OF CTEM's 9 PFTs IN EACH C SOIL LAYER C RMATC - FRACTION OF ROOTS FOR EACH OF CLASS' 4 PFTs IN EACH C SOIL LAYER C AILCB - BROWN LAI FOR CTEM's 9 PFTs. FOR NOW WE ASSUME ONLY C GRASSES CAN HAVE BROWN LAI C FLHRLOSS - FALL OR HARVEST LOSS FOR DECIDUOUS TREES AND CROPS, C RESPECTIVELY, Kg C/M2 C PANDAYS - DAYS WITH POSITIVE NET PHOTOSYNTHESIS (An) FOR USE IN C THE PHENOLOGY SUBROUTINE C LFSTATUS - LEAF PHENOLOGY STATUS C GRWTHEFF - GROWTH EFFICIENCY. CHANGE IN BIOMASS PER YEAR PER C UNIT MAX. LAI (Kg C/M2)/(M2/M2), FOR USE IN MORTALITY C SUBROUTINE C LYSTMMAS - STEM MASS AT THE END OF LAST YEAR C LYROTMAS - ROOT MASS AT THE END OF LAST YEAR C TYMAXLAI - THIS YEAR's MAXIMUM LAI C VGBIOMAS - GRID AVERAGED VEGETATION BIOMASS, Kg C/M2 C GAVGLTMS - GRID AVERAGED LITTER MASS, Kg C/M2 C GAVGSCMS - GRID AVERAGED SOIL C MASS, Kg C/M2 C STMHRLOS - STEM HARVEST LOSS FOR CROPS, Kg C/M2 C SLAI - STORAGE/IMAGINARY LAI FOR PHENOLOGY PURPOSES C BMASVEG - TOTAL (GLEAF + STEM + ROOT) BIOMASS FOR EACH CTEM PFT, Kg C/M2 C CMASVEGC - TOTAL CANOPY MASS FOR EACH OF THE 4 CLASS PFTs. RECALL THAT C CLASS REQUIRES CANOPY MASS AS AN INPUT, AND THIS IS NOW C PROVIDED BY CTEM. KG/M2. C COLDDAYS - COLD DAYS COUNTER FOR TRACKING DAYS BELOW A CERTAIN C TEMPERATURE THRESHOLD FOR NDL DCD AND CROP PFTs. C ROTHRLOS - ROOT DEATH AS CROPS ARE HARVESTED, Kg C/M2 C FCANMX - FRACTIONAL COVERAGE OF CLASS' 4 PFTs C ALVISC - VISIBLE ALBEDO FOR CLASS' 4 PFTs C ALNIRC - NEAR IR ALBEDO FOR CLASS' 4 PFTs C GAVGLAI - GRID AVERAGED GREEN LEAF AREA INDEX C GAVGLFMS - GRID AVERAGED GREEN LEAF MASS, Kg C/M2 C GAVGSTMS - GRID AVERAGED STEM MASS, Kg C/M2 C GAVGRTMS - GRID AVERAGED ROOT MASS, Kg C/M2 C C C OUTPUTS C GRID-AVERAGED FLUXES IN u-MOL CO2/M2.SEC C C NPP - NET PRIMARY PRODUCTIVITY C NEP - NET ECOSYSTEM PRODUCTIVITY C HETRORES - HETEROTROPHIC RESPIRATION C AUTORES - AUTOTROPHIC RESPIRATION C SOILRESP - SOIL RESPIRATION. THIS INCLUDES ROOT RESPIRATION C AND RESPIRATION FROM LITTER AND SOIL CARBON POOLS. C NOTE THAT SOILRESP IS DIFFERENT FROM SOCRES, WHICH IS C RESPIRATION FROM THE SOIL C POOL. C RM - MAINTENANCE RESPIRATION C RG - GROWTH RESPIRATION C NBP - NET BIOME PRODUCTIVITY C GPP - GROSS PRIMARY PRODUCTIVITY C LITRES - LITTER RESPIRATION C SOCRES - SOIL CARBON RESPIRATION C DSTCEMLS1- CARBON EMISSION LOSSES DUE TO DISTURBANCE (FIRE AT PRESENT) C FROM VEGETATION C LITRFALL - TOTAL LITTER FALL (FROM LEAVES, STEM, AND ROOT) DUE C TO ALL CAUSES (MORTALITY, TURNOVER, AND DISTURBANCE) C HUMIFTRS - TRANSFER OF HUMIDIFIED LITTER FROM LITTER TO SOIL C C POOL C LUCEMCOM - LAND USE CHANGE (LUC) RELATED COMBUSTION EMISSION LOSSES, C u-MOL CO2/M2.SEC C LUCLTRIN - LUC RELATED INPUTS TO LITTER POOL, u-MOL CO2/M2.SEC C LUCSOCIN - LUC RELATED INPUTS TO SOIL C POOL, u-MOL CO2/M2.SEC C DSTCEMLS3- CARBON EMISSION LOSSES DUE TO DISTURBANCE (FIRE AT PRESENT) C FROM LITTER POOL C GAVGNPLF - GRID AVERAGED NPP OF LEAVES, u-MOL CO2/M2.SEC C GAVGNPST - GRID AVERAGED NPP OF STEM, u-MOL CO2/M2.SEC C GAVGNPRT - GRID AVERAGED NPP OF ROOTS, u-MOL CO2/M2.SEC C CH4WET1 - WETLAND CH4 EMISSIONS u-MOL CH4-C/M2.SEC (HETRORES) C CH4WET2 - WETLAND CH4 EMISSIONS u-MOL CH4-C/M2.SEC (NPP) C WETFDYN - DYNAMIC GRIDCELL WETLAND FRACTION DETERMINED USING C SLOPE AND SOIL MOISTURE C CH4DYN1 - WETLAND CH4 EMISSIONS u-MOL CH4-C/M2.SEC (HETRORES & WETFDYN) C CH4DYN2 - WETLAND CH4 EMISSIONS u-MOL CH4-C/M2.SEC (NPP & WETFDYN) C OTHER QUANTITIES C C VEGHGHT - VEGETATION HEIGHT (METERS) C ROOTDPTH - 99% SOIL ROOTING DEPTH (METERS) C BOTH VEGHGHT & ROOTDPTH CAN BE USED AS DIAGNOSTICS TO SEE C HOW VEGETATION GROWS ABOVE AND BELOW GROUND, RESPECTIVELY C RML - LEAF MAINTENANCE RESPIRATION (u-MOL CO2/M2.SEC) C RMS - STEM MAINTENANCE RESPIRATION (u-MOL CO2/M2.SEC) C RMR - ROOT MAINTENANCE RESPIRATION (u-MOL CO2/M2.SEC) C TLTRLEAF - TOTAL LEAF LITTER FALL RATE (u-MOL CO2/M2.SEC) C TLTRSTEM - TOTAL STEM LITTER FALL RATE (u-MOL CO2/M2.SEC) C TLTRROOT - TOTAL ROOT LITTER FALL RATE (u-MOL CO2/M2.SEC) C LEAFLITR - LEAF LITTER FALL RATE (u-MOL CO2/M2.SEC). THIS LEAF LITTER C DOES NOT INCLUDE LITTER GENERATED DUE TO MORTALITY/FIRE C ROOTTEMP - ROOT TEMPERATURE, K C AFRLEAF - ALLOCATION FRACTION FOR LEAVES C AFRSTEM - ALLOCATION FRACTION FOR STEM C AFRROOT - ALLOCATION FRACTION FOR ROOT C WTSTATUS - SOIL WATER STATUS USED FOR CALCULATING ALLOCATION FRACTIONS C LTSTATUS - LIGHT STATUS USED FOR CALCULATING ALLOCATION FRACTIONS C BURNAREA - AREA BURNED DUE TO FIRE FOR EVERY GRID CELL, KM2 C PROBFIRE - PROBABILITY OF FIRE FOR EVERY GRID CELL C IMPLICIT NONE C INTEGER KK PARAMETER(KK=12) ! PRODUCT OF CLASS PFTs AND L2MAX (4 x 3 = 12) C LOGICAL DOFIRE, DO_MORTALITY INTEGER IC, ICC, ILG, IL1, IL2, IG, 1 IDAY, I, J, K, 2 ICHECK, ICOUNT, N, M, SORT(ICC), L2MAX, 3 NOL2PFTS(IC), K1, K2, LNDUSEON, SPINFAST C INTEGER PANDAYS(ILG,ICC), COLDDAYS(ILG,2), 1 LFSTATUS(ILG,ICC), ISAND(ILG,IG) C REAL FSNOW(ILG), SAND(ILG,IG), CLAY(ILG,IG), THLIQC(ILG,IG), 1 TCANO(ILG), TCANS(ILG), TBARC(ILG,IG), RMATC(ILG,IC,IG), 2 ZBOTW(ILG,IG), RML(ILG), GPP(ILG), FCANCMX(ILG,ICC), 3 TBARCS(ILG,IG), TBARG(ILG,IG),TBARGS(ILG,IG), THLIQG(ILG,IG), 4 RADJ(ILG), TA(ILG), DELTAT, DELZW(ILG,IG), 5 TBAR(ILG,IG),THICEC(ILG,IG), SOILDPTH(ILG), TODFRAC(ILG,ICC), 6 YESFRAC(ILG,ICC) C REAL STEMMASS(ILG,ICC), ROOTMASS(ILG,ICC), LITRMASS(ILG,ICC+1), 1 GLEAFMAS(ILG,ICC), BLEAFMAS(ILG,ICC), SOILCMAS(ILG,ICC+1), 2 ANCSVEG(ILG,ICC), ANCGVEG(ILG,ICC), RMLCSVEG(ILG,ICC), 3 RMLCGVEG(ILG,ICC), AILCG(ILG,ICC), AILC(ILG,IC), 4 RMATCTEM(ILG,ICC,IG), ZOLNC(ILG,IC), AILCB(ILG,ICC), 5 VGBIOMAS(ILG), GAVGLTMS(ILG), GAVGSCMS(ILG), 6 SLAI(ILG,ICC), BMASVEG(ILG,ICC), CMASVEGC(ILG,IC), 7 VEGHGHT(ILG,ICC), ROOTDPTH(ILG,ICC), GPPCSVEG(ILG,ICC), 8 GPPCGVEG(ILG,ICC), PFCANCMX(ILG,ICC), FCANMX(ILG,IC), 9 NFCANCMX(ILG,ICC), ALVISC(ILG,IC), ALNIRC(ILG,IC), A GAVGLAI(ILG), GAVGLFMS(ILG), GAVGSTMS(ILG), B GAVGRTMS(ILG) C REAL NPP(ILG), NEP(ILG), HETRORES(ILG), AUTORES(ILG), 1 SOILRESP(ILG), RM(ILG), RG(ILG), NBP(ILG), 2 DSTCEMLS1(ILG), LITRFALL(ILG), HUMIFTRS(ILG), GALTCELS(ILG), 3 DSTCEMLS2(ILG), LUCEMCOM(ILG), LUCLTRIN(ILG), LUCSOCIN(ILG), 4 DSTCEMLS3(ILG) C REAL FC(ILG), FG(ILG), FCS(ILG), FGS(ILG), 1 FCANS(ILG,IC), FCAN(ILG,IC), ZERO, RMS(ILG), 2 RMR(ILG), GRESCOEF(KK), LITRES(ILG), SOCRES(ILG), 3 HUMICFAC(KK), KN(KK), 4 TERM, ETA(KK), KAPPA(KK), LFESPANY(KK), 5 FRACBOFG, SPECSLA(KK) C REAL PGLFMASS(ILG,ICC), PBLFMASS(ILG,ICC), PSTEMASS(ILG,ICC), 1 PROTMASS(ILG,ICC), PLITMASS(ILG,ICC+1), PSOCMASS(ILG,ICC+1), 2 PVGBIOMS(ILG), PGAVLTMS(ILG), PGAVSCMS(ILG) C REAL FCANCS(ILG,ICC), FCANC(ILG,ICC), RMSCGVEG(ILG,ICC), 1 RMSCSVEG(ILG,ICC), RMRCGVEG(ILG,ICC), RMRCSVEG(ILG,ICC), 2 RMSVEG(ILG,ICC), RMRVEG(ILG,ICC), ANVEG(ILG,ICC), 3 RMLVEG(ILG,ICC), GPPVEG(ILG,ICC), NPPVEG(ILG,ICC), 4 RGVEG(ILG,ICC), RMVEG(ILG,ICC), NEPVEG(ILG,ICC), 5 RTTEMPCS(ILG,ICC), RTTEMPCG(ILG,ICC), NBPVEG(ILG,ICC), 6 PHEANVEG(ILG,ICC), PANCSVEG(ILG,ICC), PANCGVEG(ILG,ICC) C REAL LTRSVGCS(ILG,ICC), LTRSVGCG(ILG,ICC), SCRSVGCS(ILG,ICC), 1 SCRSVGCG(ILG,ICC), LTRESVEG(ILG,ICC+1), SCRESVEG(ILG,ICC+1), 2 LTRSBRG(ILG), SCRSBRG(ILG), LTRSBRGS(ILG), 3 SCRSBRGS(ILG), HETRSVEG(ILG,ICC+1), HUMTRSVG(ILG,ICC+1), 4 SOILRSVG(ILG,ICC+1) C REAL LTRESTEP(ILG,ICC+1),SCRESTEP(ILG,ICC+1), HUTRSTEP(ILG,ICC+1) C REAL ROOTTEMP(ILG,ICC), TBARCCS(ILG,IG), LEAFLITR(ILG,ICC), 1 FIELDSM(ILG,IG), FLHRLOSS(ILG,ICC), WILTSM(ILG,IG) C REAL ROOTLITR(ILG,ICC), STEMLITR(ILG,ICC), STMHRLOS(ILG,ICC), 1 ROTHRLOS(ILG,ICC) C REAL AFRLEAF(ILG,ICC), AFRSTEM(ILG,ICC), AFRROOT(ILG,ICC), 1 WTSTATUS(ILG,ICC), LTSTATUS(ILG,ICC) C REAL NPPVGSTP(ILG,ICC), RMLVGSTP(ILG,ICC), RMSVGSTP(ILG,ICC), 1 RMRVGSTP(ILG,ICC), GPPVGSTP(ILG,ICC), NTCHLVEG(ILG,ICC), 2 NTCHSVEG(ILG,ICC), NTCHRVEG(ILG,ICC) C REAL NPPLEAF(ILG,ICC), NPPSTEM(ILG,ICC), NPPROOT(ILG,ICC) REAL GAVGNPLF(ILG), GAVGNPST(ILG), GAVGNPRT(ILG) C REAL GRWTHEFF(ILG,ICC), LYSTMMAS(ILG,ICC), LYROTMAS(ILG,ICC), 1 TYMAXLAI(ILG,ICC), STEMLTRM(ILG,ICC), ROOTLTRM(ILG,ICC), 2 GLEALTRM(ILG,ICC), GEREMORT(ILG,ICC), INTRMORT(ILG,ICC) C REAL CURRLAT(ILG), AREA(ILG), GRCLAREA(ILG) C REAL VMOD(ILG), LIGHTNG(ILG), 1 PRBFRHUC(ILG), EXTNPROB(ILG), PFTAREAB(ILG,ICC), 2 STEMLTDT(ILG,ICC), ROOTLTDT(ILG,ICC), GLFLTRDT(ILG,ICC), 3 BLFLTRDT(ILG,ICC), GLCAEMLS(ILG,ICC), BLCAEMLS(ILG,ICC), 4 RTCAEMLS(ILG,ICC), STCAEMLS(ILG,ICC), LTRCEMLS(ILG,ICC), 5 PFTAREAA(ILG,ICC), BURNFRAC(ILG), DSCEMLV1(ILG,ICC), 6 DSCEMLV2(ILG,ICC), PROBFIRE(ILG), BURNVEG(ILG,ICC) C REAL EMIT_CO2(ILG), EMIT_CO(ILG), EMIT_CH4(ILG), 1 EMIT_NMHC(ILG), EMIT_H2(ILG), EMIT_NOX(ILG), 2 EMIT_N2O(ILG), EMIT_PM25(ILG), EMIT_TPM(ILG), 3 EMIT_TC(ILG), EMIT_OC(ILG), EMIT_BC(ILG) C REAL TLTRLEAF(ILG,ICC), TLTRSTEM(ILG,ICC), TLTRROOT(ILG,ICC) C REAL PAICGAT(ILG,IC), SLAICGAT(ILG,IC), POPDIN(ILG) C REAL WETFRAC(ILG), CH4WET1(ILG), CH4WET2(ILG) REAL WETFRAC_S(ILG), WETFDYN(ILG) REAL CH4DYN1(ILG), CH4DYN2(ILG) C COMMON /CTEM1/ ETA, KAPPA, KN COMMON /CTEM2/ LFESPANY, FRACBOFG, SPECSLA C --------------------------------------------------------------- C CONSTANTS AND PARAMETERS C C NOTE THE STRUCTURE OF VECTORS WHICH CLEARLY SHOWS THE CLASS C PFTs (ALONG ROWS) AND CTEM SUB-PFTs (ALONG COLUMNS) C C NEEDLE LEAF | EVG DCD --- C BROAD LEAF | EVG DCD-CLD DCD-DRY C CROPS | C3 C4 --- C GRASSES | C3 C4 --- C C GROWTH RESPIRATION COEFFICIENT DATA GRESCOEF/0.15, 0.15, 0.00, & 0.15, 0.15, 0.15, & 0.15, 0.15, 0.00, & 0.15, 0.15, 0.00/ C C HUMIFICATION FACTOR - USED FOR TRANSFERRING CARBON FROM LITTER INTO C SOIL C POOL DATA HUMICFAC/0.42, 0.42, 0.00, & 0.53, 0.48, 0.48, C & 0.42, 0.42, 0.00, & 0.10, 0.10, 0.00, & 0.42, 0.42, 0.00/ C C CANOPY LIGHT/NITROGEN EXTINCTION COEFFICIENT DATA KN/0.50, 0.50, 0.00, & 0.50, 0.50, 0.50, & 0.40, 0.48, 0.00, & 0.46, 0.44, 0.00/ C C ETA AND KAPPA, PARAMETERS FOR ESTIMATING MIN. STEM+ROOT BIOMASS C REQUIRED TO SUPPORT GREEN LEAF BIOMASS. KAPPA IS 1.6 FOR TREES C AND CROPS, AND 1.2 FOR GRASSES. DATA ETA/10.0, 30.8, 0.00, & 31.0, 50.0, 30.0, & 7.0, 7.0, 0.00, & 3.0, 3.0, 0.00/ DATA KAPPA/1.6, 1.6, 0.0, & 1.6, 1.6, 1.6, & 1.6, 1.6, 0.0, & 1.2, 1.2, 0.0/ C C LEAF LIFE SPAN (IN YEARS) FOR CTEM's 9 PFTs DATA LFESPANY/5.0, 1.00, 0.00, & 1.75, 1.00, 1.00, & 1.75, 1.75, 0.00, & 1.00, 1.00, 0.00/ C C CTEM CAN USE USER-SPECIFIED SPECIFIC LEAF AREAS (SLA) IF THE C FOLLOWING SPECIFIED VALUES ARE GREATER THAN ZERO C DATA SPECSLA/11.0, 0.0, 0.0, & 0.0, 0.0, 0.0, & 0.0, 0.0, 0.0, & 0.0, 0.0, 0.0/ C C FRACBOFG, PARAMETER USED TO ESTIMATE LAI OF BROWN LEAVES. WE C ASSUME THAT SLA OF BROWN LEAVES IS THIS FRACTION OF SLA OF C GREEN LEAVES DATA FRACBOFG/0.55/ C REAL, PARAMETER :: PI=3.1415926535898d0 C C RADIUS OF EARTH, KM REAL, PARAMETER :: EARTHRAD=6371.22 C C ZERO DATA ZERO/1E-20/ C C ----------------------------------------------------------------- C IF(ICC.NE.9) CALL XIT('CTEM',-1) IF(IC.NE.4) CALL XIT('CTEM',-2) IF(DELTAT.NE.1.0) CALL XIT('CTEM',-3) IF(L2MAX.NE.3) CALL XIT('CTEM',-4) C C FIND AREA OF THE GCM GRID CELLS. THIS IS NEEDED FOR LAND USE CHANGE C AND DISTURBANCE SUBROUTINES C NOTE THE CONVERSION TO KM^2 FROM M^2. THE FORMER IS USED FOR CTEM. C DO 50 I = IL1, IL2 CURRLAT(I)=RADJ(I)*180.0/PI GRCLAREA(I) = AREA(I)*1.E-6 50 CONTINUE C C ----------------------------------------------------------------- C C IF LANDUSE IS ON, THEN IMPLELEMENT LUC, CHANGE FRACTIONAL COVERAGES, C MOVE BIOMASSES AROUND, AND ESTIMATE LUC RELATED COMBUSTION EMISSION C LOSSES. C IF(LNDUSEON.EQ.1)THEN YESFRAC(:,:)=FCANCMX(:,:) CALL LUC( ICC, ILG, IL1, IL2, 1 IC, NOL2PFTS, L2MAX, 2 GRCLAREA, PFCANCMX, NFCANCMX, IDAY, 3 TODFRAC, YESFRAC, .FALSE., 4 GLEAFMAS, BLEAFMAS, STEMMASS, ROOTMASS, 5 LITRMASS, SOILCMAS, VGBIOMAS, GAVGLTMS, 6 GAVGSCMS, FCANCMX, FCANMX, 7 LUCEMCOM, LUCLTRIN, LUCSOCIN) ENDIF C C --------------------------------------------------------------- C C FIND PFT AREAS BEFORE (THESE ARE REQUIRED FOR DISTURB SUBROUTINE) C DO 82 J = 1, ICC DO 83 I = IL1, IL2 PFTAREAB(I,J)=GRCLAREA(I)*FCANCMX(I,J) ! AREA IN KM^2 83 CONTINUE 82 CONTINUE C C GENERATE THE SORT INDEX FOR CORRESPONDENCE BETWEEN 9 PFTs AND THE C 12 VALUES IN THE PARAMETER VECTORS C ICOUNT=0 DO 95 J = 1, IC DO 96 M = 1, NOL2PFTS(J) N = (J-1)*L2MAX + M ICOUNT = ICOUNT + 1 SORT(ICOUNT)=N 96 CONTINUE 95 CONTINUE C INITIALIZE REQUIRED ARRAYS TO ZERO C DO 100 I = IL1, IL2 RMS(I) = 0.0 !GRID AVE. STEM MAINTENANCE RESPIRATION RMR(I) = 0.0 !GRID AVE. ROOT MAINTENANCE RESPIRATION RML(I) = 0.0 !GRID AVE. LEAF MAINTENANCE RESPIRATION RM(I) = 0.0 !GRID AVE. TOTAL MAINTENANCE RESPIRATION RG(I) = 0.0 !GRID AVE. GROWTH RESPIRATION NPP(I) = 0.0 !GRID AVE. NET PRIMARY PRODUCTIVITY GPP(I) = 0.0 !GRID AVE. GROSS PRIMARY PRODUCTIVITY NEP(I)=0.0 !GRID AVE. NET ECOSYSTEM PRODUCTIVITY NBP(I)=0.0 !GRID AVE. NET BIOME PRODUCTIVITY C LITRES(I)=0.0 !GRID AVE. LITTER RESPIRATION SOCRES(I)=0.0 !GRID AVE. SOIL CARBON RESPIRATION C HETRORES(I)=0.0 !GRID AVE. HETEROTROPHIC RESPIRATION AUTORES(I)=0.0 !GRID AVE. AUTOTROPHIC RESPIRATION SOILRESP(I)=0.0 !GRID AVE. SOIL RESPIRATION HUMIFTRS(I)=0.0 !GRID AVE. HUMIFICATION RATE DSTCEMLS1(I)=0.0 !GRID AVE. CARBON EMISSION LOSSES DUE TO DISTURBANCE, VEGETATION DSTCEMLS2(I)=0.0 !GRID AVE. CARBON EMISSION LOSSES DUE TO DISTURBANCE, TOTAL DSTCEMLS3(I)=0.0 !GRID AVE. CARBON EMISSION LOSSES DUE TO DISTURBANCE, LITTER GALTCELS(I)=0.0 !GRID AVE. LITTER FIRE EMISSION LOSSES (REDUNDANT, SAME AS DSTCEMLS3) C FC(I)=0.0 !FRACTION OF CANOPY OVER GROUND SUBAREA FCS(I)=0.0 !FRACTION OF CANOPY OVER SNOW SUBAREA FG(I)=0.0 !FRACTION OF BARE GROUND SUBAREA FGS(I)=0.0 !FRACTION OF SNOW OVER GROUND SUBAREA C TBARCCS(I,1)=0.0 !AVG. SOIL TEMPERATURE OVER CANOPY OVER SNOW TBARCCS(I,2)=0.0 !AND CANOPY OVER GROUND SUBAREAS. TBARCCS(I,3)=0.0 C C OVER BARE FRACTION OF THE GRID CELL SCRESTEP(I,ICC+1)=0.0 !SOIL C RESPIRATION IN Kg C/M2 OVER THE TIME STEP LTRESTEP(I,ICC+1)=0.0 !LITTER C RESPIRATION IN Kg C/M2 OVER THE TIME STEP SOILRSVG(I,ICC+1)=0.0 !SOIL RESPIRATION OVER THE BARE FRACTION HUMTRSVG(I,ICC+1)=0.0 !HUMIFIED RATE THE BARE FRACTION C LTRESVEG(I,ICC+1)=0.0 !LITTER RESPIRATION RATE OVER BARE FRACTION SCRESVEG(I,ICC+1)=0.0 !SOIL C RESPIRATION RATE OVER BARE FRACTION HETRSVEG(I,ICC+1)=0.0 !HETEROTROPHIC RESP. RATE OVER BARE FRACTION 100 CONTINUE C DO 110 J = I,ICC DO 120 I = IL1, IL2 FCANC(I,J) =0.0 FCANCS(I,J)=0.0 C RMSVEG(I,J)=0.0 !STEM MAINTENANCE RESP. RATE FOR EACH PFT RMRVEG(I,J)=0.0 !ROOT MAINTENANCE RESP. RATE FOR EACH PFT RMLVEG(I,J)=0.0 !LEAF MAINTENANCE RESP. RATE FOR EACH PFT RMVEG(I,J)=0.0 !TOTAL MAINTENANCE RESP. RATE FOR EACH PFT RGVEG(I,J)=0.0 !GROWTH RESP. RATE FOR EACH PFT ANVEG(I,J)=0.0 !NET PHOTOSYNTHESIS RATE FOR EACH PFT PHEANVEG(I,J)=0.0 !NET PHOTOSYNTHESIS RATE, FOR PHENOLOGY PURPOSES PANCSVEG(I,J)=0.0 !NET PHOTOSYNTHESIS RATE, CANOPY OVER SNOW SUBAREA, FOR PHENOLOGY PURPOSES PANCGVEG(I,J)=0.0 !NET PHOTOSYNTHESIS RATE, CANOPY OVER GROUND SUBAREA, FOR PHENOLOGY PURPOSES C GPPVEG(I,J)=0.0 !GROSS PRIMARY PRODUCTITY FOR EACH PFT NPPVEG(I,J)=0.0 !NET PRIMARY PRODUCTITY FOR EACH PFT NBPVEG(I,J)=0.0 !NET BIOME PRODUCTITY FOR EACH PFT NEPVEG(I,J)=0.0 !NET ECOSYSTEM PRODUCTITY FOR EACH PFT C LTRESVEG(I,J)=0.0 !LITTER RESPIRATION RATE FOR EACH PFT SCRESVEG(I,J)=0.0 !SOIL C RESPIRATION RATE FOR EACH PFT HETRSVEG(I,J)=0.0 !HETEROTROPHIC RESP. RATE FOR EACH PFT SOILRSVG(I,J)=0.0 !SOIL RESPIRATION RATE FOR EACH PFT HUMTRSVG(I,J)=0.0 !HUMIFICATION RATE FOR EACH PFT SCRESTEP(I,J)=0.0 !SOIL C RESPIRATION IN Kg C/M2 OVER THE TIME STEP LTRESTEP(I,J)=0.0 !LITTER C RESPIRATION IN Kg C/M2 OVER THE TIME STEP HUTRSTEP(I,J)=0.0 !HUMIFICATION RATE IN Kg C/M2 OVER THE TIME STEP C ROOTTEMP(I,J)=0.0 !ROOT TEMPERATURE NPPVGSTP(I,J)=0.0 !NPP (Kg C/M2) SEQUESTERED OVER THE MODEL TIME STEP GPPVGSTP(I,J)=0.0 !GPP (Kg C/M2) SEQUESTERED OVER THE MODEL TIME STEP RMLVGSTP(I,J)=0.0 !LEAF MAINTENANCE RESP. (Kg C/M2) RESPIRED OVER THE MODEL TIME STEP RMSVGSTP(I,J)=0.0 !STEM MAINTENANCE RESP. (Kg C/M2) RESPIRED OVER THE MODEL TIME STEP RMRVGSTP(I,J)=0.0 !ROOT MAINTENANCE RESP. (Kg C/M2) RESPIRED OVER THE MODEL TIME STEP C NTCHLVEG(I,J)=0.0 !NET CHANGE IN GLEAF BIOMASS AFTER AUTO. RESP. & ALLOCATION NTCHSVEG(I,J)=0.0 !NET CHANGE IN STEM BIOMASS AFTER AUTO. RESP. & ALLOCATION NTCHRVEG(I,J)=0.0 !NET CHANGE IN ROOT BIOMASS AFTER AUTO. RESP. & ALLOCATION C DSCEMLV1(I,J)=0.0 !TOTAL CARBON EMISSION LOSSES (Kg C/M2), MAINLY DUE TO FIRE DSCEMLV2(I,J)=0.0 !TOTAL CARBON EMISSION LOSSES (Kg C/M2), MAINLY DUE TO FIRE C TLTRLEAF(I,J)=0.0 !TOTAL LEAF LITTER TLTRSTEM(I,J)=0.0 !TOTAL STEM LITTER TLTRROOT(I,J)=0.0 !TOTAL ROOT LITTER C NPPLEAF(I,J)= 0.0 ! NPP OF LEAVES NPPSTEM(I,J)= 0.0 ! NPP OF STEM NPPROOT(I,J)= 0.0 ! NPP OF ROOTS 120 CONTINUE 110 CONTINUE C C STORE GREEN AND BROWN LEAF, STEM, AND ROOT BIOMASS, AND LITTER AND C SOIL C POOL MASS IN ARRAYS. KNOWING INITIAL SIZES OF ALL POOLS AND C FINAL SIZES AT THE END OF THIS SUBROUTINE, WE CHECK FOR CONSERVATION C OF MASS. C DO 130 J = 1, ICC DO 140 I = IL1, IL2 PGLFMASS(I,J)=GLEAFMAS(I,J) !GREEN LEAF MASS FROM LAST TIME STEP PBLFMASS(I,J)=BLEAFMAS(I,J) !BROWN LEAF MASS FROM LAST TIME STEP PSTEMASS(I,J)=STEMMASS(I,J) !STEM MASS FROM LAST TIME STEP PROTMASS(I,J)=ROOTMASS(I,J) !ROOT MASS FROM LAST TIME STEP PLITMASS(I,J)=LITRMASS(I,J) !LITTER MASS FROM LAST TIME STEP PSOCMASS(I,J)=SOILCMAS(I,J) !SOIL C MASS FROM LAST TIME STEP 140 CONTINUE 130 CONTINUE C DO 145 I = IL1, IL2 PVGBIOMS(I)=VGBIOMAS(I) !VEGETATION BIOMASS FROM LAST TIME STEP VGBIOMAS(I)= 0.0 PGAVLTMS(I)=GAVGLTMS(I) !LITTER MASS FROM LAST TIME STEP GAVGLTMS(I)=0.0 PGAVSCMS(I)=GAVGSCMS(I) !SOIL C MASS FROM LAST TIME STEP GAVGSCMS(I)=0.0 LITRFALL(I)=0.0 !COMBINED TOTAL LITTER FALL RATE GAVGLAI (I)=0.0 !GRID AVERAGED GREEN LAI GAVGLFMS(I)=0.0 !GRID AVERAGED GREEN LEAF MASS GAVGSTMS(I)=0.0 !GRID AVERAGED STEM MASS GAVGRTMS(I)=0.0 !GRID AVERAGED ROOT MASS C PLITMASS(I,ICC+1)=LITRMASS(I,ICC+1) !LITTER MASS OVER BARE FRACTION PSOCMASS(I,ICC+1)=SOILCMAS(I,ICC+1) !SOIL C MASS OVER BARE FRACTION C GAVGNPLF(I) = 0.0 !GRID AVERAGED NPP OF LEAVES GAVGNPST(I) = 0.0 !GRID AVERAGED NPP OF STEM GAVGNPRT(I) = 0.0 !GRID AVERAGED NPP OF ROOTS 145 CONTINUE C C INITIALIZATION ENDS C C FIND FC AND FCS BASED ON FCANCMX C DO 150 J = 1, ICC DO 160 I = IL1, IL2 FCANCS(I,J) = FCANCMX(I,J)*FSNOW(I) FCANC(I,J) = FCANCMX(I,J)*(1.-FSNOW(I)) FCS(I) = FCS(I) + FCANCS(I,J) FC(I) = FC(I) + FCANC(I,J) 160 CONTINUE 150 CONTINUE C DO 170 I = IL1, IL2 FGS(I)=(1.0-FCS(I)-FC(I))*FSNOW(I) FG(I)=(1.0-FCS(I)-FC(I))*(1.0-FSNOW(I)) 170 CONTINUE C C ------------------------------------------------------------------ C C AUTOTROPHIC RESPIRATION PART STARTS C C LEAF RESPIRATION IS CALCULATED IN PHTSYN SUBROUTINE, WHILE STEM C AND ROOT MAINTENANCE RESPIRATION ARE CALCULATED HERE. C C WE TREAT CANOPY OVER GROUND AND CANOPY OVER SNOW SUBAREAS C SEPARATELY BECAUSE STEM TEMPERATURE (FOR WHICH WE USE CANOPY C TEMPERATURE AS A SURROGATE) CAN BE DIFFERENT FOR THESE TWO C SUBAREAS. C C FIND MAINTENANCE RESPIRATION FOR CANOPY OVER SNOW SUB-AREA C in uMOL CO2/M2/SEC C CALL MAINRES (FCANCS, FCS, STEMMASS, ROOTMASS, 1 ICC, IG, ILG, IL1, 2 IL2, TA, TBARCS, RMATCTEM, 3 SORT, NOL2PFTS, IC, ISAND, 4 RMSCSVEG, RMRCSVEG, RTTEMPCS) C C FIND MAINTENANCE RESPIRATION FOR CANOPY OVER GROUND SUB-AREA C CALL MAINRES ( FCANC, FC, STEMMASS, ROOTMASS, 1 ICC, IG, ILG, IL1, 2 IL2, TA, TBARC, RMATCTEM, 3 SORT, NOL2PFTS, IC, ISAND, 4 RMSCGVEG, RMRCGVEG, RTTEMPCG) C C C IF AILCG/GLEAFMAS IS ZERO, I.E. REAL LEAVES ARE NOT ON, THEN C MAKE MAINTENANCE RESPIRATION AND GPP FROM STORAGE/IMAGINARY LAI C EQUAL TO ZERO SO THAT WE DON'T USE THESE NUMBERS IN CARBON BUDGET. C DO 180 J = 1, ICC DO 190 I = IL1, IL2 GPPCSVEG(I,J)=ANCSVEG(I,J)+RMLCSVEG(I,J) GPPCGVEG(I,J)=ANCGVEG(I,J)+RMLCGVEG(I,J) C IF (LFSTATUS(I,J).EQ.4) THEN RMLCGVEG(I,J)=0.0 RMLCSVEG(I,J)=0.0 PANCSVEG(I,J)=ANCSVEG(I,J) ! TO BE USED FOR PHENOLOGY PANCGVEG(I,J)=ANCGVEG(I,J) ! PURPOSES ANCSVEG(I,J)=0.0 ANCGVEG(I,J)=0.0 ELSE PANCSVEG(I,J)=ANCSVEG(I,J) ! TO BE USED FOR PHENOLOGY PANCGVEG(I,J)=ANCGVEG(I,J) ! PURPOSES IF(SLAI(I,J).GT.AILCG(I,J))THEN TERM=((1.0/KN(SORT(J)))*(1.0-EXP(-KN(SORT(J))*AILCG(I,J))) & /(1.0/KN(SORT(J)))*(1.0-EXP(-KN(SORT(J))* SLAI(I,J)))) RMLCGVEG(I,J)=RMLCGVEG(I,J)*TERM RMLCSVEG(I,J)=RMLCSVEG(I,J)*TERM ENDIF ENDIF 190 CONTINUE 180 CONTINUE C C FIND VEGETATION AVERAGED LEAF, STEM, AND ROOT RESPIRATION, AND C GPP USING VALUES FROM CANOPY OVER GROUND AND CANOPY OVER SNOW C SUBAREAS C DO 270 J = 1, ICC DO 280 I = IL1, IL2 IF( (FCANC(I,J)+FCANCS(I,J)).GT.ZERO) THEN RMSVEG(I,J)= (FCANC(I,J)*RMSCGVEG(I,J) + & FCANCS(I,J)*RMSCSVEG(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) RMRVEG(I,J)= (FCANC(I,J)*RMRCGVEG(I,J) + & FCANCS(I,J)*RMRCSVEG(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) RMLVEG(I,J)= (FCANC(I,J)*RMLCGVEG(I,J) + & FCANCS(I,J)*RMLCSVEG(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) ANVEG(I,J)= (FCANC(I,J)*ANCGVEG(I,J) + & FCANCS(I,J)*ANCSVEG(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) GPPVEG(I,J)= (FCANC(I,J)*GPPCGVEG(I,J) + & FCANCS(I,J)*GPPCSVEG(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) PHEANVEG(I,J)= (FCANC(I,J)*PANCGVEG(I,J) + & FCANCS(I,J)*PANCSVEG(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) ELSE RMSVEG(I,J)= 0.0 RMRVEG(I,J)= 0.0 RMLVEG(I,J)= 0.0 ANVEG(I,J)= 0.0 GPPVEG(I,J)= 0.0 PHEANVEG(I,J)= 0.0 ENDIF C IF(LFSTATUS(I,J).EQ.4)THEN GPPVEG(I,J) = ANVEG(I,J) + RMLVEG(I,J) ENDIF C RMVEG(I,J) = RMLVEG(I,J) + RMRVEG(I,J) + RMSVEG(I,J) NPPVEG(I,J) = GPPVEG(I,J) - RMVEG(I,J) 280 CONTINUE 270 CONTINUE C C NOW THAT WE KNOW MAINTENANCE RESPIRATION FROM LEAF, STEM, AND ROOT, C AND GPP, WE CAN FIND GROWTH RESPIRATION FOR EACH VEGETATION C DO 300 J = 1, ICC DO 310 I = IL1, IL2 IF( NPPVEG(I,J).GT.ZERO ) THEN RGVEG(I,J)=GRESCOEF(SORT(J))*NPPVEG(I,J) ELSE RGVEG(I,J)=0.0 ENDIF NPPVEG(I,J) = NPPVEG(I,J) - RGVEG(I,J) 310 CONTINUE 300 CONTINUE C C CALCULATE GRID-AVERAGED RATES OF RM, RG, NPP, AND GPP C DO 320 J = 1,ICC DO 330 I = IL1, IL2 RML(I)=RML(I)+FCANCMX(I,J)*RMLVEG(I,J) RMS(I)=RMS(I)+FCANCMX(I,J)*RMSVEG(I,J) RMR(I)=RMR(I)+FCANCMX(I,J)*RMRVEG(I,J) RM(I) =RM(I)+FCANCMX(I,J)*RMVEG(I,J) RG(I) =RG(I)+FCANCMX(I,J)*RGVEG(I,J) NPP(I)=NPP(I)+FCANCMX(I,J)*NPPVEG(I,J) GPP(I)=GPP(I)+FCANCMX(I,J)*GPPVEG(I,J) AUTORES(I)=RG(I)+RM(I) 330 CONTINUE 320 CONTINUE C C AUTOTROPHIC RESPIRATION PART ENDS C C ------------------------------------------------------------------ C C HETEROTROPHIC RESPIRATION PART STARTS C C FIND HETEROTROPHIC RESPIRATION RATES (uMOL CO2/M2/SEC) FOR CANOPY C OVER SNOW SUBAREA C CALL HETRESV ( FCANCS, FCS, LITRMASS, SOILCMAS, 1 ICC, IG, ILG, IL1, 2 IL2, TBARCS, THLIQC, SAND, 3 CLAY, RTTEMPCS, ZBOTW, SORT, 4 ISAND, 5 LTRSVGCS, SCRSVGCS) C C FIND HETEROTROPHIC RESPIRATION RATES FOR CANOPY OVER GROUND C SUBAREA C CALL HETRESV ( FCANC, FC, LITRMASS, SOILCMAS, 1 ICC, IG, ILG, IL1, 2 IL2, TBARC, THLIQC, SAND, 3 CLAY, RTTEMPCG, ZBOTW, SORT, 4 ISAND, 5 LTRSVGCG, SCRSVGCG) C C FIND HETEROTROPHIC RESPIRATION RATES FROM BARE GROUND SUBAREA C CALL HETRESG (LITRMASS, SOILCMAS, ICC, IG, 1 ILG, IL1, IL2, TBARG, 2 THLIQG, SAND, CLAY, ZBOTW, 3 FG, 0, 4 ISAND, 5 LTRSBRG, SCRSBRG) C C FIND HETEROTROPHIC RESPIRATION RATES FROM SNOW OVER GROUND C SUBAREA C CALL HETRESG (LITRMASS, SOILCMAS, ICC, IG, 1 ILG, IL1, IL2, TBARGS, 2 THLIQG, SAND, CLAY, ZBOTW, 3 FGS, 1, 4 ISAND, 5 LTRSBRGS, SCRSBRGS) C C C FIND VEGETATION AVERAGED LITTER AND SOIL C RESPIRATION RATES C USING VALUES FROM CANOPY OVER GROUND AND CANOPY OVER SNOW SUBAREAS C DO 340 J = 1, ICC DO 350 I = IL1, IL2 IF( (FCANC(I,J)+FCANCS(I,J)).GT.ZERO) THEN LTRESVEG(I,J)= (FCANC(I,J)*LTRSVGCG(I,J) + & FCANCS(I,J)*LTRSVGCS(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) SCRESVEG(I,J)= (FCANC(I,J)*SCRSVGCG(I,J) + & FCANCS(I,J)*SCRSVGCS(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) HETRSVEG(I,J) = LTRESVEG(I,J) + SCRESVEG(I,J) ELSE LTRESVEG(I,J)= 0.0 SCRESVEG(I,J)= 0.0 HETRSVEG(I,J)= 0.0 ENDIF NEPVEG(I,J)=NPPVEG(I,J)-HETRSVEG(I,J) 350 CONTINUE 340 CONTINUE C C FIND LITTER AND SOIL C RESPIRATION RATES AVERAGED OVER THE BARE C FRACTION OF THE GRID CELL USING VALUES FROM GROUND AND SNOW OVER C GROUND SUB-AREAS. C DO 355 I = IL1, IL2 IF( (FG(I)+FGS(I)).GT.ZERO) THEN LTRESVEG(I,ICC+1)= (FG(I)*LTRSBRG(I) + & FGS(I)*LTRSBRGS(I)) / ( FG(I) + FGS(I) ) SCRESVEG(I,ICC+1)= (FG(I)*SCRSBRG(I) + & FGS(I)*SCRSBRGS(I)) / ( FG(I) + FGS(I) ) HETRSVEG(I,ICC+1) = LTRESVEG(I,ICC+1) + SCRESVEG(I,ICC+1) ELSE LTRESVEG(I,ICC+1)= 0.0 SCRESVEG(I,ICC+1)= 0.0 HETRSVEG(I,ICC+1)= 0.0 ENDIF 355 CONTINUE C C FIND GRID AVERAGED LITTER AND SOIL C RESPIRATION RATES C DO 360 J = 1,ICC DO 370 I = IL1, IL2 LITRES(I)=LITRES(I)+FCANCMX(I,J)*LTRESVEG(I,J) SOCRES(I)=SOCRES(I)+FCANCMX(I,J)*SCRESVEG(I,J) 370 CONTINUE 360 CONTINUE C DO 380 I = IL1, IL2 LITRES(I)=LITRES(I)+( (FG(I)+FGS(I))*LTRESVEG(I,ICC+1)) SOCRES(I)=SOCRES(I)+( (FG(I)+FGS(I))*SCRESVEG(I,ICC+1)) HETRORES(I)= LITRES(I)+SOCRES(I) NEP(I)=NPP(I)-HETRORES(I) 380 CONTINUE C C --------------------------------------------------------------- C C UPDATE THE LITTER AND SOIL C POOLS BASED ON LITTER AND SOIL C C RESPIRATION RATES FOUND ABOVE. ALSO TRANSFER HUMIDIFIED LITTER C TO THE SOIL C POOL. C DO 420 J = 1, (ICC+1) DO 430 I = IL1, IL2 C CONVERT u MOL CO2/M2.SEC -> Kg C/M2 RESPIRED OVER THE MODEL C TIME STEP LTRESTEP(I,J)=LTRESVEG(I,J)*(1.0/963.62)*DELTAT SCRESTEP(I,J)=SCRESVEG(I,J)*(1.0/963.62)*DELTAT C C UPDATE LITTER AND SOIL C POOLS IF(J.NE.ICC+1)THEN LITRMASS(I,J)=LITRMASS(I,J)-(LTRESTEP(I,J)* & (1.0+HUMICFAC(SORT(J)))) HUTRSTEP(I,J)=(HUMICFAC(SORT(J))* LTRESTEP(I,J)) ELSE LITRMASS(I,J)=LITRMASS(I,J)-(LTRESTEP(I,J)*(1.0+0.45)) HUTRSTEP(I,J)=(0.45 * LTRESTEP(I,J)) ENDIF C HUMTRSVG(I,J)=HUTRSTEP(I,J)*(963.62/DELTAT) ! u-MOL CO2/M2.SEC SOILCMAS(I,J)=SOILCMAS(I,J) + & REAL(SPINFAST) * (HUTRSTEP(I,J) - SCRESTEP(I,J)) C IF(LITRMASS(I,J).LT.ZERO) LITRMASS(I,J)=0.0 IF(SOILCMAS(I,J).LT.ZERO) SOILCMAS(I,J)=0.0 430 CONTINUE 420 CONTINUE C C ESTIMATE SOIL RESPIRATION. THIS IS SUM OF HETEROTROPHIC RESPIRATION C AND ROOT MAINTENANCE RESPIRATION. C DO 440 J = 1, ICC DO 450 I = IL1, IL2 SOILRSVG(I,J)=LTRESVEG(I,J)+SCRESVEG(I,J)+RMRVEG(I,J) 450 CONTINUE 440 CONTINUE C C BUT OVER THE BARE FRACTION THERE IS NO LIVE ROOT. C DO 460 I = IL1, IL2 SOILRSVG(I,ICC+1)=LTRESVEG(I,ICC+1)+SCRESVEG(I,ICC+1) 460 CONTINUE C C FIND GRID AVERAGED HUMIFICATION AND SOIL RESPIRATION RATES C DO 470 J = 1,ICC DO 480 I = IL1, IL2 SOILRESP(I)=SOILRESP(I)+FCANCMX(I,J)*SOILRSVG(I,J) HUMIFTRS(I)=HUMIFTRS(I)+FCANCMX(I,J)*HUMTRSVG(I,J) 480 CONTINUE 470 CONTINUE C DO 490 I = IL1, IL2 SOILRESP(I)=SOILRESP(I)+( (FG(I)+FGS(I))*SOILRSVG(I,ICC+1)) HUMIFTRS(I)=HUMIFTRS(I)+( (FG(I)+FGS(I))*HUMTRSVG(I,ICC+1)) 490 CONTINUE C C HETEROTROPHIC RESPIRATION PART ENDS C C ------------------------------------------------------------------ C C CH4 WETLAND EMISSIONS C CALL CH4WETLAND (HETRORES, IL1, IL2, ILG, TA, WETFRAC, 1 IG, NPP, TBAR, THLIQG, CURRLAT, 2 SAND, WETFRAC_S, 3 CH4WET1, CH4WET2, WETFDYN, 4 CH4DYN1, CH4DYN2) C C ------------------------------------------------------------------ C C ESTIMATE ALLOCATION FRACTIONS FOR LEAF, STEM, AND ROOT COMPONENTS. C CALL ALLCAR (LFSTATUS, THLIQC, AILCG, 1 ICC, IG, ILG, IL1, 2 IL2, SAND, CLAY, RMATCTEM, 3 GLEAFMAS, STEMMASS, ROOTMASS, SORT, 4 L2MAX, NOL2PFTS, IC, FCANCMX, 5 AFRLEAF, AFRSTEM, AFRROOT, WILTSM, 6 FIELDSM, WTSTATUS, LTSTATUS) C C ------------------------------------------------------------------ C C MAINTENANCE RESPIRATION ALSO REDUCES LEAF, STEM, AND ROOT BIOMASS. C WHEN NPP FOR A GIVEN PFT IS POSITIVE THEN THIS IS TAKEN CARE BY C ALLOCATING +VE NPP AMONGST THE LEAVES, STEM, AND ROOT COMPONENT. C WHEN NPP FOR A GIVEN PFT IS NEGATIVE THEN MAINTENANCE RESPIRATION C LOSS IS EXPLICITLY DEDUCTED FROM EACH COMPONENT. C DO 600 J = 1, ICC DO 610 I = IL1, IL2 C C CONVERT NPP AND MAINTENANCE RESPIRATION FROM DIFFERENT COMPONENTS C FROM UNITS OF u MOL CO2/M2.SEC -> Kg C/M2 SEQUESTERED OR RESPIRED C OVER THE MODEL TIME STEP GPPVGSTP(I,J)=GPPVEG(I,J)*(1.0/963.62)*DELTAT NPPVGSTP(I,J)=NPPVEG(I,J)*(1.0/963.62)*DELTAT RMLVGSTP(I,J)=RMLVEG(I,J)*(1.0/963.62)*DELTAT RMSVGSTP(I,J)=RMSVEG(I,J)*(1.0/963.62)*DELTAT RMRVGSTP(I,J)=RMRVEG(I,J)*(1.0/963.62)*DELTAT C IF(LFSTATUS(I,J).NE.4)THEN IF(NPPVGSTP(I,J).GT.0.0) THEN NTCHLVEG(I,J)=AFRLEAF(I,J)*NPPVGSTP(I,J) NTCHSVEG(I,J)=AFRSTEM(I,J)*NPPVGSTP(I,J) NTCHRVEG(I,J)=AFRROOT(I,J)*NPPVGSTP(I,J) ELSE NTCHLVEG(I,J)=-RMLVGSTP(I,J)+AFRLEAF(I,J)*GPPVGSTP(I,J) NTCHSVEG(I,J)=-RMSVGSTP(I,J)+AFRSTEM(I,J)*GPPVGSTP(I,J) NTCHRVEG(I,J)=-RMRVGSTP(I,J)+AFRROOT(I,J)*GPPVGSTP(I,J) ENDIF ELSE ! I.E. IF LFSTATUS.EQ.4 C AND SINCE WE DO NOT HAVE ANY REAL LEAVES ON THEN WE DO NOT TAKE C INTO ACCOUNT CO2 UPTAKE BY IMAGINARY LEAVES IN CARBON BUDGET. C RMLVGSTP(I,J) SHOULD BE ZERO BECAUSE WE SET MAINTENANCE C RESPIRATION FROM STORAGE/IMAGINARY LEAVES EQUAL TO ZERO. C IN LOOP 180 C NTCHLVEG(I,J)=-RMLVGSTP(I,J) NTCHSVEG(I,J)=-RMSVGSTP(I,J) NTCHRVEG(I,J)=-RMRVGSTP(I,J) C C SINCE NO REAL LEAVES ARE ON, MAKE ALLOCATION FRACTIONS EQUAL TO C ZERO. C AFRLEAF(I,J)=0.0 AFRSTEM(I,J)=0.0 AFRROOT(I,J)=0.0 ENDIF C GLEAFMAS(I,J)=GLEAFMAS(I,J)+NTCHLVEG(I,J) STEMMASS(I,J)=STEMMASS(I,J)+NTCHSVEG(I,J) ROOTMASS(I,J)=ROOTMASS(I,J)+NTCHRVEG(I,J) C C IF(GLEAFMAS(I,J).LT.0.0)THEN WRITE(6,1900)'GLEAFMAS LT ZERO AT I=',I,' FOR PFT=',J,'' WRITE(6,1901)'GLEAFMAS = ',GLEAFMAS(I,J) WRITE(6,1901)'NTCHLVEG = ',NTCHLVEG(I,J) WRITE(6,1902)'LFSTATUS = ',LFSTATUS(I,J) WRITE(6,1901)'AILCG = ',AILCG(I,J) WRITE(6,1901)'SLAI = ',SLAI(I,J) 1900 FORMAT(A23,I4,A10,I2,A1) 1902 FORMAT(A11,I4) CALL XIT ('CTEM',-6) ENDIF C IF(STEMMASS(I,J).LT.0.0)THEN WRITE(6,1900)'STEMMASS LT ZERO AT I=(',I,') FOR PFT=',J,')' WRITE(6,1901)'STEMMASS = ',STEMMASS(I,J) WRITE(6,1901)'NTCHSVEG = ',NTCHSVEG(I,J) WRITE(6,1902)'LFSTATUS = ',LFSTATUS(I,J) WRITE(6,1901)'RMSVGSTP = ',RMSVGSTP(I,J) WRITE(6,1901)'AFRSTEM = ',AFRSTEM(I,J) WRITE(6,1901)'GPPVGSTP = ',GPPVGSTP(I,J) WRITE(6,1901)'RMSCSVEG = ',RMSCSVEG(I,J) WRITE(6,1901)'RMSCGVEG = ',RMSCGVEG(I,J) 1901 FORMAT(A11,F12.8) CALL XIT ('CTEM',-7) ENDIF C IF(ROOTMASS(I,J).LT.0.0)THEN WRITE(6,1900)'ROOTMASS LT ZERO AT I=(',I,') FOR PFT=',J,')' WRITE(6,1901)'ROOTMASS = ',ROOTMASS(I,J) CALL XIT ('CTEM',-8) ENDIF C C CONVERT NET CHANGE IN LEAF, STEM, AND ROOT BIOMASS INTO C u-MOL CO2/M2.SEC FOR USE IN BALCAR SUBROUTINE C NTCHLVEG(I,J)=NTCHLVEG(I,J)*(963.62/DELTAT) NTCHSVEG(I,J)=NTCHSVEG(I,J)*(963.62/DELTAT) NTCHRVEG(I,J)=NTCHRVEG(I,J)*(963.62/DELTAT) C NPPLEAF(I,J)=NTCHLVEG(I,J) NPPROOT(I,J)=NTCHSVEG(I,J) NPPSTEM(I,J)=NTCHRVEG(I,J) C C TO AVOID OVER/UNDERFLOW PROBLEMS SET GLEAFMAS, STEMMASS, AND C ROOTMASS TO ZERO IF THEY GET TOO SMALL C IF(BLEAFMAS(I,J).LT.ZERO) BLEAFMAS(I,J)=0.0 IF(GLEAFMAS(I,J).LT.ZERO) GLEAFMAS(I,J)=0.0 IF(STEMMASS(I,J).LT.ZERO) STEMMASS(I,J)=0.0 IF(ROOTMASS(I,J).LT.ZERO) ROOTMASS(I,J)=0.0 C 610 CONTINUE 600 CONTINUE C ------------------------------------------------------------------ C C PHENOLOGY PART STARTS C C THE PHENOLOGY SUBROUTINE DETERMINES LEAF STATUS FOR EACH PFT AND C CALCULATES LEAF LITTER. THE PHENOLOGY SUBROUTINE USES SOIL C TEMPERATURE (TBAR) AND ROOT TEMPERATURE. HOWEVER, SINCE CTEM C DOESN'T MAKE THE DISTINCTION BETWEEN CANOPY OVER GROUND, AND C CANOPY OVER SNOW SUB-AREAS FOR PHENOLOGY PURPOSES (FOR EXAMPLE, C LEAF ONSET IS NOT ASSUMED TO OCCUR AT DIFFERENT TIMES OVER THESE C SUB-AREAS) WE USE AVERAGE SOIL AND ROOT TEMPERATURE IN THE PHENOLOGY C SUBROUTINE. C C CALCULATE AVERAGE SOIL TEMPERATURE AND ROOT TEMPERATURE USING C VALUES FOR CANOPY OVER GROUND AND CANOPY OVER SNOW SUB-AREAS, FOR C EACH VEGETATION TYPE. C DO 650 J = 1, ICC DO 660 I = IL1, IL2 IF( (FCANC(I,J)+FCANCS(I,J)).GT.ZERO) THEN ROOTTEMP(I,J)= (FCANC(I,J)*RTTEMPCG(I,J) + & FCANCS(I,J)*RTTEMPCS(I,J)) / ( FCANC(I,J) + FCANCS(I,J)) ELSE ROOTTEMP(I,J)= RTTEMPCG(I,J) ENDIF 660 CONTINUE 650 CONTINUE C DO 680 J = 1, IG DO 690 I = IL1, IL2 IF( (FC(I)+FCS(I)).GT.ZERO) THEN TBARCCS(I,J)= (FC(I)*TBARC(I,J) + & FCS(I)*TBARCS(I,J)) / ( FC(I) + FCS(I)) ELSE TBARCCS(I,J)= TBAR(I,J) ENDIF 690 CONTINUE 680 CONTINUE C C ------------------------------------------------------------------- C C CALL THE PHENOLOGY SUBROUTINE, WHICH DETERMINES THE LEAF GROWTH C STATUS, CALCULATES LEAF LITTER, AND CONVERTS GREEN GRASS INTO C BROWN. C CALL PHENOLGY(GLEAFMAS, BLEAFMAS, ICC, IG, 1 ILG, IL1, IL2, TBARCCS, 2 THLIQC, WILTSM, FIELDSM, TA, 3 PHEANVEG, IDAY, RADJ, ROOTTEMP, 4 RMATCTEM, STEMMASS, ROOTMASS, SORT, 5 L2MAX, NOL2PFTS, IC, FCANCMX, 6 FLHRLOSS, LEAFLITR, LFSTATUS, PANDAYS, 7 COLDDAYS) C C ------------------------------------------------------------------- C C WHILE LEAF LITTER IS CALCULATED IN THE PHENOLOGY SUBROUTINE, STEM C AND ROOT TURNOVER IS CALCULATED IN THE TURNOVER SUBROUTINE. C CALL TURNOVER (STEMMASS, ROOTMASS, LFSTATUS, AILCG, 1 ICC, ILG, IL1, IL2, 2 SORT, NOL2PFTS, IC, FCANCMX, 3 STMHRLOS, ROTHRLOS, 4 STEMLITR, ROOTLITR) C C ------------------------------------------------------------------- C C UPDATE GREEN LEAF BIOMASS FOR TREES AND CROPS AND BROWN LEAF BIOMASS C FOR GRASSES C K1=0 DO 700 J = 1, IC IF(J.EQ.1) THEN K1 = K1 + 1 ELSE K1 = K1 + NOL2PFTS(J-1) ENDIF K2 = K1 + NOL2PFTS(J) - 1 DO 705 M = K1, K2 DO 710 I = IL1, IL2 IF(J.LE.3)THEN ! TREES AND CROPS GLEAFMAS(I,M)=GLEAFMAS(I,M)-LEAFLITR(I,M) IF( GLEAFMAS(I,M).LT.0.0) THEN LEAFLITR(I,M)=LEAFLITR(I,M)+GLEAFMAS(I,M) GLEAFMAS(I,M)=0.0 ENDIF ELSE ! GRASSES BLEAFMAS(I,M)=BLEAFMAS(I,M)-LEAFLITR(I,M) IF( BLEAFMAS(I,M).LT.0.0) THEN LEAFLITR(I,M)=LEAFLITR(I,M)+BLEAFMAS(I,M) BLEAFMAS(I,M)=0.0 ENDIF ENDIF 710 CONTINUE 705 CONTINUE 700 CONTINUE C C UPDATE STEM AND ROOT BIOMASS FOR LITTER DEDUCTIONS C DO 780 J = 1, ICC DO 790 I = IL1, IL2 STEMMASS(I,J)=STEMMASS(I,J)-STEMLITR(I,J) IF( STEMMASS(I,J).LT.0.0) THEN STEMLITR(I,J)=STEMLITR(I,J)+STEMMASS(I,J) STEMMASS(I,J)=0.0 ENDIF C ROOTMASS(I,J)=ROOTMASS(I,J)-ROOTLITR(I,J) IF( ROOTMASS(I,J).LT.0.0) THEN ROOTLITR(I,J)=ROOTLITR(I,J)+ROOTMASS(I,J) ROOTMASS(I,J)=0.0 ENDIF 790 CONTINUE 780 CONTINUE C C UPDATE LITTER POOL WITH LEAF LITTER CALCULATED IN THE PHENOLOGY C SUBROUTINE AND STEM AND ROOT LITTER CALCULATED IN THE TURNOVER C SUBROUTINE. C DO 800 J = 1, ICC DO 810 I = IL1, IL2 LITRMASS(I,J)=LITRMASS(I,J)+LEAFLITR(I,J)+STEMLITR(I,J)+ & ROOTLITR(I,J) 810 CONTINUE 800 CONTINUE C C C ------------------------------------------------------------------ C C CALL THE MORTALIY SUBROUTINE WHICH CALCULATES MORTALITY DUE TO C REDUCED GROWTH AND AGING. EXOGENOUS MORTALITY DUE TO FIRE AND OTHER C DISTURBANCES AND THE SUBSEQUENT LITTER THAT IS GENERATED IS C CALCULATED IN THE DISTURB SUBROUTINE. C C SET DO_MORTALITY=.FALSE. TO SWITCH OFF MORTALITY DUE TO AGE AND C REDUCED GROWTH. MORTALITY IS LINKED TO THE COMPETITION PARAMETERIZATION C AND GENERATES BARE FRACTION. DO_MORTALITY=.FALSE. C CALL MORTALTY (STEMMASS, ROOTMASS, AILCG, GLEAFMAS, 1 BLEAFMAS, ICC, ILG, IL1, 2 IL2, IDAY, DO_MORTALITY, SORT, 3 FCANCMX, LYSTMMAS, LYROTMAS, TYMAXLAI, 4 GRWTHEFF, STEMLTRM, ROOTLTRM, GLEALTRM, 5 GEREMORT, INTRMORT) C C ------------------------------------------------------------------ C C UPDATE LEAF, STEM, AND ROOT BIOMASS POOLS TO TAKE INTO LOSS C DUE TO MORTALITY, AND PUT THE LITTER INTO THE LITTER POOL. THE C MORTALITY FOR GREEN GRASSES DOESN'T GENERATE LITTER, INSTEAD C THEY TURN BROWN. C K1=0 DO 830 J = 1, IC IF(J.EQ.1) THEN K1 = K1 + 1 ELSE K1 = K1 + NOL2PFTS(J-1) ENDIF K2 = K1 + NOL2PFTS(J) - 1 DO 835 M = K1, K2 DO 840 I = IL1, IL2 C STEMMASS(I,M)=STEMMASS(I,M)-STEMLTRM(I,M) ROOTMASS(I,M)=ROOTMASS(I,M)-ROOTLTRM(I,M) LITRMASS(I,M)=LITRMASS(I,M)+STEMLTRM(I,M)+ROOTLTRM(I,M) C IF(J.EQ.4)THEN ! GRASSES GLEAFMAS(I,M)=GLEAFMAS(I,M)-GLEALTRM(I,M) BLEAFMAS(I,M)=BLEAFMAS(I,M)+GLEALTRM(I,M) GLEALTRM(I,M)=0.0 ELSE ! TREES AND CROPS GLEAFMAS(I,M)=GLEAFMAS(I,M)-GLEALTRM(I,M) ENDIF LITRMASS(I,M)=LITRMASS(I,M)+GLEALTRM(I,M) C 840 CONTINUE 835 CONTINUE 830 CONTINUE C C ------------------------------------------------------------------ C C CALL THE DISTURBANCE SUBROUTINE WHICH CALCULATES MORTALITY DUE TO C FIRE AND OTHER DISTURBANCES. THE PRIMARY OUTPUT FROM FROM C DISTURBANCE SUBROUTINE IS LITTER GENERATED, C EMISSIONS DUE TO C FIRE AND AREA BURNED, WHICH MAY BE USED TO ESTIMATE CHANGE IN C FRACTIONAL COVERAGES. C C DISTURBANCE IS SPATIAL AND REQUIRES AREA OF GCM GRID CELL AND AREAS C OF DIFFERENT PFTs PRESENT IN A GIVEN GRID CELL. HOWEVER, WHEN CTEM IS C OPERATED AT A POINT SCALE THEN IT IS ASSUMED THAT THE SPATIAL SCALE C IS 1 HECTARE = 10,000 M2. THE DISTURBANCE SUBROUTINE MAY BE STOPPED C FROM SIMULATING ANY FIRE BY SPECIFYING FIRE EXTINGUSHING PROBABILITY C EQUAL TO 1. C C CALL DISTURB (STEMMASS, ROOTMASS, GLEAFMAS, BLEAFMAS, 1 THLIQC, WILTSM, FIELDSM, VMOD, 2 LIGHTNG, FCANCMX, LITRMASS, 3 PRBFRHUC, RMATCTEM, EXTNPROB, PFTAREAB, 4 IL1, IL2, IG, ICC, 5 ILG, SORT, NOL2PFTS, IC, 6 GRCLAREA, THICEC, POPDIN, LUCEMCOM, 7 DOFIRE, C IN ABOVE, OUT BELOW 8 STEMLTDT, ROOTLTDT, GLFLTRDT, BLFLTRDT, 9 PFTAREAA, GLCAEMLS, RTCAEMLS, STCAEMLS, A BLCAEMLS, LTRCEMLS, BURNFRAC, PROBFIRE, B EMIT_CO2, EMIT_CO, EMIT_CH4, EMIT_NMHC, C EMIT_H2, EMIT_NOX, EMIT_N2O, EMIT_PM25, D EMIT_TPM, EMIT_TC, EMIT_OC, EMIT_BC) C C ------------------------------------------------------------------ C C UPDATE LITTER POOL AND REDUCE LEAF, STEM, AND ROOT BIOMASS TO C TAKE INTO ACCOUNT LOSSES FROM DISTURBANCE. CALCULATE NBP (NET BIOME C PRODUCTION) FOR EACH PFT BY TAKING INTO ACCOUNT C EMISSION LOSSES. C DO 1000 J = 1, ICC DO 1010 I = IL1, IL2 GLEAFMAS(I,J)=GLEAFMAS(I,J) - GLFLTRDT(I,J) - GLCAEMLS(I,J) BLEAFMAS(I,J)=BLEAFMAS(I,J) - BLFLTRDT(I,J) - BLCAEMLS(I,J) STEMMASS(I,J)=STEMMASS(I,J) - STEMLTDT(I,J) - STCAEMLS(I,J) ROOTMASS(I,J)=ROOTMASS(I,J) - ROOTLTDT(I,J) - RTCAEMLS(I,J) LITRMASS(I,J)=LITRMASS(I,J) + GLFLTRDT(I,J) + BLFLTRDT(I,J) + & STEMLTDT(I,J) + ROOTLTDT(I,J) - LTRCEMLS(I,J) DSCEMLV1(I,J)=GLCAEMLS(I,J) + BLCAEMLS(I,J) + STCAEMLS(I,J) + & RTCAEMLS(I,J) DSCEMLV2(I,J)=GLCAEMLS(I,J) + BLCAEMLS(I,J) + STCAEMLS(I,J) + & RTCAEMLS(I,J) + LTRCEMLS(I,J) C CONVERT Kg C/M2 EMITTED IN ONE DAY INTO u MOL CO2/M2.SEC BEFORE C SUBTRACTING EMISSION LOSSES FROM NEP NBPVEG(I,J) =NEPVEG(I,J) - DSCEMLV2(I,J)*(963.62/DELTAT) 1010 CONTINUE 1000 CONTINUE C C CALCULATE GRID. AVERAGED RATE OF CARBON EMISSIONS DUE TO FIRE IN C u-MOL CO2/M2.SEC. CONVERT ALL EMISSION LOSSES FROM Kg C/M2 C EMITTED IN 1 DAY TO u-MOL CO2/M2.SEC. CALCULATE GRID AVERAGED C CARBON EMISSION LOSSES FROM LITTER. C DO 1030 J = 1,ICC DO 1040 I = IL1, IL2 DSTCEMLS1(I)=DSTCEMLS1(I) + & FCANCMX(I,J)*DSCEMLV1(I,J)*(963.62/DELTAT) DSTCEMLS2(I)=DSTCEMLS2(I) + & FCANCMX(I,J)*DSCEMLV2(I,J)*(963.62/DELTAT) GALTCELS(I)=GALTCELS(I) + & FCANCMX(I,J)*LTRCEMLS(I,J)*(963.62/DELTAT) GLCAEMLS(I,J)=GLCAEMLS(I,J)*(963.62/DELTAT) BLCAEMLS(I,J)=BLCAEMLS(I,J)*(963.62/DELTAT) STCAEMLS(I,J)=STCAEMLS(I,J)*(963.62/DELTAT) RTCAEMLS(I,J)=RTCAEMLS(I,J)*(963.62/DELTAT) LTRCEMLS(I,J)=LTRCEMLS(I,J)*(963.62/DELTAT) 1040 CONTINUE 1030 CONTINUE C DO 1041 I = IL1, IL2 NBP(I)=NEP(I)-DSTCEMLS2(I) DSTCEMLS3(I)=DSTCEMLS2(I)-DSTCEMLS1(I) 1041 CONTINUE C C CALCULATE TOTAL LITTER FALL FROM EACH COMPONENT (LEAVES, STEM, AND C ROOT) FROM ALL CAUSES (NORMAL TURNOVER, DROUGHT AND COLD STRESS FOR C LEAVES, MORTALITY, AND DISTURBANCE) FOR USE IN BALCAR SUBROUTINE C DO 1050 J = 1,ICC DO 1060 I = IL1, IL2 C C UNITS HERE ARE Kg C/M2.DAY TLTRLEAF(I,J)=LEAFLITR(I,J)+GLEALTRM(I,J)+GLFLTRDT(I,J)+ & BLFLTRDT(I,J) TLTRSTEM(I,J)=STEMLITR(I,J)+STEMLTRM(I,J)+STEMLTDT(I,J) TLTRROOT(I,J)=ROOTLITR(I,J)+ROOTLTRM(I,J)+ROOTLTDT(I,J) C C CONVERT UNITS TO u-MOL CO2/M2.SEC LEAFLITR(I,J)=LEAFLITR(I,J)*(963.62/DELTAT) TLTRLEAF(I,J)=TLTRLEAF(I,J)*(963.62/DELTAT) TLTRSTEM(I,J)=TLTRSTEM(I,J)*(963.62/DELTAT) TLTRROOT(I,J)=TLTRROOT(I,J)*(963.62/DELTAT) 1060 CONTINUE 1050 CONTINUE C C CALCULATE GRID-AVERAGE VEGETATION BIOMASS, LITTER MASS, AND SOIL C CARBON MASS, AND LITTER FALL RATE C DO 1100 J = 1, ICC DO 1110 I = IL1, IL2 VGBIOMAS(I)=VGBIOMAS(I)+FCANCMX(I,J)*(GLEAFMAS(I,J)+ & BLEAFMAS(I,J)+STEMMASS(I,J)+ROOTMASS(I,J)) LITRFALL(I)=LITRFALL(I)+FCANCMX(I,J)*(TLTRLEAF(I,J)+ & TLTRSTEM(I,J)+TLTRROOT(I,J)) GAVGLTMS(I)=GAVGLTMS(I)+FCANCMX(I,J)*LITRMASS(I,J) GAVGSCMS(I)=GAVGSCMS(I)+FCANCMX(I,J)*SOILCMAS(I,J) C GAVGLAI (I)=GAVGLAI (I)+FCANCMX(I,J)*AILCG(I,J) C GAVGLFMS(I)=GAVGLFMS(I)+FCANCMX(I,J)*GLEAFMAS(I,J) GAVGSTMS(I)=GAVGSTMS(I)+FCANCMX(I,J)*STEMMASS(I,J) GAVGRTMS(I)=GAVGRTMS(I)+FCANCMX(I,J)*ROOTMASS(I,J) C GAVGNPLF(I) = GAVGNPLF(I) + FCANCMX(I,J)*NPPLEAF(I,J) GAVGNPST(I) = GAVGNPST(I) + FCANCMX(I,J)*NPPSTEM(I,J) GAVGNPRT(I) = GAVGNPRT(I) + FCANCMX(I,J)*NPPROOT(I,J) 1110 CONTINUE 1100 CONTINUE C DO 1020 I = IL1, IL2 GAVGLTMS(I)=GAVGLTMS(I)+( (FG(I)+FGS(I))*LITRMASS(I,ICC+1)) GAVGSCMS(I)=GAVGSCMS(I)+( (FG(I)+FGS(I))*SOILCMAS(I,ICC+1)) 1020 CONTINUE C C ----------------------------------------------------------------- C C AT THIS STAGE WE HAVE ALL REQUIRED FLUXES IN u-MOL CO2/M2.SEC AND C INITIAL (LOOP 140 AND 145) AND UPDATED SIZES OF ALL POOLS C (IN Kg C/M2). NOW WE CALL THE BALCAR SUBROUTINE AND MAKE SURE THAT C C IN LEAVES, STEM, ROOT, LITTER AND SOIL C POOL BALANCES WITHIN A C CERTAIN TOLERANCE. C IF(SPINFAST.EQ.1)THEN CALL BALCAR(GLEAFMAS, STEMMASS, ROOTMASS, BLEAFMAS, 1 LITRMASS, SOILCMAS, NTCHLVEG, NTCHSVEG, 2 NTCHRVEG, TLTRLEAF, TLTRSTEM, TLTRROOT, 3 GLCAEMLS, BLCAEMLS, STCAEMLS, RTCAEMLS, 4 LTRCEMLS, LTRESVEG, SCRESVEG, HUMTRSVG, 5 PGLFMASS, PBLFMASS, PSTEMASS, PROTMASS, 6 PLITMASS, PSOCMASS, DELTAT, VGBIOMAS, 7 PVGBIOMS, GAVGLTMS, PGAVLTMS, GAVGSCMS, 8 PGAVSCMS, GALTCELS, 9 NPP, AUTORES, HETRORES, GPP, A NEP, LITRES, SOCRES, DSTCEMLS1, B NBP, LITRFALL, HUMIFTRS, C ICC, ILG, IL1, IL2) ENDIF C C ----------------------------------------------------------------- C C THE LUC SUBROUTINE ALSO ESTIMATES CARBON EMISSIONS DUE TO C COMBUSTION ASSOCITED WITH LUC, AND THIS FLUX IS SPREAD OUT OVER C THE WHOLE YEAR AND IS THEREFORE SUBTRACTED TO GET NBP OF EACH PFT C AS WELL AS THE GRID AVERAGED VALUE OF NBP. C IF(LNDUSEON.EQ.1)THEN DO 1150 J = 1, ICC DO 1151 I = IL1, IL2 C LUC RELATED COMBUSTION FLUX IS ASSUMED TO BE SPREAD C UNIFORMLY OVER THE GRID CELL AND THUS REDUCES NBP OF EACH C PFT NBPVEG(I,J)=NBPVEG(I,J)-LUCEMCOM(I) 1151 CONTINUE 1150 CONTINUE C DO 1160 I = IL1, IL2 NBP(I)=NBP(I)-LUCEMCOM(I) 1160 CONTINUE ENDIF C C ----------------------------------------------------------------- C C FINALLY FIND VEGETATION STRUCTURAL ATTRIBUTES WHICH CAN BE PASSED C TO THE LAND SURFACE SCHEME USING LEAF, STEM, AND ROOT BIOMASS. C CALL BIO2STR( GLEAFMAS, BLEAFMAS, STEMMASS, ROOTMASS, 1 ICC, ILG, IL1, IL2, 2 IG, IC, FCANCMX, ZBOTW, 3 DELZW, NOL2PFTS, L2MAX, SOILDPTH, 4 AILCG, AILCB, AILC, ZOLNC, 5 RMATC, RMATCTEM, SLAI, BMASVEG, 6 CMASVEGC, VEGHGHT, ROOTDPTH, ALVISC, 8 ALNIRC, 9 PAICGAT,SLAICGAT ) C C CALCULATION OF GAVGLAI IS MOVED FROM LOOP 1100 TO HERE C SINCE AILCG IS UPDATED BY BIO2STR C DO J = 1, ICC DO I = IL1, IL2 GAVGLAI (I)=GAVGLAI (I)+FCANCMX(I,J)*AILCG(I,J) ENDDO ENDDO C C C ----------------------------------------------------------------- C RETURN END SUBROUTINE CTEM_INIT(NLU,NEWFRAC,PREFRAC,C_CLIM_TIME, 1 MONTH,IYEAR,IDAY, 2 LNDCVRYR1,LNDCVRYR2,LNDCVRMOD,LNDCVR_OFFSET, 3 LCTEM,ICC,NTLD,NLON,NLAT,IJPAK,GG) C C * FEB 29, 2016 - M.LAZARE. NEW ROUTINE BASED ON FIRST PART OF CTEM_INIT.DK C * TO GET CTEM LAND FRACTIONS FOR PRESENT AND C * NEXT MONTH. C * AS WELL, WE CALCULATE CTEM TIME-COUNTING VARIABLES C * AND PLACE THEM IN A COMMON BLOCK PASSED C * TO ROUTINE INTCTEMF. C IMPLICIT NONE C integer NLU ! I/O UNIT NUMBER FOR FILE THAT CONTAINS LAND COVER + MAY BE OTHER VARIABLES C C * OUTPUT FIELDS: C REAL NEWFRAC(IJPAK,NTLD,ICC), PREFRAC(IJPAK,NTLD,ICC) REAL C_CLIM_TIME(3,2) C C * REST. C INTEGER LCTEM(ICC) INTEGER*4 MYNODE COMMON /MPINFO/ MYNODE C C * I/O WORK ARRAY. C REAL GG(*) C INTEGER MID_MONTH_DAYS(12) C INTEGER IYEAR ! Compressed time year (... -2, -1, 0, 1, 2 ....) INTEGER IDAY ! Compressed time day (1, 2, 3 ... 364, 365) INTEGER MONTH ! Extended time month (1, 2, 3 ... 12) C INTEGER LNDCVRYR1,LNDCVRYR2,LNDCVRMOD,LNDCVR_OFFSET INTEGER MONTHL1,TMESTMP1,TMESTMP2,nc4to8 INTEGER IJPAK,NTLD,K,M,NLON,NLAT,ICC C DATA MID_MONTH_DAYS /15,46,74,105,135,166,196,227,258,288,319, +349/ C----------------------------------------------------------------------------- IF(LNDCVRMOD.EQ.12345)THEN LNDCVRYR2 = IYEAR + LNDCVR_OFFSET ! YEAR FOR WHICH WE WANT TO GET THE LAND COVER C MONTHL1 = MONTH - 1 IF (MONTHL1.NE.0) THEN TMESTMP1 = LNDCVRYR2*100 + MONTHL1 C_CLIM_TIME(1,1)=REAL(LNDCVRYR2) C_CLIM_TIME(2,1)=REAL(MID_MONTH_DAYS(MONTHL1)) C_CLIM_TIME(3,1)=0.0 ELSE IF( MONTHL1.EQ.0) THEN TMESTMP1 = (LNDCVRYR2-1)*100 + 12 ! DECEMBER OF LAST YEAR C_CLIM_TIME(1,1)=REAL(LNDCVRYR2-1) C_CLIM_TIME(2,1)=REAL(MID_MONTH_DAYS(12)) C_CLIM_TIME(3,1)=0.0 ENDIF TMESTMP2 = LNDCVRYR2*100 + MONTH C_CLIM_TIME(1,2)=REAL(LNDCVRYR2) C_CLIM_TIME(2,2)=REAL(MID_MONTH_DAYS(MONTH)) C_CLIM_TIME(3,2)=0.0 ELSE C C * GET LAND COVER FOR THE PARTICULAR YEAR, LNDCVRMOD. SINCE LAND C * COVER DATA ARE AT MONTHLY RESOLUTION WE GET THE VALUES FOR THE C * 1st OF JULY FOR THIS YEAR C LNDCVRYR2 = LNDCVRMOD C C * ALSO BOTH TIME STAMPS ARE SAME BECAUSE WHEN RUNNING CTEM FOR A C * GIVEN YEAR OVER AND OVER AGAIN WE DON'T WANT ANY LAND USE CHANGE C * TO BE HAPPENING C TMESTMP1 = LNDCVRYR2*100 + 7 ! 7 FOR JULY TMESTMP2 = LNDCVRYR2*100 + 7 C C * HOWEVER, FOR INTERPOLATION USING WARREN'S SUBROUTINE I DO NEED C * C_CLIM_TIME SO LETS SET THEM AS THE START AND END OF THE GIVEN C * YEAR C C_CLIM_TIME(1,1)=REAL(LNDCVRYR2) C_CLIM_TIME(2,1)=1.0 C_CLIM_TIME(3,1)=0.0 C C_CLIM_TIME(1,2)=REAL(LNDCVRYR2+1) C_CLIM_TIME(2,2)=1.0 C_CLIM_TIME(3,2)=0.0 ENDIF C C * IF ANY TIME STAMP IS GREATER THAN 210012 THAN SET IT TO C * 210012 SO THAT AFTER 1st DECEMBER, 2100 THE LAND COVER C * DOESN'T CHANGE. C IF(TMESTMP1.GT.210012)THEN TMESTMP1 = 210012 ENDIF IF(TMESTMP2.GT.210012)THEN TMESTMP2 = 210012 ENDIF C C * IF ANY TIME STAMP IS LESS THAN 185001 THEN SET IT TO C * 185001 SO THAT BEFORE 1st JANUARY, 1850 THE LAND COVER C * USED IS THAT OF 1850 C IF(TMESTMP1.LT.185001)THEN TMESTMP1 = 185001 ENDIF IF(TMESTMP2.LT.185001)THEN TMESTMP2 = 185001 ENDIF C C * EXTRACT LAND COVER DATA FOR THIS AND THE NEXT MONTH C REWIND NLU DO K = 1, ICC DO M = 1, NTLD CALL GETGGBX(PREFRAC(1,M,K),NC4TO8("FRAC"),NLU,NLON,NLAT, 1 TMESTMP1,LCTEM(K),GG) ENDDO ENDDO C IF(LNDCVRMOD.EQ.12345.AND.TMESTMP1.NE.TMESTMP2)THEN DO K = 1, ICC DO M = 1, NTLD CALL GETGGBX(NEWFRAC(1,M,K),NC4TO8("FRAC"),NLU,NLON,NLAT, 1 TMESTMP2,LCTEM(K),GG) ENDDO ENDDO ELSE NEWFRAC(:,:,:)=PREFRAC(:,:,:) ENDIF RETURN END SUBROUTINE GETCTEMAN(NUAN,PEXFPAK,PFHCPAK,WETFPAK,WETSPAK,LGHTPAK, 1 MONTH,NLON,NLAT,IJPAK,GG) C C * MAR 01/2016 - M.LAZARE. NEW VERSION FOR GCM19: C * READ IN CTEM INVARIANT FIELDS. C C * READ IN CTEM INVARIANT FIELDS. C IMPLICIT NONE C C * FIELDS READ: C REAL PEXFPAK(IJPAK), PFHCPAK(IJPAK) REAL WETFPAK(IJPAK), WETSPAK(IJPAK) REAL LGHTPAK(IJPAK) C REAL GG(*) C INTEGER NLON,NLAT,IJPAK,NUAN,MONTH C INTEGER*4 MYNODE COMMON /MPINFO/ MYNODE C C * LOCAL DATA. C INTEGER :: nc4to8,machine,intsize,ibuf,idat,maxx LOGICAL OK COMMON /ICOM/ IBUF(8),IDAT(1) COMMON /MACHTYP/ MACHINE, INTSIZE C---------------------------------------------------------------------- MAXX=( NLON*NLAT + 8 )*MACHINE C C * READ SOME TIME-INVARIANT QUANTITIES FROM CTEMs AN FILE, NUCTEMAN C C * FIRE EXTINGUSHING PROBABILITY. C CALL RECGET(NUAN,NC4TO8("LABL"),-1,NC4TO8("LABL"),-1,IBUF,MAXX,OK) CALL GETGGBX(PEXFPAK,NC4TO8("PEXF"),NUAN,NLON,NLAT,0,0,GG) IF (.NOT. OK) CALL XIT('GETCTEMAN',-1) C C * PROBABILITY OF FIRE DUE TO HUMAN CAUSES. C CALL RECGET(NUAN,NC4TO8("LABL"),-1,NC4TO8("LABL"),-1,IBUF,MAXX,OK) CALL GETGGBX(PFHCPAK,NC4TO8("PFHC"),NUAN,NLON,NLAT,0,0,GG) IF (.NOT. OK) CALL XIT('GETCTEMAN',-2) C C * SPECIFIED WETLAND FRACTION. C CALL RECGET(NUAN,NC4TO8("LABL"),-1,NC4TO8("LABL"),-1,IBUF,MAXX,OK) CALL GETGGBX(WETFPAK,NC4TO8("WETF"),NUAN,NLON,NLAT,1,1,GG) IF (.NOT. OK) CALL XIT('GETCTEMAN',-3) C C * SLOPE BASED WETLAND FRACTION. C CALL RECGET(NUAN,NC4TO8("LABL"),-1,NC4TO8("LABL"),-1,IBUF,MAXX,OK) CALL GETGGBX(WETSPAK,NC4TO8("WETS"),NUAN,NLON,NLAT,1,1,GG) IF (.NOT. OK) CALL XIT('GETCTEMAN',-4) C C * LIGHTNING FREQUENCY FOR THE CURRENT MONTH. C CALL RECGET(NUAN,NC4TO8("LABL"),-1,NC4TO8("LABL"),-1,IBUF,MAXX,OK) CALL GETGGBX(LGHTPAK,NC4TO8("LGHT"),NUAN,NLON,NLAT,MONTH,1,GG) IF (.NOT. OK) CALL XIT('GETCTEMAN',-5) C CLOSE(NUAN) RETURN END SUBROUTINE GETCTEMF (NLU,NEWFRAC,PREFRAC,C_CLIM_TIME, 1 MONTH,IDAY, 2 LNDCVRYR1,LNDCVRYR2, 3 LCTEM,ICC,NTLD,NLON,NLAT,IJPAK,GG) C C * FEB 29, 2016 - M.LAZARE. NEW ROUTINE BASED ON FIRST PART OF CTEM_INTERPOL_LAND_COVER.DK C * TO OBTAIN NEXT MID-MONTH CTEM VEGETATION FRACTION FIELDS. C IMPLICIT NONE integer NLU ! I/O UNIT NUMBER FOR FILE THAT CONTAINS LAND COVER + MAY BE OTHER VARIABLES C C * I/O FIELDS: C REAL NEWFRAC(IJPAK,NTLD,ICC), PREFRAC(IJPAK,NTLD,ICC) REAL C_CLIM_TIME(3,2) C INTEGER LCTEM(ICC) INTEGER*4 MYNODE COMMON /MPINFO/ MYNODE C C * WORK ARRAY. C REAL GG(*) C INTEGER IJPAK,NTLD,K,M,NLON,NLAT,ICC INTEGER IDAY ! Compressed time day (1, 2, 3 ... 364, 365) INTEGER MONTH ! Extended time month (1, 2, 3 ... 12) C INTEGER LNDCVRYR1,LNDCVRYR2 C C * LOCAL DATA. C INTEGER :: nc4to8 C INTEGER START_DAYS_OF_MONTHS(12), MID_MONTH_DAYS(12) INTEGER MONTHP1, TMESTMP2 C DATA START_DAYS_OF_MONTHS /1,32,60,91,121,152,182,213,244,274, &305,335/ DATA MID_MONTH_DAYS /15,46,74,105,135,166,196,227,258,288,319, +349/ C----------------------------------------------------------------------------- C * FIND THE LAND COVER FOR THE CURRENT DAY USING VALUES C * PREVIOUSLY EXTRACTED. C LNDCVRYR1 = LNDCVRYR2*10000 + MONTH * 100 + IDAY - & START_DAYS_OF_MONTHS(MONTH) + 1 ! FOR USE IN WRITECS C C * AT THIS TIME I DO NOT HAVE LAND COVER BEYOND 2100 SO THE TIME STAMP C * USED IN SAVING LAND COVER IN THE CM FILE IN WRITECS SUBROUTINE CANNOT C * BE GREATER THAN THE LAST DAY OF 2100. C IF(LNDCVRYR1.GT.21001231) THEN LNDCVRYR1 = 21001231 ENDIF C C_CLIM_TIME(1,1)=LNDCVRYR2 C_CLIM_TIME(2,1)=MID_MONTH_DAYS(MONTH) C_CLIM_TIME(3,1)=0.0 C MONTHP1 = MONTH + 1 IF (MONTHP1.NE.13)THEN TMESTMP2 = LNDCVRYR2*100 + MONTH + 1 C_CLIM_TIME(1,2)=LNDCVRYR2 C_CLIM_TIME(2,2)=MID_MONTH_DAYS(MONTH+1) C_CLIM_TIME(3,2)=0.0 ELSE IF( MONTHP1.EQ.13)THEN TMESTMP2 = (LNDCVRYR2+1)*100 + 1 ! JANUARY OF NEXT YEAR IF (TMESTMP2.GT.210012) TMESTMP2=210012 C_CLIM_TIME(1,2)=LNDCVRYR2+1 C_CLIM_TIME(2,2)=MID_MONTH_DAYS(1) C_CLIM_TIME(3,2)=0.0 ENDIF C C * 15th OF THIS MONTH VALUES NOW BECOME PREFRAC C PREFRAC(:,:,:)=NEWFRAC(:,:,:) C C * AND WE GET VALUES FOR THE 15th OF THE NEXT MONTH C REWIND NLU DO K = 1, ICC DO M = 1, NTLD CALL GETGGBX(NEWFRAC(1,M,K),NC4TO8("FRAC"),NLU,NLON,NLAT, 1 TMESTMP2,LCTEM(K),GG) ENDDO ENDDO C RETURN END SUBROUTINE INTCTEMF (CURFRAC,TODFRAC,FCANMX, 1 NEWFRAC,PREFRAC,SANDARRY,SOILDPTH,NOL2PFTS, 2 C_CLIM_TIME,MONTH,IDAY,GMT,LNDCVRYR2, 3 IC,IG,ICC,ILG,IL1,IL2) C C * FEB 29, 2016 - M.LAZARE. NEW ROUTINE BASED ON MIDDLE PART OF CTEM_INTERPOL_LAND_COVER.DK C * TO INTERPOLATE TO GET CURRENT AND NEXT-DAY CTEM VEGETATION C * FRACTION FIELDS, FROM PREVIOUS AND NEXT MID-MONTH VALUES. C IMPLICIT NONE C C * OUTPUT FIELDS: C REAL CURFRAC(ILG,ICC), TODFRAC(ILG,ICC) REAL FCANMX(ILG,IC) C C * I/O FIELDS: C REAL NEWFRAC(ILG,ICC), PREFRAC(ILG,ICC) REAL SANDARRY(ILG,IG) REAL SOILDPTH(ILG) INTEGER NOL2PFTS(4) C INTEGER ILG,IL,IL1,IL2,I,J,M,K,K1,K2,IC,IG,ICC,IDAY INTEGER MONTH ! Extended time month (1, 2, 3 ... 12) REAL GMT C INTEGER LNDCVRYR2 REAL C_CLIM_TIME(3,2) C C * LOCAL WORK ARRAYS. C * THESE ARE DIMENSIONED ONLY WITH THE SIZE OF THE ACTUAL SIZE OF C * THE COMPUTE GRID, TO WORK PROPERLY WITH THE INTERPOLATION C * ROUTINE "CMINTR", WHICH WAS DESIGNED TO WORK ON THE "LON*LAT" C * GATHERED GRID IN THE OLD CTEM VERSION. C REAL USEFRAC(IL2,2), CTEMP1(IL2) C C * LOCAL DATA. C REAL C_TMP_TIME(3) C INTEGER MONTHP1, TMESTMP1, TMESTMP2 INTEGER :: nint C----------------------------------------------------------------------------- C * WE HAVE NEW AND PREVIOUS LAND COVER WE FIND THE LAND C * COVER FOR THE GIVEN DAY WHICH WE CALL CURFRAC (THIS IS INFACT C * LAND COVER AT THE START OF THE DAY). PLUS WE ALSO FIND LAND C * COVER FOR THE END OF THIS DAY/BEGINNING OF NEXT DAY FOR USE C * THE LAND USE CHANGE SUBROUTINE. C DO K = 1, ICC DO IL=IL1,IL2 USEFRAC(IL,1)=PREFRAC(IL,K) USEFRAC(IL,2)=NEWFRAC(IL,K) ENDDO C C * TIME STAMPS FOR INTERPOLATION USING WARREN'S SUBROUTINE. THESE C * ARE FOR THE CURRENT DAY C C_TMP_TIME(1)=REAL(LNDCVRYR2) C_TMP_TIME(2)=REAL(IDAY) C_TMP_TIME(3)=GMT C CALL CTMINTR(USEFRAC,C_CLIM_TIME,2,CTEMP1,C_TMP_TIME,1, + IL2,1) DO IL=IL1,IL2 CURFRAC(IL,K)=CTEMP1(IL) ENDDO C C * TIME STAMPS FOR THE NEXT DAY C IF(IDAY.LT.365) THEN C_TMP_TIME(2)=REAL(IDAY+1) ELSE IF(IDAY.EQ.365) THEN C_TMP_TIME(1)=REAL(LNDCVRYR2 + 1) C_TMP_TIME(2)=1. ENDIF C CALL CTMINTR(USEFRAC,C_CLIM_TIME,2,CTEMP1,C_TMP_TIME,1, + IL2,1) DO IL=IL1,IL2 TODFRAC(IL,K)=CTEMP1(IL) ENDDO C C * SOME GLACIAL CELLS (TAGGED WITH SAND EQUAL TO -4) MAY HAVE SOME C * VEGETATION ACCORDING TO DAVID PRICE'S LAND COVER DATA SETS. FORCE C * THE FRACTIONAL COVERAGE OF ALL PFTs EQUAL TO ZERO OVER GLACIAL CELLS. C DO I = IL1, IL2 IF( NINT(SANDARRY(I,1)).EQ.-4 .OR. & SOILDPTH(I).LT.1.E-05 )THEN CURFRAC(I,K)=0.0 TODFRAC(I,K)=0.0 NEWFRAC(I,K)=0.0 PREFRAC(I,K)=0.0 ENDIF ENDDO ENDDO C C * CONVERT FRACTIONAL COVERAGE OF CTEM 9 PFTs TO FRACTIONAL C * COVERAGE OF CLASS 4 PFTs C DO J = 1, IC DO I = IL1, IL2 FCANMX(I,J)=0.0 ENDDO ENDDO C K1=0 DO J = 1, IC IF(J.EQ.1) THEN K1 = K1 + 1 ELSE K1 = K1 + NOL2PFTS(J-1) ENDIF K2 = K1 + NOL2PFTS(J) - 1 DO M = K1, K2 DO I = IL1, IL2 FCANMX(I,J)=FCANMX(I,J)+CURFRAC(I,M) ENDDO ENDDO ENDDO RETURN END SUBROUTINE CTEMG ( 1 CO2CG1GAT,CO2CG2GAT,CO2CS1GAT,CO2CS2GAT, 2 CFLUXCSGAT,CFLUXCGGAT,CO2GAT,FSFGAT, 3 LGHTGAT,PFHCGAT,PEXFGAT,WETFGAT,WETSGAT, 4 SOILCGAT,LITRCGAT,ROOTCGAT,STEMCGAT, 5 GLEAFCGAT,BLEAFCGAT,FALLHGAT,POSPHGAT, 6 LEAFSGAT,GROWTGAT,LASTRGAT,LASTSGAT, 7 THISYLGAT,STEMHGAT,ROOTHGAT,TEMPCGAT, 9 PREFGAT,NEWFGAT,AREAGAT, A SANDGAT,CLAYGAT,SDEPGAT, B TAGTL,FSNOWGTL,TCANOGTL,TCANSGTL, C TBARGTL,TBARCGTL,TBARCSGTL,TBARGGTL, D TBARGSGTL,THLIQCGTL,THLIQGGTL,THICECGTL, E ANCSGTL,ANCGGTL,RMLCSGTL,RMLCGGTL, F ILMOS,JLMOS, G NML,NL,NT,NM,ILG,IG,IC,ICP1, H ICTEM,ICTEMP1,KOUNT,GMT, J CO2CG1ROT,CO2CG2ROT,CO2CS1ROT,CO2CS2ROT, K CFLUXCSROT,CFLUXCGROT,CO2ROW,FSFROT, L LGHTROW,PFHCROW,PEXFROW,WETFROW,WETSROW, M SOILCROT,LITRCROT,ROOTCROT,STEMCROT, N GLEAFCROT,BLEAFCROT,FALLHROT,POSPHROT, O LEAFSROT,GROWTROT,LASTRROT,LASTSROT, P THISYLROT,STEMHROT,ROOTHROT,TEMPCROT, R PREFROT,NEWFROT,AREAROW, S SANDROT,CLAYROT,SDEPROT, T TARTL,FSNOWRTL,TCANORTL,TCANSRTL, U TBARRTL,TBARCRTL,TBARCSRTL,TBARGRTL, V TBARGSRTL,THLIQCRTL,THLIQGRTL,THICECRTL, W ANCSRTL,ANCGRTL,RMLCSRTL,RMLCGRTL ) C C * Feb 20/16 - M.LAZARE. New version for gcm19+: C * - Add all necessary extra arrays to C * support moving CTEM into AGCM. C * Jan 15/15 - M.LAZARE. Previous version for gcm18: C * Remove FIELDSM,WILTSM (replaced by C * THFC,THLW used for both CTEM and CLASS). C * JAN 26/13 - M.LAZARE. ADD PAICROT/PAICGAT AND SLAICROT/SLAICGAT. C * NOV 10/11 - M.LAZARE. GATHER ROUTINE FOR CTEM BASED ON CLASSG. C IMPLICIT NONE C C * INTEGER CONSTANTS. C INTEGER NML,NL,NT,NM,ILG,IG,IC,ICP1,ICTEM,ICTEMP1,J,K,L,M,KOUNT REAL GMT C C * CTEM VARIABLES. C REAL CO2CG1ROT(NL,NT,ICTEM), CO2CG2ROT(NL,NT,ICTEM), 1 CO2CS1ROT(NL,NT,ICTEM), CO2CS2ROT(NL,NT,ICTEM) REAL CFLUXCSROT(NL,NT), CFLUXCGROT(NL,NT) C C * INVARIANT CTEM FIELDS. C REAL LGHTROW (NL), PFHCROW (NL), PEXFROW (NL), 1 WETFROW (NL), WETSROW (NL) C C * INPUT FIELDS TO MAIN CTEM ROUTINE FROM AVERAGE OVER C * COUPLING PERIOD OF PREVIOUS COUPLING CYCLE. C * THESE ARE NOT GATHERED AT GMT=0. SINCE THE "ROT" C * FIELDS DON'T EXIST AT THIS POINT UNTIL THEY ARE INITIALIZED. C REAL TBARRTL (NL,NT,IG), TBARCRTL (NL,NT,IG), 1 TBARCSRTL(NL,NT,IG), TBARGRTL (NL,NT,IG), 2 TBARGSRTL(NL,NT,IG), THLIQCRTL(NL,NT,IG), 3 THLIQGRTL(NL,NT,IG), THICECRTL(NL,NT,IG) C REAL ANCSRTL (NL,NT,ICTEM), ANCGRTL (NL,NT,ICTEM), 1 RMLCSRTL (NL,NT,ICTEM), RMLCGRTL (NL,NT,ICTEM) C REAL TARTL (NL,NT), FSNOWRTL (NL,NT), 1 TCANORTL (NL,NT), TCANSRTL (NL,NT) C C * INPUT/OUTPUT FIELDS FROM MAIN CTEM ROUTINE. C REAL SOILCROT (NL,NT,ICTEMP1), LITRCROT (NL,NT,ICTEMP1), 1 ROOTCROT (NL,NT,ICTEM), STEMCROT (NL,NT,ICTEM), 2 GLEAFCROT(NL,NT,ICTEM), BLEAFCROT(NL,NT,ICTEM), 3 FALLHROT (NL,NT,ICTEM), POSPHROT (NL,NT,ICTEM), 4 LEAFSROT (NL,NT,ICTEM), GROWTROT (NL,NT,ICTEM), 5 LASTRROT (NL,NT,ICTEM), LASTSROT (NL,NT,ICTEM), 6 THISYLROT(NL,NT,ICTEM), STEMHROT (NL,NT,ICTEM), 7 ROOTHROT (NL,NT,ICTEM), TEMPCROT (NL,NT,2) C C * CTEM VEGEGATION CLASS FRACTION FIELDS (3 TIME LEVELS). C REAL PREFROT (NL,NT,ICTEM), NEWFROT (NL,NT,ICTEM) C C * FRACTION AREA OF LAND. C REAL AREAROW (NL) C C * INVARIANT CLASS INPUT FIELDS. C REAL SANDROT (NL,NT,IG), CLAYROT (NL,NT,IG) REAL SDEPROT (NL,NT) C------------------------------------------------------------- REAL CO2CG1GAT(ILG,ICTEM), CO2CG2GAT(ILG,ICTEM), 1 CO2CS1GAT(ILG,ICTEM), CO2CS2GAT(ILG,ICTEM) REAL CFLUXCSGAT(ILG), CFLUXCGGAT(ILG) C C * INVARIANT CTEM FIELDS. C REAL LGHTGAT (ILG), PFHCGAT (ILG), 1 PEXFGAT (ILG), WETFGAT (ILG), 2 WETSGAT (ILG) C C * INPUT FIELDS TO MAIN CTEM ROUTINE FROM AVERAGE OVER C * COUPLING PERIOD OF PREVIOUS COUPLING CYCLE. C * THESE ARE NOT GATHERED AT GMT=0. SINCE THE "ROT" C * FIELDS DON'T EXIST AT THIS POINT UNTIL THEY ARE INITIALIZED. C REAL TBARGTL (ILG,IG), TBARCGTL (ILG,IG), 1 TBARCSGTL(ILG,IG), TBARGGTL (ILG,IG), 2 TBARGSGTL(ILG,IG), THLIQCGTL(ILG,IG), 3 THLIQGGTL(ILG,IG), THICECGTL(ILG,IG) C REAL ANCSGTL (ILG,ICTEM), ANCGGTL (ILG,ICTEM), 1 RMLCSGTL (ILG,ICTEM), RMLCGGTL (ILG,ICTEM) C REAL TAGTL (ILG), FSNOWGTL (ILG), 1 TCANOGTL (ILG), TCANSGTL (ILG) C C * INPUT/OUTPUT FIELDS FROM MAIN CTEM ROUTINE. C REAL SOILCGAT (ILG,ICTEMP1), LITRCGAT (ILG,ICTEMP1), 1 ROOTCGAT (ILG,ICTEM), STEMCGAT (ILG,ICTEM), 2 GLEAFCGAT(ILG,ICTEM), BLEAFCGAT(ILG,ICTEM), 3 FALLHGAT (ILG,ICTEM), GROWTGAT (ILG,ICTEM), 5 LASTRGAT (ILG,ICTEM), LASTSGAT (ILG,ICTEM), 6 THISYLGAT(ILG,ICTEM), STEMHGAT (ILG,ICTEM), 7 ROOTHGAT (ILG,ICTEM) INTEGER POSPHGAT (ILG,ICTEM), LEAFSGAT (ILG,ICTEM), 1 TEMPCGAT (ILG,2) C C * CTEM VEGEGATION CLASS FRACTION FIELDS (3 TIME LEVELS). C REAL PREFGAT (ILG,ICTEM), NEWFGAT (ILG,ICTEM) C C * FRACTION AREA OF LAND. C REAL AREAGAT (ILG) C C * INVARIANT CLASS INPUT FIELDS. C REAL SANDGAT (ILG,IG), CLAYGAT (ILG,IG) REAL SDEPGAT (ILG) C C * ATMOSPHERIC AND GRID-CONSTANT INPUT VARIABLES. C REAL CO2ROW( NL), FSFROT( NL,NM) C REAL CO2GAT(ILG), FSFGAT(ILG) C C * GATHER-SCATTER INDEX ARRAYS. C INTEGER ILMOS (ILG), JLMOS (ILG) C---------------------------------------------------------------------- DO 100 K=1,NML CFLUXCSGAT(K)=CFLUXCSROT(ILMOS(K),JLMOS(K)) CFLUXCGGAT(K)=CFLUXCGROT(ILMOS(K),JLMOS(K)) CO2GAT (K)=CO2ROW (ILMOS(K)) FSFGAT (K)=FSFROT (ILMOS(K),JLMOS(K)) LGHTGAT (K)=LGHTROW (ILMOS(K)) PFHCGAT (K)=PFHCROW (ILMOS(K)) PEXFGAT (K)=PEXFROW (ILMOS(K)) WETFGAT (K)=WETFROW (ILMOS(K)) WETSGAT (K)=WETSROW (ILMOS(K)) SDEPGAT (K)=SDEPROT (ILMOS(K),JLMOS(K)) AREAGAT (K)=AREAROW (ILMOS(K)) 100 CONTINUE C DO 200 L=1,ICTEM DO 200 K=1,NML CO2CG1GAT(K,L)=CO2CG1ROT(ILMOS(K),JLMOS(K),L) CO2CG2GAT(K,L)=CO2CG2ROT(ILMOS(K),JLMOS(K),L) CO2CS1GAT(K,L)=CO2CS1ROT(ILMOS(K),JLMOS(K),L) CO2CS2GAT(K,L)=CO2CS2ROT(ILMOS(K),JLMOS(K),L) C ROOTCGAT (K,L)=ROOTCROT (ILMOS(K),JLMOS(K),L) STEMCGAT (K,L)=STEMCROT (ILMOS(K),JLMOS(K),L) GLEAFCGAT(K,L)=GLEAFCROT(ILMOS(K),JLMOS(K),L) BLEAFCGAT(K,L)=BLEAFCROT(ILMOS(K),JLMOS(K),L) FALLHGAT (K,L)=FALLHROT (ILMOS(K),JLMOS(K),L) POSPHGAT (K,L)=NINT(POSPHROT(ILMOS(K),JLMOS(K),L)) LEAFSGAT (K,L)=NINT(LEAFSROT(ILMOS(K),JLMOS(K),L)) GROWTGAT (K,L)=GROWTROT (ILMOS(K),JLMOS(K),L) LASTRGAT (K,L)=LASTRROT (ILMOS(K),JLMOS(K),L) LASTSGAT (K,L)=LASTSROT (ILMOS(K),JLMOS(K),L) THISYLGAT(K,L)=THISYLROT(ILMOS(K),JLMOS(K),L) STEMHGAT (K,L)=STEMHROT (ILMOS(K),JLMOS(K),L) ROOTHGAT (K,L)=ROOTHROT (ILMOS(K),JLMOS(K),L) C PREFGAT (K,L)=PREFROT (ILMOS(K),JLMOS(K),L) NEWFGAT (K,L)=NEWFROT (ILMOS(K),JLMOS(K),L) 200 CONTINUE C DO 250 L=1,ICTEMP1 DO 250 K=1,NML SOILCGAT (K,L)=SOILCROT (ILMOS(K),JLMOS(K),L) LITRCGAT (K,L)=LITRCROT (ILMOS(K),JLMOS(K),L) 250 CONTINUE C DO 280 L=1,2 DO 280 K=1,NML TEMPCGAT (K,L)=NINT(TEMPCROT(ILMOS(K),JLMOS(K),L)) 280 CONTINUE C IF(GMT.GT.0. .AND. KOUNT.GT.0) THEN DO 400 L=1,IG DO 400 K=1,NML TBARGTL (K,L)=TBARRTL (ILMOS(K),JLMOS(K),L) TBARCGTL (K,L)=TBARCRTL (ILMOS(K),JLMOS(K),L) TBARCSGTL(K,L)=TBARCSRTL(ILMOS(K),JLMOS(K),L) TBARGGTL (K,L)=TBARGRTL (ILMOS(K),JLMOS(K),L) TBARGSGTL(K,L)=TBARGSRTL(ILMOS(K),JLMOS(K),L) THLIQCGTL(K,L)=THLIQCRTL(ILMOS(K),JLMOS(K),L) THLIQGGTL(K,L)=THLIQGRTL(ILMOS(K),JLMOS(K),L) THICECGTL(K,L)=THICECRTL(ILMOS(K),JLMOS(K),L) 400 CONTINUE C DO 500 L=1,ICTEM DO 500 K=1,NML ANCSGTL (K,L)=ANCSRTL (ILMOS(K),JLMOS(K),L) ANCGGTL (K,L)=ANCGRTL (ILMOS(K),JLMOS(K),L) RMLCSGTL (K,L)=RMLCSRTL (ILMOS(K),JLMOS(K),L) RMLCGGTL (K,L)=RMLCGRTL (ILMOS(K),JLMOS(K),L) 500 CONTINUE C DO 600 K=1,NML TAGTL (K)=TARTL (ILMOS(K),JLMOS(K)) FSNOWGTL (K)=FSNOWRTL (ILMOS(K),JLMOS(K)) TCANOGTL (K)=TCANORTL (ILMOS(K),JLMOS(K)) TCANSGTL (K)=TCANSRTL (ILMOS(K),JLMOS(K)) 600 CONTINUE ENDIF C DO 700 L=1,IG DO 700 K=1,NML SANDGAT (K,L) =SANDROT (ILMOS(K),JLMOS(K),L) CLAYGAT (K,L) =CLAYROT (ILMOS(K),JLMOS(K),L) 700 CONTINUE RETURN END SUBROUTINE CTEMS (RMATCROT,RTCTMROT, 1 AILCROT,PAICROT,SLAICROT, 2 FCANCROT,TODFCROT,AILCGROT,SLAIROT, 3 CFCANROT,CALVCROT,CALICROT, 4 ZOLNCROT,CMASCROT, 5 CFLUXCGROT,CFLUXCSROT, 6 CO2CG1ROT,CO2CG2ROT,CO2CS1ROT,CO2CS2ROT, 7 TARTL,FSNOWRTL,TCANORTL,TCANSRTL, 8 TBARRTL,TBARCRTL,TBARCSRTL,TBARGRTL, 9 TBARGSRTL,THLIQCRTL,THLIQGRTL,THICECRTL, A ANCSRTL,ANCGRTL,RMLCSRTL,RMLCGRTL, B SOILCROT,LITRCROT,ROOTCROT,STEMCROT, C GLEAFCROT,BLEAFCROT,FALLHROT,POSPHROT, D LEAFSROT,GROWTROT,LASTRROT,LASTSROT, E THISYLROT,STEMHROT,ROOTHROT,TEMPCROT, F AILCBROT,BMASVROT,VEGHROT,ROOTDROT, G CVEGROT,CDEBROT,CHUMROT,FCOLROT, H PREFROT,NEWFROT, I ILMOS,JLMOS, J NML,NL,NM,ILG,IG,IC,ICP1,ICTEM,ICTEMP1, K RMATCGAT,RTCTMGAT, L AILCGAT,PAICGAT,SLAICGAT, M FCANCGAT,TODFCGAT,AILCGGAT,SLAIGAT, N CFCANGAT,CALVCGAT,CALICGAT, O ZOLNCGAT,CMASCGAT, P CFLUXCGGAT,CFLUXCSGAT, Q CO2CG1GAT,CO2CG2GAT,CO2CS1GAT,CO2CS2GAT, R TAGTL,FSNOWGTL,TCANOGTL,TCANSGTL, S TBARGTL,TBARCGTL,TBARCSGTL,TBARGGTL, T TBARGSGTL,THLIQCGTL,THLIQGGTL,THICECGTL, U ANCSGTL,ANCGGTL,RMLCSGTL,RMLCGGTL, V SOILCGAT,LITRCGAT,ROOTCGAT,STEMCGAT, W GLEAFCGAT,BLEAFCGAT,FALLHGAT,POSPHGAT, X LEAFSGAT,GROWTGAT,LASTRGAT,LASTSGAT, Y THISYLGAT,STEMHGAT,ROOTHGAT,TEMPCGAT, Z AILCBGAT,BMASVGAT,VEGHGAT,ROOTDGAT, + CVEGGAT,CDEBGAT,CHUMGAT,FCOLGAT, + PREFGAT,NEWFGAT ) C C * Feb 20/16 - M.LAZARE. New version for gcm19+: C * - Add all necessary extra arrays to C * support moving CTEM into AGCM. C * NOV 10/11 - M.LAZARE. SCATTER ROUTINE FOR CTEM BASED ON CLASSS. C IMPLICIT NONE C C * INTEGER CONSTANTS. C INTEGER NML,NL,NM,ILG,IG,IC,ICP1,ICTEM,ICTEMP1,J,K,L,M C C * CTEM VARIABLES. C REAL RMATCROT(NL,NM,IC,IG) REAL RTCTMROT(NL,NM,ICTEM,IG) REAL CFCANROT(NL,NM,ICP1), CALVCROT (NL,NM,ICP1), 1 CALICROT(NL,NM,ICP1) REAL AILCROT (NL,NM,IC), PAICROT (NL,NM,IC), 1 SLAICROT (NL,NM,IC), ZOLNCROT (NL,NM,IC), 2 CMASCROT (NL,NM,IC) REAL FCANCROT (NL,NM,ICTEM), TODFCROT (NL,NM,ICTEM), 1 AILCGROT (NL,NM,ICTEM), SLAIROT (NL,NM,ICTEM), 2 CO2CG1ROT(NL,NM,ICTEM), CO2CG2ROT(NL,NM,ICTEM), 3 CO2CS1ROT(NL,NM,ICTEM), CO2CS2ROT(NL,NM,ICTEM) C REAL CFLUXCSROT(NL,NM), CFLUXCGROT(NL,NM) REAL TBARRTL (NL,NM,IG), TBARCRTL (NL,NM,IG), 1 TBARCSRTL(NL,NM,IG), TBARGRTL (NL,NM,IG), 2 TBARGSRTL(NL,NM,IG), THLIQCRTL(NL,NM,IG), 3 THLIQGRTL(NL,NM,IG), THICECRTL(NL,NM,IG) C REAL ANCSRTL (NL,NM,ICTEM), ANCGRTL (NL,NM,ICTEM), 1 RMLCSRTL (NL,NM,ICTEM), RMLCGRTL (NL,NM,ICTEM) C REAL TARTL (NL,NM), FSNOWRTL (NL,NM), 1 TCANORTL (NL,NM), TCANSRTL (NL,NM) REAL SOILCROT (NL,NM,ICTEMP1), LITRCROT (NL,NM,ICTEMP1), 1 ROOTCROT (NL,NM,ICTEM), STEMCROT (NL,NM,ICTEM), 2 GLEAFCROT(NL,NM,ICTEM), BLEAFCROT(NL,NM,ICTEM), 3 FALLHROT (NL,NM,ICTEM), POSPHROT (NL,NM,ICTEM), 4 LEAFSROT (NL,NM,ICTEM), GROWTROT (NL,NM,ICTEM), 5 LASTRROT (NL,NM,ICTEM), LASTSROT (NL,NM,ICTEM), 6 THISYLROT(NL,NM,ICTEM), STEMHROT (NL,NM,ICTEM), 7 ROOTHROT (NL,NM,ICTEM), TEMPCROT (NL,NM,2), 8 AILCBROT (NL,NM,ICTEM), BMASVROT (NL,NM,ICTEM), 9 VEGHROT (NL,NM,ICTEM), ROOTDROT (NL,NM,ICTEM) REAL CVEGROT(NL,NM), CDEBROT(NL,NM), CHUMROT(NL,NM), 1 FCOLROT(NL,NM) C C * CTEM VEGEGATION CLASS FRACTION FIELDS (3 TIME LEVELS). C REAL PREFROT (NL,NM,ICTEM), NEWFROT (NL,NM,ICTEM) C------------------------------------------------------------ REAL RMATCGAT(ILG,IC,IG) REAL RTCTMGAT(ILG,ICTEM,IG) REAL CFCANGAT(ILG,IC), CALVCGAT(ILG,IC), 1 CALICGAT(ILG,IC) REAL AILCGAT (ILG,IC), PAICGAT (ILG,IC), 1 SLAICGAT(ILG,IC), ZOLNCGAT(ILG,IC), 2 CMASCGAT(ILG,IC) REAL FCANCGAT (ILG,ICTEM), TODFCGAT (ILG,ICTEM), 1 AILCGGAT (ILG,ICTEM), SLAIGAT (ILG,ICTEM), 2 CO2CG1GAT(ILG,ICTEM), CO2CG2GAT(ILG,ICTEM), 3 CO2CS1GAT(ILG,ICTEM), CO2CS2GAT(ILG,ICTEM) C REAL CFLUXCSGAT(ILG), CFLUXCGGAT(ILG) REAL TBARGTL (ILG,IG), TBARCGTL (ILG,IG), 1 TBARCSGTL(ILG,IG), TBARGGTL (ILG,IG), 2 TBARGSGTL(ILG,IG), THLIQCGTL(ILG,IG), 3 THLIQGGTL(ILG,IG), THICECGTL(ILG,IG) C REAL ANCSGTL (ILG,ICTEM), ANCGGTL (ILG,ICTEM), 1 RMLCSGTL (ILG,ICTEM), RMLCGGTL (ILG,ICTEM) C REAL TAGTL (ILG), FSNOWGTL (ILG), 1 TCANOGTL (ILG), TCANSGTL (ILG) REAL SOILCGAT (ILG,ICTEMP1), LITRCGAT (ILG,ICTEMP1), 1 ROOTCGAT (ILG,ICTEM), STEMCGAT (ILG,ICTEM), 2 GLEAFCGAT(ILG,ICTEM), BLEAFCGAT(ILG,ICTEM), 3 FALLHGAT (ILG,ICTEM), GROWTGAT (ILG,ICTEM), 5 LASTRGAT (ILG,ICTEM), LASTSGAT (ILG,ICTEM), 6 THISYLGAT(ILG,ICTEM), STEMHGAT (ILG,ICTEM), 7 ROOTHGAT (ILG,ICTEM), 8 AILCBGAT (ILG,ICTEM), BMASVGAT (ILG,ICTEM), 9 VEGHGAT (ILG,ICTEM), ROOTDGAT (ILG,ICTEM) INTEGER POSPHGAT (ILG,ICTEM), LEAFSGAT (ILG,ICTEM), 1 TEMPCGAT (ILG,2) REAL CVEGGAT(ILG), CDEBGAT(ILG), CHUMGAT(ILG), 1 FCOLGAT(ILG) C C * CTEM VEGEGATION CLASS FRACTION FIELDS (3 TIME LEVELS). C REAL PREFGAT (ILG,ICTEM), NEWFGAT (ILG,ICTEM) C C * GATHER-SCATTER INDEX ARRAYS. C INTEGER ILMOS (ILG), JLMOS (ILG) C---------------------------------------------------------------------- DO 100 K=1,NML TARTL (ILMOS(K),JLMOS(K))=TAGTL (K) FSNOWRTL (ILMOS(K),JLMOS(K))=FSNOWGTL (K) TCANORTL (ILMOS(K),JLMOS(K))=TCANOGTL (K) TCANSRTL (ILMOS(K),JLMOS(K))=TCANSGTL (K) CFLUXCSROT(ILMOS(K),JLMOS(K))=CFLUXCSGAT(K) CFLUXCGROT(ILMOS(K),JLMOS(K))=CFLUXCGGAT(K) CVEGROT (ILMOS(K),JLMOS(K))=CVEGGAT (K) CDEBROT (ILMOS(K),JLMOS(K))=CDEBGAT (K) CHUMROT (ILMOS(K),JLMOS(K))=CHUMGAT (K) FCOLROT (ILMOS(K),JLMOS(K))=FCOLGAT (K) 100 CONTINUE C DO 150 L=1,IC DO 150 K=1,NML CFCANROT (ILMOS(K),JLMOS(K),L)=CFCANGAT(K,L) CALVCROT (ILMOS(K),JLMOS(K),L)=CALVCGAT(K,L) CALICROT (ILMOS(K),JLMOS(K),L)=CALICGAT(K,L) 150 CONTINUE C DO 175 L=1,IC DO 175 K=1,NML ZOLNCROT (ILMOS(K),JLMOS(K),L)=ZOLNCGAT(K,L) CMASCROT (ILMOS(K),JLMOS(K),L)=CMASCGAT(K,L) AILCROT (ILMOS(K),JLMOS(K),L)=AILCGAT (K,L) PAICROT (ILMOS(K),JLMOS(K),L)=PAICGAT (K,L) SLAICROT (ILMOS(K),JLMOS(K),L)=SLAICGAT(K,L) 175 CONTINUE C DO 200 L=1,ICTEM DO 200 K=1,NML FCANCROT (ILMOS(K),JLMOS(K),L)=FCANCGAT(K,L) TODFCROT (ILMOS(K),JLMOS(K),L)=TODFCGAT(K,L) AILCGROT (ILMOS(K),JLMOS(K),L)=AILCGGAT(K,L) SLAIROT (ILMOS(K),JLMOS(K),L)=SLAIGAT(K,L) C CO2CG1ROT(ILMOS(K),JLMOS(K),L)=CO2CG1GAT(K,L) CO2CG2ROT(ILMOS(K),JLMOS(K),L)=CO2CG2GAT(K,L) CO2CS1ROT(ILMOS(K),JLMOS(K),L)=CO2CS1GAT(K,L) CO2CS2ROT(ILMOS(K),JLMOS(K),L)=CO2CS2GAT(K,L) ANCSRTL (ILMOS(K),JLMOS(K),L)=ANCSGTL(K,L) ANCGRTL (ILMOS(K),JLMOS(K),L)=ANCGGTL(K,L) RMLCSRTL (ILMOS(K),JLMOS(K),L)=RMLCSGTL(K,L) RMLCGRTL (ILMOS(K),JLMOS(K),L)=RMLCGGTL(K,L) C ROOTCROT (ILMOS(K),JLMOS(K),L)=ROOTCGAT (K,L) STEMCROT (ILMOS(K),JLMOS(K),L)=STEMCGAT (K,L) GLEAFCROT(ILMOS(K),JLMOS(K),L)=GLEAFCGAT(K,L) BLEAFCROT(ILMOS(K),JLMOS(K),L)=BLEAFCGAT(K,L) FALLHROT (ILMOS(K),JLMOS(K),L)=FALLHGAT (K,L) POSPHROT (ILMOS(K),JLMOS(K),L)=REAL(POSPHGAT(K,L)) LEAFSROT (ILMOS(K),JLMOS(K),L)=REAL(LEAFSGAT(K,L)) GROWTROT (ILMOS(K),JLMOS(K),L)=GROWTGAT (K,L) LASTRROT (ILMOS(K),JLMOS(K),L)=LASTRGAT (K,L) LASTSROT (ILMOS(K),JLMOS(K),L)=LASTSGAT (K,L) THISYLROT(ILMOS(K),JLMOS(K),L)=THISYLGAT(K,L) STEMHROT (ILMOS(K),JLMOS(K),L)=STEMHGAT (K,L) ROOTHROT (ILMOS(K),JLMOS(K),L)=ROOTHGAT (K,L) AILCBROT (ILMOS(K),JLMOS(K),L)=AILCBGAT (K,L) BMASVROT (ILMOS(K),JLMOS(K),L)=BMASVGAT (K,L) VEGHROT (ILMOS(K),JLMOS(K),L)=VEGHGAT (K,L) ROOTDROT (ILMOS(K),JLMOS(K),L)=ROOTDGAT (K,L) 200 CONTINUE C DO 250 L=1,ICTEMP1 DO 250 K=1,NML SOILCROT (ILMOS(K),JLMOS(K),L)=SOILCGAT(K,L) LITRCROT (ILMOS(K),JLMOS(K),L)=LITRCGAT(K,L) 250 CONTINUE C DO 280 L=1,2 DO 280 K=1,NML TEMPCROT (ILMOS(K),JLMOS(K),L)=REAL(TEMPCGAT(K,L)) 280 CONTINUE C DO 300 L=1,IG DO 300 K=1,NML TBARRTL (ILMOS(K),JLMOS(K),L)=TBARGTL (K,L) TBARCRTL (ILMOS(K),JLMOS(K),L)=TBARCGTL (K,L) TBARCSRTL(ILMOS(K),JLMOS(K),L)=TBARCSGTL(K,L) TBARGRTL (ILMOS(K),JLMOS(K),L)=TBARGGTL (K,L) TBARGSRTL(ILMOS(K),JLMOS(K),L)=TBARGSGTL(K,L) THLIQCRTL(ILMOS(K),JLMOS(K),L)=THLIQCGTL(K,L) THLIQGRTL(ILMOS(K),JLMOS(K),L)=THLIQGGTL(K,L) THICECRTL(ILMOS(K),JLMOS(K),L)=THICECGTL(K,L) 300 CONTINUE C DO 350 L=1,ICTEM DO 350 K=1,NML PREFROT (ILMOS(K),JLMOS(K),L)=PREFGAT(K,L) NEWFROT (ILMOS(K),JLMOS(K),L)=NEWFGAT(K,L) 350 CONTINUE C DO 500 J=1,IG DO 500 L=1,IC DO 500 K=1,NML RMATCROT(ILMOS(K),JLMOS(K),L,J)=RMATCGAT(K,L,J) 500 CONTINUE C DO 600 J=1,IG DO 600 L=1,ICTEM DO 600 K=1,NML RTCTMROT(ILMOS(K),JLMOS(K),L,J)=RTCTMGAT(K,L,J) 600 CONTINUE RETURN END SUBROUTINE HYDLABT(LC,LG,LCT,LGT,LCTEM,LCTG,LCTEMG, 1 ICAN,ICANP1,IGND,ICTEM,ICTEMP1,NTLD) C * Feb 15/16 - M.Lazare. New version for gcm19: C * - ICTEMP1 passed in and used to dimension LCTEM C * to handle extra "level" for SOILCMAS and LITRCMAS C * for CTEM now in CLASS. C * - ICAN also passed in to help define new "LCTG" C * array, along with IGND and NTLD.. C * - ICTEM,NTLD,IGND used to define new "LCTEMG" array C * - Also, LCTEM is defined the usual non-tiled C * way if only one land tile. C * Jan 26/14 - M.Lazare. Previous version for gcm18: C * - ICTEM passed in and used to dimension LCTEM. C * - IM->NTLD for land-only tiles. C * - Now IMPLICT NONE. C * NOV 08/11 - M.LAZARE. PREVIOUS VERSION HYDLABT FOR GCM15J+ USING C * CLASS_V3.5 AND TILES. C * AUG 13/91 - M.LAZARE. PREVIOUS VERSION HYDLAB FOR GCM7 IHYD=2 (ICAN=4). C C * DEFINES LEVEL INDEX VALUES FOR CANOPY AND SUB-SURFACE LAND- C * SURFACE SCHEME (IHYD=2) ARRAYS. C * CANOPY ARRAY IS EXTENDED TO INCLUDE "URBAN" CLASS. C IMPLICIT NONE INTEGER ICAN,ICANP1,IGND,ICTEM,ICTEMP1,NTLD,K,L,M, 1 MLC,MLG,MLCT,MLCG INTEGER LC(ICANP1),LG(IGND) INTEGER LCT(NTLD*ICANP1),LGT(NTLD*IGND),LCTEM(NTLD*ICTEMP1) INTEGER LCTG(NTLD*IGND*ICAN), LCTEMG(NTLD*IGND*ICTEM) C----------------------------------------------------------------------- C * NON-TILED USUAL INPUT/OUTPUT. C DO 10 L=1,ICANP1 LC(L)=L 10 CONTINUE DO 20 L=1,IGND LG(L)=L 20 CONTINUE C C * TILED INPUT/OUTPUT. C MLC=0 DO 100 L=1,ICANP1 DO 100 M=1,NTLD MLC = MLC+1 LCT(MLC) = 1000*L + M 100 CONTINUE C MLG=0 DO 200 L=1,IGND DO 200 M=1,NTLD MLG = MLG+1 LGT(MLG) = 1000*L + M 200 CONTINUE C MLCG=0 DO L=1,ICAN DO K=1,IGND DO M=1,NTLD MLCG = MLCG+1 LCTG(MLCG) = 1000*L + K*M ENDDO ENDDO ENDDO C IF(NTLD.EQ.1) THEN DO L=1,ICTEMP1 LCTEM(L)=L ENDDO C MLCG=0 DO L=1,ICAN DO K=1,IGND MLCG = MLCG+1 LCTEMG(MLCG) = 1000*L + K ENDDO ENDDO ELSE MLCT=0 DO L=1,ICTEMP1 DO M=1,NTLD MLCT = MLCT+1 LCTEM(MLCT) = 1000*L + M ENDDO ENDDO C MLCG=0 DO L=1,ICTEM DO K=1,IGND DO M=1,NTLD MLCG = MLCG+1 LCTEMG(MLCG) = 1000*L + K*M ENDDO ENDDO ENDDO ENDIF RETURN END %id rad_fix %d raddriv10.1462 F1(I,K) = FA(J,K,IB) * DP(I,K) + X3 * VSCGA(IB) %id bugfix_wrkab %d raddriv10.1706,1707 WRKA(J,IB) = WRKA(J,IB)+WRKAG(I)*WWW/REAL(KGS(IB)) WRKB(J,IB) = WRKB(J,IB)+WRKBG(I)*WWW/REAL(KGS(IB)) %id fix_clipping %d conv17.1104 DSDTMIN= -(AFS *(T(ISHALL(IL),L) 1 +DSFDT(ISHALL(IL),L)*ZTMST))/ZTMST IF ( DSDT(IL,L).LT.DSDTMIN ) THEN %d conv17.1109 DQDTMIN=-(AFS*(Q(ISHALL(IL),L) 1 +DQFDT(ISHALL(IL),L)*ZTMST))/ZTMST IF ( DQDT(IL,L).LT.DQDTMIN ) THEN %d conv17.1120 DXDTMIN=-(AFS*(X(ISHALL(IL),L,N) 1 +DXFDT(ISHALL(IL),L,N)*ZTMST))/ZTMST IF ( DXDT(IL,L,N).LT.DXDTMIN) THEN %d tdcal6.464 DQDTMIN=-AFS*QG (IL,L)/DT IF ( DQDT(IL,L).LT.DQDTMIN .AND. ISKIP(IL).EQ.0 ) THEN %d tdcal6.468 DTDTMIN=-AFS*DSNG(IL,L)/(CPRES*DT) IF ( DTDT(IL,L).LT.DTDTMIN .AND. ISKIP(IL).EQ.0 ) THEN %d tdcal6.482,483 DXDTMIN=-AFS*XG(IL,L,N)/DT IF (DXDT(IL,L,N).LT.DXDTMIN .AND. ISKIP(IL).EQ.0) THEN %id no_wlost %d classa.10,11 8 CWLCPS, CWFCPS, RC, RCS, RBCOEF, FROOT, 9 FROOTS, ZPLIMC, ZPLIMG, ZPLMCS, ZPLMGS, ZSNOW, %d classa.146 REAL FROOT (ILG,IG), FROOTS(ILG,IG), HTC (ILG,IG) %d classa.214 2 RRESID(ILG), SRESID(ILG), + FRTOT (ILG), FRTOTS(ILG), %d classa.286,288 4 CMASCS,CWLCAP,CWFCAP,CWLCPS,CWFCPS,RBCOEF, 5 ZPLIMC,ZPLIMG,ZPLMCS,ZPLMGS,HTCC,HTCS,HTC, + FROOT,FROOTS, 6 WTRC,WTRS,WTRG,CMAI,PAI,PAIS,AIL,FCAN,FCANS,PSIGND, %d classa.297 F RRESID,SRESID,FRTOT,FRTOTS, %d classa.327 4 AIL,PSIGND,FCLOUD,COSZS,QSWINV,VPD,TA, %deck NEWSUBS SUBROUTINE CLASST (TBARC, TBARG, TBARCS, TBARGS, THLIQC, THLIQG, 1 THICEC, THICEG, HCPC, HCPG, TCTOPC, TCBOTC, TCTOPG, TCBOTG, 2 GZEROC, GZEROG, GZROCS, GZROGS, G12C, G12G, G12CS, G12GS, 3 G23C, G23G, G23CS, G23GS, QFREZC, QFREZG, QMELTC, QMELTG, 4 EVAPC, EVAPCG, EVAPG, EVAPCS, EVPCSG, EVAPGS, TCANO, TCANS, 5 RAICAN, SNOCAN, RAICNS, SNOCNS, CHCAP, CHCAPS, TPONDC, TPONDG, 6 TPNDCS, TPNDGS, TSNOCS, TSNOGS, WSNOCS, WSNOGS, RHOSCS, RHOSGS, 7 ITERCT, CDH, CDM, QSENS, TFLUX, QEVAP, EVAP, 8 EVPPOT, ACOND, EVAPB, GT, QG, 9 ST, SU, SV, SQ, SRH, A GTBS, SFCUBS, SFCVBS, USTARBS, B FSGV, FSGS, FSGG, FLGV, FLGS, FLGG, C HFSC, HFSS, HFSG, HEVC, HEVS, HEVG, HMFC, HMFN, D HTCC, HTCS, HTC, QFCF, QFCL, DRAG, WTABLE, ILMO, E UE, HBL, TAC, QAC, ZREFM, ZREFH, ZDIAGM, ZDIAGH, F VPD, TADP, RHOAIR, QSWINV, QSWINI, QLWIN, UWIND, VWIND, G TA, QA, PADRY, FC, FG, FCS, FGS, RBCOEF, H FSVF, FSVFS, PRESSG, VMOD, ALVSCN, ALIRCN, ALVSG, ALIRG, I ALVSCS, ALIRCS, ALVSSN, ALIRSN, ALVSGC, ALIRGC, ALVSSC, ALIRSC, J TRVSCN, TRIRCN, TRVSCS, TRIRCS, RC, RCS, WTRG, QLWAVG, K FRAINC, FSNOWC, FRAICS, FSNOCS, CMASSC, CMASCS, DISP, DISPS, L ZOMLNC, ZOELNC, ZOMLNG, ZOELNG, ZOMLCS, ZOELCS, ZOMLNS, ZOELNS, M TBAR, THLIQ, THICE, TPOND, ZPOND, TBASE, TCAN, TSNOW, N ZSNOW, RHOSNO, WSNOW, THPOR, THLRET, THLMIN, THFC, THLW, O TRSNOWC, TRSNOWG, ALSNO, FSSB, FROOT, FROOTS, P RADJ, PCPR, HCPS, TCS, TSFSAV, DELZ, DELZW, ZBOTW, Q FTEMP, FVAP, RIB, R ISAND, S AILCG, AILCGS, FCANC, FCANCS, T CO2CONC, CO2I1CG, CO2I1CS, CO2I2CG, U CO2I2CS, COSZS, XDIFFUS, SLAI, V ICTEM, ICTEMMOD, RMATCTEM, FCANCMX, W L2MAX, NOL2PFTS, CFLUXCG, CFLUXCS, X ANCSVEG, ANCGVEG, RMLCSVEG, RMLCGVEG, Y TCSNOW, GSNOW, Z ITC, ITCG, ITG, ILG, IL1,IL2,JL,N, IC, + IG, IZREF, ISLFD, NLANDCS,NLANDGS,NLANDC, NLANDG, NLANDI, + NBS, ISNOALB) C C * AUG 04/15 - M.LAZARE. SPLIT FROOT INTO TWO ARRAYS, FOR CANOPY C * AREAS WITH AND WITHOUT SNOW. C * JUL 22/15 - D.VERSEGHY. CHANGES TO TSOLVC AND TSOLVE CALLS. C * FEB 09/15 - D.VERSEGHY. New version for gcm18 and class 3.6: C * - Revised calls to revised TPREP for C * initialization of SRH and SLDIAG. C * - Input {THFC,THLW} (from CLASSB) replace C * work arrays {FIELDSM,WILTSM}. C * - Calculation of new bare-soil fields C * {GTBS,SFCUBS,SFCVBS,USTARBS}. C * SEP 09/14 - D.VERSEGHY/M.LAZARE. CORRECTIONS TO SCREEN LEVEL C * DIAGNOSTIC CALCULATIONS. C * AUG 19/13 - M.LAZARE. REMOVE CALCULATION AND REFERENCES TO C * "QFLUX" (NOW DONE IN CLASSW). C * JUN 21/13 - M.LAZARE. REVISED CALL TO TPREP TO SUPPORT ADDING C * INITIALIZATION OF "GSNOW". C * JUN 10/13 - M.LAZARE/ ADD SUPPORT FOR "ISNOALB" FORMULATION. C * M.NAMAZI. C * NOV 11/11 - M.LAZARE. IMPLEMENT CTEM (INITIALIZATION OF FIELDS C * NEAR BEGINNING AND TWO REVISED CALLS TO C * TSOLVC). C * OCT 12/11 - M.LAZARE. REMOVED "TSURF" (REQUIRED CHANGE C * TO TPREP INITIALIZATION AS WELL). C * OCT 07/11 - M.LAZARE. - CHANGE QLWAVG FROM AN INTERNAL WORK C * ARRAY TO ONE PASSED OUT TO THE CLASS C * DRIVER, TO ACCOMODATE RPN. C * - WIND SPEED NOW PASSED IN (POSSIBLY C * CONTAINING GUSTINESS FACTOR) AS "VMOD", C * INSTEAD OF CALCULATING IT LOCALLY. C * OCT 05/11 - M.LAZARE. ADD CALCULATION OF SRH (REQUIRES PASSING C * IN OF PRESSG PLUS ADDITIONAL INTERNAL C * WORK ARRAYS). C * APR 28/10 - D.VERSEGHY. REVISE CALCULATION OF QG. C * APR 28/10 - M.MACDONALD/D.VERSEGHY. CORRECT CALCULATIONS OF C * CRIB, DRAG AND VAC FOR ISLFD=1. C * APR 28/10 - E.CHAN/D/VERSEGHY. CORRECT CALCULATIONS OF ST AND C * SQ FOR ISLFD=0. C * DEC 21/09 - D.VERSEGHY. CORRECT BUG IN CALL TO TSOLVC IN CS C * SUBAREA (CALL WITH FSNOCS AND RAICNS). C * DEC 07/09 - D.VERSEGHY. ADD EVAP TO TSOLVC CALL. C * JAN 06/09 - D.VERSEGHY. INSERT UPDATES TO HTC AND WTRG C * BRACKETTING LOOP 60; CORRECT TPOTA, C * ZRSLDM AND ZRSLDH CALCULATIONS; USE C * TPOTA IN SLDIAG CALL; ASSUME THAT TA IS C * ADIABATIC EXTRAPOLATE TO SURFACE FOR C * ATMOSPHERIC MODELS. C * NOV 03/08 - L.DUARTE CORRECTED CALL TO TSOLVC. C * AUG 08 - JP PAQUIN OUTPUT FTEMP, FVAP AND RIB FOR GEM C (IMPLEMENTED BY L.DUARTE ON OCT 28/08) C * FEB 25/08 - D.VERSEGHY. MODIFICATIONS REFLECTING CHANGES C * ELSEWHERE IN CODE. C * NOV 24/06 - D.VERSEGHY. REMOVE CALL TO TZTHRM; MAKE RADJ REAL. C * AUG 16/06 - D.VERSEGHY. NEW CALLS TO TSPREP AND TSPOST. C * APR 13/06 - D.VERSEGHY. SEPARATE GROUND AND SNOW ALBEDOS FOR C * OPEN AND CANOPY-COVERED AREAS. C * MAR 23/06 - D.VERSEGHY. CHANGES TO ADD MODELLING OF WSNOW. C * MAR 21/06 - P.BARTLETT. PASS ADDITIONAL VARIABLES TO TPREP. C * OCT 04/05 - D.VERSEGHY. MODIFICATIONS TO ALLOW OPTION OF SUB- C * DIVIDING THIRD SOIL LAYER. C * APR 12/05 - D.VERSEGHY. VARIOUS NEW FIELDS; ADD CALL TO NEW C * SUBROUTINE TZTHRM; MOVE CALCULATION C * OF CPHCHC INTO TSOLVC. C * NOV 03/04 - D.VERSEGHY. ADD "IMPLICIT NONE" COMMAND. C * AUG 05/04 - Y.DELAGE/D.VERSEGHY. NEW DIAGNOSTIC VARIABLES C * ILMO, UE AND HBL. C * NOV 07/02 - Y.DELAGE/D.VERSEGHY. CALLS TO NEW DIAGNOSTIC C * SUBROUTINES "SLDIAG" AND "DIASURF"; C * MODIFICATIONS TO ACCOMMODATE DIFFERENT C * SURFACE REFERENCE HEIGHT CONVENTIONS. C * JUL 31/02 - D.VERSEGHY. MOVE CALCULATION OF VEGETATION STOMATAL C * RESISTANCE FROM TPREP INTO APREP AND C * CANALB; SHORTENED CLASS3 COMMON BLOCK. C * JUL 23/02 - D.VERSEGHY. MOVE ADDITION OF AIR TO CANOPY MASS C * INTO CLASSA; SHORTENED CLASS4 C * COMMON BLOCK. C * MAR 28/02 - D.VERSEGHY. STREAMLINED SUBROUTINE CALLS. C * MAR 22/02 - D.VERSEGHY. MOVE CALCULATION OF BACKGROUND SOIL C * PROPERTIES INTO "CLASSB"; ADD NEW C * DIAGNOSTIC VARIABLES "EVPPOT", "ACOND" C * AND "TSURF"; MODIFY CALCULATIONS OF VAC, C * EVAPB AND QG. C * JAN 18/02 - D.VERSEGHY. CHANGES TO INCORPORATE NEW BARE SOIL C * EVAPORATION FORMULATION. C * APR 11/01 - M.LAZARE. SHORTENED "CLASS2" COMMON BLOCK. C * SEP 19/00 - D.VERSEGHY. PASS VEGETATION-VARYING COEFFICIENTS C * TO TPREP FOR CALCULATION OF STOMATAL C * RESISTANCE. C * DEC 16/99 - A.WU/D.VERSEGHY. CHANGES MADE TO INCORPORATE NEW SOIL C * EVAPORATION ALGORITHMS AND NEW CANOPY C * TURBULENT FLUX FORMULATION. MODIFY C * CALCULATION OF BULK RICHARDSON NUMBER C * AND CANOPY MASS. C * APR 15/99 - M.LAZARE. CORRECT SCREEN-LEVEL CALCULATION FOR WINDS C * TO HOLD AT ANEMOMETER LEVEL (10M) INSTEAD C * OF SCREEN LEVEL (2M). C * JUN 20/97 - D.VERSEGHY. CLASS - VERSION 2.7. C * CHANGES RELATED TO VARIABLE SOIL DEPTH C * (MOISTURE HOLDING CAPACITY) AND DEPTH- C * VARYING SOIL PROPERTIES. C * ALSO, APPLY UPPER BOUND ON "RATFC1"). C * OCT 11/96 - D.VERSEGHY. CLASS - VERSION 2.6. C * REVISE CALCULATION OF SLTHKEF AND C * DEFINITION OF ZREF FOR INTERNAL C * CONSISTENCY. C * SEP 27/96 - D.VERSEGHY. FIX BUG IN CALCULATION OF FLUXES C * BETWEEN SOIL LAYERS (PRESENT SINCE C * RELEASE OF CLASS VERSION 2.5). C * MAY 21/96 - K.ABDELLA. CORRECT EXPRESSION FOR ZOSCLH (4 PLACES). C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5. C * COMPLETION OF ENERGY BALANCE C * DIAGNOSTICS; ALSO, PASS IN ZREF AND C * ILW THROUGH SUBROUTINE CALL. C * AUG 18/95 - D.VERSEGHY. CLASS - VERSION 2.4. C * REVISIONS TO ALLOW FOR INHOMOGENEITY C * BETWEEN SOIL LAYERS AND FRACTIONAL C * ORGANIC MATTER CONTENT. C * DEC 16/94 - D.VERSEGHY. CLASS - VERSION 2.3. C * ADD THREE NEW DIAGNOSTIC FIELDS; C * REVISE CALCULATION OF HTCS, HTC. C * DEC 06/94 - M.LAZARE. - PASS "CFLUX" TO TSOLVE INSTEAD OF C * "CLIMIT" IN CONJUNCTION WITH CHANGES C * TO THAT ROUTINE. C * - REVISE CALCULATION OF "ZREF" TO INCLUDE C * VIRTUAL TEMPERATURE EFFECTS. C * - REVISE CALCULATION OF "SLTHKEF". C * NOV 28/94 - M.LAZARE. FORM DRAG "CDOM" MODIFICATION REMOVED. C * NOV 18/93 - D.VERSEGHY. CLASS - VERSION 2.2. C * LOCAL VERSION WITH INTERNAL WORK ARRAYS C * HARD-CODED FOR USE ON PCS. C * NOV 05/93 - M.LAZARE. ADD NEW DIAGNOSTIC OUTPUT FIELD: DRAG. C * JUL 27/93 - D.VERSEGHY/M.LAZARE. PREVIOUS VERSION CLASSTO. C IMPLICIT NONE C C * INTEGER CONSTANTS. C INTEGER NLANDCS,NLANDGS,NLANDC,NLANDG,NLANDI,ISNOW,N,NBS,ISNOALB C INTEGER ITC,ITCG,ITG,ILG,IL1,IL2,JL,IC,IG,IZREF,ISLFD,I,J C C * OUTPUT FIELDS. C REAL TBARC (ILG,IG),TBARG (ILG,IG),TBARCS(ILG,IG),TBARGS(ILG,IG), 1 THLIQC(ILG,IG),THLIQG(ILG,IG),THICEC(ILG,IG),THICEG(ILG,IG), 2 HCPC (ILG,IG),HCPG (ILG,IG),TCTOPC(ILG,IG),TCBOTC(ILG,IG), 3 TCTOPG(ILG,IG),TCBOTG(ILG,IG),HTC (ILG,IG),TSFSAV(ILG,4) C REAL GZEROC(ILG), GZEROG(ILG), GZROCS(ILG), GZROGS(ILG), 1 G12C (ILG), G12G (ILG), G12CS (ILG), G12GS (ILG), 2 G23C (ILG), G23G (ILG), G23CS (ILG), G23GS (ILG), 3 QFREZC(ILG), QFREZG(ILG), QMELTC(ILG), QMELTG(ILG), 4 EVAPC (ILG), EVAPCG(ILG), EVAPG (ILG), EVAPCS(ILG), 5 EVPCSG(ILG), EVAPGS(ILG), TCANO (ILG), TCANS (ILG), 6 RAICAN(ILG), SNOCAN(ILG), RAICNS(ILG), SNOCNS(ILG), 7 CHCAP (ILG), CHCAPS(ILG), TPONDC(ILG), TPONDG(ILG), 8 TPNDCS(ILG), TPNDGS(ILG), TSNOCS(ILG), TSNOGS(ILG), 9 WSNOCS(ILG), WSNOGS(ILG), RHOSCS(ILG), RHOSGS(ILG) C REAL CDH (ILG), CDM (ILG), QSENS (ILG), TFLUX (ILG), 1 QEVAP (ILG), EVAP (ILG), 2 EVPPOT(ILG), ACOND (ILG), EVAPB (ILG), WTRG (ILG), 3 QLWAVG(ILG), GT (ILG), QG (ILG), 4 WTABLE(ILG), ST (ILG), SU (ILG), SV (ILG), 5 SQ (ILG), SRH (ILG), 5 GTBS (ILG), SFCUBS(ILG), SFCVBS(ILG), USTARBS(ILG), 6 FSGV (ILG), FSGS (ILG), FSGG (ILG), FLGV (ILG), 7 FLGS (ILG), FLGG (ILG), HFSC (ILG), HFSS (ILG), 8 HFSG (ILG), HEVC (ILG), HEVS (ILG), HEVG (ILG), 9 HMFC (ILG), HMFN (ILG), HTCC (ILG), HTCS (ILG), A DRAG (ILG), ILMO (ILG), UE (ILG), HBL (ILG), B TAC (ILG), QAC (ILG), QFCF (ILG), QFCL (ILG), C FTEMP (ILG), FVAP (ILG), RIB (ILG) C INTEGER ITERCT(ILG,6,50) C C * INPUT FIELDS. C REAL ZREFM (ILG), ZREFH (ILG), ZDIAGM(ILG), ZDIAGH(ILG), 1 VPD (ILG), TADP (ILG), RHOAIR(ILG), QSWINV(ILG), 2 QSWINI(ILG), QLWIN (ILG), UWIND (ILG), VWIND (ILG), 3 TA (ILG), QA (ILG), PADRY (ILG), FC (ILG), 4 FG (ILG), FCS (ILG), FGS (ILG), RBCOEF(ILG), 5 FSVF (ILG), FSVFS (ILG), PRESSG(ILG), VMOD (ILG), 6 ALVSCN(ILG), ALIRCN(ILG), ALVSG (ILG), ALIRG (ILG), 7 ALVSCS(ILG), ALIRCS(ILG), ALVSSN(ILG), ALIRSN(ILG), 8 ALVSGC(ILG), ALIRGC(ILG), ALVSSC(ILG), ALIRSC(ILG), 9 TRVSCN(ILG), TRIRCN(ILG), TRVSCS(ILG), TRIRCS(ILG), A RC (ILG), RCS (ILG), FRAINC(ILG), FSNOWC(ILG), B FRAICS(ILG), FSNOCS(ILG), CMASSC(ILG), CMASCS(ILG), C DISP (ILG), DISPS (ILG), D ZOMLNC(ILG), ZOELNC(ILG), ZOMLNG(ILG), ZOELNG(ILG), E ZOMLCS(ILG), ZOELCS(ILG), ZOMLNS(ILG), ZOELNS(ILG), F TPOND (ILG), ZPOND (ILG), TBASE (ILG), TCAN (ILG), G TSNOW (ILG), ZSNOW (ILG), TRSNOWC(ILG), RHOSNO(ILG), H WSNOW (ILG), RADJ (ILG), PCPR (ILG) C REAL TRSNOWG(ILG,NBS), ALSNO(ILG,NBS), FSSB(ILG,NBS) C REAL TBAR (ILG,IG),THLIQ (ILG,IG),THICE (ILG,IG) C C * SOIL PROPERTY ARRAYS. C REAL THPOR (ILG,IG),THLRET(ILG,IG),THLMIN(ILG,IG), 1 THFC (ILG,IG),THLW (ILG,IG),HCPS (ILG,IG),TCS (ILG,IG), 2 DELZ (IG), DELZW (ILG,IG),ZBOTW (ILG,IG), 3 FROOT (ILG,IG),FROOTS(ILG,IG) C INTEGER ISAND (ILG,IG) C C * CTEM-RELATED I/O FIELDS. C REAL AILCG(ILG,ICTEM), AILCGS(ILG,ICTEM), FCANC(ILG,ICTEM), 1 FCANCS(ILG,ICTEM), CO2CONC(ILG), CO2I1CG(ILG,ICTEM), 2 CO2I1CS(ILG,ICTEM), CO2I2CG(ILG,ICTEM), CO2I2CS(ILG,ICTEM), 3 COSZS(ILG), XDIFFUS(ILG), SLAI(ILG,ICTEM), 4 RMATCTEM(ILG,ICTEM,IG), FCANCMX(ILG,ICTEM), 5 ANCSVEG(ILG,ICTEM), ANCGVEG(ILG,ICTEM), RMLCSVEG(ILG,ICTEM), 6 RMLCGVEG(ILG,ICTEM), CFLUXCG(ILG), CFLUXCS(ILG) C INTEGER ICTEM, ICTEMMOD, L2MAX, NOL2PFTS(IC) C C * INTERNAL WORK ARRAYS FOR THIS ROUTINE. C REAL VA (ILG), ZRSLDM(ILG), ZRSLDH(ILG), ZRSLFM(ILG), 1 ZRSLFH(ILG), ZDSLM (ILG), ZDSLH (ILG), TPOTA (ILG), 2 TVIRTA(ILG), CRIB (ILG), CPHCHC(ILG), CPHCHG(ILG), 3 HCPSCS(ILG), HCPSGS(ILG), TCSNOW(ILG), CEVAP (ILG), 4 TBAR1P(ILG), GSNOWC(ILG), GSNOWG(ILG), GSNOW(ILG) , 5 GDENOM(ILG), GCOEFF(ILG), GCONST(ILG), 6 TSNBOT(ILG), GCOEFFS(ILG), GCONSTS(ILG), 7 A1 (ILG), A2 (ILG), B1 (ILG), B2 (ILG), 8 C2 (ILG), ZOM (ILG), ZOH (ILG), ZOSCLM(ILG), 9 ZOSCLH(ILG), VAC (ILG), FCOR (ILG), A CFLUX (ILG), CDHX (ILG), CDMX (ILG), B QSWX (ILG), QSWNC (ILG), QSWNG (ILG), QLWX (ILG), C QLWOC (ILG), QLWOG (ILG), QTRANS(ILG), D QSENSX(ILG), QSENSC(ILG), QSENSG(ILG), QEVAPX(ILG), E QEVAPC(ILG), QEVAPG(ILG), QPHCHC(ILG), QCANX (ILG), F TSURX (ILG), QSURX (ILG), G TACCS (ILG), QACCS (ILG), TACCO (ILG), QACCO (ILG), H ILMOX (ILG), UEX (ILG), HBLX (ILG), ZERO (ILG), I STT (ILG), SQT (ILG), SUT (ILG), SVT (ILG), J SHT (ILG) C INTEGER IEVAP (ILG), IWATER(ILG) C C * INTERNAL WORK ARRAYS FOR TPREP. C REAL FVEG (ILG), TCSATU(ILG), TCSATF(ILG) C C * INTERNAL WORK ARRAYS FOR TSOLVC/TSOLVE. C REAL TSTEP (ILG), TVIRTC(ILG), TVIRTG(ILG), TVIRTS(ILG), 1 EVBETA(ILG), XEVAP (ILG), EVPWET(ILG), Q0SAT (ILG), 2 RA (ILG), RB (ILG), RAGINV(ILG), RBINV (ILG), 3 RBTINV(ILG), RBCINV(ILG), 4 TVRTAC(ILG), TPOTG (ILG), RESID (ILG), 5 TCANP (ILG), TRTOP (ILG), TRTOPG(ILG,NBS), QSTOR (ILG), 6 AC (ILG), BC (ILG), 7 LZZ0 (ILG), LZZ0T (ILG), FM (ILG), FH (ILG), 8 DCFLXM(ILG), CFLUXM(ILG), WZERO (ILG), XEVAPM(ILG), 9 WC (ILG), DRAGIN(ILG), CFSENS(ILG), CFEVAP(ILG), A QSGADD(ILG), CFLX (ILG), B FTEMPX(ILG), FVAPX (ILG), RIBX (ILG) C INTEGER ITER (ILG), NITER (ILG), JEVAP (ILG), 1 KF (ILG), KF1 (ILG), KF2 (ILG), 2 IEVAPC(ILG) C C * TEMPORARY VARIABLES. C REAL THTOT,CA,CB,WACSAT,QACSAT,RATIOM,RATIOH,FACTM,FACTH C C * COMMON BLOCK PARAMETERS. C REAL DELT,TFREZ,RGAS,RGASV,GRAV,SBC,VKC,CT,VMIN,TCW,TCICE, 1 TCSAND,TCCLAY,TCOM,TCDRYS,RHOSOL,RHOOM,HCPW,HCPICE,HCPSOL, 2 HCPOM,HCPSND,HCPCLY,SPHW,SPHICE,SPHVEG,SPHAIR,RHOW,RHOICE, 3 TCGLAC,CLHMLT,CLHVAP,DELTA,CGRAV,CKARM,CPD,AS,ASX,CI,BS, 4 BETA,FACTN,HMIN,ANGMAX C COMMON /CLASS1/ DELT,TFREZ COMMON /CLASS2/ RGAS,RGASV,GRAV,SBC,VKC,CT,VMIN COMMON /CLASS3/ TCW,TCICE,TCSAND,TCCLAY,TCOM,TCDRYS, 1 RHOSOL,RHOOM COMMON /CLASS4/ HCPW,HCPICE,HCPSOL,HCPOM,HCPSND,HCPCLY, 1 SPHW,SPHICE,SPHVEG,SPHAIR,RHOW,RHOICE, 2 TCGLAC,CLHMLT,CLHVAP COMMON /PHYCON/ DELTA,CGRAV,CKARM,CPD COMMON /CLASSD2/ AS,ASX,CI,BS,BETA,FACTN,HMIN,ANGMAX C C---------------------------------------------------------------------- C C * CALCULATION OF ATMOSPHERIC INPUT FIELDS REQUIRED BY CLASS FROM C * VARIABLES SUPPLIED BY GCM. C DO 50 I=IL1,IL2 VA(I)=MAX(VMIN,VMOD(I)) FCOR(I)=2.0*7.29E-5*SIN(RADJ(I)) C C * CHECK DEPTH OF PONDED WATER FOR UNPHYSICAL VALUES. C IF(ZPOND(I).LT.1.0E-8) ZPOND(I)=0.0 QG(I)=0.0 50 CONTINUE C C * CHECK LIQUID AND FROZEN SOIL MOISTURE CONTENTS FOR SMALL C * ABERRATIONS CAUSED BY PACKING/UNPACKING. C DO 60 J=1,IG DO 60 I=IL1,IL2 IF(ISAND(I,1).GT.-4) THEN HTC(I,J)=HTC(I,J)-TBAR(I,J)*(HCPW*THLIQ(I,J)+ 1 HCPICE*THICE(I,J))*DELZW(I,J)/DELT WTRG(I)=WTRG(I)-(RHOW*THLIQ(I,J)+RHOICE*THICE(I,J))* 1 DELZW(I,J)/DELT IF(THLIQ(I,J).LT.THLMIN(I,J)) 1 THLIQ(I,J)=THLMIN(I,J) IF(THICE(I,J).LT.0.0) THICE(I,J)=0.0 THTOT=THLIQ(I,J)+THICE(I,J)*RHOICE/RHOW IF(THTOT.GT.THPOR(I,J)) THEN THLIQ(I,J)=MAX(THLIQ(I,J)*THPOR(I,J)/ 1 THTOT,THLMIN(I,J)) THICE(I,J)=(THPOR(I,J)-THLIQ(I,J))* 1 RHOW/RHOICE IF(THICE(I,J).LT.0.0) THICE(I,J)=0.0 ENDIF HTC(I,J)=HTC(I,J)+TBAR(I,J)*(HCPW*THLIQ(I,J)+ 1 HCPICE*THICE(I,J))*DELZW(I,J)/DELT WTRG(I)=WTRG(I)+(RHOW*THLIQ(I,J)+RHOICE*THICE(I,J))* 1 DELZW(I,J)/DELT ENDIF 60 CONTINUE C IF (ICTEMMOD.EQ.1) THEN C C * INITIALIZE VARIABLES ESTIMATED BY THE PHOTOSYNTHESIS SUBROUTINE C * CALLED FROM WITHIN TSOLVC. C DO 65 J=1,ICTEM DO 65 I=IL1,IL2 ANCSVEG(I,J)=0.0 ANCGVEG(I,J)=0.0 RMLCSVEG(I,J)=0.0 RMLCGVEG(I,J)=0.0 65 CONTINUE ENDIF C C * PREPARATION. C CALL TPREP (THLIQC, THLIQG, THICEC, THICEG, TBARC, TBARG, 1 TBARCS, TBARGS, HCPC, HCPG, TCTOPC, TCBOTC, 2 TCTOPG, TCBOTG, HCPSCS, HCPSGS, TCSNOW, TSNOCS, 3 TSNOGS, WSNOCS, WSNOGS, RHOSCS, RHOSGS, TCANO, 4 TCANS, CEVAP, IEVAP, TBAR1P, WTABLE, ZERO, 5 EVAPC, EVAPCG, EVAPG, EVAPCS, EVPCSG, EVAPGS, 6 GSNOWC, GSNOWG, GZEROC, GZEROG, GZROCS, GZROGS, 7 QMELTC, QMELTG, EVAP, GSNOW, 8 TPONDC, TPONDG, TPNDCS, TPNDGS, QSENSC, QSENSG, 9 QEVAPC, QEVAPG, TACCO, QACCO, TACCS, QACCS, A ILMOX, UEX, HBLX, B ILMO, UE, HBL, C ST, SU, SV, SQ, SRH, D CDH, CDM, QSENS, QEVAP, QLWAVG, E FSGV, FSGS, FSGG, FLGV, FLGS, FLGG, F HFSC, HFSS, HFSG, HEVC, HEVS, HEVG, G HMFC, HMFN, QFCF, QFCL, EVPPOT, ACOND, H DRAG, THLIQ, THICE, TBAR, ZPOND, TPOND, I THPOR, THLMIN, THLRET, THFC, HCPS, TCS, J TA, RHOSNO, TSNOW, ZSNOW, WSNOW, TCAN, K FC, FCS, DELZ, DELZW, ZBOTW, L ISAND, ILG, IL1, IL2, JL, IG, M FVEG, TCSATU, TCSATF, FTEMP, FTEMPX, FVAP, N FVAPX, RIB, RIBX ) C C * DEFINE NUMBER OF PIXELS OF EACH LAND SURFACE SUBAREA C * (CANOPY-COVERED, CANOPY-AND-SNOW-COVERED, BARE SOIL, AND C * SNOW OVER BARE SOIL) AND NUMBER OF LAND ICE PIXELS FOR C * CALCULATIONS IN CLASST/CLASSW. NLANDC =0 NLANDCS=0 NLANDG =0 NLANDGS=0 NLANDI =0 DO 70 I=IL1,IL2 IF(FC (I).GT.0.) NLANDC =NLANDC +1 IF(FCS(I).GT.0.) NLANDCS=NLANDCS+1 IF(FG (I).GT.0.) NLANDG =NLANDG +1 IF(FGS(I).GT.0.) NLANDGS=NLANDGS+1 IF(ISAND(I,1).EQ.-4) NLANDI =NLANDI +1 70 CONTINUE C C * CALCULATIONS FOR CANOPY OVER SNOW. C IF(NLANDCS.GT.0) THEN DO 100 I=IL1,IL2 IF(FCS(I).GT.0.) THEN ZOM(I)=EXP(ZOMLCS(I)) ZOH(I)=EXP(ZOELCS(I)) IF(IZREF.EQ.1) THEN ZRSLDM(I)=ZREFM(I)-DISPS(I) ZRSLDH(I)=ZREFH(I)-DISPS(I) ZRSLFM(I)=ZREFM(I)-ZOM(I)-DISPS(I) ZRSLFH(I)=ZREFH(I)-ZOM(I)-DISPS(I) ZDSLM(I)=ZDIAGM(I)-ZOM(I) ZDSLH(I)=ZDIAGH(I)-ZOM(I) TPOTA(I)=TA(I)+ZRSLFH(I)*GRAV/CPD ELSE ZRSLDM(I)=ZREFM(I)+ZOM(I) ZRSLDH(I)=ZREFH(I)+ZOM(I) ZRSLFM(I)=ZREFM(I)-DISPS(I) ZRSLFH(I)=ZREFH(I)-DISPS(I) ZDSLM(I)=ZDIAGM(I) ZDSLH(I)=ZDIAGH(I) TPOTA(I)=TA(I) ENDIF ZOSCLM(I)=ZOM(I)/ZRSLDM(I) ZOSCLH(I)=ZOH(I)/ZRSLDH(I) TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I)) CRIB(I)=-GRAV*ZRSLDM(I)/(TVIRTA(I)* 1 VA(I)**2) DRAG(I)=DRAG(I)+FCS(I)*(VKC/(LOG(ZRSLDM(I))- 1 ZOMLCS(I)))**2 VAC(I)=VA(I)*(LOG(10.0*ZOM(I)-DISPS(I))-ZOMLCS(I))/ 1 (LOG(ZRSLDM(I))-ZOMLCS(I)) TACCS(I)=TAC(I) QACCS(I)=QAC(I) ENDIF 100 CONTINUE C CALL CWCALC(TCANS,RAICNS,SNOCNS,FRAICS,FSNOCS,CHCAPS, 1 HMFC,HTCC,FCS,CMASCS,ILG,IL1,IL2,JL) CALL TNPREP(A1,A2,B1,B2,C2,GDENOM,GCOEFF, 1 GCONST,CPHCHG,IWATER, 2 TBAR,TCTOPC,TCBOTC, + FCS,ZPOND,TBAR1P,DELZ,TCSNOW,ZSNOW, 3 ISAND,ILG,IL1,IL2,JL,IG ) CALL TSPREP(GCOEFFS,GCONSTS,CPHCHG,IWATER, 1 FCS,ZSNOW,TSNOW,TCSNOW, 2 ILG,IL1,IL2,JL ) ISNOW=1 CALL TSOLVC(ISNOW,FCS, 1 QSWX,QSWNC,QSWNG,QLWX,QLWOC,QLWOG,QTRANS, 2 QSENSX,QSENSC,QSENSG,QEVAPX,QEVAPC,QEVAPG,EVAPCS, 3 EVPCSG,EVAP,TCANS,QCANX,TSURX,QSURX,GSNOWC,QPHCHC, 4 QMELTC,RAICNS,SNOCNS,CDHX,CDMX,RIBX,TACCS,QACCS, 5 CFLUX,FTEMPX,FVAPX,ILMOX,UEX,HBLX,QFCF,QFCL,HTCC, 6 QSWINV,QSWINI,QLWIN,TPOTA,TA,QA,VA,VAC,PADRY, 7 RHOAIR,ALVSCS,ALIRCS,ALVSSC,ALIRSC,TRVSCS,TRIRCS, 8 FSVFS,CRIB,CPHCHC,CPHCHG,CEVAP,TADP,TVIRTA,RCS, 9 RBCOEF,ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM, A FCOR,GCONSTS,GCOEFFS,TSFSAV(1,1),TRSNOWC,FSNOCS, B FRAICS,CHCAPS,CMASCS,PCPR,FROOTS,THLMIN,DELZW, + RHOSCS,ZSNOW,IWATER,IEVAP,ITERCT, C ISLFD,ITC,ITCG,ILG,IL1,IL2,JL,N, D TSTEP,TVIRTC,TVIRTG,EVBETA,XEVAP,EVPWET,Q0SAT, E RA,RB,RAGINV,RBINV,RBTINV,RBCINV,TVRTAC,TPOTG, F RESID,TCANP, G WZERO,XEVAPM,DCFLXM,WC,DRAGIN,CFLUXM,CFLX,IEVAPC, H TRTOP,QSTOR,CFSENS,CFEVAP,QSGADD,AC,BC, I LZZ0,LZZ0T,FM,FH,ITER,NITER,KF1,KF2, J AILCGS,FCANCS,CO2CONC,RMATCTEM, K THLIQC,THFC,THLW,ISAND,IG,COSZS,PRESSG, L XDIFFUS,ICTEM,IC,CO2I1CS,CO2I2CS, M ICTEMMOD,SLAI,FCANCMX,L2MAX, N NOL2PFTS,CFLUXCS,ANCSVEG,RMLCSVEG) CALL TSPOST(GSNOWC,TSNOCS,WSNOCS,RHOSCS,QMELTC, 1 GZROCS,TSNBOT,HTCS,HMFN, 2 GCONSTS,GCOEFFS,GCONST,GCOEFF,TBAR, 3 TSURX,ZSNOW,TCSNOW,HCPSCS,QTRANS, 4 FCS,DELZ,ILG,IL1,IL2,JL,IG ) CALL TNPOST(TBARCS,G12CS,G23CS,TPNDCS,GZROCS,ZERO,GCONST, 1 GCOEFF,TBAR,TCTOPC,TCBOTC,HCPC,ZPOND,TSNBOT, 2 TBASE,TBAR1P,A1,A2,B1,B2,C2,FCS,IWATER, 3 ISAND,DELZ,DELZW,ILG,IL1,IL2,JL,IG ) C C * DIAGNOSTICS. C IF(ISLFD.EQ.0) THEN DO 150 I=IL1,IL2 IF(FCS(I).GT.0.) THEN FACTM=ZDSLM(I)+ZOM(I) FACTH=ZDSLH(I)+ZOM(I) RATIOM=SQRT(CDMX(I))*LOG(FACTM/ZOM(I))/VKC RATIOM=MIN(RATIOM,1.) RATIOH=SQRT(CDMX(I))*LOG(FACTH/ZOH(I))/VKC RATIOH=MIN(RATIOH,1.) IF(RIBX(I).LT.0.) THEN RATIOH=RATIOH*CDHX(I)/CDMX(I) RATIOH=MIN(RATIOH,(FACTH/ZRSLDH(I))**(1./3.)) ENDIF STT(I)=TACCS(I)-(MIN(RATIOH,1.))*(TACCS(I)-TA(I)) SQT(I)=QACCS(I)-(MIN(RATIOH,1.))*(QACCS(I)-QA(I)) SUT(I)=RATIOM*UWIND(I) SVT(I)=RATIOM*VWIND(I) ENDIF 150 CONTINUE C CALL SCREENRH(SHT,STT,SQT,PRESSG,FCS,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FCS(I).GT.0.) THEN ST (I)=ST (I)+FCS(I)*STT(I) SQ (I)=SQ (I)+FCS(I)*SQT(I) SU (I)=SU (I)+FCS(I)*SUT(I) SV (I)=SV (I)+FCS(I)*SVT(I) SRH(I)=SRH(I)+FCS(I)*SHT(I) ENDIF ENDDO C ELSEIF(ISLFD.EQ.1) THEN CALL SLDIAG(SUT,SVT,STT,SQT, 1 CDMX,CDHX,UWIND,VWIND,TPOTA,QA, 2 TACCS,QACCS,ZOM,ZOH,FCS,ZRSLDM, 3 ZDSLM,ZDSLH,ILG,IL1,IL2,JL) C CALL SCREENRH(SHT,STT,SQT,PRESSG,FCS,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FCS(I).GT.0.) THEN ST (I)=ST (I)+FCS(I)*STT(I) SQ (I)=SQ (I)+FCS(I)*SQT(I) SU (I)=SU (I)+FCS(I)*SUT(I) SV (I)=SV (I)+FCS(I)*SVT(I) SRH(I)=SRH(I)+FCS(I)*SHT(I) ENDIF ENDDO ELSEIF(ISLFD.EQ.2) THEN CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TACCS,QACCS, 1 ZOM,ZOH,ILMOX,ZRSLFM,HBLX,UEX,FTEMPX,FVAPX, 2 ZDSLM,ZDSLH,RADJ,FCS,IL1,IL2,JL) ENDIF C DO 175 I=IL1,IL2 IF(FCS(I).GT.0.) THEN IF(TACCS(I).GE.TFREZ) THEN CA=17.269 CB=35.86 ELSE CA=21.874 CB=7.66 ENDIF WACSAT=0.622*611.0*EXP(CA*(TACCS(I)-TFREZ)/ 1 (TACCS(I)-CB))/PADRY(I) QACSAT=WACSAT/(1.0+WACSAT) EVPPOT(I)=EVPPOT(I)+FCS(I)*RHOAIR(I)*CFLUX(I)* 1 (QACSAT-QA(I)) ACOND(I)=ACOND(I)+FCS(I)*CFLUX(I) ILMO(I) =ILMO(I)+FCS(I)*ILMOX(I) UE(I) =UE(I)+FCS(I)*UEX(I) HBL(I) =HBL(I)+FCS(I)*HBLX(I) CDH (I) =CDH(I)+FCS(I)*CDHX(I) CDM (I) =CDM(I)+FCS(I)*CDMX(I) TSFSAV(I,1)=TSURX(I) QG(I)=QG(I)+FCS(I)*QACCS(I) QSENS(I)=QSENS(I)+FCS(I)*QSENSX(I) QEVAP(I)=QEVAP(I)+FCS(I)*QEVAPX(I) QLWAVG(I)=QLWAVG(I)+FCS(I)*QLWX(I) FSGV(I) =FSGV(I)+FCS(I)*QSWNC(I) FSGS(I) =FSGS(I)+FCS(I)*QSWNG(I) FSGG(I) =FSGG(I)+FCS(I)*QTRANS(I) FLGV(I) =FLGV(I)+FCS(I)*(QLWIN(I)+QLWOG(I)-2.0* 1 QLWOC(I))*(1.0-FSVFS(I)) FLGS(I) =FLGS(I)+FCS(I)*(QLWOC(I)*(1.0-FSVFS(I))+ 1 QLWIN(I)*FSVFS(I)-QLWOG(I)) IF(ITC.EQ.1) THEN HFSC(I) =HFSC(I)+FCS(I)*QSENSC(I) ELSE HFSC(I) =HFSC(I)+FCS(I)*(QSENSC(I)-QSENSG(I)) ENDIF HFSS(I) =HFSS(I)+FCS(I)*QSENSG(I) HEVC(I) =HEVC(I)+FCS(I)*QEVAPC(I) HEVS(I) =HEVS(I)+FCS(I)*QEVAPG(I) HMFC(I) =HMFC(I)+FCS(I)*QPHCHC(I) HTCS(I) =HTCS(I)+FCS(I)*(-GZROCS(I)+ 1 QTRANS(I)) HTC(I,1)=HTC(I,1)+FCS(I)*(GZROCS(I)-QTRANS(I)- 1 G12CS(I)) HTC(I,2)=HTC(I,2)+FCS(I)*(G12CS(I)-G23CS(I)) HTC(I,3)=HTC(I,3)+FCS(I)*G23CS(I) FTEMP(I)= FTEMP(I) + FCS(I) * FTEMPX(I) FVAP (I)= FVAP (I) + FCS(I) * FVAPX (I) RIB (I)= RIB (I) + FCS(I) * RIBX (I) GSNOW(I) =GSNOW(I)+FCS(I)/(FCS(I)+FGS(I))*GSNOWC(I) ENDIF 175 CONTINUE ENDIF C C * CALCULATIONS FOR SNOW-COVERED GROUND. C IF(NLANDGS.GT.0) THEN DO 200 I=IL1,IL2 IF(FGS(I).GT.0.) THEN ZOM(I)=EXP(ZOMLNS(I)) ZOH(I)=EXP(ZOELNS(I)) IF(IZREF.EQ.1) THEN ZRSLDM(I)=ZREFM(I) ZRSLDH(I)=ZREFH(I) ZRSLFM(I)=ZREFM(I)-ZOM(I) ZRSLFH(I)=ZREFH(I)-ZOM(I) ZDSLM(I)=ZDIAGM(I)-ZOM(I) ZDSLH(I)=ZDIAGH(I)-ZOM(I) TPOTA(I)=TA(I)+ZRSLFH(I)*GRAV/CPD ELSE ZRSLDM(I)=ZREFM(I)+ZOM(I) ZRSLDH(I)=ZREFH(I)+ZOM(I) ZRSLFM(I)=ZREFM(I) ZRSLFH(I)=ZREFH(I) ZDSLM(I)=ZDIAGM(I) ZDSLH(I)=ZDIAGH(I) TPOTA(I)=TA(I) ENDIF ZOSCLM(I)=ZOM(I)/ZRSLDM(I) ZOSCLH(I)=ZOH(I)/ZRSLDH(I) TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I)) CRIB(I)=-GRAV*ZRSLDM(I)/(TVIRTA(I)*VA(I)**2) DRAG(I)=DRAG(I)+FGS(I)*(VKC/(LOG(ZRSLDM(I))- 1 ZOMLNS(I)))**2 ENDIF 200 CONTINUE C CALL TNPREP(A1,A2,B1,B2,C2,GDENOM,GCOEFF, 1 GCONST,CPHCHG,IWATER, 2 TBAR,TCTOPG,TCBOTG, + FGS,ZPOND,TBAR1P,DELZ,TCSNOW,ZSNOW, 3 ISAND,ILG,IL1,IL2,JL,IG ) CALL TSPREP(GCOEFFS,GCONSTS,CPHCHG,IWATER, 1 FGS,ZSNOW,TSNOW,TCSNOW, 2 ILG,IL1,IL2,JL ) ISNOW=1 CALL TSOLVE(ISNOW,FGS, 1 QSWX,QLWX,QTRANS,QSENSX,QEVAPX,EVAPGS, 2 TSURX,QSURX,GSNOWG,QMELTG,CDHX,CDMX,RIBX,CFLUX, 3 FTEMPX,FVAPX,ILMOX,UEX,HBLX, 4 QLWIN,TPOTA,QA,VA,PADRY,RHOAIR, 5 ALVSSN,ALIRSN,CRIB,CPHCHG,CEVAP,TVIRTA, 6 ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,FCOR, 7 GCONSTS,GCOEFFS,TSFSAV(1,2),PCPR, + TRSNOWG,FSSB,ALSNO, + THLIQG,THLMIN,DELZW,RHOSGS,ZSNOW, 8 IWATER,IEVAP,ITERCT,ISAND, 9 ISLFD,ITG,ILG,IG,IL1,IL2,JL,NBS,ISNOALB, A TSTEP,TVIRTS,EVBETA,Q0SAT,RESID, B DCFLXM,CFLUXM,WZERO,TRTOPG,AC,BC, C LZZ0,LZZ0T,FM,FH,ITER,NITER,JEVAP,KF ) CALL TSPOST(GSNOWG,TSNOGS,WSNOGS,RHOSGS,QMELTG, 1 GZROGS,TSNBOT,HTCS,HMFN, 2 GCONSTS,GCOEFFS,GCONST,GCOEFF,TBAR, 3 TSURX,ZSNOW,TCSNOW,HCPSGS,QTRANS, 4 FGS,DELZ,ILG,IL1,IL2,JL,IG ) CALL TNPOST(TBARGS,G12GS,G23GS,TPNDGS,GZROGS,ZERO,GCONST, 1 GCOEFF,TBAR,TCTOPG,TCBOTG,HCPG,ZPOND,TSNBOT, 2 TBASE,TBAR1P,A1,A2,B1,B2,C2,FGS,IWATER, 3 ISAND,DELZ,DELZW,ILG,IL1,IL2,JL,IG ) C C * DIAGNOSTICS. C IF(ISLFD.EQ.0) THEN DO 250 I=IL1,IL2 IF(FGS(I).GT.0.) THEN FACTM=ZDSLM(I)+ZOM(I) FACTH=ZDSLH(I)+ZOM(I) RATIOM=SQRT(CDMX(I))*LOG(FACTM/ZOM(I))/VKC RATIOM=MIN(RATIOM,1.) RATIOH=SQRT(CDMX(I))*LOG(FACTH/ZOH(I))/VKC RATIOH=MIN(RATIOH,1.) IF(RIBX(I).LT.0.) THEN RATIOH=RATIOH*CDHX(I)/CDMX(I) RATIOH=MIN(RATIOH,(FACTH/ZRSLDH(I))**(1./3.)) ENDIF STT(I)=TSURX(I)-(MIN(RATIOH,1.))*(TSURX(I)-TA(I)) SQT(I)=QSURX(I)-(MIN(RATIOH,1.))*(QSURX(I)-QA(I)) SUT(I)=RATIOM*UWIND(I) SVT(I)=RATIOM*VWIND(I) ENDIF 250 CONTINUE C CALL SCREENRH(SHT,STT,SQT,PRESSG,FGS,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FGS(I).GT.0.) THEN ST (I)=ST (I)+FGS(I)*STT(I) SQ (I)=SQ (I)+FGS(I)*SQT(I) SU (I)=SU (I)+FGS(I)*SUT(I) SV (I)=SV (I)+FGS(I)*SVT(I) SRH(I)=SRH(I)+FGS(I)*SHT(I) ENDIF ENDDO C ELSEIF(ISLFD.EQ.1) THEN CALL SLDIAG(SUT,SVT,STT,SQT, 1 CDMX,CDHX,UWIND,VWIND,TPOTA,QA, 2 TSURX,QSURX,ZOM,ZOH,FGS,ZRSLDM, 3 ZDSLM,ZDSLH,ILG,IL1,IL2,JL) C CALL SCREENRH(SHT,STT,SQT,PRESSG,FGS,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FGS(I).GT.0.) THEN ST (I)=ST (I)+FGS(I)*STT(I) SQ (I)=SQ (I)+FGS(I)*SQT(I) SU (I)=SU (I)+FGS(I)*SUT(I) SV (I)=SV (I)+FGS(I)*SVT(I) SRH(I)=SRH(I)+FGS(I)*SHT(I) ENDIF ENDDO ELSEIF(ISLFD.EQ.2) THEN CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TSURX,QSURX, 1 ZOM,ZOH,ILMOX,ZRSLFM,HBLX,UEX,FTEMPX,FVAPX, 2 ZDSLM,ZDSLH,RADJ,FGS,IL1,IL2,JL) ENDIF C DO 275 I=IL1,IL2 IF(FGS(I).GT.0.) THEN EVPPOT(I)=EVPPOT(I)+FGS(I)*RHOAIR(I)*CFLUX(I)* 1 (Q0SAT(I)-QA(I)) ACOND(I)=ACOND(I)+FGS(I)*CFLUX(I) ILMO(I) =ILMO(I)+FGS(I)*ILMOX(I) UE(I) =UE(I)+FGS(I)*UEX(I) HBL(I) =HBL(I)+FGS(I)*HBLX(I) CDH (I) =CDH(I)+FGS(I)*CDHX(I) CDM (I) =CDM(I)+FGS(I)*CDMX(I) TSFSAV(I,2)=TSURX(I) QG(I)=QG(I)+FGS(I)*QSURX(I) QSENS(I)=QSENS(I)+FGS(I)*QSENSX(I) QEVAP(I)=QEVAP(I)+FGS(I)*QEVAPX(I) QLWAVG(I)=QLWAVG(I)+FGS(I)*QLWX(I) FSGS(I) =FSGS(I)+FGS(I)*(QSWX(I)-QTRANS(I)) FSGG(I) =FSGG(I)+FGS(I)*QTRANS(I) FLGS(I) =FLGS(I)+FGS(I)*(QLWIN(I)-QLWX(I)) HFSS(I) =HFSS(I)+FGS(I)*QSENSX(I) HEVS(I) =HEVS(I)+FGS(I)*QEVAPX(I) HTCS(I) =HTCS(I)+FGS(I)*(-GZROGS(I)+ 1 QTRANS(I)) HTC(I,1)=HTC(I,1)+FGS(I)*(GZROGS(I)-QTRANS(I)- 1 G12GS(I)) HTC(I,2)=HTC(I,2)+FGS(I)*(G12GS(I)-G23GS(I)) HTC(I,3)=HTC(I,3)+FGS(I)*G23GS(I) FTEMP(I)= FTEMP(I) + FGS(I) * FTEMPX(I) FVAP (I)= FVAP (I) + FGS(I) * FVAPX (I) RIB (I)= RIB (I) + FGS(I) * RIBX (I) GSNOW(I) =GSNOW(I)+FGS(I)/(FCS(I)+FGS(I))*GSNOWG(I) ENDIF 275 CONTINUE ENDIF C C * CALCULATIONS FOR CANOPY OVER BARE GROUND. C IF(NLANDC.GT.0) THEN DO 300 I=IL1,IL2 IF(FC(I).GT.0.) THEN ZOM(I)=EXP(ZOMLNC(I)) ZOH(I)=EXP(ZOELNC(I)) IF(IZREF.EQ.1) THEN ZRSLDM(I)=ZREFM(I)-DISP(I) ZRSLDH(I)=ZREFH(I)-DISP(I) ZRSLFM(I)=ZREFM(I)-ZOM(I)-DISP(I) ZRSLFH(I)=ZREFH(I)-ZOM(I)-DISP(I) ZDSLM(I)=ZDIAGM(I)-ZOM(I) ZDSLH(I)=ZDIAGH(I)-ZOM(I) TPOTA(I)=TA(I)+ZRSLFH(I)*GRAV/CPD ELSE ZRSLDM(I)=ZREFM(I)+ZOM(I) ZRSLDH(I)=ZREFH(I)+ZOM(I) ZRSLFM(I)=ZREFM(I)-DISP(I) ZRSLFH(I)=ZREFH(I)-DISP(I) ZDSLM(I)=ZDIAGM(I) ZDSLH(I)=ZDIAGH(I) TPOTA(I)=TA(I) ENDIF ZOSCLM(I)=ZOM(I)/ZRSLDM(I) ZOSCLH(I)=ZOH(I)/ZRSLDH(I) TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I)) CRIB(I)=-GRAV*ZRSLDM(I)/(TVIRTA(I)*VA(I)**2) DRAG(I)=DRAG(I)+FC(I)*(VKC/(LOG(ZRSLDM(I))- 1 ZOMLNC(I)))**2 VAC(I)=VA(I)*(LOG(10.0*ZOM(I)-DISP(I))-ZOMLNC(I))/ 1 (LOG(ZRSLDM(I))-ZOMLNC(I)) TACCO(I)=TAC(I) QACCO(I)=QAC(I) ENDIF 300 CONTINUE C CALL CWCALC(TCANO,RAICAN,SNOCAN,FRAINC,FSNOWC,CHCAP, 1 HMFC,HTCC,FC,CMASSC,ILG,IL1,IL2,JL) CALL TNPREP(A1,A2,B1,B2,C2,GDENOM,GCOEFF, 1 GCONST,CPHCHG,IWATER, 2 TBAR,TCTOPC,TCBOTC, + FC,ZPOND,TBAR1P,DELZ,TCSNOW,ZSNOW, 3 ISAND,ILG,IL1,IL2,JL,IG ) ISNOW=0 CALL TSOLVC(ISNOW,FC, 1 QSWX,QSWNC,QSWNG,QLWX,QLWOC,QLWOG,QTRANS, 2 QSENSX,QSENSC,QSENSG,QEVAPX,QEVAPC,QEVAPG,EVAPC, 3 EVAPCG,EVAP,TCANO,QCANX,TSURX,QSURX,GZEROC,QPHCHC, 4 QFREZC,RAICAN,SNOCAN,CDHX,CDMX,RIBX,TACCO,QACCO, 5 CFLUX,FTEMPX,FVAPX,ILMOX,UEX,HBLX,QFCF,QFCL,HTCC, 6 QSWINV,QSWINI,QLWIN,TPOTA,TA,QA,VA,VAC,PADRY, 7 RHOAIR,ALVSCN,ALIRCN,ALVSGC,ALIRGC,TRVSCN,TRIRCN, 8 FSVF,CRIB,CPHCHC,CPHCHG,CEVAP,TADP,TVIRTA,RC, 9 RBCOEF,ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM, A FCOR,GCONST,GCOEFF,TSFSAV(1,3),TRSNOWC,FSNOWC, B FRAINC,CHCAP,CMASSC,PCPR,FROOT,THLMIN,DELZW, + ZERO,ZERO,IWATER,IEVAP,ITERCT, C ISLFD,ITC,ITCG,ILG,IL1,IL2,JL,N, D TSTEP,TVIRTC,TVIRTG,EVBETA,XEVAP,EVPWET,Q0SAT, E RA,RB,RAGINV,RBINV,RBTINV,RBCINV,TVRTAC,TPOTG, F RESID,TCANP, G WZERO,XEVAPM,DCFLXM,WC,DRAGIN,CFLUXM,CFLX,IEVAPC, H TRTOP,QSTOR,CFSENS,CFEVAP,QSGADD,AC,BC, I LZZ0,LZZ0T,FM,FH,ITER,NITER,KF1,KF2, J AILCG,FCANC,CO2CONC,RMATCTEM, K THLIQC,THFC,THLW,ISAND,IG,COSZS,PRESSG, L XDIFFUS,ICTEM,IC,CO2I1CG,CO2I2CG, M ICTEMMOD,SLAI,FCANCMX,L2MAX, N NOL2PFTS,CFLUXCG,ANCGVEG,RMLCGVEG) CALL TNPOST(TBARC,G12C,G23C,TPONDC,GZEROC,QFREZC,GCONST, 1 GCOEFF,TBAR,TCTOPC,TCBOTC,HCPC,ZPOND,TSURX, 2 TBASE,TBAR1P,A1,A2,B1,B2,C2,FC,IWATER, 3 ISAND,DELZ,DELZW,ILG,IL1,IL2,JL,IG ) C C * DIAGNOSTICS. C IF(ISLFD.EQ.0) THEN DO 350 I=IL1,IL2 IF(FC(I).GT.0.) THEN FACTM=ZDSLM(I)+ZOM(I) FACTH=ZDSLH(I)+ZOM(I) RATIOM=SQRT(CDMX(I))*LOG(FACTM/ZOM(I))/VKC RATIOM=MIN(RATIOM,1.) RATIOH=SQRT(CDMX(I))*LOG(FACTH/ZOH(I))/VKC RATIOH=MIN(RATIOH,1.) IF(RIBX(I).LT.0.) THEN RATIOH=RATIOH*CDHX(I)/CDMX(I) RATIOH=MIN(RATIOH,(FACTH/ZRSLDH(I))**(1./3.)) ENDIF STT(I)=TACCO(I)-(MIN(RATIOH,1.))*(TACCO(I)-TA(I)) SQT(I)=QACCO(I)-(MIN(RATIOH,1.))*(QACCO(I)-QA(I)) SUT(I)=RATIOM*UWIND(I) SVT(I)=RATIOM*VWIND(I) ENDIF 350 CONTINUE C CALL SCREENRH(SHT,STT,SQT,PRESSG,FC,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FC(I).GT.0.) THEN ST (I)=ST (I)+FC(I)*STT(I) SQ (I)=SQ (I)+FC(I)*SQT(I) SU (I)=SU (I)+FC(I)*SUT(I) SV (I)=SV (I)+FC(I)*SVT(I) SRH(I)=SRH(I)+FC(I)*SHT(I) ENDIF ENDDO ELSEIF(ISLFD.EQ.1) THEN CALL SLDIAG(SUT,SVT,STT,SQT, 1 CDMX,CDHX,UWIND,VWIND,TPOTA,QA, 2 TACCO,QACCO,ZOM,ZOH,FC,ZRSLDM, 3 ZDSLM,ZDSLH,ILG,IL1,IL2,JL) C CALL SCREENRH(SHT,STT,SQT,PRESSG,FC,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FC(I).GT.0.) THEN ST (I)=ST (I)+FC(I)*STT(I) SQ (I)=SQ (I)+FC(I)*SQT(I) SU (I)=SU (I)+FC(I)*SUT(I) SV (I)=SV (I)+FC(I)*SVT(I) SRH(I)=SRH(I)+FC(I)*SHT(I) ENDIF ENDDO ELSEIF(ISLFD.EQ.2) THEN CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TACCO,QACCO, 1 ZOM,ZOH,ILMOX,ZRSLFM,HBLX,UEX,FTEMPX,FVAPX, 2 ZDSLM,ZDSLH,RADJ,FC,IL1,IL2,JL) ENDIF C DO 375 I=IL1,IL2 IF(FC(I).GT.0.) THEN IF(TACCO(I).GE.TFREZ) THEN CA=17.269 CB=35.86 ELSE CA=21.874 CB=7.66 ENDIF WACSAT=0.622*611.0*EXP(CA*(TACCO(I)-TFREZ)/ 1 (TACCO(I)-CB))/PADRY(I) QACSAT=WACSAT/(1.0+WACSAT) EVPPOT(I)=EVPPOT(I)+FC(I)*RHOAIR(I)*CFLUX(I)* 1 (QACSAT-QA(I)) ACOND(I)=ACOND(I)+FC(I)*CFLUX(I) ILMO(I) =ILMO(I)+FC(I)*ILMOX(I) UE(I) =UE(I)+FC(I)*UEX(I) HBL(I) =HBL(I)+FC(I)*HBLX(I) CDH (I) =CDH(I)+FC(I)*CDHX(I) CDM (I) =CDM(I)+FC(I)*CDMX(I) TSFSAV(I,3)=TSURX(I) QG(I)=QG(I)+FC(I)*QACCO(I) QSENS(I)=QSENS(I)+FC(I)*QSENSX(I) QEVAP(I)=QEVAP(I)+FC(I)*QEVAPX(I) QLWAVG(I)=QLWAVG(I)+FC(I)*QLWX(I) FSGV(I) =FSGV(I)+FC(I)*QSWNC(I) FSGG(I) =FSGG(I)+FC(I)*QSWNG(I) FLGV(I) =FLGV(I)+FC(I)*(QLWIN(I)+QLWOG(I)-2.0* 1 QLWOC(I))*(1.0-FSVF(I)) FLGG(I) =FLGG(I)+FC(I)*(FSVF(I)*QLWIN(I)+ 1 (1.0-FSVF(I))*QLWOC(I)-QLWOG(I)) IF(ITC.EQ.1) THEN HFSC(I) =HFSC(I)+FC(I)*QSENSC(I) ELSE HFSC(I) =HFSC(I)+FC(I)*(QSENSC(I)-QSENSG(I)) ENDIF HFSG(I) =HFSG(I)+FC(I)*QSENSG(I) HEVC(I) =HEVC(I)+FC(I)*QEVAPC(I) HEVG(I) =HEVG(I)+FC(I)*QEVAPG(I) HMFC(I) =HMFC(I)+FC(I)*QPHCHC(I) HTC(I,1)=HTC(I,1)+FC(I)*(-G12C(I)) HTC(I,2)=HTC(I,2)+FC(I)*(G12C(I)-G23C(I)) HTC(I,3)=HTC(I,3)+FC(I)*G23C(I) FTEMP(I)= FTEMP(I) + FC(I) * FTEMPX(I) FVAP (I)= FVAP (I) + FC(I) * FVAPX (I) RIB (I)= RIB (I) + FC(I) * RIBX (I) ENDIF 375 CONTINUE ENDIF C C * CALCULATIONS FOR BARE GROUND. C IF(NLANDG.GT.0) THEN DO 400 I=IL1,IL2 IF(FG(I).GT.0.) THEN ZOM(I)=EXP(ZOMLNG(I)) ZOH(I)=EXP(ZOELNG(I)) IF(IZREF.EQ.1) THEN ZRSLDM(I)=ZREFM(I) ZRSLDH(I)=ZREFH(I) ZRSLFM(I)=ZREFM(I)-ZOM(I) ZRSLFH(I)=ZREFH(I)-ZOM(I) ZDSLM(I)=ZDIAGM(I)-ZOM(I) ZDSLH(I)=ZDIAGH(I)-ZOM(I) TPOTA(I)=TA(I)+ZRSLFH(I)*GRAV/CPD ELSE ZRSLDM(I)=ZREFM(I)+ZOM(I) ZRSLDH(I)=ZREFH(I)+ZOM(I) ZRSLFM(I)=ZREFM(I) ZRSLFH(I)=ZREFH(I) ZDSLM(I)=ZDIAGM(I) ZDSLH(I)=ZDIAGH(I) TPOTA(I)=TA(I) ENDIF ZOSCLM(I)=ZOM(I)/ZRSLDM(I) ZOSCLH(I)=ZOH(I)/ZRSLDH(I) TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I)) CRIB(I)=-GRAV*ZRSLDM(I)/(TVIRTA(I)*VA(I)**2) DRAG(I)=DRAG(I)+FG(I)*(VKC/(LOG(ZRSLDM(I))- 1 ZOMLNG(I)))**2 ENDIF 400 CONTINUE C CALL TNPREP(A1,A2,B1,B2,C2,GDENOM,GCOEFF, 1 GCONST,CPHCHG,IWATER, 2 TBAR,TCTOPG,TCBOTG, + FG,ZPOND,TBAR1P,DELZ,TCSNOW,ZSNOW, 3 ISAND,ILG,IL1,IL2,JL,IG ) ISNOW=0 CALL TSOLVE(ISNOW,FG, 1 QSWX,QLWX,QTRANS,QSENSX,QEVAPX,EVAPG, 2 TSURX,QSURX,GZEROG,QFREZG,CDHX,CDMX,RIBX,CFLUX, 3 FTEMPX,FVAPX,ILMOX,UEX,HBLX, 4 QLWIN,TPOTA,QA,VA,PADRY,RHOAIR, 5 ALVSG,ALIRG,CRIB,CPHCHG,CEVAP,TVIRTA, 6 ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,FCOR, 7 GCONST,GCOEFF,TSFSAV(1,4),PCPR, + TRSNOWG,FSSB,ALSNO, + THLIQG,THLMIN,DELZW,ZERO,ZERO, 8 IWATER,IEVAP,ITERCT,ISAND, 9 ISLFD,ITG,ILG,IG,IL1,IL2,JL, NBS,ISNOALB, A TSTEP,TVIRTS,EVBETA,Q0SAT,RESID, B DCFLXM,CFLUXM,WZERO,TRTOPG,AC,BC, C LZZ0,LZZ0T,FM,FH,ITER,NITER,JEVAP,KF ) CALL TNPOST(TBARG,G12G,G23G,TPONDG,GZEROG,QFREZG,GCONST, 1 GCOEFF,TBAR,TCTOPG,TCBOTG,HCPG,ZPOND,TSURX, 2 TBASE,TBAR1P,A1,A2,B1,B2,C2,FG,IWATER, 3 ISAND,DELZ,DELZW,ILG,IL1,IL2,JL,IG ) C C * DIAGNOSTICS. C IF(ISLFD.EQ.0) THEN DO 450 I=IL1,IL2 IF(FG(I).GT.0.) THEN FACTM=ZDSLM(I)+ZOM(I) FACTH=ZDSLH(I)+ZOM(I) RATIOM=SQRT(CDMX(I))*LOG(FACTM/ZOM(I))/VKC RATIOM=MIN(RATIOM,1.) RATIOH=SQRT(CDMX(I))*LOG(FACTH/ZOH(I))/VKC RATIOH=MIN(RATIOH,1.) IF(RIBX(I).LT.0.) THEN RATIOH=RATIOH*CDHX(I)/CDMX(I) RATIOH=MIN(RATIOH,(FACTH/ZRSLDH(I))**(1./3.)) ENDIF STT(I)=TSURX(I)-(MIN(RATIOH,1.))*(TSURX(I)-TA(I)) SQT(I)=QSURX(I)-(MIN(RATIOH,1.))*(QSURX(I)-QA(I)) SUT(I)=RATIOM*UWIND(I) SVT(I)=RATIOM*VWIND(I) ENDIF 450 CONTINUE C CALL SCREENRH(SHT,STT,SQT,PRESSG,FG,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FG(I).GT.0.) THEN ST (I)=ST (I)+FG(I)*STT(I) SQ (I)=SQ (I)+FG(I)*SQT(I) SU (I)=SU (I)+FG(I)*SUT(I) SV (I)=SV (I)+FG(I)*SVT(I) SRH(I)=SRH(I)+FG(I)*SHT(I) SFCUBS (I)=SUT(I) SFCVBS (I)=SVT(I) USTARBS(I)=VA(I)*SQRT(CDMX(I)) ENDIF ENDDO ELSEIF(ISLFD.EQ.1) THEN CALL SLDIAG(SUT,SVT,STT,SQT, 1 CDMX,CDHX,UWIND,VWIND,TPOTA,QA, 2 TSURX,QSURX,ZOM,ZOH,FG,ZRSLDM, 3 ZDSLM,ZDSLH,ILG,IL1,IL2,JL) C CALL SCREENRH(SHT,STT,SQT,PRESSG,FG,ILG,IL1,IL2) C DO I=IL1,IL2 IF(FG(I).GT.0.) THEN ST (I)=ST (I)+FG(I)*STT(I) SQ (I)=SQ (I)+FG(I)*SQT(I) SU (I)=SU (I)+FG(I)*SUT(I) SV (I)=SV (I)+FG(I)*SVT(I) SRH(I)=SRH(I)+FG(I)*SHT(I) SFCUBS (I)=SUT(I) SFCVBS (I)=SVT(I) USTARBS(I)=VA(I)*SQRT(CDMX(I)) ENDIF ENDDO ELSEIF(ISLFD.EQ.2) THEN CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TSURX,QSURX, 1 ZOM,ZOH,ILMOX,ZRSLFM,HBLX,UEX,FTEMPX,FVAPX, 2 ZDSLM,ZDSLH,RADJ,FG,IL1,IL2,JL) ENDIF C DO 475 I=IL1,IL2 IF(FG(I).GT.0.) THEN EVPPOT(I)=EVPPOT(I)+FG(I)*RHOAIR(I)*CFLUX(I)* 1 (Q0SAT(I)-QA(I)) ACOND(I)=ACOND(I)+FG(I)*CFLUX(I) ILMO(I) =ILMO(I)+FG(I)*ILMOX(I) UE(I) =UE(I)+FG(I)*UEX(I) HBL(I) =HBL(I)+FG(I)*HBLX(I) CDH (I) =CDH(I)+FG(I)*CDHX(I) CDM (I) =CDM(I)+FG(I)*CDMX(I) TSFSAV(I,4)=TSURX(I) GTBS(I)=TSURX(I) QG(I)=QG(I)+FG(I)*QSURX(I) QSENS(I)=QSENS(I)+FG(I)*QSENSX(I) QEVAP(I)=QEVAP(I)+FG(I)*QEVAPX(I) QLWAVG(I)=QLWAVG(I)+FG(I)*QLWX(I) FSGG(I) =FSGG(I)+FG(I)*QSWX(I) FLGG(I) =FLGG(I)+FG(I)*(QLWIN(I)-QLWX(I)) HFSG(I) =HFSG(I)+FG(I)*QSENSX(I) HEVG(I) =HEVG(I)+FG(I)*QEVAPX(I) HTC(I,1)=HTC(I,1)+FG(I)*(-G12G(I)) HTC(I,2)=HTC(I,2)+FG(I)*(G12G(I)-G23G(I)) HTC(I,3)=HTC(I,3)+FG(I)*G23G(I) FTEMP(I)= FTEMP(I) + FG(I) * FTEMPX(I) FVAP (I)= FVAP (I) + FG(I) * FVAPX (I) RIB (I)= RIB (I) + FG(I) * RIBX (I) ENDIF 475 CONTINUE ENDIF C C * ADDITIONAL DIAGNOSTIC VARIABLES. C DO 500 I=IL1,IL2 GT(I)=(QLWAVG(I)/SBC)**0.25 TFLUX(I)=-QSENS(I)/(RHOAIR(I)*SPHAIR) EVAP(I)=EVAP(I)+RHOW* 1 (FCS(I)*(EVAPCS(I)+EVPCSG(I)) + FGS(I)*EVAPGS(I) + 2 FC (I)*(EVAPC (I)+EVAPCG(I)) + FG (I)*EVAPG(I)) IF(EVPPOT(I).NE.0.0) THEN EVAPB(I)=EVAP(I)/EVPPOT(I) ELSE EVAPB(I)=0.0 ENDIF IF((FCS(I)+FC(I)).GT.1.0E-5) THEN TAC(I)=(FCS(I)*TACCS(I)+FC(I)*TACCO(I))/(FCS(I)+FC(I)) QAC(I)=(FCS(I)*QACCS(I)+FC(I)*QACCO(I))/(FCS(I)+FC(I)) ELSE TAC(I)=TA(I) QAC(I)=QA(I) ENDIF 500 CONTINUE C RETURN END SUBROUTINE CLASSW(THLIQ, THICE, TBAR, TCAN, RCAN, SNCAN, 1 RUNOFF, TRUNOF, SNO, TSNOW, RHOSNO, ALBSNO, 2 WSNOW, ZPOND, TPOND, GROWTH, TBASE, GFLUX, 3 PCFC, PCLC, PCPN, PCPG, QFCF, QFCL, 4 QFN, QFG, QFC, HMFC, HMFG, HMFN, 5 HTCC, HTCS, HTC, ROFC, ROFN, ROVG, 6 WTRS, WTRG, OVRFLW, SUBFLW, BASFLW, 7 TOVRFL, TSUBFL, TBASFL, EVAP, QFLUX, RHOAIR, 8 TBARC, TBARG, TBARCS, TBARGS, THLIQC, THLIQG, 9 THICEC, THICEG, HCPC, HCPG, RPCP, TRPCP, A SPCP, TSPCP, PCPR, TA, RHOSNI, GGEO, B FC, FG, FCS, FGS, TPONDC, TPONDG, C TPNDCS, TPNDGS, EVAPC, EVAPCG, EVAPG, EVAPCS, D EVPCSG, EVAPGS, QFREZC, QFREZG, QMELTC, QMELTG, E RAICAN, SNOCAN, RAICNS, SNOCNS, FSVF, FSVFS, F CWLCAP, CWFCAP, CWLCPS, CWFCPS, TCANO, G TCANS, CHCAP, CHCAPS, CMASSC, CMASCS, ZSNOW, H GZEROC, GZEROG, GZROCS, GZROGS, G12C, G12G, I G12CS, G12GS, G23C, G23G, G23CS, G23GS, J TSNOCS, TSNOGS, WSNOCS, WSNOGS, RHOSCS, RHOSGS, K ZPLIMC, ZPLIMG, ZPLMCS, ZPLMGS, TSFSAV, L TCTOPC, TCBOTC, TCTOPG, TCBOTG, FROOT, FROOTS, M THPOR, THLRET, THLMIN, BI, PSISAT, GRKSAT, N THLRAT, THFC, XDRAIN, HCPS, DELZ, O DELZW, ZBOTW, XSLOPE, GRKFAC, WFSURF, WFCINT, P ISAND, IGDR, Q IWF, ILG, IL1, IL2, N, R JL, IC, IG, IGP1, IGP2, S NLANDCS,NLANDGS,NLANDC, NLANDG, NLANDI ) C C * AUG 04/15 - M.LAZARE. SPLIT FROOT INTO TWO ARRAYS, FOR CANOPY C * AREAS WITH AND WITHOUT SNOW. C * OCT 03/14 - D.VERSEGHY. CHANGE LIMITING VALUE OF SNOW PACK C * FROM 100 KG/M2 TO 10 M. C * AUG 19/13 - M.LAZARE. ADD CALCULATION OF "QFLUX" (NOW PASSED C * IN ALONG WITH "RHOAIR") PREVIOUSLY DONE C * IN CLASST. C * JUN 21/13 - M.LAZARE. SET ZSNOW=0. IF THERE IS NO C * SNOW IN ANY OF THE 4 SUBCLASSES, C * SIMILAR TO WHAT IS DONE FOR THE C * OTHER SNOW-RELATED FIELDS. C * OCT 18/11 - M.LAZARE. PASS IN IGDR THROUGH CALLS TO C * GRDRAN/GRINFL (ORIGINATES NOW C * IN CLASSB - ONE CONSISTENT C * CALCULATION). C * APR 04/11 - D.VERSEGHY. ADD DELZ TO GRINFL CALL. C * DEC 07/09 - D.VERSEGHY. ADD RADD AND SADD TO WPREP CALL. C * JAN 06/09 - D.VERSEGHY. INCREASE LIMITING SNOW AMOUNT. C * FEB 25/08 - D.VERSEGHY. MODIFICATIONS REFLECTING CHANGES C * ELSEWHERE IN CODE. C * MAR 23/06 - D.VERSEGHY. CHANGES TO ADD MODELLING OF WSNOW; C * PASS IN GEOTHERMAL HEAT FLUX. C * MAR 21/06 - P.BARTLETT. PASS ADDITIONAL VARIABLES TO WPREP. C * DEC 07/05 - D.VERSEGHY. REVISIONS TO CALCULATION OF TBASE. C * OCT 05/05 - D.VERSEGHY. MODIFICATIONS TO ALLOW OPTION OF SUB- C * DIVIDING THIRD SOIL LAYER. C * MAR 23/05 - D.VERSEGHY. ADD VARIABLES TO SUBROUTINE CALLS. C * MAR 14/05 - D.VERSEGHY. RENAME SCAN TO SNCAN (RESERVED NAME C * IN F90). C * NOV 04/04 - D.VERSEGHY. ADD "IMPLICIT NONE" COMMAND. C * JUL 08/04 - D.VERSEGHY. NEW LOWER LIMITS FOR RCAN, SCAN, ZPOND C * AND SNOW. C * DEC 09/02 - D.VERSEGHY. SWITCH CALLING ORDER OF TFREEZ AND C * SNOVAP FOR CONSISTENCY WITH DIAGNOSTICS. C * SEP 26.02 - D.VERSEGHY. CHANGED CALL TO SUBCAN. C * AUG 01/02 - D.VERSEGHY. ADD CALL TO WATROF, NEW SUBROUTINE C * CONTAINING WATERLOO OVERLAND FLOW C * AND INTERFLOW CALCULATIONS. C * SHORTENED CLASS3 COMMON BLOCK. C * JUL 03/02 - D.VERSEGHY. STREAMLINE SUBROUTINE CALLS; MOVE C * CALCULATION OF BACKGROUND SOIL C * PROPERTIES INTO "CLASSB"; CHANGE C * RHOSNI FROM CONSTANT TO VARIABLE. C * OCT 04/01 - M.LAZARE. REMOVE SEVERAL OLD DIAGNOSTIC FIELDS C * AND ADD NEW FIELD "ROVG". C * MAY 14/01 - M.LAZARE. ADD CALLS TO SUBROUTINE "SNOVAP" FOR C * FC AND FG SUBAREAS OF GRID CELL. C * OCT 20/00 - D.VERSEGHY. ADD WORK ARRAY "RHOMAX" FOR SNOALBW. C * JUN 20/97 - D.VERSEGHY. CLASS - VERSION 2.7. C * CHANGES RELATED TO VARIABLE SOIL DEPTH C * (MOISTURE HOLDING CAPACITY) AND DEPTH- C * VARYING SOIL PROPERTIES. C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5. C * COMPLETION OF ENERGY BALANCE C * DIAGNOSTICS; INTRODUCE CALCULATION OF C * OVERLAND FLOW. C * AUG 30/95 - D.VERSEGHY. CLASS - VERSION 2.4. C * VARIABLE SURFACE DETENTION CAPACITY C * IMPLEMENTED. C * AUG 24/95 - D.VERSEGHY. UPDATE ARRAY "EVAP" TO TAKE INTO C * ACCOUNT "WLOST"; RATIONALIZE C * CALCULATION OF THE LATTER. C * COMPLETION OF WATER BUDGET DIAGNOSTICS. C * AUG 18/95 - D.VERSEGHY. REVISIONS TO ALLOW FOR INHOMOGENEITY C * BETWEEN SOIL LAYERS AND FRACTIONAL C * ORGANIC MATTER CONTENT. C * DEC 22/94 - D.VERSEGHY. CLASS - VERSION 2.3. C * CHANGES TO SUBROUTINE CALLS ASSOCIATED C * WITH REVISIONS TO DIAGNOSTICS. C * ALLOW SPECIFICATION OF LIMITING POND C * DEPTH "PNDLIM" (PARALLEL CHANGES MADE C * SIMULTANEOUSLY IN TMCALC). C * DEC 16/94 - D.VERSEGHY. TWO NEW DIAGNOSTIC FIELDS. C * NOV 18/93 - D.VERSEGHY. LOCAL VERSION WITH INTERNAL WORK ARRAYS C * HARD-CODED FOR USE ON PCS. C * NOV 01/93 - D.VERSEGHY. CLASS - VERSION 2.2. C * REVISIONS ASSOCIATED WITH NEW VERSION C * OF TMCALC. C * JUL 30/93 - D.VERSEGHY/M.LAZARE. NUMEROUS NEW DIAGNOSTIC FIELDS. C * MAY 06/93 - D.VERSEGHY/M.LAZARE. CORRECT BUG IN CALL TO TMCALC C * FOR CANOPY-SNOW CASE, WHERE C * SHOULD BE PASSING "HCPCS" C * INSTEAD OF "HCPGS". C * MAY 15/92 - D.VERSEGHY/M.LAZARE. REVISED AND VECTORIZED CODE C * FOR MODEL VERSION GCM7. C * AUG 12/91 - D.VERSEGHY. CODE FOR MODEL VERSION GCM7U - C CLASS VERSION 2.0 (WITH CANOPY). C * APR 11/89 - D.VERSEGHY. LAND SURFACE WATER BUDGET CALCULATIONS. C IMPLICIT NONE C * INTEGER CONSTANTS. C INTEGER IWF,ILG,IL1,IL2,JL,IC,IG,IGP1,IGP2,I,J,NLANDCS,NLANDGS, 1 NLANDC,NLANDG,NLANDI,IPTBAD,JPTBAD,KPTBAD,LPTBAD,N C C * MAIN OUTPUT FIELDS. C REAL THLIQ (ILG,IG), THICE (ILG,IG), TBAR (ILG,IG), 1 GFLUX (ILG,IG) C REAL TCAN (ILG), RCAN (ILG), SNCAN (ILG), RUNOFF(ILG), 1 SNO (ILG), TSNOW (ILG), RHOSNO(ILG), ALBSNO(ILG), 2 ZPOND (ILG), TPOND (ILG), GROWTH(ILG), TBASE (ILG), 3 TRUNOF(ILG), WSNOW (ILG) C C * DIAGNOSTIC ARRAYS. C REAL PCFC (ILG), PCLC (ILG), PCPN (ILG), PCPG (ILG), 1 QFCF (ILG), QFCL (ILG), QFN (ILG), QFG (ILG), 2 HMFC (ILG), HMFN (ILG), HTCC (ILG), HTCS (ILG), 3 ROFC (ILG), ROFN (ILG), ROVG (ILG), WTRS (ILG), 4 WTRG (ILG), OVRFLW(ILG), SUBFLW(ILG), BASFLW(ILG), 5 TOVRFL(ILG), TSUBFL(ILG), TBASFL(ILG), EVAP (ILG), 6 QFLUX (ILG), RHOAIR(ILG) C REAL QFC (ILG,IG), HMFG (ILG,IG), HTC (ILG,IG) C C * I/O FIELDS PASSED THROUGH CLASS. C REAL RPCP (ILG), TRPCP (ILG), SPCP (ILG), TSPCP (ILG), 1 PCPR (ILG), TA (ILG) C REAL TBARC(ILG,IG), TBARG(ILG,IG), TBARCS(ILG,IG),TBARGS(ILG,IG), 1 THLIQC(ILG,IG),THLIQG(ILG,IG),THICEC(ILG,IG),THICEG(ILG,IG), 2 HCPC (ILG,IG),HCPG (ILG,IG),TCTOPC(ILG,IG),TCBOTC(ILG,IG), 3 TCTOPG(ILG,IG),TCBOTG(ILG,IG),FROOT (ILG,IG),FROOTS(ILG,IG), 4 TSFSAV(ILG,4) C REAL FC (ILG), FG (ILG), FCS (ILG), FGS (ILG), 1 TPONDC(ILG), TPONDG(ILG), TPNDCS(ILG), TPNDGS(ILG), 2 EVAPC (ILG), EVAPCG(ILG), EVAPG (ILG), EVAPCS(ILG), 3 EVPCSG(ILG), EVAPGS(ILG), QFREZC(ILG), QFREZG(ILG), 4 QMELTC(ILG), QMELTG(ILG), RAICAN(ILG), SNOCAN(ILG), 5 RAICNS(ILG), SNOCNS(ILG), FSVF (ILG), FSVFS (ILG), 6 CWLCAP(ILG), CWFCAP(ILG), CWLCPS(ILG), CWFCPS(ILG), 7 TCANO (ILG), TCANS (ILG), CHCAP (ILG), CHCAPS(ILG), 8 CMASSC(ILG), CMASCS(ILG), ZSNOW (ILG), RHOSNI(ILG), 9 GZEROC(ILG), GZEROG(ILG), GZROCS(ILG), GZROGS(ILG), A G12C (ILG), G12G (ILG), G12CS (ILG), G12GS (ILG), B G23C (ILG), G23G (ILG), G23CS (ILG), G23GS (ILG), C TSNOCS(ILG), TSNOGS(ILG), WSNOCS(ILG), WSNOGS(ILG), D RHOSCS(ILG), RHOSGS(ILG), ZPLIMC(ILG), ZPLIMG(ILG), E ZPLMCS(ILG), ZPLMGS(ILG), GGEO (ILG) C C * SOIL PROPERTY ARRAYS. C REAL THPOR (ILG,IG),THLRET(ILG,IG),THLMIN(ILG,IG),BI (ILG,IG), 1 GRKSAT(ILG,IG),PSISAT(ILG,IG),THLRAT(ILG,IG), 2 THFC (ILG,IG),HCPS (ILG,IG),DELZW (ILG,IG),DELZZ (ILG,IG), 3 ZBOTW (ILG,IG),XDRAIN(ILG), XSLOPE(ILG), GRKFAC(ILG), 4 WFSURF(ILG), WFCINT(ILG), DELZ (IG) C INTEGER ISAND(ILG,IG), IGDR (ILG) C C * INTERNAL WORK ARRAYS USED THROUGHOUT CLASSW. C REAL TBARWC(ILG,IG),TBARWG(ILG,IG),TBRWCS(ILG,IG),TBRWGS(ILG,IG), 1 THLQCO(ILG,IG),THLQGO(ILG,IG),THLQCS(ILG,IG),THLQGS(ILG,IG), 2 THICCO(ILG,IG),THICGO(ILG,IG),THICCS(ILG,IG),THICGS(ILG,IG), 3 HCPCO (ILG,IG),HCPGO (ILG,IG),HCPCS (ILG,IG),HCPGS (ILG,IG), 4 GRKSC (ILG,IG),GRKSG (ILG,IG),GRKSCS(ILG,IG),GRKSGS(ILG,IG), 5 GFLXC (ILG,IG),GFLXG (ILG,IG),GFLXCS(ILG,IG),GFLXGS(ILG,IG) C REAL SPCC (ILG), SPCG (ILG), SPCCS (ILG), SPCGS (ILG), 1 TSPCC (ILG), TSPCG (ILG), TSPCCS(ILG), TSPCGS(ILG), 2 RPCC (ILG), RPCG (ILG), RPCCS (ILG), RPCGS (ILG), 3 TRPCC (ILG), TRPCG (ILG), TRPCCS(ILG), TRPCGS(ILG), 4 EVPIC (ILG), EVPIG (ILG), EVPICS(ILG), EVPIGS(ILG), 5 ZPONDC(ILG), ZPONDG(ILG), ZPNDCS(ILG), ZPNDGS(ILG), 6 XSNOWC(ILG), XSNOWG(ILG), XSNOCS(ILG), XSNOGS(ILG), 7 ZSNOWC(ILG), ZSNOWG(ILG), ZSNOCS(ILG), ZSNOGS(ILG), 8 ALBSC (ILG), ALBSG (ILG), ALBSCS(ILG), ALBSGS(ILG), 9 RHOSC (ILG), RHOSG (ILG), A HCPSC (ILG), HCPSG (ILG), HCPSCS(ILG), HCPSGS(ILG), B RUNFC (ILG), RUNFG (ILG), RUNFCS(ILG), RUNFGS(ILG), C TRUNFC(ILG), TRUNFG(ILG), TRNFCS(ILG), TRNFGS(ILG), D TBASC (ILG), TBASG (ILG), TBASCS(ILG), TBASGS(ILG) C REAL SUBLC (ILG), SUBLCS(ILG), WLOSTC(ILG), WLOSTG(ILG), 1 WLSTCS(ILG), WLSTGS(ILG), RAC (ILG), RACS (ILG), 2 SNC (ILG), SNCS (ILG), TSNOWC(ILG), TSNOWG(ILG), 3 DT (ILG), ZERO (ILG), RALB (ILG), ZFAV (ILG), 4 THLINV(ILG) C INTEGER LZFAV (ILG) C C * INTERNAL WORK ARRAYS FOR WPREP AND CANADD. C REAL RADD (ILG), SADD (ILG) C C * INTERNAL WORK FIELDS FOR GRINFL/GRDRAN (AND THEIR CALLED C * ROUTINES (I.E. WFILL,WFLOW,WEND) AND ICEBAL. C REAL ZMAT (ILG,IGP2,IGP1) C REAL WMOVE (ILG,IGP2), TMOVE (ILG,IGP2) C REAL THLIQX(ILG,IGP1), THICEX(ILG,IGP1), TBARWX(ILG,IGP1), 1 DELZX (ILG,IGP1), ZBOTX (ILG,IGP1), FDT (ILG,IGP1), 2 TFDT (ILG,IGP1), PSIF (ILG,IGP1), THLINF(ILG,IGP1), 3 GRKINF(ILG,IGP1), FDUMMY(ILG,IGP1), TDUMMY(ILG,IGP1), 4 ZRMDR (ILG,IGP1) C REAL THLMAX(ILG,IG), THTEST(ILG,IG), THLDUM(ILG,IG), 1 THIDUM(ILG,IG), TDUMW (ILG,IG) C REAL TRMDR (ILG), ZF (ILG), FMAX (ILG), TUSED (ILG), 1 RDUMMY(ILG), WEXCES(ILG), FDTBND(ILG), WADD (ILG), 2 TADD (ILG), WADJ (ILG), TIMPND(ILG), DZF (ILG), 3 DTFLOW(ILG), THLNLZ(ILG), THLQLZ(ILG), DZDISP(ILG), 4 WDISP (ILG), WABS (ILG), ZMOVE (ILG), TBOT (ILG) C INTEGER IGRN (ILG), IGRD (ILG), IZERO (ILG), 1 IFILL (ILG), LZF (ILG), NINF (ILG), 2 IFIND (ILG), ITER (ILG), NEND (ILG), 3 ISIMP (ILG), ICONT (ILG) C C * INTERNAL WORK ARRAYS FOR CANVAP AND SNOALBW. C REAL EVLOST(ILG), RLOST (ILG), RHOMAX(ILG) C INTEGER IROOT (ILG) C C * INTERNAL WORK ARRAYS FOR WATROF. C REAL THCRIT(ILG,IG), DODRN (ILG), DOVER (ILG), 1 DIDRN (ILG,IG), DIDRNMX(ILG,IG) C C * INTERNAL WORK ARRAYS FOR CHKWAT. C REAL BAL (ILG) C C * INTERNAL SCALARS. C REAL SNOROF,WSNROF C C * COMMON BLOCK PARAMETERS. C REAL DELT,TFREZ,TCW,TCICE,TCSAND,TCCLAY,TCOM,TCDRYS,RHOSOL,RHOOM, 1 HCPW,HCPICE,HCPSOL,HCPOM,HCPSND,HCPCLY,SPHW,SPHICE,SPHVEG, 2 SPHAIR,RHOW,RHOICE,TCGLAC,CLHMLT,CLHVAP C COMMON /CLASS1/ DELT,TFREZ COMMON /CLASS3/ TCW,TCICE,TCSAND,TCCLAY,TCOM,TCDRYS, 1 RHOSOL,RHOOM COMMON /CLASS4/ HCPW,HCPICE,HCPSOL,HCPOM,HCPSND,HCPCLY, 1 SPHW,SPHICE,SPHVEG,SPHAIR,RHOW,RHOICE, 2 TCGLAC,CLHMLT,CLHVAP C C----------------------------------------------------------------------- C * PREPARATION. C CALL WPREP(THLQCO, THLQGO, THLQCS, THLQGS, THICCO, THICGO, 1 THICCS, THICGS, HCPCO, HCPGO, HCPCS, HCPGS, 2 GRKSC, GRKSG, GRKSCS, GRKSGS, 3 SPCC, SPCG, SPCCS, SPCGS, TSPCC, TSPCG, 4 TSPCCS, TSPCGS, RPCC, RPCG, RPCCS, RPCGS, 5 TRPCC, TRPCG, TRPCCS, TRPCGS, EVPIC, EVPIG, 6 EVPICS, EVPIGS, ZPONDC, ZPONDG, ZPNDCS, ZPNDGS, 7 XSNOWC, XSNOWG, XSNOCS, XSNOGS, ZSNOWC, ZSNOWG, 8 ZSNOCS, ZSNOGS, ALBSC, ALBSG, ALBSCS, ALBSGS, 9 RHOSC, RHOSG, HCPSC, HCPSG, HCPSCS, HCPSGS, A RUNFC, RUNFG, RUNFCS, RUNFGS, B TRUNFC, TRUNFG, TRNFCS, TRNFGS, TBASC, TBASG, C TBASCS, TBASGS, GFLXC, GFLXG, GFLXCS, GFLXGS, D SUBLC, SUBLCS, WLOSTC, WLOSTG, WLSTCS, WLSTGS, E RAC, RACS, SNC, SNCS, TSNOWC, TSNOWG, F OVRFLW, SUBFLW, BASFLW, TOVRFL, TSUBFL, TBASFL, G PCFC, PCLC, PCPN, PCPG, QFCF, QFCL, H QFN, QFG, QFC, HMFG, I ROVG, ROFC, ROFN, TRUNOF, J THLIQX, THICEX, THLDUM, THIDUM, K DT, RDUMMY, ZERO, IZERO, DELZZ, L FC, FG, FCS, FGS, M THLIQC, THLIQG, THICEC, THICEG, HCPC, HCPG, N TBARC, TBARG, TBARCS, TBARGS, TBASE, TSFSAV, O FSVF, FSVFS, RAICAN, SNOCAN, RAICNS, SNOCNS, P EVAPC, EVAPCG, EVAPG, EVAPCS, EVPCSG, EVAPGS, Q RPCP, TRPCP, SPCP, TSPCP, RHOSNI, ZPOND, R ZSNOW, ALBSNO, WSNOCS, WSNOGS, RHOSCS, RHOSGS, S THPOR, HCPS, GRKSAT, ISAND, DELZW, DELZ, T ILG, IL1, IL2, JL, IG, IGP1, U NLANDCS,NLANDGS,NLANDC, NLANDG, RADD, SADD ) C C C * CALCULATIONS FOR CANOPY OVER SNOW. C IF(NLANDCS.GT.0) THEN CALL CANVAP(EVAPCS,SUBLCS,RAICNS,SNOCNS,TCANS,THLQCS, 1 TBARCS,ZSNOCS,WLSTCS,CHCAPS,QFCF,QFCL,QFN,QFC, 2 HTCC,HTCS,HTC,FCS,CMASCS,TSNOCS,HCPSCS,RHOSCS, 3 FROOTS,THPOR,THLMIN,DELZW,EVLOST,RLOST,IROOT, 4 IG,ILG,IL1,IL2,JL,N ) CALL CANADD(2,RPCCS,TRPCCS,SPCCS,TSPCCS,RAICNS,SNOCNS, 1 TCANS,CHCAPS,HTCC,ROFC,ROVG,PCPN,PCPG, 2 FCS,FSVFS,CWLCPS,CWFCPS,CMASCS,RHOSNI, 3 TSFSAV(1,1),RADD,SADD,ILG,IL1,IL2,JL) CALL CWCALC(TCANS,RAICNS,SNOCNS,RDUMMY,RDUMMY,CHCAPS, 1 HMFC,HTCC,FCS,CMASCS,ILG,IL1,IL2,JL) CALL SUBCAN(2,RPCCS,TRPCCS,SPCCS,TSPCCS,RHOSNI,EVPCSG, 1 QFN,QFG,PCPN,PCPG,FCS,ILG,IL1,IL2,JL) CALL TWCALC(TBARCS,THLQCS,THICCS,HCPCS,TBRWCS,HMFG,HTC, 1 FCS,ZERO,THPOR,THLMIN,HCPS,DELZW,DELZZ,ISAND, 2 IG,ILG,IL1,IL2,JL) CALL SNOVAP(RHOSCS,ZSNOCS,HCPSCS,TSNOCS,EVPCSG,QFN,QFG, 1 HTCS,WLSTCS,TRNFCS,RUNFCS,TOVRFL,OVRFLW, 2 FCS,RPCCS,SPCCS,RHOSNI,WSNOCS,ILG,IL1,IL2,JL) CALL TFREEZ(ZPNDCS,TPNDCS,ZSNOCS,TSNOCS,ALBSCS, 1 RHOSCS,HCPSCS,GZROCS,HMFG,HTCS,HTC, 2 WTRS,WTRG,FCS,ZERO,WSNOCS,TA,TBARCS, 3 ISAND,IG,ILG,IL1,IL2,JL) CALL TMELT(ZSNOCS,TSNOCS,QMELTC,RPCCS,TRPCCS, 1 GZROCS,RALB,HMFN,HTCS,HTC,FCS,HCPSCS, 2 RHOSCS,WSNOCS,ISAND,IG,ILG,IL1,IL2,JL) CALL SNOADD(ALBSCS,TSNOCS,RHOSCS,ZSNOCS, 1 HCPSCS,HTCS,FCS,SPCCS,TSPCCS,RHOSNI,WSNOCS, 2 ILG,IL1,IL2,JL) CALL SNINFL(RPCCS,TRPCCS,ZSNOCS,TSNOCS,RHOSCS,HCPSCS, 1 WSNOCS,HTCS,HMFN,PCPG,ROFN,FCS,ILG,IL1,IL2,JL) CALL GRINFL(1,THLQCS,THICCS,TBRWCS,BASFLW,TBASFL,RUNFCS, 1 TRNFCS,ZFAV,LZFAV,THLINV,QFG,WLSTCS, 2 FCS,EVPCSG,RPCCS,TRPCCS,TPNDCS,ZPNDCS, 3 DT,ZMAT,WMOVE,TMOVE,THLIQX,THICEX,TBARWX, 4 DELZX,ZBOTX,FDT,TFDT,PSIF,THLINF,GRKINF, 5 THLMAX,THTEST,ZRMDR,FDUMMY,TDUMMY,THLDUM, 6 THIDUM,TDUMW,TRMDR,ZF,FMAX,TUSED,RDUMMY, 7 ZERO,WEXCES,FDTBND,WADD,TADD,WADJ,TIMPND, 8 DZF,DTFLOW,THLNLZ,THLQLZ,DZDISP,WDISP,WABS, 9 THPOR,THLRET,THLMIN,BI,PSISAT,GRKSCS, A THLRAT,THFC,DELZW,ZBOTW,XDRAIN,DELZ,ISAND, B IGRN,IGRD,IFILL,IZERO,LZF,NINF,IFIND,ITER, C NEND,ISIMP,IGDR, D IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL GRDRAN(1,THLQCS,THICCS,TBRWCS,FDUMMY,TDUMMY, 1 BASFLW,TBASFL,RUNFCS,TRNFCS, 2 QFG,WLSTCS,FCS,EVPCSG,RPCCS,ZPNDCS, 3 DT,WEXCES,THLMAX,THTEST,THPOR,THLRET,THLMIN, 4 BI,PSISAT,GRKSCS,THFC,DELZW,XDRAIN,ISAND, 5 IZERO,IGRN,IGRD,IGDR, 6 IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL TMCALC(TBARCS,THLQCS,THICCS,HCPCS,TPNDCS,ZPNDCS, 1 TSNOCS,ZSNOCS,ALBSCS,RHOSCS,HCPSCS,TBASCS, 2 OVRFLW,TOVRFL,RUNFCS,TRNFCS,HMFG,HTC,HTCS, 3 WTRS,WTRG,FCS,TBRWCS,GZROCS,G12CS, 4 G23CS,GGEO,TA,WSNOCS,TCTOPC,TCBOTC,GFLXCS, 5 ZPLMCS,THPOR,THLMIN,HCPS,DELZW,DELZZ,DELZ, 6 ISAND,IWF,IG,ILG,IL1,IL2,JL,N) CALL CHKWAT(1,PCPR,EVPICS,RUNFCS,WLSTCS,RAICNS,SNOCNS, 1 RACS,SNCS,ZPNDCS,ZPOND,THLQCS,THICCS, 2 THLIQC,THICEC,ZSNOCS,RHOSCS,XSNOCS,SNO, 3 WSNOCS,WSNOW,FCS,FGS,FCS,BAL,THPOR,THLMIN, 4 DELZW,ISAND,IG,ILG,IL1,IL2,JL,N ) CALL SNOALBW(ALBSCS,RHOSCS,ZSNOCS,HCPSCS, 1 TSNOCS,FCS,SPCCS,RALB,WSNOCS,RHOMAX, 2 ISAND,ILG,IG,IL1,IL2,JL) ENDIF C C * CALCULATIONS FOR SNOW-COVERED GROUND. C IF(NLANDGS.GT.0) THEN CALL TWCALC(TBARGS,THLQGS,THICGS,HCPGS,TBRWGS,HMFG,HTC, 1 FGS,ZERO,THPOR,THLMIN,HCPS,DELZW,DELZZ,ISAND, 2 IG,ILG,IL1,IL2,JL) CALL SNOVAP(RHOSGS,ZSNOGS,HCPSGS,TSNOGS,EVAPGS,QFN,QFG, 1 HTCS,WLSTGS,TRNFGS,RUNFGS,TOVRFL,OVRFLW, 2 FGS,RPCGS,SPCGS,RHOSNI,WSNOGS,ILG,IL1,IL2,JL) CALL TFREEZ(ZPNDGS,TPNDGS,ZSNOGS,TSNOGS,ALBSGS, 1 RHOSGS,HCPSGS,GZROGS,HMFG,HTCS,HTC, 2 WTRS,WTRG,FGS,ZERO,WSNOGS,TA,TBARGS, 3 ISAND,IG,ILG,IL1,IL2,JL) CALL TMELT(ZSNOGS,TSNOGS,QMELTG,RPCGS,TRPCGS, 1 GZROGS,RALB,HMFN,HTCS,HTC,FGS,HCPSGS, 2 RHOSGS,WSNOGS,ISAND,IG,ILG,IL1,IL2,JL) CALL SNOADD(ALBSGS,TSNOGS,RHOSGS,ZSNOGS, 1 HCPSGS,HTCS,FGS,SPCGS,TSPCGS,RHOSNI,WSNOGS, 2 ILG,IL1,IL2,JL) CALL SNINFL(RPCGS,TRPCGS,ZSNOGS,TSNOGS,RHOSGS,HCPSGS, 1 WSNOGS,HTCS,HMFN,PCPG,ROFN,FGS,ILG,IL1,IL2,JL) IF(NLANDI.NE.0) THEN CALL ICEBAL(TBARGS,TPNDGS,ZPNDGS,TSNOGS,RHOSGS,ZSNOGS, 1 HCPSGS,ALBSGS,HMFG,HTCS,HTC,WTRS,WTRG,GFLXGS, 2 RUNFGS,TRNFGS,OVRFLW,TOVRFL,ZPLMGS,GGEO, 3 FGS,EVAPGS,RPCGS,TRPCGS,GZROGS,G12GS,G23GS, 4 HCPGS,QMELTG,WSNOGS,ZMAT,TMOVE,WMOVE,ZRMDR, 5 TADD,ZMOVE,TBOT,DELZ,ISAND,ICONT, 6 IWF,IG,IGP1,IGP2,ILG,IL1,IL2,JL,N ) ENDIF CALL GRINFL(2,THLQGS,THICGS,TBRWGS,BASFLW,TBASFL,RUNFGS, 1 TRNFGS,ZFAV,LZFAV,THLINV,QFG,WLSTGS, 2 FGS,EVAPGS,RPCGS,TRPCGS,TPNDGS,ZPNDGS, 3 DT,ZMAT,WMOVE,TMOVE,THLIQX,THICEX,TBARWX, 4 DELZX,ZBOTX,FDT,TFDT,PSIF,THLINF,GRKINF, 5 THLMAX,THTEST,ZRMDR,FDUMMY,TDUMMY,THLDUM, 6 THIDUM,TDUMW,TRMDR,ZF,FMAX,TUSED,RDUMMY, 7 ZERO,WEXCES,FDTBND,WADD,TADD,WADJ,TIMPND, 8 DZF,DTFLOW,THLNLZ,THLQLZ,DZDISP,WDISP,WABS, 9 THPOR,THLRET,THLMIN,BI,PSISAT,GRKSGS, A THLRAT,THFC,DELZW,ZBOTW,XDRAIN,DELZ,ISAND, B IGRN,IGRD,IFILL,IZERO,LZF,NINF,IFIND,ITER, C NEND,ISIMP,IGDR, D IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL GRDRAN(2,THLQGS,THICGS,TBRWGS,FDUMMY,TDUMMY, 1 BASFLW,TBASFL,RUNFGS,TRNFGS, 2 QFG,WLSTGS,FGS,EVAPGS,RPCGS,ZPNDGS, 3 DT,WEXCES,THLMAX,THTEST,THPOR,THLRET,THLMIN, 4 BI,PSISAT,GRKSGS,THFC,DELZW,XDRAIN,ISAND, 5 IZERO,IGRN,IGRD,IGDR, 6 IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL TMCALC(TBARGS,THLQGS,THICGS,HCPGS,TPNDGS,ZPNDGS, 1 TSNOGS,ZSNOGS,ALBSGS,RHOSGS,HCPSGS,TBASGS, 2 OVRFLW,TOVRFL,RUNFGS,TRNFGS,HMFG,HTC,HTCS, 3 WTRS,WTRG,FGS,TBRWGS,GZROGS,G12GS, 4 G23GS,GGEO,TA,WSNOGS,TCTOPG,TCBOTG,GFLXGS, 5 ZPLMGS,THPOR,THLMIN,HCPS,DELZW,DELZZ,DELZ, 6 ISAND,IWF,IG,ILG,IL1,IL2,JL,N) CALL CHKWAT(2,PCPR,EVPIGS,RUNFGS,WLSTGS,RAICNS,SNOCNS, 1 RACS,SNCS,ZPNDGS,ZPOND,THLQGS,THICGS, 2 THLIQG,THICEG,ZSNOGS,RHOSGS,XSNOGS,SNO, 3 WSNOGS,WSNOW,FCS,FGS,FGS,BAL,THPOR,THLMIN, 4 DELZW,ISAND,IG,ILG,IL1,IL2,JL,N ) CALL SNOALBW(ALBSGS,RHOSGS,ZSNOGS,HCPSGS, 1 TSNOGS,FGS,SPCGS,RALB,WSNOGS,RHOMAX, 2 ISAND,ILG,IG,IL1,IL2,JL) ENDIF C C * CALCULATIONS FOR CANOPY OVER BARE GROUND. C IF(NLANDC.GT.0) THEN CALL CANVAP(EVAPC,SUBLC,RAICAN,SNOCAN,TCANO,THLQCO, 1 TBARC,ZSNOWC,WLOSTC,CHCAP,QFCF,QFCL,QFN,QFC, 2 HTCC,HTCS,HTC,FC,CMASSC,TSNOWC,HCPSC,RHOSC, 3 FROOT,THPOR,THLMIN,DELZW,EVLOST,RLOST,IROOT, 4 IG,ILG,IL1,IL2,JL,N ) CALL CANADD(1,RPCC,TRPCC,SPCC,TSPCC,RAICAN,SNOCAN, 1 TCANO,CHCAP,HTCC,ROFC,ROVG,PCPN,PCPG, 2 FC,FSVF,CWLCAP,CWFCAP,CMASSC,RHOSNI, 3 TSFSAV(1,3),RADD,SADD,ILG,IL1,IL2,JL) CALL CWCALC(TCANO,RAICAN,SNOCAN,RDUMMY,RDUMMY,CHCAP, 1 HMFC,HTCC,FC,CMASSC,ILG,IL1,IL2,JL) CALL SUBCAN(1,RPCC,TRPCC,SPCC,TSPCC,RHOSNI,EVAPCG, 1 QFN,QFG,PCPN,PCPG,FC,ILG,IL1,IL2,JL) CALL TWCALC(TBARC,THLQCO,THICCO,HCPCO,TBARWC,HMFG,HTC, 1 FC,EVAPCG,THPOR,THLMIN,HCPS,DELZW,DELZZ, 2 ISAND,IG,ILG,IL1,IL2,JL) CALL SNOVAP(RHOSC,ZSNOWC,HCPSC,TSNOWC,EVAPCG,QFN,QFG, 1 HTCS,WLOSTC,TRUNFC,RUNFC,TOVRFL,OVRFLW, 2 FC,RPCC,SPCC,RHOSNI,ZERO,ILG,IL1,IL2,JL) CALL TFREEZ(ZPONDC,TPONDC,ZSNOWC,TSNOWC,ALBSC, 1 RHOSC,HCPSC,GZEROC,HMFG,HTCS,HTC, 2 WTRS,WTRG,FC,QFREZC,ZERO,TA,TBARC, 3 ISAND,IG,ILG,IL1,IL2,JL) CALL SNOADD(ALBSC,TSNOWC,RHOSC,ZSNOWC, 1 HCPSC,HTCS,FC,SPCC,TSPCC,RHOSNI,ZERO, 2 ILG,IL1,IL2,JL) CALL GRINFL(3,THLQCO,THICCO,TBARWC,BASFLW,TBASFL,RUNFC, 1 TRUNFC,ZFAV,LZFAV,THLINV,QFG,WLOSTC, 2 FC,EVAPCG,RPCC,TRPCC,TPONDC,ZPONDC, 3 DT,ZMAT,WMOVE,TMOVE,THLIQX,THICEX,TBARWX, 4 DELZX,ZBOTX,FDT,TFDT,PSIF,THLINF,GRKINF, 5 THLMAX,THTEST,ZRMDR,FDUMMY,TDUMMY,THLDUM, 6 THIDUM,TDUMW,TRMDR,ZF,FMAX,TUSED,RDUMMY, 7 ZERO,WEXCES,FDTBND,WADD,TADD,WADJ,TIMPND, 8 DZF,DTFLOW,THLNLZ,THLQLZ,DZDISP,WDISP,WABS, 9 THPOR,THLRET,THLMIN,BI,PSISAT,GRKSC, A THLRAT,THFC,DELZW,ZBOTW,XDRAIN,DELZ,ISAND, B IGRN,IGRD,IFILL,IZERO,LZF,NINF,IFIND,ITER, C NEND,ISIMP,IGDR, D IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL GRDRAN(3,THLQCO,THICCO,TBARWC,FDUMMY,TDUMMY, 1 BASFLW,TBASFL,RUNFC,TRUNFC, 2 QFG,WLOSTC,FC,EVAPCG,RPCC,ZPONDC, 3 DT,WEXCES,THLMAX,THTEST,THPOR,THLRET,THLMIN, 4 BI,PSISAT,GRKSC,THFC,DELZW,XDRAIN,ISAND, 5 IZERO,IGRN,IGRD,IGDR, 6 IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL TMCALC(TBARC,THLQCO,THICCO,HCPCO,TPONDC,ZPONDC, 1 TSNOWC,ZSNOWC,ALBSC,RHOSC,HCPSC,TBASC, 2 OVRFLW,TOVRFL,RUNFC,TRUNFC,HMFG,HTC,HTCS, 3 WTRS,WTRG,FC,TBARWC,GZEROC,G12C, 4 G23C,GGEO,TA,ZERO,TCTOPC,TCBOTC,GFLXC, 5 ZPLIMC,THPOR,THLMIN,HCPS,DELZW,DELZZ,DELZ, 6 ISAND,IWF,IG,ILG,IL1,IL2,JL,N) CALL CHKWAT(3,PCPR,EVPIC,RUNFC,WLOSTC,RAICAN,SNOCAN, 1 RAC,SNC,ZPONDC,ZPOND,THLQCO,THICCO, 2 THLIQC,THICEC,ZSNOWC,RHOSC,XSNOWC,SNO, 3 ZERO,ZERO,FCS,FGS,FC,BAL,THPOR,THLMIN, 4 DELZW,ISAND,IG,ILG,IL1,IL2,JL,N ) C ENDIF C C * CALCULATIONS FOR BARE GROUND. C IF(NLANDG.GT.0) THEN CALL TWCALC(TBARG,THLQGO,THICGO,HCPGO,TBARWG,HMFG,HTC, 1 FG,EVAPG,THPOR,THLMIN,HCPS,DELZW,DELZZ, 2 ISAND,IG,ILG,IL1,IL2,JL) CALL SNOVAP(RHOSG,ZSNOWG,HCPSG,TSNOWG,EVAPG,QFN,QFG, 1 HTCS,WLOSTG,TRUNFG,RUNFG,TOVRFL,OVRFLW, 2 FG,RPCG,SPCG,RHOSNI,ZERO,ILG,IL1,IL2,JL) CALL TFREEZ(ZPONDG,TPONDG,ZSNOWG,TSNOWG,ALBSG, 1 RHOSG,HCPSG,GZEROG,HMFG,HTCS,HTC, 2 WTRS,WTRG,FG,QFREZG,ZERO,TA,TBARG, 3 ISAND,IG,ILG,IL1,IL2,JL) CALL SNOADD(ALBSG,TSNOWG,RHOSG,ZSNOWG, 1 HCPSG,HTCS,FG,SPCG,TSPCG,RHOSNI,ZERO, 2 ILG,IL1,IL2,JL) IF(NLANDI.NE.0) THEN CALL ICEBAL(TBARG,TPONDG,ZPONDG,TSNOWG,RHOSG,ZSNOWG, 1 HCPSG,ALBSG,HMFG,HTCS,HTC,WTRS,WTRG,GFLXG, 2 RUNFG,TRUNFG,OVRFLW,TOVRFL,ZPLIMG,GGEO, 3 FG,EVAPG,RPCG,TRPCG,GZEROG,G12G,G23G, 4 HCPGO,QFREZG,ZERO,ZMAT,TMOVE,WMOVE,ZRMDR, 5 TADD,ZMOVE,TBOT,DELZ,ISAND,ICONT, 6 IWF,IG,IGP1,IGP2,ILG,IL1,IL2,JL,N ) ENDIF CALL GRINFL(4,THLQGO,THICGO,TBARWG,BASFLW,TBASFL,RUNFG, 1 TRUNFG,ZFAV,LZFAV,THLINV,QFG,WLOSTG, 2 FG,EVAPG,RPCG,TRPCG,TPONDG,ZPONDG, 3 DT,ZMAT,WMOVE,TMOVE,THLIQX,THICEX,TBARWX, 4 DELZX,ZBOTX,FDT,TFDT,PSIF,THLINF,GRKINF, 5 THLMAX,THTEST,ZRMDR,FDUMMY,TDUMMY,THLDUM, 6 THIDUM,TDUMW,TRMDR,ZF,FMAX,TUSED,RDUMMY, 7 ZERO,WEXCES,FDTBND,WADD,TADD,WADJ,TIMPND, 8 DZF,DTFLOW,THLNLZ,THLQLZ,DZDISP,WDISP,WABS, 9 THPOR,THLRET,THLMIN,BI,PSISAT,GRKSG, A THLRAT,THFC,DELZW,ZBOTW,XDRAIN,DELZ,ISAND, B IGRN,IGRD,IFILL,IZERO,LZF,NINF,IFIND,ITER, C NEND,ISIMP,IGDR, D IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL GRDRAN(4,THLQGO,THICGO,TBARWG,FDUMMY,TDUMMY, 1 BASFLW,TBASFL,RUNFG,TRUNFG, 2 QFG,WLOSTG,FG,EVAPG,RPCG,ZPONDG, 3 DT,WEXCES,THLMAX,THTEST,THPOR,THLRET,THLMIN, 4 BI,PSISAT,GRKSG,THFC,DELZW,XDRAIN,ISAND, 5 IZERO,IGRN,IGRD,IGDR, 6 IG,IGP1,IGP2,ILG,IL1,IL2,JL,N) CALL TMCALC(TBARG,THLQGO,THICGO,HCPGO,TPONDG,ZPONDG, 1 TSNOWG,ZSNOWG,ALBSG,RHOSG,HCPSG,TBASG, 2 OVRFLW,TOVRFL,RUNFG,TRUNFG,HMFG,HTC,HTCS, 3 WTRS,WTRG,FG,TBARWG,GZEROG,G12G, 4 G23G,GGEO,TA,ZERO,TCTOPG,TCBOTG,GFLXG, 5 ZPLIMG,THPOR,THLMIN,HCPS,DELZW,DELZZ,DELZ, 6 ISAND,IWF,IG,ILG,IL1,IL2,JL,N) CALL CHKWAT(4,PCPR,EVPIG,RUNFG,WLOSTG,RAICAN,SNOCAN, 1 RAC,SNC,ZPONDG,ZPOND,THLQGO,THICGO, 2 THLIQG,THICEG,ZSNOWG,RHOSG,XSNOWG,SNO, 3 ZERO,ZERO,FCS,FGS,FG,BAL,THPOR,THLMIN, 4 DELZW,ISAND,IG,ILG,IL1,IL2,JL,N ) C ENDIF C C * AVERAGE RUNOFF AND PROGNOSTIC VARIABLES OVER FOUR GRID CELL C * SUBAREAS. C JPTBAD=0 KPTBAD=0 LPTBAD=0 DO 600 I=IL1,IL2 TBASE (I)=FCS(I)*(TBASCS(I)+TFREZ) + 1 FGS(I)*(TBASGS(I)+TFREZ) + 2 FC (I)*(TBASC (I)+TFREZ) + 3 FG (I)*(TBASG (I)+TFREZ) RUNOFF(I)=FCS(I)*RUNFCS(I) + FGS(I)*RUNFGS(I) + 1 FC (I)*RUNFC (I) + FG (I)*RUNFG (I) IF(RUNOFF(I).GT.0.0) 1 TRUNOF(I)=(FCS(I)*RUNFCS(I)*TRNFCS(I) + 2 FGS(I)*RUNFGS(I)*TRNFGS(I) + 3 FC (I)*RUNFC (I)*TRUNFC(I) + 4 FG (I)*RUNFG (I)*TRUNFG(I))/RUNOFF(I) RUNOFF(I)=RUNOFF(I)*RHOW/DELT OVRFLW(I)=OVRFLW(I)*RHOW/DELT SUBFLW(I)=SUBFLW(I)*RHOW/DELT BASFLW(I)=BASFLW(I)*RHOW/DELT EVAP (I)=EVAP(I)-(FCS(I)*WLSTCS(I)+FGS(I)*WLSTGS(I)+ 1 FC(I)*WLOSTC(I)+FG(I)*WLOSTG(I))/DELT QFLUX(I)=-EVAP(I)/RHOAIR(I) IF((FC(I)+FCS(I)).GT.0.) THEN TCAN(I)=(FCS(I)*TCANS(I)*CHCAPS(I)+FC(I)*TCANO(I)* 1 CHCAP(I))/(FCS(I)*CHCAPS(I)+FC(I)*CHCAP(I)) RCAN(I)= FCS(I)*RAICNS(I) + FC (I)*RAICAN(I) IF(TCAN(I).LT.173.16 .OR. TCAN(I).GT.373.16) JPTBAD=I IF(RCAN(I).LT.0.0) RCAN(I)=0.0 IF(RCAN(I).LT.1.0E-5 .AND. RCAN(I).GT.0.0) THEN TOVRFL(I)=(TOVRFL(I)*OVRFLW(I)+TCAN(I)*RCAN(I)/ 1 DELT)/(OVRFLW(I)+RCAN(I)/DELT) OVRFLW(I)=OVRFLW(I)+RCAN(I)/DELT TRUNOF(I)=(TRUNOF(I)*RUNOFF(I)+TCAN(I)*RCAN(I)/ 1 DELT)/(RUNOFF(I)+RCAN(I)/DELT) RUNOFF(I)=RUNOFF(I)+RCAN(I)/DELT ROFC(I)=ROFC(I)+RCAN(I)/DELT ROVG(I)=ROVG(I)+RCAN(I)/DELT PCPG(I)=PCPG(I)+RCAN(I)/DELT HTCC(I)=HTCC(I)-TCAN(I)*SPHW*RCAN(I)/DELT RCAN(I)=0.0 ENDIF SNCAN (I)=FCS(I)*SNOCNS(I) + FC (I)*SNOCAN(I) IF(SNCAN(I).LT.0.0) SNCAN(I)=0.0 IF(SNCAN(I).LT.1.0E-5 .AND. SNCAN(I).GT.0.0) THEN TOVRFL(I)=(TOVRFL(I)*OVRFLW(I)+TCAN(I)*SNCAN(I)/ 1 DELT)/(OVRFLW(I)+SNCAN(I)/DELT) OVRFLW(I)=OVRFLW(I)+SNCAN(I)/DELT TRUNOF(I)=(TRUNOF(I)*RUNOFF(I)+TCAN(I)*SNCAN(I)/ 1 DELT)/(RUNOFF(I)+SNCAN(I)/DELT) RUNOFF(I)=RUNOFF(I)+SNCAN(I)/DELT ROFC(I)=ROFC(I)+SNCAN(I)/DELT ROVG(I)=ROVG(I)+SNCAN(I)/DELT PCPG(I)=PCPG(I)+SNCAN(I)/DELT HTCC(I)=HTCC(I)-TCAN(I)*SPHICE*SNCAN(I)/DELT SNCAN(I)=0.0 ENDIF ELSE TCAN(I)=0.0 ENDIF IF(ZPNDCS(I).GT.0. .OR. ZPNDGS(I).GT.0. .OR. 1 ZPONDC(I).GT.0. .OR. ZPONDG(I).GT.0.) THEN ZPOND(I)=(FCS(I)*ZPNDCS(I)+FGS(I)*ZPNDGS(I)+ 1 FC (I)*ZPONDC(I)+FG (I)*ZPONDG(I)) TPOND(I)=(FCS(I)*(TPNDCS(I)+TFREZ)*ZPNDCS(I)+ 1 FGS(I)*(TPNDGS(I)+TFREZ)*ZPNDGS(I)+ 2 FC (I)*(TPONDC(I)+TFREZ)*ZPONDC(I)+ 3 FG (I)*(TPONDG(I)+TFREZ)*ZPONDG(I))/ 4 ZPOND(I) IF(ZPOND(I).LT.0.0) ZPOND(I)=0.0 IF(ZPOND(I).LT.1.0E-8 .AND. ZPOND(I).GT.0.0) THEN TOVRFL(I)=(TOVRFL(I)*OVRFLW(I)+TPOND(I)*RHOW* 1 ZPOND(I)/DELT)/(OVRFLW(I)+RHOW*ZPOND(I)/DELT) OVRFLW(I)=OVRFLW(I)+RHOW*ZPOND(I)/DELT TRUNOF(I)=(TRUNOF(I)*RUNOFF(I)+TPOND(I)*RHOW* 1 ZPOND(I)/DELT)/(RUNOFF(I)+RHOW*ZPOND(I)/DELT) RUNOFF(I)=RUNOFF(I)+RHOW*ZPOND(I)/DELT HTC(I,1)=HTC(I,1)-TPOND(I)*HCPW*ZPOND(I)/DELT TPOND(I)=TFREZ ZPOND(I)=0.0 ENDIF ELSE ZPOND(I)=0.0 TPOND(I)=TFREZ ENDIF 600 CONTINUE C DO 650 I=IL1,IL2 IF(ZSNOCS(I).GT.0. .OR. ZSNOGS(I).GT.0. .OR. 1 ZSNOWC(I).GT.0. .OR. ZSNOWG(I).GT.0.) THEN IF(ZSNOCS(I).GT.0. .OR. ZSNOGS(I).GT.0.) THEN ALBSNO(I)=(FCS(I)*ALBSCS(I)*XSNOCS(I)+ 1 FGS(I)*ALBSGS(I)*XSNOGS(I))/ 2 (FCS(I)*XSNOCS(I)+FGS(I)*XSNOGS(I)) ELSE ALBSNO(I)=(FC (I)*ALBSC(I)*XSNOWC(I) + 1 FG (I)*ALBSG(I)*XSNOWG(I))/ 2 (FC (I)*XSNOWC(I)+FG (I)*XSNOWG(I)) ENDIF TSNOW(I)=(FCS(I)*(TSNOCS(I)+TFREZ)*HCPSCS(I)* 1 ZSNOCS(I)*XSNOCS(I) + 2 FGS(I)*(TSNOGS(I)+TFREZ)*HCPSGS(I)* 3 ZSNOGS(I)*XSNOGS(I) + 4 FC (I)*(TSNOWC(I)+TFREZ)*HCPSC(I)* 5 ZSNOWC(I)*XSNOWC(I) + 6 FG (I)*(TSNOWG(I)+TFREZ)*HCPSG(I)* 7 ZSNOWG(I)*XSNOWG(I))/ 8 (FCS(I)*HCPSCS(I)*ZSNOCS(I)*XSNOCS(I) + 9 FGS(I)*HCPSGS(I)*ZSNOGS(I)*XSNOGS(I) + A FC (I)*HCPSC(I)*ZSNOWC(I)*XSNOWC(I) + B FG (I)*HCPSG(I)*ZSNOWG(I)*XSNOWG(I)) RHOSNO(I)=(FCS(I)*RHOSCS(I)*ZSNOCS(I)*XSNOCS(I) + 1 FGS(I)*RHOSGS(I)*ZSNOGS(I)*XSNOGS(I) + 2 FC (I)*RHOSC(I)*ZSNOWC(I)*XSNOWC(I) + 3 FG (I)*RHOSG(I)*ZSNOWG(I)*XSNOWG(I))/ 4 (FCS(I)*ZSNOCS(I)*XSNOCS(I) + 5 FGS(I)*ZSNOGS(I)*XSNOGS(I) + 6 FC (I)*ZSNOWC(I)*XSNOWC(I) + 7 FG (I)*ZSNOWG(I)*XSNOWG(I)) ZSNOW(I)=FCS(I)*ZSNOCS(I) + FGS(I)*ZSNOGS(I) + 1 FC (I)*ZSNOWC(I) + FG (I)*ZSNOWG(I) WSNOW(I)=FCS(I)*WSNOCS(I) + FGS(I)*WSNOGS(I) SNO(I)=ZSNOW(I)*RHOSNO(I) IF(SNO(I).LT.0.0) SNO(I)=0.0 C C * LIMIT SNOW MASS TO A MAXIMUM OF 10 METRES TO AVOID C * SNOW PILING UP AT EDGES OF GLACIERS AT HIGH ELEVATIONS. C * THIS IS TARGETTED AS OVERLAND RUNOFF. C IF(ZSNOW(I).GT.10.0) THEN SNOROF=(ZSNOW(I)-10.0)*RHOSNO(I) WSNROF=WSNOW(I)*SNOROF/SNO(I) TOVRFL(I)=(TOVRFL(I)*OVRFLW(I)+TSNOW(I)*(SNOROF+ 1 WSNROF)/DELT)/(OVRFLW(I)+(SNOROF+WSNROF)/ 2 DELT) OVRFLW(I)=OVRFLW(I)+(SNOROF+WSNROF)/DELT TRUNOF(I)=(TRUNOF(I)*RUNOFF(I)+TSNOW(I)*(SNOROF+ 1 WSNROF)/DELT)/(RUNOFF(I)+(SNOROF+WSNROF)/ 2 DELT) RUNOFF(I)=RUNOFF(I)+(SNOROF+WSNROF)/DELT ROFN(I)=ROFN(I)+(SNOROF+WSNROF)/DELT PCPG(I)=PCPG(I)+(SNOROF+WSNROF)/DELT HTCS(I)=HTCS(I)-TSNOW(I)*(SPHICE*SNOROF+SPHW* 1 WSNROF)/DELT SNO(I)=SNO(I)-SNOROF WSNOW(I)=WSNOW(I)-WSNROF ZSNOW(I)=10.0 ENDIF IF(SNO(I).LT.1.0E-2 .AND. SNO(I).GT.0.0) THEN TOVRFL(I)=(TOVRFL(I)*OVRFLW(I)+TSNOW(I)*(SNO(I)+ 1 WSNOW(I))/DELT)/(OVRFLW(I)+(SNO(I)+WSNOW(I))/ 2 DELT) OVRFLW(I)=OVRFLW(I)+(SNO(I)+WSNOW(I))/DELT TRUNOF(I)=(TRUNOF(I)*RUNOFF(I)+TSNOW(I)*(SNO(I)+ 1 WSNOW(I))/DELT)/(RUNOFF(I)+(SNO(I)+WSNOW(I))/ 2 DELT) RUNOFF(I)=RUNOFF(I)+(SNO(I)+WSNOW(I))/DELT ROFN(I)=ROFN(I)+(SNO(I)+WSNOW(I))/DELT PCPG(I)=PCPG(I)+(SNO(I)+WSNOW(I))/DELT HTCS(I)=HTCS(I)-TSNOW(I)*(SPHICE*SNO(I)+SPHW* 1 WSNOW(I))/DELT TSNOW(I)=0.0 RHOSNO(I)=0.0 SNO(I)=0.0 WSNOW(I)=0.0 ENDIF ELSE TSNOW(I)=0.0 RHOSNO(I)=0.0 SNO(I)=0.0 WSNOW(I)=0.0 ZSNOW(I)=0.0 ENDIF C IF(TSNOW(I).LT.0.0) KPTBAD=I IF((TSNOW(I)-TFREZ).GT.1.0E-3) LPTBAD=I 650 CONTINUE C IF(JPTBAD.NE.0) THEN WRITE(6,6625) JPTBAD,JL,TCAN(JPTBAD) 6625 FORMAT('0AT (I,J)= (',I3,',',I3,'), TCAN = ',F10.5) CALL XIT('CLASSW2',-2) ENDIF C IF(KPTBAD.NE.0) THEN WRITE(6,6626) KPTBAD,JL,TSNOW(KPTBAD) 6626 FORMAT('0AT (I,J)= (',I3,',',I3,'), TSNOW = ',F10.5) CALL XIT('CLASSW2',-3) ENDIF C IF(LPTBAD.NE.0) THEN WRITE(6,6626) LPTBAD,JL,TSNOW(LPTBAD) CALL XIT('CLASSW2',-4) ENDIF C IPTBAD=0 DO 700 J=1,IG DO 700 I=IL1,IL2 IF(IG.EQ.3. .AND. J.EQ.IG .AND. ISAND(I,1).GT.-4) THEN TBAR(I,J)=((FCS(I)*(TBARCS(I,J)+TFREZ)*HCPCS(I,J) + 1 FGS(I)*(TBARGS(I,J)+TFREZ)*HCPGS(I,J) + 2 FC (I)*(TBARC (I,J)+TFREZ)*HCPCO(I,J) + 3 FG (I)*(TBARG (I,J)+TFREZ)*HCPGO(I,J))* 4 DELZW(I,J)+TBASE(I)*HCPSND* 5 (DELZ(J)-DELZW(I,J)))/ 4 ((FCS(I)*HCPCS(I,J) + FGS(I)*HCPGS(I,J) + 5 FC (I)*HCPCO(I,J) + FG (I)*HCPGO(I,J))* 8 DELZW(I,J)+HCPSND*(DELZ(J)-DELZW(I,J))) ELSE TBAR(I,J)=(FCS(I)*(TBARCS(I,J)+TFREZ)*(DELZW(I,J)* 1 HCPCS(I,J)+(DELZ(J)-DELZW(I,J))*HCPSND)+ 2 FGS(I)*(TBARGS(I,J)+TFREZ)*(DELZW(I,J)* 3 HCPGS(I,J)+(DELZ(J)-DELZW(I,J))*HCPSND)+ 4 FC (I)*(TBARC (I,J)+TFREZ)*(DELZW(I,J)* 5 HCPCO(I,J)+(DELZ(J)-DELZW(I,J))*HCPSND)+ 6 FG (I)*(TBARG (I,J)+TFREZ)*(DELZW(I,J)* 7 HCPGO(I,J)+(DELZ(J)-DELZW(I,J))*HCPSND))/ 8 (FCS(I)*(DELZW(I,J)*HCPCS(I,J)+ 9 (DELZ(J)-DELZW(I,J))*HCPSND) + A FGS(I)*(DELZW(I,J)*HCPGS(I,J)+ B (DELZ(J)-DELZW(I,J))*HCPSND) + C FC (I)*(DELZW(I,J)*HCPCO(I,J)+ D (DELZ(J)-DELZW(I,J))*HCPSND) + E FG (I)*(DELZW(I,J)*HCPGO(I,J)+ F (DELZ(J)-DELZW(I,J))*HCPSND)) ENDIF THLIQ(I,J)=FCS(I)*THLQCS(I,J)+FGS(I)*THLQGS(I,J)+ 1 FC (I)*THLQCO(I,J)+FG (I)*THLQGO(I,J) THICE(I,J)=FCS(I)*THICCS(I,J)+FGS(I)*THICGS(I,J)+ 1 FC (I)*THICCO(I,J)+FG (I)*THICGO(I,J) GFLUX(I,J)=FCS(I)*GFLXCS(I,J)+FGS(I)*GFLXGS(I,J)+ 1 FC (I)*GFLXC (I,J)+FG (I)*GFLXG (I,J) C ipy test C IF(THLIQ(I,J).GT.THFC(I,J)) THEN C BASFLW(I)=BASFLW(I)+(THLIQ(I,J)-THFC(I,J))*DELZW(I,J)* C 1 RHOW/DELT C RUNOFF(I)=RUNOFF(I)+(THLIQ(I,J)-THFC(I,J))*DELZW(I,J)* C 1 RHOW/DELT C HTC(I,J)=HTC(I,J)-TBAR(I,J)*(THLIQ(I,J)-THFC(I,J))* C 1 HCPW*DELZW(I,J)/DELT C THLIQ(I,J)=THFC(I,J) C ENDIF IF(TBAR(I,1).LT.173.16 .OR. TBAR(I,1).GT.373.16) IPTBAD=I 700 CONTINUE C IF(IPTBAD.NE.0) THEN WRITE(6,6600) IPTBAD,JL,TBAR(IPTBAD,1) 6600 FORMAT('0AT (I,J)= (',I3,',',I3,'), TBAR(1) = ',F10.5) CALL XIT('CLASSW2',-1) ENDIF C CALL CGROW(GROWTH,TBAR,TA,FC,FCS,ILG,IG,IL1,IL2,JL) C RETURN END SUBROUTINE APREP(FC,FG,FCS,FGS,PAICAN,PAICNS,FSVF,FSVFS, 1 FRAINC,FSNOWC,FRAICS,FSNOCS,RAICAN,RAICNS,SNOCAN, 2 SNOCNS,DISP,DISPS,ZOMLNC,ZOMLCS,ZOELNC,ZOELCS, 3 ZOMLNG,ZOMLNS,ZOELNG,ZOELNS,CHCAP,CHCAPS,CMASSC, 4 CMASCS,CWLCAP,CWFCAP,CWLCPS,CWFCPS,RBCOEF, 5 ZPLIMC,ZPLIMG,ZPLMCS,ZPLMGS,HTCC,HTCS,HTC, + FROOT,FROOTS, 6 WTRC,WTRS,WTRG,CMAI,PAI,PAIS,AIL,FCAN,FCANS,PSIGND, 7 FCANMX,ZOLN,PAIMAX,PAIMIN,CWGTMX,ZRTMAX, 8 PAIDAT,HGTDAT,THLIQ,THICE,TBAR,RCAN,SNCAN, 9 TCAN,GROWTH,ZSNOW,TSNOW,FSNOW,RHOSNO,SNO,Z0ORO, A ZBLEND,ZPLMG0,ZPLMS0, B TA,RHOAIR,RADJ,DLON,RHOSNI,DELZ,DELZW,ZBOTW, C THPOR,THLMIN,PSISAT,BI,PSIWLT,HCPS,ISAND, D ILG,IL1,IL2,JL,IC,ICP1,IG,IDAY,IDISP,IZREF,IWF, E IPAI,IHGT,RMAT,H,HS,CWCPAV,GROWA,GROWN,GROWB, F RRESID,SRESID,FRTOT,FRTOTS, G FCANCMX,ICTEM,ICTEMMOD,RMATC, H AILC,PAIC,AILCG,L2MAX,NOL2PFTS, I AILCGS,FCANCS,FCANC,SLAIC ) C * AUG 04/15 - D.VERSEGHY. SPLIT FROOT INTO TWO ARRAYS, FOR CANOPY C * AREAS WITH AND WITHOUT SNOW. C * SEP 05/12 - J.MELTON. CHANGED IDAY C CONVERSION FROM FLOAT TO REAL, REINTEGRATED C CTEM C * NOV 15/11 - M.LAZARE. CTEM ADDED. CALCULATIONS ARE DIFFERENT C * IN SEVERAL AREAS, UNDER CONTROL OF C * "ICTEMMOD" SWITCH (ICTEMMOD=0 REVERTS C * BACK TO APREP4 FORMULATION). THIS C * INCLUDES NEW INPUT "PAIC". C * OCT 07/11 - V.FORTIN/D.VERSEGHY. MAKE THE LIMITING PONDING DEPTH C * CALCULATION OVER ORGANIC SOILS THE SAME C * AS OVER MINERAL SOILS (LOOP 175). C * DEC 23/09 - D.VERSEGHY. IN LIMITING PONDING DEPTH CALCULATIONS, C * IDENTIFY PEATLANDS WHERE ISAND(I,2)=-2 C * JAN 06/09 - D.VERSEGHY. REINTRODUCE CHECKS ON FRACTIONAL AREAS. C * MAR 25/08 - D.VERSEGHY. DISTINGUISH BETWEEN LEAF AREA INDEX C * AND PLANT AREA INDEX. C * JAN 17/08 - D.VERSEGHY. STREAMLINE SOME CALCULATIONS; REMOVE C * SUPERFLUOUS CHECKS ON FRACTIONAL AREAS. C * NOV 30/06 - E.CHAN/M.LAZARE/D.VERSEGHY. CHANGE RADJ TO REAL; C * ENSURE CONSISTENCY IN CALCULATION C * OF FRACTIONAL CANOPY AREAS. C * SEP 13/05 - D.VERSEGHY. REMOVE HARD CODING OF IG=3 IN 100, C * 450 LOOPS. C * MAR 14/05 - D.VERSEGHY. RENAME SCAN TO SNCAN (RESERVED NAME C * IN F90); TREAT SOIL FROZEN WATER AS ICE C * VOLUME RATHER THAN AS EQUIVALENT WATER. C * MAR 03/05 - Y.DELAGE. ADD CONTRIBUTION OF SUBGRID-SCALE C * OROGRAPHY TO ROUGHNESS LENGTH. C * JAN 12/05 - P.BARTLETT/D.VERSEGHY. DETERMINE SEPARATE CANOPY C * WATER INTERCEPTION CAPACITIES FOR C * RAIN AND SNOW, AND NEW FRACTIONAL C * CANOPY COVERAGE OF INTERCEPTED RAIN C * AND SNOW; DEFINE NEW PARAMETER RBCOEF C * FOR RBINV CALCULATION IN TSOLVC. C * NOV 03/04 - D.VERSEGHY. CHANGE RADJ AND DLON TO GATHERED C * VARIABLES AND REMOVE ILAND ARRAY; C * ADD "IMPLICIT NONE" COMMAND. C * JUL 05/04 - Y.DELAGE/D.VERSEGHY. PROTECT SENSITIVE CALCULATIONS C * AGAINST ROUNDOFF ERRORS. C * JUL 02/03 - D.VERSEGHY. RATIONALIZE ASSIGNMENT OF RESIDUAL C * CANOPY MOISTURE TO SOIL LAYERS. C * DEC 05/02 - Y.DELAGE/D.VERSEGHY. ADD PARTS OF CANOPY AIR MASS TO C * CANOPY MASS ONLY IF IDISP=0 OR IZREF=2. C * ALSO, REPLACE LOGARITHMIC AVERAGING OF C * ROUGHNESS HEIGHTS WITH BLENDING HEIGHT C * AVERAGING. C * JUL 31/02 - D.VERSEGHY. MOVE CALCULATION OF PSIGND AND FULL C * CALCULATION OF FROOT INTO THIS ROUTINE C * FROM TPREP; REMOVE CALCULATION OF RCMIN. C * SHORTENED CLASS3 COMMON BLOCK. C * JUL 23/02 - D.VERSEGHY. MOVE ADDITION OF AIR TO CANOPY MASS C * INTO THIS ROUTINE; SHORTENED CLASS4 C * COMMON BLOCK. C * MAR 18/02 - D.VERSEGHY. MOVE CALCULATION OF SOIL PROPERTIES INTO C * ROUTINE "CLASSB"; ALLOW FOR ASSIGNMENT C * OF SPECIFIED TIME-VARYING VEGETATION C * HEIGHT AND LEAF AREA INDEX. C * SEP 19/00 - D.VERSEGHY. ADD CALCULATION OF VEGETATION-DEPENDENT C * COEFFICIENTS FOR DETERMINATION OF STOMATAL C * RESISTANCE. C * APR 12/00 - D.VERSEGHY. RCMIN NOW VARIES WITH VEGETATION TYPE: C * PASS IN BACKGROUND ARRAY "RCMINX". C * DEC 16/99 - A.WU/D.VERSEGHY. ADD CALCULATION OF NEW LEAF DIMENSION C * PARAMETER FOR REVISED CANOPY TURBULENT C * TRANSFER FORMULATION. C * NOV 16/98 - M.LAZARE. "DLON" NOW PASSED IN AND USED DIRECTLY C * (INSTEAD OF INFERRING FROM "LONSL" AND C * "ILSL" WHICH USED TO BE PASSED) TO CALCULATE C * GROWTH INDEX. THIS IS DONE TO MAKE THE PHYSICS C * PLUG COMPATIBLE FOR USE WITH THE RCM WHICH C * DOES NOT HAVE EQUALLY-SPACED LONGITUDES. C * JUN 20/97 - D.VERSEGHY. CLASS - VERSION 2.7. C * MODIFICATIONS TO ALLOW FOR VARIABLE C * SOIL PERMEABLE DEPTH. C * OCT 11/96 - D.VERSEGHY. CLASS - VERSION 2.6. C * BUG FIX: TO AVOID ROUND-OFF ERRORS, C * SET CANOPY COVER EQUAL TO 1 IF THE C * CALCULATED SUM OF FC AND FCS IS C * VERY CLOSE TO 1. C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5. C * COMPLETION OF ENERGY BALANCE C * DIAGNOSTICS. C * ALSO CORRECT BUG IN CALCULATION OF C * DEGLON, AND USE IDISP TO DETERMINE C * METHOD OF CALCULATING DISP AND DISPS. C * AUG 30/95 - D.VERSEGHY. CLASS - VERSION 2.4. C * VARIABLE SURFACE DETENTION CAPACITY C * IMPLEMENTED. C * AUG 16/95 - D.VERSEGHY. THREE NEW ARRAYS TO COMPLETE WATER C * BALANCE DIAGNOSTICS. C * NOV 22/94 - D.VERSEGHY. CLASS - VERSION 2.3. C * RATIONALIZE CALCULATION OF RCMIN. C * NOV 12/94 - D.VERSEGHY. FIX BUGS IN SENESCING LIMB OF CROP C * GROWTH INDEX AND IN CANOPY MASS C * CALCULATION. C * MAY 06/93 - M.LAZARE/D.VERSEGHY. CLASS - VERSION 2.1. C * USE NEW "CANEXT" CANOPY C * EXTINCTION ARRAY TO DEFINE C * SKY-VIEW FACTORS. ALSO, CORRECT C * MINOR BUG WHERE HAD "IF(IN.LE.9)..." C * INSTEAD OF "IF(IN.GT.9)...". C * DEC 12/92 - M.LAZARE. MODIFIED FOR MULTIPLE LATITUDES. C * OCT 24/92 - D.VERSEGHY/M.LAZARE. REVISED AND VECTORIZED CODE C * FOR MODEL VERSION GCM7. C * AUG 12/91 - D.VERSEGHY. CALCULATION OF LAND SURFACE CANOPY C * PARAMETERS. C IMPLICIT NONE C C * INTEGER CONSTANTS. C INTEGER ILG,IL1,IL2,JL,IC,ICP1,IG,IDAY,IDISP,IZREF,IWF, 1 IPAI,IHGT,I,J,K,IN,NL C C * OUTPUT ARRAYS USED ELSEWHERE IN CLASS. C REAL FC (ILG), FG (ILG), FCS (ILG), FGS (ILG), 1 PAICAN(ILG), PAICNS(ILG), FSVF (ILG), FSVFS (ILG), 2 FRAINC(ILG), FSNOWC(ILG), FRAICS(ILG), FSNOCS(ILG), 3 RAICAN(ILG), RAICNS(ILG), SNOCAN(ILG), SNOCNS(ILG), 4 DISP (ILG), DISPS (ILG), 5 ZOMLNC(ILG), ZOMLCS(ILG), ZOELNC(ILG), ZOELCS(ILG), 6 ZOMLNG(ILG), ZOMLNS(ILG), ZOELNG(ILG), ZOELNS(ILG), 7 RBCOEF(ILG), CHCAP (ILG), CHCAPS(ILG), 8 CMASSC(ILG), CMASCS(ILG), CWLCAP(ILG), CWFCAP(ILG), 9 CWLCPS(ILG), CWFCPS(ILG), ZPLIMC(ILG), ZPLIMG(ILG), A ZPLMCS(ILG), ZPLMGS(ILG), HTCC (ILG), HTCS (ILG), B WTRC (ILG), WTRS (ILG), WTRG (ILG), CMAI (ILG) C REAL FROOT (ILG,IG), FROOTS(ILG,IG), HTC (ILG,IG) C C * OUTPUT ARRAYS ONLY USED ELSEWHERE IN CLASSA. C REAL PAI (ILG,IC), PAIS (ILG,IC), AIL (ILG,IC), 1 FCAN (ILG,IC), FCANS (ILG,IC), PSIGND(ILG) C C * INPUT ARRAYS. C REAL FCANMX(ILG,ICP1), ZOLN (ILG,ICP1), 1 PAIMAX(ILG,IC), PAIMIN(ILG,IC), CWGTMX(ILG,IC), 2 ZRTMAX(ILG,IC), PAIDAT(ILG,IC), HGTDAT(ILG,IC), 3 THLIQ (ILG,IG), THICE (ILG,IG), TBAR (ILG,IG) C REAL RCAN (ILG), SNCAN (ILG), TCAN (ILG), 1 GROWTH(ILG), ZSNOW (ILG), TSNOW (ILG), 2 FSNOW (ILG), RHOSNO(ILG), SNO (ILG), 3 TA (ILG), RHOAIR(ILG), DLON (ILG), 4 Z0ORO (ILG), ZBLEND(ILG), RHOSNI(ILG), 5 ZPLMG0(ILG), ZPLMS0(ILG), RADJ (ILG) C C * SOIL PROPERTY ARRAYS. C REAL DELZW(ILG,IG), ZBOTW(ILG,IG), THPOR(ILG,IG), 1 THLMIN(ILG,IG), PSISAT(ILG,IG), BI (ILG,IG), 2 PSIWLT(ILG,IG), HCPS (ILG,IG) C INTEGER ISAND (ILG,IG) C C * OTHER DATA ARRAYS WITH NON-VARYING VALUES. C REAL GROWYR(18,4,2), DELZ (IG), ZORAT (4), 1 CANEXT(4), XLEAF (4) C C * WORK ARRAYS NOT USED ELSEWHERE IN CLASSA. C REAL RMAT (ILG,IC,IG),H (ILG,IC), HS (ILG,IC), 1 CWCPAV(ILG), GROWA (ILG), GROWN (ILG), 2 GROWB (ILG), RRESID(ILG), SRESID(ILG), 3 FRTOT (ILG), FRTOTS(ILG) C C * TEMPORARY VARIABLES. C REAL DAY,GROWG,FSUM,SNOI,ZSNADD,THSUM,THICEI,THLIQI,ZROOT, 1 ZROOTG,FCOEFF,PSII,LZ0ORO,THR_LAI,PSIRAT C C * CTEM-RELATED FIELDS. C REAL AILC (ILG,IC), PAIC (ILG,IC), 1 AILCG(ILG,ICTEM), AILCGS (ILG,ICTEM), 2 RMATC(ILG,IC,IG), FCANCMX(ILG,ICTEM), 3 FCANC(ILG,ICTEM), FCANCS (ILG,ICTEM), 4 SLAIC(ILG,IC) C C * AILCG - GREEN LAI FOR USE WITH PHTSYN SUBROUTINE C * AILCGS - GREEN LAI FOR CANOPY OVER SNOW SUB-AREA C * NOL2PFTS - NUMBER OF LEVEL 2 CTEM PFTs C * FCANC - FRACTION OF CANOPY OVER GROUND FOR CTEM's 9 PFTs C * FCANCS - FRACTION OF CANOPY OVER SNOW FOR CTEM's 9 PFTs C * SEE BIO2STR SUBROUTINE FOR EXPLANATION OF OTHER CTEM VARIABLES C * INTERNAL WORK FIELD. C REAL SFCANCMX(ILG,IC) C INTEGER ICTEM, M, N, K1, K2, L2MAX, NOL2PFTS(IC), ICTEMMOD C C * COMMON BLOCK PARAMETERS. C REAL DELT,TFREZ,TCW,TCICE,TCSAND,TCCLAY,TCOM,TCDRYS,RHOSOL,RHOOM, 1 HCPW,HCPICE,HCPSOL,HCPOM,HCPSND,HCPCLY,SPHW,SPHICE,SPHVEG, 2 SPHAIR,RHOW,RHOICE,TCGLAC,CLHMLT,CLHVAP,PI,ZOLNG,ZOLNS,ZOLNI, 3 ZORATG C COMMON /CLASS1/ DELT,TFREZ COMMON /CLASS3/ TCW,TCICE,TCSAND,TCCLAY,TCOM,TCDRYS, 1 RHOSOL,RHOOM COMMON /CLASS4/ HCPW,HCPICE,HCPSOL,HCPOM,HCPSND,HCPCLY, 1 SPHW,SPHICE,SPHVEG,SPHAIR,RHOW,RHOICE, 2 TCGLAC,CLHMLT,CLHVAP COMMON /CLASS6/ PI,GROWYR,ZOLNG,ZOLNS,ZOLNI,ZORAT,ZORATG COMMON /CLASS7/ CANEXT,XLEAF C----------------------------------------------------------------------- IF(IC.NE.4) CALL XIT('APREP',-2) C C * INITIALIZE DIAGNOSTIC AND OTHER ARRAYS. C DO 100 I=IL1,IL2 HTCC(I) =0.0 HTCS(I) =0.0 DO 50 J=1,IG HTC(I,J)=0.0 50 CONTINUE WTRC(I) =0.0 WTRS(I) =0.0 WTRG(I) =0.0 FRTOT(I)=0.0 FRTOTS(I)=0.0 DISP (I)=0. ZOMLNC(I)=0. ZOELNC(I)=1. DISPS (I)=0. ZOMLCS(I)=0. ZOELCS(I)=1. ZOMLNG(I)=0. ZOELNG(I)=0. ZOMLNS(I)=0. ZOELNS(I)=0. CMASSC(I)=0. CMASCS(I)=0. PSIGND(I)=1.0E+5 100 CONTINUE C C * DETERMINE GROWTH INDEX FOR CROPS (VEGETATION TYPE 3). C * MUST USE UN-GATHERED LONGITUDES TO COMPUTE ACTUAL LONGITUDE/ C * LATITUDE VALUES. C DAY=REAL(IDAY) C C * FOR CTEM, CROP GROWTH IS BUILT IN, SO GROWA=1. C IF (ICTEMMOD.EQ.0) THEN DO 120 I=IL1,IL2 IN = INT( (RADJ(I)+PI/2.0)*18.0/PI ) + 1 IF(DLON(I).GT.190. .AND. DLON(I).LT.330.) THEN NL=2 ELSE NL=1 ENDIF IF(GROWYR(IN,1,NL).LT.0.1) THEN GROWA(I)=1.0 ELSE IF(IN.GT.9) THEN IF(DAY.GE.GROWYR(IN,2,NL).AND.DAY.LT.GROWYR(IN,3,NL)) 1 GROWA(I)=1.0 IF(DAY.GE.GROWYR(IN,4,NL).OR.DAY.LT.GROWYR(IN,1,NL)) 1 GROWA(I)=0.0 ELSE IF(DAY.GE.GROWYR(IN,2,NL).OR.DAY.LT.GROWYR(IN,3,NL)) 1 GROWA(I)=1.0 IF(DAY.GE.GROWYR(IN,4,NL).AND.DAY.LT.GROWYR(IN,1,NL)) 1 GROWA(I)=0.0 ENDIF IF(DAY.GE.GROWYR(IN,1,NL).AND.DAY.LT.GROWYR(IN,2,NL)) 1 GROWA(I)=(DAY-GROWYR(IN,1,NL))/(GROWYR(IN,2,NL)- 2 GROWYR(IN,1,NL)) IF(DAY.GE.GROWYR(IN,3,NL).AND.DAY.LT.GROWYR(IN,4,NL)) 1 GROWA(I)=(GROWYR(IN,4,NL)-DAY)/(GROWYR(IN,4,NL)- 2 GROWYR(IN,3,NL)) GROWA(I)=MAX(0.0,MIN(GROWA(I),1.0)) IF(GROWA(I).LT.1.0E-5) GROWA(I)=0.0 ENDIF 120 CONTINUE ELSE DO I=IL1,IL2 GROWA(I)=1. ENDDO ENDIF C C * DETERMINE GROWTH INDICES FOR NEEDLELEAF TREES, BROADLEAF C * TREES AND GRASS (VEGETATION TYPES 1, 2 AND 4); CALCULATE C * VEGETATION HEIGHT, CORRECTED FOR GROWTH STAGE FOR CROPS C * AND FOR SNOW COVER FOR CROPS AND GRASS; CALCULATE CURRENT C * LEAF AREA INDEX FOR FOUR VEGETATION TYPES. C DO 150 I=IL1,IL2 GROWN(I)=ABS(GROWTH(I)) IF(GROWTH(I).GT.0.0) THEN GROWB(I)=MIN(1.0,GROWTH(I)*2.0) ELSE GROWB(I)=MAX(0.0,(ABS(GROWTH(I))*2.0-1.0)) ENDIF GROWG=1.0 C IF(IHGT.EQ.0) THEN H(I,1)=10.0*EXP(ZOLN(I,1)) H(I,2)=10.0*EXP(ZOLN(I,2)) H(I,3)=10.0*EXP(ZOLN(I,3))*GROWA(I) H(I,4)=10.0*EXP(ZOLN(I,4)) ELSE H(I,1)=HGTDAT(I,1) H(I,2)=HGTDAT(I,2) H(I,3)=HGTDAT(I,3) H(I,4)=HGTDAT(I,4) ENDIF HS(I,1)=H(I,1) HS(I,2)=H(I,2) HS(I,3)=MAX(H(I,3)-ZSNOW(I),1.0E-3) HS(I,4)=MAX(H(I,4)-ZSNOW(I),1.0E-3) IF(IPAI.EQ.0) THEN C ----------------- CTEM MODIFICATIONS -----------------------------\ C USE CTEM GENERATED PAI OR CLASS' OWN SPECIFIED PAI IF (ICTEMMOD .EQ. 1) THEN PAI(I,1)=PAIC(I,1) PAI(I,2)=PAIC(I,2) PAI(I,3)=PAIC(I,3) PAI(I,4)=PAIC(I,4) ELSE PAI(I,1)=PAIMIN(I,1)+GROWN(I)*(PAIMAX(I,1)-PAIMIN(I,1)) PAI(I,2)=PAIMIN(I,2)+GROWB(I)*(PAIMAX(I,2)-PAIMIN(I,2)) PAI(I,3)=PAIMIN(I,3)+GROWA(I)*(PAIMAX(I,3)-PAIMIN(I,3)) PAI(I,4)=PAIMIN(I,4)+GROWG *(PAIMAX(I,4)-PAIMIN(I,4)) ENDIF C ----------------- CTEM MODIFICATIONS -----------------------------/ C ELSE PAI(I,1)=PAIDAT(I,1) PAI(I,2)=PAIDAT(I,2) PAI(I,3)=PAIDAT(I,3) PAI(I,4)=PAIDAT(I,4) ENDIF PAIS(I,1)=PAI(I,1) PAIS(I,2)=PAI(I,2) IF(H(I,3).GT.0.0) THEN PAIS(I,3)=PAI(I,3)*HS(I,3)/H(I,3) ELSE PAIS(I,3)=0.0 ENDIF IF(H(I,4).GT.0.0) THEN PAIS(I,4)=PAI(I,4)*HS(I,4)/H(I,4) ELSE PAIS(I,4)=0.0 ENDIF C C ----------------- CTEM MODIFICATIONS -----------------------------\ C IF (ICTEMMOD .EQ. 1) THEN AIL(I,1)=MAX(AILC(I,1), SLAIC(I,1)) AIL(I,2)=MAX(AILC(I,2), SLAIC(I,2)) AIL(I,3)=MAX(AILC(I,3), SLAIC(I,3)) AIL(I,4)=MAX(AILC(I,4), SLAIC(I,4)) ELSE C ----------------- CTEM MODIFICATIONS -----------------------------/ C AIL(I,1)=PAI(I,1)*0.90 AIL(I,2)=MAX((PAI(I,2)-PAIMIN(I,2)),0.0) AIL(I,3)=PAI(I,3) AIL(I,4)=PAI(I,4) ENDIF C ----------------- CTEM MODIFICATIONS -----------------------------\ C C ESTIMATE GREEN LAI FOR CANOPY OVER SNOW FRACTION FOR CTEM's C 9 PFTs, JUST LIKE CLASS DOES. C IF (ICTEMMOD.EQ.1) THEN AILCGS(I,1)=AILCG(I,1) !NDL EVG AILCGS(I,2)=AILCG(I,2) !NDL DCD AILCGS(I,3)=AILCG(I,3) !BDL EVG AILCGS(I,4)=AILCG(I,4) !BDL DCD CLD AILCGS(I,5)=AILCG(I,5) !BDL DCD DRY IF(H(I,3).GT.0.0) THEN AILCGS(I,6)=AILCG(I,6)*HS(I,3)/H(I,3) !C3 CROP AILCGS(I,7)=AILCG(I,7)*HS(I,3)/H(I,3) !C4 CROP ELSE AILCGS(I,6)=0.0 AILCGS(I,7)=0.0 ENDIF IF(H(I,4).GT.0.0) THEN AILCGS(I,8)=AILCG(I,8)*HS(I,4)/H(I,4) !C3 GRASS AILCGS(I,9)=AILCG(I,9)*HS(I,4)/H(I,4) !C4 GRASS ELSE AILCGS(I,8)=0.0 AILCGS(I,9)=0.0 ENDIF ENDIF C ----------------- CTEM MODIFICATIONS -----------------------------/ C 150 CONTINUE C C * ADJUST FRACTIONAL COVERAGE OF GRID CELL FOR CROPS AND C * GRASS IF LAI FALLS BELOW A SET THRESHOLD VALUE DUE TO C * GROWTH STAGE OR SNOW COVER; RESET LAI TO THE THRESHOLD C * VALUE; CALCULATE RESULTANT GRID CELL COVERAGE BY CANOPY, C * BARE GROUND, CANOPY OVER SNOW AND SNOW OVER BARE GROUND. C * C * ALSO CALCULATE SURFACE DETENTION CAPACITY FOR FOUR C * GRID CELL SUBAREAS BASED ON VALUES SUPPLIED BY C * U. OF WATERLOO: C * IMPERMEABLE SURFACES: 0.001 M. C * BARE SOIL: 0.002 M. C * LOW VEGETATION: 0.003 M. C * FOREST: 0.01 M. C THR_LAI=1.0 C DO 175 I=IL1,IL2 FCAN(I,1)=FCANMX(I,1)*(1.0-FSNOW(I)) FCAN(I,2)=FCANMX(I,2)*(1.0-FSNOW(I)) IF(FCAN(I,1).LT.1.0E-5) FCAN(I,1)=0.0 IF(FCAN(I,2).LT.1.0E-5) FCAN(I,2)=0.0 IF(PAI(I,3).LT.THR_LAI) THEN FCAN(I,3)=FCANMX(I,3)*(1.0-FSNOW(I))*PAI(I,3) PAI (I,3)=THR_LAI ELSE FCAN(I,3)=FCANMX(I,3)*(1.0-FSNOW(I)) ENDIF IF(PAI(I,4).LT.THR_LAI) THEN FCAN(I,4)=FCANMX(I,4)*(1.0-FSNOW(I))*PAI(I,4) PAI (I,4)=THR_LAI ELSE FCAN(I,4)=FCANMX(I,4)*(1.0-FSNOW(I)) ENDIF IF(FCAN(I,3).LT.1.0E-5) FCAN(I,3)=0.0 IF(FCAN(I,4).LT.1.0E-5) FCAN(I,4)=0.0 C FCANS(I,1)=FCANMX(I,1)*FSNOW(I) FCANS(I,2)=FCANMX(I,2)*FSNOW(I) IF(FCANS(I,1).LT.1.0E-5) FCANS(I,1)=0.0 IF(FCANS(I,2).LT.1.0E-5) FCANS(I,2)=0.0 IF(PAIS(I,3).LT.THR_LAI) THEN FCANS(I,3)=FCANMX(I,3)*FSNOW(I)*PAIS(I,3) PAIS (I,3)=THR_LAI ELSE FCANS(I,3)=FCANMX(I,3)*FSNOW(I) ENDIF IF(PAIS(I,4).LT.THR_LAI) THEN FCANS(I,4)=FCANMX(I,4)*FSNOW(I)*PAIS(I,4) PAIS (I,4)=THR_LAI ELSE FCANS(I,4)=FCANMX(I,4)*FSNOW(I) ENDIF IF(FCANS(I,3).LT.1.0E-5) FCANS(I,3)=0.0 IF(FCANS(I,4).LT.1.0E-5) FCANS(I,4)=0.0 C FC (I)=FCAN(I,1)+FCAN(I,2)+FCAN(I,3)+FCAN(I,4) FG (I)=1.0-FSNOW(I)-FC(I) FCS(I)=FCANS(I,1)+FCANS(I,2)+FCANS(I,3)+FCANS(I,4) FGS(I)=FSNOW(I)-FCS(I) IF(ABS(1.0-FCS(I)-FC(I)).LT.8.0E-5) THEN IF(FCS(I).LT.1.0E-5) THEN FSNOW (I)=0.0 ELSE IF (FC(I).LT.1.0E-5) THEN FSNOW(I)= 1.0 ENDIF IF(FCS(I).GT.0.) THEN FCANS(I,1)=FCANS(I,1)*FSNOW(I)/FCS(I) FCANS(I,2)=FCANS(I,2)*FSNOW(I)/FCS(I) FCANS(I,3)=FCANS(I,3)*FSNOW(I)/FCS(I) FCANS(I,4)=FCANS(I,4)*FSNOW(I)/FCS(I) ENDIF IF(FC(I).GT.0.) THEN FCAN(I,1)=FCAN(I,1)*(1.0-FSNOW(I))/FC(I) FCAN(I,2)=FCAN(I,2)*(1.0-FSNOW(I))/FC(I) FCAN(I,3)=FCAN(I,3)*(1.0-FSNOW(I))/FC(I) FCAN(I,4)=FCAN(I,4)*(1.0-FSNOW(I))/FC(I) ENDIF FCS(I)=MIN(FSNOW(I),1.0) FC(I)=1.0-FCS(I) FGS(I)=0.0 FG(I)=0.0 ENDIF FC (I)=MAX(FC (I),0.0) FG (I)=MAX(FG (I),0.0) FCS(I)=MAX(FCS(I),0.0) FGS(I)=MAX(FGS(I),0.0) FSUM=(FCS(I)+FGS(I)+FC(I)+FG(I)) FC (I)=FC (I)/FSUM FG (I)=FG (I)/FSUM FCS(I)=FCS(I)/FSUM FGS(I)=FGS(I)/FSUM IF(ABS(1.0-FCS(I)-FGS(I)-FC(I)-FG(I)).GT.1.0E-5) 1 CALL XIT('APREP',-1) C IF(IWF.EQ.0) THEN IF(ISAND(I,1).EQ.-4) THEN ZPLIMG(I)=0.001 ELSEIF(ISAND(I,1).EQ.-3) THEN ZPLIMG(I)=0.001 ELSE ZPLIMG(I)=0.002 ENDIF IF(FGS(I).GT.0.0) THEN ZPLMGS(I)=(ZPLIMG(I)*FSNOW(I)*(1.0-FCANMX(I,1)- 1 FCANMX(I,2)-FCANMX(I,3)-FCANMX(I,4))+ 2 ZPLIMG(I)*(FSNOW(I)*FCANMX(I,3)- 3 FCANS(I,3))+0.003*(FSNOW(I)*FCANMX(I,4)- 4 FCANS(I,4)))/FGS(I) ELSE ZPLMGS(I)=0.0 ENDIF IF(FC(I).GT.0.0) THEN ZPLIMC(I)=(0.01*(FCAN(I,1)+FCAN(I,2))+0.003* 1 (FCAN(I,3)+FCAN(I,4)))/FC(I) ELSE ZPLIMC(I)=0.0 ENDIF IF(FCS(I).GT.0.0) THEN ZPLMCS(I)=(0.01*(FCANS(I,1)+FCANS(I,2))+0.003* 1 (FCANS(I,3)+FCANS(I,4)))/FCS(I) ELSE ZPLMCS(I)=0.0 ENDIF ELSE ZPLMCS(I)=ZPLMS0(I) ZPLMGS(I)=ZPLMS0(I) ZPLIMC(I)=ZPLMG0(I) ZPLIMG(I)=ZPLMG0(I) ENDIF 175 CONTINUE C C * PARTITION INTERCEPTED LIQUID AND FROZEN MOISTURE BETWEEN C * CANOPY OVERLYING BARE GROUND AND CANOPY OVERLYING SNOW, C * USING DIFFERENT EFFECTIVE LEAF AREAS FOR EACH. ADD C * RESIDUAL TO SOIL MOISTURE OR SNOW (IF PRESENT); CALCULATE C * RELATIVE FRACTIONS OF LIQUID AND FROZEN INTERCEPTED C * MOISTURE ON CANOPY. C DO 200 I=IL1,IL2 IF(FC(I).GT.0.) THEN PAICAN(I)=(FCAN(I,1)*PAI(I,1)+FCAN(I,2)*PAI(I,2)+ 1 FCAN(I,3)*PAI(I,3)+FCAN(I,4)*PAI(I,4))/FC(I) ELSE PAICAN(I)=0.0 ENDIF IF(FCS(I).GT.0.) THEN PAICNS(I)=(FCANS(I,1)*PAIS(I,1)+FCANS(I,2)*PAIS(I,2)+ 1 FCANS(I,3)*PAIS(I,3)+FCANS(I,4)*PAIS(I,4))/ 2 FCS(I) ELSE PAICNS(I)=0.0 ENDIF C CWLCAP(I)=0.20*PAICAN(I) CWLCPS(I)=0.20*PAICNS(I) C RRESID(I)=0.0 IF(RCAN(I).LT.1.0E-5 .OR. (FC(I)+FCS(I)).LT.1.0E-5) THEN RRESID(I)=RRESID(I)+RCAN(I) RCAN(I)=0.0 ENDIF C IF(RCAN(I).GT.0. .AND. (FC(I)+FCS(I)).GT.0.) THEN RCAN(I)=RCAN(I)/(FC(I)+FCS(I)) IF(PAICAN(I).GT.0.0) THEN RAICAN(I)=RCAN(I)*(FC(I)+FCS(I))/(FC(I)+FCS(I)* 1 PAICNS(I)/PAICAN(I)) ELSE RAICAN(I)=0.0 ENDIF IF(PAICNS(I).GT.0.0) THEN RAICNS(I)=RCAN(I)*(FC(I)+FCS(I))/(FCS(I)+FC(I)* 1 PAICAN(I)/PAICNS(I)) ELSE RAICNS(I)=0.0 ENDIF ELSE RAICAN(I)=0.0 RAICNS(I)=0.0 ENDIF C IF(FC(I).GT.0.) THEN PAICAN(I)=(0.7*FCAN(I,1)*PAI(I,1)+FCAN(I,2)*PAI(I,2)+ 1 FCAN(I,3)*PAI(I,3)+FCAN(I,4)*PAI(I,4))/FC(I) ELSE PAICAN(I)=0.0 ENDIF IF(FCS(I).GT.0.) THEN PAICNS(I)=(0.7*FCANS(I,1)*PAIS(I,1)+FCANS(I,2)*PAIS(I,2)+ 1 FCANS(I,3)*PAIS(I,3)+FCANS(I,4)*PAIS(I,4))/ 2 FCS(I) ELSE PAICNS(I)=0.0 ENDIF C CWFCAP(I)=6.0*PAICAN(I)*(0.27+46.0/RHOSNI(I)) CWFCPS(I)=6.0*PAICNS(I)*(0.27+46.0/RHOSNI(I)) C SRESID(I)=0.0 IF(SNCAN(I).LT.1.0E-5 .OR. (FC(I)+FCS(I)).LT.1.0E-5) THEN SRESID(I)=SRESID(I)+SNCAN(I) SNCAN(I)=0.0 ENDIF C IF(SNCAN(I).GT.0. .AND. (FC(I)+FCS(I)).GT.0.) THEN SNCAN(I)=SNCAN(I)/(FC(I)+FCS(I)) IF(PAICAN(I).GT.0.0) THEN SNOCAN(I)=SNCAN(I)*(FC(I)+FCS(I))/(FC(I)+FCS(I)* 1 PAICNS(I)/PAICAN(I)) ELSE SNOCAN(I)=0.0 ENDIF IF(PAICNS(I).GT.0.0) THEN SNOCNS(I)=SNCAN(I)*(FC(I)+FCS(I))/(FCS(I)+FC(I)* 1 PAICAN(I)/PAICNS(I)) ELSE SNOCNS(I)=0.0 ENDIF ELSE SNOCAN(I)=0.0 SNOCNS(I)=0.0 ENDIF C IF(CWFCAP(I).GT.0.0) THEN FSNOWC(I)=MIN(SNOCAN(I)/CWFCAP(I),1.0) ELSE FSNOWC(I)=0.0 ENDIF IF(CWFCPS(I).GT.0.0) THEN FSNOCS(I)=MIN(SNOCNS(I)/CWFCPS(I),1.0) ELSE FSNOCS(I)=0.0 ENDIF C IF(CWLCAP(I).GT.0.0) THEN FRAINC(I)=MIN(RAICAN(I)/CWLCAP(I),1.0) ELSE FRAINC(I)=0.0 ENDIF IF(CWLCPS(I).GT.0.0) THEN FRAICS(I)=MIN(RAICNS(I)/CWLCPS(I),1.0) ELSE FRAICS(I)=0.0 ENDIF FRAINC(I)=MAX(0.0,MIN(FRAINC(I)-FSNOWC(I),1.0)) FRAICS(I)=MAX(0.0,MIN(FRAICS(I)-FSNOCS(I),1.0)) C IF(RAICAN(I).GT.CWLCAP(I)) THEN RRESID(I)=RRESID(I)+FC(I)*(RAICAN(I)-CWLCAP(I)) RAICAN(I)=CWLCAP(I) ENDIF IF(SNOCAN(I).GT.CWFCAP(I)) THEN SRESID(I)=SRESID(I)+FC(I)*(SNOCAN(I)-CWFCAP(I)) SNOCAN(I)=CWFCAP(I) ENDIF C IF(RAICNS(I).GT.CWLCPS(I)) THEN RRESID(I)=RRESID(I)+FCS(I)*(RAICNS(I)-CWLCPS(I)) RAICNS(I)=CWLCPS(I) ENDIF IF(SNOCNS(I).GT.CWFCPS(I)) THEN SRESID(I)=SRESID(I)+FCS(I)*(SNOCNS(I)-CWFCPS(I)) SNOCNS(I)=CWFCPS(I) ENDIF C WTRC (I)=WTRC(I)-(RRESID(I)+SRESID(I))/DELT HTCC (I)=HTCC(I)-TCAN(I)*(SPHW*RRESID(I)+SPHICE*SRESID(I))/ 1 DELT IF(FSNOW(I).GT.0.0) THEN SNOI=SNO(I) ZSNADD=SRESID(I)/(RHOSNO(I)*FSNOW(I)) ZSNOW(I)=ZSNOW(I)+ZSNADD SNO(I)=ZSNOW(I)*FSNOW(I)*RHOSNO(I) TSNOW(I)=(TCAN(I)*SPHICE*SRESID(I)+TSNOW(I)*HCPICE* 1 SNOI/RHOICE)/(HCPICE*SNO(I)/RHOICE) HTCS (I)=HTCS(I)+TCAN(I)*SPHICE*SRESID(I)/DELT WTRS (I)=WTRS(I)+SRESID(I)/DELT SRESID(I)=0.0 ENDIF C DO 190 J=1,IG IF(DELZW(I,J).GT.0.0 .AND. (RRESID(I).GT.0.0 1 .OR. SRESID(I).GT.0.0)) THEN THSUM=THLIQ(I,J)+THICE(I,J)+ 1 (RRESID(I)+SRESID(I))/(RHOW*DELZW(I,J)) IF(THSUM.LT.THPOR(I,J)) THEN THICEI=THICE(I,J) THLIQI=THLIQ(I,J) THICE(I,J)=THICE(I,J)+SRESID(I)/ 1 (RHOICE*DELZW(I,J)) THLIQ(I,J)=THLIQ(I,J)+RRESID(I)/ 1 (RHOW*DELZW(I,J)) TBAR(I,J)=(TBAR(I,J)*((DELZ(J)-DELZW(I,J))* 1 HCPSND+DELZW(I,J)*(THLIQI*HCPW+THICEI* 2 HCPICE+(1.0-THPOR(I,J))*HCPS(I,J)))+TCAN(I)* 3 (RRESID(I)*HCPW/RHOW+SRESID(I)*HCPICE/RHOICE)) 4 /((DELZ(J)-DELZW(I,J))*HCPSND+DELZW(I,J)* 5 (HCPW*THLIQ(I,J)+HCPICE*THICE(I,J)+HCPS(I,J)* 6 (1.0-THPOR(I,J)))) HTC(I,J)=HTC(I,J)+TCAN(I)*(RRESID(I)*HCPW/RHOW+ 1 SRESID(I)*HCPICE/RHOICE)/DELT WTRG (I)=WTRG(I)+(RRESID(I)+SRESID(I))/DELT RRESID(I)=0.0 SRESID(I)=0.0 ENDIF ENDIF 190 CONTINUE C 200 CONTINUE C C * CALCULATION OF ROUGHNESS LENGTHS FOR HEAT AND MOMENTUM AND C * ZERO-PLANE DISPLACEMENT FOR CANOPY OVERLYING BARE SOIL AND C * CANOPY OVERLYING SNOW. C DO 250 J=1,IC DO 250 I=IL1,IL2 IF(FC(I).GT.0. .AND. H(I,J).GT.0.) THEN IF(IDISP.EQ.1) DISP(I)=DISP(I)+FCAN (I,J)* 1 LOG(0.7*H(I,J)) ZOMLNC(I)=ZOMLNC(I)+FCAN (I,J)/ 1 ((LOG(ZBLEND(I)/(0.1*H(I,J))))**2) ZOELNC(I)=ZOELNC(I)* 1 (0.01*H(I,J)*H(I,J)/ZORAT(IC))**FCAN(I,J) ENDIF IF(FCS(I).GT.0. .AND. HS(I,J).GT.0.) THEN IF(IDISP.EQ.1) DISPS(I)=DISPS (I)+FCANS(I,J)* 1 LOG(0.7*HS(I,J)) ZOMLCS(I)=ZOMLCS(I)+FCANS(I,J)/ 1 ((LOG(ZBLEND(I)/(0.1*HS(I,J))))**2) ZOELCS(I)=ZOELCS(I)* 1 (0.01*HS(I,J)*HS(I,J)/ZORAT(IC))**FCANS(I,J) ENDIF 250 CONTINUE C DO 275 I=IL1,IL2 IF(FC(I).GT.0.) THEN IF(IDISP.EQ.1) DISP(I)=EXP(DISP(I)/FC(I)) ZOMLNC(I)=ZBLEND(I)/EXP(SQRT(1.0/(ZOMLNC(I)/FC(I)))) ZOELNC(I)=LOG(ZOELNC(I)**(1.0/FC(I))/ZOMLNC(I)) ZOMLNC(I)=LOG(ZOMLNC(I)) ENDIF IF(FCS(I).GT.0.) THEN IF(IDISP.EQ.1) DISPS(I)=EXP(DISPS(I)/FCS(I)) ZOMLCS(I)=ZBLEND(I)/EXP(SQRT(1.0/(ZOMLCS(I)/FCS(I)))) ZOELCS(I)=LOG(ZOELCS(I)**(1.0/FCS(I))/ZOMLCS(I)) ZOMLCS(I)=LOG(ZOMLCS(I)) ENDIF 275 CONTINUE C C * ADJUST ROUGHNESS LENGTHS OF BARE SOIL AND SNOW-COVERED BARE C * SOIL FOR URBAN ROUGHNESS IF PRESENT. C DO 300 I=IL1,IL2 IF(FG(I).GT.0.) THEN IF(ISAND(I,1).NE.-4) THEN ZOMLNG(I)=((FG(I)-FCANMX(I,5)*(1.0-FSNOW(I)))*ZOLNG+ 1 FCANMX(I,5)*(1.0-FSNOW(I))*ZOLN(I,5))/FG(I) ELSE ZOMLNG(I)=ZOLNI ENDIF ZOELNG(I)=ZOMLNG(I)-LOG(ZORATG) ENDIF IF(FGS(I).GT.0.) THEN ZOMLNS(I)=((FGS(I)-FCANMX(I,5)*FSNOW(I))*ZOLNS+ 1 FCANMX(I,5)*FSNOW(I)*ZOLN(I,5))/FGS(I) ZOELNS(I)=ZOMLNS(I)-LOG(ZORATG) ENDIF 300 CONTINUE C C * ADD CONTRIBUTION OF OROGRAPHY TO MOMENTUM ROUGHNESS LENGTH C DO 325 I=IL1,IL2 IF(Z0ORO(I).GT.1.0E-4) THEN LZ0ORO=LOG(Z0ORO(I)) ELSE LZ0ORO=-10.0 ENDIF ZOMLNC(I)=MAX(ZOMLNC(I),LZ0ORO) ZOMLCS(I)=MAX(ZOMLCS(I),LZ0ORO) ZOMLNG(I)=MAX(ZOMLNG(I),LZ0ORO) ZOMLNS(I)=MAX(ZOMLNS(I),LZ0ORO) 325 CONTINUE C C * CALCULATE HEAT CAPACITY FOR CANOPY OVERLYING BARE SOIL AND C * CANOPY OVERLYING SNOW. C * ALSO CALCULATE INSTANTANEOUS GRID-CELL AVERAGED CANOPY MASS. C DO 350 I=IL1,IL2 IF(FC(I).GT.0.) THEN CMASSC(I)=(FCAN(I,1)*CWGTMX(I,1)+FCAN (I,2)*CWGTMX(I,2)+ 1 FCAN(I,3)*CWGTMX(I,3)*GROWA(I)+ 2 FCAN(I,4)*CWGTMX(I,4))/FC (I) C IF(IDISP.EQ.0) THEN CMASSC(I)=CMASSC(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.7* 1 (FCAN(I,1)*H(I,1)+FCAN(I,2)*H(I,2)+ 2 FCAN(I,3)*H(I,3)+FCAN(I,4)*H(I,4))/FC(I) ENDIF IF(IZREF.EQ.2) THEN CMASSC(I)=CMASSC(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.1* 1 (FCAN(I,1)*H(I,1)+FCAN(I,2)*H(I,2)+ 2 FCAN(I,3)*H(I,3)+FCAN(I,4)*H(I,4))/FC(I) ENDIF ENDIF IF(FCS(I).GT.0.) THEN CMASCS(I)=(FCANS(I,1)*CWGTMX(I,1)+FCANS(I,2)*CWGTMX(I,2)+ 1 FCANS(I,3)*CWGTMX(I,3)*GROWA(I) 2 *HS(I,3)/MAX(H(I,3),HS(I,3))+ 3 FCANS(I,4)*CWGTMX(I,4) 4 *HS(I,4)/MAX(H(I,4),HS(I,4)))/FCS(I) C IF(IDISP.EQ.0) THEN CMASCS(I)=CMASCS(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.7* 1 (FCANS(I,1)*HS(I,1)+FCANS(I,2)*HS(I,2)+ 2 FCANS(I,3)*HS(I,3)+FCANS(I,4)*HS(I,4))/ 3 FCS(I) ENDIF IF(IZREF.EQ.2) THEN CMASCS(I)=CMASCS(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.1* 1 (FCANS(I,1)*HS(I,1)+FCANS(I,2)*HS(I,2)+ 2 FCANS(I,3)*HS(I,3)+FCANS(I,4)*HS(I,4))/ 3 FCS(I) ENDIF ENDIF CHCAP (I)=SPHVEG*CMASSC(I)+SPHW*RAICAN(I)+SPHICE*SNOCAN(I) CHCAPS(I)=SPHVEG*CMASCS(I)+SPHW*RAICNS(I)+SPHICE*SNOCNS(I) HTCC (I)=HTCC(I)-SPHVEG*CMAI(I)*TCAN(I)/DELT IF(CMAI(I).LT.1.0E-5 .AND. (CMASSC(I).GT.0.0 .OR. 1 CMASCS(I).GT.0.0)) TCAN(I)=TA(I) CMAI (I)=FC(I)*CMASSC(I)+FCS(I)*CMASCS(I) HTCC (I)=HTCC(I)+SPHVEG*CMAI(I)*TCAN(I)/DELT RBCOEF(I)=0.0 350 CONTINUE C C * CALCULATE VEGETATION ROOTING DEPTH AND FRACTION OF ROOTS C * IN EACH SOIL LAYER (SAME FOR SNOW/BARE SOIL CASES). C * ALSO CALCULATE LEAF BOUNDARY RESISTANCE PARAMETER RBCOEF. C DO 450 J=1,IC DO 450 I=IL1,IL2 IF (ICTEMMOD.EQ.1) THEN RMAT(I,J,1)=RMATC(I,J,1) RMAT(I,J,2)=RMATC(I,J,2) RMAT(I,J,3)=RMATC(I,J,3) ELSE ZROOT=ZRTMAX(I,J) IF(J.EQ.3) ZROOT=ZRTMAX(I,J)*GROWA(I) ZROOTG=0.0 DO 375 K=1,IG ZROOTG=ZROOTG+DELZW(I,K) 375 CONTINUE ZROOT=MIN(ZROOT,ZROOTG) DO 400 K=1,IG IF(ZROOT.LE.(ZBOTW(I,K)-DELZW(I,K)+0.0001)) THEN RMAT(I,J,K)=0.0 ELSEIF(ZROOT.LE.ZBOTW(I,K)) THEN RMAT(I,J,K)=(EXP(-3.0*(ZBOTW(I,K)-DELZW(I,K)))- 1 EXP(-3.0*ZROOT))/(1.0-EXP(-3.0*ZROOT)) ELSE RMAT(I,J,K)=(EXP(-3.0*(ZBOTW(I,K)-DELZW(I,K)))- 1 EXP(-3.0*ZBOTW(I,K)))/(1.0-EXP(-3.0*ZROOT)) ENDIF 400 CONTINUE ENDIF C IF((FC(I)+FCS(I)).GT.0.) THEN RBCOEF(I)=RBCOEF(I)+ 1 (FCAN(I,J)*XLEAF(J)*(SQRT(PAI(I,J))/0.75)* 2 (1.0-EXP(-0.75*SQRT(PAI(I,J))))+ 3 FCANS(I,J)*XLEAF(J)*(SQRT(PAIS(I,J))/0.75)* 4 (1.0-EXP(-0.75*SQRT(PAIS(I,J)))))/ 5 (FC(I)+FCS(I)) ENDIF 450 CONTINUE C DO 500 J=1,IG DO 500 I=IL1,IL2 IF(FC(I).GT.0.) THEN FROOT(I,J)=(FCAN(I,1)*RMAT(I,1,J) + 1 FCAN(I,2)*RMAT(I,2,J) + 2 FCAN(I,3)*RMAT(I,3,J) + 3 FCAN(I,4)*RMAT(I,4,J))/FC(I) ELSE FROOT(I,J)=0.0 ENDIF IF(FCS(I).GT.0.) THEN FROOTS(I,J)=(FCANS(I,1)*RMAT(I,1,J) + 1 FCANS(I,2)*RMAT(I,2,J) + 2 FCANS(I,3)*RMAT(I,3,J) + 3 FCANS(I,4)*RMAT(I,4,J))/FCS(I) ELSE FROOTS(I,J)=0.0 ENDIF 500 CONTINUE C C * CALCULATE SKY-VIEW FACTORS FOR BARE GROUND AND SNOW C * UNDERLYING CANOPY. C DO 600 I=IL1,IL2 IF(FC(I).GT.0.) THEN FSVF (I)=(FCAN (I,1)*EXP(CANEXT(1)*PAI (I,1)) + 1 FCAN (I,2)*EXP(CANEXT(2)*PAI (I,2)) + 2 FCAN (I,3)*EXP(CANEXT(3)*PAI (I,3)) + 3 FCAN (I,4)*EXP(CANEXT(4)*PAI (I,4)))/FC (I) ELSE FSVF (I)=0. ENDIF IF(FCS(I).GT.0.) THEN FSVFS(I)=(FCANS(I,1)*EXP(CANEXT(1)*PAIS(I,1)) + 1 FCANS(I,2)*EXP(CANEXT(2)*PAIS(I,2)) + 2 FCANS(I,3)*EXP(CANEXT(3)*PAIS(I,3)) + 3 FCANS(I,4)*EXP(CANEXT(4)*PAIS(I,4)))/FCS(I) ELSE FSVFS(I)=0. ENDIF 600 CONTINUE C C * CALCULATE BULK SOIL MOISTURE SUCTION FOR STOMATAL RESISTANCE. C * CALCULATE FRACTIONAL TRANSPIRATION EXTRACTED FROM SOIL LAYERS. C DO 650 J=1,IG DO 650 I=IL1,IL2 IF(FCS(I).GT.0.0 .OR. FC(I).GT.0.0) THEN IF(THLIQ(I,J).GT.(THLMIN(I,J)+0.01)) THEN PSII=PSISAT(I,J)*(THLIQ(I,J)/THPOR(I,J))**(-BI(I,J)) PSII=MIN(PSII,PSIWLT(I,J)) IF(FROOT(I,J).GT.0.0) PSIGND(I)=MIN(PSIGND(I),PSII) PSIRAT=(PSIWLT(I,J)-PSII)/(PSIWLT(I,J)-PSISAT(I,J)) FROOT(I,J)=FROOT(I,J)*PSIRAT FROOTS(I,J)=FROOTS(I,J)*PSIRAT FRTOT(I)=FRTOT(I)+FROOT(I,J) FRTOTS(I)=FRTOTS(I)+FROOTS(I,J) ELSE FROOT(I,J)=0.0 FROOTS(I,J)=0.0 ENDIF ENDIF 650 CONTINUE C DO 700 J=1,IG DO 700 I=IL1,IL2 IF(FRTOT(I).GT.0.) THEN FROOT(I,J)=FROOT(I,J)/FRTOT(I) ENDIF IF(FRTOTS(I).GT.0.) THEN FROOTS(I,J)=FROOTS(I,J)/FRTOTS(I) ENDIF 700 CONTINUE C C * CALCULATE EFFECTIVE LEAF AREA INDICES FOR TRANSPIRATION. C DO 800 I=IL1,IL2 IF(FC(I).GT.0.) THEN PAICAN(I)=(FCAN(I,1)*PAI(I,1)+FCAN(I,2)*PAI(I,2)+ 1 FCAN(I,3)*PAI(I,3)+FCAN(I,4)*PAI(I,4))/FC(I) ELSE PAICAN(I)=0.0 ENDIF IF(FCS(I).GT.0.) THEN PAICNS(I)=(FCANS(I,1)*PAIS(I,1)+FCANS(I,2)*PAIS(I,2)+ 1 FCANS(I,3)*PAIS(I,3)+FCANS(I,4)*PAIS(I,4))/ 2 FCS(I) ELSE PAICNS(I)=0.0 ENDIF 800 CONTINUE C IF (ICTEMMOD.EQ.1) THEN C C * ESTIMATE FCANC AND FCANCS FOR USE BY PHTSYN SUBROUTINE BASED ON C * FCAN AND FCANS FOR CTEM PFTS. C DO 810 J = 1, IC DO 810 I = IL1, IL2 SFCANCMX(I,J)=0.0 ! SUM OF FCANCMXS 810 CONTINUE C K1=0 DO 830 J = 1, IC IF(J.EQ.1) THEN K1 = K1 + 1 ELSE K1 = K1 + NOL2PFTS(J-1) ENDIF K2 = K1 + NOL2PFTS(J) - 1 DO 820 M = K1, K2 DO 820 I = IL1, IL2 SFCANCMX(I,J)=SFCANCMX(I,J)+FCANCMX(I,M) 820 CONTINUE 830 CONTINUE C K1=0 DO 860 J = 1, IC IF(J.EQ.1) THEN K1 = K1 + 1 ELSE K1 = K1 + NOL2PFTS(J-1) ENDIF K2 = K1 + NOL2PFTS(J) - 1 DO 850 M = K1, K2 DO 850 I = IL1, IL2 IF(SFCANCMX(I,J).GT.1.E-20) THEN FCANC(I,M) = FCAN(I,J) * (FCANCMX(I,M)/SFCANCMX(I,J)) FCANCS(I,M) = FCANS(I,J)* (FCANCMX(I,M)/SFCANCMX(I,J)) ELSE FCANC(I,M) = 0.0 FCANCS(I,M) = 0.0 ENDIF 850 CONTINUE 860 CONTINUE ENDIF C RETURN END SUBROUTINE CANALB(ALVSCN,ALIRCN,ALVSCS,ALIRCS,TRVSCN,TRIRCN, 1 TRVSCS,TRIRCS,RC,RCS, 2 ALVSC,ALIRC,RSMIN,QA50,VPDA,VPDB,PSIGA,PSIGB, 3 FC,FCS,FSNOW,FSNOWC,FSNOCS,FCAN,FCANS,PAI,PAIS, 4 AIL,PSIGND,FCLOUD,COSZS,QSWINV,VPD,TA, 5 ACVDAT,ACIDAT,ALVSGC,ALIRGC,ALVSSC,ALIRSC, 6 ILG,IL1,IL2,JL,IC,ICP1,IG,IALC, 7 CXTEFF,TRVS,TRIR,RCACC,RCG,RCV,RCT,GC) C C * AUG 04/15 - D.VERSEGHY/M.LAZARE. REMOVE FLAG VALUE OF RC FOR C * VERY DRY SOILS. C * SEP 05/14 - P.BARTLETT. INCREASED ALBEDO VALUES FOR SNOW- C * COVERED CANOPY. C * JUN 27/13 - D.VERSEGHY/ USE LOWER BOUND OF 0.01 INSTEAD OF C * M.LAZARE. 0. IN LOOP 900 TO AVOID CRASH C * IN EXTREME CASE OF LOW VISIBLE C * INCIDENT SUN. C * DEC 21/11 - M.LAZARE. DEFINE CONSTANTS "EXPMAX1", EXPMAX2", C * "EXPMAX3" TO AVOID REDUNDANT EXP C * CALCULATIONS. C * OCT 16/08 - R.HARVEY. ADD LARGE LIMIT FOR EFFECTIVE C * EXTINCTION COEFFICIENT (CXTEFF) IN C * (RARE) CASES WHEN CANOPY TRANSMISSIVITY C * IN THE VISIBLE IS ZERO EXACTLY. C * MAR 25/08 - D.VERSEGHY. DISTINGUISH BETWEEN LEAF AREA INDEX C * AND PLANT AREA INDEX. C * OCT 19/07 - D.VERSEGHY. SIMPLIFY ALBEDO CALCULATIONS FOR C * SNOW-FREE CROPS AND GRASS; CORRECT C * BUG IN CALCULATION OF RC. C * APR 13/06 - P.BARTLETT/D.VERSEGHY. CORRECT OVERALL CANOPY C * ALBEDO, INTRODUCE SEPARATE C * GROUND AND SNOW ALBEDOS FOR C * OPEN OR CANOPY-COVERED AREAS. C * MAR 21/06 - P.BARTLETT. PROTECT RC CALCULATION AGAINST DIVISION C * BY ZERO. C * SEP 26/05 - D.VERSEGHY. REMOVE HARD CODING OF IG=3 IN 600 LOOP. C * NOV 03/04 - D.VERSEGHY. ADD "IMPLICIT NONE" COMMAND. C * JUL 05/04 - D.VERSEGHY. PROTECT SENSITIVE CALCULATIONS AGAINST C * ROUNDOFF ERRORS. C * JAN 24/02 - P.BARTLETT/D.VERSEGHY. REFINE CALCULATION OF NEW C * STOMATAL RESISTANCES. C * JUL 30/02 - P.BARTLETT/D.VERSEGHY. NEW STOMATAL RESISTANCE C * FORMULATION INCORPORATED. C * MAR 18/02 - D.VERSEGHY. ALLOW FOR ASSIGNMENT OF SPECIFIED TIME- C * VARYING VALUES OF VEGETATION SNOW-FREE C * ALBEDO. C * NOV 29/94 - M.LAZARE. CLASS - VERSION 2.3. C * CALL ABORT CHANGED TO CALL XIT TO ENABLE C * RUNNING ON PC'S. C * MAY 06/93 - D.VERSEGHY. EXTENSIVE MODIFICATIONS TO CANOPY C * ALBEDO LOOPS. C * MAR 03/92 - D.VERSEGHY/M.LAZARE. REVISED AND VECTORIZED CODE C * FOR MODEL VERSION GCM7. C * AUG 12/91 - D.VERSEGHY. CANOPY ALBEDOS AND TRANSMISSIVITIES. C IMPLICIT NONE C C * INTEGER CONSTANTS. C INTEGER ILG,IL1,IL2,JL,IC,ICP1,IG,IALC,I,J,IPTBAD,JPTBAD,JPTBDI C C * OUTPUT ARRAYS. C REAL ALVSCN(ILG), ALIRCN(ILG), ALVSCS(ILG), ALIRCS(ILG), 1 TRVSCN(ILG), TRIRCN(ILG), TRVSCS(ILG), TRIRCS(ILG), 2 RC (ILG), RCS (ILG) C C * 2-D INPUT ARRAYS. C REAL ALVSC (ILG,ICP1), ALIRC (ILG,ICP1), 1 RSMIN (ILG,IC), QA50 (ILG,IC), 2 VPDA (ILG,IC), VPDB (ILG,IC), 3 PSIGA (ILG,IC), PSIGB (ILG,IC), 4 FCAN (ILG,IC), FCANS (ILG,IC), 5 PAI (ILG,IC), PAIS (ILG,IC), 6 ACVDAT(ILG,IC), ACIDAT(ILG,IC), 7 AIL (ILG,IC) C C * 1-D INPUT ARRAYS. C REAL FC (ILG), FCS (ILG), FSNOW (ILG), FSNOWC(ILG), 1 FSNOCS(ILG), PSIGND(ILG), FCLOUD(ILG), COSZS (ILG), 2 QSWINV(ILG), VPD (ILG), TA (ILG), ALVSGC(ILG), 3 ALIRGC(ILG), ALVSSC(ILG), ALIRSC(ILG) C C * OTHER DATA ARRAYS. C REAL CANEXT(4), XLEAF (4) C C * WORK ARRAYS. C REAL CXTEFF(ILG,IC), RCACC (ILG,IC), 1 RCV (ILG,IC), RCG (ILG,IC), 2 RCT (ILG), GC (ILG), 3 TRVS (ILG), TRIR (ILG) C C * TEMPORARY VARIABLES. C REAL SVF,ALVSCX,ALIRCX,ALVSN,ALIRN,ALVSS,ALIRS, 1 TRTOT,EXPMAX1,EXPMAX2,EXPMAX3 C C * COMMON BLOCK AND OTHER PARAMETERS. C REAL DELT,TFREZ,ALVSWC,ALIRWC, 1 TRCLRV,TRCLDV,TRCLRT,TRCLDT,CXTLRG C COMMON /CLASS1/ DELT,TFREZ COMMON /CLASS7/ CANEXT,XLEAF DATA ALVSWC,ALIRWC,CXTLRG 1 / 0.27, 0.38, 1.0E20 / C---------------------------------------------------------------------- C C * ASSIGN CONSTANT EXPONENTIATION TERMS: EXPMAX1=EXP(-0.4/0.9659), C * EXPMAX2=EXP(-0.4/0.7071),EXPMAX3=EXP(-0.4/0.2588) C EXPMAX1=0.6609 EXPMAX2=0.5680 EXPMAX3=0.2132 C C * INITIALIZE WORK ARRAYS. C DO 50 I=IL1,IL2 RCT(I)=0.0 GC(I)=0.0 RC(I)=0.0 50 CONTINUE DO 100 J=1,IC DO 100 I=IL1,IL2 CXTEFF(I,J)=0.0 RCACC(I,J)=0.0 RCG(I,J)=0.0 RCV(I,J)=0.0 100 CONTINUE C C * ALBEDO AND TRANSMISSIVITY CALCULATIONS FOR CANOPY OVER C * BARE SOIL. C C * NEEDLELEAF TREES. C J=1 DO 150 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCAN(I,J).GT.0.) THEN TRCLRV=EXP(-0.4*PAI(I,J)/COSZS(I)) TRCLDV=0.30*EXP(-0.4*PAI(I,J)/0.9659)+0.50*EXP(-0.4* 1 PAI(I,J)/0.7071)+0.20*EXP(-0.4*PAI(I,J)/0.2588) TRCLRT=EXP(-0.3*PAI(I,J)/COSZS(I)) TRCLDT=0.30*EXP(-0.3*PAI(I,J)/0.9659)+0.50*EXP(-0.3* 1 PAI(I,J)/0.7071)+0.20*EXP(-0.3*PAI(I,J)/0.2588) TRVS(I)=FCLOUD(I)*TRCLDV+(1.0-FCLOUD(I))*TRCLRV IF(TRVS(I).GT.0.0001) THEN CXTEFF(I,J)=-LOG(TRVS(I))/MAX(PAI(I,J),1.0E-5) ELSE CXTEFF(I,J)=CXTLRG ENDIF TRTOT =FCLOUD(I)*TRCLDT+(1.0-FCLOUD(I))*TRCLRT TRIR(I)= 2.*TRTOT-TRVS(I) TRVSCN(I)=TRVSCN(I)+FCAN(I,J)*TRVS(I) TRIRCN(I)=TRIRCN(I)+FCAN(I,J)*TRIR(I) ENDIF 150 CONTINUE C DO 200 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCAN(I,J).GT.0.) THEN SVF=EXP(CANEXT(J)*PAI(I,J)) IF(IALC.EQ.0) THEN ALVSCX=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ALVSC(I,J) ALIRCX=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ALIRC(I,J) ALVSN=(1.0-SVF)*ALVSCX+SVF*TRVS(I)*ALVSGC(I) ALIRN=(1.0-SVF)*ALIRCX+SVF*TRIR(I)*ALIRGC(I) ELSE ALVSCX=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ACVDAT(I,J) ALIRCX=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ACIDAT(I,J) ALVSN=(1.0-SVF)*ALVSCX+SVF*ACVDAT(I,J) ALIRN=(1.0-SVF)*ALIRCX+SVF*ACIDAT(I,J) ENDIF ALVSCN(I)=ALVSCN(I)+FCAN(I,J)*ALVSN ALIRCN(I)=ALIRCN(I)+FCAN(I,J)*ALIRN ENDIF 200 CONTINUE C C * BROADLEAF TREES. C J=2 DO 250 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCAN(I,J).GT.0.) THEN TRCLRV=MIN(EXP(-0.7*PAI(I,J)),EXP(-0.4/COSZS(I))) TRCLDV=0.30*MIN(EXP(-0.7*PAI(I,J)),EXPMAX1) 1 +0.50*MIN(EXP(-0.7*PAI(I,J)),EXPMAX2) 2 +0.20*MIN(EXP(-0.7*PAI(I,J)),EXPMAX3) TRCLRT=MIN(EXP(-0.4*PAI(I,J)),EXP(-0.4/COSZS(I))) TRCLDT=0.30*MIN(EXP(-0.4*PAI(I,J)),EXPMAX1)+ 1 0.50*MIN(EXP(-0.4*PAI(I,J)),EXPMAX2)+ 2 0.20*MIN(EXP(-0.4*PAI(I,J)),EXPMAX3) TRVS(I)=FCLOUD(I)*TRCLDV+(1.0-FCLOUD(I))*TRCLRV IF(TRVS(I).GT.0.0001) THEN CXTEFF(I,J)=-LOG(TRVS(I))/MAX(PAI(I,J),1.0E-5) ELSE CXTEFF(I,J)=CXTLRG ENDIF TRTOT =FCLOUD(I)*TRCLDT+(1.0-FCLOUD(I))*TRCLRT TRIR(I)= 2.*TRTOT-TRVS(I) TRVSCN(I)=TRVSCN(I)+FCAN(I,J)*TRVS(I) TRIRCN(I)=TRIRCN(I)+FCAN(I,J)*TRIR(I) ENDIF 250 CONTINUE C DO 300 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCAN(I,J).GT.0.) THEN SVF=EXP(CANEXT(J)*PAI(I,J)) IF(IALC.EQ.0) THEN ALVSCX=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ALVSC(I,J) ALIRCX=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ALIRC(I,J) ALVSN=(1.0-SVF)*ALVSCX+SVF*TRVS(I)*ALVSGC(I) ALIRN=(1.0-SVF)*ALIRCX+SVF*TRIR(I)*ALIRGC(I) ELSE ALVSCX=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ACVDAT(I,J) ALIRCX=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ACIDAT(I,J) ALVSN=(1.0-SVF)*ALVSCX+SVF*ACVDAT(I,J) ALIRN=(1.0-SVF)*ALIRCX+SVF*ACIDAT(I,J) ENDIF ALVSCN(I)=ALVSCN(I)+FCAN(I,J)*ALVSN ALIRCN(I)=ALIRCN(I)+FCAN(I,J)*ALIRN ENDIF 300 CONTINUE C C * CROPS AND GRASS. C DO 350 J=3,IC DO 350 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCAN(I,J).GT.0.) THEN TRCLRV=EXP(-0.5*PAI(I,J)/COSZS(I)) TRCLDV=0.30*EXP(-0.5*PAI(I,J)/0.9659)+0.50*EXP(-0.5* 1 PAI(I,J)/0.7071)+0.20*EXP(-0.5*PAI(I,J)/0.2588) TRCLRT=EXP(-0.4*PAI(I,J)/COSZS(I)) TRCLDT=0.30*EXP(-0.4*PAI(I,J)/0.9659)+0.50*EXP(-0.4* 1 PAI(I,J)/0.7071)+0.20*EXP(-0.4*PAI(I,J)/0.2588) TRVS(I)=FCLOUD(I)*TRCLDV+(1.0-FCLOUD(I))*TRCLRV IF(TRVS(I).GT.0.0001) THEN CXTEFF(I,J)=-LOG(TRVS(I))/MAX(PAI(I,J),1.0E-5) ELSE CXTEFF(I,J)=CXTLRG ENDIF TRTOT =FCLOUD(I)*TRCLDT+(1.0-FCLOUD(I))*TRCLRT TRIR(I)= 2.*TRTOT-TRVS(I) TRVSCN(I)=TRVSCN(I)+FCAN(I,J)*TRVS(I) TRIRCN(I)=TRIRCN(I)+FCAN(I,J)*TRIR(I) ENDIF 350 CONTINUE C DO 400 J=3,IC DO 400 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCAN(I,J).GT.0.) THEN SVF=EXP(CANEXT(J)*PAI(I,J)) IF(IALC.EQ.0) THEN ALVSCX=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ALVSC(I,J) ALIRCX=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ALIRC(I,J) ALVSN=(1.0-SVF)*ALVSCX+SVF*TRVS(I)*ALVSGC(I) ALIRN=(1.0-SVF)*ALIRCX+SVF*TRIR(I)*ALIRGC(I) ELSE ALVSCX=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ACVDAT(I,J) ALIRCX=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ACIDAT(I,J) ALVSN=(1.0-SVF)*ALVSCX+SVF*ACVDAT(I,J) ALIRN=(1.0-SVF)*ALIRCX+SVF*ACIDAT(I,J) ENDIF ALVSCN(I)=ALVSCN(I)+FCAN(I,J)*ALVSN ALIRCN(I)=ALIRCN(I)+FCAN(I,J)*ALIRN ENDIF 400 CONTINUE C C * TOTAL ALBEDOS. C IPTBAD=0 DO 450 I=IL1,IL2 IF(FC(I).GT.0. .AND. COSZS(I).GT.0.) THEN ALVSCN(I)=ALVSCN(I)/FC(I) ALIRCN(I)=ALIRCN(I)/FC(I) ENDIF IF(ALVSCN(I).GT.1. .OR. ALVSCN(I).LT.0.) IPTBAD=I IF(ALIRCN(I).GT.1. .OR. ALIRCN(I).LT.0.) IPTBAD=I 450 CONTINUE C IF(IPTBAD.NE.0) THEN WRITE(6,6100) IPTBAD,JL,ALVSCN(IPTBAD),ALIRCN(IPTBAD) 6100 FORMAT('0AT (I,J)= (',I3,',',I3,'), ALVSCN,ALIRCN = ',2F10.5) CALL XIT('CANALB',-1) ENDIF C C * TOTAL TRANSMISSIVITIES. C IPTBAD=0 DO 475 I=IL1,IL2 IF(FC(I).GT.0. .AND. COSZS(I).GT.0.) THEN TRVSCN(I)=TRVSCN(I)/FC(I) TRIRCN(I)=TRIRCN(I)/FC(I) TRVSCN(I)=MIN( TRVSCN(I), 0.90*(1.0-ALVSCN(I)) ) TRIRCN(I)=MIN( TRIRCN(I), 0.90*(1.0-ALIRCN(I)) ) ENDIF IF(TRVSCN(I).GT.1. .OR. TRVSCN(I).LT.0.) IPTBAD=I IF(TRIRCN(I).GT.1. .OR. TRIRCN(I).LT.0.) IPTBAD=I 475 CONTINUE C IF(IPTBAD.NE.0) THEN WRITE(6,6300) IPTBAD,JL,TRVSCN(IPTBAD),TRIRCN(IPTBAD) 6300 FORMAT('0AT (I,J)= (',I3,',',I3,'), TRVSCN,TRIRCN = ',2F10.5) CALL XIT('CANALB',-3) ENDIF C---------------------------------------------------------------------- C C * ALBEDO AND TRANSMISSIVITY CALCULATIONS FOR CANOPY OVER SNOW. C C * NEEDLELEAF TREES. C J=1 DO 500 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCANS(I,J).GT.0.) THEN TRCLRV=EXP(-0.4*PAIS(I,J)/COSZS(I)) TRCLDV=0.30*EXP(-0.4*PAIS(I,J)/0.9659)+0.50*EXP(-0.4* 1 PAIS(I,J)/0.7071)+0.20*EXP(-0.4*PAIS(I,J)/0.2588) TRCLRT=EXP(-0.3*PAIS(I,J)/COSZS(I)) TRCLDT=0.30*EXP(-0.3*PAIS(I,J)/0.9659)+0.50*EXP(-0.3* 1 PAIS(I,J)/0.7071)+0.20*EXP(-0.3*PAIS(I,J)/0.2588) TRVS(I)=FCLOUD(I)*TRCLDV+(1.0-FCLOUD(I))*TRCLRV TRTOT =FCLOUD(I)*TRCLDT+(1.0-FCLOUD(I))*TRCLRT TRIR(I)= 2.*TRTOT-TRVS(I) TRVSCS(I)=TRVSCS(I)+FCANS(I,J)*TRVS(I) TRIRCS(I)=TRIRCS(I)+FCANS(I,J)*TRIR(I) ENDIF 500 CONTINUE C DO 550 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCANS(I,J).GT.0.) THEN IF(IALC.EQ.0) THEN ALVSCX=FSNOCS(I)*ALVSWC+(1.0-FSNOCS(I))*ALVSC(I,J) ALIRCX=FSNOCS(I)*ALIRWC+(1.0-FSNOCS(I))*ALIRC(I,J) ELSE ALVSCX=FSNOCS(I)*ALVSWC+(1.0-FSNOCS(I))*ACVDAT(I,J) ALIRCX=FSNOCS(I)*ALIRWC+(1.0-FSNOCS(I))*ACIDAT(I,J) ENDIF SVF=EXP(CANEXT(J)*PAIS(I,J)) ALVSS=(1.0-SVF)*ALVSCX+SVF*TRVS(I)*ALVSSC(I) ALIRS=(1.0-SVF)*ALIRCX+SVF*TRIR(I)*ALIRSC(I) ALVSCS(I)=ALVSCS(I)+FCANS(I,J)*ALVSS ALIRCS(I)=ALIRCS(I)+FCANS(I,J)*ALIRS ENDIF 550 CONTINUE C C * BROADLEAF TREES. C J=2 DO 600 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCANS(I,J).GT.0.) THEN TRCLRV=MIN(EXP(-0.7*PAIS(I,J)),EXP(-0.4/COSZS(I))) TRCLDV=0.30*MIN(EXP(-0.7*PAIS(I,J)),EXPMAX1) 1 +0.50*MIN(EXP(-0.7*PAIS(I,J)),EXPMAX2) 2 +0.20*MIN(EXP(-0.7*PAIS(I,J)),EXPMAX3) TRCLRT=MIN(EXP(-0.4*PAIS(I,J)),EXP(-0.4/COSZS(I))) TRCLDT=0.30*MIN(EXP(-0.4*PAIS(I,J)),EXPMAX1)+ 1 0.50*MIN(EXP(-0.4*PAIS(I,J)),EXPMAX2)+ 2 0.20*MIN(EXP(-0.4*PAIS(I,J)),EXPMAX3) TRVS(I)=FCLOUD(I)*TRCLDV+(1.0-FCLOUD(I))*TRCLRV TRTOT =FCLOUD(I)*TRCLDT+(1.0-FCLOUD(I))*TRCLRT TRIR(I)= 2.*TRTOT-TRVS(I) TRVSCS(I)=TRVSCS(I)+FCANS(I,J)*TRVS(I) TRIRCS(I)=TRIRCS(I)+FCANS(I,J)*TRIR(I) ENDIF 600 CONTINUE C DO 650 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCANS(I,J).GT.0.) THEN IF(IALC.EQ.0) THEN ALVSCX=FSNOCS(I)*ALVSWC+(1.0-FSNOCS(I))*ALVSC(I,J) ALIRCX=FSNOCS(I)*ALIRWC+(1.0-FSNOCS(I))*ALIRC(I,J) ELSE ALVSCX=FSNOCS(I)*ALVSWC+(1.0-FSNOCS(I))*ACVDAT(I,J) ALIRCX=FSNOCS(I)*ALIRWC+(1.0-FSNOCS(I))*ACIDAT(I,J) ENDIF SVF=EXP(CANEXT(J)*PAIS(I,J)) ALVSS=(1.0-SVF)*ALVSCX+SVF*TRVS(I)*ALVSSC(I) ALIRS=(1.0-SVF)*ALIRCX+SVF*TRIR(I)*ALIRSC(I) ALVSCS(I)=ALVSCS(I)+FCANS(I,J)*ALVSS ALIRCS(I)=ALIRCS(I)+FCANS(I,J)*ALIRS ENDIF 650 CONTINUE C C * CROPS AND GRASS. C DO 700 J=3,IC DO 700 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCANS(I,J).GT.0.) THEN TRCLRV=EXP(-0.5*PAIS(I,J)/COSZS(I)) TRCLDV=0.30*EXP(-0.5*PAIS(I,J)/0.9659)+0.50*EXP(-0.5* 1 PAIS(I,J)/0.7071)+0.20*EXP(-0.5*PAIS(I,J)/0.2588) TRCLRT=EXP(-0.4*PAIS(I,J)/COSZS(I)) TRCLDT=0.30*EXP(-0.4*PAIS(I,J)/0.9659)+0.50*EXP(-0.4* 1 PAIS(I,J)/0.7071)+0.20*EXP(-0.4*PAIS(I,J)/0.2588) TRVS(I)=FCLOUD(I)*TRCLDV+(1.0-FCLOUD(I))*TRCLRV TRTOT =FCLOUD(I)*TRCLDT+(1.0-FCLOUD(I))*TRCLRT TRIR(I)= 2.*TRTOT-TRVS(I) TRVSCS(I)=TRVSCS(I)+FCANS(I,J)*TRVS(I) TRIRCS(I)=TRIRCS(I)+FCANS(I,J)*TRIR(I) ENDIF 700 CONTINUE C DO 750 J=3,IC DO 750 I=IL1,IL2 IF(COSZS(I).GT.0. .AND. FCANS(I,J).GT.0.) THEN IF(IALC.EQ.0) THEN ALVSCX=FSNOCS(I)*ALVSWC+(1.0-FSNOCS(I))*ALVSC(I,J) ALIRCX=FSNOCS(I)*ALIRWC+(1.0-FSNOCS(I))*ALIRC(I,J) ELSE ALVSCX=FSNOCS(I)*ALVSWC+(1.0-FSNOCS(I))*ACVDAT(I,J) ALIRCX=FSNOCS(I)*ALIRWC+(1.0-FSNOCS(I))*ACIDAT(I,J) ENDIF SVF=EXP(CANEXT(J)*PAIS(I,J)) ALVSS=(1.0-SVF)*ALVSCX+SVF*TRVS(I)*ALVSSC(I) ALIRS=(1.0-SVF)*ALIRCX+SVF*TRIR(I)*ALIRSC(I) ALVSCS(I)=ALVSCS(I)+FCANS(I,J)*ALVSS ALIRCS(I)=ALIRCS(I)+FCANS(I,J)*ALIRS ENDIF 750 CONTINUE C C * TOTAL ALBEDOS AND CONSISTENCY CHECKS. C IPTBAD=0 DO 775 I=IL1,IL2 IF(FCS(I).GT.0. .AND. COSZS(I).GT.0.) THEN ALVSCS(I)=ALVSCS(I)/FCS(I) ALIRCS(I)=ALIRCS(I)/FCS(I) ENDIF IF(ALVSCS(I).GT.1. .OR. ALVSCS(I).LT.0.) IPTBAD=I IF(ALIRCS(I).GT.1. .OR. ALIRCS(I).LT.0.) IPTBAD=I 775 CONTINUE C C * TOTAL TRANSMISSIVITIES AND CONSISTENCY CHECKS. C IPTBAD=0 JPTBAD=0 DO 800 I=IL1,IL2 IF(FCS(I).GT.0. .AND. COSZS(I).GT.0.) THEN TRVSCS(I)=TRVSCS(I)/FCS(I) TRIRCS(I)=TRIRCS(I)/FCS(I) TRVSCS(I)=MIN( TRVSCS(I), 0.90*(1.0-ALVSCS(I)) ) TRIRCS(I)=MIN( TRIRCS(I), 0.90*(1.0-ALIRCS(I)) ) ENDIF IF(TRVSCS(I).GT.1. .OR. TRVSCS(I).LT.0.) IPTBAD=I IF(TRIRCS(I).GT.1. .OR. TRIRCS(I).LT.0.) IPTBAD=I IF((1.-ALVSCN(I)-TRVSCN(I)).LT.0.) THEN JPTBAD=1000+I JPTBDI=I ENDIF IF((1.-ALVSCS(I)-TRVSCS(I)).LT.0.) THEN JPTBAD=2000+I JPTBDI=I ENDIF IF((1.-ALIRCN(I)-TRIRCN(I)).LT.0.) THEN JPTBAD=3000+I JPTBDI=I ENDIF IF((1.-ALIRCS(I)-TRIRCS(I)).LT.0.) THEN JPTBAD=4000+I JPTBDI=I ENDIF 800 CONTINUE C IF(IPTBAD.NE.0) THEN WRITE(6,6400) IPTBAD,JL,TRVSCS(IPTBAD),TRIRCS(IPTBAD) 6400 FORMAT('0AT (I,J)= (',I3,',',I3,'), TRVSCS,TRIRCS = ',2F10.5) CALL XIT('CANALB',-4) ENDIF C IF(IPTBAD.NE.0) THEN WRITE(6,6200) IPTBAD,JL,ALVSCS(IPTBAD),ALIRCS(IPTBAD) 6200 FORMAT('0AT (I,J)= (',I3,',',I3,'), ALVSCS,ALIRCS = ',2F10.5) CALL XIT('CANALB',-2) ENDIF C IF(JPTBAD.NE.0) THEN WRITE(6,6500) JPTBDI,JL,JPTBAD 6500 FORMAT('0AT (I,J)= (',I3,',',I3,'), JPTBAD = ',I5) CALL XIT('CANALB',-5) ENDIF C----------------------------------------------------------------------- C C * BULK STOMATAL RESISTANCES FOR CANOPY OVERLYING SNOW AND CANOPY C * OVERLYING BARE SOIL. C DO 850 I=IL1,IL2 IF((FCS(I)+FC(I)).GT.0.0) THEN IF(TA(I).LE.268.15) THEN RCT(I)=250. ELSEIF(TA(I).LT.278.15) THEN RCT(I)=1./(1.-(278.15-TA(I))*.1) ELSEIF(TA(I).GT.313.15) THEN IF(TA(I).GE.323.15) THEN RCT(I)=250. ELSE RCT(I)=1./(1.-(TA(I)-313.15)*0.1) ENDIF ELSE RCT(I)=1. ENDIF ENDIF 850 CONTINUE C DO 900 J=1,IC DO 900 I=IL1,IL2 IF(FCAN(I,J).GT.0.) THEN IF(VPD(I).GT.0. .AND. VPDA(I,J).GT.0.0) THEN IF(ABS(VPDB(I,J)).GT.1.0E-5) THEN RCV(I,J)=MAX(1.,((VPD(I)/10.)**VPDB(I,J))/ 1 VPDA(I,J)) ELSE RCV(I,J)=1./EXP(-VPDA(I,J)*VPD(I)/10.) ENDIF ELSE RCV(I,J)=1.0 ENDIF IF(PSIGA(I,J).GT.0.0) THEN RCG(I,J)=1.+(PSIGND(I)/PSIGA(I,J))**PSIGB(I,J) ELSE RCG(I,J)=1.0 ENDIF IF(QSWINV(I).GT.0.01 .AND. COSZS(I).GT.0. .AND. 1 CXTEFF(I,J).GT.1.0E-5 .AND. RCG(I,J).LT.1.0E5) THEN RCACC(I,J)=MIN(CXTEFF(I,J)*RSMIN(I,J)/LOG((QSWINV(I)+ 1 QA50(I,J)/CXTEFF(I,J))/(QSWINV(I)*EXP(-CXTEFF(I,J)* 2 PAI(I,J))+QA50(I,J)/CXTEFF(I,J)))*RCV(I,J)*RCG(I,J)* 3 RCT(I),5000.) RCACC(I,J)=MAX(RCACC(I,J),10.0) ELSE RCACC(I,J)=5000. ENDIF RC(I)=RC(I)+FCAN(I,J)/RCACC(I,J) ENDIF 900 CONTINUE C DO 950 I=IL1,IL2 IF((FCS(I)+FC(I)).GT.0.) THEN IF(QSWINV(I).LT.2.0) THEN RCS(I)=5000.0 RC(I)=5000.0 ELSE RCS(I)=5000.0 IF(RC(I).GT.0) THEN RC(I)=FC(I)/RC(I) ELSE RC(I)=5000.0 ENDIF ENDIF ELSE RC(I)=0.0 RCS(I)=0.0 ENDIF 950 CONTINUE C RETURN END SUBROUTINE TSOLVC(ISNOW,FI, 1 QSWNET,QSWNC,QSWNG,QLWOUT,QLWOC,QLWOG,QTRANS, 2 QSENS,QSENSC,QSENSG,QEVAP,QEVAPC,QEVAPG,EVAPC, 3 EVAPG,EVAP,TCAN,QCAN,TZERO,QZERO,GZERO,QMELTC, 4 QMELTG,RAICAN,SNOCAN,CDH,CDM,RIB,TAC,QAC, 5 CFLUX,FTEMP,FVAP,ILMO,UE,H,QFCF,QFCL,HTCC, 6 QSWINV,QSWINI,QLWIN,TPOTA,TA,QA,VA,VAC,PADRY, 7 RHOAIR,ALVISC,ALNIRC,ALVISG,ALNIRG,TRVISC,TRNIRC, 7 FSVF,CRIB,CPHCHC,CPHCHG,CEVAP,TADP,TVIRTA,RC, 8 RBCOEF,ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM, A FCOR,GCONST,GCOEFF,TGND,TRSNOW,FSNOWC,FRAINC, B CHCAP,CMASS,PCPR,FROOT,THLMIN,DELZW,RHOSNO,ZSNOW, + IWATER,IEVAP,ITERCT, C ISLFD,ITC,ITCG,ILG,IL1,IL2,JL,N, D TSTEP,TVIRTC,TVIRTG,EVBETA,XEVAP,EVPWET,Q0SAT, E RA,RB,RAGINV,RBINV,RBTINV,RBCINV,TVRTAC, F TPOTG,RESID, G TCANO,WZERO,XEVAPM,DCFLXM,WC,DRAGIN,CFLUXM,CFLX, H IEVAPC,TRTOP,QSTOR,CFSENS,CFEVAP,QSGADD,A,B, I LZZ0,LZZ0T,FM,FH,ITER,NITER,KF1,KF2, J AILCG,FCANC,CO2CONC,RMATCTEM, K THLIQ,FIELDSM,WILTSM,ISAND,IG,COSZS,PRESSG, L XDIFFUS,ICTEM,IC,CO2I1,CO2I2, M ICTEMMOD,SLAI,FCANCMX,L2MAX, N NOL2PFTS,CFLUXV,ANVEG,RMLVEG) C C * JUL 22/15 - D.VERSEGHY. LIMIT CALCULATED EVAPORATION RATES C * ACCORDING TO WATER AVAILABILITY. C * JUN 27/14 - D.VERSEGHY. CHANGE ITERATION LIMIT BACK TO 50 FOR C * BISECTION SCHEME; BUGFIX IN CALCULATION C * OF EVPWET. C * OCT 30/12 - V. ARORA - CFLUXV WAS BEING INITIALIZED TO ZERO INAPPROPRIATELY C * FOR MOSAIC RUNS. NOT A PROBLEM WITH COMPOSITE C * RUNS. CREATED A TEMPORARY STORAGE VAR TO ALLOW C * AN APPROPRIATE VALUE FOR THE INITIALIZATION C * SEP 05/12 - J.MELTON. - MADE AN IMPLICIT INT TO REAL CONVERSION C * EXPLICIT. ALSO PROBLEM WITH TAC, SEE NOTE C * IN THE CODE BEFORE CALL TO PHTSYN. C * NOV 11/11 - M.LAZARE. - INCORPORATES CTEM. THIS INVOLVES C * SEVERAL CHANGES AND NEW OUTPUT ROUTINES. C * QSWNVC IS PROMOTED TO A WORK ARRAY C * SINCE PASSED AS INPUT TO THE NEW CALLED C * PHOTOSYNTHESIS ROUTINE "PHTSYN3". THE C * CTEM CANOPY RESISTANCE COMING OUT OF C * THIS ROUTINE, "RCPHTSYN" IS STORED INTO C * THE USUAL "RC" ARRAY AS LONG AS THE C * BONE-DRY SOIL FLAG IS NOT SET (RC=1.E20). C * WE ALSO HAVE TO PASS "TA" THROUGH FROM C * CLASST. FINALLY, "ISAND", "FIELDSM" AND C * "WILTSM" ARE PASSED THROUGH TO PHTSYN3 C * FOR CTEM. C * OCT 14/11 - D.VERSEGHY. FOR POST-ITERATION CLEANUP WITH N-R SCHEME, C * REMOVE CONDITION INVOLVING LAST ITERATION C * TEMPERATURE. C * DEC 07/09 - D.VERSEGHY. RESTORE EVAPOTRANSPIRATION WHEN C * PRECIPITATION IS OCCURRING; ADD EVAPC C * TO EVAP WHEN DEPOSITION OF WATER ON C * CANOPY IS OCCURRING. C * MAR 13/09 - D.VERSEGHY. REPLACE COMMON BLOCK SURFCON WITH CLASSD2; C * REVISED CALL TO FLXSURFZ. C * JAN 20/09 - D.VERSEGHY. CORRECT CALCULATION OF TPOTG. C * JAN 06/09 - E.CHAN/D.VERSEGHY. SET UPPER LIMIT FOR TSTEP IN C * N-R ITERATION SCHEME. C * FEB 26/08 - D.VERSEGHY. STREAMLINE SOME CALCULATIONS; REMOVE C * "ILW" SWITCH; SUPPRESS WATER VAPOUR FLUX C * IF PRECIPITATION IS OCCURRING. C * FEB 19/07 - D.VERSEGHY. UPDATE CANOPY WATER STORES IN THIS C * ROUTINE INSTEAD OF CANADD FOR CASES C * OF WATER DEPOSITION. C * MAY 17/06 - D.VERSEGHY. ADD IL1 AND IL2 TO CALL TO FLXSURFZ; C * REMOVE JL FROM CALL TO DRCOEF. C * APR 15/05 - D.VERSEGHY. SUBLIMATION OF INTERCEPTED SNOW TAKES C * PLACE BEFORE EVAPORATION OF INTERCEPTED C * RAIN. C * APR 14/05 - Y.DELAGE. REFINEMENTS TO N-R ITERATION SCHEME. C * FEB 23/05 - D.VERSEGHY. INCORPORATE A SWITCH TO USE EITHER THE C * BISECTION ITERATION SCHEME WITH CANOPY C * AIR PARAMETRIZATION, OR THE NEWTON- C * RAPHSON ITERATION SCHEME WITH MODIFIED C * ZOH. C * JAN 31/05 - Y.DELAGE. USE THE CANOPY AIR RESISTANCE TO CALCULATE A C * ROUGHNESS LENGTH FOR TEMPERATURE AND HUMIDITY. C * REPLACE SECANT METHOD BY NEWTON-RAPHSON SCHEME C * FOR BOTH ITERATION LOOPS. C * LIMIT NUMBER OF ITERATIONS (ITERMX) TO 5 AND C * APPLY CORRECTIONS IF RESIDUE REMAINS. C * JAN 12/05 - P.BARTLETT/D.VERSEGHY. MODIFICATION TO CALCULATION C * OF RBINV; ALLOW SUBLIMATION OF FROZEN C * WATER ONLY ONTO SNOW-COVERED PORTION C * OF CANOPY. C * NOV 04/04 - D.VERSEGHY. ADD "IMPLICIT NONE" COMMAND. C * AUG 06/04 - Y.DELAGE/D.VERSEGHY. PROTECT SENSITIVE CALCULATIONS C * FROM ROUNDOFF ERRORS. C * NOV 07/02 - Y.DELAGE/D.VERSEGHY. NEW CALL TO FLXSURFZ; VIRTUAL C * AND POTENTIAL TEMPERATURE CORRECTIONS. C * NOV 01/02 - P.BARTLETT. MODIFICATIONS TO CALCULATIONS OF QAC C * AND RB. C * JUL 26/02 - D.VERSEGHY. SHORTENED CLASS4 COMMON BLOCK. C * MAR 28/02 - D.VERSEGHY. STREAMLINED SUBROUTINE CALL. C * MAR 10/02 - M.LAZARE. VECTORIZE LOOP 650 BY SPLITTING INTO TWO. C * JAN 18/02 - P.BARTLETT/D.VERSEGHY. NEW "BETA" FORMULATION FOR C * BARE SOIL EVAPORATION BASED ON LEE AND C * PIELKE. C * APR 11/01 - M.LAZARE. SHORTENED "CLASS2" COMMON BLOCK. C * OCT 06/00 - D.VERSEGHY. CONDITIONAL "IF" IN ITERATION SEQUENCE C * TO AVOID DIVIDE BY ZERO. C * DEC 16/99 - A.WU/D.VERSEGHY. REVISED CANOPY TURBULENT FLUX C * FORMULATION: ADD PARAMETRIZATION C * OF CANOPY AIR TEMPERATURE. C * DEC 07/99 - A.WU/D.VERSEGHY. NEW SOIL EVAPORATION FORMULATION. C * JUL 24/97 - D.VERSEGHY. CLASS - VERSION 2.7. C * REPLACE BISECTION METHOD IN SURFACE C * TEMPERATURE ITERATION SCHEME WITH C * SECANT METHOD FOR FIRST TEN ITERATIONS. C * PASS QZERO,QA,ZOMS,ZOHS TO REVISED C * DRCOEF (ZOMS AND ZOHS ALSO NEW WORK ARRAYS C * PASSED TO THIS ROUTINE). C * JUN 20/97 - D.VERSEGHY. PASS IN NEW "CLASS4" COMMON BLOCK. C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5. C * COMPLETION OF ENERGY BALANCE C * DIAGNOSTICS. ALSO, PASS SWITCH "ILW" C * THROUGH SUBROUTINE CALL, SPECIFYING C * WHETHER QLWIN REPRESENTS INCOMING C * (ILW=1) OR NET (ILW=2) LONGWAVE C * RADIATION ABOVE THE GROUND. C * NOV 30/94 - M.LAZARE. CLASS - VERSION 2.3. C * NEW DRAG COEFFICIENT AND RELATED FIELDS, C * NOW DETERMINED IN ROUTINE "DRCOEF". C * OCT 04/94 - D.VERSEGHY. CHANGE "CALL ABORT" TO "CALL XIT" TO C * ENABLE RUNNING ON PCS. C * JAN 24/94 - M.LAZARE. UNFORMATTED I/O COMMENTED OUT IN LOOPS C * 200 AND 600. C * JUL 29/93 - D.VERSEGHY. CLASS - VERSION 2.2. C * ADD TRANSMISSION THROUGH SNOWPACK TO C * "QSWNET" FOR DIAGNOSTIC PURPOSES. C * OCT 15/92 - D.VERSEGHY/M.LAZARE. CLASS - VERSION 2.1. C * REVISED AND VECTORIZED CODE C * FOR MODEL VERSION GCM7. C * AUG 12/91 - D.VERSEGHY. ITERATIVE TEMPERATURE CALCULATIONS C * FOR VEGETATION CANOPY AND UNDERLYING C * SURFACE. C IMPLICIT NONE C C * INTEGER CONSTANTS. C INTEGER ISNOW,ISLFD,ITC,ITCG,ILG,IL1,IL2,JL,I,J,N,KK C INTEGER NUMIT,IBAD,NIT,ITERMX C C * OUTPUT ARRAYS. C REAL QSWNET(ILG), QSWNC (ILG), QSWNG (ILG), QLWOUT(ILG), 1 QLWOC (ILG), QLWOG (ILG), QTRANS(ILG), QSENS (ILG), 2 QSENSC(ILG), QSENSG(ILG), QEVAP (ILG), QEVAPC(ILG), 3 QEVAPG(ILG), EVAPC (ILG), EVAPG (ILG), TCAN (ILG), 4 QCAN (ILG), TZERO (ILG), QZERO (ILG), GZERO (ILG), 5 QMELTC(ILG), QMELTG(ILG), RAICAN(ILG), SNOCAN(ILG), 6 CDH (ILG), CDM (ILG), RIB (ILG), TAC (ILG), 7 QAC (ILG), CFLUX (ILG), FTEMP (ILG), FVAP (ILG), 8 ILMO (ILG), UE (ILG), H (ILG), 9 QFCF (ILG), QFCL (ILG), HTCC (ILG), EVAP (ILG) C C * INPUT ARRAYS. C REAL FI (ILG), QSWINV(ILG), QSWINI(ILG), QLWIN (ILG), 1 TPOTA (ILG), TA (ILG), QA (ILG), VA (ILG), 2 VAC (ILG), PADRY (ILG), RHOAIR(ILG), ALVISC(ILG), 3 ALNIRC(ILG), ALVISG(ILG), ALNIRG(ILG), TRVISC(ILG), 4 TRNIRC(ILG), FSVF (ILG), CRIB (ILG), CPHCHC(ILG), 5 CPHCHG(ILG), CEVAP (ILG), TADP (ILG), TVIRTA(ILG), 6 RC (ILG), RBCOEF(ILG), ZOSCLH(ILG), ZOSCLM(ILG), 7 ZRSLFH(ILG), ZRSLFM(ILG), ZOH (ILG), ZOM (ILG), 8 FCOR (ILG), GCONST(ILG), GCOEFF(ILG), TGND (ILG), 9 TRSNOW(ILG), FSNOWC(ILG), FRAINC(ILG), CHCAP (ILG), A CMASS (ILG), PCPR (ILG), RHOSNO(ILG), ZSNOW (ILG) C REAL FROOT (ILG,IG), THLMIN(ILG,IG), DELZW(ILG,IG) C INTEGER IWATER(ILG), IEVAP (ILG), 1 ITERCT(ILG,6,50) C C * ARRAYS FOR CTEM. C C * AILCG - GREEN LAI FOR CARBON PURPOSES C * FCANC - FRACTIONAL COVERAGE OF 8 CARBON PFTs C * CO2CONC - ATMOS. CO2 CONC. IN PPM C * RMATCTEM - FRACTION OF ROOTS IN EACH SOIL LAYER FOR EACH OF THE 8 PFTs C FOR CARBON RELATED PURPOSES. C * RCPHTSYN - STOMATAL RESISTANCE ESTIMATED BY THE PHTSYN SUBROUTINE, S/M C * COSZS - COS OF SUN'S ZENITH ANGLE C * XDIFFUS - FRACTION OF DIFFUSED RADIATION C * CO2I1 - INTERCELLULAR CO2 CONC.(PA) FOR THE SINGLE/SUNLIT LEAF C * CO2I2 - INTERCELLULAR CO2 CONC.(PA) FOR THE SHADED LEAF C * CTEM1 - LOGICAL BOOLEAN FOR USING CTEM's STOMATAL RESISTANCE C OR NOT C * CTEM2 - LOGICAL BOOLEAN FOR USING CTEM's STRUCTURAL ATTRIBUTES C OR NOT C * SLAI - STORAGE LAI. SEE PHTSYN SUBROUTINE FOR MORE DETAILS. C * FCANCMX - MAX. FRACTIONAL COVERAGE OF CTEM PFTs C * L2MAX - MAX. NUMBER OF LEVEL 2 CTEM PFTs C * NOL2PFTS - NUMBER OF LEVEL 2 CTEM PFTs C * ANVEG - NET PHTOSYNTHETIC RATE, u-MOL/M^2/S, FOR CTEM's 8 PFTs C * RMLVEG - LEAF MAINTENANCE RESP. RATE, u-MOL/M^2/S, FOR CTEM's 8 PFTs C REAL AILCG(ILG,ICTEM), FCANC(ILG,ICTEM), CO2CONC(ILG), 1 CO2I1(ILG,ICTEM), CO2I2(ILG,ICTEM), COSZS(ILG), 3 PRESSG(ILG), XDIFFUS(ILG), SLAI(ILG,ICTEM), 4 RMATCTEM(ILG,ICTEM,IG), FCANCMX(ILG,ICTEM), 5 ANVEG(ILG,ICTEM), RMLVEG(ILG,ICTEM), THLIQ(ILG,IG), 6 FIELDSM(ILG,IG), WILTSM(ILG,IG), CFLUXV(ILG), 7 CFLUXV_IN(ILG) INTEGER ISAND(ILG,IG) C INTEGER ICTEM, ICTEMMOD, L2MAX, NOL2PFTS(IC), IC, IG C C * LOCAL WORK ARRAYS FOR CTEM. C REAL RCPHTSYN(ILG), QSWNVC(ILG) C C * GENERAL INTERNAL WORK ARRAYS. C REAL TSTEP (ILG), TVIRTC(ILG), TVIRTG(ILG), 1 EVBETA(ILG), XEVAP (ILG), EVPWET(ILG), Q0SAT (ILG), 2 RA (ILG), RB (ILG), RAGINV(ILG), RBINV (ILG), 3 RBTINV(ILG), RBCINV(ILG), TVRTAC(ILG), 4 TPOTG (ILG), RESID (ILG), TCANO (ILG), 5 TRTOP (ILG), QSTOR (ILG), A (ILG), B (ILG), 6 LZZ0 (ILG), LZZ0T (ILG), 7 FM (ILG), FH (ILG), WZERO (ILG), XEVAPM(ILG), 8 DCFLXM(ILG), WC (ILG), DRAGIN(ILG), CFLUXM(ILG), 9 CFSENS(ILG), CFEVAP(ILG), QSGADD(ILG), CFLX (ILG), A EVPMAX(ILG), WTRTOT(ILG) C REAL WAVAIL(ILG,IG), WROOT (ILG,IG) C INTEGER ITER (ILG), NITER (ILG), IEVAPC(ILG), 1 KF1 (ILG), KF2 (ILG) C C * TEMPORARY VARIABLES. C REAL QSWNVG,QSWNIG,QSWNIC,HFREZ,HCONV, 1 RCONV,HCOOL,HMELT,SCONV,HWARM,WCAN,DQ0DT, 2 DRDT0,QEVAPT,BOWEN,DCFLUX,DXEVAP,TCANT,QEVAPCT, 3 TZEROT,YEVAP,RAGCO,EZERO,WTRANSP,WTEST C C * COMMON BLOCK PARAMETERS. C REAL DELT,TFREZ,RGAS,RGASV,GRAV,SBC,VKC,CT,VMIN,HCPW,HCPICE, 1 HCPSOL,HCPOM,HCPSND,HCPCLY,SPHW,SPHICE,SPHVEG,SPHAIR, 2 RHOW,RHOICE,TCGLAC,CLHMLT,CLHVAP,DELTA,CGRAV,CKARM,CPD, 3 AS,ASX,CI,BS,BETA,FACTN,HMIN,ANGMAX C COMMON /CLASS1/ DELT,TFREZ COMMON /CLASS2/ RGAS,RGASV,GRAV,SBC,VKC,CT,VMIN COMMON /CLASS4/ HCPW,HCPICE,HCPSOL,HCPOM,HCPSND,HCPCLY, 1 SPHW,SPHICE,SPHVEG,SPHAIR,RHOW,RHOICE, 2 TCGLAC,CLHMLT,CLHVAP COMMON /PHYCON/ DELTA,CGRAV,CKARM,CPD COMMON /CLASSD2/ AS,ASX,CI,BS,BETA,FACTN,HMIN,ANGMAX C C----------------------------------------------------------------------- C * INITIALIZATION AND PRE-ITERATION SEQUENCE. C===================== CTEM =====================================\ C DO I = 1,ILG QSWNVC(I)=0.0 ENDDO C===================== CTEM =====================================/ C IF(ITCG.LT.2) THEN ITERMX=50 ELSE ITERMX=5 ENDIF C IF(ISNOW.EQ.0) THEN C EZERO=0.0 C ELSE C EZERO=2.0 C ENDIF EZERO=0.0 RAGCO=1.9E-3 C DO 50 I=IL1,IL2 IF(FI(I).GT.0.) THEN IF(ISNOW.EQ.0) THEN TRTOP(I)=0. ELSE TRTOP(I)=TRSNOW(I) ENDIF QSWNVG=QSWINV(I)*TRVISC(I)*(1.0-ALVISG(I)) QSWNIG=QSWINI(I)*TRNIRC(I)*(1.0-ALNIRG(I)) QSWNG(I)=QSWNVG+QSWNIG QTRANS(I)=QSWNG(I)*TRTOP(I) QSWNG(I)=QSWNG(I)-QTRANS(I) QSWNVC(I)=QSWINV(I)*(1.0-ALVISC(I))-QSWNVG QSWNIC=QSWINI(I)*(1.0-ALNIRC(I))-QSWNIG QSWNC(I)=QSWNVC(I)+QSWNIC IF(ABS(TCAN(I)).LT.1.0E-3) TCAN(I)=TPOTA(I) QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I) C IF(TCAN(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/ 1 (TCAN(I)-B(I)))/PADRY(I) QCAN(I)=WCAN/(1.0+WCAN) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) IF(ITC.EQ.2) THEN TAC(I)=TCAN(I) QAC(I)=QA(I) ENDIF TVRTAC(I)=TAC(I)*(1.0+0.61*QAC(I)) C IF(SNOCAN(I).GT.0.) THEN CPHCHC(I)=CLHVAP+CLHMLT ELSE CPHCHC(I)=CLHVAP ENDIF RBINV(I)=RBCOEF(I)*SQRT(VAC(I)) RB(I)=1.0/RBINV(I) TZERO(I)=TGND(I) TCANO(I)=TCAN(I) TSTEP(I)=1.0 ITER(I)=1 NITER(I)=1 QMELTC(I)=0.0 QMELTG(I)=0.0 IF(ISNOW.EQ.1) THEN KF1(I)=1 KF2(I)=2 EVPMAX(I)=RHOSNO(I)*ZSNOW(I)/DELT ELSE KF1(I)=4 KF2(I)=5 EVPMAX(I)=RHOW*(THLIQ(I,1)-THLMIN(I,1))*DELZW(I,1)/ 1 DELT EVPMAX(I)=MAX(EVPMAX(I),0.) ENDIF ENDIF 50 CONTINUE C C * CALL PHOTOSYNTHESIS SUBROUTINE HERE TO GET A NEW ESTIMATE OF C * RC BASED ON PHOTOSYNTHESIS. C IF(ICTEMMOD.EQ.1) THEN C C STORE CFLUXV NUMBERS IN A TEMPORARY ARRAY DO I = IL1, IL2 CFLUXV_IN(I)=CFLUXV(I) ENDDO C C NOTE: FOR NOW, CTEM IS USING TA INSTEAD OF TCAN (THE SUB OCCURS C IN PHTSYN). JM 11/09/12. (THIS IS CURRENTLY UNDER REVIEW.) C CALL PHTSYN3( AILCG, FCANC, TCAN, CO2CONC, PRESSG, FI, 1 CFLUXV, QA, QSWNVC, IC, THLIQ, ISAND, 2 TA, RMATCTEM, COSZS, XDIFFUS, ILG, 3 IL1, IL2, IG, ICTEM, ISNOW, SLAI, 4 FIELDSM,WILTSM, FCANCMX, L2MAX,NOL2PFTS, 5 RCPHTSYN, CO2I1, CO2I2, ANVEG, RMLVEG) C C * KEEP CLASS RC FOR BONEDRY POINTS (DIANA'S FLAG OF 1.E20) SUCH C * THAT WE GET (BALT-BEG) CONSERVATION. C DO 70 I =IL1,IL2 C IF(RC(I).LE.10000.) THEN !FLAG, TURNING ON CAUSES A MAJOR PROBLEM C WHEN THERE IS VEG WITH NO ROOTS. VA & JM OCT2012 RC(I)=MIN(RCPHTSYN(I),4999.999) C ENDIF 70 CONTINUE ENDIF C C * ITERATION FOR SURFACE TEMPERATURE OF GROUND UNDER CANOPY. C * LOOP IS REPEATED UNTIL SOLUTIONS HAVE BEEN FOUND FOR ALL POINTS C * ON THE CURRENT LATITUDE CIRCLE(S). C 100 CONTINUE C NUMIT=0 DO 125 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN IF(TZERO(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WZERO(I)=0.622*611.0*EXP(A(I)*(TZERO(I)-TFREZ)/ 1 (TZERO(I)-B(I)))/PADRY(I) Q0SAT(I)=WZERO(I)/(1.0+WZERO(I)) IF(IWATER(I).GT.0) THEN EVBETA(I)=1.0 QZERO(I)=Q0SAT(I) ELSE EVBETA(I)=CEVAP(I) QZERO(I)=EVBETA(I)*Q0SAT(I)+(1.0-EVBETA(I))*QAC(I) IF(QZERO(I).GT.QAC(I) .AND. IEVAP(I).EQ.0) THEN EVBETA(I)=0.0 QZERO(I)=QAC(I) ENDIF ENDIF C TPOTG(I)=TZERO(I)-8.0*ZOM(I)*GRAV/CPD TVIRTG(I)=TPOTG(I)*(1.0+0.61*QZERO(I)) IF(TVIRTG(I).GT.TVRTAC(I)+1.) THEN RAGINV(I)=RAGCO*(TVIRTG(I)-TVRTAC(I))**0.333333 DRAGIN(I)=0.333*RAGCO*(TVIRTG(I)-TVRTAC(I))**(-.667) ELSEIF(TVIRTG(I).GT.(TVRTAC(I)+0.001)) THEN RAGINV(I)=RAGCO*(TVIRTG(I)-TVRTAC(I)) DRAGIN(I)=RAGCO ELSE RAGINV(I)=0.0 DRAGIN(I)=0.0 ENDIF C QLWOG(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I) QSENSG(I)=RHOAIR(I)*SPHAIR*RAGINV(I)* 1 (TPOTG(I)-TAC(I)) EVAPG (I)=RHOAIR(I)*(QZERO(I)-QAC(I))*RAGINV(I) IF(EVAPG(I).GT.EVPMAX(I)) EVAPG(I)=EVPMAX(I) QEVAPG(I)=CPHCHG(I)*EVAPG(I) GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I) RESID(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))* 1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I)-GZERO(I) IF(ABS(RESID(I)).LT.5.0) ITER(I)=0 IF(ABS(TSTEP(I)).LT.1.0E-2) ITER(I)=0 IF(NITER(I).EQ.ITERMX .AND. ITER(I).EQ.1) ITER(I)=-1 ENDIF 125 CONTINUE C IF(ITCG.LT.2) THEN C C * OPTION #1: BISECTION ITERATION METHOD. C DO 150 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN IF(NITER(I).EQ.1) THEN IF(RESID(I).GT.0.0) THEN TZERO(I)=TZERO(I)+TSTEP(I) ELSE TZERO(I)=TZERO(I)-TSTEP(I) ENDIF ELSE IF((RESID(I).GT.0. .AND. TSTEP(I).LT.0.) .OR. 1 (RESID(I).LT.0. .AND. TSTEP(I).GT.0.)) THEN TSTEP(I)=-TSTEP(I)/2.0 ENDIF TZERO(I)=TZERO(I)+TSTEP(I) ENDIF NITER(I)=NITER(I)+1 NUMIT=NUMIT+1 ENDIF 150 CONTINUE C ELSE C C * OPTION #2: NEWTON-RAPHSON ITERATION METHOD. C DO 175 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN DQ0DT=-WZERO(I)*A(I)*(B(I)-TFREZ)/((TZERO(I)-B(I))* 1 (1.0+WZERO(I)))**2*EVBETA(I) DRDT0=-4.0*SBC*TZERO(I)**3 1 -GCOEFF(I)-RHOAIR(I)*SPHAIR* 2 (RAGINV(I)+(TPOTG(I)-TAC(I))*DRAGIN(I))- 3 CPHCHG(I)*RHOAIR(I)*(DQ0DT*RAGINV(I) 4 +(QZERO(I)-QAC(I))*DRAGIN(I)) TSTEP(I)=-RESID(I)/DRDT0 IF(ABS(TSTEP(I)).GT.20.0) TSTEP(I)=SIGN(10.0,TSTEP(I)) TZERO(I)=TZERO(I)+TSTEP(I) NITER(I)=NITER(I)+1 NUMIT=NUMIT+1 ENDIF 175 CONTINUE C ENDIF C IF(NUMIT.GT.0) GO TO 100 C C * IF CONVERGENCE HAS NOT BEEN REACHED FOR ITERATION METHOD #2, C * CALCULATE TEMPERATURE AND FLUXES ASSUMING NEUTRAL STABILITY C * AND USING BOWEN RATIO APPROACH. C IF(ITCG.EQ.2) THEN C DO 200 I=IL1,IL2 IF(ITER(I).EQ.-1) THEN TZEROT=TVIRTC(I)/(1.0+0.61*QZERO(I)) IF(ABS(RESID(I)).GT.15.) THEN TZERO(I)=TZEROT IF(TZERO(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WZERO(I)=0.622*611.0*EXP(A(I)*(TZERO(I)-TFREZ)/ 1 (TZERO(I)-B(I)))/PADRY(I) Q0SAT(I)=WZERO(I)/(1.0+WZERO(I)) QZERO(I)=EVBETA(I)*Q0SAT(I)+(1.0-EVBETA(I))*QAC(I) QLWOG(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I) GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I) RESID(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))* 1 QLWOC(I)-QLWOG(I)-GZERO(I) QEVAPT=CPHCHG(I)*(QZERO(I)-QAC(I)) BOWEN=SPHAIR*(TZERO(I)-TAC(I))/ 1 SIGN(MAX(ABS(QEVAPT),1.E-6),QEVAPT) QEVAPG(I)=RESID(I)/SIGN(MAX(ABS(1.+BOWEN),0.1),1.+BOWEN) QSENSG(I)=RESID(I)-QEVAPG(I) RESID(I)=0. EVAPG(I)=QEVAPG(I)/CPHCHG(I) ENDIF ENDIF 200 CONTINUE C ENDIF C IBAD=0 C DO 225 I=IL1,IL2 C IF(FI(I).GT.0. .AND. ITER(I).EQ.-1) THEN C WRITE(6,6250) I,JL,NITER(I),RESID(I),TZERO(I),RIB(I) C6250 FORMAT('0SUBCAN ITERATION LIMIT',3X,3I3,3(F8.2,E12.4)) C ENDIF IF(FI(I).GT.0.) THEN IF(TZERO(I).LT.173.16 .OR. TZERO(I).GT.373.16) THEN IBAD=I ENDIF ENDIF 225 CONTINUE C IF(IBAD.NE.0) THEN WRITE(6,6370) IBAD,N,TZERO(IBAD),NITER(IBAD),ISNOW 6370 FORMAT('0BAD GROUND ITERATION TEMPERATURE',3X,2I8,F16.2,2I4) WRITE(6,6380) QSWNG(IBAD),FSVF(IBAD),QLWIN(IBAD),QLWOC(IBAD), 1 QLWOG(IBAD),QSENSG(IBAD),QEVAPG(IBAD),GZERO(IBAD) WRITE(6,6380) TCAN(IBAD) CALL XIT('TSOLVC',-1) ENDIF C C * POST-ITERATION CLEAN-UP. C DO 250 I=IL1,IL2 IF(FI(I).GT.0.) THEN IF((IWATER(I).EQ.1 .AND. TZERO(I).LT.TFREZ) .OR. 1 (IWATER(I).EQ.2 .AND. TZERO(I).GT.TFREZ)) THEN TZERO(I)=TFREZ WZERO(I)=0.622*611.0/PADRY(I) QZERO(I)=WZERO(I)/(1.0+WZERO(I)) TPOTG(I)=TZERO(I)-8.0*ZOM(I)*GRAV/CPD TVIRTG(I)=TPOTG(I)*(1.0+0.61*QZERO(I)) C QLWOG(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I) GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I) IF(TVIRTG(I).GT.(TVRTAC(I)+0.001)) THEN RAGINV(I)=RAGCO*(TVIRTG(I)-TVRTAC(I))**0.333333 QSENSG(I)=RHOAIR(I)*SPHAIR*RAGINV(I)* 1 (TPOTG(I)-TAC(I)) EVAPG (I)=RHOAIR(I)*(QZERO(I)-QAC(I))*RAGINV(I) ELSE RAGINV(I)=0.0 QSENSG(I)=0.0 EVAPG (I)=0.0 ENDIF IF(EVAPG(I).GT.EVPMAX(I)) EVAPG(I)=EVPMAX(I) QEVAPG(I)=CPHCHG(I)*EVAPG(I) QMELTG(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))* 1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I)-GZERO(I) RESID(I)=0.0 ENDIF C IF(ABS(EVAPG(I)).LT.1.0E-8) THEN RESID(I)=RESID(I)+QEVAPG(I) EVAPG(I)=0.0 QEVAPG(I)=0.0 ENDIF C IF(RESID(I).GT.15. .AND. QEVAPG(I).GT.10. .AND. PCPR(I) C 1 .LT.1.0E-8) THEN C QEVAPG(I)=QEVAPG(I)+RESID(I) C ELSE QSENSG(I)=QSENSG(I)+RESID(I) C ENDIF ITERCT(I,KF2(I),NITER(I))=ITERCT(I,KF2(I),NITER(I))+1 ENDIF 250 CONTINUE C C * PRE-ITERATION SEQUENCE FOR VEGETATION CANOPY. C DO 300 I=IL1,IL2 IF(FI(I).GT.0.) THEN QSGADD(I)=0.0 IF(ITC.EQ.2) THEN QSGADD(I)=QSENSG(I) TAC(I)=TCAN(I) QAC(I)=QCAN(I) TVRTAC(I)=TVIRTC(I) ENDIF ITER(I)=1 NITER(I)=1 TSTEP(I)=1.0 CFLUXM(I)=0.0 DCFLXM(I)=0.0 WTRTOT(I)=0.0 ENDIF 300 CONTINUE C DO 350 J=1,IG DO 350 I=IL1,IL2 IF(FI(I).GT.0.) THEN WAVAIL(I,J)=RHOW*(THLIQ(I,J)-THLMIN(I,J))*DELZW(I,J) IF(J.EQ.1 .AND. EVAPG(I).GT.0.0) 1 WAVAIL(I,J)=WAVAIL(I,J)-EVAPG(I)*DELT WAVAIL(I,J)=MAX(WAVAIL(I,J),0.) WROOT(I,J)=0.0 ENDIF 350 CONTINUE C IF(ITC.LT.2) THEN ITERMX=50 ELSE ITERMX=5 ENDIF C C * ITERATION FOR CANOPY TEMPERATURE. C * LOOP IS REPEATED UNTIL SOLUTIONS HAVE BEEN FOUND FOR ALL POINTS C * ON THE CURRENT LATITUDE CIRCLE(S). C 400 CONTINUE C NUMIT=0 NIT=0 DO 450 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN NIT=NIT+1 IF(ITC.EQ.1) THEN IF(TCAN(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/ 1 (TCAN(I)-B(I)))/PADRY(I) QCAN(I)=WCAN/(1.0+WCAN) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) ENDIF ENDIF 450 CONTINUE C IF(NIT.GT.0) THEN C C * CALCULATE SURFACE DRAG COEFFICIENTS (STABILITY-DEPENDENT) C * AND OTHER RELATED QUANTITIES BETWEEN CANOPY AIR SPACE AND C * ATMOSPHERE. C IF(ISLFD.LT.2) THEN CALL DRCOEF(CDM,CDH,RIB,CFLUX,QAC,QA,ZOSCLM,ZOSCLH, 1 CRIB,TVRTAC,TVIRTA,VA,FI,ITER, 2 ILG,IL1,IL2) ELSE CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO, 1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA, 2 TAC,QAC,H,ZOM,ZOH, 3 LZZ0,LZZ0T,FM,FH,ILG,IL1,IL2,FI,ITER,JL ) ENDIF C C * CALCULATE CANOPY AIR TEMPERATURE AND SPECIFIC HUMIDITY OF C * CANOPY AIR (FIRST WITHOUT RC TO CHECK FOR CONDENSATION; C * IF NO CONDENSATION EXISTS, RECALCULATE). C IF(ITC.EQ.1) THEN C DO 475 I=IL1,IL2 IF (FI(I).GT.0. .AND. ITER(I).EQ.1) THEN XEVAP(I)=RBINV(I) QAC(I)=(QCAN(I)*XEVAP(I)+QZERO(I)*RAGINV(I)+ 1 QA(I)*CFLUX(I))/(XEVAP(I)+RAGINV(I)+CFLUX(I)) IF(QAC(I).LT.QCAN(I)) THEN IF(FSNOWC(I).GT.0.0) THEN XEVAP(I)=(FRAINC(I)+FSNOWC(I))/RB(I) ELSE XEVAP(I)=FRAINC(I)/RB(I)+(1.0-FRAINC(I))/ 1 (RB(I)+RC(I)) QAC(I)=(QCAN(I)*XEVAP(I)+QZERO(I)*RAGINV(I)+ 1 QA(I)*CFLUX(I))/(XEVAP(I)+RAGINV(I)+ 2 CFLUX(I)) ENDIF ELSE IF(FSNOWC(I).GT.1.0E-5) THEN XEVAP(I)=FSNOWC(I)/RB(I) ELSE XEVAP(I)=1.0/RB(I) ENDIF ENDIF TAC(I)=(TCAN(I)*RBINV(I)+TPOTG(I)*RAGINV(I)+ 1 TPOTA(I)*CFLUX(I))/(RBINV(I)+RAGINV(I)+CFLUX(I)) TVRTAC(I)=TAC(I)*(1.0+0.61*QAC(I)) CFSENS(I)=RBINV(I) CFEVAP(I)=XEVAP(I) ENDIF 475 CONTINUE C ELSE C DO 500 I=IL1,IL2 IF (FI(I).GT.0. .AND. ITER(I).EQ.1) THEN CFLX(I)=RBINV(I)*CFLUX(I)/(RBINV(I)+CFLUX(I)) CFLX(I)=CFLUX(I)+(CFLX(I)-CFLUX(I))* 1 MIN(1.0,QSWINV(I)*0.04) RA(I)=1.0/CFLX(I) IF(QA(I).LT.QCAN(I)) THEN IF(FSNOWC(I).GT.0.0) THEN XEVAP(I)=(FRAINC(I)+FSNOWC(I))/RA(I) ELSE XEVAP(I)=FRAINC(I)/RA(I)+(1.0-FRAINC(I))/ 1 (RA(I)+RC(I)) ENDIF ELSE IF(FSNOWC(I).GT.1.0E-5) THEN XEVAP(I)=FSNOWC(I)/RA(I) ELSE XEVAP(I)=1.0/RA(I) ENDIF ENDIF IF(TCAN(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/ 1 (TCAN(I)-B(I)))/PADRY(I) WC(I)=WCAN QCAN(I)=WCAN/(1.0+WCAN) QCAN(I)=RA(I)*XEVAP(I)*QCAN(I)+(1.0-RA(I)*XEVAP(I))* 1 QA(I) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) CFSENS(I)=CFLX(I) CFEVAP(I)=CFLX(I) TAC(I)=TPOTA(I) QAC(I)=QA(I) ENDIF 500 CONTINUE C ENDIF C C * CALCULATE THE TERMS IN THE ENERGY BALANCE AND SOLVE. C DO 525 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I) QSENSC(I)=RHOAIR(I)*SPHAIR*CFSENS(I)*(TCAN(I)-TAC(I)) IF(FRAINC(I).GT.0. .OR. FSNOWC(I).GT.0. .OR. 1 RC(I).LE.5000. .OR. QAC(I).GT.QCAN(I)) THEN EVAPC(I)=RHOAIR(I)*CFEVAP(I)*(QCAN(I)-QAC(I)) IEVAPC(I)=1 ELSE EVAPC(I)=0.0 IEVAPC(I)=0 QCAN(I)=QA(I) ENDIF IF(EVAPC(I).LT.0. .AND. TCAN(I).GT.TADP(I)) EVAPC(I)=0.0 IF(SNOCAN(I).GT.0.) THEN EVPWET(I)=SNOCAN(I)/DELT IF(EVAPC(I).GT.EVPWET(I)) EVAPC(I)=EVPWET(I) ELSE EVPWET(I)=RAICAN(I)/DELT IF(EVAPC(I).GT.EVPWET(I)) THEN WTRANSP=(EVAPC(I)-EVPWET(I))*DELT EVPMAX(I)=EVPWET(I) WTRTOT(I)=0.0 DO J=1,IG WTEST=WTRANSP*FROOT(I,J) WROOT(I,J)=MIN(WTEST,WAVAIL(I,J)) WTRTOT(I)=WTRTOT(I)+WROOT(I,J) EVPMAX(I)=EVPMAX(I)+WROOT(I,J)/DELT ENDDO IF(EVAPC(I).GT.EVPMAX(I)) EVAPC(I)=EVPMAX(I) ENDIF ENDIF QEVAPC(I)=CPHCHC(I)*EVAPC(I) QSTOR (I)=CHCAP(I)*(TCAN(I)-TCANO(I))/DELT RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-2.0*QLWOC(I))* 1 (1.0-FSVF(I))+QSGADD(I)-QSENSC(I)-QEVAPC(I)- 2 QSTOR(I)-QMELTC(I) IF(ABS(RESID(I)).LT.5.0) ITER(I)=0 IF(ABS(TSTEP(I)).LT. 1.0E-2) ITER(I)=0 IF(NITER(I).EQ.ITERMX .AND. ITER(I).EQ.1) ITER(I)=-1 ENDIF 525 CONTINUE C IF(ITC.LT.2) THEN C C * OPTION #1: SECANT/BISECTION ITERATION METHOD. C DO 550 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN IF(NITER(I).EQ.1) THEN IF(RESID(I).GT.0.0) THEN TCAN(I)=TCAN(I)+TSTEP(I) ELSE TCAN(I)=TCAN(I)-TSTEP(I) ENDIF ELSE IF((RESID(I).GT.0. .AND. TSTEP(I).LT.0.) .OR. 1 (RESID(I).LT.0. .AND. TSTEP(I).GT.0.)) THEN TSTEP(I)=-TSTEP(I)/2.0 ENDIF TCAN(I)=TCAN(I)+TSTEP(I) ENDIF IF(ABS(TCAN(I)-TFREZ).LT.1.0E-6) TCAN(I)=TFREZ NITER(I)=NITER(I)+1 NUMIT=NUMIT+1 ENDIF 550 CONTINUE C ELSE C C * OPTION #2: NEWTON-RAPHSON ITERATION METHOD. C DO 575 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN IF(NITER(I).GT.1) THEN DCFLUX=(CFLX(I)-CFLUXM(I))/ 1 SIGN(MAX(.001,ABS(TSTEP(I))),TSTEP(I)) IF(ABS(TVIRTA(I)-TVIRTC(I)).LT.0.4) 1 DCFLUX=MAX(DCFLUX,0.8*DCFLXM(I)) DXEVAP=(XEVAP(I)-XEVAPM(I))/ 1 SIGN(MAX(.001,ABS(TSTEP(I))),TSTEP(I)) ELSE DCFLUX=0. DXEVAP=0. ENDIF XEVAPM(I)=XEVAP(I) CFLUXM(I)=CFLX(I) DCFLXM(I)=DCFLUX DRDT0=-4.0*SBC*TCAN(I)*TCAN(I)*TCAN(I)*(1.0-FSVF(I))* 1 2.0-RHOAIR(I)*SPHAIR*(CFLX(I)+MAX(0., 2 TCAN(I)-TPOTA(I))*DCFLUX)+REAL(IEVAPC(I))*CPHCHC(I)* 3 RHOAIR(I)*(XEVAP(I)*WC(I)*A(I)*(B(I)-TFREZ)/ 4 ((TCAN(I)-B(I))*(1.0+WC(I)))**2-(QCAN(I)-QA(I))* 5 DXEVAP)-CHCAP(I)/DELT TSTEP(I)=-RESID(I)/DRDT0 TSTEP(I)=MAX(-10.,MIN(5.,TSTEP(I))) TCAN(I)=TCAN(I)+TSTEP(I) IF(ABS(TCAN(I)-TFREZ).LT.1.0E-3) TCAN(I)=TFREZ NITER(I)=NITER(I)+1 NUMIT=NUMIT+1 TAC(I)=TCAN(I) QAC(I)=QCAN(I) TVRTAC(I)=TVIRTC(I) ENDIF 575 CONTINUE C ENDIF C ENDIF IF(NUMIT.GT.0) GO TO 400 C C * IF CONVERGENCE HAS NOT BEEN REACHED FOR ITERATION METHOD #2, C * CALCULATE TEMPERATURE AND FLUXES ASSUMING NEUTRAL STABILITY. C IF(ITC.EQ.2) THEN C NUMIT=0 DO 600 I=IL1,IL2 IEVAPC(I)=0 IF(ITER(I).EQ.-1) THEN TCANT=TVIRTA(I)/(1.0+0.61*QCAN(I)) IF(ABS(RESID(I)).GT.100.) THEN TCAN(I)=TCANT IF(TCAN(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/ 1 (TCAN(I)-B(I)))/PADRY(I) QCAN(I)=WCAN/(1.0+WCAN) IF(FSNOWC(I).GT.0.0) THEN YEVAP=FRAINC(I)+FSNOWC(I) ELSE YEVAP=FRAINC(I)+(1.0-FRAINC(I))*10./(10.+RC(I)) ENDIF QCAN(I)=YEVAP*QCAN(I)+(1.0-YEVAP)*QA(I) QSTOR(I)=CHCAP(I)*(TCAN(I)-TCANO(I))/DELT QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I) RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-2.0*QLWOC(I))* 1 (1.0-FSVF(I))+QSENSG(I)-QSTOR(I) IF(RESID(I).GT.0.) THEN QEVAPC(I)=RESID(I) ELSE QEVAPC(I)=RESID(I)*0.5 ENDIF QSENSC(I)=RESID(I)-QEVAPC(I) RESID(I)=0. EVAPC(I)=QEVAPC(I)/CPHCHC(I) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) NUMIT=NUMIT+1 IEVAPC(I)=1 ENDIF ENDIF 600 CONTINUE c IF(NUMIT.GT.0) THEN IF(ISLFD.LT.2) THEN CALL DRCOEF(CDM,CDH,RIB,CFLUX,QA,QA,ZOSCLM,ZOSCLH, 1 CRIB,TVIRTC,TVIRTA,VA,FI,IEVAPC, 2 ILG,IL1,IL2) ELSE CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO, 1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA, 2 TCAN,QCAN,H,ZOM,ZOH, 3 LZZ0,LZZ0T,FM,FH,ILG,IL1,IL2,FI,IEVAPC,JL ) ENDIF ENDIF C ENDIF C IBAD=0 C DO 625 I=IL1,IL2 C IF(FI(I).GT.0. .AND. ITER(I).EQ.-1) THEN C WRITE(6,6350) I,JL,NITER(I),RESID(I),TCAN(I),RIB(I) C6350 FORMAT('0CANOPY ITERATION LIMIT',3X,3I3,3(F8.2,E12.4)) C ENDIF IF(FI(I).GT.0. .AND. (TCAN(I).LT.173.16 .OR. 1 TCAN(I).GT.373.16)) THEN IBAD=I ENDIF 625 CONTINUE C IF(IBAD.NE.0) THEN WRITE(6,6375) IBAD,JL,TCAN(IBAD),NITER(IBAD),ISNOW 6375 FORMAT('0BAD CANOPY ITERATION TEMPERATURE',3X,2I3,F16.2,2I4) WRITE(6,6380) QSWNC(IBAD),QLWIN(IBAD),QLWOG(IBAD), 1 QLWOC(IBAD),QSENSG(IBAD),QSENSC(IBAD), 2 QEVAPC(IBAD),QSTOR(IBAD),QMELTC(IBAD) WRITE(6,6380) TCAN(IBAD),TPOTA(IBAD),TZERO(IBAD) 6380 FORMAT(2X,9F10.2) CALL XIT('TSOLVC',-2) ENDIF C C * POST-ITERATION CLEAN-UP. C NIT=0 DO 650 I=IL1,IL2 IF(FI(I).GT.0.) THEN IF(RAICAN(I).GT.0. .AND. TCAN(I).LT.TFREZ) THEN QSTOR(I)=-CHCAP(I)*TCANO(I)/DELT ITER(I)=1 NIT=NIT+1 HFREZ=CHCAP(I)*(TFREZ-TCAN(I)) HCONV=RAICAN(I)*CLHMLT IF(HFREZ.LE.HCONV) THEN RCONV=HFREZ/CLHMLT FSNOWC(I)=FSNOWC(I)+FRAINC(I)*RCONV/RAICAN(I) FRAINC(I)=FRAINC(I)-FRAINC(I)*RCONV/RAICAN(I) SNOCAN(I)=SNOCAN(I)+RCONV RAICAN(I)=RAICAN(I)-RCONV TCAN (I)=TFREZ QMELTC(I)=-CLHMLT*RCONV/DELT WCAN=0.622*611.0/PADRY(I) QCAN(I)=WCAN/(1.0+WCAN) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) ELSE HCOOL=HFREZ-HCONV SNOCAN(I)=SNOCAN(I)+RAICAN(I) FSNOWC(I)=FSNOWC(I)+FRAINC(I) FRAINC(I)=0.0 TCAN (I)=-HCOOL/(SPHVEG*CMASS(I)+SPHICE* 1 SNOCAN(I))+TFREZ QMELTC(I)=-CLHMLT*RAICAN(I)/DELT RAICAN(I)=0.0 A(I)=21.874 B(I)=7.66 WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/ 1 (TCAN(I)-B(I)))/PADRY(I) QCAN(I)=WCAN/(1.0+WCAN) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) ENDIF CHCAP(I)=SPHVEG*CMASS(I)+SPHICE*SNOCAN(I)+ 1 SPHW*RAICAN(I) QSTOR(I)=QSTOR(I)+CHCAP(I)*TCAN(I)/DELT ELSE ITER(I)=0 ENDIF IF(ITC.EQ.2) THEN TAC(I)=TCAN(I) QAC(I)=QCAN(I) TVRTAC(I)=TVIRTC(I) ENDIF ENDIF 650 CONTINUE C DO 675 I=IL1,IL2 IF(FI(I).GT.0.) THEN IF(SNOCAN(I).GT.0. .AND. TCAN(I).GT.TFREZ) THEN QSTOR(I)=-CHCAP(I)*TCANO(I)/DELT ITER(I)=1 NIT=NIT+1 HMELT=CHCAP(I)*(TCAN(I)-TFREZ) HCONV=SNOCAN(I)*CLHMLT IF(HMELT.LE.HCONV) THEN SCONV=HMELT/CLHMLT FRAINC(I)=FRAINC(I)+FSNOWC(I)*SCONV/SNOCAN(I) FSNOWC(I)=FSNOWC(I)-FSNOWC(I)*SCONV/SNOCAN(I) SNOCAN(I)=SNOCAN(I)-SCONV RAICAN(I)=RAICAN(I)+SCONV TCAN (I)=TFREZ QMELTC(I)=CLHMLT*SCONV/DELT WCAN=0.622*611.0/PADRY(I) QCAN(I)=WCAN/(1.0+WCAN) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) ELSE HWARM=HMELT-HCONV RAICAN(I)=RAICAN(I)+SNOCAN(I) FRAINC(I)=FRAINC(I)+FSNOWC(I) FSNOWC(I)=0.0 TCAN (I)=HWARM/(SPHVEG*CMASS(I)+SPHW* 1 RAICAN(I))+TFREZ QMELTC(I)=CLHMLT*SNOCAN(I)/DELT SNOCAN(I)=0.0 A(I)=17.269 B(I)=35.86 WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/ 1 (TCAN(I)-B(I)))/PADRY(I) QCAN(I)=WCAN/(1.0+WCAN) TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I)) ENDIF CHCAP(I)=SPHVEG*CMASS(I)+SPHW*RAICAN(I)+ 1 SPHICE*SNOCAN(I) QSTOR(I)=QSTOR(I)+CHCAP(I)*TCAN(I)/DELT ENDIF IF(ITC.EQ.2) THEN TAC(I)=TCAN(I) QAC(I)=QCAN(I) TVRTAC(I)=TVIRTC(I) ENDIF ENDIF 675 CONTINUE C IF(NIT.GT.0) THEN C C * CALCULATE SURFACE DRAG COEFFICIENTS (STABILITY-DEPENDENT) C * AND OTHER RELATED QUANTITIES BETWEEN CANOPY AIR SPACE AND C * ATMOSPHERE. C IF(ISLFD.LT.2) THEN CALL DRCOEF(CDM,CDH,RIB,CFLUX,QAC,QA,ZOSCLM,ZOSCLH, 1 CRIB,TVRTAC,TVIRTA,VA,FI,ITER, 2 ILG,IL1,IL2) ELSE CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO, 1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA, 2 TAC,QAC,H,ZOM,ZOH, 3 LZZ0,LZZ0T,FM,FH,ILG,IL1,IL2,FI,ITER,JL ) ENDIF ENDIF C C * REMAINING CALCULATIONS. C IF(ITC.EQ.1) THEN C DO 700 I=IL1,IL2 IF (FI(I).GT.0. .AND. ITER(I).EQ.1) THEN XEVAP(I)=RBINV(I) QAC(I)=(QCAN(I)*XEVAP(I)+QZERO(I)*RAGINV(I)+ 1 QA(I)*CFLUX(I))/(XEVAP(I)+RAGINV(I)+CFLUX(I)) IF(QAC(I).LT.QCAN(I)) THEN IF(FSNOWC(I).GT.0.0) THEN XEVAP(I)=(FRAINC(I)+FSNOWC(I))/RB(I) ELSE XEVAP(I)=FRAINC(I)/RB(I)+(1.0-FRAINC(I))/ 1 (RB(I)+RC(I)) QAC(I)=(QCAN(I)*XEVAP(I)+QZERO(I)*RAGINV(I)+ 1 QA(I)*CFLUX(I))/(XEVAP(I)+RAGINV(I)+ 2 CFLUX(I)) ENDIF ELSE IF(FSNOWC(I).GT.1.0E-5) THEN XEVAP(I)=FSNOWC(I)/RB(I) ELSE XEVAP(I)=1.0/RB(I) ENDIF ENDIF TAC(I)=(TCAN(I)*RBINV(I)+TPOTG(I)*RAGINV(I)+ 1 TPOTA(I)*CFLUX(I))/(RBINV(I)+RAGINV(I)+CFLUX(I)) TVRTAC(I)=TAC(I)*(1.0+0.61*QAC(I)) CFSENS(I)=RBINV(I) CFEVAP(I)=XEVAP(I) ENDIF 700 CONTINUE C ELSE C DO 750 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN CFLX(I)=RBINV(I)*CFLUX(I)/(RBINV(I)+CFLUX(I)) CFLX(I)=CFLUX(I)+(CFLX(I)-CFLUX(I))* 1 MIN(1.0,QSWINV(I)*0.04) RA(I)=1.0/CFLX(I) IF(QA(I).LT.QCAN(I)) THEN IF(FSNOWC(I).GT.0.0) THEN XEVAP(I)=(FRAINC(I)+FSNOWC(I))/RA(I) ELSE XEVAP(I)=FRAINC(I)/RA(I)+(1.0-FRAINC(I))/ 1 (RA(I)+RC(I)) ENDIF ELSE IF(FSNOWC(I).GT.1.0E-5) THEN XEVAP(I)=FSNOWC(I)/RA(I) ELSE XEVAP(I)=1.0/RA(I) ENDIF ENDIF QCAN(I)=RA(I)*XEVAP(I)*QCAN(I)+(1.0-RA(I)* 1 XEVAP(I))*QA(I) CFSENS(I)=CFLX(I) CFEVAP(I)=CFLX(I) TAC(I)=TPOTA(I) QAC(I)=QA(I) ENDIF 750 CONTINUE C ENDIF C DO 800 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN IF(SNOCAN(I).GT.0.) THEN CPHCHC(I)=CLHVAP+CLHMLT ELSE CPHCHC(I)=CLHVAP ENDIF QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I) QSENSC(I)=RHOAIR(I)*SPHAIR*CFSENS(I)*(TCAN(I)-TAC(I)) IF(FRAINC(I).GT.0. .OR. FSNOWC(I).GT.0. .OR. 1 RC(I).LE.5000. .OR. QAC(I).GT.QCAN(I)) THEN EVAPC(I)=RHOAIR(I)*CFEVAP(I)*(QCAN(I)-QAC(I)) ELSE EVAPC(I)=0.0 ENDIF IF(EVAPC(I).LT.0. .AND. TCAN(I).GE.TADP(I)) EVAPC(I)=0.0 IF(SNOCAN(I).GT.0.) THEN EVPWET(I)=SNOCAN(I)/DELT IF(EVAPC(I).GT.EVPWET(I)) EVAPC(I)=EVPWET(I) ELSE EVPWET(I)=RAICAN(I)/DELT IF(EVAPC(I).GT.EVPWET(I)) THEN WTRANSP=(EVAPC(I)-EVPWET(I))*DELT EVPMAX(I)=EVPWET(I) WTRTOT(I)=0.0 DO J=1,IG WTEST=WTRANSP*FROOT(I,J) WROOT(I,J)=MIN(WTEST,WAVAIL(I,J)) WTRTOT(I)=WTRTOT(I)+WROOT(I,J) EVPMAX(I)=EVPMAX(I)+WROOT(I,J)/DELT ENDDO IF(EVAPC(I).GT.EVPMAX(I)) EVAPC(I)=EVPMAX(I) ENDIF ENDIF QEVAPC(I)=CPHCHC(I)*EVAPC(I) RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-2.0*QLWOC(I))* 1 (1.0-FSVF(I))+QSGADD(I)-QSENSC(I)-QEVAPC(I)- 2 QSTOR(I)-QMELTC(I) ENDIF 800 CONTINUE C DO 850 I=IL1,IL2 IF(FI(I).GT.0.) THEN IF(ABS(EVAPC(I)).LT.1.0E-8) THEN RESID(I)=RESID(I)+QEVAPC(I) EVAPC(I)=0.0 QEVAPC(I)=0.0 ENDIF QSENSC(I)=QSENSC(I)+RESID(I) IF(ABS(TZERO(I)-TFREZ).LT.1.0E-3) THEN QMELTG(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))* 1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I)-GZERO(I) ELSE GZERO(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))* 1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I) ENDIF IF(EVAPC(I).LT.0.) THEN IF(SNOCAN(I).GT.0.) THEN SNOCAN(I)=SNOCAN(I)-EVAPC(I)*DELT QFCF(I)=QFCF(I)+FI(I)*EVAPC(I) HTCC(I)=HTCC(I)-FI(I)*TCAN(I)*SPHICE*EVAPC(I) ELSE RAICAN(I)=RAICAN(I)-EVAPC(I)*DELT QFCL(I)=QFCL(I)+FI(I)*EVAPC(I) HTCC(I)=HTCC(I)-FI(I)*TCAN(I)*SPHW*EVAPC(I) ENDIF EVAP(I)=EVAP(I)+FI(I)*EVAPC(I) EVAPC(I)=0.0 CHCAP(I)=SPHVEG*CMASS(I)+SPHICE*SNOCAN(I)+ 1 SPHW*RAICAN(I) ENDIF QSWNET(I)=QSWNG(I)+QSWNC(I)+QTRANS(I) QLWOUT(I)=FSVF(I)*QLWOG(I)+(1.0-FSVF(I))*QLWOC(I) QSENS(I)=QSENSC(I)+QSENSG(I)-QSGADD(I) QEVAP(I)=QEVAPC(I)+QEVAPG(I) EVAPC(I)=EVAPC(I)/RHOW EVAPG(I)=EVAPG(I)/RHOW ITERCT(I,KF1(I),NITER(I))=ITERCT(I,KF1(I),NITER(I))+1 ENDIF 850 CONTINUE IF (ICTEMMOD.EQ.1) THEN C C * STORE AERODYNAMIC CONDUCTANCE FOR USE IN NEXT TIME STEP C * OVERWRITE OLDER NUMBERS ONLY WHEN FRACTION OF CANOPY C * OR FRACTION OF CANOPY OVER SNOW (AKA FI) IS > 0. C DO 900 I = IL1, IL2 IF(FI(I).GT.0.) THEN CFLUXV(I) = CFLUX(I) ELSE CFLUXV(I) = CFLUXV_IN(I) ENDIF 900 CONTINUE ENDIF C DO 950 J=1,IG DO 950 I=IL1,IL2 IF(FI(I).GT.0.) THEN IF(WTRTOT(I).GT.0.0) FROOT(I,J)=WROOT(I,J)/WTRTOT(I) ENDIF 950 CONTINUE C RETURN END SUBROUTINE TSOLVE(ISNOW,FI, 1 QSWNET,QLWOUT,QTRANS,QSENS,QEVAP,EVAP, 2 TZERO,QZERO,GZERO,QMELT,CDH,CDM,RIB,CFLUX, 3 FTEMP,FVAP,ILMO,UE,H, 4 QLWIN,TPOTA,QA,VA,PADRY,RHOAIR, 5 ALVISG,ALNIRG,CRIB,CPHCH,CEVAP,TVIRTA, 6 ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,FCOR, 7 GCONST,GCOEFF,TSTART,PCPR,TRSNOWG,FSSB,ALSNO, 8 THLIQ,THLMIN,DELZW,RHOSNO,ZSNOW, + IWATER,IEVAP,ITERCT,ISAND, 9 ISLFD,ITG,ILG,IG,IL1,IL2,JL,NBS,ISNOALB, A TSTEP,TVIRTS,EVBETA,Q0SAT,RESID, B DCFLXM,CFLUXM,WZERO,TRTOP,A,B, C LZZ0,LZZ0T,FM,FH,ITER,NITER,JEVAP,KF) C C * JUL 22/15 - D.VERSEGHY. LIMIT CALCULATED EVAPORATION RATE C * ACCORDING TO WATER AVAILABILITY. C * JAN 09/15 - D.VERSEGHY. FIX TO SUPPRESS EVAPORATION FROM ROCK. C * JUN 27/14 - D.VERSEGHY. CHANGE ITERATION LIMIT BACK TO 50 FOR C * BISECTION SCHEME. C * NOV 16/13 - J.COLE/ FINAL VERSION FOR GCM17: C * M.LAZARE. - FIX COMPUTATION OF QSWNI OVER SNOW FREE C * BARE SOIL for ISNOW=0 and ISNOALB=1 (NEED C * TO SUM OVER THE 3 NEAR-IR BANDS). C * JUN 22/13 - J.COLE/ - ADD "ISNOALB" OPTION (4-BAND SOLAR). C * M.LAZARE. - MODIFY ABORT CONDITION FOR TOO COLD C * TEMPS FROM 173 TO 123, SO WON'T C * BLOW UP OVER ANTARCTICA. C * OCT 14/11 - D.VERSEGHY. FOR POST-ITERATION CLEANUP WITH N-R SCHEME, C * REMOVE CONDITION INVOLVING LAST ITERATION C * TEMPERATURE. C * DEC 07/09 - D.VERSEGHY. RESTORE EVAPORATION WHEN PRECIPITATION C * IS OCCURRING. C * MAR 13/09 - D.VERSEGHY. REPLACE SURFCON COMMON BLOCK WITH CLASSD2; C * REVISED CALL TO FLXSURFZ. C * JAN 06/09 - D.VERSEGHY/M.LAZARE. SPLIT IF CONDITIONS FRAMING C * 300 LOOP. C * FEB 25/08 - D.VERSEGHY. STREAMLINE SOME CALCULATIONS; REMOVE C * "ILW" SWITCH; SUPPRESS WATER VAPOUR FLUX C * IF PRECIPITATION IS OCCURRING. C * MAY 17/06 - D.VERSEGHY. SUPPRESS EVAPORATION WHEN PONDED WATER C * IS FREEZING; ADD IL1 AND IL2 TO CALL TO C * FLXSURFZ; REMOVE JL FROM CALL TO DRCOEF. C * APR 13/05 - R.BROWN. ADD WINDLESS TRANFER COEFFICIENT TO QSENS C * CALCULATION FOR SNOW PACKS. C * DEC 17/04 - Y.DELAGE/D.VERSEGHY. ADD SWITCH TO USE EITHER SECANT/ C * BISECTION OR NEWTON-RAPHSON ITERATION C * SCHEME (WITH NUMBER OF ITERATIONS LIMITED C * TO FIVE AND CORRECTION FOR REMAINING C * RESIDUAL). C * NOV 04/04 - D.VERSEGHY. ADD "IMPLICIT NONE" COMMAND. C * AUG 06/04 - Y.DELAGE/D.VERSEGHY. PROTECT SENSITIVE CALCULATIONS C * FROM ROUNDOFF ERRORS. C * NOV 07/02 - Y.DELAGE/D.VERSEGHY. NEW CALL TO FLXSURFZ. C * JUL 26/02 - D.VERSEGHY. SHORTENED CLASS4 COMMON BLOCK. C * MAR 28/02 - D.VERSEGHY. STREAMLINED SUBROUTINE CALL. C * BYPASS EVAPORATION EFFICIENCY PARAMETER C * IN CASES OF CONDENSATION. C * JAN 18/02 - P.BARTLETT/D.VERSEGHY. NEW "BETA" FORMULATION FOR C * BARE SOIL EVAPORATION BASED ON LEE AND C * PIELKE. C * APR 11/01 - M.LAZARE. SHORTENED "CLASS2" COMMON BLOCK. C * OCT 06/00 - D.VERSEGHY. CONDITIONAL "IF" IN ITERATION SEQUENCE C * TO AVOID DIVIDE BY ZERO. C * DEC 07/99 - A.WU/D.VERSEGHY. NEW SOIL EVAPORATION FORMULATION. C * JUL 24/97 - D.VERSEGHY. CLASS - VERSION 2.7. C * REPLACE BISECTION METHOD IN SURFACE C * TEMPERATURE ITERATION SCHEME WITH C * SECANT METHOD FOR FIRST TEN ITERATIONS. C * PASS QZERO,QA,ZOMS,ZOHS TO REVISED C * DRCOEF (ZOMS AND ZOHS ALSO NEW WORK ARRAYS C * PASSED TO THIS ROUTINE). C * JUN 20/97 - D.VERSEGHY. PASS IN NEW "CLASS4" COMMON BLOCK. C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5. C * COMPLETION OF ENERGY BALANCE C * DIAGNOSTICS. ALSO, PASS SWITCH "ILW" C * THROUGH SUBROUTINE CALL, SPECIFYING C * WHETHER QLWIN REPRESENTS INCOMING C * (ILW=1) OR NET (ILW=2) LONGWAVE C * RADIATION ABOVE THE GROUND. C * NOV 30/94 - M.LAZARE. CLASS - VERSION 2.3. C * NEW DRAG COEFFICIENT AND RELATED FIELDS, C * NOW DETERMINED IN ROUTINE "DRCOEF" C * "CFLUX" NOW WORK FIELD INSTEAD OF "CLIMIT". C * OCT 04/94 - D.VERSEGHY. CHANGE "CALL ABORT" TO "CALL XIT" TO C * ENABLE RUNNING ON PCS. C * JAN 24/94 - M.LAZARE. UNFORMATTED I/O COMMENTED OUT IN LOOP 200. C * JUL 29/93 - D.VERSEGHY. CLASS - VERSION 2.2. C * REMOVE RE-DEFINITION OF QMELT NEAR END C * (SINCE DONE ELSEWHERE ALREADY) AND C * REDEFINE QSWNET FOR DIAGNOSTIC PURPOSES C * TO INCLUDE TRANSMISSION THROUGH C * SNOWPACK. C * OCT 15/92 - D.VERSEGHY/M.LAZARE. CLASS - VERSION 2.1. C * REVISED AND VECTORIZED CODE C * FOR MODEL VERSION GCM7. C * AUG 12/91 - D.VERSEGHY. CODE FOR MODEL VERSION GCM7U - C * CLASS VERSION 2.0 (WITH CANOPY). C * APR 11/89 - D.VERSEGHY. ITERATIVE SURFACE TEMPERATURE C * CALCULATIONS FOR SNOW/SOIL. C IMPLICIT NONE C * INTEGER CONSTANTS. C INTEGER ISNOW,ISLFD,ITG,ILG,IG,IL1,IL2,JL,I,IB,NBS,ISNOALB C INTEGER NUMIT,NIT,IBAD,ITERMX C C * OUTPUT ARRAYS. C REAL QSWNET(ILG), QLWOUT(ILG), QTRANS(ILG), QSENS (ILG), 1 QEVAP (ILG), EVAP (ILG), TZERO (ILG), QZERO (ILG), 2 GZERO (ILG), QMELT (ILG), CDH (ILG), CDM (ILG), 3 RIB (ILG), CFLUX (ILG), FTEMP (ILG), FVAP (ILG), 4 ILMO (ILG), UE (ILG), H (ILG) C C * INPUT ARRAYS. C REAL FI (ILG), QLWIN (ILG), 1 TPOTA (ILG), QA (ILG), VA (ILG), PADRY (ILG), 2 RHOAIR(ILG), ALVISG(ILG), ALNIRG(ILG), CRIB (ILG), 3 CPHCH (ILG), CEVAP (ILG), TVIRTA(ILG), 4 ZOSCLH(ILG), ZOSCLM(ILG), ZRSLFH(ILG), ZRSLFM(ILG), 5 ZOH (ILG), ZOM (ILG), GCONST(ILG), GCOEFF(ILG), 6 TSTART(ILG), FCOR (ILG), PCPR (ILG), 7 RHOSNO(ILG), ZSNOW (ILG) C REAL THLIQ (ILG,IG), THLMIN(ILG,IG), DELZW (ILG,IG) C INTEGER IWATER(ILG), IEVAP (ILG) INTEGER ITERCT(ILG,6,50), ISAND(ILG,IG) C C * BAND-DEPENDANT ARRAYS. C REAL TRSNOWG(ILG,NBS), ALSNO(ILG,NBS), FSSB(ILG,NBS), 1 TRTOP (ILG,NBS) C C * INTERNAL WORK ARRAYS. C REAL TSTEP (ILG), TVIRTS(ILG), EVBETA(ILG), Q0SAT (ILG), 1 RESID (ILG), DCFLXM(ILG), CFLUXM(ILG), 2 A (ILG), B (ILG), 3 LZZ0 (ILG), LZZ0T (ILG), FM (ILG), FH (ILG), 4 WZERO (ILG), EVPMAX(ILG) C INTEGER ITER (ILG), NITER (ILG), JEVAP (ILG), 1 KF (ILG) C C * TEMPORARY VARIABLES. C REAL QSWNV,QSWNI,DCFLUX,DRDT0,TZEROT,QEVAPT,BOWEN,EZERO C C * COMMON BLOCK PARAMETERS. C REAL DELT,TFREZ,RGAS,RGASV,GRAV,SBC,VKC,CT,VMIN,HCPW,HCPICE, 1 HCPSOL,HCPOM,HCPSND,HCPCLY,SPHW,SPHICE,SPHVEG,SPHAIR, 2 RHOW,RHOICE,TCGLAC,CLHMLT,CLHVAP,DELTA,CGRAV,CKARM,CPD, 3 AS,ASX,CI,BS,BETA,FACTN,HMIN,ANGMAX C COMMON /CLASS1/ DELT,TFREZ COMMON /CLASS2/ RGAS,RGASV,GRAV,SBC,VKC,CT,VMIN COMMON /CLASS4/ HCPW,HCPICE,HCPSOL,HCPOM,HCPSND,HCPCLY, 1 SPHW,SPHICE,SPHVEG,SPHAIR,RHOW,RHOICE, 2 TCGLAC,CLHMLT,CLHVAP COMMON /PHYCON/ DELTA,CGRAV,CKARM,CPD COMMON /CLASSD2/ AS,ASX,CI,BS,BETA,FACTN,HMIN,ANGMAX C----------------------------------------------------------------------- C * INITIALIZATION AND PRE-ITERATION SEQUENCE. C IF(ITG.LT.2) THEN ITERMX=50 ELSE ITERMX=5 ENDIF C C IF(ISNOW.EQ.0) THEN C EZERO=0.0 C ELSE C EZERO=2.0 C ENDIF EZERO=0.0 C DO I=IL1,IL2 QSWNET(I)=0.0 QTRANS(I)=0.0 END DO C IF(ISNOW. EQ. 0) THEN ! Use usual snow-free bare soil formulation DO I=IL1,IL2 IF(FI(I).GT.0.) THEN TRTOP(I,1)=0. QSWNV=FSSB(I,1)*(1.0-ALVISG(I)) IF (ISNOALB .EQ. 0) THEN QSWNI=FSSB(I,2)*(1.0-ALNIRG(I)) ELSE IF (ISNOALB .EQ. 1) THEN QSWNI=0.0 DO IB = 2, NBS QSWNI=QSWNI+FSSB(I,IB)*(1.0-ALNIRG(I)) END DO ! IB ENDIF QSWNET(I)=QSWNV+QSWNI QTRANS(I)=QSWNET(I)*TRTOP(I,1) QSWNET(I)=QSWNET(I)-QTRANS(I) END IF END DO ! I ELSE IF (ISNOALB .EQ. 0) THEN ! Use the existing snow albedo and transmission DO I=IL1,IL2 IF(FI(I).GT.0.) THEN TRTOP(I,1)=TRSNOWG(I,1) QSWNV=FSSB(I,1)*(1.0-ALSNO(I,1)) QSWNI=FSSB(I,2)*(1.0-ALSNO(I,2)) QSWNET(I)=QSWNV+QSWNI QTRANS(I)=QSWNET(I)*TRTOP(I,1) QSWNET(I)=QSWNET(I)-QTRANS(I) END IF END DO ! I ELSE IF(ISNOALB .EQ. 1) THEN ! Use the band-by-band snow albedo and transmission DO I=IL1,IL2 QTRANS(I) = 0.0 QSWNET(I) = 0.0 END DO ! I DO IB = 1, NBS DO I=IL1,IL2 IF(FI(I).GT.0.) THEN TRTOP(I,IB)=TRSNOWG(I,IB) QSWNV=FSSB(I,IB)*(1.0-ALSNO(I,IB)) QSWNET(I)=QSWNET(I)+FSSB(I,IB)*(1.0-ALSNO(I,IB)) QTRANS(I)=QTRANS(I)+QSWNV*TRTOP(I,IB) END IF END DO ! I END DO ! IB DO I=IL1,IL2 IF(FI(I).GT.0.) THEN QSWNET(I)=QSWNET(I)-QTRANS(I) END IF END DO ! I END IF ! ISNOALB END IF ! ISNOW C DO 50 I=IL1,IL2 IF(FI(I).GT.0.) THEN TZERO(I)=TSTART(I) TSTEP(I)=1.0 ITER(I)=1 NITER(I)=1 C QMELT(I)=0.0 RESID(I)=999999. DCFLXM(I)=0.0 CFLUX(I)=0.0 IF(ISNOW.EQ.1) THEN KF(I)=3 EVPMAX(I)=RHOSNO(I)*ZSNOW(I)/DELT ELSE KF(I)=6 EVPMAX(I)=RHOW*(THLIQ(I,1)-THLMIN(I,1))*DELZW(I,1)/ 1 DELT ENDIF ENDIF 50 CONTINUE C C * ITERATION SECTION. C * LOOP IS REPEATED UNTIL SOLUTIONS HAVE BEEN FOUND FOR ALL POINTS C * ON THE CURRENT LATITUDE CIRCLE(S). C 100 CONTINUE C NUMIT=0 NIT=0 DO 150 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN NIT=NIT+1 CFLUXM(I)=CFLUX(I) IF(TZERO(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WZERO(I)=0.622*611.0*EXP(A(I)*(TZERO(I)-TFREZ)/ 1 (TZERO(I)-B(I)))/PADRY(I) Q0SAT(I)=WZERO(I)/(1.0+WZERO(I)) IF(IWATER(I).GT.0) THEN EVBETA(I)=1.0 QZERO(I)=Q0SAT(I) ELSE EVBETA(I)=CEVAP(I) QZERO(I)=EVBETA(I)*Q0SAT(I)+(1.0-EVBETA(I))*QA(I) IF(QZERO(I).GT.QA(I) .AND. IEVAP(I).EQ.0) THEN EVBETA(I)=0.0 QZERO(I)=QA(I) ENDIF ENDIF TVIRTS(I)=TZERO(I)*(1.0+0.61*QZERO(I)) ENDIF 150 CONTINUE C IF(NIT.GT.0) THEN C C * CALCULATE SURFACE DRAG COEFFICIENTS (STABILITY-DEPENDENT) AND C * OTHER RELATED QUANTITIES. C IF(ISLFD.LT.2) THEN CALL DRCOEF (CDM,CDH,RIB,CFLUX,QZERO,QA,ZOSCLM,ZOSCLH, 1 CRIB,TVIRTS,TVIRTA,VA,FI,ITER, 2 ILG,IL1,IL2) ELSE CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO, 1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA, 2 TZERO,QZERO,H,ZOM,ZOH, 3 LZZ0,LZZ0T,FM,FH,ILG,IL1,IL2,FI,ITER,JL ) ENDIF C C * REMAINING CALCULATIONS. C DO 175 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN QLWOUT(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I) IF(TZERO(I).LT.TPOTA(I)) THEN QSENS(I)=(RHOAIR(I)*SPHAIR*CFLUX(I)+EZERO)*(TZERO(I)- 1 TPOTA(I)) ELSE QSENS(I)=RHOAIR(I)*SPHAIR*CFLUX(I)*(TZERO(I)- 1 TPOTA(I)) ENDIF EVAP(I)=RHOAIR(I)*CFLUX(I)*(QZERO(I)-QA(I)) IF(EVAP(I).GT.EVPMAX(I)) EVAP(I)=EVPMAX(I) QEVAP(I)=CPHCH(I)*EVAP(I) GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I) RESID(I)=QSWNET(I)+QLWIN(I)-QLWOUT(I)-QSENS(I)-QEVAP(I)- 1 GZERO(I) IF(ABS(RESID(I)).LT.5.0) ITER(I)=0 IF(ABS(TSTEP(I)).LT. 1.0E-2) ITER(I)=0 IF(NITER(I).EQ.ITERMX .AND. ITER(I).EQ.1) ITER(I)=-1 ENDIF 175 CONTINUE ENDIF C IF(ITG.LT.2) THEN C C * OPTION #1: BISECTION ITERATION METHOD. C IF(NIT.GT.0) THEN DO 180 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN IF(NITER(I).EQ.1) THEN IF(RESID(I).GT.0.0) THEN TZERO(I)=TZERO(I)+1.0 ELSE TZERO(I)=TZERO(I)-1.0 ENDIF ELSE IF((RESID(I).GT.0. .AND. TSTEP(I).LT.0.) .OR. 1 (RESID(I).LT.0. .AND. TSTEP(I).GT.0.)) THEN TSTEP(I)=-TSTEP(I)/2.0 ENDIF TZERO(I)=TZERO(I)+TSTEP(I) ENDIF ENDIF C IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN NITER(I)=NITER(I)+1 NUMIT=NUMIT+1 ENDIF 180 CONTINUE ENDIF C c DO 185 I=IL1,IL2 C IF(FI(I).GT.0. .AND. ITER(I).EQ.-1) THEN C WRITE(6,6250) I,JL,RESID(I),TZERO(I),RIB(I) C6250 FORMAT('0GROUND ITERATION LIMIT',3X,2I3,3(F8.2,E12.4)) C ENDIF c 185 CONTINUE C IF(NUMIT.GT.0) GO TO 100 C ELSE C C * OPTION #2: NEWTON-RAPHSON ITERATION METHOD. C IF(NIT.GT.0) THEN DO 190 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN IF(NITER(I).GT.1) THEN DCFLUX=(CFLUX(I)-CFLUXM(I))/ 1 SIGN(MAX(.001,ABS(TSTEP(I))),TSTEP(I)) IF(ABS(TVIRTA(I)-TVIRTS(I)).LT.0.4) 1 DCFLUX=MAX(DCFLUX,0.8*DCFLXM(I)) DCFLXM(I)=DCFLUX ELSE DCFLUX=0. ENDIF DRDT0= -4.0*SBC*TZERO(I)**3 1 -RHOAIR(I)*SPHAIR*(CFLUX(I)+MAX(0.,TZERO(I)-TPOTA(I)) 2 *DCFLUX) -GCOEFF(I) 3 +CPHCH(I)*RHOAIR(I)*(CFLUX(I)*WZERO(I)*A(I) 4 *EVBETA(I)*(B(I)-TFREZ)/((TZERO(I)-B(I))* 5 (1.0+WZERO(I)))**2-(QZERO(I)-QA(I))*DCFLUX) TSTEP(I)=-RESID(I)/DRDT0 TSTEP(I)=MAX(-10.,MIN(5.,TSTEP(I))) TZERO(I)=TZERO(I)+TSTEP(I) NITER(I)=NITER(I)+1 NUMIT=NUMIT+1 ENDIF 190 CONTINUE ENDIF C IF(NUMIT.GT.0) GO TO 100 C C * IF CONVERGENCE HAS NOT BEEN REACHED, CALCULATE TEMPERATURE AND C * FLUXES ASSUMING NEUTRAL STABILITY. C DO 195 I=IL1,IL2 NUMIT=0 JEVAP(I)=0 IF(FI(I).GT.0. .AND.ITER(I).EQ.-1) THEN TZEROT=TVIRTA(I)/(1.0+0.61*QZERO(I)) IF(ABS(RESID(I)).GT.50.) THEN TZERO(I)=TZEROT IF(TZERO(I).GE.TFREZ) THEN A(I)=17.269 B(I)=35.86 ELSE A(I)=21.874 B(I)=7.66 ENDIF WZERO(I)=0.622*611.0*EXP(A(I)*(TZERO(I)-TFREZ)/ 1 (TZERO(I)-B(I)))/PADRY(I) Q0SAT(I)=WZERO(I)/(1.0+WZERO(I)) QZERO(I)=EVBETA(I)*Q0SAT(I)+(1.0-EVBETA(I))*QA(I) QLWOUT(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I) GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I) RESID(I)=QSWNET(I)+QLWIN(I)-QLWOUT(I)-GZERO(I) IF(RESID(I).GT.0.) THEN QEVAP(I)=RESID(I) ELSE QEVAP(I)=RESID(I)*0.5 ENDIF IF(IEVAP(I).EQ.0) QEVAP(I)=0.0 QSENS(I)=RESID(I)-QEVAP(I) RESID(I)=0. EVAP(I)=QEVAP(I)/CPHCH(I) TVIRTS(I)=TZERO(I)*(1.0+0.61*QZERO(I)) JEVAP(I)=1 NUMIT=NUMIT+1 ENDIF ENDIF 195 CONTINUE C IF(NUMIT.GT.0) THEN IF(ISLFD.LT.2) THEN CALL DRCOEF (CDM,CDH,RIB,CFLUX,QZERO,QA,ZOSCLM,ZOSCLH, 1 CRIB,TVIRTS,TVIRTA,VA,FI,JEVAP, 2 ILG,IL1,IL2) ELSE CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO, 1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA, 2 TZERO,QZERO,H,ZOM,ZOH, 3 LZZ0,LZZ0T,FM,FH,ILG,IL1,IL2,FI,JEVAP,JL ) ENDIF ENDIF C ENDIF C C * CHECK FOR BAD ITERATION TEMPERATURES. C IBAD=0 DO 200 I=IL1,IL2 IF(FI(I).GT.0. .AND. (TZERO(I).LT.123.16 .OR. 1 TZERO(I).GT.373.16)) THEN IBAD=I ENDIF 200 CONTINUE C IF(IBAD.NE.0) THEN WRITE(6,6275) IBAD,JL,TZERO(IBAD),NITER(IBAD),ISNOW 6275 FORMAT('0BAD ITERATION TEMPERATURE',3X,2I3,F16.2,2I4) WRITE(6,6280) QSWNET(IBAD),QLWIN(IBAD),QSENS(IBAD), 1 QEVAP(IBAD),GZERO(IBAD),CFLUX(IBAD),RIB(IBAD) 6280 FORMAT(2X,7F12.4) CALL XIT('TSOLVE',-1) ENDIF C C * POST-ITERATION CLEAN-UP. C NIT=0 DO 300 I=IL1,IL2 IF(FI(I).GT.0.) THEN IF(((IWATER(I).EQ.1 .AND. TZERO(I).LT.TFREZ) .OR. 1 (IWATER(I).EQ.2 .AND. TZERO(I).GT.TFREZ)) .OR. 2 (ISAND(I,1).EQ.-4 .AND. TZERO(I).GT.TFREZ)) THEN TZERO(I)=TFREZ WZERO(I)=0.622*611.0/PADRY(I) QZERO(I)=WZERO(I)/(1.0+WZERO(I)) TVIRTS(I)=TZERO(I)*(1.0+0.61*QZERO(I)) ITER(I)=1 NIT=NIT+1 ELSE ITER(I)=0 ENDIF ENDIF 300 CONTINUE C IF(NIT.GT.0) THEN C C * CALCULATE SURFACE DRAG COEFFICIENTS (STABILITY-DEPENDENT) AND C * OTHER RELATED QUANTITIES. C IF(ISLFD.LT.2) THEN CALL DRCOEF (CDM,CDH,RIB,CFLUX,QZERO,QA,ZOSCLM,ZOSCLH, 1 CRIB,TVIRTS,TVIRTA,VA,FI,ITER, 2 ILG,IL1,IL2) ELSE CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO, 1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA, 2 TZERO,QZERO,H,ZOM,ZOH, 3 LZZ0,LZZ0T,FM,FH,ILG,IL1,IL2,FI,ITER,JL ) ENDIF ENDIF C C * REMAINING CALCULATIONS. C DO 350 I=IL1,IL2 IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN QLWOUT(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I) IF(TZERO(I).LT.TPOTA(I)) THEN QSENS(I)=(RHOAIR(I)*SPHAIR*CFLUX(I)+EZERO)*(TZERO(I)- 1 TPOTA(I)) ELSE QSENS(I)=RHOAIR(I)*SPHAIR*CFLUX(I)*(TZERO(I)- 1 TPOTA(I)) ENDIF EVAP(I)=RHOAIR(I)*CFLUX(I)*(QZERO(I)-QA(I)) IF(EVAP(I).GT.EVPMAX(I)) EVAP(I)=EVPMAX(I) QEVAP(I)=CPHCH(I)*EVAP(I) GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I) QMELT(I)=QSWNET(I)+QLWIN(I)-QLWOUT(I)-QSENS(I)-QEVAP(I)- 1 GZERO(I) RESID(I)=0.0 IF(QMELT(I).LT.0.0) THEN QMELT(I)=QMELT(I)+QEVAP(I) QEVAP(I)=0.0 EVAP(I) =0.0 ENDIF ENDIF C IF(FI(I).GT.0.) THEN IF(ABS(EVAP(I)).LT.1.0E-8) THEN RESID(I)=RESID(I)+QEVAP(I) EVAP(I)=0.0 QEVAP(I)=0.0 ENDIF IF((ISNOW.EQ.1 .AND. QMELT(I).LT.0.0) .OR. 1 (ISNOW.EQ.0 .AND. QMELT(I).GT.0.0)) THEN GZERO(I)=GZERO(I)+QMELT(I) QMELT(I)=0.0 ENDIF C QSENS(I)=QSENS(I)+0.5*RESID(I) C GZERO(I)=GZERO(I)+0.5*RESID(I) QSENS(I)=QSENS(I)+RESID(I) QSWNET(I)=QSWNET(I)+QTRANS(I) EVAP(I)=EVAP(I)/RHOW ITERCT(I,KF(I),NITER(I))=ITERCT(I,KF(I),NITER(I))+1 ENDIF 350 CONTINUE C RETURN END end_of_data . endjcl.cdk #end_of_job