diff --git a/.github/scripts/icar_install_utils.sh b/.github/scripts/icar_install_utils.sh index d8546d86..d99e7b04 100755 --- a/.github/scripts/icar_install_utils.sh +++ b/.github/scripts/icar_install_utils.sh @@ -74,21 +74,24 @@ function icar_dependencies { sudo apt-get update sudo apt-get install libcurl4-gnutls-dev sudo apt-get install libfftw3-dev + sudo apt-get install netcdf-bin + sudo apt-get install libnetcdff-dev + # Installing HDF5 currently not working for NetCDF # sudo apt-get install libhdf5-dev libhdf5-openmpi-dev export CPPFLAGS="$CPPFLAGS -I${INSTALLDIR}/include" export LDFLAGS="$LDFLAGS -L${INSTALLDIR}/lib" - # Install szip (used by hdf5) - install_szip - # Install HDF5 - install_hdf5 + # # Install szip (used by hdf5) + # install_szip + # # Install HDF5 + # install_hdf5 - # Install NetCDF-C - install_netcdf_c - # Install NetCDF fortran - install_netcdf_fortran + # # Install NetCDF-C + # install_netcdf_c + # # Install NetCDF fortran + # install_netcdf_fortran # put installed bin directory in PATH export PATH=${INSTALLDIR}/bin:$PATH @@ -148,7 +151,17 @@ function gen_test_run_data { function execute_test_run { cp ${GITHUB_WORKSPACE}/src/icar ${GITHUB_WORKSPACE}/tests/ cd ${GITHUB_WORKSPACE}/tests - ./icar icar_options.nm + echo "Starting ICAR run" + ./icar icar_options.nml + time_dim=$(ncdump -v time icar_out_000001_2020-12-01_00-00-00.nc | grep "time = UNLIMITED" | sed 's/[^0-9]*//g') + + if [[ ${time_dim} == "1" ]]; then + echo "FAILURE: ICAR output time dimension should not be equal to one, it was ${time_dim}" + exit 1 + else + echo "SUCCESS: time dimension is equal to ${time_dim}" + exit 0 + fi } function icar_after_success { diff --git a/helpers/aggregate_parallel_files.py b/helpers/aggregate_parallel_files.py index 5f2c8bbb..9a40bfd5 100755 --- a/helpers/aggregate_parallel_files.py +++ b/helpers/aggregate_parallel_files.py @@ -76,7 +76,7 @@ def set_up_dataset(d): data = np.zeros((nt, nz, ny + y_off, nx + x_off)) # print(name, data.shape, dims, attrs) - data_vars[v] = xr.DataArray(data.astype(np.float32), dims=dims, name=name, attrs=attrs)#, coords=coords) + data_vars[v] = xr.DataArray(data.astype(d[v].dtype), dims=dims, name=name, attrs=attrs)#, coords=coords) ds = xr.Dataset(data_vars, attrs=d.attrs) ds.encoding = d.encoding diff --git a/helpers/batch_submit.sh b/helpers/batch_submit_LSF.sh similarity index 95% rename from helpers/batch_submit.sh rename to helpers/batch_submit_LSF.sh index 98a92ad7..25d88f28 100644 --- a/helpers/batch_submit.sh +++ b/helpers/batch_submit_LSF.sh @@ -4,7 +4,7 @@ # #BSUB -P P48500028 # project code #BSUB -W 12:00 # wall-clock time (hrs:mins) -#BSUB -n 1 # number of tasks in job +#BSUB -n 1 # number of tasks in job #BSUB -R "span[ptile=16]" # run 16 MPI tasks per node #BSUB -J run_name # job name #BSUB -o job_output/run_name.%J.out # job output file (%J is replaced by the job ID) @@ -24,7 +24,7 @@ PREFIX=run_name # it is useful to keep all other filenames relative to $PREFIX # note that this is not required anywhere though OUTDIR=$PREFIX -OPTFILE=${PREFIX}_options.nml +OPTFILE=${PREFIX}_options.nml BATCHFILE=${PREFIX}_batch_submit.sh TEMPLATE=${PREFIX}_template.nml @@ -58,17 +58,17 @@ if [[ ! -e ${PREFIX}_finished ]]; then if [[ -e ${PREFIX}_running ]]; then $SETUP_RUN $OPTFILE $TEMPLATE fi - + # declare that we have run before so the next job will know touch ${PREFIX}_running - + # run the actual executable (e.g. icar options.nml) $EXE $OPTFILE # typically the job will get killed while icar is running - # but for some reason bkilling the job still lets it touch _finished... + # but for some reason bkilling the job still lets it touch _finished... # maybe this will give it a chance to really kill it first? sleep 10 - + # if icar completes, we are done, tell the next job that we finished touch ${PREFIX}_finished else diff --git a/helpers/batch_submit_PBS.sh b/helpers/batch_submit_PBS.sh new file mode 100644 index 00000000..4aa4c6ae --- /dev/null +++ b/helpers/batch_submit_PBS.sh @@ -0,0 +1,92 @@ +#!/bin/bash +# + +### Job Name (will be used as prefix later on!) +#PBS -N icar_batch_run +### Project code +#PBS -A P48500028 +#PBS -l walltime=00:15:00 +#PBS -q regular +### Merge output and error files +#PBS -o job_output/log.out +### job error file (PBS will not allow use of ${PBS_JOBID} here? ) +#PBS -e job_output/log.err +### Select X nodes with 36 CPUs each for a total of 72 MPI processes +#PBS -l select=1:ncpus=36:mpiprocs=36:ompthreads=1 + +### PBS options for automation: https://gif.biotech.iastate.edu/submitting-dependency-jobs-using-pbs-torque + +# otherwise xarray is not available: +module load conda/latest +source /glade/u/apps/opt/conda/bin/activate + +# echo ${PBS_JOBID::7} + +# Set OpenMP variables +export OMP_NUM_THREADS=1 +# export MP_TASK_AFFINITY=core:$OMP_NUM_THREADS + +# the easy way +# icar icar_options.nml + +# the complex way (allows a continuous sequence of jobs) +PREFIX=$PBS_JOBNAME + +# it is useful to keep all other filenames relative to $PREFIX +# note that this is not required anywhere though +OUTDIR=$PREFIX +OPTFILE=${PREFIX}_options.nml +BATCHFILE=${PREFIX}_batch_submit.sh +TEMPLATE=${PREFIX}_template.nml + +# specify the location of the icar executable to use: +EXE=${HOME}/bin/icar + +# various useful helper scripts (SETUP_RUN is critical) +SETUP_RUN=${HOME}/icar/helpers/setup_next_run.py +MAKE_TEMPLATE=${HOME}/icar/helpers/make_template.py +MKOUTDIR=mkdir #/mkscratch.py # mkscratch creates the directory on scratch and links to it + + +# -------------------------------------------------- +# SHOULD NOT NEED TO MODIFY ANYTHING BELOW THIS LINE +# -------------------------------------------------- + +# if the template file doesn't exist yet, make it +if [[ ! -e $TEMPLATE ]]; then + $MAKE_TEMPLATE $OPTFILE $TEMPLATE > job_output/py_mktemp.out +fi + +# if the output directory doesn't exist, create it +if [[ ! -e $OUTDIR ]]; then + $MKOUTDIR $OUTDIR +fi + +# if we didn't finish yet we have to continue -BK: but we print this in line 87, so 2 jobs max? +if [[ ! -e ${PREFIX}_finished ]]; then + # first submit the next job dependant on this one + qsub -W depend=afterany:${PBS_JOBID} ${BATCHFILE} + + # if we have run before, setup the appropriate restart options + if [[ -e ${PREFIX}_running ]]; then + # echo "setting up next run (setup_next_run.py)" + $SETUP_RUN $OPTFILE $TEMPLATE > job_output/py_setup.out + fi + + # declare that we have run before so the next job will know + touch ${PREFIX}_running + + # run the actual executable (e.g. icar options.nml) + cafrun -n 36 $EXE $OPTFILE >> job_output/icar${PBS_JOBID::7}.out + # typically the job will get killed while icar is running + # but for some reason bkilling the job still lets it touch _finished... + # maybe this will give it a chance to really kill it first? + sleep 20 + + # if icar completes, we are done, tell the next job that we finished + touch ${PREFIX}_finished +else + # if the last job ran to completion, delete the inter-job communication files and exit + rm ${PREFIX}_running + rm ${PREFIX}_finished +fi diff --git a/helpers/batch_submit_SLURM.sh b/helpers/batch_submit_SLURM.sh new file mode 100644 index 00000000..993b66dc --- /dev/null +++ b/helpers/batch_submit_SLURM.sh @@ -0,0 +1,97 @@ +#!/bin/bash +### Job Name (will be used as prefix later on!) +#SBATCH --job-name="ICAR_tst" +#SBATCH --nodes=1 +#SBATCH --ntasks-per-node=32 +#SBATCH --time=00:05:00 +#SBATCH --constraint=haswell +#SBATCH --qos=debug +### Project code +#SBATCH --account=m4062 +### error and output files in separate folder, name with jobid (%x) an job name (%j) +### N.B: create the job_output folder before submitting this job! +#SBATCH --output=job_output/log-%x.%j.out +#SBATCH --error=job_output/log-%x.%j.err + +# Make sure a python environment with xarray is available: +module load python +conda activate myenv + +# Set OpenMP variables +export OMP_NUM_THREADS=1 +# export MP_TASK_AFFINITY=core:$OMP_NUM_THREADS + +# the easy way +# icar icar_options.nml + +# the complex way (allows a continuous sequence of jobs) +PREFIX=tst ##$SBATCH_JOB_NAME + +# it is useful to keep all other filenames relative to $PREFIX +# note that this is not required anywhere though +OUTDIR=$PREFIX +OPTFILE=options.nml #${PREFIX}_options.nml +BATCHFILE=batch_submit_SLURM.sh #${PREFIX}_batch_submit.sh +TEMPLATE=${PREFIX}_template.nml + +# the ICAR executable to use +EXE=$HOME/bin/icar_dbs + +# load any environmental settings to run icar properly (system dependent): +. /global/cfs/cdirs/m4062/env_scripts/UO-GNU-env.sh + + +# various useful helper scripts (SETUP_RUN is critical) +SETUP_RUN=${HOME}/icar/helpers/setup_next_run.py +MAKE_TEMPLATE=${HOME}/icar/helpers/make_template.py +MKOUTDIR=mkdir #/mkscratch.py # mkscratch creates the directory on scratch and links to it + + + +# -------------------------------------------------- +# SHOULD NOT NEED TO MODIFY ANYTHING BELOW THIS LINE +# -------------------------------------------------- + +# if the template file doesn't exist yet, make it +if [[ ! -e $TEMPLATE ]]; then + $MAKE_TEMPLATE $OPTFILE $TEMPLATE > job_output/py_mktemp.out +fi + +# # if the output directory doesn't exist, create it +# if [[ ! -e $OUTDIR ]]; then +# $MKOUTDIR $OUTDIR +# fi + +# if we didn't finish yet we have to continue -BK: but we print this in line 87, so 2 jobs max? +if [[ ! -e ${PREFIX}_finished ]]; then + # first submit the next job dependant on this one + # sub -w "ended(${PBS_JOBID})" < $BATCHFILE + # qsub -W depend=afterany:${PBS_JOBID} ${BATCHFILE} ## PBS version + sbatch --dependency=afternotok:$SLURM_JOB_ID ${BATCHFILE} + + # if we have run before, setup the appropriate restart options + if [[ -e ${PREFIX}_running ]]; then + # echo "setting up next run (setup_next_run.py)" + $SETUP_RUN $OPTFILE $TEMPLATE > job_output/py_setup.out + fi + + # declare that we have run before so the next job will know + touch ${PREFIX}_running + + # run the actual executable (e.g. icar options.nml) + # cafrun -n 36 $EXE $OPTFILE > job_output/icar_$SLURM_JOB_ID.out + cafrun -n 36 $EXE $OPTFILE >> job_output/icar.out ### if you prefer one log file for the icar output + + # typically the job will get killed while icar is running + # but for some reason bkilling the job still lets it touch _finished... + # maybe this will give it a chance to really kill it first? + sleep 10 + + # if icar completes, we are done, tell the next job that we finished + # BK dont understand this: wont it prevent the next (or after-next job from starting (ln 63)) + touch ${PREFIX}_finished +else + # if the last job ran to completion, delete the inter-job communication files and exit + rm ${PREFIX}_running + rm ${PREFIX}_finished +fi diff --git a/helpers/erai/config.py b/helpers/erai/config.py index 41918517..e1833436 100644 --- a/helpers/erai/config.py +++ b/helpers/erai/config.py @@ -13,7 +13,7 @@ def set_bounds(info): atm_file=info.atmdir+info.atmfile erai_file=atm_file.replace("_Y_","2000").replace("_M_","01").replace("_D_","01").replace("_h_","00") - varlist=["g4_lat_0","g4_lon_1"] + varlist=["g4_lat_0","g4_lon_1","Z_GDS4_HYBL","T_GDS4_HYBL","Q_GDS4_HYBL","LNSP_GDS4_HYBL","CLWC_GDS4_HYBL","CIWC_GDS4_HYBL","lv_HYBL2_a","lv_HYBL2_b","P0"] output_dir=info.nc_file_dir try: os.mkdir(output_dir) diff --git a/helpers/erai/convert.py b/helpers/erai/convert.py index 945c2b36..2fa1aa75 100644 --- a/helpers/erai/convert.py +++ b/helpers/erai/convert.py @@ -38,6 +38,29 @@ def convert_atm(data): return output_data +def bfill(arr): + ''' from https://stackoverflow.com/questions/41190852/most-efficient-way-to-forward-fill-nan-values-in-numpy-array + ''' + mask = np.isnan(arr) + idx = np.where(~mask, np.arange(mask.shape[1]), mask.shape[1] - 1) + idx = np.minimum.accumulate(idx[:, ::-1], axis=1)[:, ::-1] + out = arr[np.arange(idx.shape[0])[:,None], idx] + return out + + +def numpy_fill(arr): + '''modified from Solution provided by Divakar. + from https://stackoverflow.com/questions/41190852/most-efficient-way-to-forward-fill-nan-values-in-numpy-array + ''' + for i in range(arr.shape[0]): + mask = np.isnan(arr[i]) + idx = np.where(~mask,np.arange(mask.shape[1]),0) + np.maximum.accumulate(idx,axis=1, out=idx) + out = arr[i,np.arange(idx.shape[0])[:,None], idx] + arr[i] = bfill(out) # in case there are still missing values on the left side + + return arr + # icar_sfc_var=["sensible_heat","latent_heat","hgt_98","PBL_height"] def convert_sfc(data): global last_longwave @@ -53,6 +76,13 @@ def convert_sfc(data): output_data.lw = data.lw[np.newaxis,::-1,:] / dt # convert from Joules to W /m^2 output_data.cp = data.cp[np.newaxis,::-1,:] * 1000 # convert m to mm + output_data.landmask = data.landmask[np.newaxis,::-1,:] + # landval = data.tskin[np.argmax(data.landmask)] # ~273.15, alternatively, tskin[landmask>0.99].mean() + # above seems to always create an array, and sometimes with very different values in it ... e.g. >300... + landval = 273.16 + output_data["sst"] = (data.tskin[np.newaxis,::-1,:] - (output_data.landmask * landval)) / (1 - output_data.landmask) + output_data["sst"][output_data.landmask>0.25] =np.nan + output_data["sst"] = numpy_fill(output_data["sst"]) # this is now handled in io so it can just use the last value in the file, much simple # ... though in some ways what is below is better as it integrates over a longer time period # if last_longwave==None: diff --git a/helpers/erai/io_routines.py b/helpers/erai/io_routines.py index 0c1f0016..16fd7b08 100644 --- a/helpers/erai/io_routines.py +++ b/helpers/erai/io_routines.py @@ -4,8 +4,8 @@ from bunch import Bunch -sfcvarlist=["SSHF_GDS4_SFC","SLHF_GDS4_SFC","Z_GDS4_SFC","BLH_GDS4_SFC","SSRD_GDS4_SFC","STRD_GDS4_SFC", "SKT_GDS4_SFC", "CP_GDS4_SFC"] -icar_sfc_var=["sensible_heat","latent_heat","hgt_98","PBL_height","sw","lw", "tskin", "cp"] +sfcvarlist=["SSHF_GDS4_SFC","SLHF_GDS4_SFC","Z_GDS4_SFC","BLH_GDS4_SFC","SSRD_GDS4_SFC","STRD_GDS4_SFC", "SSTK_GDS4_SFC", "CP_GDS4_SFC", "LSM_GDS4_SFC"] +icar_sfc_var=["sensible_heat","latent_heat","hgt_98","PBL_height","sw","lw", "tskin", "cp","landmask"] atmvarlist=["Z_GDS4_HYBL","T_GDS4_HYBL","Q_GDS4_HYBL","LNSP_GDS4_HYBL","CLWC_GDS4_HYBL","CIWC_GDS4_HYBL","lv_HYBL2_a","lv_HYBL2_b","P0"] icar_atm_var=["gph","t","qv","ln_p_sfc","cloud","ice","sigma_a","sigma_b","P0"] @@ -92,7 +92,7 @@ def load_atm(time,info): """Load atmospheric variable from a GRIB file""" uvfile,scfile=find_atm_file(time,info) uvnc_file=grib2nc(uvfile,atmuvlist,info.nc_file_dir) - scnc_file=grib2nc(scfile,atmvarlist,info.nc_file_dir) + scnc_file=grib2nc(scfile,atmvarlist+["g4_lat_0","g4_lon_1"],info.nc_file_dir) outputdata=Bunch() for s,v in zip(icar_uv_var,atmuvlist): diff --git a/helpers/erai/output.py b/helpers/erai/output.py index 8f63a11f..cb20837b 100644 --- a/helpers/erai/output.py +++ b/helpers/erai/output.py @@ -63,9 +63,15 @@ def write_file(date,info,erai): atts=Bunch(long_name="Planetary Boundary Layer Height",units="m") extra_vars.append(Bunch(name="PBL_height",data=erai["PBL_height"],dims=dims2dt,dtype="f",attributes=atts)) + atts=Bunch(long_name="Land fraction",units="") + extra_vars.append(Bunch(name="landfraction",data=erai["landmask"],dims=dims2dt,dtype="f",attributes=atts)) + atts=Bunch(long_name="Skin Temperature",units="K") extra_vars.append(Bunch(name="tskin",data=erai["tskin"],dims=dims2dt,dtype="f",attributes=atts)) + atts=Bunch(long_name="Sea Surface Temperature",units="K") + extra_vars.append(Bunch(name="sst",data=erai["sst"],dims=dims2dt,dtype="f",attributes=atts)) + atts=Bunch(long_name="Convective precipitation",units="mm") extra_vars.append(Bunch(name="cp",data=erai["cp"],dims=dims2dt,dtype="f",attributes=atts)) diff --git a/helpers/fix_icar_time.py b/helpers/fix_icar_time.py new file mode 100644 index 00000000..ba1d6a54 --- /dev/null +++ b/helpers/fix_icar_time.py @@ -0,0 +1,96 @@ +#!/usr/bin/python +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +# +# ICAR helper script to fix tinestamps when an exisitng output file has been overwritten after a restart. +# This leads to incorrect timestamps in the file, as the time:units attribute is not overwritten. As a result, +# one or more hours after the restart have the original 'days since' attribute, but new 'time' values, +# leading to weird jumps in time. +# Best is to remove the output file(s) before restarting (i.e. the output files of the timestep one is restarting from). +# But in case one forgets to do so, this script can (brute force) fix it. +# More elegant solutions are undoubtedly possible (using option B below) , but I'll leave that to more skilled programmers +# +# Usage: +# > python fix_icar_times.py -i -o +# N.B. if no output file is specified, inputfile will be overwritten. +# +# Note: +# - currently (Option A) Modifies the time:units attribute from "days since" to "hours since". Not ideal but works. +# - only tested for output files with hourly resolution. +# +# +# Bert Kruyt, March 2022. NCAR. +# +# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + +import pandas as pd +# from datetime import datetime +import xarray as xr +# import numpy as np +import sys, getopt + + + +def main(argv): + + """overwrite the times in an icar file based on its filename. Only tested for hourly output files""" + + inputfile = '' + outputfile = '' + try: + opts, args = getopt.getopt(argv,"hi:o:",["ifile=","ofile="]) + except getopt.GetoptError: + print( 'usage: fix_icar_time.py -i -o ' ) + sys.exit(2) + for opt, arg in opts: + if opt == '-h': + print( 'use: fix_icar_time.py -i -o ' ) + sys.exit() + elif opt in ("-i", "--ifile"): + inputfile = arg + elif opt in ("-o", "--ofile"): + outputfile = arg + + print( 'Input file is ', inputfile) + print( 'Output file is ', outputfile) + + + #### Option A: less elegant, but more robust: #### + #_______ open the icar file: ______ + FIX = xr.open_dataset( inputfile ) + + + #_______ create the correct times: ______ + tstring = inputfile[inputfile.find('out_')+4:inputfile.rfind(".nc")] + + times2 = pd.date_range(tstring[:10], periods=len(FIX.time), freq='H') + + FIX['time'] = times2 + + + #_______ Write the fixed Dataset to nc file: _________ + + if outputfile == '': + out_path = inputfile + else: + out_path = outputfile + + FIX.to_netcdf( path=out_path, mode='w', encoding={'time': {'dtype': 'i4'}}) + + + + ########### Option B: only modify units, but this doesnt always work as sometimes it is only the first hour, sometimes more hours. ######## + # #_______ open the icar file: ______ + # FIX = xr.open_dataset( inputfile , decode_times=False) + + # #_______ create the correct times: ______ + # units = FIX.time.units + # tstring = inputfile[inputfile.find('out_')+4:inputfile.rfind(".nc")] + # # create right time based on file name: + # FIX['time'].attrs['units'] = units[:units.find('since')+6] + tstring[:10] + + + +if __name__ == "__main__": + main(sys.argv[1:]) + + diff --git a/helpers/genNetCDF/Forcing.py b/helpers/genNetCDF/Forcing.py index 30f56728..8f0567e5 100644 --- a/helpers/genNetCDF/Forcing.py +++ b/helpers/genNetCDF/Forcing.py @@ -1,11 +1,8 @@ -from netCDF4 import Dataset -import xarray as xr +import datetime import pandas as pd import numpy as np -import datetime +import xarray as xr import math -from genNetCDF import fixType -from sys import exit # Create NetCDF file containing the forcing data class Forcing: @@ -13,34 +10,55 @@ class Forcing: attributes = {"history": "Dec 01 00:00:00 2020"} - def __init__(self, nz=10, nx=2, ny=2, sealevel_pressure=100000.0, - rh=0.9, u_val=0.5, v_val=0.5, w_val=0.0, - water_vapor_val=0.001, theta_val=300.0, nt=2, - height_value=500, dx=10, dy=10, dz_value=500.0): - + def __init__(self,nt=10, nz=10, nx=2, ny=2, sealevel_pressure=100000.0, + u_val=0.5, v_val=0.5, w_val=0.0, + water_vapor_val=0.001, theta_val=300.0, + height_value=500, dx=10, dy=10, dz_value=500.0, + qv_val=0.1, weather_model='basic', + pressure_func='calc_pressure_from_sea', + hill_height=0, lat0 = 39.5, + lon0 = -105, + Schaer_test=False): + print(weather_model.capitalize(), "weather model in use") self.setup_class_variables(nz, nx, ny, nt, sealevel_pressure) - # -------------------------------------------------------------- - # Create and define variables for datafile - # -------------------------------------------------------------- - # create time - nt = 2 + # --- Create and define variables for datafile + # lat_flat = np.arange(39,39+nx*dx, dx) + # lon_flat = np.arange(-107,-107+ny*dy, dy) + + # center around lat0, lon0 (i.s.o. corner), so we can align with hi-res grid. + lon_flat = np.arange(lon0-(nx/2*dx/111111/np.cos(np.radians(lat0))), + lon0+(nx/2*dx/111111/np.cos(np.radians(lat0))), + dx/111111/np.cos(np.radians(lat0)) + )[:nx] + lat_flat = np.arange(lat0-(ny/2*dy/111111), + lat0+(ny/2*dy/111111), + dy/111111 + )[:ny] + + x_m = np.arange(-nx*dx/2,nx*dx/2, dx) + + + print( " forcing lon/lat min/max: ", np.min(lon_flat), np.max(lon_flat), np.min(lat_flat), np.max(lat_flat) ) + # print(" forcing lat min/max: ", np.amin(lat_flat), np.amax(lat_flat)) + # lon_flat, lat_flat = np.meshgrid(lon_tmp, lat_tmp) + + self.define_data_variables(nt, nz, nx, ny, height_value, lat_flat, + lon_flat, dz_value, theta_val, u_val, + v_val, qv_val, weather_model, pressure_func, + hill_height, Schaer_test, dx, x_m) + + # define time t0 = datetime.datetime(2020,12,1) - time = xr.DataArray([t0+datetime.timedelta(dt*100) for dt in range(nt)], name="time", + time = xr.DataArray([t0+datetime.timedelta(hours=dt) for dt in range(nt)], name="time", dims=["time"]) - # create longitude and latitude - lat_tmp = np.zeros([nt, nx, ny]) - lon_tmp = np.zeros([nt, nx, ny]) - lat_flat = np.arange(39,39+nx*dx, dx) - lon_flat = np.arange(-107,-107+ny*dy, dy) + # --- Write all variable to netcdf file + self.write_netcdf_file(time) - self.define_data_variables(nt, nz, nx, ny, height_value, lat_flat, - lon_flat, dz_value) - # -------------------------------------------------------------- - # Combine variables, create dataset and write to file - # -------------------------------------------------------------- + # Combine variables, create dataset and write to file + def write_netcdf_file(self, time): data_vars = dict( u = self.u, v = self.v, @@ -49,8 +67,10 @@ def __init__(self, nz=10, nx=2, ny=2, sealevel_pressure=100000.0, height = self.height, z = self.z, pressure = self.pressure, + temperature = self.temperature, lat_m = self.lat, lon_m = self.lon, + x_m = self.x_m, time = time) ds = xr.Dataset( @@ -58,15 +78,11 @@ def __init__(self, nz=10, nx=2, ny=2, sealevel_pressure=100000.0, attrs = self.attributes ) - ds.to_netcdf("forcing.nc", "w", "NETCDF4", unlimited_dims='time') + ds.to_netcdf("forcing.nc", "w", "NETCDF4", unlimited_dims='time', encoding={'time': {'dtype': 'i4'}}) def set_water_vapor(self, water_vapor, temperature, pressure): - for k in range(1,self.nz): - for i in range(0,self.nx): - for j in range(0,self.ny): - water_vapor[k,i,j] = sat_mr(temperature[k,i,j], - pressure[k,i,j]) + water_vapor = sat_mr(temperature, pressure) return water_vapor @@ -79,22 +95,22 @@ def setup_class_variables(self, nz, nx, ny, nt, sealevel_pressure): dimensions4d = { "time": nt, "level": nz, - "lat": nx, - "lon": ny + "lat": ny, + "lon": nx } dimensions3d = { "level": nz, - "lat": nx, - "lon": ny + "lat": ny, + "lon": nx } dimensions3d_t = { "time": nt, - "lat": nx, - "lon": ny + "lat": ny, + "lon": nx } dimensions2d = { - "lat": nx, - "lon": ny + "lat": ny, + "lon": nx } dimensions1d = { "time": 1 @@ -105,61 +121,75 @@ def setup_class_variables(self, nz, nx, ny, nt, sealevel_pressure): self.dimensions3d_t = dimensions3d_t self.dimensions2d = dimensions2d self.dimensions1d = dimensions1d + self.dims4d = list(dimensions4d.keys()) + self.dims3d = list(dimensions3d.keys()) + self.dims2d = list(dimensions2d.keys()) + self.dims1d = list(dimensions1d.keys()) - def define_data_variables(self, nt, nz, nx, ny, height_value,lat_flat, - lon_flat, dz_value): - dims2d = ["lat", "lon"] - dims4d = ["time","level","lat", "lon"] + def define_data_variables(self, nt, nz, nx, ny, height_value,lat_flat, + lon_flat, dz_value, theta_val, u_val, v_val, + qv_val, weather_model, pressure_func, hill_height, + Schaer_test, dx, x_m): + # --- u variable - self.u = xr.Variable(dims4d, - np.full([nt, nz, nx, ny], 0.5), + # if advection test is selected, set the appropriate windfield: + if Schaer_test==True: + z1 = 4000. ; z2 = 5000. ; hill_height = 3000.0 ; u0=10 + u_val = np.array( [0]* int(z1/dz_value) + + [u0* (np.sin(np.pi/2*(z1/dz_value+1 - z1/dz_value) / ((z2-z1)/dz_value) ))**2 ] + + [u0* (np.sin(np.pi/2*(z1/dz_value+2 - z1/dz_value) / ((z2-z1)/dz_value) ))**2 ] + + [u0] * nz #int(nz-z2/dz_value) + ) + u_array=np.tile(u_val[:nz], (nt,nx,ny,1) ) + u_array = np.transpose(u_array,(0,3,2,1) ) # order? + + # if uval is given as a single float, make a uniform windfield: + elif isinstance(u_val, float): + u_array= np.full([nt, nz, ny, nx], u_val[:nz]) + # if u_val is given as a vector, interpret this a vector in the z direction (bottom-top): + elif isinstance(u_val, np.ndarray): + u_array=np.tile(u_val[:nz], (nt,nx,ny,1) ) + u_array = np.transpose(u_array,(0,3,2,1) ) + # print(U.shape) + print(" Treating u_test_val as a u field in z-direction") + + self.u = xr.Variable(self.dims4d, + u_array, {'long_name':'U (E/W) wind speed', 'units':"m s**-1"}) + # --- v variable - self.v = xr.Variable(dims4d, - np.full([nt, nz, nx, ny], 0.25), + if Schaer_test==True: v_val=0. + self.v = xr.Variable(self.dims4d, + np.full([nt, nz, ny, nx], v_val), {'long_name':'V (N/S) wind speed', 'units':"m s**-1"}) - # --- potential temperature variable - self.theta = xr.Variable(dims4d, - np.full([nt, nz, nx, ny], 270.), - {'long_name':'Potential Temperature', 'units':"K"}) - # --- qv variable - self.qv = xr.Variable(dims4d, - np.full([nt, nz, nx, ny], 0.1), - {'long_name':'Relative Humidity', 'units':"kg kg**-1"}) # --- height - self.height = xr.Variable(dims2d, - np.full([nx, ny], height_value), + self.height = xr.Variable(self.dims2d, + np.full([ny, nx], height_value), {'long_name':'Topographic Height', 'units':'m'}) # --- Atmospheric Elevation - dz = np.full([nz,nx,ny], dz_value) - z_data = np.full([nt,nz,nx,ny], height_value) - for k in range(1,nz): - for i in range(0,nx): - for j in range(0,ny): - z_data[:,k,i,j] = z_data[:,k-1,i,j] + dz[k,i,j] - self.z = xr.Variable(dims4d, - z_data, - {'long_name':'Atmospheric Elevation', - 'units':'m', - 'positive':'up'}) + dz = np.full([nz,ny,nx], dz_value) + z_data = np.full([nt,nz,ny,nx], height_value) + # dz[0,:,:] = [50.] + # dz[1,:,:] = [75.] + # dz[2,:,:] = [125.] + # dz[3,:,:] = [200.] + # dz[4,:,:] = [300.] + # dz[5,:,:] = [400.] - # --- Pressure - pressure_data = np.zeros([nt,nz,nx,ny]) - for k in range(0,nz): - for i in range(0,nx): - for j in range(0,ny): - pressure_data[:,k,i,j] = self.sealevel_pressure * \ - (1 - 2.25577E-5 * z_data[0,k,i,j])**5.25588 - self.pressure = xr.Variable(dims4d, - pressure_data, - {'long_name':'Pressure', - 'units':'Pa'}) - del(pressure_data) + for k in range(1,nz): + z_data[:,k,:,:] = z_data[:,k-1,:,:] + dz[k,:,:] + self.z_data = z_data + self.z = xr.Variable(self.dims4d, + z_data, + {'long_name':'Atmospheric Elevation', + 'units':'m', + 'positive':'up'}) + del(z_data) # --- Latitude self.lat = xr.Variable(["lat"], @@ -167,6 +197,7 @@ def define_data_variables(self, nt, nz, nx, ny, height_value,lat_flat, {'long_name':'latitude', 'units':'degree_north'} ) + # --- Longitude self.lon = xr.Variable(["lon"], lon_flat, @@ -174,21 +205,208 @@ def define_data_variables(self, nt, nz, nx, ny, height_value,lat_flat, 'units':'degree_east'} ) + # --- x_m + self.x_m = xr.Variable(["x_m"], + x_m, + {'long_name':'x distance from domain center', + 'units':'meters'} + ) -# Taken from atm_utilities.f90 -def sat_mr(temperature,pressure): - if (temperature < 273.15): - a = 21.8745584 - b = 7.66 + + # --- potential temperature variable + self.set_theta(theta_val, weather_model) + + # --- Pressure + self.set_pressure(weather_model, pressure_func) + + # --- Temperature + self.set_temperature(weather_model) + + # --- qv variable + if Schaer_test==True: + # create a small blob of moisture, in an otherwise dry environment. Values from Schaer et al 2002 + qv_arr = np.zeros([nt,nz,ny,nx]) + z0 = int(9000/dz_value) + x0 = int(-50000/dx + nx/2) # -50km + Ax = int(25000/dx) + Az = int(3000/dz_value) + print(" setting up advection test with a cloud of qv with half-width ",Ax,"km") + if x0-Ax<0: + print(" QV blob outside forcing domain; increase nx_lo and or dx_lo (currently",nx, " and ", dx) + print(" x0-Ax=", x0-Ax) + for r in np.arange(1,0,-0.05): + for t in np.arange(0,np.pi*2,0.1): + qv_arr[0, + z0-int(r*Az*np.sin(t)):z0+int(r*Az*np.sin(t)), + :, + x0-int(np.cos(t)*r*Ax):x0+int(np.cos(t)*r*Ax), + ] = (np.cos(np.pi*r/2))**2 *qv_val + print(" qv_arr min: ",np.amin(qv_arr), " max:", np.amax(qv_arr)) + + else: # homogenous qv throughout domain + qv_arr = np.full([nt,nz,ny,nx], qv_val) + + self.qv = xr.Variable(self.dims4d, + # np.full([nt, nz, nx, ny], ), + qv_arr, + {'long_name':'Relative Humidity', + 'units':"kg kg**-1"}) + + + + def set_theta(self, theta_val, model='basic'): + if model in ['basic']: + theta = np.full([self.nt, self.nz, self.ny, self.nx], theta_val) + elif model in ['WeismanKlemp']: + print('Note: theta value of', theta_val, + 'has been replaced with a profile generated for', model, + 'model') + theta = np.zeros([self.nt, self.nz, self.ny, self.nx]) + theta[0,:,:,:] = np.vectorize(calc_wk_theta)(self.z_data[0,:,:,:]) + theta[:,:,:,:] = theta[0,:,:,:] + self.theta = xr.Variable(self.dims4d, theta, + {'long_name':'Potential Temperature', + 'units':"K"}) + + def set_pressure(self, model='basic', + pressure_func='calc_pressure_from_sea'): + print('Pressure function used is', pressure_func) + # basic is defined in ICAR's atm_utilities + pressure_data = np.zeros([self.nt,self.nz,self.ny,self.nx]) + # print(self.z_data[0,:,0,0]) + if model in ['basic', 'WeismanKlemp']: + if pressure_func == 'calc_pressure_from_sea': + pressure_data[:,:,:,:] = np.vectorize(calc_pressure_from_sea)( + self.sealevel_pressure, + self.z_data[:,:,:,:]) + elif pressure_func in ['calc_pressure_dz_iter', + 'calc_pressure_1m_iter']: + pressure_data[:,0,:,:] = \ + np.vectorize(pressure_func_d[pressure_func])( + self.sealevel_pressure, + 0, + self.z_data[0,0,:,:]) + for z in range(1,self.nz): + pressure_data[:,z,:,:] = \ + np.vectorize(pressure_func_d[pressure_func])( + pressure_data[0,z-1,:,:], + self.z_data[0,z-1,:,:], + self.z_data[0,z,:,:]) + self.pressure = xr.Variable(self.dims4d, + pressure_data, + {'long_name':'Pressure', + 'units':'Pa'}) + else: + print("Error: ", pressure_model, " is not defined") + exit() + # print("NX NY", self.nx, self.ny) + for t in range(self.nt): + for i in range(self.nx): + for j in range(self.ny): + if not np.array_equal(pressure_data[t,:,0,0], + pressure_data[t,:,j,i]): + print("ERROR: PRESSURE DATA NOT EQUAL THROUGHOUT") + sys.exit() + # print("--- PRESSURE DATA EQUAL THROUGHOUT ---") + # print(pressure_data[0,:,0,0]) + # exit() + del(pressure_data) + + + def set_temperature(self, model='basic'): + if (model in ['basic', 'WeismanKlemp']): + # --TODO-- + # get better equation with temp and humidity + # look at ICAR + temp = np.zeros([self.nt, self.nz, self.ny, self.nx]) + temp = np.vectorize(calc_temp)(self.pressure.values, + self.theta.values) + else: + print("Error: ", weather_model, " temperature is not defined") + exit() + self.temperature = xr.Variable(self.dims4d, temp, + {'long_name':'Temperature', + 'units':"K"}) + + +#--- +# Lambda like functions used for np.vectorize +#--- +# Weisman Klemp Theta equation +# z is elevation in meters +def calc_wk_theta(z): + z_tr = 12000. # m + theta_0 = 300. # + theta_tr = 343. # K + T_tr = 213. # K + WK_C_p = 1000.0 + # WK_C_p = 1003.5 + # q_v0 = 11 # g kg^-1 + # q_v0 = 16 # g kg^-1 + # q_v0 = 14 # g kg^-1 + if z <= z_tr: + theta = theta_0 + (theta_tr - theta_0) * (z / z_tr) ** (5./4) else: - a = 17.2693882 - b = 35.86 - e_s = 610.78 * math.exp(a * (temperature - 273.16) / (temperature - b)) - if ((pressure - e_s) <= 0): - e_s = pressure * 0.99999 + theta = theta_tr * math.exp((gravity / (WK_C_p * T_tr)) * (z - z_tr)) + return theta + +# --- +# Functions taken from or based on functions from atm_utilities.f90 +# --- +# Constancts from icar_constants.f90 +gravity = 9.81 +R_d = 287.058 +C_p = 1003.5 +Rd_over_Cp = R_d / C_p +P_0 = 100000 + +# p input pressure dz below, t temperature in layer between +# qv water vapor in layer between +def compute_p_offset(p, dz, t, qv): + return p * exp( -dz / (Rd / gravity * ( t * ( 1 + 0.608 * qv ) ))) + +def calc_pressure_from_sea(sealevel_pressure, z): + return sealevel_pressure * (1 - 2.25577E-5 * z)**5.25588 + +def calc_pressure_dz_iter(base_pressure, from_z, to_z): + return base_pressure * (1 - 2.25577E-5 * (to_z - from_z))**5.25588 + +def calc_pressure_1m_iter(pressure, from_z, to_z): + dz = 1 + for i in range(from_z,to_z,dz): + pressure = pressure * (1 - 2.25577E-5 * dz)**5.25588 + return pressure + +pressure_func_d = { + 'calc_pressure_dz_iter':calc_pressure_dz_iter, + 'calc_pressure_1m_iter':calc_pressure_1m_iter} + +# theta * exner +def calc_temp(pressure, theta): + return theta * (pressure / P_0)**Rd_over_Cp + +# Modified from atm_utilities.f90 +def sat_mr(temperature,pressure): + + e_s = np.zeros(temperature.shape) + + freezing = (temperature < 273.16) + a = 21.8745584 + b = 7.66 + e_s[freezing] = 610.78 * np.exp(a * (temperature[freezing] - 273.16) / (temperature[freezing] - b)) + + a = 17.2693882 + b = 35.86 + freezing = not freezing + e_s[freezing] = 610.78 * np.exp(a * (temperature[freezing] - 273.16) / (temperature[freezing] - b)) + + # not quite sure what this is needed for, maybe very low pressure rounding errors? + high_es = e_s > pressure + e_s[high_es] = pressure[high_es] * 0.9999 + sat_mr_val = 0.6219907 * e_s / (pressure - e_s) + return sat_mr_val def calc_exner(pressure): - po=100000; Rd=287.058; cp=1003.5 - return (pressure / po) ** (Rd/cp) + return (pressure / p_0) ** Rd_over_Cp diff --git a/helpers/genNetCDF/ICARoptions.py b/helpers/genNetCDF/ICARoptions.py index 8a6f1ed4..6c54ef28 100644 --- a/helpers/genNetCDF/ICARoptions.py +++ b/helpers/genNetCDF/ICARoptions.py @@ -1,122 +1,286 @@ -import sys - # class generates ICAR namelist file class ICARoptions: - def __init__(self): - self.f = open('icar_options.nm', 'w') - self.gen(self.model_version) - self.gen(self.output_list) - self.gen(self.physics) - self.gen(self.files_list) - self.gen(self.parameters) - self.clean_var_list() - self.gen(self.var_list) - self.gen(self.z_info) - self.close() - print("generated ICAR options") - - - def gen(self, nml): - f = self.f - f.write("&"+nml['name']) + def __init__(self, + filename = 'icar_options.nml', + # model namelist + model_version = 2.1, + model_comment = 'Unit Test Data', + # output namelist + output_vars = ['u','v','precipitation','swe'], + output_interval = 3600, + output_file = 'icar_out_', + restart_interval = 3600, + restart_file = 'icar_rst_', + # physics namelist + phys_opt_pbl = 0, + phys_opt_lsm = 0, + phys_opt_water = 0, + phys_opt_mp = 2, + phys_opt_rad = 0, + phys_opt_conv = 0, + phys_opt_adv = 1, + phys_opt_wind = 0, + # files namelist + init_conditions_file = 'init.nc', + boundary_files = 'forcing.nc', + forcing_file_list = [], + # z_info namelist + dz_levels = [50., 75., 125., 200., 300., 400.] + [500.] * 50, + space_varying = ".True.", + flat_z_height = -1, + fixed_dz_advection = ".True.", + sleve=".True.", + terrain_smooth_windowsize = 4, + terrain_smooth_cycles = 5, + decay_rate_L_topo = 1.0, + decay_rate_S_topo = 5.0, + sleve_n = 1.35, + # forcing variables namelist + forc_u_var = 'u', + forc_v_var = 'v', + forc_p_var = 'pressure', + forc_t_var = 'theta', + forc_qv_var = 'qv', + forc_hgt_var = 'height', + forc_z_var = 'z', + forc_lat_var = 'lat_m', + forc_lon_var = 'lon_m', + forc_lat_hi_var = 'lat_hi', + forc_lon_hi_var = 'lon_hi', + forc_hgt_hi_var = 'hgt_hi', + forc_time_var = 'time', + # parameters namelist + start_date = '2020-12-01 00:00:00', + end_date = '2020-12-02 00:00:00', + calendar = 'standard', + input_interval = '3600', + dx = '4000.0', + qv_is_relative_humidity ='true', + readdz = 'true', + nz = '15', + z_is_geopotential = 'False', + z_is_on_interface = 'False', + t_is_potential = 'True', + time_varying_z = 'False', + ideal='True', + debug='True', # currently this writes the global jacobian to a netcdf file, and gives min/max values of the jacobian on runtime. + smooth_wind_distance = '72000', + use_agl_height = True, # Use height above ground level to interpolate the wind field instead of height above sea level. + agl_cap = 400, # Height at which we switch from AGL-interpolation to using ASL-interpolation + # parcels namelist + total_parcels = 0): + + # Open file, create namelist objects, then write + f = open(filename, 'w') + self.model_version = ModelVersion(filename=f, + version=model_version, + comment=model_comment) + + self.output_list = OutputList(filename=f, + names=output_vars, + outputinterval=output_interval, + output_file=output_file, + restartinterval=restart_interval, + restart_file=restart_file) + + self.physics_list = PhysicsList(filename=f, + pbl=phys_opt_pbl, + lsm=phys_opt_lsm, + water=phys_opt_water, + mp=phys_opt_mp, + rad=phys_opt_rad, + conv=phys_opt_conv, + adv=phys_opt_adv, + wind=phys_opt_wind) + + self.files_list = FilesList(filename=f, + init_conditions_file=init_conditions_file, + boundary_files=boundary_files, + forcing_file_list=forcing_file_list) + + self.z_info_list = ZInfoList(filename=f, + dz_levels=dz_levels, + space_varying = space_varying, + flat_z_height = flat_z_height , + fixed_dz_advection = fixed_dz_advection, + sleve=sleve, + terrain_smooth_windowsize = terrain_smooth_windowsize, + terrain_smooth_cycles = terrain_smooth_cycles , + decay_rate_L_topo = decay_rate_L_topo, + decay_rate_S_topo = decay_rate_S_topo, + sleve_n = sleve_n + ) + + self.forcing_var_list = ForcingVarList(filename=f, + uvar=forc_u_var, + vvar=forc_v_var, + pvar=forc_p_var, + tvar=forc_t_var, + qvvar=forc_qv_var, + hgtvar=forc_hgt_var, + zvar=forc_z_var, + latvar=forc_lat_var, + lonvar=forc_lon_var, + lat_hi=forc_lat_hi_var, + lon_hi=forc_lon_hi_var, + hgt_hi=forc_hgt_hi_var, + time_var=forc_time_var) + + self.parameters_list = ParametersList(filename=f, + forcing_start_date=start_date, + end_date=end_date, + calendar=calendar, + inputinterval=input_interval, + dx=dx, + qv_is_relative_humidity =\ + qv_is_relative_humidity, + ideal=ideal, + debug=debug, + readdz=readdz, + nz=nz, + z_is_geopotential =\ + z_is_geopotential, + z_is_on_interface =\ + z_is_on_interface, + t_is_potential =\ + t_is_potential, + time_varying_z =\ + time_varying_z, + use_agl_height =\ + use_agl_height, + agl_cap=agl_cap, + smooth_wind_distance =\ + smooth_wind_distance) + self.parcels_list = ParcelsList(filename=f, + total_parcels=total_parcels) + + self.generate_all_namelists() + f.close() + + + def generate_all_namelists(self): + self.model_version.gen() + self.output_list.gen() + self.physics_list.gen() + self.files_list.gen() + self.z_info_list.gen() + self.forcing_var_list.gen() + self.parameters_list.gen() + self.parcels_list.gen() + + +class Namelist: + def __init__(self, kargs): + self.filename = kargs['filename'] + del kargs['filename'] + self.nml = {} + for name, val in kargs.items(): + self.nml[name] = val + self.remove_empty_values() + def remove_empty_values(self): + delete = [] + for name, val in self.nml.items(): + if val in ['', ""]: + delete.append(name) + for name in delete: + del self.nml[name] + def gen(self): + f = self.filename + f.write("&"+self.nml['name']) + del self.nml['name'] i = 0 - for name, val in nml.items(): - if name == 'name': - continue + for name, val in self.nml.items(): if i != 0: - f.write(',') + f.write(', \n') else: f.write('\n') i += 1 f.write(str(name)+'='+str(val)) - f.write('\n/\n') + f.write('\n/\n\n') + - def close(self): - self.f.close() +class ModelVersion(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'model_version' - def clean_var_list(self): - for name, val in self.var_list.items(): + def gen(self): + for name, val in self.nml.items(): + if name == 'comment': + self.nml[name] = '"' + val + '"' + super().gen() + + +class OutputList(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'output_list' + def gen(self): + for name, val in self.nml.items(): + if name == 'names': + self.nml[name] = '"' + '","'.join(val) + '"' + if name in ['output_file', 'restart_file']: + self.nml[name] = '"' + val + '"' + super().gen() + + +class PhysicsList(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'physics' + + +class FilesList(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'files_list' + def gen(self): + for name, val in self.nml.items(): + if name == 'forcing_file_list': + self.nml[name] = '"' + '","'.join(val) + '"' + elif name != 'name': + self.nml[name] = '"' + val + '"' + super().gen() + + +class ZInfoList(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'z_info' + def gen(self): + for name, val in self.nml.items(): + if name == 'dz_levels': + self.nml[name] = str(val)[1:-1] + super().gen() + + +class ForcingVarList(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'var_list' + + def gen(self): + for name, val in self.nml.items(): if name == 'name': continue - self.var_list[name] = '"' + val + '"' - # print(name, val) - - # namelist options to write - model_version = { - 'name': 'model_version', - 'version': 2.0, - 'comment': '"Unit Test Data"' - } - - output_list = { - 'name': 'output_list', - 'names': '"u","v","ta2m","hus2m", "precipitation", "swe"', - 'outputinterval': 3600, - 'output_file': '"out_"' - } - - physics = { - 'name': 'physics', - 'pbl': 0, 'lsm': 0, - 'water': 0, 'mp': 2, - 'rad': 0, 'conv': 0, - 'adv': 1, 'wind': 0 - } - - files_list = { - 'name': 'files_list', - 'init_conditions_file': '"init.nc"', - # 'boundary_files':'TBD', - 'forcing_file_list': '"forcing.nc"' - } - - z_info = { - 'name': 'z_info', - 'dz_levels': str([50., 75., 125., 200., 300., 400.] + [500.] * 35)[1:-1] - } - - - var_list = { - # forcing variables - 'name': 'var_list', - 'uvar':'u', - 'vvar':'v', - 'pvar': 'pressure', - 'tvar': 'theta', - 'qvvar': 'qv', # water_vapor - 'hgtvar': 'height', - 'zvar': 'z', - 'latvar': 'lat_m', - 'lonvar': 'lon_m', - # init conditions variables - 'lat_hi': 'lat_hi', - 'lon_hi': 'lon_hi', - 'hgt_hi': 'hgt_hi', # surface elevation - 'time_var':'time' - } - # 'wvar':'w' - - - files_list = { - 'name': 'files_list', - 'init_conditions_file': '"init.nc"', - 'boundary_files': '"forcing.nc"' - } - - parameters = { - 'name': 'parameters', - 'forcing_start_date': '"2020-12-01 00:00:00"', - 'end_date': '"2020-12-01 06:00:00"', - 'calendar': '"standard"', - 'inputinterval': '3600', - 'dx': '4000.0', - 'qv_is_relative_humidity':'true', - 'readdz': 'true', - 'nz': '15', - 'z_is_geopotential': 'True', - 'z_is_on_interface': 'True', - 'time_varying_z': 'False', - 'use_agl_height': 'False', - 'smooth_wind_distance': '72000' - } + self.nml[name] = '"' + val + '"' + super().gen() + + +class ParametersList(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'parameters' + + def gen(self): + for name, val in self.nml.items(): + if name in ['forcing_start_date', 'end_date', 'calendar']: + self.nml[name] = '"' + val + '"' + super().gen() + + +class ParcelsList(Namelist): + def __init__(self, **kargs): + Namelist.__init__(self, kargs) + self.nml['name'] = 'parcel_parameters' diff --git a/helpers/genNetCDF/Topography.py b/helpers/genNetCDF/Topography.py index 670544a0..57f457db 100644 --- a/helpers/genNetCDF/Topography.py +++ b/helpers/genNetCDF/Topography.py @@ -1,24 +1,32 @@ -from netCDF4 import Dataset -from genNetCDF import fixType import pandas as pd import xarray as xr import numpy as np -import math -from sys import exit # Create NetCDF file containing the initial conditions topography # Currently creates flat domain class Topography: - hill_height = 1000.0 # height of the ideal hill(s) [m] - def __init__(self, nz=10, nx=100, ny=100, mult_factor=2.5, dx=0.1, dy=0.1, - n_hills=0.0, height_value=500, f_name="init.nc"): - print("todo: nx and ny because of C") + def __init__(self, + nz=32, + nx=100, + ny=100, + f_name="init.nc", + mult_factor=1, + dx=0.01, + dy=0.01, + n_hills=0.0, + height_value=500, + hill_height = 2000.0, + time_start = 20010101, + lat0 = 39.5, + lon0 = -105, + Schaer_test=False): + # print("todo: nx and ny because of C") # # initialize program variables nt = 1 self.n_hills = n_hills - nx,ny = self.setup_class_variables(nz, nx, ny, nt, mult_factor) + nx,ny = self.setup_class_variables(nx, ny, nt, mult_factor) self.setup_attributes(nx,ny) @@ -26,7 +34,6 @@ def __init__(self, nz=10, nx=100, ny=100, mult_factor=2.5, dx=0.1, dy=0.1, # Create and define variables for datafile # -------------------------------------------------------------- # create time - time_start = 20010101 time_end = time_start time_series = pd.date_range(start=str(time_start), end=str(time_end), @@ -34,14 +41,30 @@ def __init__(self, nz=10, nx=100, ny=100, mult_factor=2.5, dx=0.1, dy=0.1, time = time_series.astype(np.unicode_) # create longitude and latitude - lon_flat = np.arange(-105,-105+(nx*dx),dx)[:nx] - lat_flat = np.arange(40,40+(ny*dy),dy)[:ny] - lat_tmp = np.zeros([nt, nx, ny]) - lon_tmp = np.zeros([nt, nx, ny]) - lat_tmp[:,:,:] = lat_flat.reshape([1,1,ny]) - lon_tmp[:,:,:] = lon_flat.reshape([1,nx,1]) - - self.define_data_variables(lat_tmp, lon_tmp, height_value) + # lon_tmp = np.arange(lon0,lon0+(nx*dx),dx)[:nx] #[np.newaxis,:nx].repeat(ny,axis=0) + # lat_tmp = np.arange(lat0,lat0+(ny*dy),dy)[:ny] #[:ny,np.newaxis].repeat(nx,axis=1) + + ## If your displacements aren't too great (less than a few kilometers) and you're not right at the poles, + # use the quick and dirty estimate that 111,111 meters (111.111 km) in the y direction is 1 degree + # (of latitude) and 111,111 * cos(latitude) meters in the x direction is 1 degree (of longitude). + lon_tmp = np.arange(lon0-(nx/2*dx/111111/np.cos(np.radians(lat0))), + lon0+(nx/2*dx/111111/np.cos(np.radians(lat0))), + dx/111111/np.cos(np.radians(lat0)) + )[:nx] + lat_tmp = np.arange(lat0-(ny/2*dy/111111), + lat0+(ny/2*dy/111111), + dy/111111 + )[:ny] + # print(" lat_hi min/max: ", np.amin(lat_tmp), np.amax(lat_tmp)) + lon_tmp, lat_tmp = np.meshgrid(lon_tmp, lat_tmp) + + + i = (np.arange(self.nx) - self.nx/2) * dx + j = (np.arange(self.ny) - self.ny/2) * dy # dx=dy + + X, Y = np.meshgrid(i,j) + + self.define_data_variables(lat_tmp, lon_tmp, X, Y, height_value, hill_height, n_hills, Schaer_test, dx) # -------------------------------------------------------------- # Combine variables, create dataset and write to file @@ -49,10 +72,6 @@ def __init__(self, nz=10, nx=100, ny=100, mult_factor=2.5, dx=0.1, dy=0.1, data_vars = dict( lat_hi = self.lat_m, lon_hi = self.lon_m, - lat_u = self.lat_u, - lon_u = self.lon_u, - lat_v = self.lat_v, - lon_v = self.lon_v, hgt_hi = self.hgt_m, Times = time) @@ -66,151 +85,131 @@ def __init__(self, nz=10, nx=100, ny=100, mult_factor=2.5, dx=0.1, dy=0.1, # Define individual variables for datafile - def define_data_variables(self, lat_tmp, lon_tmp, height_value): + def define_data_variables(self, lat_tmp, lon_tmp, X, Y, height_value, + hill_height, n_hills, Schaer_test, dx): # dimensions of variables dims2d = ["lat", "lon"] - dims3d = ["time","lat", "lon"] + # dims3d = ["time","lat", "lon"] # --- xlat_m - self.lat_m = xr.Variable(dims3d, + self.lat_m = xr.Variable(dims2d, lat_tmp, - {'FieldType':'104', - 'units':'degrees latitude', + {'units':'degrees latitude', 'description':'Latitude on mass grid', - 'stagger':'M', - 'sr_x':'1', - 'sr_y':'1' }) # --- xlon_m - self.lon_m = xr.Variable(dims3d, + self.lon_m = xr.Variable(dims2d, lon_tmp, - {'FieldType':'104', - 'units':'degrees longitude', + {'units':'degrees longitude', 'description':'Longitude on mass grid', - 'stagger':'M', - 'sr_x':'1', - 'sr_y':'1' }) + print(" hires lon/lat min/max: ", np.min(lon_tmp), np.max(lon_tmp), np.min(lat_tmp), np.max(lat_tmp) ) + # --- hgt_m - hgt = np.full([self.nt,self.nx,self.ny], height_value) - self.hgt_m = xr.Variable(dims3d, + # hgt = np.full([self.nt,self.nx,self.ny], height_value) + # hgt = self.genHill(hill_height) + if Schaer_test==True: + hgt=self.gen_adv_test_topo(hill_height, dx) + elif n_hills == 1: + hgt = self.genHill(hill_height) + elif n_hills >1: + hgt = self.gen_n_Hills(hill_height, n_hills) + elif n_hills ==0: + hgt = self.genHill(hill_height=0) + + + self.hgt_m = xr.Variable(dims2d, hgt, - {'FieldType':'104', - 'MemoryOrder':'XY', - 'units':'meters MSL', + {'units':'meters MSL', 'description':'topography height', - 'stagger':'M', - 'sr_x':'1', - 'sr_y':'1' - }) - - - # --- xlat_u - self.lat_u = xr.Variable(dims3d, - lat_tmp, - {'FieldType':'104', - 'units':'degrees latitude', - 'description':'Latitude on U grid', - 'stagger':'M', - 'sr_x':'1', - 'sr_y':'1' - }) - - # --- xlon_u - self.lon_u = xr.Variable(dims3d, - lon_tmp, - {'FieldType':'104', - 'units':'degrees longitude', - 'description':'Longitude on U grid', - 'stagger':'M', - 'sr_x':'1', - 'sr_y':'1' - }) - - # --- xlat_v - self.lat_v = xr.Variable(dims3d, - lat_tmp, - {'FieldType':'104', - 'units':'degrees latitude', - 'description':'Latitude on V grid', - 'stagger':'M', - 'sr_x':'1', - 'sr_y':'1' - }) - - # --- xlon_v - self.lon_v = xr.Variable(dims3d, - lon_tmp, - {'FieldType':'104', - 'units':'degrees longitude', - 'description':'Longitude on V grid', - 'stagger':'M', - 'sr_x':'1', - 'sr_y':'1' }) - def close(self): self.topography_f.close() - def setup_class_variables(self, nz, nx, ny, nt, mult_factor): + def setup_class_variables(self, nx, ny, nt, mult_factor): self.nt = nt - self.nz = nz self.nx = round(nx * mult_factor) self.ny = round(ny * mult_factor) - dimensions4d = { - "time": nt, - "level": nz, - "lat": nx, - "lon": ny - } - dimensions3d = { - "level": nz, - "lat": nx, - "lon": ny - } - dimensions3d_t = { - "time": nt, - "lat": nx, - "lon": ny - } - dimensions2d = { - "lat": nx, - "lon": ny - } - dimensions1d = { - "time": 1 - - } - self.dimensions4d = dimensions4d - self.dimensions3d = dimensions3d - self.dimensions3d_t = dimensions3d_t - self.dimensions2d = dimensions2d - self.dimensions1d = dimensions1d return self.nx, self.ny # hasn't been integrated and tested - def genHill(self): - k = 0 - ids = 1 - ide = self.nx + 1 - jds = 1 - jde = self.ny + 1 - for i in range(ids,ide): - for j in range(jds,jde): - sine_curve = (math.sin((i-ids)/ \ - np.single((ide-ids)/self.n_hills) \ - * 2*3.14159 - 3.14159/2) + 1) / 2 \ - * (math.sin((j-jds)/np.single((jde-jds) \ - / self.n_hills) * 2*3.14159 - 3.14159/2)+1)/2 - self.z_interface[k,i-1,j-1] = self.surface_z + sine_curve * self.hill_height - self.z[k,:,:] = self.z_interface[k,:,:] + self.dz_value/2 + def genHill(self, hill_height): + i = (np.arange(self.nx) - self.nx/2) / self.nx * np.pi * 2 + j = (np.arange(self.nx) - self.ny/2) / self.ny * np.pi * 2 + + ig, jg = np.meshgrid(i,j) + + hgt = ((np.cos(ig)+1) * (np.cos(jg)+1))/4 * hill_height + + return hgt + + + # # generate a simple mountain range + def gen_n_Hills(self, hill_height, n_hills): + i = (np.arange(self.nx) - self.nx/2) / self.nx * np.pi * 2 + j = (np.arange(self.nx) - self.ny/2) / self.ny * np.pi * 2 + + ig, jg = np.meshgrid(i,j) + + # should become arguments, but for now: + c = 0.15 # fraction of domain taken up by the hill(s) + sigma = n_hills**2 # amount of cosines, (very) roughly + + hgt= ( + ( np.cos(ig/c) )**2 * np.exp(-(ig/c)**2/sigma) * + ( np.cos(jg/c) )**2 * np.exp(-(jg/c)**2/sigma) + ) * hill_height + print(" generated ", n_hills," hills w max hgt: ", np.amax(hgt), " (hh=", hill_height, ")") + return hgt + + + # Topo for Schär's advection test + def gen_adv_test_topo(self, hill_height, dx): + i = (np.arange(self.nx) - self.nx/2) * dx # / self.nx * np.pi * 2 + j = (np.arange(self.ny) - self.ny/2) * dx # / self.ny * np.pi * 2 # dx=dy + ig, jg = np.meshgrid(i,j) + + lmbda = 8000 + a = 25000 + adv_3D = False # should become an argument (maybe) + + if adv_3D==True: + hgt = ( + hill_height * + self.h_x(ig, lmbda) * self.h_x_star( ig, a) + * self.h_x(jg, lmbda) * self.h_x_star( jg, a) + ) + j_a = np.where(abs(j)>a)[0] # satisfy the hgt=0 for |x|>a condition (eqn 26b in Schaer 2002) + hgt[j_a] = 0 + elif adv_3D==False: # generate 2D topo: + hgt = ( + hill_height * + self.h_x(ig, lmbda) * self.h_x_star( ig, a) + ) + + # satisfy the hgt=0 for |x|>a condition (eqn 26b): (could be done more elegantly) + i_a = np.where(abs(i)>a)[0] + hgt[:,i_a] = 0 + + + print(" generated Schaer Topo w max hgt: ", np.amax(hgt), " (hh=", hill_height, ")") + return hgt + + def h_x(self, x,lmbda): + h_x = (np.cos(np.pi*x /lmbda))**2 + return h_x + + def h_x_star(self, x, a): + + h_x = (np.cos(np.pi*x/2/a))**2 + return h_x def setup_attributes(self,nx,ny): @@ -219,8 +218,7 @@ def setup_attributes(self,nx,ny): "SIMULATION_START_DATE": "0000-00-00_00:00:00", "WEST-EAST_GRID_DIMENSION": nx, "SOUTH-NORTH_GRID_DIMENSION": ny, - "BOTTOM-TOP_GRID_DIMENSION": 0, "GRIDTYPE": "C", - "DX": 100.0, - "DY": 100.0 + "DX": 1000.0, + "DY": 1000.0 } diff --git a/helpers/make_template.py b/helpers/make_template.py index 6d040bde..805bffde 100755 --- a/helpers/make_template.py +++ b/helpers/make_template.py @@ -38,8 +38,11 @@ import argparse import re -def main (options_file, template_file): +# global verbose + +def main (options_file, template_file): + entered_restart_section=False with open(options_file,"r") as opt: @@ -50,15 +53,13 @@ def main (options_file, template_file): entered_restart_section=True key = (l.split("=")[0]).strip().lower() - if key == "restart_file": - if verbose: print("Writing restart_file line") - tmpl.write(' restart_file="__RESTART_FILE__"\n') - elif key == "restart_date": + ## as long as the default (i.e. restart_file="restart/icar_rst_" ) is used, no need to change. + # if key == "restart_file": + # if verbose: print("Writing restart_file line") + # tmpl.write(' restart_file="__RESTART_FILE__"\n') + if key == "restart_date": if verbose: print("Writing restart_date line") tmpl.write(' restart_date= __RESTART_DATE__,\n') - elif key == "restart_step": - if verbose: print("Removing restart_step line") - pass elif key == "restart": if verbose: print("Writing restart=true line") tmpl.write(' restart=true,\n') diff --git a/helpers/setup_next_run.py b/helpers/setup_next_run.py index 897ba751..a09dd375 100755 --- a/helpers/setup_next_run.py +++ b/helpers/setup_next_run.py @@ -1,5 +1,6 @@ #!/usr/bin/env python + """ SYNOPSIS @@ -37,7 +38,6 @@ import argparse global verbose -verbose=False import glob,os,re,sys, fnmatch from math import floor @@ -46,6 +46,7 @@ def find_last_output(options_file, skip): """docstring for find_last_output""" + if(verbose==True): print("looking for last output") with open(options_file,"r") as f: for l in f: ltest = l.split("!")[0] # only look at the line before any comment characters diff --git a/run/MPTABLE.TBL b/run/MPTABLE.TBL new file mode 100644 index 00000000..6e7e86b0 --- /dev/null +++ b/run/MPTABLE.TBL @@ -0,0 +1,608 @@ +&noahmp_usgs_veg_categories + VEG_DATASET_DESCRIPTION = "USGS" + NVEG = 27 +/ +&noahmp_usgs_parameters + ! NVEG = 27 + ! 1: Urban and Built-Up Land + ! 2: Dryland Cropland and Pasture + ! 3: Irrigated Cropland and Pasture + ! 4: Mixed Dryland/Irrigated Cropland and Pasture + ! 5: Cropland/Grassland Mosaic + ! 6: Cropland/Woodland Mosaic + ! 7: Grassland + ! 8: Shrubland + ! 9: Mixed Shrubland/Grassland + ! 10: Savanna + ! 11: Deciduous Broadleaf Forest + ! 12: Deciduous Needleleaf Forest + ! 13: Evergreen Broadleaf Forest + ! 14: Evergreen Needleleaf Forest + ! 15: Mixed Forest + ! 16: Water Bodies + ! 17: Herbaceous Wetland + ! 18: Wooded Wetland + ! 19: Barren or Sparsely Vegetated + ! 20: Herbaceous Tundra + ! 21: Wooded Tundra + ! 22: Mixed Tundra + ! 23: Bare Ground Tundra + ! 24: Snow or Ice + ! 25: Playa + ! 26: Lava + ! 27: White Sand + + ISURBAN = 1 + ISWATER = 16 + ISBARREN = 19 + ISICE = 24 + ISCROP = 2 + EBLFOREST = 13 + NATURAL = 5 + LCZ_1 = 31 + LCZ_2 = 32 + LCZ_3 = 33 + LCZ_4 = 34 + LCZ_5 = 35 + LCZ_6 = 36 + LCZ_7 = 37 + LCZ_8 = 38 + LCZ_9 = 39 + LCZ_10 = 40 + LCZ_11 = 41 + + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + Z0MVT = 1.00, 0.15, 0.15, 0.15, 0.14, 0.50, 0.12, 0.06, 0.09, 0.50, 0.80, 0.85, 1.10, 1.09, 0.80, 0.00, 0.12, 0.50, 0.00, 0.10, 0.30, 0.20, 0.03, 0.00, 0.01, 0.00, 0.00, + HVT = 15.0, 2.00, 2.00, 2.00, 1.50, 8.00, 1.00, 1.10, 1.10, 10.0, 16.0, 18.0, 20.0, 20.0, 16.0, 0.00, 0.50, 10.0, 0.00, 0.50, 4.00, 2.00, 0.50, 0.00, 0.10, 0.00, 0.00, + HVB = 1.00, 0.10, 0.10, 0.10, 0.10, 0.15, 0.05, 0.10, 0.10, 0.10, 11.5, 7.00, 8.00, 8.50, 10.0, 0.00, 0.05, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + DEN = 0.01, 25.0, 25.0, 25.0, 25.0, 25.0, 100., 10.0, 10.0, 0.02, 0.10, 0.28, 0.02, 0.28, 0.10, 0.01, 10.0, 0.10, 0.01, 1.00, 1.00, 1.00, 1.00, 0.00, 0.01, 0.01, 0.01, + RC = 1.00, 0.08, 0.08, 0.08, 0.08, 0.08, 0.03, 0.12, 0.12, 3.00, 1.40, 1.20, 3.60, 1.20, 1.40, 0.01, 0.10, 1.40, 0.01, 0.30, 0.30, 0.30, 0.30, 0.00, 0.01, 0.01, 0.01, +!MFSNO = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, +! C. He 12/17/2020: optimized MFSNO values dependent on land type based on evaluation with SNOTEL SWE and MODIS SCF, surface albedo + MFSNO = 4.00, 3.00, 3.00, 3.00, 4.00, 4.00, 2.00, 2.00, 2.00, 2.00, 1.00, 1.00, 1.00, 1.00, 1.00, 3.00, 3.00, 3.00, 3.00, 3.50, 3.50, 3.50, 3.50, 2.50, 3.50, 3.50, 3.50, +! C. He 12/17/2020: optimized snow cover factor (m) in SCF formulation to replace original constant 2.5*z0,z0=0.002m, based on evaluation with SNOTEL SWE and MODIS SCF, surface albedo + SCFFAC= 0.042, 0.014, 0.014, 0.014, 0.026, 0.026, 0.020, 0.018, 0.016, 0.020, 0.008, 0.008, 0.008, 0.008, 0.008, 0.030, 0.020, 0.020, 0.016, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, + + ! Row 1: Vis + ! Row 2: Near IR + RHOL_VIS=0.00, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.07, 0.10, 0.10, 0.10, 0.07, 0.10, 0.07, 0.10, 0.00, 0.11, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + RHOL_NIR=0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.35, 0.45, 0.00, 0.58, 0.45, 0.00, 0.45, 0.45, 0.45, 0.45, 0.00, 0.45, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + RHOS_VIS=0.00, 0.36, 0.36, 0.36, 0.36, 0.36, 0.36, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.00, 0.36, 0.16, 0.00, 0.16, 0.16, 0.16, 0.16, 0.00, 0.16, 0.00, 0.00, + RHOS_NIR=0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.00, 0.58, 0.39, 0.00, 0.39, 0.39, 0.39, 0.39, 0.00, 0.39, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUL_VIS=0.00, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.07, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, + TAUL_NIR=0.00, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.10, 0.10, 0.25, 0.25, 0.10, 0.25, 0.10, 0.25, 0.00, 0.25, 0.25, 0.00, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUS_VIS=0.00, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.220, 0.001, 0.000, 0.220, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + TAUS_NIR=0.00, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.380, 0.001, 0.000, 0.380, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + + XL = 0.000, -0.30, -0.30, -0.30, -0.30, -0.30, -0.30, 0.010, 0.250, 0.010, 0.250, 0.010, 0.010, 0.010, 0.250, 0.000, -0.30, 0.250, 0.000, -0.30, 0.250, 0.250, 0.250, 0.000, 0.250, 0.000, 0.000, + ! make CWPVT vegetation dependent according to J. Goudriaan, Crop Micrometeorology: A Simulation Study (Simulation monographs), 1977). C. He, 12/17/2020 + CWPVT = 0.18, 1.67, 1.67, 1.67, 1.67, 0.5, 5.0, 1.0, 2.0, 1.0, 0.67, 0.18, 0.67, 0.18, 0.29, 0.18, 1.67, 0.67, 0.18, 1.67, 0.67, 1.00, 0.18, 0.18, 0.18, 0.18, 0.18, + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + + LTOVRC= 0.0, 1.2, 1.2, 1.2, 1.2, 1.30, 0.50, 0.65, 0.70, 0.65, 0.55, 0.2, 0.55, 0.5, 0.5, 0.0, 1.4, 1.4, 0.0, 1.2, 1.3, 1.4, 1.0, 0.0, 1.0, 0.0, 0.0, + DILEFC= 0.00, 0.50, 0.50, 0.50, 0.35, 0.20, 0.20, 0.20, 0.50, 0.50, 0.60, 1.80, 0.50, 1.20, 0.80, 0.00, 0.40, 0.40, 0.00, 0.40, 0.30, 0.40, 0.30, 0.00, 0.30, 0.00, 0.00, + DILEFW= 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.20, 0.50, 0.20, 0.20, 4.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.20, 0.20, 0.00, 0.20, 0.00, 0.00, + RMF25 = 0.00, 1.00, 1.40, 1.45, 1.45, 1.45, 1.80, 0.26, 0.26, 0.80, 3.00, 4.00, 0.65, 3.00, 3.00, 0.00, 3.20, 3.20, 0.00, 3.20, 3.00, 3.00, 3.00, 0.00, 3.00, 0.00, 0.00, + SLA = 60, 80, 80, 80, 80, 80, 60, 60, 60, 50, 80, 80, 80, 80, 80, 0, 80, 80, 0, 80, 80, 80, 80, 0, 80, 0, 0, + FRAGR = 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + TMIN = 0, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 268, 273, 265, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + VCMX25= 0.00, 80.0, 80.0, 80.0, 60.0, 70.0, 40.0, 40.0, 40.0, 40.0, 60.0, 60.0, 60.0, 50.0, 55.0, 0.00, 50.0, 50.0, 0.00, 50.0, 50.0, 50.0, 50.0, 0.00, 50.0, 0.00, 0.00, + TDLEF = 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 268, 278, 278, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + BP = 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 1.E15, + MP = 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 6., 9., 6., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., + QE25 = 0., 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.00, + RMS25 = 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.32, 0.10, 0.64, 0.30, 0.90, 0.80, 0.00, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, + RMR25 = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.20, 0.00, 0.00, 0.01, 0.01, 0.05, 0.05, 0.36, 0.03, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + FOLNMX= 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 0.00, + WDPOOL= 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, + WRRAT = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, 30.0, 30.0, 30.0, 30.0, 30.0, 0.00, 0.00, 30.0, 0.00, 0.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, + MRP = 0.00, 0.23, 0.23, 0.23, 0.23, 0.23, 0.17, 0.19, 0.19, 0.40, 0.40, 0.37, 0.23, 0.37, 0.30, 0.00, 0.17, 0.40, 0.00, 0.17, 0.23, 0.20, 0.00, 0.00, 0.20, 0.00, 0.00, + NROOT = 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 0, 2, 2, 1, 3, 3, 3, 2, 1, 1, 0, 0, + RGL = 999.0, 100.0, 100.0, 100.0, 100.0, 65.0, 100.0, 100.0, 100.0, 65.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 30.0, 999.0, 100.0, 100.0, 100.0, 100.0, 999.0, 100.0, 999.0, 999.0, + RS = 200.0, 40.0, 40.0, 40.0, 40.0, 70.0, 40.0, 300.0, 170.0, 70.0, 100.0, 150.0, 150.0, 125.0, 125.0, 100.0, 40.0, 100.0, 999.0, 150.0, 150.0, 150.0, 200.0, 999.0, 40.0, 999.0, 999.0, + HS = 999.0, 36.25, 36.25, 36.25, 36.25, 44.14, 36.35, 42.00, 39.18, 54.53, 54.53, 47.35, 41.69, 47.35, 51.93, 51.75, 60.00, 51.93, 999.0, 42.00, 42.00, 42.00, 42.00, 999.0, 36.25, 999.0, 999.0, + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., + +! Monthly values, one row for each month: + SAI_JAN = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_FEB = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_APR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.3, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAY = 0.0, 0.2, 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.4, 0.4, 0.0, 0.3, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUN = 0.0, 0.3, 0.3, 0.3, 0.4, 0.4, 0.4, 0.2, 0.3, 0.4, 0.4, 0.7, 0.5, 0.5, 0.4, 0.0, 0.4, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUL = 0.0, 0.4, 0.4, 0.4, 0.6, 0.6, 0.8, 0.4, 0.6, 0.8, 0.9, 1.3, 0.5, 0.5, 0.7, 0.0, 0.6, 0.6, 0.0, 0.4, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_AUG = 0.0, 0.5, 0.5, 0.5, 0.9, 0.9, 1.3, 0.6, 0.9, 1.2, 1.2, 1.2, 0.5, 0.6, 0.8, 0.0, 0.9, 0.9, 0.0, 0.6, 0.6, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_SEP = 0.0, 0.4, 0.4, 0.4, 0.7, 1.0, 1.1, 0.8, 1.0, 1.3, 1.6, 1.0, 0.5, 0.6, 1.0, 0.0, 0.7, 1.0, 0.0, 0.7, 0.8, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_OCT = 0.0, 0.3, 0.3, 0.3, 0.3, 0.8, 0.4, 0.7, 0.6, 0.7, 1.4, 0.8, 0.5, 0.7, 1.0, 0.0, 0.3, 0.8, 0.0, 0.5, 0.7, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_NOV = 0.0, 0.3, 0.3, 0.3, 0.3, 0.4, 0.4, 0.3, 0.3, 0.4, 0.6, 0.6, 0.5, 0.6, 0.5, 0.0, 0.3, 0.4, 0.0, 0.3, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_DEC = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.4, 0.2, 0.3, 0.4, 0.4, 0.5, 0.5, 0.5, 0.4, 0.0, 0.3, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + + LAI_JAN = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_FEB = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.3, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAR = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.0, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_APR = 0.0, 0.0, 0.0, 0.0, 0.4, 0.6, 0.7, 0.6, 0.7, 0.8, 1.2, 0.6, 4.5, 4.0, 2.6, 0.0, 0.4, 0.6, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAY = 0.0, 1.0, 1.0, 1.0, 1.1, 2.0, 1.2, 1.5, 1.4, 1.8, 3.0, 1.2, 4.5, 4.0, 3.5, 0.0, 1.1, 2.0, 0.0, 0.6, 1.7, 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUN = 0.0, 2.0, 2.0, 2.0, 2.5, 3.3, 3.0, 2.3, 2.6, 3.6, 4.7, 2.0, 4.5, 4.0, 4.3, 0.0, 2.5, 3.3, 0.0, 1.5, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUL = 0.0, 3.0, 3.0, 3.0, 3.2, 3.7, 3.5, 2.3, 2.9, 3.8, 4.5, 2.6, 4.5, 4.0, 4.3, 0.0, 3.2, 3.7, 0.0, 1.7, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_AUG = 0.0, 3.0, 3.0, 3.0, 2.2, 3.2, 1.5, 1.7, 1.6, 2.1, 3.4, 1.7, 4.5, 4.0, 3.7, 0.0, 2.2, 3.2, 0.0, 0.8, 1.8, 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_SEP = 0.0, 1.5, 1.5, 1.5, 1.1, 1.3, 0.7, 0.6, 0.7, 0.9, 1.2, 1.0, 4.5, 4.0, 2.6, 0.0, 1.1, 1.3, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_OCT = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.5, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_NOV = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.2, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_DEC = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + + SLAREA=0.0228,0.0200,0.0200,0.0295,0.0223,0.0277,0.0060,0.0227,0.0188,0.0236,0.0258,0.0200,0.0200,0.0090,0.0223,0.0422,0.0390, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + +! Five types, one row for each type (BVOC currently not active). + EPS1 = 41.87, 0.00, 0.00, 2.52, 0.04, 17.11, 0.02, 21.62, 0.11, 22.80, 46.86, 0.00, 0.00, 0.46, 30.98, 2.31, 1.63, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS2 = 0.98, 0.00, 0.00, 0.16, 0.09, 0.28, 0.05, 0.92, 0.22, 0.59, 0.38, 0.00, 0.00, 3.34, 0.96, 1.47, 1.07, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS3 = 1.82, 0.00, 0.00, 0.23, 0.05, 0.81, 0.03, 1.73, 1.26, 1.37, 1.84, 0.00, 0.00, 1.85, 1.84, 1.70, 1.21, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS4 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS5 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, +/ + +&noahmp_modis_veg_categories + VEG_DATASET_DESCRIPTION = "modified igbp modis noah" + NVEG = 21 +/ + +&noahmp_modis_parameters +! 1 'Evergreen Needleleaf Forest' -> USGS 14 +! 2, 'Evergreen Broadleaf Forest' -> USGS 13 +! 3, 'Deciduous Needleleaf Forest' -> USGS 12 +! 4, 'Deciduous Broadleaf Forest' -> USGS 11 +! 5, 'Mixed Forests' -> USGS 15 +! 6, 'Closed Shrublands' -> USGS 8 "shrubland" +! 7, 'Open Shrublands' -> USGS 9 "shrubland/grassland" +! 8, 'Woody Savannas' -> USGS 8 "shrubland" +! 9, 'Savannas' -> USGS 10 +! 10, 'Grasslands' -> USGS 7 +! 11 'Permanent wetlands' -> avg of USGS 17 and 18 (herb. wooded wetland) +! 12, 'Croplands' -> USGS 2 "dryland cropland" +! 13, 'Urban and Built-Up' -> USGS 1 +! 14 'cropland/natural vegetation mosaic' -> USGS 5 "cropland/grassland" +! 15, 'Snow and Ice' -> USGS 24 +! 16, 'Barren or Sparsely Vegetated' -> USGS 19 +! 17, 'Water' -> USGS 16 +! 18, 'Wooded Tundra' -> USGS 21 +! 19, 'Mixed Tundra' -> USGS 22 +! 20, 'Barren Tundra' -> USGS 23 + + ISURBAN = 13 + ISWATER = 17 + ISBARREN = 16 + ISICE = 15 + ISCROP = 12 + EBLFOREST = 2 + NATURAL = 14 + LCZ_1 = 31 + LCZ_2 = 32 + LCZ_3 = 33 + LCZ_4 = 34 + LCZ_5 = 35 + LCZ_6 = 36 + LCZ_7 = 37 + LCZ_8 = 38 + LCZ_9 = 39 + LCZ_10 = 40 + LCZ_11 = 41 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + Z0MVT = 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, 0.20, 0.03, 0.00, + HVT = 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, 2.00, 0.50, 0.00, + HVB = 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, 0.20, 0.10, 0.00, + DEN = 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, 10.0, 10.0, 0.02, 100., 5.05, 25.0, 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, 1.00, 1.00, 0.00, + RC = 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, 0.30, 0.30, 0.00, +!MFSNO = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, +! C. He 12/17/2020: optimized MFSNO values dependent on land type based on evaluation with SNOTEL SWE and MODIS SCF, surface albedo + MFSNO = 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, 3.50, 3.50, 2.50, +! C. He 12/17/2020: optimized snow cover factor (m) in SCF formulation to replace original constant 2.5*z0,z0=0.002m, based on evaluation with SNOTEL SWE and MODIS SCF, surface albedo + SCFFAC = 0.008, 0.008, 0.008, 0.008, 0.008, 0.016, 0.016, 0.020, 0.020, 0.020, 0.020, 0.014, 0.042, 0.026, 0.030, 0.016, 0.030, 0.030, 0.030, 0.030, 0.030, + + ! Row 1: Vis + ! Row 2: Near IR + RHOL_VIS=0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, 0.00, + RHOL_NIR=0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, 0.45, 0.45, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + RHOS_VIS=0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, 0.16, 0.16, 0.00, + RHOS_NIR=0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, 0.39, 0.39, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUL_VIS=0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, 0.05, 0.05, 0.00, + TAUL_NIR=0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, 0.25, 0.25, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUS_VIS=0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.1105, 0.220, 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, 0.000, + TAUS_NIR=0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, 0.000, + + XL = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, 0.250, 0.250, 0.000, +! make CWPVT vegetation dependent according to J. Goudriaan, Crop Micrometeorology: A Simulation Study (Simulation monographs), 1977). C. He, 12/17/2020 + CWPVT = 0.18, 0.67, 0.18, 0.67, 0.29, 1.0, 2.0, 1.3, 1.0, 5.0, 1.17, 1.67, 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, 1.0, 0.18, 0.18, + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + LTOVRC= 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, 1.4, 1.0, 0.0, + DILEFC= 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, 0.40, 0.30, 0.00, + DILEFW= 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, 0.20, 0.20, 0.00, + RMF25 = 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, 0.00, + SLA = 80, 80, 80, 80, 80, 60, 60, 60, 50, 60, 80, 80, 60, 80, 0, 0, 0, 80, 80, 80, 0, + FRAGR = 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, 0.10, 0.10, 0.00, + TMIN = 265, 273, 268, 273, 268, 273, 273, 273, 273, 273, 268, 273, 0, 273, 0, 0, 0, 268, 268, 268, 0, + VCMX25= 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, 50.0, 50.0, 0.00, + TDLEF = 278, 278, 268, 278, 268, 278, 278, 278, 278, 278, 268, 278, 278, 278, 0, 0, 0, 268, 268, 268, 0, + BP = 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, 1.E15, + MP = 6., 9., 6., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., + QE25 = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, 0.06, 0.06, 0.00, + RMS25 = 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, 0.10, 0.00, 0.00, + RMR25 = 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 0.00, 0.00, + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + FOLNMX= 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, 1.5, 1.5, 0.00, + WDPOOL= 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, + WRRAT = 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 0.00, 0.00, + MRP = 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, 0.19, 0.19, 0.40, 0.17, 0.285, 0.23, 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, 0.20, 0.00, 0.00, + NROOT = 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 2, 3, 1, 3, 1, 1, 0, 3, 3, 2, 1, + RGL = 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, 100.0, 100.0, 999.0, + RS = 125.0, 150.0, 150.0, 100.0, 125.0, 300.0, 170.0, 300.0, 70.0, 40.0, 70.0, 40.0, 200.0, 40.0, 999.0, 999.0, 100.0, 150.0, 150.0, 200.0, 999.0, + HS = 47.35, 41.69, 47.35, 54.53, 51.93, 42.00, 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, 42.00, 42.00, 999.0, + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., +! Monthly values, one row for each month: + SAI_JAN = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, 0.0, + SAI_FEB = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, 0.0, + SAI_MAR = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, 0.0, + SAI_APR = 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, 0.0, + SAI_MAY = 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, 0.0, + SAI_JUN = 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, 0.0, + SAI_JUL = 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, 0.0, + SAI_AUG = 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, 0.6, 0.0, 0.0, + SAI_SEP = 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, 0.0, + SAI_OCT = 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, 0.5, 0.0, 0.0, + SAI_NOV = 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, 0.0, + SAI_DEC = 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, 0.0, + LAI_JAN = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, 0.0, + LAI_FEB = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, 0.0, + LAI_MAR = 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, 0.0, + LAI_APR = 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, 0.0, + LAI_MAY = 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, 1.2, 0.0, 0.0, + LAI_JUN = 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, 0.0, + LAI_JUL = 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, 0.0, + LAI_AUG = 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, 1.3, 0.0, 0.0, + LAI_SEP = 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, 0.0, + LAI_OCT = 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, 0.0, + LAI_NOV = 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, 0.0, + LAI_DEC = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, 0.0, + SLAREA=0.0090, 0.0200, 0.0200, 0.0258, 0.0223, 0.0227, 0.0188, 0.0227, 0.0236, 0.0060, 0.0295, 0.0200, 0.0228, 0.0223, 0.02, 0.02, 0.0422, 0.02, 0.02, 0.02, 0.02, + +! Five types, one row for each type (BVOC currently not active). + EPS1 = 0.46, 0.00, 0.00, 46.86, 30.98, 21.62, 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, 0.0, 0.0, 0.0, + EPS2 = 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, 0.0, 0.0, 0.0, + EPS3 = 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, 0.0, 0.0, 0.0, + EPS4 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS5 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + +/ + +&noahmp_rad_parameters + !------------------------------------------------------------------------------ + ! 1 2 3 4 5 6 7 8 soil color index for soil albedo + !------------------------------------------------------------------------------ + ALBSAT_VIS = 0.15, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05 ! saturated soil albedos + ALBSAT_NIR = 0.30, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! saturated soil albedos + ALBDRY_VIS = 0.27, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! dry soil albedos + ALBDRY_NIR = 0.54, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20 ! dry soil albedos + ALBICE = 0.80, 0.55 ! albedo land ice: 1=vis, 2=nir + ALBLAK = 0.60, 0.40 ! albedo frozen lakes: 1=vis, 2=nir + OMEGAS = 0.8 , 0.4 ! two-stream parameter omega for snow + BETADS = 0.5 ! two-stream parameter betad for snow + BETAIS = 0.5 ! two-stream parameter betaI for snow + EG = 0.97, 0.98 ! emissivity soil surface 1-soil;2-lake + +/ + +&noahmp_global_parameters + +! atmospheric constituants + + CO2 = 395.e-06 !co2 partial pressure + O2 = 0.209 !o2 partial pressure + +! runoff parameters used for SIMTOP and SIMGM: + + TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) + FSATMX = 0.38 !maximum surface saturated fraction (global mean) + +! adjustable parameters for snow processes + + Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + SNOW_RET_FAC = 5.e-5 !snowpack water release timescale factor (1/s) + SNOW_EMIS = 0.95 !snow emissivity (bring from hard-coded value of 1.0 to here) + SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + TAU0 = 1.e6 !tau0 from Yang97 eqn. 10a + GRAIN_GROWTH = 5000. !growth from vapor diffusion Yang97 eqn. 10b + EXTRA_GROWTH = 10. !extra growth near freezing Yang97 eqn. 10c + DIRT_SOOT = 0.3 !dirt and soot term Yang97 eqn. 10d + BATS_COSZ = 2.0 !zenith angle snow albedo adjustment; b in Yang97 eqn. 15 + BATS_VIS_NEW = 0.95 !new snow visible albedo + BATS_NIR_NEW = 0.65 !new snow NIR albedo + BATS_VIS_AGE = 0.2 !age factor for diffuse visible snow albedo Yang97 eqn. 17 + BATS_NIR_AGE = 0.5 !age factor for diffuse NIR snow albedo Yang97 eqn. 18 + BATS_VIS_DIR = 0.4 !cosz factor for direct visible snow albedo Yang97 eqn. 15 + BATS_NIR_DIR = 0.4 !cosz factor for direct NIR snow albedo Yang97 eqn. 16 + RSURF_SNOW = 50.0 !surface resistence for snow [s/m] + RSURF_EXP = 5.0 !exponent in the shape parameter for soil resistance option 1 + +/ + +&noahmp_irrigation_parameters +IRR_FRAC = 0.10 ! irrigation Fraction +IRR_HAR = 20 ! number of days before harvest date to stop irrigation +IRR_LAI = 0.50 ! Minimum lai to trigger irrigation +IRR_MAD = 0.60 ! management allowable deficit (0-1) +FILOSS = 0.10 ! fraction of flood irrigation loss (0-1) +SPRIR_RATE = 6.40 ! mm/h, sprinkler irrigation rate +MICIR_RATE = 1.38 ! mm/h, micro irrigation rate +FIRTFAC = 1.00 ! flood application rate factor +IR_RAIN = 1.00 ! maximum precipitation to stop irrigation trigger +/ + +&noahmp_crop_parameters + + ! NCROP = 5 + ! 1: Corn + ! 2: Soybean + ! 3: Sorghum + ! 4: Rice + ! 5: Winter wheat + +DEFAULT_CROP = 0 ! The default crop type(1-5); if zero, use generic dynamic vegetation + +!---------------------------------------------------------- +! 1 2 3 4 5 +!---------------------------------------------------------- + +PLTDAY = 111, 131, 111, 111, 111, ! Planting date +HSDAY = 300, 280, 300, 300, 300, ! Harvest date +PLANTPOP = 78.0, 78.0, 78.0, 78.0, 78.0, ! Plant density [per ha] - used? +IRRI = 0.0, 0.0, 0.0, 0.0, 0.0, ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + +GDDTBASE = 10.0, 10.0, 10.0, 10.0, 10.0, ! Base temperature for GDD accumulation [C] +GDDTCUT = 30.0, 30.0, 30.0, 30.0, 30.0, ! Upper temperature for GDD accumulation [C] +GDDS1 = 50.0, 60.0, 50.0, 50.0, 50.0, ! GDD from seeding to emergence +GDDS2 = 625.0, 675.0, 718.0, 718.0, 718.0, ! GDD from seeding to initial vegetative +GDDS3 = 933.0, 1183.0, 933.0, 933.0, 933.0, ! GDD from seeding to post vegetative +GDDS4 = 1103.0, 1253.0, 1103.0, 1103.0, 1103.0, ! GDD from seeding to intial reproductive +GDDS5 = 1555.0, 1605.0, 1555.0, 1555.0, 1555.0, ! GDD from seeding to pysical maturity +C3PSN = 0.0, 1.0, 1.0, 1.0, 1.0, ! transfer crop-specific photosynthetic parameters +KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, ! Zhe Zhang +AKC = 2.1, 2.1, 2.1, 2.1, 2.1, ! 2020-02-05 +KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, ! +AKO = 1.2, 1.2, 1.2, 1.2, 1.2, ! +AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, ! +VCMX25 = 60.0, 80.0, 60.0, 60.0, 55.0, ! +BP = 4.E4, 1.E4, 2.E3, 2.E3, 2.E3, ! +MP = 4., 9., 6., 9., 9., ! +FOLNMX = 1.5, 1.5, 1.5, 1.5, 1.5, ! +QE25 = 0.05, 0.06, 0.06, 0.06, 0.06, ! +C3C4 = 2, 1, 2, 2, 2, ! photosynthetic pathway: 1. = c3 2. = c4 +Aref = 7.0, 7.0, 7.0, 7.0, 7.0, ! reference maximum CO2 assimulation rate +PSNRF = 0.85, 0.85, 0.85, 0.85, 0.85, ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) +I2PAR = 0.5, 0.5, 0.5, 0.5, 0.5, ! Fraction of incoming solar radiation to photosynthetically active radiation +TASSIM0 = 8.0, 8.0, 8.0, 8.0, 8.0, ! Minimum temperature for CO2 assimulation [C] +TASSIM1 = 18.0, 18.0, 18.0, 18.0, 18.0, ! CO2 assimulation linearly increasing until temperature reaches T1 [C] +TASSIM2 = 30.0, 30.0, 30.0, 30.0, 30.0, ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] +K = 0.55, 0.55, 0.55, 0.55, 0.55, ! light extinction coefficient +EPSI = 12.5, 12.5, 12.5, 12.5, 12.5, ! initial light use efficiency + +Q10MR = 2.0, 2.0, 2.0, 2.0, 2.0, ! q10 for maintainance respiration +FOLN_MX = 1.5, 1.5, 1.5, 1.5, 1.5, ! foliage nitrogen concentration when f(n)=1 (%) +LEFREEZ = 268, 268, 268, 268, 268, ! characteristic T for leaf freezing [K] + +DILE_FC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] +DILE_FC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +DILE_FC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FC_S5 = 0.5, 0.5, 0.5, 0.5, 0.5, +DILE_FC_S6 = 0.5, 0.5, 0.5, 0.5, 0.5, +DILE_FC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +DILE_FW_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] +DILE_FW_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +DILE_FW_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FW_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FW_S5 = 0.2, 0.2, 0.2, 0.2, 0.2, +DILE_FW_S6 = 0.2, 0.2, 0.2, 0.2, 0.2, +DILE_FW_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FW_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +FRA_GR = 0.2, 0.2, 0.2, 0.2, 0.2, ! fraction of growth respiration + +LF_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] +LF_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +LF_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +LF_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +LF_OVRC_S5 = 0.2, 0.2, 0.48, 0.48, 0.48, +LF_OVRC_S6 = 0.3, 0.3, 0.48, 0.48, 0.48, +LF_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +LF_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +ST_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] +ST_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +ST_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +ST_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +ST_OVRC_S5 = 0.2, 0.12, 0.12, 0.12, 0.12, +ST_OVRC_S6 = 0.3, 0.06, 0.06, 0.06, 0.06, +ST_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +ST_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +RT_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] +RT_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +RT_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +RT_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +RT_OVRC_S5 = 0.12, 0.12, 0.12, 0.12, 0.12, +RT_OVRC_S6 = 0.06, 0.06, 0.06, 0.06, 0.06, +RT_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +RT_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +LFMR25 = 0.8, 1.0, 1.0, 1.0, 1.0, ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] +STMR25 = 0.05, 0.05, 0.1, 0.1, 0.1, ! stem maintenance respiration at 25C [umol CO2/kg bio/s] +RTMR25 = 0.05, 0.05, 0.0, 0.0, 0.0, ! root maintenance respiration at 25C [umol CO2/kg bio/s] +GRAINMR25 = 0.0, 0.0, 0.1, 0.1, 0.1, ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + +LFPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf +LFPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +LFPT_S3 = 0.36, 0.4, 0.4, 0.4, 0.4, +LFPT_S4 = 0.1, 0.2, 0.2, 0.2, 0.2, +LFPT_S5 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFPT_S6 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +STPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem +STPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +STPT_S3 = 0.24, 0.2, 0.2, 0.2, 0.2, +STPT_S4 = 0.6, 0.5, 0.5, 0.5, 0.5, +STPT_S5 = 0.0, 0.0, 0.15, 0.15, 0.15, +STPT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, +STPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +STPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +RTPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root +RTPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +RTPT_S3 = 0.4, 0.4, 0.4, 0.4, 0.4, +RTPT_S4 = 0.3, 0.3, 0.3, 0.3, 0.3, +RTPT_S5 = 0.05, 0.05, 0.05, 0.05, 0.05, +RTPT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, +RTPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +RTPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +GRAINPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain +GRAINPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +GRAINPT_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +GRAINPT_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +GRAINPT_S5 = 0.95, 0.95, 0.8, 0.8, 0.8, +GRAINPT_S6 = 1.0, 1.0, 0.9, 0.9, 0.9, +GRAINPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +GRAINPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +LFCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! carbohydrate translocation +LFCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFCT_S3 = 0.0, 0., 0.4, 0.4, 0.4, +LFCT_S4 = 0.0, 0., 0.3, 0.3, 0.3, +LFCT_S5 = 0.0, 0.0, 0.05, 0.05, 0.05, +LFCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, +LFCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +STCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! carbohydrate translocation +STCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, +STCT_S3 = 0.0, 0., 0.4, 0.4, 0.4, +STCT_S4 = 0.0, 0., 0.3, 0.3, 0.3, +STCT_S5 = 0.0, 0., 0.05, 0.05, 0.05, +STCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, +STCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +STCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +RTCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! carbohydrate translocation +RTCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, +RTCT_S3 = 0.0, 0., 0.4, 0.4, 0.4, +RTCT_S4 = 0.0, 0., 0.3, 0.3, 0.3, +RTCT_S5 = 0.0, 0., 0.05, 0.05, 0.05, +RTCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, +RTCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +RTCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +BIO2LAI = 0.015, 0.030, 0.015, 0.015, 0.015, ! leaf are per living leaf biomass [m^2/kg] + + +/ + +&noahmp_optional_parameters + + !------------------------------------------------------------------------------ + ! Saxton and Rawls 2006 Pedo-transfer function coefficients + !------------------------------------------------------------------------------ + + sr2006_theta_1500t_a = -0.024 ! sand coefficient + sr2006_theta_1500t_b = 0.487 ! clay coefficient + sr2006_theta_1500t_c = 0.006 ! orgm coefficient + sr2006_theta_1500t_d = 0.005 ! sand*orgm coefficient + sr2006_theta_1500t_e = -0.013 ! clay*orgm coefficient + sr2006_theta_1500t_f = 0.068 ! sand*clay coefficient + sr2006_theta_1500t_g = 0.031 ! constant adjustment + + sr2006_theta_1500_a = 0.14 ! theta_1500t coefficient + sr2006_theta_1500_b = -0.02 ! constant adjustment + + sr2006_theta_33t_a = -0.251 ! sand coefficient + sr2006_theta_33t_b = 0.195 ! clay coefficient + sr2006_theta_33t_c = 0.011 ! orgm coefficient + sr2006_theta_33t_d = 0.006 ! sand*orgm coefficient + sr2006_theta_33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_33t_f = 0.452 ! sand*clay coefficient + sr2006_theta_33t_g = 0.299 ! constant adjustment + + sr2006_theta_33_a = 1.283 ! theta_33t*theta_33t coefficient + sr2006_theta_33_b = -0.374 ! theta_33t coefficient + sr2006_theta_33_c = -0.015 ! constant adjustment + + sr2006_theta_s33t_a = 0.278 ! sand coefficient + sr2006_theta_s33t_b = 0.034 ! clay coefficient + sr2006_theta_s33t_c = 0.022 ! orgm coefficient + sr2006_theta_s33t_d = -0.018 ! sand*orgm coefficient + sr2006_theta_s33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_s33t_f = -0.584 ! sand*clay coefficient + sr2006_theta_s33t_g = 0.078 ! constant adjustment + + sr2006_theta_s33_a = 0.636 ! theta_s33t coefficient + sr2006_theta_s33_b = -0.107 ! constant adjustment + + sr2006_psi_et_a = -21.67 ! sand coefficient + sr2006_psi_et_b = -27.93 ! clay coefficient + sr2006_psi_et_c = -81.97 ! theta_s33 coefficient + sr2006_psi_et_d = 71.12 ! sand*theta_s33 coefficient + sr2006_psi_et_e = 8.29 ! clay*theta_s33 coefficient + sr2006_psi_et_f = 14.05 ! sand*clay coefficient + sr2006_psi_et_g = 27.16 ! constant adjustment + + sr2006_psi_e_a = 0.02 ! psi_et*psi_et coefficient + sr2006_psi_e_b = -0.113 ! psi_et coefficient + sr2006_psi_e_c = -0.7 ! constant adjustment + + sr2006_smcmax_a = -0.097 ! sand adjustment + sr2006_smcmax_b = 0.043 ! constant adjustment + +/ diff --git a/run/complete_icar_options.nml b/run/complete_icar_options.nml index 3880eaa4..c729cfaf 100644 --- a/run/complete_icar_options.nml +++ b/run/complete_icar_options.nml @@ -2,7 +2,7 @@ ! Model and run meta-data !--------------------------------------------------------- &model_version - version = "2.0", ! This must match the version of the compiled code + version = "2.1", ! This must match the version of the compiled code comment = "Add your comment here" ! This will be stored in output files / @@ -21,7 +21,11 @@ ! fixed_dz_advection = .True. - ! Use a SLEVE vertical coordinate, where the decay of the large- and small-scale terrain influence towards model top is controlled by the decay_rate_L_topo and decay_rate_S_topo respectively (=H/s1 and H/s2), and the exponential factor n that controls compression across the z column. For higher n values, the terrain compression happens more in the mid to upper z levels (but always below flat_z_height), whereas for n=1 it is mainly at the lower levels, which may cause numerical issues if these are very thin. By setting s1=s2 a standard hybrid coordinate is obtained. + ! Use a SLEVE vertical coordinate, where the decay of the large- and small-scale terrain influence towards model top is controlled by the + ! decay_rate_L_topo and decay_rate_S_topo respectively (=H/s1 and H/s2), and the exponential factor n that controls compression across the z column. + ! For higher n values, the terrain compression happens more in the mid to upper z levels (but always below flat_z_height), + ! whereas for n=1 it is mainly at the lower levels, which may cause numerical issues if these are very thin. By setting s1=s2 a standard hybrid coordinate is obtained. + ! For many atmospheric applications it appears optimal to choose s1 ~10 km and, subsequently, to minimize s2 for a specified value of gamma > 0" sleve = .True. terrain_smooth_windowsize = 4 ! Terrain is smoothed to obtain the large-scale terrain features @@ -49,6 +53,7 @@ ! These are the options for output variables. Though they will only be output if they are computed internally ! "u", "v", "w_grid", "w", + ! "ivt", "iwv", "iwl", "iwi" ! "nsquared", "pressure", "pressure_i", "psfc", ! "potential_temperature", "temperature", ! "qv", "qc", "nc", "qi", "ni", "qr", "nr", "qs", "ns", "qg", "ng", @@ -60,6 +65,17 @@ ! "canopy_water", "swe", "soil_water_content", "soil_column_total_water", "soil_temperature", "soil_deep_temperature", ! "land_mask", "terrain", "lat", "lon", "u_lat", "u_lon", "v_lat", "v_lon" + !additional output variable options for NoahMP (check default_output_metadata for complete list) + ! "snowfall_ground","rainfall_ground","snow_temperature","snow_layer_depth","snow_layer_ice", + ! "snow_layer_liquid_water","canopy_ice","canopy_liquid","snow_height", + ! "snow_nlayers","eq_soil_moisture", + ! "smc_watertable_deep","recharge","recharge_deep","evap_canopy","evap_soil_surface", + ! "transpiration_rate","ground_surf_temperature","runoff_surface","runoff_subsurface" + + !! additional output variable options for water_lake + ! "t_lake3d" , "lake_icefrac3d", "snl2d", "t_grnd2d",lake_icefrac3d,z_lake3d,dz_lake3d,t_soisno3d,h2osoi_ice3d + ! ,h2osoi_liq3d,h2osoi_vol3d ,z3d,dz3d,watsat3d,csol3d,tkmg3d,lakemask,zi3d,tksatu3d,tkdry3d,lakedepth2d + outputinterval = 3600 ! number of seconds between output time slices output_file = "output/icar_out_" ! prefix name of output file (date will be appended) ! output_file_frequency = "monthly" ! eventually this will be used to specify how frequently to create new files (not implemented yet) @@ -76,19 +92,33 @@ &physics ! Common precipitation downscaling run use pbl=0 lsm=0 mp=1 rad=0 conv=0 adv=1 wind=1 ! For a FASTER run (simpler physics), set mp=2 - ! If surface air temperature is important use pbl=2 lsm=3 rad=2 water=2 this requires Noah LSM data + ! If surface air temperature is important use pbl=2 lsm=4 rad=3 water=3 this requires Noah MP and lake data ! N/A = Not Available or Not fully implemented ! Warning, convection can be unstable. ! wishlist = No Code Present yet - pbl = 0, ! 1=legacy (deprecated) 2=Simple (Local HP96) 3=YSU (N/A) - lsm = 0, ! 1=use prescribed fluxes 2=Simple LSM (N/A) 3=Noah LSM 4=NoahMP (wishlist) - water=2, ! 1=use prescribed (w/lsm=1) 2=Simple sea surface fluxes - mp = 1, ! 1=Thompson 2=Simple (SB04) 3=Morrison 4=WSM6 5=Thompson-Eidhammer - rad = 0, ! 1=use prescribed fluxes 2=Simple (empirical) 3=RRTMG (wishlist) - conv= 0, ! 1=Tiedke Scheme 2=Simple Scheme (wishlist) 3=Kain-Fritsch - adv = 1, ! 1=Upwind 2=MPDATA 3=Adams-Bashforth (wishlist) - wind= 1 ! 1=Linear Theory + ! Planetary Boundary Layer Scheme + pbl = 0, ! 1=legacy (deprecated) 2=Simple (Local HP96) 3=YSU (work in progress) + + ! Land Surface Model + lsm = 0, ! 1=use prescribed fluxes 2=Simple LSM (N/A) 3=Noah LSM 4=NoahMP + + ! Open water fluxes + water=0, ! 1=use prescribed (w/lsm=1) 2=Simple sea surface fluxes 3=Lake model (simple ocean) + + ! Microphysics Scheme + mp = 1, ! 1=Thompson 2=Simple (SB04) 3=Morrison 4=WSM6 5=Thompson-Eidhammer 6=WSM3 + ! Radiation Scheme + rad = 0, ! 1=use prescribed fluxes 2=Simple (empirical) 3=RRTMG + + ! Convection / Cumulus Scheme + conv= 0, ! 1=Tiedke Scheme 2=Simple Scheme (wishlist) 3=Kain-Fritsch 4=NSAS 5=BMJ + + ! Advection Scheme + adv = 1, ! 1=Upwind 2=MPDATA 3=Runga-Kutta (in progress?) + + ! Wind field calculations + wind= 1 ! 1=Linear Theory 2=grid based,mass-conserving 3=iterative wind solver 4=implicit(in progress) 5=linear+iterative / !--------------------------------------------------------- @@ -234,6 +264,8 @@ use_mp_options = true ! Read parameters for land surface model use_lsm_options = true + ! Read parameters for radiation model + use_rad_options = true ! Read parameters for online bias correction use_bias_correction = false ! Read parameters for experimental blocked flow parameterization @@ -287,7 +319,8 @@ lwdown_var = "GLW", ! Longwave down [W/m^2] ! only required for some physics code (Noah LSM, water, Tiedke, KF(?)) - landvar = "LANDMASK", ! land-water mask (as in WRF) 1=land, 0 or 2=water + landvar = "LANDMASK", ! land-water mask (as in WRF) 1=land, 0 or 2=water + lakedepthvar = "LAKE_DEPTH", ! depth of the lake [m] ! NOTE, these variables should be in the high-resolution initial conditions netcdf file lat_hi = "XLAT_M", ! latitude (mass grid) [degrees] @@ -313,6 +346,11 @@ ! soil_t_var = "TSLB", ! soil temperature (4 levels) [K] ! soil_vwc_var = "SMOIS", ! soil water content (4 levels) [m^3/m^3] + ! to use the NoahMP LSM, the following additional fields must be specified or default values will be applied + !vegfracmax_var = "VEGMAX", ! maximum annual vegetation fraction (default = 0.8) + !lai_var = "LAI", ! leaf area index (default = 1) + !canwat_var = "CANWAT", ! total canopy water (liquid + ice) (default = 0) + ! variables to read from calibration files, both default to "data" ! nsq_calibration_var = "data", ! linear_mask_var = "data" @@ -326,6 +364,15 @@ tsoil3D_ext = "T_SO" ! N.B. This will overwrite any input from soil_t_var or soil_deept_var !! / +!--------------------------------------------------------- +! Optionally specified radiation parameters +!--------------------------------------------------------- +&rad_parameters + update_interval_rrtmg=1800 + icloud=3 + read_ghg=.True. + use_simple_sw=True +/ !--------------------------------------------------------- ! Optionally specified Microphysics parameters (mostly for Thompson) @@ -367,8 +414,8 @@ ! Optionally specified convection parameters !--------------------------------------------------------- &cu_parameters - stochastic_cu = 0 - tendency_fraction = 1.0 + stochastic_cu = 0 ! disturbes the W field (randomly; higher value=more disturbance). Triggers convection. + tendency_fraction = 1.0 ! scales the q[v/c/i]/th fractions (relative to 1). Lower values lead to more cu_precip. tend_qv_fraction = 1.0 tend_qc_fraction = 1.0 tend_th_fraction = 1.0 @@ -409,6 +456,13 @@ ! urban_category = -1 ! Int: index that defines the urban category in LU_Categories ! ice_category = -1 ! Int: index that defines the ice category in LU_Categories ! water_category = -1 ! Int: index that defines the water category in LU_Categories + ! lake_category = -1 ! Int: index that defines the lake(s) category in LU_Categories + + lh_feedback_fraction = 1.0 ! fraction of latent heat to feed into the atmosphere to increase water vapor + sh_feedback_fraction = 0.625 ! fraction of sensible heat to feed into the atmosphere to increase temperature + sfc_layer_thickness = 400.0 ! thickness of lower atmosphere to spread LH and SH fluxes over [m] + dz_lsm_modification = 0.5 ! multiplier on dz thickness in call to NoahMP, significantly improves ta2m + wind_enhancement = 1.5 ! factor to increase wind speeds passed to NoahMP to account for biases in driving model and improve surface fluxes / @@ -491,8 +545,9 @@ bias_correction_filename = "" ! name of variable in netcdf file that defines a multiplier for precipitation at each grid point - ! variable should have a time dimension that will be interpolated over a one year period to permit a seasonality - ! to the bias correction + ! variable can have a 12-month time dimension to permit seasonality + ! to the bias correction. Data should represent the ratio between ICAR precipitation and Observations + ! e.g. icar / obs rain_fraction_var = "" / @@ -511,6 +566,11 @@ !--------------------------------------------------------- ! Optionally specified Restart information +! +! NOTE: If the (original) output file corresponding to the restart time is not removed before restarting, its 'time:units' parameter (i.e. +! time:units = "days since 2000-01-01 00:00:00") - is not overwritten, resulting in wrong timestamp for that first file after restart. +! CURE: remove output files of the restart time from initial simulation before restarting. Or use the fix_icar_time.py script in icar/helpers/ +! !--------------------------------------------------------- &restart_info ! file to read for initial conditions (an ICAR output file will work) diff --git a/run/short_icar_options.nml b/run/short_icar_options.nml index 5109896e..eeb87016 100644 --- a/run/short_icar_options.nml +++ b/run/short_icar_options.nml @@ -2,7 +2,7 @@ ! Model and run meta-data !--------------------------------------------------------- &model_version - version = "2.0", ! This must match the version of the compiled code + version = "2.1", ! This must match the version of the compiled code comment = "Add your comment here" ! This will be stored in output files / @@ -10,7 +10,7 @@ ! Specify output and restart files and output frequencies !--------------------------------------------------------- &output_list - ! this is a list of variable names to be written in each output file + ! this is a list of variable names to be written in each output file see complete_icar_options file for list of variables names = "u","v","ta2m","hus2m", "precipitation", "swe" outputinterval = 3600 ! number of seconds between output time slices @@ -29,33 +29,34 @@ &physics ! Common precipitation downscaling run use pbl=0 lsm=0 mp=1 rad=0 conv=0 adv=1 wind=1 ! For a FASTER run (simpler physics), set mp=2 - ! If surface air temperature is important use pbl=2 lsm=3 rad=2 water=2 this requires Noah LSM data - ! Warning, convection can be unstable + ! If surface air temperature is important use pbl=2 lsm=4 rad=2 water=3 this requires NoahMP LSM data + ! Convection is OK, but not great, conv=5 seems best? requires lsm/pbl/etc options + ! ! N/A = Not Available or Not fully implemented ! wishlist = No Code Present yet ! Planetary Boundary Layer Scheme - pbl = 0, ! 1=legacy (deprecated) 2=Simple (Local HP96) 3=YSU (N/A) + pbl = 0, ! 1=legacy (deprecated) 2=Simple (Local HP96) 3=YSU (work in progress) ! Land Surface Model - lsm = 0, ! 1=use prescribed fluxes 2=Simple LSM (N/A) 3=Noah LSM 4=NoahMP (wishlist) + lsm = 0, ! 1=use prescribed fluxes 2=Simple LSM (N/A) 3=Noah LSM 4=NoahMP ! Open water fluxes - water=0, ! 1=use prescribed (w/lsm=1) 2=Simple sea surface fluxes + water=0, ! 1=use prescribed (w/lsm=1) 2=Simple sea surface fluxes 3=WRF-Lake model ! Microphysics Scheme - mp = 1, ! 1=Thompson 2=Simple (SB04) 3=Morrison 4=WSM6 5=Thompson-Eidhammer + mp = 1, ! 1=Thompson 2=Simple (SB04) 3=Morrison 4=WSM6 5=Thompson-Eidhammer 6=WSM3 ! Radiation Scheme - rad = 0, ! 1=use prescribed fluxes 2=Simple (empirical) 3=RRTMG (wishlist) + rad = 0, ! 1=use prescribed fluxes 2=Simple (empirical) 3=RRTMG ! Convection / Cumulus Scheme - conv= 0, ! 1=Tiedke Scheme 2=Simple Scheme (wishlist) 3=Kain-Fritsch + conv= 0, ! 1=Tiedke Scheme 2=Simple Scheme (wishlist) 3=Kain-Fritsch 4=NSAS 5=BMJ ! Advection Scheme - adv = 1, ! 1=Upwind 2=MPDATA 3=Adams-Bashforth (wishlist) + adv = 1, ! 1=Upwind 2=MPDATA 3=Runga-Kutta (in progress?) ! Wind field calculations - wind= 1 ! 1=Linear Theory + wind= 1 ! 1=Linear Theory 2=grid based,mass-conserving 3=iterative wind solver 4=implicit(in progress) 5=linear+iterative / !--------------------------------------------------------- @@ -106,11 +107,11 @@ ! WARNING : ICAR can be surprisingly sensitive to this parameter nz = 15, ! [] ! Set this to true if the zvar in the input data is actually in units of geopotential height (m/s^2) - z_is_geopotential = True, + z_is_geopotential = False, ! Set this to true if the zvar in the input data is specified on the interfaces between mass levels - z_is_on_interface = True, + z_is_on_interface = False, ! Specify that the height of the forcing data will change through the simulation (common for atmospheric model-level output) - time_varying_z = true, + time_varying_z = True, ! Use height above ground level to interpolate the wind field instead of height above sea level. use_agl_height = False, @@ -164,7 +165,7 @@ vlat_hi = "XLAT_V", ! latitude (ns-staggered grid) [degrees] vlon_hi = "XLONG_V", ! longitude (ns-staggered grid) [degrees] - ! To use the Noah LSM additional fields must be specified on the high-res grid, see complete_icar_options.nml + ! To use the Noah or NoahMP LSMs, additional fields must be specified on the high-res grid, see complete_icar_options.nml ! only required for some physics code (Noah LSM, water, Tiedke, KF(?)) landvar = "LANDMASK", ! land-water mask (as in WRF) 1=land, 0 or 2=water diff --git a/src/constants/.ipynb_checkpoints/icar_constants-checkpoint.f90 b/src/constants/.ipynb_checkpoints/icar_constants-checkpoint.f90 deleted file mode 100644 index fc76d14a..00000000 --- a/src/constants/.ipynb_checkpoints/icar_constants-checkpoint.f90 +++ /dev/null @@ -1,236 +0,0 @@ -!>------------------------------------------------ -!! Defines model constants (e.g. gravity, and MAXFILELENGTH) -!! -!!------------------------------------------------ -module icar_constants - - implicit none - - character(len=5) :: kVERSION_STRING = "2.0a1" - - ! string lengths - integer, parameter :: kMAX_FILE_LENGTH = 1024 - integer, parameter :: kMAX_DIM_LENGTH = 1024 - integer, parameter :: kMAX_NAME_LENGTH = 1024 - integer, parameter :: kMAX_ATTR_LENGTH = 1024 - - !>-------------------------------------------- - ! list of integer constants to be used when accessing various arrays that track variable allocation, usage, etc. requests - ! - ! NOTE: IF YOU ADD TO THIS LIST BE SURE TO ADD AN INTEGER TO THE kVARS STRUCTURE CONSTRUCTOR BELOW IT! - ! This could be transitioned to an enum... but then one can't just "use, only:kVARS"... - ! enum, bind(C) - ! enumerator :: u, v, w,... - ! end enum - ! -------------------------------------------- - type var_constants_type - SEQUENCE ! technically SEQUENCE just requires the compiler leave them in order, - ! but it can also keep compilers (e.g. ifort) from padding for alignment, - ! as long as there is no padding we can test last_var = sizeof(kVARS) - - integer :: u - integer :: v - integer :: w - integer :: w_real - integer :: pressure - integer :: pressure_interface - integer :: potential_temperature - integer :: temperature - integer :: water_vapor - integer :: cloud_water - integer :: cloud_number_concentration - integer :: cloud_ice - integer :: ice_number_concentration - integer :: rain_in_air - integer :: rain_number_concentration - integer :: snow_in_air - integer :: snow_number_concentration - integer :: graupel_in_air - integer :: graupel_number_concentration - integer :: precipitation - integer :: convective_precipitation - integer :: snowfall - integer :: graupel - integer :: exner - integer :: density - integer :: z - integer :: z_interface - integer :: dz - integer :: dz_interface - integer :: cloud_fraction - integer :: shortwave - integer :: longwave - integer :: vegetation_fraction - integer :: veg_type - integer :: soil_type - integer :: lai - integer :: canopy_water - integer :: sensible_heat - integer :: latent_heat - integer :: u_10m - integer :: v_10m - integer :: ustar - integer :: temperature_2m - integer :: humidity_2m - integer :: surface_pressure - integer :: longwave_up - integer :: ground_heat_flux - integer :: soil_totalmoisture - integer :: soil_deep_temperature - integer :: roughness_z0 - integer :: snow_water_equivalent - integer :: soil_water_content - integer :: soil_temperature - integer :: skin_temperature - integer :: sst - integer :: land_mask - integer :: terrain - integer :: latitude - integer :: longitude - integer :: u_latitude - integer :: u_longitude - integer :: v_latitude - integer :: v_longitude - integer :: tend_qv_adv - integer :: tend_qv_pbl - integer :: tend_qv - integer :: tend_th - integer :: tend_qc - integer :: tend_qi - integer :: tend_qs - integer :: tend_qr - integer :: tend_u - integer :: tend_v - integer :: znu - integer :: znw - integer :: last_var - end type var_constants_type - - type(var_constants_type) :: kVARS = var_constants_type( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & - 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, & - 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, & - 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, & - 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, & - 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, & - 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, & - 71, 72, 73, 74, 75, 76 ) - - integer, parameter :: kINTEGER_BITS = storage_size(kINTEGER_BITS) - integer, parameter :: kMAX_STORAGE_VARS = storage_size(kVARS) / kINTEGER_BITS - - ! Initial number of output variables for which pointers are created - integer, parameter :: kINITIAL_VAR_SIZE= 128 - - ! Maximum number of dimensions - ! Note this is defined in NetCDF, though not enforced (a file can have more than 1024 dimensions) - integer, parameter :: kMAX_DIMENSIONS = 1024 - -!>------------------------------------------------ -!! Model constants (mostly string lengths) -!! ------------------------------------------------ - integer, parameter :: MAXFILELENGTH = 1024 ! maximum file name length - integer, parameter :: MAXVARLENGTH = 1024 ! maximum variable name length - integer, parameter :: MAXLEVELS = 500 ! maximum number of vertical layers (should typically be ~10-20) - integer, parameter :: MAX_NUMBER_FILES = 50000 ! maximum number of permitted input files (probably a bit extreme) - integer, parameter :: MAXSTRINGLENGTH = 1024 ! maximum length of other strings (e.g. netcdf attributes) - integer, parameter :: kMAX_STRING_LENGTH = 1024 ! maximum length of other strings (e.g. netcdf attributes) - - -!>------------------------------------------------ -!! Default width of coarray halos, ideally might be physics dependant (e.g. based on advection spatial order) -!! ------------------------------------------------ - integer,parameter :: kDEFAULT_HALO_SIZE = 1 - -!>------------------------------------------------ -!! Value to accept for difference between real numbers should be as a fraction but then have to test for non-zero... -!! For some variables (cloud ice) 1e-6 is not that small, for others (pressure) it might be below precision... -!! ------------------------------------------------ - real, parameter :: kSMALL_VALUE = 1e-6 - - integer, parameter :: kMAINTAIN_LON = 0 - integer, parameter :: kPRIME_CENTERED = 1 - integer, parameter :: kDATELINE_CENTERED = 2 - integer, parameter :: kGUESS_LON = 3 - -! ------------------------------------------------ -! Physics scheme selection definitions -! -! NB: BASIC typically means "use the data from the low res model" -! SIMPLE typically means a relatively simple formulation written for ICAR -! These could all be switched to enums too, but this makes it easy to see what number each has for the options file... -! ------------------------------------------------ - integer, parameter :: kNO_STOCHASTIC = -9999 - integer, parameter :: kCU_TIEDTKE = 1 - integer, parameter :: kCU_SIMPLE = 2 - integer, parameter :: kCU_KAINFR = 3 - - integer, parameter :: kMP_THOMPSON = 1 - integer, parameter :: kMP_SB04 = 2 - integer, parameter :: kMP_MORRISON = 3 - integer, parameter :: kMP_WSM6 = 4 - integer, parameter :: kMP_THOMP_AER = 5 - - integer, parameter :: kPBL_BASIC = 1 - integer, parameter :: kPBL_SIMPLE = 2 - integer, parameter :: kPBL_YSU = 3 - - integer, parameter :: kWATER_BASIC = 1 - integer, parameter :: kWATER_SIMPLE = 2 - - integer, parameter :: kLSM_BASIC = 1 - integer, parameter :: kLSM_SIMPLE = 2 - integer, parameter :: kLSM_NOAH = 3 - - integer, parameter :: kRA_BASIC = 1 - integer, parameter :: kRA_SIMPLE = 2 - - integer, parameter :: kADV_UPWIND = 1 - integer, parameter :: kADV_MPDATA = 2 - - integer, parameter :: kWIND_LINEAR = 1 - integer, parameter :: kCONSERVE_MASS = 2 - integer, parameter :: kITERATIVE_WINDS = 3 - - integer, parameter :: kLC_LAND = 1 - integer, parameter :: kLC_WATER = 2 - - ! mm of accumulated precip before "tipping" into the bucket - ! only performed on output operations - integer, parameter :: kPRECIP_BUCKET_SIZE=100 - -! ------------------------------------------------ -! Physical Constants -! ------------------------------------------------ - real, parameter :: LH_vaporization=2260000.0 ! J/kg - ! could be calculated as 2.5E6 + (-2112.0)*temp_degC ? - real, parameter :: Rd = 287.058 ! J/(kg K) specific gas constant for dry air - real, parameter :: Rw = 461.5 ! J/(kg K) specific gas constant for moist air - real, parameter :: cp = 1012.0 ! J/kg/K specific heat capacity of moist STP air? - real, parameter :: gravity= 9.81 ! m/s^2 gravity - real, parameter :: pi = 3.1415927 ! pi - real, parameter :: stefan_boltzmann = 5.67e-8 ! the Stefan-Boltzmann constant - real, parameter :: karman = 0.41 ! the von Karman constant - - ! convenience parameters for various physics packages - real, parameter :: rovcp = Rd/cp - real, parameter :: rovg = Rd/gravity - - ! from wrf module_model_constants - ! parameters for calculating latent heat as a function of temperature for - ! vaporization - real, parameter :: XLV0 = 3.15E6 - real, parameter :: XLV1 = 2370. - ! sublimation - real, parameter :: XLS0 = 2.905E6 - real, parameter :: XLS1 = 259.532 - - ! saturated vapor pressure parameters (?) - real, parameter :: SVP1 = 0.6112 - real, parameter :: SVP2 = 17.67 - real, parameter :: SVP3 = 29.65 - real, parameter :: SVPT0= 273.15 - - real, parameter :: EP1 = Rw/Rd-1. - real, parameter :: EP2 = Rd/Rw - -end module diff --git a/src/constants/icar_constants.f90 b/src/constants/icar_constants.f90 index fea9cf4b..82f386b4 100644 --- a/src/constants/icar_constants.f90 +++ b/src/constants/icar_constants.f90 @@ -6,7 +6,7 @@ module icar_constants implicit none - character(len=5) :: kVERSION_STRING = "2.0" + character(len=5) :: kVERSION_STRING = "2.1" ! string lengths integer, parameter :: kMAX_FILE_LENGTH = 1024 @@ -49,8 +49,11 @@ module icar_constants integer :: graupel_number_concentration integer :: precipitation integer :: convective_precipitation + integer :: external_precipitation integer :: snowfall integer :: graupel + integer :: snowfall_ground + integer :: rainfall_ground integer :: exner integer :: nsquared integer :: density @@ -60,28 +63,139 @@ module icar_constants integer :: dz_interface integer :: cloud_fraction integer :: shortwave + integer :: shortwave_direct + integer :: shortwave_diffuse integer :: longwave + integer :: albedo integer :: vegetation_fraction + integer :: vegetation_fraction_max + integer :: vegetation_fraction_out integer :: veg_type + integer :: mass_leaf + integer :: mass_root + integer :: mass_stem + integer :: mass_wood integer :: soil_type + integer :: soil_texture_1 + integer :: soil_texture_2 + integer :: soil_texture_3 + integer :: soil_texture_4 + integer :: soil_sand_and_clay + integer :: soil_carbon_stable + integer :: soil_carbon_fast integer :: lai + integer :: sai + integer :: crop_category + integer :: crop_type + integer :: date_planting + integer :: date_harvest + integer :: growing_season_gdd + integer :: irr_frac_total + integer :: irr_frac_sprinkler + integer :: irr_frac_micro + integer :: irr_frac_flood + integer :: irr_eventno_sprinkler + integer :: irr_eventno_micro + integer :: irr_eventno_flood + integer :: irr_alloc_sprinkler + integer :: irr_alloc_micro + integer :: irr_alloc_flood + integer :: irr_evap_loss_sprinkler + integer :: irr_amt_sprinkler + integer :: irr_amt_micro + integer :: irr_amt_flood + integer :: evap_heat_sprinkler + integer :: mass_ag_grain + integer :: growing_degree_days + integer :: plant_growth_stage + integer :: net_ecosystem_exchange + integer :: gross_primary_prod + integer :: net_primary_prod + integer :: apar + integer :: photosynthesis_total + integer :: stomatal_resist_total + integer :: stomatal_resist_sun + integer :: stomatal_resist_shade + integer :: gecros_state integer :: canopy_water + integer :: canopy_water_ice + integer :: canopy_water_liquid + integer :: canopy_vapor_pressure + integer :: canopy_temperature + integer :: canopy_fwet + integer :: veg_leaf_temperature + integer :: ground_surf_temperature + integer :: frac_between_gap + integer :: frac_within_gap + integer :: ground_temperature_bare + integer :: ground_temperature_canopy integer :: sensible_heat integer :: latent_heat integer :: u_10m integer :: v_10m integer :: ustar + integer :: coeff_momentum_drag + integer :: coeff_heat_exchange + integer :: coeff_heat_exchange_3d + integer :: surface_rad_temperature integer :: temperature_2m integer :: humidity_2m + integer :: temperature_2m_veg + integer :: temperature_2m_bare + integer :: mixing_ratio_2m_veg + integer :: mixing_ratio_2m_bare integer :: surface_pressure + integer :: rad_absorbed_total + integer :: rad_absorbed_veg + integer :: rad_absorbed_bare + integer :: rad_net_longwave integer :: longwave_up integer :: ground_heat_flux + integer :: evap_canopy + integer :: evap_soil_surface + integer :: transpiration_rate + integer :: ch_veg + integer :: ch_veg_2m + integer :: ch_bare + integer :: ch_bare_2m + integer :: ch_under_canopy + integer :: ch_leaf + integer :: sensible_heat_veg + integer :: sensible_heat_bare + integer :: sensible_heat_canopy + integer :: evap_heat_veg + integer :: evap_heat_bare + integer :: evap_heat_canopy + integer :: transpiration_heat + integer :: ground_heat_veg + integer :: ground_heat_bare + integer :: net_longwave_veg + integer :: net_longwave_bare + integer :: net_longwave_canopy + integer :: runoff_surface + integer :: runoff_subsurface integer :: soil_totalmoisture integer :: soil_deep_temperature + integer :: water_table_depth + integer :: water_aquifer + integer :: storage_gw + integer :: storage_lake integer :: roughness_z0 integer :: snow_water_equivalent + integer :: snow_water_eq_prev + integer :: snow_albedo_prev + integer :: snow_temperature + integer :: snow_layer_depth + integer :: snow_layer_ice + integer :: snow_layer_liquid_water + integer :: snow_age_factor integer :: snow_height + integer :: snow_nlayers integer :: soil_water_content + integer :: eq_soil_moisture + integer :: smc_watertable_deep + integer :: recharge + integer :: recharge_deep integer :: soil_temperature integer :: skin_temperature integer :: sst @@ -97,29 +211,91 @@ module icar_constants integer :: tend_qv_pbl integer :: tend_qv integer :: tend_th + integer :: tend_th_pbl integer :: tend_qc + integer :: tend_qc_pbl integer :: tend_qi + integer :: tend_qi_pbl integer :: tend_qs integer :: tend_qr integer :: tend_u integer :: tend_v integer :: znu integer :: znw + integer :: re_cloud + integer :: re_ice + integer :: re_snow + integer :: out_longwave_rad + integer :: longwave_cloud_forcing + integer :: shortwave_cloud_forcing + integer :: land_emissivity + integer :: temperature_interface + integer :: cosine_zenith_angle + integer :: tend_swrad + integer :: kpbl + integer :: hpbl + integer :: lake_depth + integer :: t_lake3d + integer :: snl2d + integer :: t_grnd2d + integer :: lake_icefrac3d + integer :: z_lake3d + integer :: dz_lake3d + integer :: t_soisno3d + integer :: h2osoi_ice3d + integer :: h2osoi_liq3d! liquid water (kg/m2) + integer :: h2osoi_vol3d! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + integer :: z3d ! layer depth for snow & soil (m) + integer :: dz3d + integer :: watsat3d + integer :: csol3d + integer :: tkmg3d + integer :: lakemask + integer :: zi3d + integer :: tksatu3d + integer :: tkdry3d + integer :: savedtke12d + integer :: lakedepth2d + integer :: ivt + integer :: iwv + integer :: iwl + integer :: iwi integer :: last_var end type var_constants_type - type(var_constants_type) :: kVARS = var_constants_type( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & - 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, & - 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, & - 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, & - 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, & - 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, & - 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, & - 71, 72, 73, 74, 75, 76, 77 ,78) + + type(var_constants_type) :: kVARS = var_constants_type( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & + 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, & + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, & + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, & + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, & + 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, & + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, & + 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, & + 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, & + 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, & + 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, & + 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, & + 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, & + 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, & + 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, & + 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, & + 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, & + 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, & + 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, & + 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, & + 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, & + 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, & + 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, & + 231, 232, 233) + integer, parameter :: kINTEGER_BITS = storage_size(kINTEGER_BITS) integer, parameter :: kMAX_STORAGE_VARS = storage_size(kVARS) / kINTEGER_BITS + integer, parameter :: kREAL = 4 + integer, parameter :: kDOUBLE = 8 + ! Initial number of output variables for which pointers are created integer, parameter :: kINITIAL_VAR_SIZE= 128 @@ -165,12 +341,15 @@ module icar_constants integer, parameter :: kCU_TIEDTKE = 1 integer, parameter :: kCU_SIMPLE = 2 integer, parameter :: kCU_KAINFR = 3 + integer, parameter :: kCU_NSAS = 4 + integer, parameter :: kCU_BMJ = 5 integer, parameter :: kMP_THOMPSON = 1 integer, parameter :: kMP_SB04 = 2 integer, parameter :: kMP_MORRISON = 3 integer, parameter :: kMP_WSM6 = 4 integer, parameter :: kMP_THOMP_AER = 5 + integer, parameter :: kMP_WSM3 = 6 integer, parameter :: kPBL_BASIC = 1 integer, parameter :: kPBL_SIMPLE = 2 @@ -178,13 +357,16 @@ module icar_constants integer, parameter :: kWATER_BASIC = 1 integer, parameter :: kWATER_SIMPLE = 2 + integer, parameter :: kWATER_LAKE = 3 integer, parameter :: kLSM_BASIC = 1 integer, parameter :: kLSM_SIMPLE = 2 integer, parameter :: kLSM_NOAH = 3 + integer, parameter :: kLSM_NOAHMP = 4 integer, parameter :: kRA_BASIC = 1 integer, parameter :: kRA_SIMPLE = 2 + integer, parameter :: kRA_RRTMG = 3 integer, parameter :: kADV_UPWIND = 1 integer, parameter :: kADV_MPDATA = 2 @@ -192,9 +374,10 @@ module icar_constants integer, parameter :: kWIND_LINEAR = 1 integer, parameter :: kCONSERVE_MASS = 2 integer, parameter :: kITERATIVE_WINDS = 3 + integer, parameter :: kLINEAR_ITERATIVE_WINDS = 5 integer, parameter :: kLC_LAND = 1 - integer, parameter :: kLC_WATER = 2 + integer, parameter :: kLC_WATER = 2 ! 0 ! This should maybe become an argument in the namelist if we use different hi-es files? ! mm of accumulated precip before "tipping" into the bucket ! only performed on output operations @@ -212,6 +395,7 @@ module icar_constants real, parameter :: pi = 3.1415927 ! pi real, parameter :: stefan_boltzmann = 5.67e-8 ! the Stefan-Boltzmann constant real, parameter :: karman = 0.41 ! the von Karman constant + real, parameter :: solar_constant = 1366 ! W/m^2 ! convenience parameters for various physics packages real, parameter :: rovcp = Rd/cp diff --git a/src/constants/wrf_constants.f90 b/src/constants/wrf_constants.f90 index ae310923..00ced356 100644 --- a/src/constants/wrf_constants.f90 +++ b/src/constants/wrf_constants.f90 @@ -65,6 +65,11 @@ MODULE mod_wrf_constants REAL , PARAMETER :: rhowater = 1000. REAL , PARAMETER :: rhosnow = 100. REAL , PARAMETER :: rhoair0 = 1.28 + + REAL , PARAMETER :: RE_QC_BG = 2.49E-6 ! effective radius of cloud for background (m) + REAL , PARAMETER :: RE_QI_BG = 4.99E-6 ! effective radius of ice for background (m) + REAL , PARAMETER :: RE_QS_BG = 9.99E-6 ! effective radius of snow for background (m) + ! REAL , PARAMETER :: n_ccn0 = 1.0E8 ! @@ -72,12 +77,12 @@ MODULE mod_wrf_constants REAL , PARAMETER :: DEGRAD = piconst/180. REAL , PARAMETER :: DPD = 360./365. - ! REAL , PARAMETER :: SVP1=0.6112 - ! REAL , PARAMETER :: SVP2=17.67 - ! REAL , PARAMETER :: SVP3=29.65 - ! REAL , PARAMETER :: SVPT0=273.15 - ! REAL , PARAMETER :: EP_1=R_v/R_d-1. - ! REAL , PARAMETER :: EP_2=R_d/R_v +! REAL , PARAMETER :: SVP1=0.6112 ! for YSU pbl +! REAL , PARAMETER :: SVP2=17.67 +! REAL , PARAMETER :: SVP3=29.65 +! REAL , PARAMETER :: SVPT0=273.15 +! REAL , PARAMETER :: EP_1=R_v/R_d-1. !-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless) +! REAL , PARAMETER :: EP_2=R_d/R_v !-- ep2 constant for specific humidity calculation ! REAL , PARAMETER :: KARMAN=0.4 REAL , PARAMETER :: EOMEG=7.2921E-5 REAL , PARAMETER :: STBOLT=5.67051E-8 diff --git a/src/io/default_output_metadata.f90 b/src/io/default_output_metadata.f90 index ceaa8c08..cd53ef97 100644 --- a/src/io/default_output_metadata.f90 +++ b/src/io/default_output_metadata.f90 @@ -11,7 +11,7 @@ module output_metadata !! Generic interface to the netcdf read routines !!------------------------------------------------------------ interface get_metadata - module procedure get_metadata_2d, get_metadata_3d, get_metadata_nod + module procedure get_metadata_2d, get_metadata_2dd, get_metadata_3d, get_metadata_nod end interface @@ -38,7 +38,6 @@ function get_metadata_nod(var_idx) result(meta_data) ! set the dimensionality to false meta_data%two_d = .False. meta_data%three_d = .False. - end function get_metadata_nod !>------------------------------------------------------------ @@ -61,6 +60,7 @@ function get_metadata_2d(var_idx, input_data) result(meta_data) if (.not.allocated(var_meta)) call init_var_meta() meta_data = var_meta(var_idx) + meta_data%dtype=kREAL if (associated(input_data)) then meta_data%data_2d => input_data @@ -74,6 +74,35 @@ function get_metadata_2d(var_idx, input_data) result(meta_data) end function get_metadata_2d + function get_metadata_2dd(var_idx, input_data) result(meta_data) + implicit none + integer, intent(in) :: var_idx + double precision, intent(in), pointer :: input_data(:,:) + + type(variable_t) :: meta_data ! function result + integer :: local_shape(2) ! store the shape of the input data array + + if (var_idx>kMAX_STORAGE_VARS) then + stop "Invalid variable metadata requested" + endif + + if (.not.allocated(var_meta)) call init_var_meta() + + meta_data = var_meta(var_idx) + meta_data%dtype=kDOUBLE + + if (associated(input_data)) then + meta_data%data_2dd => input_data + meta_data%two_d = .True. + meta_data%three_d = .False. + local_shape(1) = size(input_data, 1) + local_shape(2) = size(input_data, 2) + ! for some reason if shape(input_data) is passed as source, then the dim_len bounds are (0:1) instead of 1:2 + allocate(meta_data%dim_len, source=local_shape) + endif + + end function get_metadata_2dd + !>------------------------------------------------------------ !! Get generic metadata for a three-dimensional variable !! @@ -95,6 +124,7 @@ function get_metadata_3d(var_idx, input_data) result(meta_data) if (.not.allocated(var_meta)) call init_var_meta() meta_data = var_meta(var_idx) + meta_data%dtype=kREAL if (associated(input_data)) then meta_data%data_3d => input_data @@ -153,8 +183,18 @@ subroutine init_var_meta() character(len=16) :: two_d_t_dimensions(3) = [character(len=16) :: "lon_x","lat_y","time"] character(len=16) :: two_d_u_dimensions(2) = [character(len=16) :: "lon_u","lat_y"] character(len=16) :: two_d_v_dimensions(2) = [character(len=16) :: "lon_x","lat_v"] - character(len=16) :: three_d_soil_dimensions(3) = [character(len=16) :: "lon_x","lat_y","nsoil"] character(len=16) :: three_d_t_soil_dimensions(4) = [character(len=16) :: "lon_x","lat_y","nsoil","time"] + character(len=16) :: three_d_t_snow_dimensions(4) = [character(len=16) :: "lon_x","lat_y","nsnow","time"] + character(len=16) :: three_d_t_snowsoil_dimensions(4) = [character(len=16) :: "lon_x","lat_y","nsnowsoil","time"] + character(len=16) :: three_d_soilcomp_dimensions(3) = [character(len=16) :: "lon_x","lat_y","nsoil_composition"] + character(len=16) :: three_d_crop_dimensions(3) = [character(len=16) :: "lon_x","lat_y","crop"] + character(len=16) :: three_d_t_gecros_dimensions(4) = [character(len=16) :: "lon_x","lat_y","gecros","time"] + character(len=16) :: two_d_month_dimensions(3) = [character(len=16) :: "lon_x","lat_y","month"] + character(len=16) :: three_d_t_lake_dimensions(4) = [character(len=16) :: "lon_x","lat_y","nlevlake","time"] + character(len=16) :: three_d_t_lake_soisno_dimensions(4) = [character(len=16) :: "lon_x","lat_y","nlevsoisno","time"] !grid_lake_soisno + character(len=16) :: three_d_t_lake_soisno_1_dimensions(4) = [character(len=16) :: "lon_x","lat_y","nlevsoisno_1","time"] + character(len=16) :: three_d_t_lake_soi_dimensions(4) = [character(len=16) :: "lon_x","lat_y","nlevsoi_lake","time"] !grid_lake_soi + if (allocated(var_meta)) deallocate(var_meta) @@ -535,6 +575,131 @@ subroutine init_var_meta() attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate + + !>------------------------------------------------------------ + !! Effective cloud droplet radius + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%re_cloud)) + var%name = "re_cloud" + var%dimensions = three_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "effective_radius_of_cloud_liquid_water_particles"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Effective cloud ice radius + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%re_ice)) + var%name = "re_ice" + var%dimensions = three_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "effective_radius_of_stratiform_cloud_ice_particles"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Effective snow radius + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%re_snow)) + var%name = "re_snow" + var%dimensions = three_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "effective_radius_of_stratiform_snow_particles"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Outgoing longwave radiation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%out_longwave_rad)) + var%name = "rlut" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "toa_outgoing_longwave_flux"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Longwave cloud forcing + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%longwave_cloud_forcing)) + var%name = "lwcf" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "longwave_cloud_forcing"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Shortwave cloud forcing + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%shortwave_cloud_forcing)) + var%name = "swcf" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "shortwave_cloud_forcing"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Cosine solar zenith angle + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%cosine_zenith_angle)) + var%name = "cosz" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "cosine_zenith_angle"), & + attribute_t("units", " "), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Tendency from short wave radiation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%tend_swrad)) + var%name = "tend_swrad" + var%dimensions = three_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "sw_rad_tend"), & + attribute_t("units", " "), & + attribute_t("coordinates", "lat lon")] + end associate + + + !>------------------------------------------------------------ + !! Surface emissivity + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%land_emissivity)) + var%name = "emiss" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_longwave_emissivity"), & + attribute_t("units", " "), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Temperature on interface + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%temperature_interface)) + var%name = "temperature_i" + var%dimensions = three_d_t_interface_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "air_temperature"), & + attribute_t("long_name", "Temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + + + !>------------------------------------------------------------ !! Downward Shortwave Radiation at the Surface (positive down) !!------------------------------------------------------------ @@ -547,6 +712,28 @@ subroutine init_var_meta() attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ + !! Downward Direct Shortwave Radiation at the Surface (positive down) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%shortwave_direct)) + var%name = "shortwave_direct" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_direct_downwelling_shortwave_flux_in_air"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Downward Diffuse Shortwave Radiation at the Surface (positive down) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%shortwave_diffuse)) + var%name = "shortwave_diffuse" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_diffuse_downwelling_shortwave_flux_in_air"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ !! Downward Longwave Radiation at the Surface (positive down) !!------------------------------------------------------------ associate(var=>var_meta(kVARS%longwave)) @@ -558,6 +745,50 @@ subroutine init_var_meta() attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ + !! Total Absorbed Solar Radiation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%rad_absorbed_total)) + var%name = "rad_absorbed_total" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "total_absorbed_radiation"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Solar Radiation Absorbed by Vegetation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%rad_absorbed_veg)) + var%name = "rad_absorbed_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "radiation_absorbed_by_vegetation"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Solar Radiation Absorbed by Bare Ground + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%rad_absorbed_bare)) + var%name = "rad_absorbed_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "radiation_absorbed_by_bare_ground"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Net Longwave Radiation (positive up) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%rad_net_longwave)) + var%name = "rad_net_longwave" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "net_upward_longwave_flux_in_air"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ !! Upward Longwave Radiation at the Surface (positive up) !!------------------------------------------------------------ associate(var=>var_meta(kVARS%longwave_up)) @@ -584,9 +815,30 @@ subroutine init_var_meta() !!------------------------------------------------------------ associate(var=>var_meta(kVARS%vegetation_fraction)) var%name = "vegetation_fraction" + var%dimensions = two_d_month_dimensions + var%attributes = [attribute_t("standard_name", "vegetation_area_fraction"), & + attribute_t("units", "m2 m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Annual Maximum Vegetation Fraction + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%vegetation_fraction_max)) + var%name = "vegetation_fraction_max" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "max_vegetation_area_fraction"), & + attribute_t("units", "m2 m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Noah-MP Output Vegetation Fraction + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%vegetation_fraction_out)) + var%name = "vegetation_fraction_out" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "vegetation_fraction"), & + var%attributes = [attribute_t("non_standard_name", "vegetation_fraction_out"), & attribute_t("units", "m2 m-2"), & attribute_t("coordinates", "lat lon")] end associate @@ -601,157 +853,1306 @@ subroutine init_var_meta() attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ + !! Leaf Mass + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%mass_leaf)) + var%name = "mass_leaf" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "leaf_mass"), & + attribute_t("units", "g m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Root Mass + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%mass_root)) + var%name = "mass_root" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "root_mass"), & + attribute_t("units", "g m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Stem Mass + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%mass_stem)) + var%name = "mass_stem" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "stem_mass"), & + attribute_t("units", "g m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Wood Mass + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%mass_wood)) + var%name = "mass_wood" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "wood_mass"), & + attribute_t("units", "g m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ !! Leaf Area Index !!------------------------------------------------------------ associate(var=>var_meta(kVARS%lai)) var%name = "lai" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("non_standard_name", "leaf_area_index"), & + var%attributes = [attribute_t("standard_name", "leaf_area_index"), & attribute_t("units", "m2 m-2"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Canopy Water Content + !! Stem Area Index !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%canopy_water)) - var%name = "canopy_water" + associate(var=>var_meta(kVARS%sai)) + var%name = "sai" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "canopy_water_amount"), & - attribute_t("units", "kg m-2"), & + var%attributes = [attribute_t("non_standard_name", "stem_area_index"), & + attribute_t("units", "m2 m-2"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Snow water equivalent on the surface + !! Planting Date !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%snow_water_equivalent)) - var%name = "swe" + associate(var=>var_meta(kVARS%date_planting)) + var%name = "date_planting" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "surface_snow_amount"), & - attribute_t("units", "kg m-2"), & + var%attributes = [attribute_t("non_standard_name", "planting_date"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Snow height + !! Harvesting Date !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%snow_height)) - var%name = "snow_height" + associate(var=>var_meta(kVARS%date_harvest)) + var%name = "date_harvest" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "surface_snow_height"), & - attribute_t("units", "m"), & + var%attributes = [attribute_t("non_standard_name", "harvest_date"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Soil water content + !! Crop Category !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%soil_water_content)) - var%name = "soil_water_content" - var%dimensions = three_d_t_soil_dimensions - var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "moisture_content_of_soil_layer"), & - attribute_t("units", "kg m-2"), & + associate(var=>var_meta(kVARS%crop_category)) + var%name = "crop_category" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "crop_category"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Total Column Soil water content + !! Crop Type (Noah-MP initialization variable) !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%soil_totalmoisture)) - var%name = "soil_column_total_water" - var%dimensions = two_d_t_dimensions - var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "soil_moisture_content"), & - attribute_t("units", "kg m-2"), & + associate(var=>var_meta(kVARS%crop_type)) + var%name = "crop_type" + var%dimensions = three_d_crop_dimensions + var%attributes = [attribute_t("non_standard_name", "crop_type"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Soil Temperature + !! Growing Season Growing Degree Days !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%soil_temperature)) - var%name = "soil_temperature" - var%dimensions = three_d_t_soil_dimensions + associate(var=>var_meta(kVARS%growing_season_gdd)) + var%name = "growing_season_gdd" + var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "soil_temperature"), & - attribute_t("units", "K"), & + var%attributes = [attribute_t("non_standard_name", "growing_season_gdd"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Deep Soil Temperature (time constant) + !! Irrigation Event Number, Sprinkler !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%soil_deep_temperature)) - var%name = "soil_deep_temperature" + associate(var=>var_meta(kVARS%irr_eventno_sprinkler)) + var%name = "irr_eventno_sprinkler" var%dimensions = two_d_t_dimensions - var%attributes = [attribute_t("non_standard_name", "deep_soil_temperature"), & - attribute_t("units", "K"), & + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_eventno_sprinkler"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Surface roughness length z0 + !! Irrigation Fraction !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%roughness_z0)) - var%name = "surface_roughness" + associate(var=>var_meta(kVARS%irr_frac_total)) + var%name = "irr_frac_total" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "surface_roughness_length"), & - attribute_t("long_name", "Surface roughness length"), & - attribute_t("units", "m"), & + var%attributes = [attribute_t("non_standard_name", "irr_frac_total"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! 2 meter air temperture + !! Irrigation Fraction, Sprinkler !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%temperature_2m)) - var%name = "ta2m" + associate(var=>var_meta(kVARS%irr_frac_sprinkler)) + var%name = "irr_frac_sprinkler" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "air_temperature"), & - attribute_t("long_name", "Bulk air temperature at 2m"), & - attribute_t("units", "K"), & + var%attributes = [attribute_t("non_standard_name", "irr_frac_sprinkler"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! 2 meter specific humidity + !! Irrigation Fraction, Micro !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%humidity_2m)) - var%name = "hus2m" + associate(var=>var_meta(kVARS%irr_frac_micro)) + var%name = "irr_frac_micro" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "specific_humidity"), & - attribute_t("units", "kg kg-2"), & + var%attributes = [attribute_t("non_standard_name", "irr_frac_micro"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! 10 meter height V component of wind field + !! Irrigation Fraction, Flood !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%v_10m)) - var%name = "v10m" + associate(var=>var_meta(kVARS%irr_frac_flood)) + var%name = "irr_frac_flood" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "northward_10m_wind_speed"), & - attribute_t("units", "m s-1"), & + var%attributes = [attribute_t("non_standard_name", "irr_frac_flood"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! 10 meter height U component of the wind field + !! Irrigation Event Number, Micro !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%u_10m)) - var%name = "u10m" + associate(var=>var_meta(kVARS%irr_eventno_micro)) + var%name = "irr_eventno_micro" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "eastward_10m_wind_speed"), & - attribute_t("units", "m s-1"), & + var%attributes = [attribute_t("non_standard_name", "irr_eventno_micro"), & + attribute_t("units", "1"), & attribute_t("coordinates", "lat lon")] end associate !>------------------------------------------------------------ - !! Land surface radiative skin temperature + !! Irrigation Event Number, Flood !!------------------------------------------------------------ - associate(var=>var_meta(kVARS%skin_temperature)) - var%name = "ts" + associate(var=>var_meta(kVARS%irr_eventno_flood)) + var%name = "irr_eventno_flood" var%dimensions = two_d_t_dimensions var%unlimited_dim=.True. - var%attributes = [attribute_t("standard_name", "surface_temperature"), & + var%attributes = [attribute_t("non_standard_name", "irr_eventno_flood"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Irrigation Water Amount to be Applied, Sprinkler + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%irr_alloc_sprinkler)) + var%name = "irr_alloc_sprinkler" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_alloc_sprinkler"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Irrigation Water Amount to be Applied, Micro + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%irr_alloc_micro)) + var%name = "irr_alloc_micro" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_alloc_micro"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Irrigation Water Amount to be Applied, Flood + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%irr_alloc_flood)) + var%name = "irr_alloc_flood" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_alloc_flood"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Loss of Sprinkler Irrigation Water to Evaporation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%irr_evap_loss_sprinkler)) + var%name = "irr_evap_loss_sprinkler" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_evap_loss_sprinkler"), & + attribute_t("units", "m timestep-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Amount of Irrigation, Sprinkler + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%irr_amt_sprinkler)) + var%name = "irr_amt_sprinkler" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_amt_sprinkler"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Amount of Irrigation, Micro + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%irr_amt_micro)) + var%name = "irr_amt_micro" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_amt_micro"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Amount of Irrigation, Flood + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%irr_amt_flood)) + var%name = "irr_amt_flood" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "irr_amt_flood"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Growing Season Growing Degree Days + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%growing_season_gdd)) + var%name = "growing_season_gdd" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "growing_season_gdd"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Mass of Agricultural Grain Produced + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%mass_ag_grain)) + var%name = "mass_ag_grain" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "mass_agricultural_grain"), & + attribute_t("units", "g m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Growing Degree Days (based on 10C) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%growing_degree_days)) + var%name = "growing_degree_days" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "growing_degree_days"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Plant Growth Stage + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%plant_growth_stage)) + var%name = "plant_growth_stage" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "plant_growth_stage"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Net Ecosystem Exchange + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%net_ecosystem_exchange)) + var%name = "net_ecosystem_exchange" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "net_ecosystem_exchange_expressed_as_carbon_dioxide"), & + attribute_t("units", "g m-2 s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Gross Primary Productivity + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%gross_primary_prod)) + var%name = "gross_primary_prod" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "gross_primary_productivity_of_biomass_expressed_as_carbon"), & + attribute_t("units", "g m-2 s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Net Primary Productivity + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%net_primary_prod)) + var%name = "net_primary_prod" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "net_primary_productivity_of_biomass_expressed_as_carbon"), & + attribute_t("units", "g m-2 s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Absorbed Photosynthetically Active Radiation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%apar)) + var%name = "apar" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "absorbed_photosynthetically_active_radiation"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Total Photosynthesis + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%photosynthesis_total)) + var%name = "photosynthesis_total" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "total_photosynthesis_expressed_as_carbon_dioxide"), & + attribute_t("units", "mmol m-2 s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Total Leaf Stomatal Resistance + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%stomatal_resist_total)) + var%name = "stomatal_resist_total" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "total_leaf_stomatal_resistance"), & + attribute_t("units", "s m-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sunlit Leaf Stomatal Resistance + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%stomatal_resist_sun)) + var%name = "stomatal_resist_sun" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "sunlif_leaf_stomatal_resistance"), & + attribute_t("units", "s m-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Shaded Leaf Stomatal Resistance + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%stomatal_resist_shade)) + var%name = "stomatal_resist_shade" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "shaded_leaf_stomatal_resistance"), & + attribute_t("units", "s m-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! GECROS (Genotype-by-Envrionment interaction on CROp growth Simulator [Yin and van Laar, 2005]) crop model state + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%gecros_state)) + var%name = "gecros_state" + var%dimensions = three_d_t_gecros_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "gecros_state"), & + attribute_t("units", "N/A"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Canopy Total Water Content + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%canopy_water)) + var%name = "canopy_water" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "canopy_water_amount"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Canopy Frozen Water Content + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%canopy_water_ice)) + var%name = "canopy_ice" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "canopy_snow_amount"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Canopy Liquid Water Content (in snow) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%canopy_water_liquid)) + var%name = "canopy_liquid" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "canopy_liquid_water_amount"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Canopy Air Vapor Pressure + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%canopy_vapor_pressure)) + var%name = "canopy_vapor_pressure" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "canopy_air_vapor_pressure"), & + attribute_t("units", "Pa"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Canopy Air Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%canopy_temperature)) + var%name = "canopy_temperature" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "canopy_air_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Canopy Wetted/Snowed Fraction + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%canopy_fwet)) + var%name = "canopy_fwet" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "canopy_wetted_fraction"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Vegetation Leaf Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%veg_leaf_temperature)) + var%name = "veg_leaf_temperature" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "veg_leaf_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Ground Surface Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ground_surf_temperature)) + var%name = "ground_surf_temperature" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ground_surface_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Between Gap Fraction + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%frac_between_gap)) + var%name = "frac_between_gap" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "between_gap_fraction"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Within Gap Fraction + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%frac_within_gap)) + var%name = "frac_within_gap" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "within_gap_fraction"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Under-Canopy Ground Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ground_temperature_canopy)) + var%name = "ground_temperature_canopy" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "under_canopy_ground_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Bare Ground Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ground_temperature_bare)) + var%name = "ground_temperature_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "bare_ground_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snowfall on the Ground + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snowfall_ground)) + var%name = "snowfall_ground" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ground_snow_rate"), & + attribute_t("units", "mm s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Rainfall on the Ground + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%rainfall_ground)) + var%name = "rainfall_ground" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ground_rain_rate"), & + attribute_t("units", "mm s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow water equivalent on the surface + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_water_equivalent)) + var%name = "swe" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_snow_amount"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow water equivalent from previous timestep + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_water_eq_prev)) + var%name = "swe_0" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "surface_snow_amount_prev"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow albedo from previous timestep + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_albedo_prev)) + var%name = "snow_albedo_0" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "snowpack_albedo_prev"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_temperature)) + var%name = "snow_temperature" + var%dimensions = three_d_t_snow_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "temperature_in_surface_snow"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow Layer Depth + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_layer_depth)) + var%name = "snow_layer_depth" + var%dimensions = three_d_t_snowsoil_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "snow_layer_depth"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow Layer Ice + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_layer_ice)) + var%name = "snow_layer_ice" + var%dimensions = three_d_t_snow_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "snow_layer_ice_content"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow Layer Liquid Water + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_layer_liquid_water)) + var%name = "snow_layer_liquid_water" + var%dimensions = three_d_t_snow_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "snow_layer_liquid_water_content"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow Age Factor + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_age_factor)) + var%name = "tau_ss" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "snow_age_factor"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Snow height + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_height)) + var%name = "snow_height" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_snow_height"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Number of Snowpack Layers + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snow_nlayers)) + var%name = "snow_nlayers" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "snow_nlayers"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil water content + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_water_content)) + var%name = "soil_water_content" + var%dimensions = three_d_t_soil_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "moisture_content_of_soil_layer"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Equilibrium Volumetric Soil Moisture + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%eq_soil_moisture)) + var%name = "eq_soil_moisture" + var%dimensions = three_d_t_soil_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "equilibrium_volumetric_soil_moisture"), & + attribute_t("units", "m3 m-3"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Moisture Content in the Layer Draining to Water Table when Deep + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%smc_watertable_deep)) + var%name = "smc_watertable_deep" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "soil_moisture_content_in_layer_to_water_table_when_deep"), & + attribute_t("units", "m3 m-3"), & !units not defined in noahmpdrv (guess) + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Groundwater Recharge + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%recharge)) + var%name = "recharge" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "groundwater_recharge"), & + attribute_t("units", "mm"), & !units not defined in noahmpdrv (guess) + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Groundwater Recharge when Water Table is Deep + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%recharge_deep)) + var%name = "recharge_deep" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "groundwater_recharge_deep"), & + attribute_t("units", "mm"), & !units not defined in noahmpdrv (guess) + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Canopy Evaporation Rate + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%evap_canopy)) + var%name = "evap_canopy" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "water_evaporation_flux_from_canopy"), & + attribute_t("units", "mm s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Surface Evaporation Rate + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%evap_soil_surface)) + var%name = "evap_soil_surface" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "water_evaporation_flux_from_soil"), & + attribute_t("units", "mm s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Transpiration Rate + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%transpiration_rate)) + var%name = "transpiration_rate" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "transpiration_rate"), & + attribute_t("units", "mm s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient, Vegetated + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ch_veg)) + var%name = "ch_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ch_vegetated"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient at 2m, Vegetated + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ch_veg_2m)) + var%name = "ch_veg_2m" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ch_vegetated_2m"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient, Bare + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ch_bare)) + var%name = "ch_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ch_bare_ground"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient at 2m, Bare + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ch_bare_2m)) + var%name = "ch_bare_2m" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ch_bare_2m"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient, Under Canopy + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ch_under_canopy)) + var%name = "ch_under_canopy" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ch_under_canopy"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient, Leaf + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ch_leaf)) + var%name = "ch_leaf" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ch_leaf"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Flux, Vegetated Ground (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%sensible_heat_veg)) + var%name = "sensible_heat_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "sensible_heat_veg"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Flux, Bare Ground (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%sensible_heat_bare)) + var%name = "sensible_heat_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "sensible_heat_bare"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Flux, Canopy (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%sensible_heat_canopy)) + var%name = "sensible_heat_canopy" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "sensible_heat_canopy"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Evaporation Heat Flux, Vegetated Ground (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%evap_heat_veg)) + var%name = "evap_heat_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "evap_heat_veg"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Evaporation Heat Flux, Bare Ground (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%evap_heat_bare)) + var%name = "evap_heat_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "evap_heat_bare"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Evaporation Heat Flux, Canopy (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%evap_heat_canopy)) + var%name = "evap_heat_canopy" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "evap_heat_canopy"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Transpiration Heat Flux (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%transpiration_heat)) + var%name = "transpiration_heat" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "transpiration_heat"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Ground Heat Flux, Vegetated Ground (+ to soil) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ground_heat_veg)) + var%name = "ground_heat_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ground_heat_veg"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Ground Heat Flux, Bare Ground (+ to soil) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ground_heat_bare)) + var%name = "ground_heat_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "ground_heat_bare"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Net Longwave Radiation Flux, Vegetated Ground (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%net_longwave_veg)) + var%name = "net_longwave_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "net_longwave_veg"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Net Longwave Radiation Flux, Bare Ground (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%net_longwave_bare)) + var%name = "net_longwave_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "net_longwave_bare"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Net Longwave Radiation Flux, Canopy (+ to atmosphere) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%net_longwave_canopy)) + var%name = "net_longwave_canopy" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "net_longwave_canopy"), & + attribute_t("units", "W m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Surface Runoff Rate + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%runoff_surface)) + var%name = "runoff_surface" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_runoff_flux"), & + attribute_t("units", "mm s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Subsurface Runoff Rate + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%runoff_subsurface)) + var%name = "runoff_subsurface" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "subsurface_runoff_flux"), & + attribute_t("units", "mm s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Total Column Soil water content + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_totalmoisture)) + var%name = "soil_column_total_water" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "soil_moisture_content"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_temperature)) + var%name = "soil_temperature" + var%dimensions = three_d_t_soil_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "soil_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Deep Soil Temperature (time constant) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_deep_temperature)) + var%name = "soil_deep_temperature" + var%dimensions = two_d_t_dimensions + var%attributes = [attribute_t("non_standard_name", "deep_soil_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Stable Carbon Mass in Deep Soil + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_carbon_stable)) + var%name = "soil_carbon_stable" + var%dimensions = two_d_t_dimensions + var%attributes = [attribute_t("standard_name", "slow_soil_pool_mass_content_of_carbon"), & + attribute_t("units", "g m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Short-lived Carbon Mass in Shallow Soil + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_carbon_fast)) + var%name = "soil_carbon_fast" + var%dimensions = two_d_t_dimensions + var%attributes = [attribute_t("standard_name", "fast_soil_pool_mass_content_of_carbon"), & + attribute_t("units", "g m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Class, Layer 1 + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_texture_1)) + var%name = "soil_class_1" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "soil_class_layer1"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Class, Layer 2 + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_texture_2)) + var%name = "soil_class_2" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "soil_class_layer2"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Class, Layer 3 + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_texture_3)) + var%name = "soil_class_3" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "soil_class_layer3"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Class, Layer 4 + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_texture_4)) + var%name = "soil_class_4" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("non_standard_name", "soil_class_layer4"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Soil Sand and Clay Composition by Layer + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%soil_sand_and_clay)) + var%name = "soil_sand_and_clay_composition" + var%dimensions = three_d_soilcomp_dimensions + var%attributes = [attribute_t("non_standard_name", "soil_sand_and_clay_composition"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Water Table Depth + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%water_table_depth)) + var%name = "water_table_depth" + var%dimensions = two_d_t_dimensions + var%attributes = [attribute_t("standard_name", "water_table_depth"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Water in Aquifer + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%water_aquifer)) + var%name = "water_aquifer" + var%dimensions = two_d_t_dimensions + var%attributes = [attribute_t("non_standard_name", "water_in_aquifer"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Groundwater Storage + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%storage_gw)) + var%name = "storage_gw" + var%dimensions = two_d_t_dimensions + var%attributes = [attribute_t("non_standard_name", "groundwater_storage"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake Storage + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%storage_lake)) + var%name = "storage_lake" + var%dimensions = two_d_t_dimensions + var%attributes = [attribute_t("non_standard_name", "lake_storage"), & + attribute_t("units", "mm"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Surface roughness length z0 + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%roughness_z0)) + var%name = "surface_roughness" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_roughness_length"), & + attribute_t("long_name", "Surface roughness length"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Surface Radiative Temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%surface_rad_temperature)) + var%name = "surface_rad_temperature" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_radiative_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 2 meter air temperture + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%temperature_2m)) + var%name = "ta2m" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "air_temperature"), & + attribute_t("long_name", "Bulk air temperature at 2m"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 2 meter Air Temperature over Vegetation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%temperature_2m_veg)) + var%name = "temperature_2m_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "air_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 2 meter Air Temperature over Bare Ground + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%temperature_2m_bare)) + var%name = "temperature_2m_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "air_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 2 meter Mixing Ratio over Vegetation + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%mixing_ratio_2m_veg)) + var%name = "mixing_ratio_2m_veg" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "mixing_ratio"), & + attribute_t("units", "kg kg-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 2 meter Mixing Ratio over Bare Ground + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%mixing_ratio_2m_bare)) + var%name = "mixing_ratio_2m_bare" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "mixing_ratio"), & + attribute_t("units", "kg kg-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 2 meter specific humidity + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%humidity_2m)) + var%name = "hus2m" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "specific_humidity"), & + attribute_t("units", "kg kg-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 10 meter height V component of wind field + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%v_10m)) + var%name = "v10m" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "northward_10m_wind_speed"), & + attribute_t("units", "m s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! 10 meter height U component of the wind field + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%u_10m)) + var%name = "u10m" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "eastward_10m_wind_speed"), & + attribute_t("units", "m s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Momentum Drag Coefficient + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%coeff_momentum_drag)) + var%name = "coeff_momentum_drag" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_drag_coefficient_for_momentum_in_air"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%coeff_heat_exchange)) + var%name = "coeff_heat_exchange" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "sensible_heat_exchange_coefficient"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Sensible Heat Exchange Coefficient 3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%coeff_heat_exchange_3d)) + var%name = "coeff_heat_exchange_3d" + var%dimensions = three_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "sensible_heat_exchange_coefficient_3d"), & + attribute_t("units", "1"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! PBL height + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%hpbl)) + var%name = "hpbl" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "height_of_planetary_boundary_layer"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! PBL layer index + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%kpbl)) + var%name = "kpbl" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "index_of_planetary_boundary_layer_height"), & + attribute_t("units", "-"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Land surface radiative skin temperature + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%skin_temperature)) + var%name = "ts" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "surface_temperature"), & attribute_t("units", "K"), & attribute_t("coordinates", "lat lon")] end associate @@ -777,6 +2178,286 @@ subroutine init_var_meta() attribute_t("units", "W m-2"), & attribute_t("coordinates", "lat lon")] end associate + !>------------------------------------------------------------ + !! Lake temperature 3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%t_lake3d)) + var%name = "t_lake3d" + var%dimensions = three_d_t_lake_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "lake_water_temperature"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake lake_icefraction_3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%lake_icefrac3d)) + var%name = "lake_icefrac3d" + var%dimensions = three_d_t_lake_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "lake_icefraction_3d"), & + attribute_t("units", "-"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake z_lake3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%z_lake3d)) + var%name = "z_lake3d" + var%dimensions = three_d_t_lake_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "lake_layer_depth"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake dz_lake3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%dz_lake3d)) + var%name = "dz_lake3d" + var%dimensions = three_d_t_lake_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "lake_layer_thickness"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! lake snl2d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%snl2d)) + var%name = "snl2d" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "lake_snow_layer_2d"), & + attribute_t("units", "-"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! lake_t_grnd2d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%t_grnd2d)) + var%name = "t_grnd2d" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "t_grnd2d"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake t_soisno3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%t_soisno3d)) + var%name = "t_soisno3d" + var%dimensions = three_d_t_lake_soisno_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "temperature_soil_snow_below_or_above_lake"), & + attribute_t("units", "K"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake h2osoi_ice3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%h2osoi_ice3d)) + var%name = "h2osoi_ice3d" + var%dimensions = three_d_t_lake_soisno_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "h2osoi_ice3d"), & + attribute_t("units", ""), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake soil/snowliquid water (kg/m2) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%h2osoi_liq3d)) + var%name = "h2osoi_liq3d" + var%dimensions = three_d_t_lake_soisno_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "lake_soil_or_snow_liquid water_content"), & + attribute_t("units", "kg/m2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake h2osoi_vol3d volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%h2osoi_vol3d)) + var%name = "h2osoi_vol3d" + var%dimensions = three_d_t_lake_soisno_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "volumetric_soil_water"), & + attribute_t("units", "m3/m3"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake z3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%z3d)) + var%name = "z3d" + var%dimensions = three_d_t_lake_soisno_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "layer_depth_for_lake_snow&soil"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake layer_thickness_for_lake_snow&soil + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%dz3d)) + var%name = "dz3d" + var%dimensions = three_d_t_lake_soisno_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "layer_thickness_for_lake_snow&soil"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake z3d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%zi3d)) + var%name = "zi3d" + var%dimensions = three_d_t_lake_soisno_1_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "interface_layer_depth_for_lake_snow&soil"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake watsat3d: volumetric soil water at saturation (porosity) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%watsat3d)) + var%name = "watsat3d" + var%dimensions = three_d_t_lake_soi_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "volumetric soil water at saturation (porosity)"), & + attribute_t("units", ""), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake csol3d: heat capacity, soil solids (J/m**3/Kelvin) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%csol3d)) + var%name = "csol3d" + var%dimensions = three_d_t_lake_soi_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "heat capacity, soil solids "), & + attribute_t("units", "(J/m**3/Kelvin)"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake: thermal conductivity, soil minerals [W/m-K] + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%tkmg3d)) + var%name = "tkmg3d" + var%dimensions = three_d_t_lake_soi_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "thermal conductivity, soil minerals [W/m-K]"), & + attribute_t("units", ""), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake lakemask + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%lakemask)) + var%name = "lakemask" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("standard_name", "lakemask"), & + attribute_t("units", ""), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake lakedepth2d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%lakedepth2d)) + var%name = "lakedepth2d" + var%dimensions = two_d_dimensions + var%attributes = [attribute_t("standard_name", "lake_depth"), & + attribute_t("units", "m"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! lake savedtke12d + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%savedtke12d)) + var%name = "savedtke12d" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "savedtke12d"), & + attribute_t("units", "-?"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake: thermal conductivity, saturated soil [W/m-K] + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%tksatu3d)) + var%name = "tksatu3d" + var%dimensions = three_d_t_lake_soi_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "thermal conductivity, saturated soil [W/m-K]"), & + attribute_t("units", ""), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ + !! Lake tkdry3d: thermal conductivity, dry soil (W/m/Kelvin) + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%tkdry3d)) + var%name = "tkdry3d" + var%dimensions = three_d_t_lake_soi_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "thermal conductivity, dry soil (W/m/Kelvin)"), & + attribute_t("units", "?"), & + attribute_t("coordinates", "lat lon")] + end associate + + + + !>------------------------------------------------------------ + !! Integrated Vapor Transport + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%ivt)) + var%name = "ivt" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "integrated_vapor_transport"), & + attribute_t("units", "kg m-1 s-1"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Integrated Water Vapor + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%iwv)) + var%name = "iwv" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "atmosphere_mass_content_of_water_vapor"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Integrated Water Liquid + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%iwl)) + var%name = "iwl" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("non_standard_name", "atmosphere_mass_content_of_water_liquid"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + + !>------------------------------------------------------------ + !! Integrated Water Ice + !!------------------------------------------------------------ + associate(var=>var_meta(kVARS%iwi)) + var%name = "iwi" + var%dimensions = two_d_t_dimensions + var%unlimited_dim=.True. + var%attributes = [attribute_t("standard_name", "atmosphere_mass_content_of_water_ice"), & + attribute_t("units", "kg m-2"), & + attribute_t("coordinates", "lat lon")] + end associate + !>------------------------------------------------------------ !! Binary land mask (water vs land) !!------------------------------------------------------------ diff --git a/src/io/io_routines.f90 b/src/io/io_routines.f90 index 963d100a..c4275362 100644 --- a/src/io/io_routines.f90 +++ b/src/io/io_routines.f90 @@ -16,6 +16,7 @@ !!------------------------------------------------------------ module io_routines use netcdf + use iso_fortran_env, only: real64, real128 implicit none ! maximum number of dimensions for a netCDF file @@ -27,7 +28,8 @@ module io_routines !! Generic interface to the netcdf read routines !!------------------------------------------------------------ interface io_read - module procedure io_read6d, io_read5d, io_read3d, io_read2d, io_read1d, io_read2di, io_read1dd, io_read_scalar_d + module procedure io_read6d, io_read5d, io_read4d, io_read3d, io_read2d, io_read1d, & + io_read2dd, io_read2di, io_read1dd, io_read_scalar_d, io_read0d, io_read0di end interface !>------------------------------------------------------------ @@ -103,8 +105,8 @@ end function io_variable_is_present !!------------------------------------------------------------ integer function io_nearest_time_step(filename, mjd) character(len=*),intent(in) :: filename - double precision, intent(in) :: mjd - double precision, allocatable, dimension(:) :: time_data + real(real128), intent(in) :: mjd + real(real64), allocatable, dimension(:) :: time_data integer :: ncid,varid,dims(1),ntimes,i call check(nf90_open(filename, NF90_NOWRITE, ncid),filename) @@ -295,6 +297,75 @@ subroutine io_read5d(filename,varname,data_in,extradim) end subroutine io_read5d + !>------------------------------------------------------------ + !! Same as io_read6d but for 4-dimensional data + !! + !! Reads in a variable from a netcdf file, allocating memory in data_in for it. + !! + !! if extradim is provided specifies this index for any extra dimensions (dims>3) + !! e.g. we may only want one time slice from a 3d variable + !! + !! @param filename Name of NetCDF file to look at + !! @param varname Name of the NetCDF variable to read + !! @param[out] data_in Allocatable 3-dimensional array to store output + !! @param extradim OPTIONAL: specify the position to read for any extra (e.g. time) dimension + !! @retval data_in Allocated 3-dimensional array with the netCDF data + !! + !!------------------------------------------------------------ + subroutine io_read4d(filename,varname,data_in,extradim) + implicit none + ! This is the name of the data_in file and variable we will read. + character(len=*), intent(in) :: filename, varname + real,intent(out),allocatable :: data_in(:,:,:,:) + integer, intent(in),optional :: extradim + integer, dimension(io_maxDims) :: diminfo !will hold dimension lengths + integer, dimension(io_maxDims) :: dimstart + ! This will be the netCDF ID for the file and data_in variable. + integer :: ncid, varid,i, err + real :: scale, offset + + if (present(extradim)) then + dimstart=extradim + dimstart(1:4)=1 + else + dimstart=1 + endif + + ! Read the dimension lengths + call io_getdims(filename,varname,diminfo) + + if (allocated(data_in)) deallocate(data_in) + allocate(data_in(diminfo(2),diminfo(3),diminfo(4),diminfo(5))) + + ! Open the file. NF90_NOWRITE tells netCDF we want read-only access to + ! the file. + call check(nf90_open(filename, NF90_NOWRITE, ncid),filename) + ! Get the varid of the data_in variable, based on its name. + call check(nf90_inq_varid(ncid, varname, varid),trim(filename)//":"//trim(varname)) + err = nf90_get_att(ncid,varid,'scale_factor', scale) + if (err/=0) scale=1 + err = nf90_get_att(ncid,varid,'add_offset', offset) + if (err/=0) offset=0 + + + ! Read the data_in. skip the slowest varying indices if there are more than 3 dimensions (typically this will be time) + if (diminfo(1)>4) then + diminfo(6:diminfo(1)+1)=1 ! set count for extra dims to 1 + call check(nf90_get_var(ncid, varid, data_in,& + dimstart(1:diminfo(1)), & ! start = 1 or extradim + [ (diminfo(i+1), i=1,diminfo(1)) ],& ! count=n or 1 created through an implied do loop + [ (1, i=1,diminfo(1)) ]),& ! for all dims, stride = 1 " implied do loop + trim(filename)//":"//trim(varname)) !pass file:var to check so it can give us more info + else + call check(nf90_get_var(ncid, varid, data_in),trim(filename)//":"//trim(varname)) + endif + + data_in = data_in * scale + offset + ! Close the file, freeing all resources. + call check( nf90_close(ncid),filename) + + end subroutine io_read4d + !>------------------------------------------------------------ !! Same as io_read6d but for 3-dimensional data !! @@ -436,6 +507,65 @@ subroutine io_read2d(filename,varname,data_in,extradim) end subroutine io_read2d + subroutine io_read2dd(filename,varname,data_in,extradim) + implicit none + ! This is the name of the data_in file and variable we will read. + character(len=*), intent(in) :: filename, varname + double precision,intent(out),allocatable :: data_in(:,:) + integer, intent(in),optional :: extradim + integer, dimension(io_maxDims) :: diminfo ! will hold dimension lengths + integer, dimension(io_maxDims) :: dimstart + ! This will be the netCDF ID for the file and data_in variable. + integer :: ncid, varid,i, err + real :: scale, offset + + if (present(extradim)) then + dimstart=extradim + dimstart(1:2)=1 + else + dimstart=1 + endif + + diminfo = 1 + ! Read the dimension lengths + call io_getdims(filename,varname,diminfo) + + if (allocated(data_in)) deallocate(data_in) + allocate(data_in(diminfo(2),diminfo(3))) + + ! Open the file. NF90_NOWRITE tells netCDF we want read-only access to + ! the file. + call check(nf90_open(filename, NF90_NOWRITE, ncid),filename) + ! Get the varid of the data_in variable, based on its name. + call check(nf90_inq_varid(ncid, varname, varid),trim(filename)//":"//trim(varname)) + err = nf90_get_att(ncid,varid,'scale_factor', scale) + if (err/=0) scale=1 + err = nf90_get_att(ncid,varid,'add_offset', offset) + if (err/=0) offset=0 + + + + ! Read the data_in. skip the slowest varying indices if there are more than 3 dimensions (typically this will be time) + if (diminfo(1)>2) then + diminfo(4:diminfo(1)+1)=1 ! set count for extra dims to 1 + call check(nf90_get_var(ncid, varid, data_in,& + dimstart(1:diminfo(1)), & ! start = 1 or extradim + [ (diminfo(i+1), i=1,diminfo(1)) ],& ! count=n or 1 created through an implied do loop + [ (1, i=1,diminfo(1)) ] ), & ! for all dims, stride = 1 " implied do loop + trim(filename)//":"//trim(varname)) !pass varname to check so it can give us more info + elseif (diminfo(1)==1) then + call check(nf90_get_var(ncid, varid, data_in(:,1)),trim(filename)//":"//trim(varname)) + else + call check(nf90_get_var(ncid, varid, data_in),trim(filename)//":"//trim(varname)) + endif + data_in = data_in * scale + offset + + ! Close the file, freeing all resources. + call check( nf90_close(ncid),filename) + + end subroutine io_read2dd + + !>------------------------------------------------------------ !! Same as io_read2d but for integer data !! @@ -560,8 +690,107 @@ subroutine io_read1d(filename,varname,data_in,extradim) end subroutine io_read1d +!>------------------------------------------------------------ + !! Same as io_read3d but for 0-dimensional data + !! + !! Reads in a variable from a netcdf file, allocating memory in data_in for it. + !! + !! if extradim is provided specifies this index for any extra dimensions (dims>1) + !! e.g. we may only want one time slice from a 1d variable + !! + !! @param filename Name of NetCDF file to look at + !! @param varname Name of the NetCDF variable to read + !! @param[out] data_in Allocatable 1-dimensional array to store output + !! @param extradim OPTIONAL: specify the position to read for any extra (e.g. time) dimension + !! @retval data_in Allocated 1-dimensional array with the netCDF data + !! + !!------------------------------------------------------------ + subroutine io_read0d(filename,varname,data_in,extradim) + implicit none + ! This is the name of the data_in file and variable we will read. + character(len=*), intent(in) :: filename, varname + real,intent(out) :: data_in + integer, intent(in),optional :: extradim + integer, dimension(io_maxDims) :: diminfo ! will hold dimension lengths + integer, dimension(io_maxDims) :: dimstart + ! This will be the netCDF ID for the file and data_in variable. + integer :: ncid, varid,i + + if (present(extradim)) then + dimstart=extradim + dimstart(1)=1 + else + dimstart=1 + endif + + ! Read the dimension lengths + call io_getdims(filename,varname,diminfo) + + ! Open the file. NF90_NOWRITE tells netCDF we want read-only access to + ! the file. + call check(nf90_open(filename, NF90_NOWRITE, ncid),filename) + ! Get the varid of the data_in variable, based on its name. + call check(nf90_inq_varid(ncid, varname, varid),trim(filename)//":"//trim(varname)) + + call check(nf90_get_var(ncid, varid, data_in),trim(filename)//":"//trim(varname)) + + ! Close the file, freeing all resources. + call check( nf90_close(ncid),filename) + + end subroutine io_read0d + +!>------------------------------------------------------------ + !! Same as io_read3d but for 0-dimensional integer + !! + !! Reads in a variable from a netcdf file, allocating memory in data_in for it. + !! + !! if extradim is provided specifies this index for any extra dimensions (dims>1) + !! e.g. we may only want one time slice from a 1d variable + !! + !! @param filename Name of NetCDF file to look at + !! @param varname Name of the NetCDF variable to read + !! @param[out] data_in Allocatable 1-dimensional array to store output + !! @param extradim OPTIONAL: specify the position to read for any extra (e.g. time) dimension + !! @retval data_in Allocated 1-dimensional array with the netCDF data + !! + !!------------------------------------------------------------ + subroutine io_read0di(filename,varname,data_in,extradim) + implicit none + ! This is the name of the data_in file and variable we will read. + character(len=*), intent(in) :: filename, varname + integer,intent(out) :: data_in + integer, intent(in),optional :: extradim + integer, dimension(io_maxDims) :: diminfo ! will hold dimension lengths + integer, dimension(io_maxDims) :: dimstart + ! This will be the netCDF ID for the file and data_in variable. + integer :: ncid, varid,i + + if (present(extradim)) then + dimstart=extradim + dimstart(1)=1 + else + dimstart=1 + endif + + ! Read the dimension lengths + call io_getdims(filename,varname,diminfo) + + + ! Open the file. NF90_NOWRITE tells netCDF we want read-only access to + ! the file. + call check(nf90_open(filename, NF90_NOWRITE, ncid),filename) + ! Get the varid of the data_in variable, based on its name. + call check(nf90_inq_varid(ncid, varname, varid),trim(filename)//":"//trim(varname)) + + call check(nf90_get_var(ncid, varid, data_in),trim(filename)//":"//trim(varname)) + + ! Close the file, freeing all resources. + call check( nf90_close(ncid),filename) + + end subroutine io_read0di + !>------------------------------------------------------------ - !! Same as io_read1d but for double precision data + !! Same as io_read1d but for real(real64) data !! !! Reads in a variable from a netcdf file, allocating memory in data_in for it. !! @@ -580,7 +809,7 @@ subroutine io_read1dd(filename, varname, data_in, extradim, curstep) implicit none ! This is the name of the data_in file and variable we will read. character(len=*), intent(in) :: filename, varname - double precision,intent(out),allocatable :: data_in(:) + real(real64),intent(out),allocatable :: data_in(:) integer, intent(in),optional :: extradim integer, intent(in),optional :: curstep integer, dimension(io_maxDims) :: diminfo ! will hold dimension lengths @@ -636,13 +865,13 @@ subroutine io_read1dd(filename, varname, data_in, extradim, curstep) end subroutine io_read1dd !>------------------------------------------------------------ - !! Read a double precision scalar + !! Read a real(real64) scalar !! !! Reads in a scalar variable from a netcdf file (primarily time). !! !! @param filename Name of NetCDF file to look at !! @param varname Name of the NetCDF variable to read - !! @param[out] result double precision scalar to store the data in + !! @param[out] result real(real64) scalar to store the data in !! @param step specify the position to read from a 1D array !! !!------------------------------------------------------------ @@ -650,10 +879,10 @@ subroutine io_read_scalar_d(filename, varname, result, step) implicit none ! This is the name of the data_in file and variable we will read. character(len=*), intent(in) :: filename, varname - double precision, intent(out) :: result + real(real64), intent(out) :: result integer, intent(in) :: step - double precision, allocatable :: data_in(:) + real(real64), allocatable :: data_in(:) ! This will be the netCDF ID for the file and data_in variable. integer :: ncid, varid,i diff --git a/src/io/output_h.f90 b/src/io/output_h.f90 index 88b0baa5..6cd55df4 100644 --- a/src/io/output_h.f90 +++ b/src/io/output_h.f90 @@ -58,6 +58,7 @@ module output_interface integer :: dim_ids(kMAX_DIMENSIONS) ! name of the dimensions in the file character(len=kMAX_DIM_LENGTH) :: dimensions(kMAX_DIMENSIONS) + character(len=kMAX_NAME_LENGTH) :: time_units contains diff --git a/src/io/output_obj.f90 b/src/io/output_obj.f90 index 61d595f8..d9828c09 100644 --- a/src/io/output_obj.f90 +++ b/src/io/output_obj.f90 @@ -1,6 +1,8 @@ submodule(output_interface) output_implementation - use output_metadata, only : get_metadata - implicit none + use icar_constants, only : kREAL, kDOUBLE + use output_metadata, only : get_metadata + use time_io, only : get_output_time + implicit none contains @@ -24,7 +26,7 @@ module subroutine add_to_output(this, variable) if (.not.this%is_initialized) call this%init() - if (associated(variable%data_2d).or.associated(variable%data_3d)) then + if (associated(variable%data_2d).or.associated(variable%data_2dd).or.associated(variable%data_3d)) then if (this%n_variables == size(this%variables)) call this%increase_var_capacity() @@ -97,10 +99,10 @@ module subroutine add_variables(this, var_list, domain) if (0 5) domain%rain_fraction = 5 + where(domain%rain_fraction < 0.2) domain%rain_fraction = 0.2 + domain%rain_fraction = 1 / domain%rain_fraction + endif + end subroutine setup_bias_correction ! ! subroutine init_domain_land(domain,options) ! implicit none diff --git a/src/main/time_step.f90 b/src/main/time_step.f90 index b7be103e..b52f0edf 100644 --- a/src/main/time_step.f90 +++ b/src/main/time_step.f90 @@ -12,11 +12,12 @@ module time_step use icar_constants, only : Rd use microphysics, only : mp use advection, only : advect - use mod_atm_utilities, only : exner_function + use mod_atm_utilities, only : exner_function, compute_ivt, compute_iq use convection, only : convect use land_surface, only : lsm use planetary_boundary_layer, only : pbl use radiation, only : rad + use wind, only : balance_uvw use domain_interface, only : domain_t use options_interface, only : options_t @@ -52,6 +53,7 @@ subroutine diagnostic_update(domain, options) integer :: z logical :: use_delta_terrain + real, allocatable :: temporary_data(:,:,:) associate(ims => domain%ims, ime => domain%ime, & jms => domain%jms, jme => domain%jme, & @@ -62,7 +64,14 @@ subroutine diagnostic_update(domain, options) dz_interface => domain%dz_interface%data_3d, & psfc => domain%surface_pressure%data_2d, & density => domain%density%data_3d, & + water_vapor => domain%water_vapor%data_3d, & + cloud_water => domain%cloud_water_mass%data_3d, & + rain_water => domain%rain_mass%data_3d, & + cloud_ice => domain%cloud_ice_mass%data_3d, & + snow_ice => domain%snow_mass%data_3d, & + graupel_ice => domain%graupel_mass%data_3d, & temperature => domain%temperature%data_3d, & + temperature_i => domain%temperature_interface%data_3d,& u => domain%u%data_3d, & v => domain%v%data_3d, & w => domain%w%data_3d, & @@ -71,8 +80,9 @@ subroutine diagnostic_update(domain, options) v_mass => domain%v_mass%data_3d, & potential_temperature => domain%potential_temperature%data_3d ) - exner = exner_function(pressure) + allocate(temporary_data(ims:ime, kms:kme, jms:jme)) + exner = exner_function(pressure) ! domain%p_inter=domain%p ! call update_pressure(domain%p_inter, domain%z, domain%z_inter, domain%t) pressure_i(:,kms+1:kme, :) = (pressure(:,kms:kme-1, :) + pressure(:,kms+1:kme, :)) / 2 @@ -84,6 +94,8 @@ subroutine diagnostic_update(domain, options) endif temperature = potential_temperature * exner + temperature_i(:,kms+1:kme, :) = (temperature(:,kms:kme-1, :) + temperature(:,kms+1:kme, :)) / 2 + temperature_i(:, kms, :) = temperature(:, kms, :) + (temperature(:, kms, :) - temperature(:, kms+1, :)) / 2 if (associated(domain%density%data_3d)) then density = pressure / & @@ -97,17 +109,6 @@ subroutine diagnostic_update(domain, options) endif - ! NOTE: all code below is not implemented in ICAR 2.0 yet - ! it is left as a reminder of what needs to be done, and example when the time comes - ! - ! ! update mut - ! - ! domain%p_inter=domain%p - ! call update_pressure(domain%p_inter, domain%z, domain%z_inter, domain%t) - ! domain%psfc = domain%p_inter(:,1,:) - ! ! technically this isn't correct, we should be using update_pressure or similar to solve this - ! domain%ptop = 2*domain%p(:,nz,:) - domain%p(:,nz-1,:) - ! ! ! dry mass in the gridcell is equivalent to the difference in pressure from top to bottom ! domain%mut(:,1:nz-1,:) = domain%p_inter(:,1:nz-1,:) - domain%p_inter(:,2:nz,:) ! domain%mut(:,nz,:) = domain%p_inter(:,nz,:) - domain%ptop @@ -119,6 +120,26 @@ subroutine diagnostic_update(domain, options) allocate( vw( ims+1:ime-1, jms+1:jme )) endif + if (associated(domain%ivt%data_2d)) then + call compute_ivt(domain%ivt%data_2d, water_vapor, u_mass, v_mass, pressure_i) + endif + if (associated(domain%iwv%data_2d)) then + call compute_iq(domain%iwv%data_2d, water_vapor, pressure_i) + endif + if (associated(domain%iwl%data_2d)) then + temporary_data = 0 + if (associated(domain%cloud_water_mass%data_3d)) temporary_data = temporary_data + cloud_water + if (associated(domain%rain_mass%data_3d)) temporary_data = temporary_data + rain_water + call compute_iq(domain%iwl%data_2d, temporary_data, pressure_i) + endif + if (associated(domain%iwi%data_2d)) then + temporary_data = 0 + if (associated(domain%cloud_ice_mass%data_3d)) temporary_data = temporary_data + cloud_ice + if (associated(domain%snow_mass%data_3d)) temporary_data = temporary_data + snow_ice + if (associated(domain%graupel_mass%data_3d)) temporary_data = temporary_data + graupel_ice + call compute_iq(domain%iwi%data_2d, temporary_data, pressure_i) + endif + ! temporary constant if (associated(domain%roughness_z0%data_2d)) then ! use log-law of the wall to convert from first model level to surface @@ -471,6 +492,18 @@ subroutine step(domain, end_time, options) if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" lsm") call pbl(domain, options, real(dt%seconds()))!, halo=1) + ! balance u/v and re-calculate dt after winds have been modified by pbl: + ! if (options%physics%boundarylayer==kPBL_YSU) then + ! call balance_uvw( domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, & + ! domain%jacobian_u, domain%jacobian_v, domain%jacobian_w, & + ! domain%advection_dz, domain%dx, domain%jacobian, options ) + ! + ! call update_dt(dt, options, domain, end_time) + ! + ! if ((domain%model_time + dt) > end_time) then + ! dt = end_time - domain%model_time + ! endif + ! endif if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" pbl") call convect(domain, options, real(dt%seconds()))!, halo=1) diff --git a/src/makefile b/src/makefile index 52ca6cdb..64ae5847 100644 --- a/src/makefile +++ b/src/makefile @@ -106,10 +106,16 @@ ifndef NETCDF NETCDF=${NETCDF_DIR} endif endif + NCDF_PATH = ${NETCDF} LIBNETCDF = -L$(NCDF_PATH)/lib -lnetcdff -lnetcdf INCNETCDF = -I$(NCDF_PATH)/include +ifdef NETCDFF + LIBNETCDF += -L$(NETCDFF)/lib + INCNETCDF += -I$(NETCDFF)/include +endif + USE_ASSERTIONS:=.false. ifeq ($(ASSERTIONS),) @@ -201,7 +207,7 @@ ifeq ($(MODE), debugslow) LINK= endif ifeq ($(COMPILER), gnu) - COMP= -c -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none + COMP= -c -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none -Wconversion LINK= endif ifeq ($(COMPILER), cray) @@ -217,7 +223,7 @@ ifeq ($(MODE), debug) LINK= endif ifeq ($(COMPILER), gnu) - COMP= -c -O2 -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none + COMP= -c -O2 -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none -Wconversion LINK= endif ifeq ($(COMPILER), cray) @@ -234,7 +240,7 @@ ifeq ($(MODE), debugompslow) LINK= -qopenmp -liomp5 endif ifeq ($(COMPILER), gnu) - COMP= -fopenmp -lgomp -c -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none -ffpe-trap=invalid + COMP= -fopenmp -lgomp -c -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none -ffpe-trap=invalid -Wconversion LINK= -fopenmp -lgomp endif ifeq ($(COMPILER), cray) @@ -250,7 +256,7 @@ ifeq ($(MODE), debugomp) LINK= -qopenmp -liomp5 endif ifeq ($(COMPILER), gnu) - COMP= -fopenmp -lgomp -c -O2 -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none -fimplicit-none # -ftree-vectorize -funroll-loops -march=native -fno-protect-parens + COMP= -fopenmp -lgomp -c -O2 -g -fbounds-check -fbacktrace -finit-real=nan -ffree-line-length-none -fimplicit-none -Wconversion # -ftree-vectorize -funroll-loops -march=native -fno-protect-parens LINK= -fopenmp -lgomp # -Wall -Wno-unused-variable -Wno-unused-dummy-argument endif @@ -338,7 +344,7 @@ OBJS= \ $(BUILD)time_step.o \ $(BUILD)debug_utils.o \ $(BUILD)icar_constants.o \ - $(BUILD)wrf_constants.o \ + $(BUILD)wrf_constants.o \ $(BUILD)model_tracking.o \ $(BUILD)string.o \ $(BUILD)time_delta_obj.o \ @@ -368,6 +374,7 @@ OBJS= \ $(BUILD)boundary_obj.o \ $(BUILD)assertions.o \ $(BUILD)atm_utilities.o \ + $(BUILD)pbl_utilities.o \ $(BUILD)co_utilities.o \ $(BUILD)default_output_metadata.o\ $(BUILD)output_h.o \ @@ -379,22 +386,34 @@ OBJS= \ $(BUILD)lt_lut_io.o \ $(BUILD)pbl_driver.o \ $(BUILD)pbl_simple.o \ + $(BUILD)pbl_ysu.o \ $(BUILD)ra_driver.o \ $(BUILD)ra_simple.o \ + $(BUILD)ra_rrtmg_lw.o \ + $(BUILD)ra_rrtmg_sw.o \ + $(BUILD)ra_clWRF_support.o \ $(BUILD)mp_driver.o \ $(BUILD)mp_simple.o \ $(BUILD)mp_thompson.o \ $(BUILD)mp_thompson_aer.o \ - $(BUILD)mp_wsm6.o \ + $(BUILD)mp_wsm6.o \ + $(BUILD)mp_wsm3.o \ $(BUILD)cu_driver.o \ $(BUILD)cu_tiedtke.o \ + $(BUILD)cu_nsas.o \ + $(BUILD)cu_bmj.o \ $(BUILD)advection_driver.o \ $(BUILD)advect.o \ - $(BUILD)adv_mpdata.o \ + $(BUILD)adv_mpdata.o \ $(BUILD)lsm_driver.o \ $(BUILD)lsm_noahdrv.o \ $(BUILD)lsm_noahlsm.o \ + $(BUILD)lsm_noahmpdrv.o \ + $(BUILD)lsm_noahmplsm.o \ + $(BUILD)lsm_noahmp_glacier.o \ + $(BUILD)lsm_noahmp_gecros.o \ $(BUILD)water_simple.o \ + $(BUILD)water_lake.o \ $(BUILD)geo_reader.o \ $(BUILD)io_routines.o \ $(BUILD)data_structures.o \ @@ -416,11 +435,12 @@ CAF_TEST_EXECUTABLES = caf_options_test \ TEST_EXECUTABLES= fftshift_test \ calendar_test \ - fftw_test \ + fftw_test \ point_in_on_test \ array_util_test \ variable_dict_test \ caf_threads_test \ + time_obj_test \ $(CAF_TEST_EXECUTABLES) # Pre-Coarray Tests that we may want to re-implement @@ -469,7 +489,10 @@ fftw_test: $(BUILD)test_fftw.o $(OBJS) fftshift_test: $(BUILD)test_fftshift.o $(OBJS) ${LINKER} $^ -o $@ ${LFLAGS} -calendar_test: $(BUILD)test_calendar.o $(BUILD)time.o +time_obj_test: $(BUILD)test_time_obj.o $(BUILD)time_obj.o $(BUILD)time_h.o $(BUILD)time_delta_obj.o $(BUILD)co_utilities.o + ${LINKER} $^ -o $@ ${LFLAGS} + +calendar_test: $(BUILD)test_calendar.o $(BUILD)time_obj.o $(BUILD)time_h.o $(BUILD)time_delta_obj.o $(BUILD)co_utilities.o ${LINKER} $^ -o $@ ${LFLAGS} mpdata_test: $(BUILD)test_mpdata.o $(BUILD)adv_mpdata.o @@ -516,19 +539,22 @@ caf_no_forcing_test: $(BUILD)test_caf_no_forcing.o \ $(BUILD)exchangeable_h.o $(BUILD)exchangeable_obj.o \ $(BUILD)icar_constants.o $(BUILD)io_routines.o \ $(BUILD)model_tracking.o $(BUILD)string.o \ - $(BUILD)assertions.o $(BUILD)atm_utilities.o \ + $(BUILD)assertions.o $(BUILD)atm_utilities.o \ $(BUILD)pbl_utilities.o \ $(BUILD)co_utilities.o $(BUILD)default_output_metadata.o \ $(BUILD)ra_driver.o $(BUILD)ra_simple.o \ - $(BUILD)pbl_driver.o $(BUILD)pbl_simple.o \ + $(BUILD)pbl_driver.o $(BUILD)pbl_simple.o $(BUILD)pbl_ysu.o \ $(BUILD)mp_driver.o $(BUILD)mp_simple.o \ - $(BUILD)mp_thompson.o $(BUILD)mp_thompson_aer.o $(BUILD)mp_wsm6.o\ - $(BUILD)cu_driver.o $(BUILD)cu_tiedtke.o \ + $(BUILD)mp_thompson.o $(BUILD)mp_thompson_aer.o \ + $(BUILD)mp_wsm6.o $(BUILD)mp_wsm3.o \ + $(BUILD)cu_driver.o $(BUILD)cu_tiedtke.o \ + $(BUILD)cu_nsas.o $(BUILD)cu_bmj.o \ $(BUILD)advection_driver.o $(BUILD)geo_reader.o \ $(BUILD)advect.o $(BUILD)data_structures.o \ $(BUILD)vinterp.o $(BUILD)array_utilities.o \ $(BUILD)lsm_driver.o \ $(BUILD)lsm_noahdrv.o $(BUILD)lsm_noahlsm.o \ - $(BUILD)water_simple.o + $(BUILD)lsm_noahmpdrv.o $(BUILD)lsm_noahmplsm.o \ + $(BUILD)water_simple.o $(BUILD)water_lake.o ${LINKER} $^ -o $@ ${LFLAGS} caf_domain_init_test: $(BUILD)test_caf_domain_init.o $(OBJS) @@ -688,8 +714,6 @@ $(BUILD)time_step.o:$(MAIN)time_step.f90 $(BUILD)data_structures.o $(BUILD)wind. # Utility Routines ################################################################### -# $(BUILD)time.o:$(UTIL)time.f90 - $(BUILD)co_utilities.o:$(UTIL)co_utilities.f90 $(BUILD)icar_constants.o $(BUILD)time_delta_obj.o:$(UTIL)time_delta_obj.f90 $(BUILD)icar_constants.o @@ -710,15 +734,17 @@ $(BUILD)string.o:$(UTIL)string.f90 $(BUILD)array_utilities.o:$(UTIL)array_utilities.f90 $(BUILD)atm_utilities.o:$(UTIL)atm_utilities.f90 $(BUILD)icar_constants.o \ - $(BUILD)data_structures.o $(BUILD)options_h.o + $(BUILD)data_structures.o $(BUILD)options_h.o $(BUILD)mp_thompson.o \ + $(BUILD)opt_types.o + +$(BUILD)pbl_utilities.o:$(UTIL)pbl_utilities.f90 $(BUILD)icar_constants.o \ + $(BUILD)data_structures.o ################################################################### # I/O routines ################################################################### -$(BUILD)output.o:$(IO)output.f90 $(BUILD)data_structures.o $(BUILD)io_routines.o $(BUILD)time.o $(BUILD)string.o - $(BUILD)io_routines.o:$(IO)io_routines.f90 $(BUILD)data_structures.o $(BUILD)lt_lut_io.o: $(IO)lt_lut_io.f90 $(BUILD)data_structures.o $(BUILD)io_routines.o \ @@ -736,16 +762,15 @@ $(BUILD)vinterp.o: $(UTIL)vinterp.f90 $(BUILD)data_structures.o ################################################################### # Microphysics code ################################################################### -$(BUILD)mp_driver.o:$(PHYS)mp_driver.f90 $(BUILD)mp_simple.o $(BUILD)mp_thompson_aer.o $(BUILD)mp_thompson.o $(BUILD)mp_wsm6.o\ - $(BUILD)data_structures.o $(BUILD)time.o $(BUILD)domain_h.o $(BUILD)icar_constants.o\ +$(BUILD)mp_driver.o:$(PHYS)mp_driver.f90 $(BUILD)mp_simple.o $(BUILD)mp_thompson_aer.o $(BUILD)mp_thompson.o \ + $(BUILD)mp_wsm6.o $(BUILD)mp_wsm3.o \ + $(BUILD)data_structures.o $(BUILD)domain_h.o $(BUILD)icar_constants.o\ $(BUILD)wrf_constants.o -# $(BUILD)mp_driver.o:$(PHYS)mp_driver.f90 $(BUILD)mp_thompson.o $(BUILD)mp_simple.o \ -# $(BUILD)mp_morrison.o $(BUILD)data_structures.o $(BUILD)mp_wsm6.o $(BUILD)time.o -# ${F90} ${FFLAGS} $(PHYS)mp_driver.f90 -o $(BUILD)mp_driver.o - $(BUILD)mp_morrison.o:$(PHYS)mp_morrison.f90 $(BUILD)data_structures.o +$(BUILD)mp_wsm3.o:$(PHYS)mp_wsm3.f90 $(BUILD)wrf_constants.o + $(BUILD)mp_wsm6.o:$(PHYS)mp_wsm6.f90 $(BUILD)wrf_constants.o $(BUILD)mp_thompson.o:$(PHYS)mp_thompson.f90 $(BUILD)opt_types.o @@ -757,34 +782,48 @@ $(BUILD)mp_simple.o:$(PHYS)mp_simple.f90 $(BUILD)data_structures.o $(BUILD)optio ################################################################### # Convection code ################################################################### -$(BUILD)cu_driver.o:$(PHYS)cu_driver.f90 $(BUILD)cu_tiedtke.o \ +$(BUILD)cu_driver.o:$(PHYS)cu_driver.f90 $(BUILD)cu_tiedtke.o $(BUILD)cu_nsas.o $(BUILD)cu_bmj.o \ $(BUILD)data_structures.o $(BUILD)icar_constants.o $(BUILD)domain_h.o $(BUILD)cu_tiedtke.o:$(PHYS)cu_tiedtke.f90 $(BUILD)cu_kf.o:$(PHYS)cu_kf.f90 +$(BUILD)cu_nsas.o:$(PHYS)cu_nsas.f90 + +$(BUILD)cu_bmj.o:$(PHYS)cu_bmj.f90 + ################################################################### # Radiation code ################################################################### -$(BUILD)ra_driver.o:$(PHYS)ra_driver.f90 $(BUILD)ra_simple.o $(BUILD)data_structures.o $(BUILD)icar_constants.o $(BUILD)options_h.o $(BUILD)domain_h.o +$(BUILD)ra_driver.o:$(PHYS)ra_driver.f90 $(BUILD)ra_simple.o $(BUILD)ra_rrtmg_lw.o $(BUILD)ra_rrtmg_sw.o $(BUILD)data_structures.o $(BUILD)icar_constants.o $(BUILD)options_h.o $(BUILD)domain_h.o + +$(BUILD)ra_rrtmg_lw.o:$(PHYS)ra_rrtmg_lw.f90 $(BUILD)ra_clWRF_support.o $(BUILD)io_routines.o + +$(BUILD)ra_rrtmg_sw.o:$(PHYS)ra_rrtmg_sw.f90 $(BUILD)ra_clWRF_support.o $(BUILD)io_routines.o $(BUILD)ra_rrtmg_lw.o + +$(BUILD)ra_clWRF_support.o:$(PHYS)ra_clWRF_support.f90 $(BUILD)io_routines.o -$(BUILD)ra_simple.o:$(PHYS)ra_simple.f90 $(BUILD)data_structures.o $(BUILD)time.o $(BUILD)atm_utilities.o $(BUILD)options_h.o $(BUILD)domain_h.o +$(BUILD)ra_simple.o:$(PHYS)ra_simple.f90 $(BUILD)data_structures.o $(BUILD)atm_utilities.o $(BUILD)options_h.o $(BUILD)domain_h.o ################################################################### # Surface code ################################################################### -$(BUILD)lsm_driver.o: $(PHYS)lsm_driver.f90 $(BUILD)data_structures.o \ - $(BUILD)lsm_noahdrv.o $(BUILD)lsm_noahlsm.o \ - $(BUILD)water_simple.o $(BUILD)icar_constants.o \ +$(BUILD)lsm_driver.o: $(PHYS)lsm_driver.f90 $(BUILD)data_structures.o \ + $(BUILD)lsm_noahdrv.o $(BUILD)lsm_noahlsm.o \ + $(BUILD)lsm_noahmpdrv.o $(BUILD)lsm_noahmplsm.o \ + $(BUILD)water_simple.o $(BUILD)water_lake.o \ $(BUILD)domain_h.o $(BUILD)options_h.o \ - $(BUILD)atm_utilities.o + $(BUILD)atm_utilities.o $(BUILD)ra_simple.o \ + $(BUILD)opt_types.o $(BUILD)icar_constants.o # $(BUILD)lsm_basic.o $(BUILD)lsm_simple.o $(BUILD)water_simple.o: $(PHYS)water_simple.f90 $(BUILD)data_structures.o +$(BUILD)water_lake.o: $(PHYS)water_lake.f90 $(BUILD)data_structures.o + $(BUILD)lsm_simple.o: $(PHYS)lsm_simple.f90 $(BUILD)data_structures.o $(BUILD)lsm_basic.o: $(PHYS)lsm_basic.f90 $(BUILD)data_structures.o @@ -793,11 +832,21 @@ $(BUILD)lsm_noahdrv.o: $(PHYS)lsm_noahdrv.f90 $(BUILD)lsm_noahlsm.o $(BUILD)lsm_noahlsm.o: $(PHYS)lsm_noahlsm.f90 +$(BUILD)lsm_noahmpdrv.o: $(PHYS)lsm_noahmpdrv.f90 $(BUILD)lsm_noahmplsm.o \ + $(BUILD)lsm_noahmp_gecros.o $(BUILD)lsm_noahmp_glacier.o + +$(BUILD)lsm_noahmplsm.o: $(PHYS)lsm_noahmplsm.f90 $(BUILD)lsm_noahmp_gecros.o \ + $(BUILD)lsm_noahmp_glacier.o + +$(BUILD)lsm_noahmp_gecros.o: $(PHYS)lsm_noahmp_gecros.f90 + +$(BUILD)lsm_noahmp_glacier.o: $(PHYS)lsm_noahmp_glacier.f90 ################################################################### # Planetary Boundary Layer code ################################################################### -$(BUILD)pbl_driver.o: $(PHYS)pbl_driver.f90 $(BUILD)pbl_simple.o $(BUILD)domain_h.o $(BUILD)options_h.o $(BUILD)data_structures.o +$(BUILD)pbl_driver.o: $(PHYS)pbl_driver.f90 $(BUILD)pbl_simple.o $(BUILD)pbl_ysu.o $(BUILD)domain_h.o \ + $(BUILD)options_h.o $(BUILD)lsm_driver.o $(BUILD)data_structures.o $(BUILD)atm_utilities.o $(BUILD)pbl_utilities.o $(BUILD)pbl_simple.o: $(PHYS)pbl_simple.f90 $(BUILD)domain_h.o $(BUILD)options_h.o $(BUILD)data_structures.o @@ -900,7 +949,7 @@ $(BUILD)test_fftw.o: $(TESTS)test_fftw.f90 $(BUILD)fftw.o $(BUILD)test_fftshift.o:$(TESTS)test_fftshift.f90 $(BUILD)fftshift.o -$(BUILD)test_calendar.o:$(TESTS)test_calendar.f90 $(BUILD)time.o +$(BUILD)test_calendar.o:$(TESTS)test_calendar.f90 $(BUILD)time_obj.o $(BUILD)time_h.o $(BUILD)time_delta_obj.o $(BUILD)test_point_in_on.o:$(TESTS)test_point_in_on.f90 $(BUILD)geo_reader.o diff --git a/src/objects/boundary_obj.f90 b/src/objects/boundary_obj.f90 index edbc4255..8ae2091a 100644 --- a/src/objects/boundary_obj.f90 +++ b/src/objects/boundary_obj.f90 @@ -570,7 +570,12 @@ subroutine compute_mixing_ratio_from_rh(list, options) qvar%data_3d = qvar%data_3d/100.0 endif - qvar%data_3d = rh_to_mr(qvar%data_3d, tvar%data_3d, pvar%data_3d) + if (options%parameters%t_is_potential) then + qvar%data_3d = rh_to_mr(qvar%data_3d, tvar%data_3d * exner_function(pvar%data_3d), pvar%data_3d) + else + qvar%data_3d = rh_to_mr(qvar%data_3d, tvar%data_3d, pvar%data_3d) + endif + end subroutine compute_mixing_ratio_from_rh diff --git a/src/objects/domain_h.f90 b/src/objects/domain_h.f90 index d16b7f57..6f6ff199 100644 --- a/src/objects/domain_h.f90 +++ b/src/objects/domain_h.f90 @@ -21,6 +21,9 @@ module domain_interface type(grid_t) :: grid2d, u_grid2d, v_grid2d type(grid_t) :: u_grid2d_ext, v_grid2d_ext!, grid2d_ext ! extended grids for u and v fields pre smoothing (grid_2d_ext is for SLEVE topography smoothing) type(grid_t) :: grid_monthly, grid_soil + type(grid_t) :: grid_snow, grid_snowsoil + type(grid_t) :: grid_soilcomp, grid_gecros, grid_croptype + type(grid_t) :: grid_lake , grid_lake_soisno, grid_lake_soi, grid_lake_soisno_1 type(Time_type) :: model_time @@ -63,37 +66,193 @@ module domain_interface type(variable_t) :: accumulated_convective_pcp integer,allocatable :: cu_precipitation_bucket(:,:) type(variable_t) :: accumulated_snowfall + type(variable_t) :: precip_in_total + type(variable_t) :: snowfall_ground + type(variable_t) :: rainfall_ground integer,allocatable :: snowfall_bucket(:,:) + type(variable_t) :: external_precipitation type(variable_t) :: cloud_fraction type(variable_t) :: longwave type(variable_t) :: shortwave + type(variable_t) :: shortwave_direct + type(variable_t) :: shortwave_diffuse type(variable_t) :: terrain type(variable_t) :: forcing_terrain ! BK 05/2020: The forcing terrain interpolated 2d to the hi-res grid. In order to calculate difference in slope - type(variable_t) :: forcing_terrain2 ! test 9-6-2020 - ! type(variable_t) :: forcing_terrain_u1 ! test 9-6-2020 + type(variable_t) :: forcing_terrain2 ! test 9-6-2020 type(variable_t) :: u_10m type(variable_t) :: v_10m + type(variable_t) :: coeff_momentum_drag + type(variable_t) :: coeff_heat_exchange + type(variable_t) :: coeff_heat_exchange_3d ! used in YSU pbl + integer,allocatable :: kpbl(:,:) ! used in YSU pbl / BMJ cu + type(variable_t) :: hpbl ! used in YSU pbl /NSAS cu + type(variable_t) :: surface_rad_temperature type(variable_t) :: temperature_2m type(variable_t) :: humidity_2m + type(variable_t) :: temperature_2m_veg + type(variable_t) :: temperature_2m_bare + type(variable_t) :: mixing_ratio_2m_veg + type(variable_t) :: mixing_ratio_2m_bare type(variable_t) :: surface_pressure + type(variable_t) :: rad_absorbed_total + type(variable_t) :: rad_absorbed_veg + type(variable_t) :: rad_absorbed_bare + type(variable_t) :: rad_net_longwave type(variable_t) :: longwave_up type(variable_t) :: ground_heat_flux type(variable_t) :: sensible_heat type(variable_t) :: latent_heat integer,allocatable :: veg_type(:,:) + type(variable_t) :: mass_leaf + type(variable_t) :: mass_root + type(variable_t) :: mass_stem + type(variable_t) :: mass_wood integer,allocatable :: soil_type(:,:) + type(variable_t) :: soil_texture_1 + type(variable_t) :: soil_texture_2 + type(variable_t) :: soil_texture_3 + type(variable_t) :: soil_texture_4 + type(variable_t) :: soil_sand_and_clay + type(variable_t) :: soil_carbon_stable + type(variable_t) :: soil_carbon_fast type(variable_t) :: roughness_z0 + type(variable_t) :: albedo type(variable_t) :: vegetation_fraction + type(variable_t) :: vegetation_fraction_max + type(variable_t) :: vegetation_fraction_out type(variable_t) :: lai + type(variable_t) :: sai + integer,allocatable :: crop_category(:,:) + type(variable_t) :: crop_type + type(variable_t) :: date_planting + type(variable_t) :: date_harvest + type(variable_t) :: growing_season_gdd + type(variable_t) :: irr_frac_total + type(variable_t) :: irr_frac_sprinkler + type(variable_t) :: irr_frac_micro + type(variable_t) :: irr_frac_flood + integer,allocatable :: irr_eventno_sprinkler(:,:) + integer,allocatable :: irr_eventno_micro(:,:) + integer,allocatable :: irr_eventno_flood(:,:) + type(variable_t) :: irr_alloc_sprinkler + type(variable_t) :: irr_alloc_micro + type(variable_t) :: irr_alloc_flood + type(variable_t) :: irr_evap_loss_sprinkler + type(variable_t) :: irr_amt_sprinkler + type(variable_t) :: irr_amt_micro + type(variable_t) :: irr_amt_flood + type(variable_t) :: evap_heat_sprinkler + type(variable_t) :: mass_ag_grain + type(variable_t) :: growing_degree_days + integer,allocatable :: plant_growth_stage(:,:) + type(variable_t) :: net_ecosystem_exchange + type(variable_t) :: gross_primary_prod + type(variable_t) :: net_primary_prod + type(variable_t) :: apar + type(variable_t) :: photosynthesis_total + type(variable_t) :: stomatal_resist_total + type(variable_t) :: stomatal_resist_sun + type(variable_t) :: stomatal_resist_shade + type(variable_t) :: gecros_state type(variable_t) :: canopy_water + type(variable_t) :: canopy_water_ice + type(variable_t) :: canopy_water_liquid + type(variable_t) :: canopy_vapor_pressure + type(variable_t) :: canopy_temperature + type(variable_t) :: canopy_fwet + type(variable_t) :: veg_leaf_temperature + type(variable_t) :: ground_surf_temperature + type(variable_t) :: frac_between_gap + type(variable_t) :: frac_within_gap + type(variable_t) :: ground_temperature_bare + type(variable_t) :: ground_temperature_canopy type(variable_t) :: snow_water_equivalent + type(variable_t) :: snow_water_eq_prev + type(variable_t) :: snow_albedo_prev + type(variable_t) :: snow_temperature + type(variable_t) :: snow_layer_depth + type(variable_t) :: snow_layer_ice + type(variable_t) :: snow_layer_liquid_water + type(variable_t) :: snow_age_factor type(variable_t) :: snow_height + integer,allocatable :: snow_nlayers(:,:) type(variable_t) :: skin_temperature type(variable_t) :: sst type(variable_t) :: soil_water_content + type(variable_t) :: eq_soil_moisture + type(variable_t) :: smc_watertable_deep + type(variable_t) :: recharge + type(variable_t) :: recharge_deep type(variable_t) :: soil_temperature + type(variable_t) :: runoff_subsurface + type(variable_t) :: runoff_surface + type(variable_t) :: evap_canopy + type(variable_t) :: evap_soil_surface + type(variable_t) :: transpiration_rate + type(variable_t) :: ch_veg + type(variable_t) :: ch_veg_2m + type(variable_t) :: ch_bare + type(variable_t) :: ch_bare_2m + type(variable_t) :: ch_under_canopy + type(variable_t) :: ch_leaf + type(variable_t) :: sensible_heat_veg + type(variable_t) :: sensible_heat_bare + type(variable_t) :: sensible_heat_canopy + type(variable_t) :: evap_heat_veg + type(variable_t) :: evap_heat_bare + type(variable_t) :: evap_heat_canopy + type(variable_t) :: transpiration_heat + type(variable_t) :: ground_heat_veg + type(variable_t) :: ground_heat_bare + type(variable_t) :: net_longwave_veg + type(variable_t) :: net_longwave_bare + type(variable_t) :: net_longwave_canopy type(variable_t) :: soil_totalmoisture type(variable_t) :: soil_deep_temperature + type(variable_t) :: water_table_depth + type(variable_t) :: water_aquifer + type(variable_t) :: storage_gw + type(variable_t) :: storage_lake + ! lake model vars: + type(variable_t) :: lake_depth + type(variable_t) :: t_lake3d + type(variable_t) :: snl2d + type(variable_t) :: t_grnd2d + type(variable_t) :: lake_icefrac3d + type(variable_t) :: z_lake3d + type(variable_t) :: dz_lake3d + type(variable_t) :: t_soisno3d + type(variable_t) :: h2osoi_ice3d + type(variable_t) :: h2osoi_liq3d! liquid water (kg/m2) + type(variable_t) :: h2osoi_vol3d! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + type(variable_t) :: z3d ! layer depth for snow & soil (m) + type(variable_t) :: dz3d + type(variable_t) :: watsat3d + type(variable_t) :: csol3d + type(variable_t) :: tkmg3d + type(variable_t) :: lakemask + type(variable_t) :: tksatu3d + type(variable_t) :: tkdry3d + type(variable_t) :: zi3d + type(variable_t) :: savedtke12d + type(variable_t) :: lakedepth2d + ! diagnostics + type(variable_t) :: ivt + type(variable_t) :: iwv + type(variable_t) :: iwl + type(variable_t) :: iwi + + ! link effective radius from microphysics to radiation scheme + type(variable_t) :: re_cloud + type(variable_t) :: re_ice + type(variable_t) :: re_snow + type(variable_t) :: out_longwave_rad + type(variable_t) :: longwave_cloud_forcing + type(variable_t) :: shortwave_cloud_forcing + type(variable_t) :: land_emissivity + type(variable_t) :: temperature_interface + type(variable_t) :: cosine_zenith_angle + type(variable_t) :: tend_swrad integer,allocatable :: land_mask(:,:) type(variable_t) :: latitude @@ -122,6 +281,7 @@ module domain_interface double precision, allocatable :: costheta(:,:) double precision, allocatable :: sintheta(:,:) real, allocatable :: advection_dz(:,:,:) + real, allocatable :: rain_fraction(:,:,:) ! monthly varying fraction to multiple precipitation [-] ! store the ratio between the average dz and each grid cells topographically modified dz (for space varying dz only) real, allocatable :: jacobian(:,:,:) real, allocatable :: jacobian_u(:,:,:) @@ -153,7 +313,6 @@ module domain_interface real, allocatable :: ustar(:,:) real, allocatable :: znu(:) real, allocatable :: znw(:) - ! these data are stored on the domain wide grid even if this process is only looking at a subgrid ! these variables are necessary with linear winds, especially with spatially variable dz, to compute the LUT real, allocatable :: global_terrain(:,:) diff --git a/src/objects/domain_obj.f90 b/src/objects/domain_obj.f90 index 8c6a7a84..613f4afd 100644 --- a/src/objects/domain_obj.f90 +++ b/src/objects/domain_obj.f90 @@ -10,12 +10,12 @@ submodule(domain_interface) domain_implementation use assertions_mod, only : assert, assertions use mod_atm_utilities, only : exner_function, update_pressure - use icar_constants, only : kVARS, kLC_LAND + use icar_constants, only : kVARS, kLC_LAND, kLC_WATER, kWATER_LAKE, kDOUBLE use string, only : str use co_util, only : broadcast use io_routines, only : io_read, io_write use geo, only : geo_lut, geo_interp, geo_interp2d, standardize_coordinates - use array_utilities, only : array_offset_x, array_offset_y, smooth_array, smooth_array_2d, array_offset_x_2d, array_offset_y_2d + use array_utilities, only : array_offset_x, array_offset_y, smooth_array, make_2d_x, make_2d_y use vertical_interpolation,only : vinterp, vLUT implicit none @@ -44,7 +44,7 @@ module subroutine init(this, options) call create_variables(this, options) - call initialize_core_variables(this, options) + call initialize_core_variables(this, options) ! split into several subroutines? call read_land_variables(this, options) @@ -194,9 +194,10 @@ subroutine create_variables(this, opt) if (0 ------------------------------- !! Setup an exchangeable variable. !! @@ -400,12 +566,15 @@ subroutine read_core_variables(this, options) call load_data(options%parameters%init_conditions_file, & options%parameters%lat_hi, & temporary_data, this%grid) + + call make_2d_y(temporary_data, this%grid%ims, this%grid%ime) this%latitude%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) ! Read the longitude data call load_data(options%parameters%init_conditions_file, & options%parameters%lon_hi, & temporary_data, this%grid) + call make_2d_x(temporary_data, this%grid%jms, this%grid%jme) this%longitude%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) @@ -421,6 +590,7 @@ subroutine read_core_variables(this, options) options%parameters%ulon_hi, & temporary_data, this%u_grid) + call make_2d_y(temporary_data, 1, size(this%global_terrain,2)) call subset_array(temporary_data, this%u_longitude%data_2d, this%u_grid) associate(g=>this%u_grid2d_ext, var=>this%geo_u%lon) @@ -433,6 +603,7 @@ subroutine read_core_variables(this, options) options%parameters%lon_hi, & temporary_data, this%grid) + call make_2d_y(temporary_data, 1, size(this%global_terrain,2)) call array_offset_x(temporary_data, temp_offset) call subset_array(temp_offset, this%u_longitude%data_2d, this%u_grid) associate(g=>this%u_grid2d_ext, var=>this%geo_u%lon) @@ -447,6 +618,7 @@ subroutine read_core_variables(this, options) options%parameters%ulat_hi, & temporary_data, this%u_grid) + call make_2d_x(temporary_data, 1, size(this%global_terrain,1)+1) call subset_array(temporary_data, this%u_latitude%data_2d, this%u_grid) associate(g=>this%u_grid2d_ext, var=>this%geo_u%lat) allocate(this%geo_u%lat(1:g%ime-g%ims+1, 1:g%jme-g%jms+1)) @@ -458,6 +630,7 @@ subroutine read_core_variables(this, options) options%parameters%lat_hi, & temporary_data, this%grid) + call make_2d_x(temporary_data, 1, size(this%global_terrain,1)+1) call array_offset_x(temporary_data, temp_offset) call subset_array(temp_offset, this%u_latitude%data_2d, this%u_grid) associate(g=>this%u_grid2d_ext, var=>this%geo_u%lat) @@ -473,6 +646,7 @@ subroutine read_core_variables(this, options) options%parameters%vlon_hi, & temporary_data, this%v_grid) + call make_2d_y(temporary_data, 1, size(this%global_terrain,2)+1) call subset_array(temporary_data, this%v_longitude%data_2d, this%v_grid) associate(g=>this%v_grid2d_ext, var=>this%geo_v%lon) allocate(this%geo_v%lon(1:g%ime-g%ims+1, 1:g%jme-g%jms+1)) @@ -484,6 +658,7 @@ subroutine read_core_variables(this, options) options%parameters%lon_hi, & temporary_data, this%grid) + call make_2d_y(temporary_data, 1, size(this%global_terrain,2)+1) call array_offset_y(temporary_data, temp_offset) call subset_array(temp_offset, this%v_longitude%data_2d, this%v_grid) associate(g=>this%v_grid2d_ext, var=>this%geo_v%lon) @@ -498,6 +673,7 @@ subroutine read_core_variables(this, options) options%parameters%vlat_hi, & temporary_data, this%v_grid) + call make_2d_x(temporary_data, 1, size(this%global_terrain,1)) call subset_array(temporary_data, this%v_latitude%data_2d, this%v_grid) associate(g=>this%v_grid2d_ext, var=>this%geo_v%lat) allocate(this%geo_v%lat(1:g%ime-g%ims+1, 1:g%jme-g%jms+1)) @@ -510,6 +686,7 @@ subroutine read_core_variables(this, options) options%parameters%lat_hi, & temporary_data, this%grid) + call make_2d_x(temporary_data, 1, size(this%global_terrain,1)) call array_offset_y(temporary_data, temp_offset) call subset_array(temp_offset, this%v_latitude%data_2d, this%v_grid) associate(g=>this%v_grid2d_ext, var=>this%geo_v%lat) @@ -761,76 +938,69 @@ subroutine allocate_z_arrays(this) end subroutine allocate_z_arrays - !> ------------------------------- - !! Initialize various domain variables, mostly z, dz, etc. + !! Setup the SLEVE vertical grid structure. + !! This basically entails 2 transformations: First a linear one so that sum(dz) ranges from 0 to smooth_height H. + !! (boundary cnd (3) in Schär et al 2002) Next, the nonlinear SLEVE transformation + !! eqn (2) from Leuenberger et al 2009 z_sleve = Z + terrain * sinh((H/s)**n - (Z/s)**n) / SINH((H/s)**n) (for both smallscale and largescale terrain) + !! Here H is the model top or (flat_z_height in m), s controls how fast the terrain decays + !! and n controls the compression throughout the column (this last factor was added by Leuenberger et al 2009) + !! References: Leuenberger et al 2009 "A Generalization of the SLEVE Vertical Coordinate" + !! Schär et al 2002 "A New Terrain-Following Vertical Coordinate Formulation for Atmospheric Prediction Models" !! + !! N.B. flat dz height != 0 makes little sense here? But works (?) !! ------------------------------- - subroutine initialize_core_variables(this, options) + subroutine setup_sleve(this, options) implicit none class(domain_t), intent(inout) :: this type(options_t), intent(in) :: options - real, allocatable :: temp(:,:,:) + real, allocatable :: temp(:,:,:), gamma_n(:) integer :: i, max_level - real :: s, n, s1, s2, gamma + real :: s, n, s1, s2, gamma, gamma_min logical :: SLEVE - ! character :: filename, file_idS, file_idn - - call read_core_variables(this, options) - - call allocate_z_arrays(this) - - if (options%parameters%sleve) call split_topography(this, options) ! here h1 and h2 are calculated associate(ims => this%ims, ime => this%ime, & - jms => this%jms, jme => this%jme, & - kms => this%kms, kme => this%kme, & - z => this%z%data_3d, & - z_u => this%geo_u%z, & - z_v => this%geo_v%z, & - z_interface => this%z_interface%data_3d, & - nz => options%parameters%nz, & - dz => options%parameters%dz_levels, & - dz_mass => this%dz_mass%data_3d, & - dz_interface => this%dz_interface%data_3d, & - terrain => this%terrain%data_2d, & - terrain_u => this%terrain_u, & - terrain_v => this%terrain_v, & - h1 => this%h1, & - h2 => this%h2, & - h1_u => this%h1_u, & - h2_u => this%h2_u, & - h1_v => this%h1_v, & - h2_v => this%h2_v, & - global_z_interface => this%global_z_interface, & - global_dz_interface => this%global_dz_interface, & - global_terrain => this%global_terrain, & - global_jacobian => this%global_jacobian, & - dzdx => this%dzdx, & - dzdy => this%dzdy, & - jacobian => this%jacobian, & - jacobian_u => this%jacobian_u, & - jacobian_v => this%jacobian_v, & - jacobian_w => this%jacobian_w, & - smooth_height => this%smooth_height, & - dz_scl => this%dz_scl, & - zr_u => this%zr_u, & - zr_v => this%zr_v) - - - ! _________ Hybrid coordinate Implementation _______________________ - if (options%parameters%sleve) then - - ! This basically entails 2 transformations: First a linear one so that sum(dz) ranges from 0 to smooth_height H. - ! (boundary cnd (3) in Schär et al 2002) Next, the nonlinear SLEVE transformation - ! eqn (2) from Leuenberger et al 2009 z_sleve = Z + terrain * sinh((H/s)**n - (Z/s)**n) / SINH((H/s)**n) (for both smallscale and largescale terrain) - ! Here H is the model top or (flat_z_height in m), s controls how fast the terrain decays - ! and n controls the compression throughout the column (this last factor was added by Leuenberger et al 2009) - ! References: Leuenberger et al 2009 "A Generalization of the SLEVE Vertical Coordinate" - ! Schär et al 2002 "A New Terrain-Following Vertical Coordinate Formulation for Atmospheric Prediction Models" - + jms => this%jms, jme => this%jme, & + kms => this%kms, kme => this%kme, & + z => this%z%data_3d, & + z_u => this%geo_u%z, & + z_v => this%geo_v%z, & + z_interface => this%z_interface%data_3d, & + nz => options%parameters%nz, & + dz => options%parameters%dz_levels, & + dz_mass => this%dz_mass%data_3d, & + dz_interface => this%dz_interface%data_3d, & + terrain => this%terrain%data_2d, & + terrain_u => this%terrain_u, & + terrain_v => this%terrain_v, & + h1 => this%h1, & + h2 => this%h2, & + h1_u => this%h1_u, & + h2_u => this%h2_u, & + h1_v => this%h1_v, & + h2_v => this%h2_v, & + global_z_interface => this%global_z_interface, & + global_dz_interface => this%global_dz_interface, & + global_terrain => this%global_terrain, & + global_jacobian => this%global_jacobian, & + dzdy => this%dzdy, & + jacobian => this%jacobian, & + smooth_height => this%smooth_height, & + dz_scl => this%dz_scl, & + zr_u => this%zr_u, & + zr_v => this%zr_v) + + ! Still not 100% convinced this works well in cases other than flat_z_height = 0 (w sleve). So for now best to keep at 0 when using sleve? max_level = find_flat_model_level(options, nz, dz) + ! if(max_level /= nz) then + ! if (this_image()==1) then + ! print*, " flat z height ", options%parameters%flat_z_height + ! print*, " flat z height set to 0 to comply with SLEVE coordinate calculation " + ! print*, " flat z height now", nz + ! end if + ! max_level = nz + ! end if smooth_height = sum(dz(1:max_level)) !sum(global_terrain) / size(global_terrain) + sum(dz(1:max_level)) @@ -838,43 +1008,61 @@ subroutine initialize_core_variables(this, options) s1 = smooth_height / options%parameters%decay_rate_L_topo s2 = smooth_height / options%parameters%decay_rate_S_topo n = options%parameters%sleve_n ! this will have an effect on the z_level ratio throughout the vertical column, and thus on the terrain induced acceleration with wind=2 . Conceptually very nice, but for wind is 2 not ideal. Unless we let that acceleration depend on the difference between hi-res and lo-res terrain. - ! h = terrain(:,:) + ! Scale dz with smooth_height/sum(dz(1:max_level)) before calculating sleve levels. - dz_scl(:) = dz(1:nz) ! * smooth_height / sum(dz(1:max_level)) ! this leads to a jump in dz thickness at max_level+1. Not sure if this is a problem. - ! dz_scl(:) = dz(1:nz) * H / sum(dz(1:nz)) ! gives the same for flatz=0, but smoother otherwise? BAD idea - ! dz_scl = dz(:) * smooth_height / sum(dz(1:max_level)) - ! H = sum(dz_scl(1:max_level)) ! should also lead to smooth_height, but more error proof? + dz_scl(:) = dz(1:nz) * smooth_height / sum(dz(1:max_level)) ! this leads to a jump in dz thickness at max_level+1. Not sure if this is a problem. ! - - - calculate invertibility parameter gamma (Schär et al 2002 eqn 20): - - - - - - - gamma = 1 - MAXVAL(h1)/s1 * COSH(smooth_height/s1)/SINH(smooth_height/s1) - MAXVAL(h2)/s2 * COSH(smooth_height/s2)/SINH(smooth_height/s2) + gamma = 1 - MAXVAL(h1)/s1 * COSH(smooth_height/s1)/SINH(smooth_height/s1) & + - MAXVAL(h2)/s2 * COSH(smooth_height/s2)/SINH(smooth_height/s2) + + ! with the new (leuenberger et al 2010) Sleve formulation, the inveribiltiy criterion is as follows: + ! ( Although an argument could be made to calculate this on the offset (u/v) grid b/c that is most + ! relevant for advection? In reality this is probably a sufficient approximation, as long as we + ! aren't pushing the gamma factor too close to zero ) + allocate(gamma_n(this%kds : this%kde+1)) + i=kms + gamma_n(i) = 1 & + - MAXVAL(h1) * n/(s1**n) & + * COSH((smooth_height/s1)**n) / SINH((smooth_height/s1)**n) & + - MAXVAL(h2) * n/(s2**n) & + * COSH((smooth_height/s2)**n) / SINH((smooth_height/s2)**n) + + do i = this%grid%kds, this%grid%kde + gamma_n(i+1) = 1 & ! # for i != kds !! + - MAXVAL(h1) * n/(s1**n) * sum(dz_scl(1:i))**(n-1) & + * COSH((smooth_height/s1)**n -(sum(dz_scl(1:i))/s1)**n ) / SINH((smooth_height/s1)**n) & + - MAXVAL(h2) * n/(s2**n) * sum(dz_scl(1:i))**(n-1) & + * COSH((smooth_height/s2)**n -(sum(dz_scl(1:i))/s2)**n ) / SINH((smooth_height/s2)**n) + enddo + if (n==1) then + gamma_min = gamma + else + gamma_min = MINVAL(gamma_n) + endif - ! Decay Rate for Large-Scale Topography: svc1 = 10000.0000 COSMO1 operational setting (but model top is at ~22000 masl) - ! Decay Rate for Small-Scale Topography: svc2 = 3300.0000 - if ((this_image()==1)) then - ! print*, "using a sleve_decay_factor (H/s) of ", options%parameters%sleve_decay_factor - print*, " Using a SLEVE coordinate with a Decay height for Large-Scale Topography: (s1) of ", s1, " m." - print*, " Using a SLEVE coordinate with a Decay height for Small-Scale Topography: (s2) of ", s2, " m." - print*, " Using a sleve_n of ", options%parameters%sleve_n - ! print*, "" - write(*,*) " Smooth height (model top) is ", smooth_height, "m.a.s.l" - write(*,*) " invertibility parameter gamma is: ", gamma - if(gamma <= 0) print*, " CAUTION: coordinate transformation is not invertible (gamma <= 0 ) !!! reduce decay rate(s)!" - ! write(*,*) " mean terrain ", sum(terrain) / size(terrain) - ! write(*,*) " sum(dz) ", sum(dz(1:max_level)) - ! write(*,*) " sum(dz_scl) ", sum(dz_scl(1:max_level)) - ! write(*,*) " model top ", sum(dz_scl(1:nz)) - print*, "" + ! For reference: COSMO1 operational setting (but model top is at ~22000 masl): + ! Decay Rate for Large-Scale Topography: svc1 = 10000.0000 + ! Decay Rate for Small-Scale Topography: svc2 = 3300.0000 + if ((this_image()==1)) then + print*, " Using a SLEVE coordinate with a Decay height for Large-Scale Topography: (s1) of ", s1, " m." + print*, " Using a SLEVE coordinate with a Decay height for Small-Scale Topography: (s2) of ", s2, " m." + print*, " Using a sleve_n of ", options%parameters%sleve_n + write(*,*) " Smooth height is ", smooth_height, "m.a.s.l (model top ", sum(dz(1:nz)), "m.a.s.l.)" + write(*,*) " invertibility parameter gamma is: ", gamma_min + if(gamma_min <= 0) print*, " CAUTION: coordinate transformation is not invertible (gamma <= 0 ) !!! reduce decay rate(s), and/or increase flat_z_height!" + ! if(options%parameters%debug) write(*,*) " (for (debugging) reference: 'gamma(n=1)'= ", gamma,")" + print*, "" endif - i=kms - ! - - - - - Mass grid calculations for lowest level (i=kms) - - - - - + i=kms - !use temp to store global z-interface so that global-jacobian can be calculated + ! use temp to store global z-interface so that global-jacobian can be calculated allocate(temp(this%ids:this%ide, this%kds:this%kde, this%jds:this%jde)) temp(:,i,:) = global_terrain @@ -882,19 +1070,21 @@ subroutine initialize_core_variables(this, options) temp(:,i+1,:) = dz_scl(i) & + h1 * SINH( (smooth_height/s1)**n - (dz_scl(i)/s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain + h2 * SINH( (smooth_height/s2)**n - (dz_scl(i)/s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features - ! + terrain * SINH( (H/s)**n - (dz_scl(i)/s)**n ) / SINH((H/s)**n) + global_dz_interface(:,i,:) = temp(:,i+1,:) - temp(:,i,:) ! same for higher k + global_z_interface(:,i,:) = global_terrain + global_jacobian(:,i,:) = global_dz_interface(:,i,:)/dz_scl(i) + + ! this is on the subset grid: z_interface(:,i,:) = temp(ims:ime,i,jms:jme) z_interface(:,i+1,:) = temp(ims:ime,i+1,jms:jme) - global_dz_interface(:,i,:) = temp(:,i+1,:) - temp(:,i,:) ! same for higher k dz_interface(:,i,:) = z_interface(:,i+1,:) - z_interface(:,i,:) ! same for higher k dz_mass(:,i,:) = dz_interface(:,i,:) / 2 ! Diff for k=1 z(:,i,:) = terrain + dz_mass(:,i,:) ! Diff for k=1 jacobian(:,i,:) = dz_interface(:,i,:)/dz_scl(i) - global_jacobian(:,i,:) = global_dz_interface(:,i,:)/dz_scl(i) ! ! - - - - - u/v grid calculations for lowest level (i=kms) - - - - - ! ! for the u and v grids, z(1) was already initialized with terrain. @@ -908,13 +1098,11 @@ subroutine initialize_core_variables(this, options) ! Offset analogous to: z_u(:,i,:) = z_u(:,i,:) + dz(i) / 2 * zr_u(:,i,:) z_u(:,i,:) = dz_scl(i)/2 & - ! + terrain_u * SINH( (H/s)**n - ( dz_scl(i)/2 /s)**n ) / SINH((H/s)**n) - + h1_u * SINH( (smooth_height/s1)**n - (dz_scl(i)/2/s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain - + h2_u * SINH( (smooth_height/s2)**n - (dz_scl(i)/2/s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features + + h1_u * SINH( (smooth_height/s1)**n - (dz_scl(i)/2/s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain + + h2_u * SINH( (smooth_height/s2)**n - (dz_scl(i)/2/s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features z_v(:,i,:) = dz_scl(i)/2 & - ! + terrain_v * SINH( (H/s)**n - ( dz_scl(i)/2 /s)**n ) / SINH((H/s)**n) - + h1_v * SINH( (smooth_height/s1)**n - (dz_scl(i)/2/s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain - + h2_v * SINH( (smooth_height/s2)**n - (dz_scl(i)/2/s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features + + h1_v * SINH( (smooth_height/s1)**n - (dz_scl(i)/2/s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain + + h2_v * SINH( (smooth_height/s2)**n - (dz_scl(i)/2/s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features zr_u(:,i,:) = (z_u(:,i,:) - terrain_u) / ( dz_scl(i)/2 ) zr_v(:,i,:) = (z_v(:,i,:) - terrain_v) / (dz_scl(i)/2 ) @@ -926,42 +1114,42 @@ subroutine initialize_core_variables(this, options) if (i==this%grid%kme) then ! if we are at the model top i+1 is not defined - dz_interface(:,i,:) = smooth_height - z_interface(:,i,:) - global_dz_interface(:,i,:) = smooth_height - temp(:,i,:) + dz_interface(:,i,:) = smooth_height - z_interface(:,i,:) + global_dz_interface(:,i,:) = smooth_height - temp(:,i,:) else - temp(:,i+1,:) = sum(dz_scl(1:i)) & + temp(:,i+1,:) = sum(dz_scl(1:i)) & + h1 * SINH( (smooth_height/s1)**n - (sum(dz_scl(1:i))/s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain + h2 * SINH( (smooth_height/s2)**n - (sum(dz_scl(1:i))/s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features - ! + terrain * SINH( (H/s)**n - (dz_scl(i)/s)**n ) / SINH((H/s)**n) - z_interface(:,i+1,:) = temp(ims:ime,i+1,jms:jme) - global_dz_interface(:,i,:) = temp(:,i+1,:) - temp(:,i,:) - dz_interface(:,i,:) = z_interface(:,i+1,:) - z_interface(:,i,:) + z_interface(:,i+1,:) = temp(ims:ime,i+1,jms:jme) + + global_dz_interface(:,i,:) = temp(:,i+1,:) - temp(:,i,:) + global_z_interface(:,i,:) = global_z_interface(:,i-1,:) + global_dz_interface(:,i-1,:) + dz_interface(:,i,:) = z_interface(:,i+1,:) - z_interface(:,i,:) endif if ( ANY(dz_interface(:,i,:)<0) ) then ! Eror catching. Probably good to engage. - if (this_image()==1) then + if (this_image()==1) then write(*,*) "Error: dz_interface below zero (for level ",i,")" print*, "min max dz_interface: ",MINVAL(dz_interface(:,i,:)),MAXVAL(dz_interface(:,i,:)) error stop print*, dz_interface(:,i,:) print*,"" - endif - else if ( ANY(dz_interface(:,i,:)<=0.01) ) then - if (this_image()==1) write(*,*) "WARNING: dz_interface very low (at level ",i,")" + endif + else if ( ANY(global_dz_interface(:,i,:)<=0.01) ) then + if (this_image()==1) write(*,*) "WARNING: dz_interface very low (at level ",i,")" endif ! - - - - - u/v grid calculations - - - - - + ! contrary to the calculations above, these all take place on the parallelized terrain z_u(:,i,:) = (sum(dz_scl(1:(i-1))) + dz_scl(i)/2) & - ! + terrain_u * SINH( (H/s)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s)**n ) / SINH((H/s)**n) - + h1_u * SINH( (smooth_height/s1)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain - + h2_u * SINH( (smooth_height/s2)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features + + h1_u * SINH( (smooth_height/s1)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain + + h2_u * SINH( (smooth_height/s2)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features z_v(:,i,:) = (sum(dz_scl(1:(i-1))) + dz_scl(i)/2) & - ! + terrain_v * SINH( (H/s)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s)**n ) / SINH((H/s)**n) - + h1_v * SINH( (smooth_height/s1)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain - + h2_v * SINH( (smooth_height/s2)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features + + h1_v * SINH( (smooth_height/s1)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s1)**n ) / SINH((smooth_height/s1)**n) &! large-scale terrain + + h2_v * SINH( (smooth_height/s2)**n - ( (sum(dz_scl(1:(i-1)))+dz_scl(i)/2) /s2)**n ) / SINH((smooth_height/s2)**n) ! small terrain features zr_u(:,i,:) = (z_u(:,i,:) - z_u(:,i-1,:)) / (dz_scl(i)/2 + dz_scl(i-1)/2 ) ! if dz_scl(i-1) = 0 (and no error) k=1 can be included zr_v(:,i,:) = (z_v(:,i,:) - z_v(:,i-1,:)) / (dz_scl(i)/2 + dz_scl(i-1)/2 ) @@ -973,6 +1161,7 @@ subroutine initialize_core_variables(this, options) zr_v(:,i,:) = 1 global_dz_interface(:,i,:) = dz_scl(i) + global_z_interface(:,i,:) = global_z_interface(:,i-1,:) + global_dz_interface(:,i-1,:) dz_interface(:,i,:) = dz_scl(i) !(dz(i) + dz_scl(i) )/2 ! to mitigate the jump in dz at max_level+1: (dz+dz_scl)/2 iso dz if (i/=this%grid%kme) z_interface(:,i+1,:) = z_interface(:,i,:) + dz(i) ! (dz(i) + dz_scl( i) )/2 !test in icar_s5T @@ -987,10 +1176,67 @@ subroutine initialize_core_variables(this, options) jacobian(:,i,:) = dz_interface(:,i,:)/dz_scl(i) global_jacobian(:,i,:) = global_dz_interface(:,i,:)/dz_scl(i) - enddo ! ____ end SLEVE simple Implementation _______ + enddo + + i=kme+1 + global_z_interface(:,i,:) = global_z_interface(:,i-1,:) + global_dz_interface(:,i-1,:) + + ! if ((this_image()==1).and.(options%parameters%debug)) then + ! call io_write("global_jacobian.nc", "global_jacobian", global_jacobian(:,:,:) ) + ! write(*,*) " global jacobian minmax: ", MINVAL(global_jacobian) , MAXVAL(global_jacobian) + ! endif + + end associate + end subroutine setup_sleve - else !. i.e. no sleve coordinates + + + !> ------------------------------- + !! Setup the vertical grid structure, in case SLEVE coordinates are not used. + !! This means either constant vertical height, or a simple terrain following coordinate (Gal-Chen) + !! + !! -------------------------------- + subroutine setup_simple_z(this, options) + implicit none + class(domain_t), intent(inout) :: this + type(options_t), intent(in) :: options + + real, allocatable :: temp(:,:,:) + integer :: i, max_level + + associate( ims => this%ims, ime => this%ime, & + jms => this%jms, jme => this%jme, & + kms => this%kms, kme => this%kme, & + z => this%z%data_3d, & + z_u => this%geo_u%z, & + z_v => this%geo_v%z, & + z_interface => this%z_interface%data_3d, & + nz => options%parameters%nz, & + dz => options%parameters%dz_levels, & + dz_mass => this%dz_mass%data_3d, & + dz_interface => this%dz_interface%data_3d, & + terrain => this%terrain%data_2d, & + terrain_u => this%terrain_u, & + terrain_v => this%terrain_v, & + h1 => this%h1, & + h2 => this%h2, & + h1_u => this%h1_u, & + h2_u => this%h2_u, & + h1_v => this%h1_v, & + h2_v => this%h2_v, & + global_z_interface => this%global_z_interface, & + global_dz_interface => this%global_dz_interface, & + global_terrain => this%global_terrain, & + global_jacobian => this%global_jacobian, & + dzdy => this%dzdy, & + jacobian => this%jacobian, & + smooth_height => this%smooth_height, & + dz_scl => this%dz_scl, & + zr_u => this%zr_u, & + zr_v => this%zr_v) + + ! Start with a separate calculation for the lowest model level z=1 i = this%grid%kms max_level = nz @@ -1029,6 +1275,7 @@ subroutine initialize_core_variables(this, options) z_u(:,i,:) = z_u(:,i,:) + dz(i) / 2 * zr_u(:,i,:) z_v(:,i,:) = z_v(:,i,:) + dz(i) / 2 * zr_v(:,i,:) + ! Now the higher (k!=1) levels can be calculated: do i = this%grid%kms+1, this%grid%kme if (i<=max_level) then jacobian(:,i,:) = jacobian(:,i-1,:) @@ -1064,32 +1311,83 @@ subroutine initialize_core_variables(this, options) i = this%grid%kme + 1 global_z_interface(:,i,:) = global_z_interface(:,i-1,:) + global_dz_interface(:,i-1,:) + end associate + + end subroutine setup_simple_z + + + + !> ------------------------------- + !! Initialize various domain variables, mostly z, dz, etc. + !! + !! ------------------------------- + subroutine initialize_core_variables(this, options) + implicit none + class(domain_t), intent(inout) :: this + type(options_t), intent(in) :: options + + real, allocatable :: temp(:,:,:) + + call read_core_variables(this, options) + + call allocate_z_arrays(this) + + ! Setup the vertical grid structure, either as a SLEVE coordinate, or a more 'simple' vertical structure: + if (options%parameters%sleve) then + + call split_topography(this, options) ! here h1 and h2 are calculated + call setup_sleve(this, options) + + else + ! This will set up either a Gal-Chen terrainfollowing coordinate, or no terrain following. + call setup_simple_z(this, options) endif - if (allocated(temp)) deallocate(temp) - allocate(temp(this%ids:this%ide+1, this%kds:this%kde, this%jds:this%jde+1)) - temp(this%ids,:,this%jds:this%jde) = global_jacobian(this%ids,:,this%jds:this%jde) - temp(this%ide+1,:,this%jds:this%jde) = global_jacobian(this%ide,:,this%jds:this%jde) - temp(this%ids+1:this%ide,:,this%jds:this%jde) = (global_jacobian(this%ids+1:this%ide,:,this%jds:this%jde) + & - global_jacobian(this%ids:this%ide-1,:,this%jds:this%jde))/2 - jacobian_u = temp(ims:ime+1,:,jms:jme) - - temp(this%ids:this%ide,:,this%jds) = global_jacobian(this%ids:this%ide,:,this%jds) - temp(this%ids:this%ide,:,this%jde+1) = global_jacobian(this%ids:this%ide,:,this%jde) - temp(this%ids:this%ide,:,this%jds+1:this%jde) = (global_jacobian(this%ids:this%ide,:,this%jds+1:this%jde) + & - global_jacobian(this%ids:this%ide,:,this%jds:this%jde-1))/2 - jacobian_v = temp(ims:ime,:,jms:jme+1) - - temp(this%ids:this%ide,this%kme,this%jds) = global_jacobian(this%ids:this%ide,this%kme,this%jds) - temp(this%ids:this%ide,this%kms:this%kme-1,this%jds:this%jde) = (global_jacobian(this%ids:this%ide,this%kms:this%kme-1,this%jds:this%jde) + & - global_jacobian(this%ids:this%ide,this%kms+1:this%kme,this%jds:this%jde))/2 - jacobian_w = temp(ims:ime,:,jms:jme) - - call setup_dzdxy(this, options) - - ! technically these should probably be defined to the k+1 model top as well bu not used at present. - ! z_interface(:,i,:) = z_interface(:,i-1,:) + dz_interface(:,i-1,:) + !! To allow for development and debugging of coordinate transformations: + ! if ((this_image()==1).and.(options%parameters%debug)) then + ! ! call io_write("global_jacobian.nc", "global_jacobian", this%global_jacobian(:,:,:) ) + ! write(*,*) " global jacobian minmax: ", MINVAL(this%global_jacobian) , MAXVAL(this%global_jacobian) + ! write(*,*) "" + ! endif + + + associate(ims => this%ims, ime => this%ime, & + jms => this%jms, jme => this%jme, & + kms => this%kms, kme => this%kme, & + z => this%z%data_3d, & + global_jacobian => this%global_jacobian, & + jacobian => this%jacobian, & + jacobian_u => this%jacobian_u, & + jacobian_v => this%jacobian_v, & + jacobian_w => this%jacobian_w, & + zr_u => this%zr_u, & + zr_v => this%zr_v) + + + if (allocated(temp)) deallocate(temp) + allocate(temp(this%ids:this%ide+1, this%kds:this%kde, this%jds:this%jde+1)) + temp(this%ids,:,this%jds:this%jde) = global_jacobian(this%ids,:,this%jds:this%jde) + temp(this%ide+1,:,this%jds:this%jde) = global_jacobian(this%ide,:,this%jds:this%jde) + temp(this%ids+1:this%ide,:,this%jds:this%jde) = (global_jacobian(this%ids+1:this%ide,:,this%jds:this%jde) + & + global_jacobian(this%ids:this%ide-1,:,this%jds:this%jde))/2 + jacobian_u = temp(ims:ime+1,:,jms:jme) + + temp(this%ids:this%ide,:,this%jds) = global_jacobian(this%ids:this%ide,:,this%jds) + temp(this%ids:this%ide,:,this%jde+1) = global_jacobian(this%ids:this%ide,:,this%jde) + temp(this%ids:this%ide,:,this%jds+1:this%jde) = (global_jacobian(this%ids:this%ide,:,this%jds+1:this%jde) + & + global_jacobian(this%ids:this%ide,:,this%jds:this%jde-1))/2 + jacobian_v = temp(ims:ime,:,jms:jme+1) + + temp(this%ids:this%ide,this%kme,this%jds) = global_jacobian(this%ids:this%ide,this%kme,this%jds) + temp(this%ids:this%ide,this%kms:this%kme-1,this%jds:this%jde) = (global_jacobian(this%ids:this%ide,this%kms:this%kme-1,this%jds:this%jde) + & + global_jacobian(this%ids:this%ide,this%kms+1:this%kme,this%jds:this%jde))/2 + jacobian_w = temp(ims:ime,:,jms:jme) + + call setup_dzdxy(this, options) + + ! technically these should probably be defined to the k+1 model top as well bu not used at present. + ! z_interface(:,i,:) = z_interface(:,i-1,:) + dz_interface(:,i-1,:) end associate ! z_u and zr_u are on the v/u_grid2d_ext; move to vu_grid2d @@ -1114,6 +1412,8 @@ subroutine initialize_core_variables(this, options) end subroutine initialize_core_variables + + subroutine setup_dzdxy(this,options) implicit none class(domain_t), intent(inout) :: this @@ -1167,7 +1467,7 @@ subroutine split_topography(this, options) class(domain_t), intent(inout) :: this type(options_t), intent(in) :: options - real, allocatable :: h_org(:,:), h_u(:,:), h_v(:,:), temp(:,:), temporary_data(:,:), temp_offset(:,:) + real, allocatable :: h_org(:,:), h_u(:,:), h_v(:,:), temp(:,:), temp_offset(:,:) ! temporary_data(:,:), integer :: i !, nflt, windowsize, allocate(h_org( this%grid2d% ids : this%grid2d% ide, & @@ -1232,71 +1532,64 @@ subroutine split_topography(this, options) endif - ! Read in terrain again: This time onto the entire (ids-ide) 2d grid so we can smooth it. - call load_data(options%parameters%init_conditions_file, & - options%parameters%hgt_hi, & - temporary_data, this%grid2d ) - - h_org = temporary_data(this%grid2d%ids:this%grid2d%ide, this%grid2d%jds:this%grid2d%jde) ! Smoothing over entire domain - h1 = h_org + ! create a separate variable that will be smoothed later on: + h1 = global_terrain(this%grid2d%ids:this%grid2d%ide, this%grid2d%jds:this%grid2d%jde) - call array_offset_x_2d(temporary_data, temp_offset) + ! offset the global terrain for the h_(u/v) calculations: + call array_offset_x(global_terrain, temp_offset) h_u = temp_offset h1_u = temp_offset if (allocated(temp_offset)) deallocate(temp_offset) - call array_offset_y_2d(temporary_data, temp_offset) + call array_offset_y(global_terrain, temp_offset) h_v = temp_offset h1_v = temp_offset ! Smooth the terrain to attain the large-scale contribution h1 (_u/v): do i =1,options%parameters%terrain_smooth_cycles - call smooth_array_2d( h1, windowsize = options%parameters%terrain_smooth_windowsize) - call smooth_array_2d( h1_u, windowsize = options%parameters%terrain_smooth_windowsize) - call smooth_array_2d( h1_v, windowsize = options%parameters%terrain_smooth_windowsize) + call smooth_array( h1, windowsize = options%parameters%terrain_smooth_windowsize) + call smooth_array( h1_u, windowsize = options%parameters%terrain_smooth_windowsize) + call smooth_array( h1_v, windowsize = options%parameters%terrain_smooth_windowsize) enddo ! Subract the large-scale terrain from the full topography to attain the small-scale contribution: - h2 = h_org - h1 + h2 = global_terrain - h1 h2_u = h_u - h1_u h2_v = h_v - h1_v + ! In case one wants to see how the terrain is split by smoothing, activate the block below and run in debug: + ! if ((this_image()==1).and.(options%parameters%debug)) then + ! call io_write("terrain_smooth_h1.nc", "h1", h1(:,:) ) + ! call io_write("terrain_smooth_h2.nc", "h2", h2(:,:) ) + ! call io_write("h1_u.nc", "h1_u", h1_u(:,:) ) + ! call io_write("h2_u.nc", "h2_u", h2_u(:,:) ) + ! endif - - if ((this_image()==1).and.(options%parameters%debug)) then - ! if (this_image()==1) then - call io_write("terrain_smooth_h1.nc", "h1", h1(:,:) ) - call io_write("terrain_smooth_h2.nc", "h2", h2(:,:) ) - call io_write("h1_u.nc", "h1_u", h1_u(:,:) ) - call io_write("h2_u.nc", "h2_u", h2_u(:,:) ) - endif if (this_image()==1) then - ! print*, " global_terrain max ", MAXVAL(global_terrain) - print*, " Max of full topography", MAXVAL(h_org) - print*, " Max of large-scale topography (h1) ", MAXVAL(h1) - print*, " Max of small-scale topography (h2) ", MAXVAL(h2) + print*, " Max of full topography", MAXVAL(global_terrain ) + print*, " Max of large-scale topography (h1) ", MAXVAL(h1) + print*, " Max of small-scale topography (h2) ", MAXVAL(h2) end if end associate + ! Subset onto paralellized 2d grid (h1 and h2 are kept on the global grid so we can calculate the global jacobian) - ! Subset onto paralellized 2d grid - !temp = this%h1 - !deallocate(this%h1) - !allocate(this%h1( this%grid2d% ims : this%grid2d% ime, & + ! temp = this%h1 + ! deallocate(this%h1) + ! allocate(this%h1( this%grid2d% ims : this%grid2d% ime, & ! this%grid2d% jms : this%grid2d% jme) ) - !this%h1 = temp(this%grid2d%ims:this%grid2d%ime, this%grid2d%jms:this%grid2d%jme) - !deallocate(temp) - + ! this%h1 = temp(this%grid2d%ims:this%grid2d%ime, this%grid2d%jms:this%grid2d%jme) + ! deallocate(temp) - !temp = this%h2 - !deallocate(this%h2) - !allocate(this%h2( this%grid2d% ims : this%grid2d% ime, & + ! temp = this%h2 + ! deallocate(this%h2) + ! allocate(this%h2( this%grid2d% ims : this%grid2d% ime, & ! this%grid2d% jms : this%grid2d% jme) ) - !this%h2 = temp(this%grid2d%ims:this%grid2d%ime, this%grid2d%jms:this%grid2d%jme) - !deallocate(temp) + ! this%h2 = temp(this%grid2d%ims:this%grid2d%ime, this%grid2d%jms:this%grid2d%jme) + ! deallocate(temp) - ! same for u and v: + ! same for u and v: temp = this%h1_u deallocate(this%h1_u) allocate(this%h1_u( this%u_grid2d_ext% ims : this%u_grid2d_ext% ime, & @@ -1326,8 +1619,7 @@ subroutine split_topography(this, options) this%h2_v = temp(this%v_grid2d_ext%ims:this%v_grid2d_ext%ime, this%v_grid2d_ext%jms:this%v_grid2d_ext%jme) deallocate(temp) - - end subroutine + end subroutine split_topography @@ -1393,6 +1685,8 @@ subroutine read_land_variables(this, options) soil_thickness = 1.0 soil_thickness(1:4) = [0.1, 0.2, 0.5, 1.0] + + if (this_image()==1) write (*,*) "Reading Land Variables" if (associated(this%soil_water_content%data_3d)) then nsoil = size(this%soil_water_content%data_3d, 2) elseif (associated(this%soil_temperature%data_3d)) then @@ -1405,9 +1699,21 @@ subroutine read_land_variables(this, options) temporary_data) if (allocated(this%land_mask)) then this%land_mask = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + where(this%land_mask==0) this%land_mask = kLC_WATER ! To ensure conisitency. land_mask can be 0 or 2 for water, enforce a single value. endif endif + if ((options%physics%watersurface==kWATER_LAKE) .AND.(options%parameters%lakedepthvar /= "")) then + if (this_image()==1) write(*,*) " reading lake depth data from hi-res file" + + call io_read(options%parameters%init_conditions_file, & + options%parameters%lakedepthvar, & + temporary_data) + if (associated(this%lake_depth%data_2d)) then + this%lake_depth%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + endif + + endif if (options%parameters%soiltype_var /= "") then call io_read(options%parameters%init_conditions_file, & @@ -1424,8 +1730,15 @@ subroutine read_land_variables(this, options) temporary_data) if (associated(this%soil_deep_temperature%data_2d)) then this%soil_deep_temperature%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) - endif + if (minval(temporary_data)< 200) then + if (this_image()==1) print*, "WARNING, VERY COLD SOIL TEMPERATURES SPECIFIED:", minval(temporary_data) + if (this_image()==1) print*, trim(options%parameters%init_conditions_file)," ",trim(options%parameters%soil_deept_var) + endif + if (minval(this%soil_deep_temperature%data_2d)< 200) then + where(this%soil_deep_temperature%data_2d<200) this%soil_deep_temperature%data_2d=280 ! <200 is just broken, set to mean annual air temperature at mid-latidudes + endif + endif else if (associated(this%soil_deep_temperature%data_2d)) then this%soil_deep_temperature%data_2d = 280 @@ -1441,15 +1754,19 @@ subroutine read_land_variables(this, options) this%soil_temperature%data_3d(:,i,:) = temporary_data_3d(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme, i) enddo if (options%parameters%soil_deept_var == "") then - this%soil_deep_temperature%data_2d = this%soil_temperature%data_3d(:,nsoil,:) + if (associated(this%soil_deep_temperature%data_2d)) then + this%soil_deep_temperature%data_2d = this%soil_temperature%data_3d(:,nsoil,:) + endif endif endif else if (associated(this%soil_temperature%data_3d)) then - do i=1,nsoil - this%soil_temperature%data_3d(:,i,:) = this%soil_deep_temperature%data_2d - enddo + if (associated(this%soil_deep_temperature%data_2d)) then + do i=1,nsoil + this%soil_temperature%data_3d(:,i,:) = this%soil_deep_temperature%data_2d + enddo + endif endif endif @@ -1468,6 +1785,19 @@ subroutine read_land_variables(this, options) endif endif + if (options%parameters%snowh_var /= "") then + call io_read(options%parameters%init_conditions_file, & + options%parameters%snowh_var, & + temporary_data) + if (associated(this%snow_height%data_2d)) then + this%snow_height%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + endif + + else + if (associated(this%snow_height%data_2d)) then + this%snow_height%data_2d = 0 + endif + endif if (options%parameters%soil_vwc_var /= "") then call io_read(options%parameters%init_conditions_file, & @@ -1481,7 +1811,7 @@ subroutine read_land_variables(this, options) else if (associated(this%soil_water_content%data_3d)) then - this%soil_water_content%data_3d = 0.2 + this%soil_water_content%data_3d = 0.4 endif endif @@ -1494,14 +1824,65 @@ subroutine read_land_variables(this, options) endif endif + if (options%parameters%albedo_var /= "") then + if (options%lsm_options%monthly_albedo) then + call io_read(options%parameters%init_conditions_file, & + options%parameters%albedo_var, & + temporary_data_3d) + + if (associated(this%albedo%data_3d)) then + do i=1,size(this%albedo%data_3d, 2) + this%albedo%data_3d(:,i,:) = temporary_data_3d(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme,i) + enddo + + if (maxval(temporary_data_3d) > 1) then + if (this_image()==1) print*, "Changing input ALBEDO % to fraction" + this%albedo%data_3d = this%albedo%data_3d / 100 + endif + endif + else + call io_read(options%parameters%init_conditions_file, & + options%parameters%albedo_var, & + temporary_data) + if (associated(this%albedo%data_3d)) then + do i=1,size(this%albedo%data_3d, 2) + this%albedo%data_3d(:,i,:) = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + enddo + + if (maxval(temporary_data) > 1) then + if (this_image()==1) print*, "Changing input ALBEDO % to fraction" + this%albedo%data_3d = this%albedo%data_3d / 100 + endif + endif + endif + + else + if (associated(this%albedo%data_3d)) then + this%albedo%data_3d = 0.17 + endif + endif + + if (options%parameters%vegfrac_var /= "") then - call io_read(options%parameters%init_conditions_file, & - options%parameters%vegfrac_var, & - temporary_data) - if (associated(this%vegetation_fraction%data_3d)) then - do i=1,size(this%vegetation_fraction%data_3d, 2) - this%vegetation_fraction%data_3d(:,i,:) = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) - enddo + if (options%lsm_options%monthly_albedo) then + call io_read(options%parameters%init_conditions_file, & + options%parameters%vegfrac_var, & + temporary_data_3d) + + if (associated(this%vegetation_fraction%data_3d)) then + do i=1,size(this%vegetation_fraction%data_3d, 2) + this%vegetation_fraction%data_3d(:,i,:) = temporary_data_3d(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme,i) + enddo + endif + else + call io_read(options%parameters%init_conditions_file, & + options%parameters%vegfrac_var, & + temporary_data) + if (associated(this%vegetation_fraction%data_3d)) then + do i=1,size(this%vegetation_fraction%data_3d, 2) + this%vegetation_fraction%data_3d(:,i,:) = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + enddo + endif endif else @@ -1519,6 +1900,48 @@ subroutine read_land_variables(this, options) endif endif + if (options%parameters%vegfracmax_var /= "") then + call io_read(options%parameters%init_conditions_file, & + options%parameters%vegfracmax_var, & + temporary_data) + if (associated(this%vegetation_fraction_max%data_2d)) then + this%vegetation_fraction_max%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + endif + else + if (associated(this%vegetation_fraction_max%data_2d)) then + if (this_image()==1) write(*,*) " VEGMAX not specified; using default value of 0.8" + this%vegetation_fraction_max%data_2d = 0.8 + endif + endif + + if (options%parameters%lai_var /= "") then + call io_read(options%parameters%init_conditions_file, & + options%parameters%lai_var, & + temporary_data) + if (associated(this%lai%data_2d)) then + this%lai%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + endif + else + if (associated(this%lai%data_2d)) then + if (this_image()==1) write(*,*) " LAI not specified; using default value of 1" + this%lai%data_2d = 1 + endif + endif + + if (options%parameters%canwat_var /= "") then + call io_read(options%parameters%init_conditions_file, & + options%parameters%canwat_var, & + temporary_data) + if (associated(this%canopy_water%data_2d)) then + this%canopy_water%data_2d = temporary_data(this%grid%ims:this%grid%ime, this%grid%jms:this%grid%jme) + endif + else + if (associated(this%canopy_water%data_2d)) then + if (this_image()==1) write(*,*) " CANWAT not specified; using default value of 0" + this%canopy_water%data_2d = 0 + endif + endif + ! these will all be udpated by either forcing data or the land model, but initialize to sensible values to avoid breaking other initialization routines if (associated(this%skin_temperature%data_2d)) this%skin_temperature%data_2d = 280 if (associated(this%roughness_z0%data_2d)) this%roughness_z0%data_2d = 0.001 @@ -1531,10 +1954,21 @@ subroutine read_land_variables(this, options) if (associated(this%surface_pressure%data_2d)) this%surface_pressure%data_2d=102000 if (associated(this%longwave_up%data_2d)) this%longwave_up%data_2d=0 if (associated(this%ground_heat_flux%data_2d)) this%ground_heat_flux%data_2d=0 - + if (associated(this%veg_leaf_temperature%data_2d)) this%veg_leaf_temperature%data_2d=280 + if (associated(this%ground_surf_temperature%data_2d)) this%ground_surf_temperature%data_2d=280 + if (associated(this%canopy_vapor_pressure%data_2d)) this%canopy_vapor_pressure%data_2d=2000 + if (associated(this%canopy_temperature%data_2d)) this%canopy_temperature%data_2d=280 + if (associated(this%coeff_momentum_drag%data_2d)) this%coeff_momentum_drag%data_2d=0 + if (associated(this%coeff_heat_exchange%data_2d)) this%coeff_heat_exchange%data_2d=0 + if (associated(this%coeff_heat_exchange_3d%data_3d)) this%coeff_heat_exchange_3d%data_3d=0.01 + if (associated(this%canopy_fwet%data_2d)) this%canopy_fwet%data_2d=0 + if (associated(this%snow_water_eq_prev%data_2d)) this%snow_water_eq_prev%data_2d=0 + if (associated(this%snow_albedo_prev%data_2d)) this%snow_albedo_prev%data_2d=0.65 + if (associated(this%storage_lake%data_2d)) this%storage_lake%data_2d=0 end subroutine read_land_variables + !> ------------------------------- !! Initialize various internal variables that need forcing data first, e.g. temperature, pressure on interface, exner, ... !! @@ -1549,6 +1983,7 @@ subroutine initialize_internal_variables(this, options) associate(pressure => this%pressure%data_3d, & exner => this%exner%data_3d, & pressure_interface => this%pressure_interface%data_3d, & + temperature_interface => this%temperature_interface%data_3d, & psfc => this%surface_pressure%data_2d, & temperature => this%temperature%data_3d, & potential_temperature => this%potential_temperature%data_3d ) @@ -1573,6 +2008,15 @@ subroutine initialize_internal_variables(this, options) temperature = potential_temperature * exner endif + if (associated(this%temperature_interface%data_3d)) then + ! this isn't exactly correct, should be distance weighted... + ! weight one = (dz2) / (dz1+dz2) + ! weight two = (dz1) / (dz1+dz2) + temperature_interface(:,1,:) = ( temperature(:,1,:) * 2 - temperature(:,2,:) ) + do i = 2, size(temperature_interface, 2) + temperature_interface(:,i,:) = ( temperature(:,i-1,:) + temperature(:,i,:) ) / 2 + enddo + ENDIF end associate if (allocated(this%znw).or.allocated(this%znu)) call init_znu(this) @@ -1669,13 +2113,17 @@ module subroutine var_request(this, options) [kVARS%z, kVARS%z_interface, & kVARS%dz, kVARS%dz_interface, & kVARS%u, kVARS%v, & - kVARS%surface_pressure, kVARS%roughness_z0, & + kVARS%surface_pressure, kVARS%roughness_z0, & kVARS%terrain, kVARS%pressure, & kVARS%temperature, kVARS%pressure_interface, & kVARS%exner, kVARS%potential_temperature, & kVARS%latitude, kVARS%longitude, & kVARS%u_latitude, kVARS%u_longitude, & - kVARS%v_latitude, kVARS%v_longitude ]) + kVARS%v_latitude, kVARS%v_longitude, & + kVARS%temperature_interface, kVARS%ivt, & + kVARS%iwv, kVARS%iwl, kVARS%iwi ]) + + if (trim(options%parameters%rain_var) /= "") call options%alloc_vars([kVARS%external_precipitation]) ! List the variables that are required for any restart call options%restart_vars( & @@ -1743,10 +2191,17 @@ subroutine read_domain_shape(this, options) this%v_grid2d_ext%jme = min(this%v_grid2d%jme + nsmooth, this%v_grid2d%jde) - call this%grid_soil%set_grid_dimensions( nx_global, ny_global, 4) - call this%grid_monthly%set_grid_dimensions( nx_global, ny_global, 12) - - + call this%grid_soil%set_grid_dimensions( nx_global, ny_global, 4) + call this%grid_snow%set_grid_dimensions( nx_global, ny_global, 3) + call this%grid_snowsoil%set_grid_dimensions( nx_global, ny_global, 7) + call this%grid_soilcomp%set_grid_dimensions( nx_global, ny_global, 8) + call this%grid_gecros%set_grid_dimensions( nx_global, ny_global, 60) + call this%grid_croptype%set_grid_dimensions( nx_global, ny_global, 5) + call this%grid_monthly%set_grid_dimensions( nx_global, ny_global, 12) + call this%grid_lake%set_grid_dimensions( nx_global, ny_global, 10) ! nlevlake=10 (in water_lake.f90: should become nml option?) + call this%grid_lake_soisno%set_grid_dimensions( nx_global, ny_global, 9)! nlevsoil=4; nlevsnow=5 real, dimension( ims:ime,-nlevsnow+1:nlevsoil, jms:jme ) ,INTENT(inout) :: t_soisno3d, h2osoi_ice3d, h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d + call this%grid_lake_soi%set_grid_dimensions( nx_global, ny_global, 4) ! separate from grid_soil in case we want fewer layers under the lake. + call this%grid_lake_soisno_1%set_grid_dimensions(nx_global, ny_global, 10) !soisno+1 (for layer interface depth zi3d) deallocate(temporary_data) @@ -1937,7 +2392,7 @@ module subroutine apply_forcing(this, dt) ! make sure the dictionary is reset to point to the first variable call this%variables_to_force%reset_iterator() - ! No iterate through the dictionary as long as there are more elements present + ! Now iterate through the dictionary as long as there are more elements present do while (this%variables_to_force%has_more_elements()) ! get the next variable var_to_update = this%variables_to_force%next() @@ -1980,6 +2435,16 @@ module subroutine apply_forcing(this, dt) var_to_update = this%w%meta_data var_to_update%data_3d = var_to_update%data_3d + (var_to_update%dqdt_3d * dt%seconds()) + if (associated(this%external_precipitation%data_2d)) then + if (associated(this%accumulated_precipitation%data_2d)) then + this%accumulated_precipitation%data_2d = this%accumulated_precipitation%data_2d + (this%external_precipitation%data_2d * dt%seconds()) + endif + if (associated(this%accumulated_precipitation%data_2dd)) then + this%accumulated_precipitation%data_2dd = this%accumulated_precipitation%data_2dd + (this%external_precipitation%data_2d * dt%seconds()) + endif + endif + + end subroutine !> ----------------------------------------------------------------------------------------------------------------- @@ -2010,10 +2475,11 @@ module subroutine interpolate_external(this, external_conditions, options) if (this_image()==1) print*, " interpolating external var ", trim(varname) , " for initial conditions" external_var =external_conditions%variables%get_var(trim(varname)) ! the external variable - ! if (this_image()==1) print*, "shape swe var: ",(shape(this%snow_water_equivalent%data_2d)) - call geo_interp2d( this%snow_water_equivalent%data_2d, & ! ( this%grid2d% ids : this%grid2d% ide, this%grid2d% jds : this%grid2d% jde) , & - external_var%data_2d, & - external_conditions%geo%geolut ) + if (associated(this%snow_water_equivalent%data_2d)) then + call geo_interp2d( this%snow_water_equivalent%data_2d, & ! ( this%grid2d% ids : this%grid2d% ide, this%grid2d% jds : this%grid2d% jde) , & + external_var%data_2d, & + external_conditions%geo%geolut ) + endif endif @@ -2025,9 +2491,11 @@ module subroutine interpolate_external(this, external_conditions, options) if (this_image()==1) print*, " interpolating external var ", trim(varname) , " for initial conditions" external_var =external_conditions%variables%get_var(trim(varname)) ! the external variable - call geo_interp2d( this%snow_height%data_2d, & ! ( this%grid2d% ids : this%grid2d% ide, this%grid2d% jds : this%grid2d% jde) , & - external_var%data_2d, & - external_conditions%geo%geolut ) + if (associated(this%snow_height%data_2d)) then + call geo_interp2d( this%snow_height%data_2d, & ! ( this%grid2d% ids : this%grid2d% ide, this%grid2d% jds : this%grid2d% jde) , & + external_var%data_2d, & + external_conditions%geo%geolut ) + endif ! ------- external snow height from external swe and density ----------------- elseif (options%parameters%swe_ext/="" .AND. options%parameters%rho_snow_ext/="") then @@ -2036,10 +2504,11 @@ module subroutine interpolate_external(this, external_conditions, options) if (this_image()==1) print*, " interpolating external var ", trim(varname) , " to calculate initial snow height" external_var =external_conditions%variables%get_var(trim(varname)) ! the external variable external_var2 =external_conditions%variables%get_var(trim(options%parameters%swe_ext)) ! the external swe - - call geo_interp2d( this%snow_height%data_2d, & - external_var2%data_2d / external_var%data_2d, & ! ext_swe / rho_snow_swe = hsnow_ext - external_conditions%geo%geolut ) + if (associated(this%snow_height%data_2d)) then + call geo_interp2d( this%snow_height%data_2d, & + external_var2%data_2d / external_var%data_2d, & ! ext_swe / rho_snow_swe = hsnow_ext + external_conditions%geo%geolut ) + endif endif ! ------ soil temperature (2D or 3D)_______________________ @@ -2050,13 +2519,17 @@ module subroutine interpolate_external(this, external_conditions, options) if (this_image()==1) print*, " interpolating external var ", trim(varname) , " for initial conditions" external_var =external_conditions%variables%get_var(trim(varname)) ! the external variable - call geo_interp2d( this%soil_deep_temperature%data_2d, & - external_var%data_2d, & - external_conditions%geo%geolut ) - do i=1,nsoil - this%soil_temperature%data_3d(:,i,:) = this%soil_deep_temperature%data_2d - ! if (this_image()==1) write(*,*) " max soil_temperature in layer",i," on init: ", maxval(this%soil_temperature%data_3d(:,i,:)) - enddo + if (associated(this%soil_deep_temperature%data_2d)) then + + call geo_interp2d( this%soil_deep_temperature%data_2d, & + external_var%data_2d, & + external_conditions%geo%geolut ) + if (associated(this%soil_temperature%data_3d)) then + do i=1,nsoil + this%soil_temperature%data_3d(:,i,:) = this%soil_deep_temperature%data_2d + enddo + endif + endif elseif (options%parameters%tsoil3D_ext/="") then ! if 3D soil is provided we take the lowest level only. (can/should be expanded later) @@ -2065,14 +2538,16 @@ module subroutine interpolate_external(this, external_conditions, options) if (this_image()==1) print*, " interpolating external var ", trim(varname) , " for initial conditions" external_var =external_conditions%variables%get_var(trim(varname)) ! the external variable - call geo_interp2d( this%soil_deep_temperature%data_2d, & - external_var%data_3d(:,size(external_var%data_3d,2),:) , & - external_conditions%geo%geolut ) - do i=1,nsoil - this%soil_temperature%data_3d(:,i,:) = this%soil_deep_temperature%data_2d - ! if (this_image()==1) write(*,*) " max soil_temperature in layer",i," on init: ", maxval(this%soil_temperature%data_3d(:,i,:)) - enddo - + if (associated(this%soil_deep_temperature%data_2d)) then + call geo_interp2d( this%soil_deep_temperature%data_2d, & + external_var%data_3d(:,size(external_var%data_3d,2),:) , & + external_conditions%geo%geolut ) + if (associated(this%soil_temperature%data_3d)) then + do i=1,nsoil + this%soil_temperature%data_3d(:,i,:) = this%soil_deep_temperature%data_2d + enddo + endif + endif endif endif end subroutine @@ -2093,7 +2568,8 @@ module subroutine interpolate_forcing(this, forcing, update) ! temporary to hold the variable to be interpolated to type(variable_t) :: var_to_interpolate ! temporary to hold the forcing variable to be interpolated from - type(variable_t) :: input_data + type(variable_t) :: input_data, forcing_temperature + real, allocatable, dimension(:,:,:) :: potential_temperature ! number of layers has to be used when subsetting for update_pressure (for now) integer :: nz logical :: var_is_u, var_is_v @@ -2101,6 +2577,8 @@ module subroutine interpolate_forcing(this, forcing, update) update_only = .False. if (present(update)) update_only = update + forcing_temperature = forcing%variables%get_var(this%potential_temperature%meta_data%forcing_var) + ! make sure the dictionary is reset to point to the first variable call this%variables_to_force%reset_iterator() @@ -2133,18 +2611,29 @@ module subroutine interpolate_forcing(this, forcing, update) call interpolate_variable(var_to_interpolate%dqdt_3d, input_data, forcing, this, & vert_interp=var_is_not_pressure, var_is_u=var_is_u, var_is_v=var_is_v, nsmooth=this%nsmooth) + + ! because pressure needs to be adjusted for grid points that fall below the forcing lowest level, we adjust it separately. if (.not.var_is_not_pressure) then - nz = min(size(this%geo%z, 2), size(forcing%geo%z, 2)) - call update_pressure(var_to_interpolate%dqdt_3d, forcing%geo%z(:,:nz,:), this%geo%z) + allocate(potential_temperature, mold=var_to_interpolate%dqdt_3d) + ! to improve the pressure adjustment, we need to get forcing potential temperature on the ICAR grid WITHOUT vertical interpolation + call interpolate_variable(potential_temperature, forcing_temperature, forcing, this, & + vert_interp=.False., var_is_u=.False., var_is_v=.False., nsmooth=this%nsmooth) + + call adjust_pressure(var_to_interpolate%dqdt_3d, forcing%geo%z, this%geo%z, potential_temperature) endif else call interpolate_variable(var_to_interpolate%data_3d, input_data, forcing, this, & vert_interp=var_is_not_pressure, var_is_u=var_is_u, var_is_v=var_is_v, nsmooth=this%nsmooth) + ! because pressure needs to be adjusted for grid points that fall below the forcing lowest level, we adjust it separately. if (.not.var_is_not_pressure) then - nz = min(size(this%geo%z, 2), size(forcing%geo%z, 2)) - call update_pressure(var_to_interpolate%data_3d, forcing%geo%z(:,:nz,:), this%geo%z) + allocate(potential_temperature, mold=var_to_interpolate%dqdt_3d) + ! to improve the pressure adjustment, we need to get forcing potential temperature on the ICAR grid WITHOUT vertical interpolation + call interpolate_variable(potential_temperature, forcing_temperature, forcing, this, & + vert_interp=.False., var_is_u=.False., var_is_v=.False., nsmooth=this%nsmooth) + + call adjust_pressure(var_to_interpolate%data_3d, forcing%geo%z, this%geo%z, potential_temperature) endif endif @@ -2153,6 +2642,64 @@ module subroutine interpolate_forcing(this, forcing, update) end subroutine + !> ------------------------------- + !! Adjust a 3d pressure field from the forcing data to the ICAR model grid + !! + !! Because the GCM grid can be very different from the ICAR grid, we first roughly match up + !! the GCM level that is closest to the ICAR level. This has to be done grid cell by gridcell. + !! This still is not ideal, in that it has already subset the GCM levels to the same number as are in ICAR + !! If the GCM has a LOT of fine layers ICAR will not be getting layers higher up in the atmosphere. + !! It would be nice to first use vinterp to get as close as we can, then update pressure only for grid cells below. + !! Uses update_pressure to make a final adjustment (including below the lowest model level). + !! + !! ------------------------------- + subroutine adjust_pressure(pressure, input_z, output_z, potential_temperature) + implicit none + real, intent(inout), dimension(:,:,:) :: pressure !> Pressure on the forcing model levels [Pa] + real, intent(in), dimension(:,:,:) :: input_z, output_z !> z on the forcing and ICAR model levels [m] + real, intent(in), dimension(:,:,:) :: potential_temperature !> potential temperature of the forcing data [K] + + ! store a temporary copy of P and Z from the forcing data after selecting the closest GCM level to the ICAR data + real, allocatable, dimension(:,:,:) :: temp_z, temp_p, temp_t + ! loop counter variables + integer :: k, nz, in_z_idx + integer :: i,j, nx, ny + + allocate(temp_z, temp_p, temp_t, mold=pressure) + + nx = size(pressure, 1) + nz = size(pressure, 2) + ny = size(pressure, 3) + + do j = 1, ny + do i = 1, nx + ! keep track of the nearest z level from the forcing data + in_z_idx = 1 + do k = 1, nz + ! if the ICAR z level is more than half way to the next forcing z level, then increment the GCM z + findz: do while (output_z(i,k,j) > ((input_z(i,in_z_idx,j) + input_z(i,min(nz,in_z_idx+1),j)) / 2)) + in_z_idx = min(nz, in_z_idx + 1) + + if (in_z_idx == nz) then + exit findz + endif + end do findz + ! make a new copy of the pressure and z data from the closest GCM model level + temp_z(i,k,j) = input_z(i,in_z_idx,j) + temp_p(i,k,j) = pressure(i,in_z_idx,j) + temp_t(i,k,j) = exner_function(pressure(i,in_z_idx,j)) * potential_temperature(i,in_z_idx,j) + end do + enddo + enddo + + ! put the updated pressure data into the pressure variable prior to adjustments + pressure = temp_p + + ! update pressure for the change in height between the closest GCM model level and each ICAR level. + call update_pressure(pressure, temp_z, output_z, temp_t) + + deallocate(temp_p, temp_z) + end subroutine !> ------------------------------- !! Interpolate one variable by requesting the forcing data from the boundary data structure then @@ -2442,7 +2989,7 @@ module subroutine calculate_delta_terrain(this, forcing, options) zfr_v(:,i,:) = zfr_v(:,i-1,:) enddo - if ((this_image()==1)) call io_write("zfr_u_ns.nc", "zfr_u", zfr_u(:,:,:) ) ! check in plot + ! if ((this_image()==1)) call io_write("zfr_u_ns.nc", "zfr_u", zfr_u(:,:,:) ) ! check in plot ! if ((this_image()==1).and.(options%parameters%debug)) call io_write("zfr_u_ns.nc", "zfr_u", zfr_u(:,:,:) ) ! check in plot endif diff --git a/src/objects/exchangeable_h.f90 b/src/objects/exchangeable_h.f90 index 63fde31a..1638e452 100644 --- a/src/objects/exchangeable_h.f90 +++ b/src/objects/exchangeable_h.f90 @@ -1,6 +1,6 @@ module exchangeable_interface use assertions_mod, only : assert, assertions - use icar_constants, only : kMAX_NAME_LENGTH + use icar_constants, only : kMAX_NAME_LENGTH, kREAL use grid_interface, only : grid_t use variable_interface, only : variable_t implicit none @@ -23,6 +23,7 @@ module exchangeable_interface logical :: south_boundary=.false. logical :: east_boundary=.false. logical :: west_boundary=.false. + integer :: dtype=kREAL contains private diff --git a/src/objects/exchangeable_obj.f90 b/src/objects/exchangeable_obj.f90 index 4426a4cd..bc0726dd 100644 --- a/src/objects/exchangeable_obj.f90 +++ b/src/objects/exchangeable_obj.f90 @@ -31,6 +31,7 @@ module subroutine const(this, grid, metadata, forcing_var) nullify(this%data_3d) endif + this%dtype = kREAL allocate(this%data_3d(grid%ims:grid%ime, & grid%kms:grid%kme, & grid%jms:grid%jme), stat=err) @@ -124,6 +125,7 @@ module subroutine set_outputdata(this, metadata) this%meta_data%data_3d => this%data_3d this%meta_data%three_d = .True. + this%meta_data%dtype = this%dtype if (.not.allocated(this%meta_data%dim_len)) allocate(this%meta_data%dim_len(3)) this%meta_data%dim_len(1) = size(this%data_3d,1) @@ -173,8 +175,7 @@ module subroutine exchange_v(this) if (.not. this%south_boundary) then start = lbound(this%data_3d,3) nx = size(this%data_3d,1) - - this%halo_north_in(1:nx,:,1:halo_size)[south_neighbor] = this%data_3d(:,:,start+halo_size*2:start+halo_size*2) + this%halo_north_in(1:nx,:,1:halo_size)[south_neighbor] = this%data_3d(:,:,start+halo_size+1:start+halo_size*2) endif if (.not. this%east_boundary) call this%put_east if (.not. this%west_boundary) call this%put_west @@ -186,7 +187,6 @@ module subroutine exchange_v(this) if (.not. this%south_boundary) then start = lbound(this%data_3d,3) nx = size(this%data_3d,1) - this%data_3d(:,:,start:start+halo_size) = this%halo_south_in(:nx,:,1:halo_size+1) endif @@ -213,7 +213,7 @@ module subroutine exchange_u(this) if (.not. this%west_boundary) then start = lbound(this%data_3d,1) ny = size(this%data_3d,3) - this%halo_east_in(1:halo_size,:,1:ny)[west_neighbor] = this%data_3d(start+halo_size*2:start+halo_size*2,:,:) + this%halo_east_in(1:halo_size,:,1:ny)[west_neighbor] = this%data_3d(start+halo_size+1:start+halo_size*2,:,:) endif sync images( neighbors ) diff --git a/src/objects/grid_obj.f90 b/src/objects/grid_obj.f90 index 9ea68627..adf963c7 100644 --- a/src/objects/grid_obj.f90 +++ b/src/objects/grid_obj.f90 @@ -214,8 +214,9 @@ module subroutine set_grid_dimensions(this, nx, ny, nz, nx_extra, ny_extra, halo ! define the halo needed to manage communications between images ! perhaps this should be defined in exchangeable instead though? - this%ns_halo_nx = this%nx !_global / this%ximages + 1 + nx_e ! number of grid cells in x in the ns halo - this%ew_halo_ny = this%ny !_global / this%yimages + 1 + ny_e ! number of grid cells in y in the ew halo + + this%ns_halo_nx = this%nx_global / this%ximages + 1 + nx_e ! number of grid cells in x in the ns halo + this%ew_halo_ny = this%ny_global / this%yimages + 1 + ny_e ! number of grid cells in y in the ew halo end subroutine diff --git a/src/objects/opt_types.f90 b/src/objects/opt_types.f90 index f0888fc1..42519857 100644 --- a/src/objects/opt_types.f90 +++ b/src/objects/opt_types.f90 @@ -131,15 +131,36 @@ module options_types ! ------------------------------------------------ type lsm_options_type character (len=MAXVARLENGTH) :: LU_Categories ! land use categories to read from VEGPARM.tbl (e.g. "USGS") + real :: lh_feedback_fraction ! fraction of latent heat added back to the atmosphere + real :: sh_feedback_fraction ! fraction of sensible heat added back to the atmosphere + real :: sfc_layer_thickness ! thickness of atmosphere to spread heat flux over. + real :: dz_lsm_modification ! ability to change the apparent thickness of the lowest model level to compensate for issues in the LSM? + real :: wind_enhancement ! enhancement to winds in LSM to mitigate low bias in driving models + real :: max_swe ! maximum value for Snow water equivalent (excess above this is removed) integer :: update_interval ! minimum time to let pass before recomputing LSM ~300s (it may be longer) [s] ! the following categories will be set by default if an known LU_Category is used integer :: urban_category ! LU index value that equals "urban" integer :: ice_category integer :: water_category + integer :: lake_category + ! integer :: snow_category ! = ice cat ! use monthly vegetation fraction data, not just a single value logical :: monthly_vegfrac + logical :: monthly_albedo end type lsm_options_type + ! ------------------------------------------------ + ! store Radiation options + ! ------------------------------------------------ + type rad_options_type + integer :: update_interval_rrtmg ! how ofen to update the radiation in seconds. + ! RRTMG scheme is expensive. Default is 1800s (30 minutes) + integer :: icloud ! How RRTMG interact with clouds + logical :: read_ghg ! Eihter use default green house gas mixing ratio, or read the in from file + logical :: use_simple_sw + + end type rad_options_type + ! ------------------------------------------------ ! store output file related options ! ------------------------------------------------ @@ -173,13 +194,14 @@ module options_types character (len=MAXFILELENGTH), dimension(:), allocatable :: boundary_files, ext_wind_files ! variable names from init/BC/wind/... files - character (len=MAXVARLENGTH) :: landvar,latvar,lonvar,uvar,ulat,ulon,vvar,vlat,vlon, & + character (len=MAXVARLENGTH) :: landvar,lakedepthvar,latvar,lonvar,uvar,ulat,ulon,vvar,vlat,vlon, & hgt_hi,lat_hi,lon_hi,ulat_hi,ulon_hi,vlat_hi,vlon_hi, & pvar,pbvar,tvar,qvvar,qcvar,qivar,qrvar,qsvar,qgvar,hgtvar, & - pslvar, psvar, & + pslvar, psvar, snowh_var, & shvar,lhvar,pblhvar,zvar,zbvar,& soiltype_var, soil_t_var,soil_vwc_var,swe_var,soil_deept_var, & - vegtype_var,vegfrac_var, linear_mask_var, nsq_calibration_var, & + vegtype_var,vegfrac_var, albedo_var, vegfracmax_var, lai_var, canwat_var, & + linear_mask_var, nsq_calibration_var, & swdown_var, lwdown_var, & sst_var, rain_var, time_var, sinalpha_var, cosalpha_var, & lat_ext, lon_ext, swe_ext, hsnow_ext, rho_snow_ext, tss_ext, & @@ -194,7 +216,7 @@ module options_types ! Filenames for files to read various physics options from character(len=MAXFILELENGTH) :: mp_options_filename, lt_options_filename, adv_options_filename, & lsm_options_filename, bias_options_filename, block_options_filename, & - cu_options_filename + cu_options_filename, rad_options_filename character(len=MAXFILELENGTH) :: calendar @@ -281,6 +303,7 @@ module options_types real :: agl_cap ! height up to which AGL height is used for vertical interpolation + ! physics parameterization options logical :: use_mp_options logical :: use_cu_options @@ -288,6 +311,7 @@ module options_types logical :: use_block_options logical :: use_adv_options logical :: use_lsm_options + logical :: use_rad_options logical :: use_bias_correction integer :: warning_level ! level of warnings to issue when checking options settings 0-10. diff --git a/src/objects/options_h.f90 b/src/objects/options_h.f90 index 0be4be31..89726c2f 100644 --- a/src/objects/options_h.f90 +++ b/src/objects/options_h.f90 @@ -3,7 +3,7 @@ module options_interface use icar_constants, only : kMAX_STRING_LENGTH, kMAX_STORAGE_VARS use options_types, only : parameter_options_type, physics_type, mp_options_type, lt_options_type, & block_options_type, adv_options_type, lsm_options_type, bias_options_type, & - cu_options_type, output_options_type + cu_options_type, output_options_type, rad_options_type implicit none @@ -45,6 +45,7 @@ module options_interface type(bias_options_type) :: bias_options + type(rad_options_type) :: rad_options contains procedure, public :: init diff --git a/src/objects/options_obj.f90 b/src/objects/options_obj.f90 index 3bf7b59c..07e2f2d5 100644 --- a/src/objects/options_obj.f90 +++ b/src/objects/options_obj.f90 @@ -1,6 +1,9 @@ submodule(options_interface) options_implementation - use icar_constants, only : kMAINTAIN_LON, MAXFILELENGTH, MAXVARLENGTH, MAX_NUMBER_FILES, MAXLEVELS, kNO_STOCHASTIC, kVERSION_STRING, kMAX_FILE_LENGTH, kMAX_NAME_LENGTH, pi + use icar_constants, only : kMAINTAIN_LON, MAXFILELENGTH, MAXVARLENGTH, MAX_NUMBER_FILES, MAXLEVELS, & + kNO_STOCHASTIC, kVERSION_STRING, kMAX_FILE_LENGTH, kMAX_NAME_LENGTH, pi, & + kWATER_LAKE, & + kWIND_LINEAR, kLINEAR_ITERATIVE_WINDS, kITERATIVE_WINDS, kCONSERVE_MASS use io_routines, only : io_newunit use time_io, only : find_timestep_in_file use time_delta_object, only : time_delta_t @@ -14,6 +17,7 @@ use microphysics, only : mp_var_request use advection, only : adv_var_request use wind, only : wind_var_request + use planetary_boundary_layer, only : pbl_var_request use output_metadata, only : get_varname @@ -64,6 +68,7 @@ module subroutine init(this) call lsm_parameters_namelist( this%parameters%lsm_options_filename, this) call cu_parameters_namelist( this%parameters%cu_options_filename, this) call bias_parameters_namelist( this%parameters%bias_options_filename, this) + call rad_parameters_namelist( this%parameters%rad_options_filename, this) if (this%parameters%restart) then ! if (this_image()==1) write(*,*) " (opt) Restart = ", this%parameters%restart @@ -92,10 +97,12 @@ subroutine collect_physics_requests(options) call ra_var_request(options) call lsm_var_request(options) + call pbl_var_request(options) call cu_var_request(options) call mp_var_request(options) call adv_var_request(options) call wind_var_request(options) + call pbl_var_request(options) end subroutine @@ -336,6 +343,50 @@ subroutine options_check(options) stop endif endif + + ! wind calculations almost require fixed_dz_advection settings + if ((options%physics%windtype.eq.kITERATIVE_WINDS).and.(.not.options%parameters%fixed_dz_advection)) then + if (options%parameters%warning_level>3) then + if (this_image()==1) write(*,*) "" + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + if (this_image()==1) write(*,*) "WARNING, wind=3 setting is best used with fixed_dz_advection=.True." + if (this_image()==1) write(*,*) "WARNING, setting fixed_dz_advection=.True." + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + options%parameters%fixed_dz_advection = .True. + endif + if (options%parameters%warning_level==10) then + if (this_image()==1) write(*,*) "Set warning_level<10 to continue" + stop + endif + endif + if (((options%physics%windtype.eq.kWIND_LINEAR).or.(options%physics%windtype.eq.kLINEAR_ITERATIVE_WINDS)).and.(options%parameters%fixed_dz_advection)) then + if (options%parameters%warning_level>3) then + if (this_image()==1) write(*,*) "" + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + if (this_image()==1) write(*,*) "WARNING, wind=1 or 5 setting is best used with fixed_dz_advection=.False." + if (this_image()==1) write(*,*) "WARNING, setting fixed_dz_advection=.False." + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + if (this_image()==1) write(*,*) "" + options%parameters%fixed_dz_advection = .False. + endif + if (options%parameters%warning_level==10) then + if (this_image()==1) write(*,*) "Set warning_level<10 to continue" + stop + endif + endif + if ((options%physics%windtype.eq.0).and.(options%parameters%fixed_dz_advection)) then + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + if (this_image()==1) write(*,*) "WARNING setting fixed_dz_advection=False for wind=0" + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + options%parameters%fixed_dz_advection = .False. + endif + if ((options%physics%windtype.eq.kCONSERVE_MASS).and.(.not.options%parameters%fixed_dz_advection)) then + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + if (this_image()==1) write(*,*) "WARNING setting fixed_dz_advection=True for wind=2" + if (this_image()==1) write(*,*) "WARNING WARNING WARNING" + options%parameters%fixed_dz_advection = .True. + endif + ! if using a real LSM, feedback will probably keep hot-air from getting even hotter, so not likely a problem if ((options%physics%landsurface>1).and.(options%physics%boundarylayer==0)) then if (options%parameters%warning_level>2) then @@ -522,6 +573,7 @@ subroutine physics_namelist(filename,options) water =0! 0 = no open water fluxes, ! 1 = Fluxes from GCM, (needs lsm=1) ! 2 = Simple fluxes (needs SST in forcing data) + ! 3 = WRF's lake model (needs lake depth in hi-res data) mp = 1 ! 0 = no MP, ! 1 = Thompson et al (2008), @@ -532,6 +584,7 @@ subroutine physics_namelist(filename,options) rad = 0 ! 0 = no RAD, ! 1 = Surface fluxes from GCM, (radiative cooling ~1K/day in LSM=1 module), ! 2 = cloud fraction based radiation + radiative cooling + ! 3 = RRTMG conv= 0 ! 0 = no CONV, ! 1 = Tiedke scheme @@ -667,21 +720,21 @@ subroutine var_namelist(filename,options) character(len=*), intent(in) :: filename type(parameter_options_type), intent(inout) :: options integer :: name_unit, i, j - character(len=MAXVARLENGTH) :: landvar,latvar,lonvar,uvar,ulat,ulon,vvar,vlat,vlon,zvar,zbvar, & + character(len=MAXVARLENGTH) :: landvar,lakedepthvar,latvar,lonvar,uvar,ulat,ulon,vvar,vlat,vlon,zvar,zbvar, & hgt_hi,lat_hi,lon_hi,ulat_hi,ulon_hi,vlat_hi,vlon_hi, & pvar,pbvar,tvar,qvvar,qcvar,qivar,qrvar,qgvar,qsvar,hgtvar,shvar,lhvar,pblhvar, & - psvar, pslvar, & + psvar, pslvar, snowh_var, & soiltype_var, soil_t_var,soil_vwc_var,swe_var, soil_deept_var, & - vegtype_var,vegfrac_var, linear_mask_var, nsq_calibration_var, & + vegtype_var,vegfrac_var, vegfracmax_var, albedo_var, lai_var, canwat_var, linear_mask_var, nsq_calibration_var, & swdown_var, lwdown_var, sst_var, rain_var, time_var, sinalpha_var, cosalpha_var, & lat_ext, lon_ext, swe_ext, hsnow_ext, rho_snow_ext, tss_ext, tsoil2D_ext, tsoil3D_ext, z_ext, time_ext namelist /var_list/ pvar,pbvar,tvar,qvvar,qcvar,qivar,qrvar,qgvar,qsvar,hgtvar,shvar,lhvar,pblhvar, & - landvar,latvar,lonvar,uvar,ulat,ulon,vvar,vlat,vlon,zvar,zbvar, & - psvar, pslvar, & + landvar,lakedepthvar,latvar,lonvar,uvar,ulat,ulon,vvar,vlat,vlon,zvar,zbvar, & + psvar, pslvar, snowh_var, & hgt_hi,lat_hi,lon_hi,ulat_hi,ulon_hi,vlat_hi,vlon_hi, & soiltype_var, soil_t_var,soil_vwc_var,swe_var,soil_deept_var, & - vegtype_var,vegfrac_var, linear_mask_var, nsq_calibration_var, & + vegtype_var,vegfrac_var, vegfracmax_var, albedo_var, lai_var, canwat_var, linear_mask_var, nsq_calibration_var, & swdown_var, lwdown_var, sst_var, rain_var, time_var, sinalpha_var, cosalpha_var, & lat_ext, lon_ext, swe_ext, hsnow_ext, rho_snow_ext, tss_ext, tsoil2D_ext, tsoil3D_ext, z_ext, time_ext @@ -717,6 +770,7 @@ subroutine var_namelist(filename,options) pblhvar="" hgt_hi="" landvar="" + lakedepthvar="" lat_hi="" lon_hi="" ulat_hi="" @@ -727,9 +781,14 @@ subroutine var_namelist(filename,options) soil_t_var="" soil_vwc_var="" swe_var="" + snowh_var="" soil_deept_var="" vegtype_var="" vegfrac_var="" + vegfracmax_var="" + albedo_var="" + lai_var="" + canwat_var="" linear_mask_var="" nsq_calibration_var="" rain_var="" @@ -847,6 +906,7 @@ subroutine var_namelist(filename,options) ! variable names for the high resolution domain options%hgt_hi = hgt_hi options%landvar = landvar + options%lakedepthvar = lakedepthvar options%lat_hi = lat_hi options%lon_hi = lon_hi options%ulat_hi = ulat_hi @@ -858,13 +918,18 @@ subroutine var_namelist(filename,options) options%cosalpha_var = cosalpha_var ! soil and vegetation parameters - options%soiltype_var = soiltype_var - options%soil_t_var = soil_t_var - options%soil_vwc_var = soil_vwc_var - options%swe_var = swe_var - options%soil_deept_var = soil_deept_var - options%vegtype_var = vegtype_var - options%vegfrac_var = vegfrac_var + options%soiltype_var = soiltype_var + options%soil_t_var = soil_t_var + options%soil_vwc_var = soil_vwc_var + options%swe_var = swe_var + options%snowh_var = snowh_var + options%soil_deept_var = soil_deept_var + options%vegtype_var = vegtype_var + options%vegfrac_var = vegfrac_var + options%vegfracmax_var = vegfracmax_var + options%albedo_var = albedo_var + options%lai_var = lai_var + options%canwat_var = canwat_var ! optional calibration variables for linear wind solution options%linear_mask_var = linear_mask_var @@ -918,14 +983,14 @@ subroutine parameters_namelist(filename,options) high_res_soil_state, use_agl_height, time_varying_z, t_is_potential, qv_is_spec_humidity, & qv_is_relative_humidity, & use_mp_options, use_lt_options, use_adv_options, use_lsm_options, use_bias_correction, & - use_block_options, use_cu_options + use_block_options, use_cu_options, use_rad_options character(len=MAXFILELENGTH) :: date, calendar, start_date, forcing_start_date, end_date integer :: year, month, day, hour, minute, second character(len=MAXFILELENGTH) :: mp_options_filename, lt_options_filename, & adv_options_filename, lsm_options_filename, & bias_options_filename, block_options_filename, & - cu_options_filename + cu_options_filename, rad_options_filename namelist /parameters/ ntimesteps, wind_iterations, outputinterval, frames_per_outfile, inputinterval, surface_io_only, & @@ -944,7 +1009,8 @@ subroutine parameters_namelist(filename,options) lsm_options_filename, use_lsm_options, & adv_options_filename, use_adv_options, & bias_options_filename, use_bias_correction,& - cu_options_filename, use_cu_options + cu_options_filename, use_cu_options, & + rad_options_filename, use_rad_options ! default parameters surface_io_only = .False. @@ -1004,6 +1070,9 @@ subroutine parameters_namelist(filename,options) use_lsm_options=.False. lsm_options_filename = filename + use_rad_options=.False. + rad_options_filename = filename + use_bias_correction=.False. bias_options_filename = filename @@ -1015,7 +1084,7 @@ subroutine parameters_namelist(filename,options) close(name_unit) if (ideal) then - if (this_image()==1) write(*,*) " Running Idealized simulation (time step does not advance)" + if (this_image()==1) write(*,*) " Running Idealized simulation " endif if ((trim(date)=="").and.(trim(start_date)/="")) date = start_date @@ -1127,7 +1196,6 @@ subroutine parameters_namelist(filename,options) options%cfl_reduction_factor = cfl_reduction_factor options%cfl_strictness = cfl_strictness - options%use_mp_options = use_mp_options options%mp_options_filename = mp_options_filename @@ -1143,6 +1211,9 @@ subroutine parameters_namelist(filename,options) options%use_lsm_options = use_lsm_options options%lsm_options_filename= lsm_options_filename + options%use_rad_options = use_rad_options + options%rad_options_filename= rad_options_filename + options%use_bias_correction = use_bias_correction options%bias_options_filename= bias_options_filename @@ -1595,41 +1666,50 @@ end subroutine cu_parameters_namelist !! Sets the default value for each of three land use categories depending on the LU_Categories input !! !! ------------------------------- - subroutine set_default_LU_categories(urban_category, ice_category, water_category, LU_Categories) + subroutine set_default_LU_categories(options, urban_category, ice_category, water_category, LU_Categories, lake_category) ! if various LU categories were not defined in the namelist (i.e. they == -1) then attempt ! to define default values for them based on the LU_Categories variable supplied. implicit none - integer, intent(inout) :: urban_category, ice_category, water_category + type(options_t), intent(inout)::options + integer, intent(inout) :: urban_category, ice_category, water_category, lake_category character(len=MAXVARLENGTH), intent(in) :: LU_Categories if (trim(LU_Categories)=="MODIFIED_IGBP_MODIS_NOAH") then if (urban_category==-1) urban_category = 13 if (ice_category==-1) ice_category = 15 if (water_category==-1) water_category = 17 + if (lake_category==-1) lake_category = 21 elseif (trim(LU_Categories)=="USGS") then if (urban_category==-1) urban_category = 1 if (ice_category==-1) ice_category = -1 if (water_category==-1) water_category = 16 + ! if (lake_category==-1) lake_category = 16 ! No separate lake category! + if((options%physics%watersurface==kWATER_LAKE) .AND. (this_image()==1)) then + write(*,*) "WARNING: Lake model selected (water=3), but USGS LU-categories has no lake category" + endif elseif (trim(LU_Categories)=="USGS-RUC") then if (urban_category==-1) urban_category = 1 if (ice_category==-1) ice_category = 24 if (water_category==-1) water_category = 16 + if (lake_category==-1) lake_category = 28 ! also note, lakes_category = 28 - write(*,*) "WARNING: not handling lake category (28)" + ! write(*,*) "WARNING: not handling lake category (28)" elseif (trim(LU_Categories)=="MODI-RUC") then if (urban_category==-1) urban_category = 13 if (ice_category==-1) ice_category = 15 if (water_category==-1) water_category = 17 + if (lake_category==-1) lake_category = 21 ! also note, lakes_category = 21 - write(*,*) "WARNING: not handling lake category (21)" + ! write(*,*) "WARNING: not handling lake category (21)" elseif (trim(LU_Categories)=="NLCD40") then if (urban_category==-1) urban_category = 13 if (ice_category==-1) ice_category = 15 ! and 22? - if (water_category==-1) water_category = 17 ! and 21 + ! if (water_category==-1) water_category = 17 ! and 21 'Open Water' + if(options%physics%watersurface==kWATER_LAKE) write(*,*) "WARNING: Lake model selected (water=3), but NLCD40 LU-categories has no lake category" write(*,*) "WARNING: not handling all varients of categories (e.g. permanent_snow=15 is, but permanent_snow_ice=22 is not)" endif @@ -1699,15 +1779,25 @@ subroutine lsm_parameters_namelist(filename, options) integer :: name_unit character(len=MAXVARLENGTH) :: LU_Categories ! Category definitions (e.g. USGS, MODIFIED_IGBP_MODIS_NOAH) + real :: lh_feedback_fraction + real :: sh_feedback_fraction + real :: sfc_layer_thickness + real :: dz_lsm_modification + real :: wind_enhancement + real :: max_swe logical :: monthly_vegfrac ! read in 12 months of vegfrac data + logical :: monthly_albedo ! same for albedo (requires vegfrac be monthly) integer :: update_interval ! minimum number of seconds between LSM updates integer :: urban_category ! index that defines the urban category in LU_Categories integer :: ice_category ! index that defines the ice category in LU_Categories integer :: water_category ! index that defines the water category in LU_Categories + integer :: lake_category ! index that defines the lake category in (some) LU_Categories ! define the namelist - namelist /lsm_parameters/ LU_Categories, update_interval, monthly_vegfrac, & - urban_category, ice_category, water_category + namelist /lsm_parameters/ LU_Categories, lh_feedback_fraction, sh_feedback_fraction, update_interval, & + urban_category, ice_category, water_category, lake_category, & + monthly_vegfrac, monthly_albedo, sfc_layer_thickness, dz_lsm_modification, & + wind_enhancement, max_swe ! because adv_options could be in a separate file if (options%parameters%use_lsm_options) then @@ -1721,11 +1811,21 @@ subroutine lsm_parameters_namelist(filename, options) LU_Categories = "MODIFIED_IGBP_MODIS_NOAH" update_interval = 300 ! 5 minutes monthly_vegfrac = .False. + monthly_albedo = .False. ! default values for these will be set after reading LU_Categories urban_category = -1 ice_category = -1 water_category = -1 + lake_category = -1 + + lh_feedback_fraction = 1.0 + sh_feedback_fraction = 0.625 + sfc_layer_thickness = 400.0 + dz_lsm_modification = 0.5 + wind_enhancement = 1.5 + + max_swe = 1e10 ! read the namelist options if (options%parameters%use_lsm_options) then @@ -1734,21 +1834,83 @@ subroutine lsm_parameters_namelist(filename, options) close(name_unit) endif - call set_default_LU_categories(urban_category, ice_category, water_category, LU_Categories) + call set_default_LU_categories(options, urban_category, ice_category, water_category, LU_Categories, lake_category) ! store everything in the lsm_options structure - lsm_options%LU_Categories = LU_Categories - lsm_options%monthly_vegfrac = monthly_vegfrac - lsm_options%update_interval = update_interval - lsm_options%urban_category = urban_category - lsm_options%ice_category = ice_category - lsm_options%water_category = water_category + lsm_options%LU_Categories = LU_Categories + lsm_options%monthly_vegfrac = monthly_vegfrac + lsm_options%monthly_albedo = monthly_albedo + lsm_options%update_interval = update_interval + lsm_options%urban_category = urban_category + lsm_options%ice_category = ice_category + lsm_options%water_category = water_category + lsm_options%lake_category = lake_category + lsm_options%lh_feedback_fraction = lh_feedback_fraction + lsm_options%sh_feedback_fraction = sh_feedback_fraction + lsm_options%sfc_layer_thickness = sfc_layer_thickness + lsm_options%dz_lsm_modification = dz_lsm_modification + lsm_options%wind_enhancement = wind_enhancement + lsm_options%max_swe = max_swe ! copy the data back into the global options data structure options%lsm_options = lsm_options end subroutine lsm_parameters_namelist + !> ------------------------------- + !! Initialize the radiation model options + !! + !! Reads the rad_parameters namelist or sets default values + !! ------------------------------- + subroutine rad_parameters_namelist(filename, options) + implicit none + character(len=*), intent(in) :: filename + type(options_t), intent(inout)::options + + type(rad_options_type) :: rad_options + integer :: name_unit + + integer :: update_interval_rrtmg ! minimum number of seconds between RRTMG updates + integer :: icloud ! how RRTMG interacts with clouds + logical :: read_ghg + logical :: use_simple_sw + ! define the namelist + namelist /rad_parameters/ update_interval_rrtmg, icloud, read_ghg, use_simple_sw + + + ! because adv_options could be in a separate file + if (options%parameters%use_rad_options) then + if (trim(filename)/=trim(get_options_file())) then + call version_check(filename,options%parameters) + endif + endif + + + ! set default values + update_interval_rrtmg = 1800 ! 30 minutes + icloud = 3 ! effective radius from microphysics scheme + read_ghg = .false. + use_simple_sw = .false. + + ! read the namelist options + if (options%parameters%use_rad_options) then + open(io_newunit(name_unit), file=filename) + read(name_unit,nml=rad_parameters) + close(name_unit) + endif + + ! store everything in the radiation_options structure + rad_options%update_interval_rrtmg = update_interval_rrtmg + rad_options%icloud = icloud + rad_options%read_ghg = read_ghg + rad_options%use_simple_sw = use_simple_sw + + ! copy the data back into the global options data structure + options%rad_options = rad_options + end subroutine rad_parameters_namelist + + + !> ------------------------------- !! Set up model levels, either read from a namelist, or from a default set of values !! @@ -1765,7 +1927,8 @@ subroutine model_levels_namelist(filename,options) real, dimension(45) :: fulldz logical :: space_varying, fixed_dz_advection, dz_modifies_wind, sleve, use_terrain_difference - real :: flat_z_height, terrain_smooth_windowsize, terrain_smooth_cycles, decay_rate_L_topo, decay_rate_S_topo, sleve_n + real :: flat_z_height, decay_rate_L_topo, decay_rate_S_topo, sleve_n + integer :: terrain_smooth_windowsize, terrain_smooth_cycles namelist /z_info/ dz_levels, space_varying, dz_modifies_wind, flat_z_height, fixed_dz_advection, sleve, terrain_smooth_windowsize, terrain_smooth_cycles, decay_rate_L_topo, decay_rate_S_topo, sleve_n, use_terrain_difference diff --git a/src/objects/variable_h.f90 b/src/objects/variable_h.f90 index 74d39125..ce114e9b 100644 --- a/src/objects/variable_h.f90 +++ b/src/objects/variable_h.f90 @@ -2,6 +2,7 @@ module variable_interface use icar_constants, only : kMAX_DIM_LENGTH, kMAX_STRING_LENGTH, kMAX_NAME_LENGTH use grid_interface, only : grid_t use meta_data_interface, only : meta_data_t + use iso_fortran_env, only : real64 implicit none @@ -11,6 +12,7 @@ module variable_interface type, extends(meta_data_t) :: variable_t real, pointer :: data_3d(:,:,:) => null() real, pointer :: data_2d(:,:) => null() + real(kind=real64), pointer :: data_2dd(:,:) => null() real, pointer :: dqdt_3d(:,:,:) => null() ! Note these have to be pointers so they get referenced when variable_t is passed around(?) real, pointer :: dqdt_2d(:,:) => null() ! Note these have to be pointers so they get referenced when variable_t is passed around(?) @@ -23,6 +25,7 @@ module variable_interface character(len=kMAX_NAME_LENGTH) :: forcing_var = "" integer :: n_dimensions + integer :: dtype integer, allocatable :: dim_len(:) character(len=kMAX_DIM_LENGTH), allocatable :: dimensions(:) @@ -53,12 +56,13 @@ module subroutine bcast_var(this, source, start_img, end_img) end subroutine - module subroutine init_grid(this, grid, forcing_var, force_boundaries) + module subroutine init_grid(this, grid, forcing_var, force_boundaries, dtype) implicit none class(variable_t), intent(inout) :: this type(grid_t), intent(in) :: grid character(len=*), intent(in), optional :: forcing_var logical, intent(in), optional :: force_boundaries + integer, intent(in), optional :: dtype end subroutine diff --git a/src/objects/variable_obj.f90 b/src/objects/variable_obj.f90 index ee95f705..0de57e5d 100644 --- a/src/objects/variable_obj.f90 +++ b/src/objects/variable_obj.f90 @@ -1,5 +1,6 @@ submodule(variable_interface) variable_implementation - use co_util, only : broadcast + use icar_constants, only : kREAL, kDOUBLE + use co_util, only : broadcast implicit none @@ -11,15 +12,19 @@ !! Allocates 2d/3d data structure as appropriate !! !! ------------------------------- - module subroutine init_grid(this, grid, forcing_var, force_boundaries) + module subroutine init_grid(this, grid, forcing_var, force_boundaries, dtype) implicit none class(variable_t), intent(inout) :: this type(grid_t), intent(in) :: grid character(len=*), intent(in), optional :: forcing_var logical, intent(in), optional :: force_boundaries + integer, intent(in), optional :: dtype integer :: err + this%dtype = kREAL + if (present(dtype)) this%dtype = dtype + this%dimensions = grid%dimensions this%dim_len = grid%get_dims() @@ -35,11 +40,19 @@ module subroutine init_grid(this, grid, forcing_var, force_boundaries) if (grid%is2d) then this%n_dimensions = 2 if (associated(this%data_2d)) deallocate(this%data_2d) - allocate(this%data_2d(grid%ims:grid%ime, & - grid%jms:grid%jme), stat=err) - if (err /= 0) stop "variable:grid:2d: Allocation request failed" + if (this%dtype == kREAL) then + allocate(this%data_2d(grid%ims:grid%ime, & + grid%jms:grid%jme), stat=err) + if (err /= 0) stop "variable:grid:2d: Allocation request failed" - this%data_2d = 0 + this%data_2d = 0 + elseif (this%dtype == kDOUBLE) then + allocate(this%data_2dd(grid%ims:grid%ime, & + grid%jms:grid%jme), stat=err) + if (err /= 0) stop "variable:grid:2d: Allocation request failed" + + this%data_2dd = 0 + endif if (trim(this%forcing_var) /= "") then allocate(this%dqdt_2d(grid%ims:grid%ime, & diff --git a/src/physics/adv_mpdata.f90 b/src/physics/adv_mpdata.f90 index 4c5e602c..7cde1c39 100644 --- a/src/physics/adv_mpdata.f90 +++ b/src/physics/adv_mpdata.f90 @@ -14,152 +14,162 @@ module adv_mpdata private real,dimension(:,:,:),allocatable::U_m,V_m,W_m integer :: order - + public:: mpdata, mpdata_init public:: advect3d ! for test_mpdata testing only! - + contains subroutine flux1(l,r,U,f) ! Calculate the donor cell flux function - ! l = left gridcell scalar + ! l = left gridcell scalar ! r = right gridcell scalar ! U = Courant number (u*dt/dx) - ! + ! ! If U is positive, return l*U if U is negative return r*U - ! By using the mathematical form instead of the logical form, + ! By using the mathematical form instead of the logical form, ! we can run on the entire grid simultaneously, and avoid branches ! arguments implicit none real, dimension(:), intent(in) :: l,r,U real, dimension(:), intent(inout) :: f - + ! main code f= ((U+ABS(U)) * l + (U-ABS(U)) * r)/2 end subroutine flux1 - - subroutine upwind_advection(qin, u, v, w, q, dx,dz,nx,nz,ny,jaco) + + subroutine upwind_advection(qin, u, v, w, rho, q, dz, ims,ime,kms,kme,jms,jme,jaco) implicit none - real,dimension(1:nx,1:nz,1:ny), intent(in) :: qin - real,dimension(1:nx-1,1:nz,1:ny),intent(in) :: u - real,dimension(1:nx,1:nz,1:ny-1),intent(in) :: v - real,dimension(1:nx,1:nz,1:ny), intent(in) :: w - real,dimension(1:nx,1:nz,1:ny), intent(inout) :: q - real,dimension(1:nx,1:nz,1:ny), intent(in) :: jaco - real,dimension(1:nx,1:nz,1:ny), intent(in) :: dz - integer, intent(in) :: ny,nz,nx - real, intent(in) :: dx - + real, dimension(ims:ime, kms:kme,jms:jme), intent(in) :: qin + real, dimension(ims+1:ime, kms:kme,jms:jme), intent(in) :: u + real, dimension(ims:ime, kms:kme,jms+1:jme), intent(in) :: v + real, dimension(ims:ime, kms:kme,jms:jme), intent(in) :: w + real, dimension(ims:ime, kms:kme,jms:jme), intent(in) :: rho + real, dimension(ims:ime, kms:kme,jms:jme), intent(inout) :: q + real, dimension(ims:ime, kms:kme,jms:jme), intent(in) :: jaco, dz + integer, intent(in) :: ims,ime,kms,kme,jms,jme + ! interal parameters integer :: i - real, dimension(1:nx-1,1:nz) :: f1 ! there used to be an f2 to store f[x+1] - real, dimension(1:nx-2,1:nz) :: f3,f4 - real, dimension(1:nx-2,1:nz-1) ::f5 - !$omp parallel shared(qin,q,u,v,w) firstprivate(nx,ny,nz) private(i,f1,f3,f4,f5) - !$omp do schedule(static) - do i=1,ny + real, dimension(ims:ime-1,kms:kme) :: f1 + real, dimension(ims:ime-2,kms:kme) :: f3,f4 + real, dimension(ims:ime-2,kms:kme-1) :: f5 + + ! !$omp parallel shared(qin,q,u,v,w) firstprivate(nx,ny,nz) private(i,f1,f3,f4,f5) + ! !$omp do schedule(static) + do i=jms,jme q(:,:,i)=qin(:,:,i) enddo - !$omp end do - !$omp barrier - !$omp do schedule(static) - do i=2,ny-1 + + ! !$omp end do + ! !$omp barrier + ! !$omp do schedule(static) + do i=jms+1,jme-1 ! by manually inlining the flux2 call we should remove extra array copies that the compiler doesn't remove. ! equivalent flux2 calls are left in for reference (commented) to restore recall that f1,f3,f4... arrays should be 3D : n x m x 1 - ! calculate fluxes between grid cells - ! call flux2(qin(1:nx-1,:,i), qin(2:nx,:,i), u(1:nx-1,:,i), nx-1,nz, 1,f1) ! f1 = Ux0 and Ux1 - ! call flux2(qin(2:nx-1,:,i), qin(2:nx-1,:,i+1), v(2:nx-1,:,i), nx-2,nz, 1,f3) ! f3 = Vy1 - ! call flux2(qin(2:nx-1,:,i-1), qin(2:nx-1,:,i), v(2:nx-1,:,i-1), nx-2,nz, 1,f4) ! f4 = Vy0 - ! call flux2(qin(2:nx-1,1:nz-1,i),qin(2:nx-1,2:nz,i),w(2:nx-1,1:nz-1,i),nx-2,nz-1,1,f5) ! f5 = Wz0 and Wz1 - f1= ((u(1:nx-1,:,i) + ABS(u(1:nx-1,:,i))) * qin(1:nx-1,:,i) + & - (u(1:nx-1,:,i) - ABS(u(1:nx-1,:,i))) * qin(2:nx,:,i)) / 2 - f3= ((v(2:nx-1,:,i) + ABS(v(2:nx-1,:,i))) * qin(2:nx-1,:,i) + & - (v(2:nx-1,:,i) - ABS(v(2:nx-1,:,i))) * qin(2:nx-1,:,i+1)) / 2 + f1= ((u(ims+1:ime,:,i) + ABS(u(ims+1:ime,:,i))) * qin(ims:ime-1,:,i) + & + (u(ims+1:ime,:,i) - ABS(u(ims+1:ime,:,i))) * qin(ims+1:ime,:,i)) / 2 + + f3= ((v(ims+1:ime-1,:,i+1) + ABS(v(ims+1:ime-1,:,i+1))) * qin(ims+1:ime-1,:,i) + & + (v(ims+1:ime-1,:,i+1) - ABS(v(ims+1:ime-1,:,i+1))) * qin(ims+1:ime-1,:,i+1)) / 2 - f4= ((v(2:nx-1,:,i-1) + ABS(v(2:nx-1,:,i-1))) * qin(2:nx-1,:,i-1) + & - (v(2:nx-1,:,i-1) - ABS(v(2:nx-1,:,i-1))) * qin(2:nx-1,:,i)) / 2 + f4= ((v(ims+1:ime-1,:,i) + ABS(v(ims+1:ime-1,:,i))) * qin(ims+1:ime-1,:,i-1) + & + (v(ims+1:ime-1,:,i) - ABS(v(ims+1:ime-1,:,i))) * qin(ims+1:ime-1,:,i)) / 2 + + f5= ((w(ims+1:ime-1,kms:kme-1,i) + ABS(w(ims+1:ime-1,kms:kme-1,i))) * qin(ims+1:ime-1,kms:kme-1,i) + & + (w(ims+1:ime-1,kms:kme-1,i) - ABS(w(ims+1:ime-1,kms:kme-1,i))) * qin(ims+1:ime-1,kms+1:kme,i)) / 2 - f5= ((w(2:nx-1,1:nz-1,i) + ABS(w(2:nx-1,1:nz-1,i))) * qin(2:nx-1,1:nz-1,i) + & - (w(2:nx-1,1:nz-1,i) - ABS(w(2:nx-1,1:nz-1,i))) * qin(2:nx-1,2:nz,i)) / 2 - ! if (options%parameters%advect_density) then - ! ! perform horizontal advection - ! q(2:nx-1,:,i) = q(2:nx-1,:,i) - ((f1(2:nx-1,:) - f1(1:nx-2,:)) + (f3 - f4)) & - ! / rho(2:nx-1,:,i) / dz(2:nx-1,:,i) - ! ! then vertical - ! ! (order doesn't matter because fluxes f1-6 are calculated before applying them) - ! ! add fluxes to middle layers - ! q(2:nx-1,2:nz-1,i) = q(2:nx-1,2:nz-1,i) - (f5(:,2:nz-1) - f5(:,1:nz-2)) & - ! / rho(2:nx-1,2:nz-1,i) / dz(2:nx-1,2:nz-1,i) - ! ! add fluxes to bottom layer - ! q(2:nx-1,1,i) = q(2:nx-1,1,i) - f5(:,1) & - ! / rho(2:nx-1,1,i) / dz(2:nx-1,1,i) - ! ! add fluxes to top layer - ! q(2:nx-1,nz,i) = q(2:nx-1,nz,i) - (qin(2:nx-1,nz,i) * w(2:nx-1,nz,i)-f5(:,nz-1)) & - ! / rho(2:nx-1,nz,i) / dz(2:nx-1,nz,i) - ! else ! perform horizontal advection, from difference terms - q(2:nx-1,:,i) = q(2:nx-1,:,i) - ((f1(2:nx-1,:) - f1(1:nx-2,:)) + (f3 - f4)) /(dx*dz(2:nx-1,:,i)*jaco(2:nx-1,:,i)) + q(ims+1:ime-1,:,i) = q(ims+1:ime-1,:,i) - ((f1(ims+1:ime-1,:) - f1(ims:ime-2,:)) + (f3 - f4)) & + / (jaco(ims+1:ime-1,:,i)*rho(ims+1:ime-1,:,i)) ! then vertical (order doesn't matter because fluxes f1-6 are calculated before applying them) ! add fluxes to middle layers - q(2:nx-1,2:nz-1,i) = q(2:nx-1,2:nz-1,i) - (f5(:,2:nz-1) - f5(:,1:nz-2)) / (dz(2:nx-1,2:nz-1,i)*jaco(2:nx-1,2:nz-1,i)) + q(ims+1:ime-1,kms+1:kme-1,i) = q(ims+1:ime-1,kms+1:kme-1,i) - (f5(:,kms+1:kme-1) - f5(:,kms:kme-2)) & + / (dz(ims+1:ime-1,kms+1:kme-1,i)*jaco(ims+1:ime-1,kms+1:kme-1,i)*rho(ims+1:ime-1,kms+1:kme-1,i)) ! add fluxes to bottom layer - q(2:nx-1,1,i) = q(2:nx-1,1,i) - f5(:,1) / (dz(2:nx-1,1,i)*jaco(2:nx-1,1,i)) + q(ims+1:ime-1,kms,i) = q(ims+1:ime-1,kms,i) - f5(:,kms) & + / (dz(ims+1:ime-1,kms,i)*jaco(ims+1:ime-1,kms,i) * rho(ims+1:ime-1,kms,i) ) ! add fluxes to top layer - q(2:nx-1,nz,i) = q(2:nx-1,nz,i) - (qin(2:nx-1,nz,i) * w(2:nx-1,nz,i) - f5(:,nz-1)) / (dz(2:nx-1,nz,i)*jaco(2:nx-1,nz,i)) - ! endif - enddo - !$omp end do - !$omp end parallel + q(ims+1:ime-1,kme,i) = q(ims+1:ime-1,kme,i) - (qin(ims+1:ime-1,kme,i) * w(ims+1:ime-1,kme,i) - f5(:,kme-1)) & + / (dz(ims+1:ime-1,kme,i)*jaco(ims+1:ime-1,kme,i)*rho(ims+1:ime-1,kme,i)) + enddo + ! !$omp end do + ! !$omp end parallel + end subroutine upwind_advection - subroutine mpdata_fluxes(q,u,v,w,u2,v2,w2, nx,nz,ny) + subroutine mpdata_fluxes(q,u,v,w,u2,v2,w2, ims,ime,kms,kme,jms,jme,G) implicit none - real, dimension(nx,nz,ny), intent(in) :: q,w - real, dimension(nx-1,nz,ny), intent(in) :: u - real, dimension(nx,nz,ny-1), intent(in) :: v - real, dimension(nx-1,nz,ny), intent(out) :: u2 - real, dimension(nx,nz,ny-1), intent(out) :: v2 - real, dimension(nx,nz,ny), intent(out) :: w2 - integer, intent(in) :: nx,ny,nz - - real, dimension(nx-1) :: rx, lx, denomx - real, dimension(nx) :: r, l, denom + real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: q,w + real, dimension(ims+1:ime,kms:kme,jms:jme), intent(in) :: u + real, dimension(ims:ime,kms:kme,jms+1:jme), intent(in) :: v + real, dimension(ims+1:ime,kms:kme,jms:jme), intent(out) :: u2 + real, dimension(ims:ime,kms:kme,jms+1:jme), intent(out) :: v2 + real, dimension(ims:ime,kms:kme,jms:jme), intent(out) :: w2 + real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: G ! Notation kept from SMOLARKIEWICZ AND MARGOLIN 1998 + integer, intent(in) :: ims, ime, kms, kme, jms, jme + + real, dimension(ims+1:ime) :: rx, lx, denomx + real, dimension(ims:ime) :: r, l, denom, edge_v, edge_q integer :: i, j - - ! This might run faster if tiled over x and y to be more cache friendly. - !$omp parallel shared(q,u,v,w,u2,v2,w2) firstprivate(nx,ny,nz) & - !$omp private(i,j, rx,lx,r,l, denomx,denom) - !$omp do schedule(static) - do i=1,ny - do j=1,nz + + u2 = 0 + v2 = 0 + w2 = 0 + ! This might run faster if tiled over x and y to be more cache friendly. + ! !$omp parallel shared(q,u,v,w,u2,v2,w2) firstprivate(nx,ny,nz) & + ! !$omp private(i,j, rx,lx,r,l, denomx,denom) + ! !$omp do schedule(static) + do i=jms,jme + do j=kms,kme ! ----------------------- ! First compute the U component ! ----------------------- - if ((i>1).and.(i 0) then !((i>jms).and.(i jms) .and. (i < jme) ) then + edge_q(ims+1:ime) = (q(ims+1:ime,j,i+1) - q(ims+1:ime,j,i-1) + & + q(ims:ime-1,j,i+1) - q(ims:ime-1,j,i-1)) / & + (q(ims+1:ime,j,i+1) + q(ims+1:ime,j,i-1) + & + q(ims:ime-1,j,i+1) + q(ims:ime-1,j,i-1)+ 1e-10) + edge_v(ims+1:ime) = (1/4.0)*(v(ims+1:ime,j,i) + v(ims+1:ime,j,i+1) + v(ims:ime-1,j,i) + v(ims:ime-1,j,i+1)) + u2(:,j,i) = u2(:,j,i) - 0.5*u(:,j,i)*edge_v(ims+1:ime)*edge_q(ims+1:ime)/( G(ims+1:ime,j,i) + G(ims:ime-1,j,i) ) + endif + + edge_v = 0 + edge_q = 0 + ! UxW terms + if ( (j > kms) .and. (j < kme) ) then + edge_q(ims+1:ime) = (q(ims+1:ime,j+1,i) - q(ims+1:ime,j-1,i) + & + q(ims:ime-1,j+1,i) - q(ims:ime-1,j-1,i)) / & + (q(ims+1:ime,j+1,i) + q(ims+1:ime,j-1,i) + & + q(ims:ime-1,j+1,i) + q(ims:ime-1,j-1,i)+ 1e-10) + edge_v(ims+1:ime) = (1/4.0)*(w(ims+1:ime,j,i) + w(ims+1:ime,j-1,i) + w(ims:ime-1,j,i) + w(ims:ime-1,j-1,i)) + u2(:,j,i) = u2(:,j,i) - 0.5*u(:,j,i)*edge_v(ims+1:ime)*edge_q(ims+1:ime)/( G(ims+1:ime,j,i) + G(ims:ime-1,j,i) ) + endif endif - + ! next compute the V and W components - if (i==1) then - w2(:,j,i)=0 - else + if (i>jms) then ! ----------------------- ! compute the V component ! ----------------------- @@ -167,221 +177,298 @@ subroutine mpdata_fluxes(q,u,v,w,u2,v2,w2, nx,nz,ny) l=q(:,j,i-1) ! In MPDATA papers A = (r-l)/(r+l) ! compute the denomenator first so we can check that it is not zero - denom=(r + l) - where(denom==0) denom=1e-10 + denom=(r + l + 1e-10) + !where(denom==0) denom=1e-10 ! U2 is the diffusive pseudo-velocity - v2(:,j,i-1) = abs(v(:,j,i-1)) - v(:,j,i-1)**2 - v2(:,j,i-1) = v2(:,j,i-1) * (r-l) / denom - - - ! ----------------------- - ! compute the w component - ! ----------------------- - if (i==ny) then - w2(:,j,i)=0 - else - if (j kms) .and. (j < kme) ) then + edge_q = (q(:,j+1,i-1) - q(:,j-1,i) + & + q(:,j+1,i) - q(:,j-1,i-1)) / & + (q(:,j+1,i-1) + q(:,j-1,i) + & + q(:,j+1,i) + q(:,j-1,i-1)+ 1e-10) + edge_v = (1/4.0)*(w(:,j,i) + w(:,j-1,i) + w(:,j,i-1) + w(:,j-1,i-1)) + v2(:,j,i) = v2(:,j,i) - 0.5*v(:,j,i)*edge_v*edge_q/( G(:,j,i) + G(:,j,i-1) ) + endif + endif + + + ! ----------------------- + ! compute the w component + ! ----------------------- + if (j==kme) then + w2(:,j,i)=0 + else + r=q(:,j+1,i) + l=q(:,j,i) + ! In MPDATA papers A = (r-l)/(r+l) + ! compute the denomenator first so we can check that it is not zero + denom=(r + l + 1e-10) + !where(denom==0) denom=1e-10 + ! U2 is the diffusive pseudo-velocity + w2(:,j,i) = abs(w(:,j,i))*(1-abs(w(:,j,i))/(0.5* ( G(:,j+1,i) + G(:,j,i) ))) + w2(:,j,i) = w2(:,j,i) * (r-l) / denom + + edge_v = 0 + edge_q = 0 + !WxU terms + edge_q(ims+1:ime-1) = (q(ims+2:ime,j+1,i) - q(ims:ime-2,j,i) + & + q(ims+2:ime,j,i) - q(ims:ime-2,j+1,i)) / & + (q(ims+2:ime,j,i) + q(ims+2:ime,j+1,i) + & + q(ims:ime-2,j,i) + q(ims:ime-2,j+1,i)+ 1e-10) + edge_v(ims+1:ime-1) = (1/4.0)* & + (u(ims+2:ime,j,i) + u(ims+2:ime,j+1,i) + u(ims+1:ime-1,j,i) + u(ims+1:ime-1,j+1,i)) + w2(:,j,i) = w2(:,j,i) - 0.5*w(:,j,i)*edge_v*edge_q/( G(:,j+1,i) + G(:,j,i) ) + + edge_v = 0 + edge_q = 0 + ! WxV terms + if ( (i > jms) .and. (i < jme) ) then + edge_q = (q(:,j+1,i+1) - q(:,j,i-1) + & + q(:,j,i+1) - q(:,j+1,i-1)) / & + (q(:,j,i+1) + q(:,j+1,i-1) + & + q(:,j+1,i+1) + q(:,j,i-1)+ 1e-10) + edge_v = (1/4.0)*(v(:,j,i) + v(:,j+1,i) + v(:,j,i+1) + v(:,j+1,i+1)) + w2(:,j,i) = w2(:,j,i) - 0.5*w(:,j,i)*edge_v*edge_q/( G(:,j+1,i) + G(:,j,i) ) endif - endif end do end do - !$omp end do - !$omp end parallel - + ! !$omp end do + ! !$omp end parallel + end subroutine mpdata_fluxes - subroutine flux_limiter(q, q2, u,v,w, nx,nz,ny) + subroutine flux_limiter(q, q2, u,v,w, ims,ime,kms,kme,jms,jme) implicit none - real,dimension(1:nx,1:nz,1:ny), intent(in) :: q, q2 - real,dimension(1:nx-1,1:nz,1:ny),intent(inout) :: u - real,dimension(1:nx,1:nz,1:ny-1),intent(inout) :: v - real,dimension(1:nx,1:nz,1:ny), intent(inout) :: w - integer, intent(in) :: nx,nz,ny - - integer :: i,j,k,n + real,dimension(ims:ime,kms:kme,jms:jme), intent(in) :: q, q2 + real,dimension(ims:ime-1,kms:kme,jms:jme),intent(inout) :: u + real,dimension(ims:ime,kms:kme,jms:jme-1),intent(inout) :: v + real,dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: w + integer, intent(in) :: ims, ime, kms, kme, jms, jme + + integer :: i,j,k,n,n_s real, dimension(:), pointer :: q1, U2, l, f ! q1 = q after applying previous iteration advection ! l = q before applying previous iteration ! U2 is the anti-diffusion pseudo-velocity ! f is the first pass calculation of MPDATA fluxes - real, dimension(nx), target :: q1x,lx - real, dimension(nx-1), target :: fx, U2x - real, dimension(ny), target :: q1y,ly - real, dimension(ny-1), target :: fy, U2y - real, dimension(nz), target :: q1z,lz - real, dimension(nz-1), target :: fz, U2z + real, dimension(ims:ime), target :: q1x,lx + real, dimension(ims:ime-1), target :: fx, U2x + real, dimension(jms:jme), target :: q1y,ly + real, dimension(jms:jme-1), target :: fy, U2y + real, dimension(kms:kme), target :: q1z,lz + real, dimension(kms:kme-1), target :: fz, U2z logical :: flux_is_w - + real :: qmax_i,qmin_i,qmax_i2,qmin_i2 real :: beta_in_i, beta_out_i, beta_in_i2, beta_out_i2 real :: fin_i, fout_i, fin_i2, fout_i2 - - ! NOTE: before inclusion of FCT_core the following variables must be setup: + + ! NOTE: before inclusion of FCT_core the following variables must be setup: ! q1 and l (l=q0) - !$omp parallel shared(q2,q,u,v,w) firstprivate(nx,ny,nz) default(private) + !$omp parallel shared(q2,q,u,v,w) firstprivate(ims,ime,kms,kme,jms,jme) default(private) !$omp do schedule(static) - do j=2,ny-1 + do j=jms+1,jme-1 flux_is_w=.False. - n=nx q1=>q1x l =>lx U2=>U2x f=>fx - do k=1,nz + n=ime + n_s=ims + do k=kms,kme ! setup u q1=q2(:,k,j) U2=u(:,k,j) l =q(:,k,j) - call flux1(q1(1:n-1),q1(2:n),U2,f) - + call flux1(q1(ims:ime-1),q1(ims+1:ime),U2,f) + include "adv_mpdata_FCT_core.f90" u(:,k,j)=U2 end do - - n=nz + q1=>q1z l =>lz U2=>U2z f=>fz + n=kme + n_s=kms flux_is_w=.True. - do k=2,nx-1 + do k=ims+1,ime-1 ! setup w q1=q2(k,:,j) - U2=w(k,1:n-1,j) + U2=w(k,kms:kme-1,j) l =q(k,:,j) - call flux1(q1(1:n-1),q1(2:n),U2,f) + call flux1(q1(kms:kme-1),q1(kms+1:kme),U2,f) ! NOTE: need to check this a little more include "adv_mpdata_FCT_core.f90" - w(k,1:n-1,j)=U2 - w(k,n,j)=0 + w(k,kms:kme-1,j)=U2 + w(k,kme,j)=0 end do - + end do !$omp end do - + flux_is_w=.False. - n=ny q1=>q1y l =>ly U2=>U2y f=>fy + n=jme + n_s=jms ! NOTE: This it typically not the correct order for the loop variables ! but in this case it permits parallelization over a larger number (nx instead of nz) ! and because all data are copied from an oddly spaced grid regardless, it *probably* doesn't slow it down ! I'd like to re-write the v-flux delimiter to operate on all x simulataneously at some point... !$omp do - do j=1,nx - do k=1,nz + do j=ims,ime + do k=kms,kme q1=q2(j,k,:) U2=v(j,k,:) l =q(j,k,:) - call flux1(q1(1:n-1),q1(2:n),U2,f) - + call flux1(q1(jms:jme-1),q1(jms+1:jme),U2,f) + include "adv_mpdata_FCT_core.f90" v(j,k,:)=U2 end do end do !$omp end do !$omp end parallel - + end subroutine flux_limiter - subroutine advect3d(q,u,v,w,rho,dz,dx,nx,nz,ny,jaco,options,err) + subroutine advect3d(q,rho,ims,ime,kms,kme,jms,jme,jaco,dz,options) implicit none - real,dimension(1:nx,1:nz,1:ny), intent(inout) :: q - real,dimension(1:nx-1,1:nz,1:ny),intent(in) :: u - real,dimension(1:nx,1:nz,1:ny-1),intent(in) :: v - real,dimension(1:nx,1:nz,1:ny), intent(in) :: w - real,dimension(1:nx,1:nz,1:ny), intent(in) :: rho - real,dimension(1:nx,1:nz,1:ny), intent(in) :: dz - integer, intent(in) :: ny,nz,nx - real,dimension(1:nx,1:nz,1:ny), intent(in) :: jaco + real,dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: q + real,dimension(ims:ime,kms:kme,jms:jme), intent(in) :: rho + integer, intent(in) :: ims,ime,kms,kme,jms,jme + real,dimension(ims:ime,kms:kme,jms:jme), intent(in) :: jaco,dz type(options_t), intent(in)::options - integer, intent(inout) :: err - real, intent(in) :: dx ! used for intermediate values in the mpdata calculation - real,dimension(1:nx,1:nz,1:ny) :: q2 - real,dimension(1:nx-1,1:nz,1:ny) :: u2 - real,dimension(1:nx,1:nz,1:ny-1) :: v2 - real,dimension(1:nx,1:nz,1:ny) :: w2 - + real,dimension(ims:ime,kms:kme,jms:jme) :: q2 + real,dimension(ims+1:ime,kms:kme,jms:jme) :: u2 + real,dimension(ims:ime,kms:kme,jms+1:jme) :: v2 + real,dimension(ims:ime,kms:kme,jms:jme) :: w2 + integer :: iord, i - + do iord=1,options%adv_options%mpdata_order if (iord==1) then - call upwind_advection(q, u, v, w, q2, dx,dz,nx,nz,ny,jaco) + call upwind_advection(q, U_m, V_m, W_m, rho, q2,dz,ims,ime,kms,kme,jms,jme,jaco) else - call mpdata_fluxes(q2, u, v, w, u2,v2,w2, nx,nz,ny) - if (this_image()==100) write(*,*) maxval(u2) - if ( (sum(abs(u2))+sum(abs(v2))+sum(abs(w2)) < 0.01)) write(*,*) "no ADV corr--1" - + ! Due to an uneven vertical grid spacing, W_m is not normalized by dz, because this causes problems in + ! advection code. However, pseudo-velocity expects, all velocities normalized by time and dx/z + ! so do that here before passing to pseudo-velocity calculations + call mpdata_fluxes(q2, U_m, V_m, (W_m/dz), u2,v2,w2, ims,ime,kms,kme,jms,jme,(jaco*rho)) + ! and un-normalize, since upwind advection scheme includes dz + ! Since pseudo-velocities cannot be gaurenteed to be non-divergent, we assume worst-case and multiply by 0.5 to + ! ensure stability (from Smolarkiewicz 1984, after Eq. 24) + u2 = u2*0.5 + v2 = v2*0.5 + w2 = w2*0.5*dz if (options%adv_options%flux_corrected_transport) then - call flux_limiter(q, q2, u2,v2,w2, nx,nz,ny) + call flux_limiter(q, q2, u2,v2,w2, ims,ime,kms,kme,jms,jme) endif - if ( (sum(abs(u2))+sum(abs(v2))+sum(abs(w2)) < 0.01)) write(*,*) "no ADV corr--2" - call upwind_advection(q2, u2, v2, w2, q, dx,dz,nx,nz,ny,jaco) + call upwind_advection(q2, u2,v2,w2, rho, q,dz,ims,ime,kms,kme,jms,jme,jaco) endif - - ! + + ! if (iord/=options%adv_options%mpdata_order) then if (iord>1) then - !$omp parallel shared(q,q2) firstprivate(ny) private(i) - !$omp do schedule(static) - do i=1,ny + ! !$omp parallel shared(q,q2) firstprivate(ny) private(i) + ! !$omp do schedule(static) + do i=jms,jme q2(:,:,i)=q(:,:,i) enddo - !$omp end do - !$omp end parallel + ! !$omp end do + ! !$omp end parallel endif - else + else if (iord==1) then - !$omp parallel shared(q,q2) firstprivate(ny) private(i) - !$omp do schedule(static) - do i=1,ny + ! !$omp parallel shared(q,q2) firstprivate(ny) private(i) + ! !$omp do schedule(static) + do i=jms,jme q(:,:,i)=q2(:,:,i) enddo - !$omp end do - !$omp end parallel + ! !$omp end do + ! !$omp end parallel endif - + endif end do - + end subroutine advect3d - + subroutine mpdata_init(domain,options) type(domain_t), intent(in) :: domain type(options_t), intent(in) :: options - + ! originally used to permit the order of dimensions in advection to be rotated order = 0 end subroutine mpdata_init + + + subroutine test_divergence(dz, ims, ime, kms, kme, jms, jme) + implicit none + real, intent(in) :: dz(ims:ime,kms:kme,jms:jme) + integer, intent(in) :: ims, ime, jms, jme, kms, kme + + real, allocatable :: du(:,:), dv(:,:), dw(:,:) + integer :: i,j,k + + allocate(du(ims+1:ime-1,jms+1:jme-1)) + allocate(dv(ims+1:ime-1,jms+1:jme-1)) + allocate(dw(ims+1:ime-1,jms+1:jme-1)) + + do i=ims+1,ime-1 + do j=jms+1,jme-1 + do k=kms,kme + du(i,j) = (U_m(i+1,k,j)-U_m(i,k,j)) + dv(i,j) = (V_m(i,k,j+1)-V_m(i,k,j)) + if (k==kms) then + dw(i,j) = (W_m(i,k,j))/dz(i,k,j) + else + dw(i,j) = (W_m(i,k,j)-W_m(i,k-1,j))/dz(i,k,j) + endif + if (abs(du(i,j) + dv(i,j) + dw(i,j)) > 1e-3) then + print*, this_image(), i,k,j , abs(du(i,j) + dv(i,j) + dw(i,j)) + print*, "Winds are not balanced on entry to advect" + !error stop + endif + enddo + enddo + enddo + end subroutine test_divergence + ! primary entry point, advect all scalars in domain subroutine mpdata(domain,options,dt) implicit none type(domain_t),intent(inout)::domain type(options_t), intent(in)::options real,intent(in)::dt - + + real, allocatable, dimension(:,:,:) :: rho real::dx - integer::nx,nz,ny,i, error - integer :: ims, ime, jms, jme, kms, kme + integer :: i, ims, ime, jms, jme, kms, kme ims = domain%grid%ims ime = domain%grid%ime @@ -391,9 +478,6 @@ subroutine mpdata(domain,options,dt) kme = domain%grid%kme dx=domain%dx - nx = domain%grid%nx - nz = domain%grid%nz - ny = domain%grid%ny if (.not.allocated(domain%advection_dz)) then allocate(domain%advection_dz(ims:ime,kms:kme,jms:jme)) @@ -401,45 +485,41 @@ subroutine mpdata(domain,options,dt) domain%advection_dz(:,i,:) = options%parameters%dz_levels(i) enddo endif - + ! if this if the first time we are called, we need to allocate the module level arrays if (.not.allocated(U_m)) then - allocate(U_m(nx-1,nz,ny)) - allocate(V_m(nx,nz,ny-1)) - allocate(W_m(nx,nz,ny)) + allocate(U_m (ims+1:ime,kms:kme,jms:jme )) + allocate(V_m (ims:ime, kms:kme,jms+1:jme)) + allocate(W_m (ims:ime, kms:kme,jms:jme )) + endif + + allocate(rho(ims:ime, kms:kme,jms:jme )) + rho = 1 + if (options%parameters%advect_density) rho = domain%density%data_3d + + U_m = domain%u%data_3d(ims+1:ime,:,:) * dt * (rho(ims+1:ime,:,:)+rho(ims:ime-1,:,:))*0.5 * & + domain%jacobian_u(ims+1:ime,:,:) / dx + V_m = domain%v%data_3d(:,:,jms+1:jme) * dt * (rho(:,:,jms+1:jme)+rho(:,:,jms:jme-1))*0.5 * & + domain%jacobian_v(:,:,jms+1:jme) / dx + W_m(:,kms:kme-1,:) = domain%w%data_3d(:,kms:kme-1,:) * dt * domain%jacobian_w(:,kms:kme-1,:) * & + (rho(:,kms+1:kme,:)+rho(:,kms:kme-1,:)) * 0.5 + W_m(:,kme,:) = domain%w%data_3d(:,kme,:) * dt * domain%jacobian_w(:,kme,:) * rho(:,kme,:) + + if (options%parameters%debug) then + call test_divergence(domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme) endif -! calculate U,V,W normalized for dt/dx - !if (options%advect_density) then - ! U_m=domain%ur(2:nx,:,:)*(dt/dx**2) - ! V_m=domain%vr(:,:,2:ny)*(dt/dx**2) -! note, even though dz!=dx, W is computed from the divergence in U/V so it is scaled by dx/dz already - ! W_m=domain%wr*(dt/dx**2) - !else - U_m = domain%u%data_3d(ims+1:ime,:,:) * ((domain%advection_dz(ims:ime-1,:,:)+domain%advection_dz(ims+1:ime,:,:))/2 * dt) * domain%jacobian_u(ims+1:ime,:,:) - V_m = domain%v%data_3d(:,:,jms+1:jme) * ((domain%advection_dz(:,:,jms:jme-1)+domain%advection_dz(:,:,jms+1:jme))/2 * dt) * domain%jacobian_v(:,:,jms+1:jme) - W_m = domain%w%data_3d * dt - !Because Jacobian is defined on mass-grid, need to make assumption about first level (ground) - W_m(:,kms,:) = W_m(:,kms,:) * domain%jacobian(:,kms,:) - W_m(:,kms+1:kme,:) = W_m(:,kms+1:kme,:) * (domain%jacobian(:,kms:kme-1,:) + domain%jacobian(:,kms+1:kme,:))/2 - !endif - - error=0 - - if (options%vars_to_advect(kVARS%water_vapor)>0) call advect3d(domain%water_vapor%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%cloud_water)>0) call advect3d(domain%cloud_water_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%rain_in_air)>0) call advect3d(domain%rain_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%snow_in_air)>0) call advect3d(domain%snow_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%potential_temperature)>0) call advect3d(domain%potential_temperature%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%cloud_ice)>0) call advect3d(domain%cloud_ice_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%graupel_in_air)>0) call advect3d(domain%graupel_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%ice_number_concentration)>0) call advect3d(domain%cloud_ice_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%rain_number_concentration)>0) call advect3d(domain%rain_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%snow_number_concentration)>0) call advect3d(domain%snow_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - if (options%vars_to_advect(kVARS%graupel_number_concentration)>0) call advect3d(domain%graupel_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options,error) - - - order=mod(order+1,3) + if (options%vars_to_advect(kVARS%water_vapor)>0) call advect3d(domain%water_vapor%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%cloud_water)>0) call advect3d(domain%cloud_water_mass%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%rain_in_air)>0) call advect3d(domain%rain_mass%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%snow_in_air)>0) call advect3d(domain%snow_mass%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%potential_temperature)>0) call advect3d(domain%potential_temperature%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%cloud_ice)>0) call advect3d(domain%cloud_ice_mass%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%graupel_in_air)>0) call advect3d(domain%graupel_mass%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%ice_number_concentration)>0) call advect3d(domain%cloud_ice_number%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%rain_number_concentration)>0) call advect3d(domain%rain_number%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%snow_number_concentration)>0) call advect3d(domain%snow_number%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) + if (options%vars_to_advect(kVARS%graupel_number_concentration)>0) call advect3d(domain%graupel_number%data_3d, rho, ims, ime, kms, kme, jms, jme, domain%jacobian, domain%advection_dz, options) end subroutine mpdata end module adv_mpdata diff --git a/src/physics/adv_mpdata_FCT_core.f90 b/src/physics/adv_mpdata_FCT_core.f90 index 887ada1b..072aa6dc 100644 --- a/src/physics/adv_mpdata_FCT_core.f90 +++ b/src/physics/adv_mpdata_FCT_core.f90 @@ -9,7 +9,7 @@ ! ! It is stored in a separate file so that the same code can ! be used for advect_u, advect_v, and advect_w after l, r, etc. are set up -! +! ! ! First Calculate the standard upwind advection ! call flux1(l,r,U2,f) ! @@ -40,14 +40,14 @@ ! Fluxes are added to the original scalar field in the advect_u and advect_v subroutines -! This is the Flux Corrected Transport option described in : +! This is the Flux Corrected Transport option described in : ! Smolarkiewicz and Grabowski (1990) J. of Comp. Phys. v86 p355-375 -! for now at least this is in a loop instead of vectorized. I'm not sure how easy this would be to vectorize. - do i=1,n-1 +! for now at least this is in a loop instead of vectorized. I'm not sure how easy this would be to vectorize. + do i=n_s,n-1 ! first find the min and max values allowable in the final field based on the initial (stored in l) and upwind (q1) fields ! min and max are taken from the grid cells on either side of the flux cell wall to be corrected - if (i==1) then + if (i==n_s) then ! l still equals q0 qmax_i=max(q1(i),q1(i+1),l(i),l(i+1)) qmin_i=min(q1(i),q1(i+1),l(i),l(i+1)) @@ -66,10 +66,10 @@ qmax_i2=max(q1(i),q1(i+1),l(i)) qmin_i2=min(q1(i),q1(i+1),l(i)) endif - + ! next compute the total fluxes into and out of the upwind and downwind cells ! these are the fluxes into and out of the "left-hand" cell (which is just the previous "right-hand" cell) - if (i/=1) then + if (i/=n_s) then fin_i = fin_i2 fout_i = fout_i2 else @@ -81,9 +81,9 @@ fin_i = 0 fout_i = 0 endif - + endif - + ! these are the fluxes into and out of the "right-hand" cell if (i/=(n-1)) then fin_i2 = max(0.,f(i)) - min(0.,f(i+1)) @@ -98,19 +98,20 @@ fout_i2 = 0 endif endif - + ! if wind is left to right we limit based on flow out of the left cell and into the right cell if (U2(i)>0) then beta_out_i = (q1(i)-qmin_i) / (fout_i+1e-15) beta_in_i2 = (qmax_i2-q1(i+1)) / (fin_i2+1e-15) - + U2(i) = min(1.,beta_in_i2, beta_out_i) * U2(i) - + ! if wind is right to left we limit based on flow out of the right cell and into the left cell elseif (U2(i)<0) then beta_in_i = (qmax_i-q1(i)) / (fin_i+1e-15) beta_out_i2 = (q1(i+1)-qmin_i2) / (fout_i2+1e-15) - + U2(i) = min(1.,beta_in_i, beta_out_i2) * U2(i) endif end do + diff --git a/src/physics/advect.f90 b/src/physics/advect.f90 index c1740c91..d5e7876a 100644 --- a/src/physics/advect.f90 +++ b/src/physics/advect.f90 @@ -27,11 +27,14 @@ subroutine upwind_init(domain,options) type(domain_t), intent(in) :: domain type(options_t),intent(in) :: options - integer :: nx, nz, ny + integer :: ims, ime, jms, jme, kms, kme - nx = domain%grid%nx - nz = domain%grid%nz - ny = domain%grid%ny + ims = domain%grid%ims + ime = domain%grid%ime + jms = domain%grid%jms + jme = domain%grid%jme + kms = domain%grid%kms + kme = domain%grid%kme ! if module level arrays are already allocated for some reason, deallocate them first if (allocated(U_m)) deallocate(U_m) @@ -40,10 +43,10 @@ subroutine upwind_init(domain,options) if (allocated(lastqv_m)) deallocate(lastqv_m) ! allocate the module level arrays - allocate(U_m (nx-1,nz,ny )) - allocate(V_m (nx, nz,ny-1)) - allocate(W_m (nx, nz,ny )) - allocate(lastqv_m(nx, nz,ny )) + allocate(U_m (ims+1:ime,kms:kme,jms:jme )) + allocate(V_m (ims:ime, kms:kme,jms+1:jme)) + allocate(W_m (ims:ime, kms:kme,jms:jme )) + allocate(lastqv_m(ims:ime, kms:kme,jms:jme )) ! if (.not.allocated(U_4cu_u)) then ! allocate(U_4cu_u(nx, nz, ny)) @@ -100,37 +103,40 @@ subroutine upwind_var_request(options) ! ! end subroutine flux2 - subroutine advect3d(q,u,v,w,rho,dz,dx,nx,nz,ny,jaco,options) + subroutine advect3d(q,rho_in,dz,ims,ime,kms,kme,jms,jme,jaco,options) + implicit none - real, dimension(1:nx, 1:nz,1:ny), intent(inout) :: q - real, dimension(1:nx, 1:nz,1:ny), intent(in) :: w - real, dimension(1:nx-1,1:nz,1:ny), intent(in) :: u - real, dimension(1:nx, 1:nz,1:ny-1),intent(in) :: v - real, dimension(:, :, :), intent(in) :: rho - real, dimension(:, :, :), intent(in) :: dz - real, intent(in) :: dx - integer, intent(in) :: ny, nz, nx - real, dimension(:, :, :), intent(in) :: jaco + real, dimension(ims:ime, kms:kme,jms:jme), intent(inout) :: q + real, dimension(ims:ime, kms:kme,jms:jme), intent(in) :: rho_in + real, dimension(ims:ime, kms:kme,jms:jme), intent(in) :: dz + integer, intent(in) :: ims, ime, kms, kme, jms, jme + real, dimension(ims:ime, kms:kme,jms:jme), intent(in) :: jaco type(options_t), intent(in)::options ! interal parameters integer :: err, i, j, k - real, dimension(1:nx,1:nz,1:ny) :: qin - real, dimension(1:nx-1,1:nz) :: f1 ! historical note, there used to be an f2 to store f[x+1] - real, dimension(1:nx-2,1:nz) :: f3,f4 - real, dimension(1:nx-2,1:nz-1) :: f5 - - ! Multiply dz by jacobian so that all advection terms will be divided by mass-centered jacobian - - !$omp parallel shared(qin,q,u,v,w,rho,dz,jaco) firstprivate(nx,ny,nz) private(i,f1,f3,f4,f5) - !$omp do schedule(static) - do i=1,ny + real, dimension(ims:ime-1,kms:kme) :: f1 ! historical note, there used to be an f2 to store f[x+1] + real, dimension(ims:ime-2,kms:kme) :: f3,f4 + real, dimension(ims:ime-2,kms:kme-1) :: f5 + real, dimension(ims:ime,kms:kme,jms:jme) :: qin, rho + + rho = 1 + + do i=jms,jme qin(:,:,i)=q(:,:,i) enddo - !$omp end do - !$omp barrier - !$omp do schedule(static) - do i=2,ny-1 + + if (options%parameters%advect_density) rho = rho_in + + + ! !$omp parallel shared(qin,q,u,v,w,rho,dz,jaco) firstprivate(ims,ime,kms,kme,jms,jme) private(i,f1,f3,f4,f5) + ! !$omp do schedule(static) + + + ! !$omp end do + ! !$omp barrier + ! !$omp do schedule(static) + do i=jms+1,jme-1 ! by manually inlining the flux2 call we should remove extra array copies that the compiler doesn't remove. ! equivalent flux2 calls are left in for reference (commented) to restore recall that f1,f3,f4... arrays should be 3D : n x m x 1 ! calculate fluxes between grid cells @@ -138,47 +144,37 @@ subroutine advect3d(q,u,v,w,rho,dz,dx,nx,nz,ny,jaco,options) ! call flux2(qin(2:nx-1,:,i), qin(2:nx-1,:,i+1), v(2:nx-1,:,i), nx-2,nz, 1,f3) ! f3 = Vy1 ! call flux2(qin(2:nx-1,:,i-1), qin(2:nx-1,:,i), v(2:nx-1,:,i-1), nx-2,nz, 1,f4) ! f4 = Vy0 ! call flux2(qin(2:nx-1,1:nz-1,i),qin(2:nx-1,2:nz,i),w(2:nx-1,1:nz-1,i),nx-2,nz-1,1,f5) ! f5 = Wz0 and Wz1 - f1= ((u(1:nx-1,:,i) + ABS(u(1:nx-1,:,i))) * qin(1:nx-1,:,i) + & - (u(1:nx-1,:,i) - ABS(u(1:nx-1,:,i))) * qin(2:nx,:,i)) / 2 - - f3= ((v(2:nx-1,:,i) + ABS(v(2:nx-1,:,i))) * qin(2:nx-1,:,i) + & - (v(2:nx-1,:,i) - ABS(v(2:nx-1,:,i))) * qin(2:nx-1,:,i+1)) / 2 - - f4= ((v(2:nx-1,:,i-1) + ABS(v(2:nx-1,:,i-1))) * qin(2:nx-1,:,i-1) + & - (v(2:nx-1,:,i-1) - ABS(v(2:nx-1,:,i-1))) * qin(2:nx-1,:,i)) / 2 - - f5= ((w(2:nx-1,1:nz-1,i) + ABS(w(2:nx-1,1:nz-1,i))) * qin(2:nx-1,1:nz-1,i) + & - (w(2:nx-1,1:nz-1,i) - ABS(w(2:nx-1,1:nz-1,i))) * qin(2:nx-1,2:nz,i)) / 2 - - ! if (options%parameters%advect_density) then - ! ! perform horizontal advection - ! q(2:nx-1,:,i) = q(2:nx-1,:,i) - ((f1(2:nx-1,:) - f1(1:nx-2,:)) + (f3 - f4)) & - ! / rho(2:nx-1,:,i) / dz(2:nx-1,:,i) - ! ! then vertical - ! ! (order doesn't matter because fluxes f1-6 are calculated before applying them) - ! ! add fluxes to middle layers - ! q(2:nx-1,2:nz-1,i) = q(2:nx-1,2:nz-1,i) - (f5(:,2:nz-1) - f5(:,1:nz-2)) & - ! / rho(2:nx-1,2:nz-1,i) / dz(2:nx-1,2:nz-1,i) - ! ! add fluxes to bottom layer - ! q(2:nx-1,1,i) = q(2:nx-1,1,i) - f5(:,1) & - ! / rho(2:nx-1,1,i) / dz(2:nx-1,1,i) - ! ! add fluxes to top layer - ! q(2:nx-1,nz,i) = q(2:nx-1,nz,i) - (qin(2:nx-1,nz,i) * w(2:nx-1,nz,i)-f5(:,nz-1)) & - ! / rho(2:nx-1,nz,i) / dz(2:nx-1,nz,i) - ! else + f1= ((U_m(ims+1:ime,:,i) + ABS(U_m(ims+1:ime,:,i))) * qin(ims:ime-1,:,i) + & + (U_m(ims+1:ime,:,i) - ABS(U_m(ims+1:ime,:,i))) * qin(ims+1:ime,:,i)) / 2 + + f3= ((V_m(ims+1:ime-1,:,i+1) + ABS(V_m(ims+1:ime-1,:,i+1))) * qin(ims+1:ime-1,:,i) + & + (V_m(ims+1:ime-1,:,i+1) - ABS(V_m(ims+1:ime-1,:,i+1))) * qin(ims+1:ime-1,:,i+1)) / 2 + + f4= ((V_m(ims+1:ime-1,:,i) + ABS(V_m(ims+1:ime-1,:,i))) * qin(ims+1:ime-1,:,i-1) + & + (V_m(ims+1:ime-1,:,i) - ABS(V_m(ims+1:ime-1,:,i))) * qin(ims+1:ime-1,:,i)) / 2 + + f5= ((W_m(ims+1:ime-1,kms:kme-1,i) + ABS(W_m(ims+1:ime-1,kms:kme-1,i))) * qin(ims+1:ime-1,kms:kme-1,i) + & + (W_m(ims+1:ime-1,kms:kme-1,i) - ABS(W_m(ims+1:ime-1,kms:kme-1,i))) * qin(ims+1:ime-1,kms+1:kme,i)) / 2 + + ! perform horizontal advection, from difference terms - q(2:nx-1,:,i) = q(2:nx-1,:,i) - ((f1(2:nx-1,:) - f1(1:nx-2,:)) + (f3 - f4)) /(dx*dz(2:nx-1,:,i)*jaco(2:nx-1,:,i)) + q(ims+1:ime-1,:,i) = q(ims+1:ime-1,:,i) - ((f1(ims+1:ime-1,:) - f1(ims:ime-2,:)) + (f3 - f4)) & + / (jaco(ims+1:ime-1,:,i)*rho(ims+1:ime-1,:,i)) ! then vertical (order doesn't matter because fluxes f1-6 are calculated before applying them) ! add fluxes to middle layers - q(2:nx-1,2:nz-1,i) = q(2:nx-1,2:nz-1,i) - (f5(:,2:nz-1) - f5(:,1:nz-2)) / (dz(2:nx-1,2:nz-1,i)*jaco(2:nx-1,2:nz-1,i)) + q(ims+1:ime-1,kms+1:kme-1,i) = q(ims+1:ime-1,kms+1:kme-1,i) - (f5(:,kms+1:kme-1) - f5(:,kms:kme-2)) & + / (dz(ims+1:ime-1,kms+1:kme-1,i)*jaco(ims+1:ime-1,kms+1:kme-1,i)*rho(ims+1:ime-1,kms+1:kme-1,i)) ! add fluxes to bottom layer - q(2:nx-1,1,i) = q(2:nx-1,1,i) - f5(:,1) / (dz(2:nx-1,1,i)*jaco(2:nx-1,1,i)) + q(ims+1:ime-1,kms,i) = q(ims+1:ime-1,kms,i) - f5(:,kms) & + / (dz(ims+1:ime-1,kms,i)*jaco(ims+1:ime-1,kms,i) * rho(ims+1:ime-1,kms,i) ) ! add fluxes to top layer - q(2:nx-1,nz,i) = q(2:nx-1,nz,i) - (qin(2:nx-1,nz,i) * w(2:nx-1,nz,i) - f5(:,nz-1)) / (dz(2:nx-1,nz,i)*jaco(2:nx-1,nz,i)) - ! endif + q(ims+1:ime-1,kme,i) = q(ims+1:ime-1,kme,i) - (qin(ims+1:ime-1,kme,i) * W_m(ims+1:ime-1,kme,i) - f5(:,kme-1)) & + / (dz(ims+1:ime-1,kme,i)*jaco(ims+1:ime-1,kme,i)*rho(ims+1:ime-1,kme,i)) + + enddo - !$omp end do - !$omp end parallel + ! !$omp end do + ! !$omp end parallel end subroutine advect3d ! subroutine setup_cu_winds(domain, options, dt) @@ -274,37 +270,30 @@ end subroutine advect3d ! end subroutine advect_cu_winds - subroutine test_divergence(u, v, w, dz, dx, jaco_u, jaco_v, jaco_w, ims, ime, jms, jme, kms, kme) + subroutine test_divergence(dz, ims, ime, kms, kme, jms, jme) implicit none - real, intent(in) :: u(ims:ime+1,kms:kme,jms:jme), jaco_u(ims:ime+1,kms:kme,jms:jme) - real, intent(in) :: v(ims:ime,kms:kme,jms:jme+1), jaco_v(ims:ime,kms:kme,jms:jme+1) - real, intent(in) :: w(ims:ime,kms:kme,jms:jme), jaco_w(ims:ime,kms:kme,jms:jme) real, intent(in) :: dz(ims:ime,kms:kme,jms:jme) - real, intent(in) :: dx integer, intent(in) :: ims, ime, jms, jme, kms, kme - real, allocatable :: du(:,:), dv(:,:), dzu(:,:,:), dzv(:,:,:) + real, allocatable :: du(:,:), dv(:,:), dw(:,:) integer :: i,j,k allocate(du(ims+1:ime-1,jms+1:jme-1)) allocate(dv(ims+1:ime-1,jms+1:jme-1)) - allocate(dzv(ims:ime,kms:kme,jms:jme)) - allocate(dzu(ims:ime,kms:kme,jms:jme)) - - dzv = 0 - dzu = 0 - - dzv(:,:,jms+1:jme) = (dz(:,:,jms+1:jme) + dz(:,:,jms:jme-1)) / 2 - dzu(ims+1:ime,:,:) = (dz(ims+1:ime,:,:) + dz(ims:ime-1,:,:)) / 2 + allocate(dw(ims+1:ime-1,jms+1:jme-1)) do i=ims+1,ime-1 do j=jms+1,jme-1 - do k=kms+1,kme - dv(i,j) = (v(i,k,j+1) * jaco_v(i,k,j+1) - v(i,k,j) * jaco_v(i,k,j))/dx - du(i,j) = (u(i+1,k,j) * jaco_u(i+1,k,j) - u(i,k,j) * jaco_u(i,k,j))/dx - - if (abs(du(i,j) + dv(i,j) + (w(i,k,j)*jaco_w(i,k,j)-w(i,k-1,j)*jaco_w(i,k-1,j))/(dz(i,k,j))) > 1e-3) then - print*, this_image(), i,j,k , abs(du(i,j) + dv(i,j) + (w(i,k,j)*jaco_w(i,k,j)-w(i,k-1,j)*jaco_w(i,k-1,j))/(dz(i,k,j))) + do k=kms,kme + du(i,j) = (U_m(i+1,k,j)-U_m(i,k,j)) + dv(i,j) = (V_m(i,k,j+1)-V_m(i,k,j)) + if (k==kms) then + dw(i,j) = (W_m(i,k,j))/dz(i,k,j) + else + dw(i,j) = (W_m(i,k,j)-W_m(i,k-1,j))/dz(i,k,j) + endif + if (abs(du(i,j) + dv(i,j) + dw(i,j)) > 1e-3) then + print*, this_image(), i,k,j , abs(du(i,j) + dv(i,j) + dw(i,j)) print*, "Winds are not balanced on entry to advect" !error stop endif @@ -314,62 +303,57 @@ subroutine test_divergence(u, v, w, dz, dx, jaco_u, jaco_v, jaco_w, ims, ime, jm end subroutine test_divergence - subroutine setup_module_winds(u,v,w, dz, dx, options, dt,jaco,jaco_u,jaco_v, jaco_w) + subroutine setup_module_winds(u,v,w, dx, options, dt,jaco_u,jaco_v, jaco_w,rho_in,ims, ime, kms, kme, jms, jme) implicit none - real, intent(in) :: u(:,:,:) - real, intent(in) :: v(:,:,:) - real, intent(in) :: w(:,:,:) - real, intent(in) :: dz(:,:,:) + real, intent(in) :: u(ims:ime+1,kms:kme,jms:jme), v(ims:ime,kms:kme,jms:jme+1) + real, intent(in) :: w(ims:ime,kms:kme,jms:jme) real, intent(in) :: dx type(options_t), intent(in) :: options real, intent(in) :: dt - real, intent(in) :: jaco(:, :, :) - real, intent(in) :: jaco_u(:, :, :) - real, intent(in) :: jaco_v(:, :, :) - real, intent(in) :: jaco_w(:, :, :) - - integer :: nx, nz, ny, i + real, intent(in) :: jaco_u(ims:ime+1,kms:kme,jms:jme) + real, intent(in) :: jaco_v(ims:ime,kms:kme,jms:jme+1), jaco_w(ims:ime,kms:kme,jms:jme) + real, intent(in) :: rho_in(ims:ime,kms:kme,jms:jme) + integer, intent(in) :: ims, ime, jms, jme, kms, kme - nx = size(w,1) - nz = size(w,2) - ny = size(w,3) + real, dimension(ims:ime,kms:kme,jms:jme) :: rho + integer :: i + ! if this if the first time we are called, we need to allocate the module level arrays ! Could/should be put in an init procedure if (.not.allocated(U_m)) then - allocate(U_m (nx-1,nz,ny )) - allocate(V_m (nx, nz,ny-1)) - allocate(W_m (nx, nz,ny )) - allocate(lastqv_m(nx, nz,ny )) + allocate(U_m (ims+1:ime,kms:kme,jms:jme )) + allocate(V_m (ims:ime, kms:kme,jms+1:jme)) + allocate(W_m (ims:ime, kms:kme,jms:jme )) + allocate(lastqv_m(ims:ime, kms:kme,jms:jme )) endif + + rho = 1 + if (options%parameters%advect_density) rho = rho_in - ! calculate U,V,W normalized for dt/dx (dx**2 for density advection so we can skip a /dx in the actual advection code) - ! if (options%parameters%advect_density) then - ! U_m = domain%ur(2:nx,:,:) * (dt/dx**2) - ! V_m = domain%vr(:,:,2:ny) * (dt/dx**2) - ! W_m = domain%wr * (dt/dx**2) + ! if (options%physics%convection > 0) then + ! print*, "Advection of convective winds not enabled in ICAR >=1.5 yet" + ! stop + ! U_m = (domain%u_cu(2:nx,:,:) + domain%u(2:nx,:,:)) * (dt/dx) + ! V_m = (domain%v_cu(:,:,2:ny) + domain%v(:,:,2:ny)) * (dt/dx) + ! W_m = (domain%w_cu + domain%w) * (dt/dx) + ! call rebalance_cu_winds(U_m,V_m,W_m) ! else - ! if (options%physics%convection > 0) then - ! print*, "Advection of convective winds not enabled in ICAR >=1.5 yet" - ! stop - ! U_m = (domain%u_cu(2:nx,:,:) + domain%u(2:nx,:,:)) * (dt/dx) - ! V_m = (domain%v_cu(:,:,2:ny) + domain%v(:,:,2:ny)) * (dt/dx) - ! W_m = (domain%w_cu + domain%w) * (dt/dx) - ! call rebalance_cu_winds(U_m,V_m,W_m) - ! else - U_m = u(2:nx,:,:) * ((dz(1:nx-1,:,:)+dz(2:nx,:,:))/2 * dt) * jaco_u(2:nx,:,:) - V_m = v(:,:,2:ny) * ((dz(:,:,1:ny-1)+dz(:,:,2:ny))/2 * dt) * jaco_v(:,:,2:ny) - W_m = w * dt * jaco_w - ! endif - ! endif + ! Divide only U and V by dx. This minimizes the number of operations per advection step. W cannot be divided by dz, + ! since non-uniform dz spacing does not allow for the same spacing to be assumed on either side of a k+1/2 interface, + ! as is required for the upwind scheme. + U_m = u(ims+1:ime,:,:) * dt * jaco_u(ims+1:ime,:,:) * (rho(ims+1:ime,:,:)+rho(ims:ime-1,:,:))*0.5 / dx + V_m = v(:,:,jms+1:jme) * dt * jaco_v(:,:,jms+1:jme) * (rho(:,:,jms+1:jme)+rho(:,:,jms:jme-1))*0.5 / dx + W_m(:,kms:kme-1,:) = w(:,kms:kme-1,:) * dt * jaco_w(:,kms:kme-1,:) * (rho(:,kms+1:kme,:)+rho(:,kms:kme-1,:))*0.5 + W_m(:,kme,:) = w(:,kme,:) * dt * jaco_w(:,kme,:) * rho(:,kme,:) + ! endif end subroutine setup_module_winds - subroutine setup_advection_dz(domain, options, nx, ny, nz) + subroutine setup_advection_dz(domain, options) implicit none type(domain_t), intent(inout) :: domain type(options_t), intent(in) :: options - integer, intent(in) :: nx, ny, nz integer :: i, ims, ime, jms, jme, kms, kme ims = domain%grid%ims @@ -385,13 +369,9 @@ subroutine setup_advection_dz(domain, options, nx, ny, nz) return endif - if (options%parameters%fixed_dz_advection) then - do i=kms,kme - domain%advection_dz(:,i,:) = options%parameters%dz_levels(i) - enddo - else - domain%advection_dz = domain%dz_interface%data_3d - endif + do i=kms,kme + domain%advection_dz(:,i,:) = options%parameters%dz_levels(i) + enddo end subroutine setup_advection_dz @@ -404,34 +384,30 @@ subroutine upwind(domain,options,dt) real, intent(in) :: dt real :: dx - integer :: nx, nz, ny, i - - nx = domain%grid%nx - nz = domain%grid%nz - ny = domain%grid%ny + integer :: i - call setup_advection_dz(domain, options, nx,ny,nz) + call setup_advection_dz(domain, options) ! calculate U,V,W normalized for dt/dx (dx**2 for density advection so we can skip a /dx in the actual advection code) - call setup_module_winds(domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, domain%advection_dz, domain%dx, options, dt,domain%jacobian,domain%jacobian_u,domain%jacobian_v,domain%jacobian_w) + call setup_module_winds(domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, domain%dx, options, dt,domain%jacobian_u,domain%jacobian_v,domain%jacobian_w,domain%density%data_3d, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme) ! lastqv_m=domain%qv if (options%parameters%debug) then - call test_divergence(domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, domain%advection_dz, domain%dx, domain%jacobian_u, domain%jacobian_v, domain%jacobian_w, domain%ims, domain%ime, domain%jms, domain%jme, domain%kms, domain%kme) + call test_divergence(domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme) endif - if (options%vars_to_advect(kVARS%water_vapor)>0) call advect3d(domain%water_vapor%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%cloud_water)>0) call advect3d(domain%cloud_water_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%rain_in_air)>0) call advect3d(domain%rain_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%snow_in_air)>0) call advect3d(domain%snow_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%potential_temperature)>0) call advect3d(domain%potential_temperature%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%cloud_ice)>0) call advect3d(domain%cloud_ice_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%graupel_in_air)>0) call advect3d(domain%graupel_mass%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%ice_number_concentration)>0) call advect3d(domain%cloud_ice_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%rain_number_concentration)>0) call advect3d(domain%rain_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%snow_number_concentration)>0) call advect3d(domain%snow_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) - if (options%vars_to_advect(kVARS%graupel_number_concentration)>0) call advect3d(domain%graupel_number%data_3d, U_m,V_m,W_m, domain%density%data_3d, domain%advection_dz, domain%dx, nx,nz,ny, domain%jacobian, options) + if (options%vars_to_advect(kVARS%water_vapor)>0) call advect3d(domain%water_vapor%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%cloud_water)>0) call advect3d(domain%cloud_water_mass%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%rain_in_air)>0) call advect3d(domain%rain_mass%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%snow_in_air)>0) call advect3d(domain%snow_mass%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%potential_temperature)>0) call advect3d(domain%potential_temperature%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%cloud_ice)>0) call advect3d(domain%cloud_ice_mass%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%graupel_in_air)>0) call advect3d(domain%graupel_mass%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%ice_number_concentration)>0) call advect3d(domain%cloud_ice_number%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%rain_number_concentration)>0) call advect3d(domain%rain_number%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%snow_number_concentration)>0) call advect3d(domain%snow_number%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) + if (options%vars_to_advect(kVARS%graupel_number_concentration)>0) call advect3d(domain%graupel_number%data_3d, domain%density%data_3d, domain%advection_dz, domain%ims, domain%ime, domain%kms, domain%kme, domain%jms, domain%jme, domain%jacobian, options) ! if (options%physics%convection > 0) then ! call advect_cu_winds(domain, options, dt) diff --git a/src/physics/cu_bmj.f90 b/src/physics/cu_bmj.f90 new file mode 100644 index 00000000..90fe56c9 --- /dev/null +++ b/src/physics/cu_bmj.f90 @@ -0,0 +1,2203 @@ +!----------------------------------------------------------------------- +! +!WRF:MODEL_LAYER:PHYSICS +! +!----------------------------------------------------------------------- +! + MODULE MODULE_CU_BMJ + ! + !----------------------------------------------------------------------- + ! USE MODULE_MODEL_CONSTANTS + use mod_wrf_constants + ! use options_interface, only : options_t ! for debugging. + !----------------------------------------------------------------------- + ! + REAL,PARAMETER :: & + & DSPC=-3000. & + & ,DTTOP=0.,EFIFC=5.0,EFIMN=0.20,EFMNT=0.70 & + & ,ELIWV=2.683E6,ENPLO=20000.,ENPUP=15000. & + & ,EPSDN=1.05,EPSDT=0. & + & ,EPSNTP=.0001,EPSNTT=.0001,EPSPR=1.E-7 & + & ,EPSUP=1.00 & + & ,FR=1.00,FSL=0.85,FSS=0.85,GAM=0.5,PEPS=1./2.5 & + & ,FUP=0.,FCC=5.00,CRMN=0.14,CRMX=85.0 & + & ,PBM=13000.,PFRZ=15000.,PNO=1000. & + & ,PONE=2500.,PQM=20000. & + & ,PSH=20000.,PSHU=45000. & + & ,RENDP=1./(ENPLO-ENPUP) & + & ,RHLSC=0.00,RHHSC=1.10 & + & ,ROW=1.E3 & + & ,STABDF=0.90,STABDS=0.90 & + & ,STABS=1.0,STRESH=1.10 & + & ,DTSHAL=-1.0,TREL=2400. + ! + REAL,PARAMETER :: DTtrigr=-0.0 & + ,DTPtrigr=DTtrigr*PONE !<-- Average parcel virtual temperature deficit over depth PONE. + !<-- NOTE: CAPEtrigr is scaled by the cloud base temperature (see below) + ! + REAL,PARAMETER :: DSPBFL=-3875.*FR & + & ,DSP0FL=-5875.*FR & + & ,DSPTFL=-1875.*FR & + & ,DSPBFS=-3875. & + & ,DSP0FS=-5875. & + & ,DSPTFS=-1875. + ! + REAL,PARAMETER :: PL=2500.,PLQ=70000.,PH=105000. & + & ,THL=210.,THH=365.,THHQ=325. + ! + INTEGER,PARAMETER :: ITB=76,JTB=134,ITBQ=152,JTBQ=440 + ! + INTEGER,PARAMETER :: ITREFI_MAX=3 + ! + !*** ARRAYS FOR LOOKUP TABLES + ! + REAL,DIMENSION(ITB),PRIVATE,SAVE :: STHE,THE0 + REAL,DIMENSION(JTB),PRIVATE,SAVE :: QS0,SQS + REAL,DIMENSION(ITBQ),PRIVATE,SAVE :: STHEQ,THE0Q + REAL,DIMENSION(ITB,JTB),PRIVATE,SAVE :: PTBL + REAL,DIMENSION(JTB,ITB),PRIVATE,SAVE :: TTBL + REAL,DIMENSION(JTBQ,ITBQ),PRIVATE,SAVE :: TTBLQ + + !*** SHARE COPIES FOR MODULE_BL_MYJPBL + ! + REAL,DIMENSION(JTB) :: QS0_EXP,SQS_EXP + REAL,DIMENSION(ITB,JTB) :: PTBL_EXP + ! + REAL,PARAMETER :: RDP=(ITB-1.)/(PH-PL),RDPQ=(ITBQ-1.)/(PH-PLQ) & + & ,RDQ=ITB-1,RDTH=(JTB-1.)/(THH-THL) & + & ,RDTHE=JTB-1.,RDTHEQ=JTBQ-1. & + & ,RSFCP=1./101300. + ! + REAL,PARAMETER :: AVGEFI=(EFIMN+1.)*0.5 + ! + !----------------------------------------------------------------------- + ! + CONTAINS + ! + !----------------------------------------------------------------------- + SUBROUTINE BMJDRV( & + & IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE & + & ,DT,ITIMESTEP,STEPCU,CCLDFRA,CONVCLD & + & ,RAINCV,PRATEC,CUTOP,CUBOT,KPBL & + & ,TH,T,QV,QCCONV,QICONV,BMJ_RAD_FEEDBACK & + & ,PINT,PMID,PI,RHO,DZ8W & + & ,CP,R,ELWV,ELIV,G,TFRZ,D608 & + & ,CLDEFI,LOWLYR,XLAND,CU_ACT_FLAG & + ! optional + & ,RTHCUTEN,RQVCUTEN & + & ) + !----------------------------------------------------------------------- + IMPLICIT NONE + !----------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE + ! + INTEGER,INTENT(IN) :: ITIMESTEP,STEPCU + ! + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: KPBL,LOWLYR + ! + REAL,INTENT(IN) :: CP,DT,ELIV,ELWV,G,R,TFRZ,D608 + ! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: XLAND + ! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DZ8W & + & ,PI,PINT & + & ,PMID,QV & + & ,RHO,T,TH + ! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CCLDFRA & + ,QCCONV & + ,QICONV + ! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) & + & ,OPTIONAL & + & ,INTENT(INOUT) :: RQVCUTEN,RTHCUTEN + ! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CLDEFI,RAINCV, & + PRATEC,CONVCLD + ! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CUBOT,CUTOP + ! + LOGICAL,INTENT(IN) :: bmj_rad_feedback + LOGICAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CU_ACT_FLAG + + ! + !----------------------------------------------------------------------- + !*** + !*** LOCAL VARIABLES + !*** + !----------------------------------------------------------------------- + INTEGER :: LBOT,LPBL,LTOP + ! + REAL :: DTCNVC,LANDMASK,PCPCOL,PSFC,PTOP + REAL :: PAVG,PWCOL,DQCOL,DQCOLMIN + REAL :: CUMX,QCIS,RRP,PRRT,MCOL,MPVPR,FACTL + INTEGER :: BBOT,TTOP + ! + REAL,DIMENSION(KTS:KTE) :: DPCOL,DQDT,DTDT,PCOL,QCOL,TCOL + REAL,DIMENSION(KTS:KTE) :: PVPR,JPR + ! + INTEGER :: I,J,K,KFLIP,LMH + + !*** Begin debugging convection + REAL :: DELQ,DELT,PLYR + INTEGER :: IMD,JMD + LOGICAL :: PRINT_DIAG + !*** End debugging convection + ! + !----------------------------------------------------------------------- + !*********************************************************************** + !----------------------------------------------------------------------- + ! + !*** PREPARE TO CALL BMJ CONVECTION SCHEME + ! + !----------------------------------------------------------------------- + + !*** Begin debugging convection + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 + PRINT_DIAG=.FALSE. + !*** End debugging convection + + ! + DO J=JTS,JTE + DO I=ITS,ITE + CU_ACT_FLAG(I,J)=.TRUE. + ENDDO + ENDDO + + ! + DTCNVC=DT*STEPCU + ! + DO J=JTS,JTE + DO I=ITS,ITE + ! + DO K=KTS,KTE + DQDT(K)=0. + DTDT(K)=0. + JPR(K)=0. + PVPR(K)=0. + QCCONV(I,K,J)=0. + QICONV(I,K,J)=0. + CCLDFRA(I,K,J)=0. + ENDDO + ! + DQCOL=0. + PWCOL=0. + PCPCOL=0. + DQCOLMIN=0. + RAINCV(I,J)=0. + PRATEC(I,J)=0. + CONVCLD(I,J)=0. + PSFC=PINT(I,LOWLYR(I,J),J) + PTOP=PINT(I,KTE+1,J) ! KTE+1=KME + ! + !*** CONVERT TO BMJ LAND MASK (1.0 FOR SEA; 0.0 FOR LAND) + ! + LANDMASK=XLAND(I,J)-1. + ! + !*** FILL 1-D VERTICAL ARRAYS + !*** AND FLIP DIRECTION SINCE BMJ SCHEME + !*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP + ! + DO K=KTS,KTE + KFLIP=KTE+1-K + ! + !*** CONVERT FROM MIXING RATIO TO SPECIFIC HUMIDITY + ! + QCOL(K)=MAX(EPSQ,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J))) + TCOL(K)=T(I,KFLIP,J) + PCOL(K)=PMID(I,KFLIP,J) + ! DPCOL(K)=PINT(I,KFLIP,J)-PINT(I,KFLIP+1,J) + DPCOL(K)=RHO(I,KFLIP,J)*G*DZ8W(I,KFLIP,J) + ENDDO + ! + !*** LOWEST LAYER ABOVE GROUND MUST ALSO BE FLIPPED + ! + LMH=KTE+1-LOWLYR(I,J) + LPBL=KTE+1-KPBL(I,J) + !----------------------------------------------------------------------- + !*** + !*** CALL CONVECTION + !*** + !----------------------------------------------------------------------- + !*** Begin debugging convection + ! PRINT_DIAG=.FALSE. + ! IF(I==IMD.AND.J==JMD)PRINT_DIAG=.TRUE. + !*** End debugging convection + !----------------------------------------------------------------------- + CALL BMJ(ITIMESTEP,I,J,DTCNVC,LMH,LANDMASK,CLDEFI(I,J) & + & ,DPCOL,PCOL,QCOL,TCOL,PSFC,PTOP & + & ,DQDT,DTDT,PCPCOL,LBOT,LTOP,LPBL & + & ,PWCOL,DQCOL,DQCOLMIN & + & ,CP,R,ELWV,ELIV,G,TFRZ,D608 & + & ,PRINT_DIAG & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) + !----------------------------------------------------------------------- + ! + !*** COMPUTE HEATING AND MOISTENING TENDENCIES + ! + IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN )) THEN + DO K=KTS,KTE + KFLIP=KTE+1-K + RTHCUTEN(I,K,J)=DTDT(KFLIP)/PI(I,K,J) + ! + !*** CONVERT FROM SPECIFIC HUMIDTY BACK TO MIXING RATIO + ! + RQVCUTEN(I,K,J)=DQDT(KFLIP)/(1.-QCOL(KFLIP))**2 + ENDDO + ENDIF + ! + !*** ALL UNITS IN BMJ SCHEME ARE MKS, THUS CONVERT PRECIP FROM METERS + !*** TO MILLIMETERS PER STEP FOR OUTPUT. + ! + RAINCV(I,J)=PCPCOL*1.E3/STEPCU + PRATEC(I,J)=PCPCOL*1.E3/(STEPCU * DT) + ! + !*** CONVECTIVE CLOUD TOP AND BOTTOM FROM THIS CALL + ! + CUTOP(I,J)=REAL(KTE+1-LTOP) + CUBOT(I,J)=REAL(KTE+1-LBOT) + ! + IF ( bmj_rad_feedback ) THEN + ! + IF (DQCOL.GT.DQCOLMIN) THEN + ! + !*** CONVECTIVE CLOUD FRACTION: BASED ON SLINGO (1987) WITH A POISSON + !*** VERTICAL PROFILE. PLEASE NOTE THAT THE BMJ PRECIPITATION RATE + !*** (PRATEC) HAS TO BE CONVERTED FROM MMS-1 TO MMDAY-1. + ! + TTOP=0 + BBOT=0 + PAVG=0. + CUMX=0. + MPVPR=0. + FACTL=0. + ! + PRRT=(PRATEC(I,J)*86400.0)/CRMN + RRP=0.8/(LOG(CRMX/CRMN)) + IF (PRRT=17 USE THE STERLING APPROXIMATION AS FOR N=17 IT GIVES A RELATIVE + !*** ERROR OF ~9.4x10E-8. + ! + TTOP=NINT(CUTOP(I,J)) + BBOT=NINT(CUBOT(I,J)) + PAVG=1./(PEPS*3.)**2 + DO K=KTS,KTE + IF (K.GE.BBOT.AND.K.LE.TTOP) THEN + JPR(K)=(1./PEPS)*((PMID(I,K,J)-PMID(I,TTOP,J))/(PMID(I,BBOT,J)-PMID(I,TTOP,J))) + ELSE + JPR(K)=0.0 + ENDIF + ENDDO + ! + DO K=KTS,KTE + PVPR(K)=0. + ENDDO + IF (JPR(BBOT).LT.17) THEN + DO K=BBOT,TTOP + PVPR(K)=(PAVG)**(JPR(K))/GAMMA(JPR(K)+1.) + ENDDO + ELSE + DO K=BBOT,TTOP + FACTL=JPR(K)*LOG(JPR(K))-JPR(K)+1./2.*LOG(2.*JPR(K)*ACOS(-1.))+ & + LOG(1.+1./(12.*JPR(K))+1./(288.*JPR(K)**2)) + PVPR(K)=EXP((JPR(K))*LOG(1.*PAVG)-FACTL) + ENDDO + ENDIF + MPVPR=MAXVAL(PVPR) + DO K=BBOT,TTOP + PVPR(K)=PVPR(K)/MPVPR + ENDDO + DO K=KTS,KTE + CCLDFRA(I,K,J)=CUMX*PVPR(K) + ENDDO + ! + !*** COMPUTE THE CONVECTIVE CLOUD CONDENSATES (QCCONV,QICONV). PLEASE NOTE THAT + !*** THE EQUATION FOR QCIS IS VALID FOR PRRTs IN THE RANGE 10**(-7) TO 10**3. + ! + QCIS=0. + MCOL=0. + DO K=CUBOT(I,J),CUTOP(I,J) + KFLIP=KTE+1-K + MCOL=RHO(I,K,J)*DZ8W(I,K,J)*QCOL(KFLIP)*CCLDFRA(I,K,J)+MCOL + ENDDO + CONVCLD(I,J)=PWCOL**GAM*(DQCOL-DQCOLMIN)**(1.-GAM) + QCIS=CONVCLD(I,J)/MCOL + DO K=KTS,KTE + KFLIP=KTE+1-K + IF (TCOL(KFLIP)>=TFRZ) THEN + QICONV(I,K,J)=0. + QCCONV(I,K,J)=(QCIS*QCOL(KFLIP)*CCLDFRA(I,K,J))/(1.-QCOL(KFLIP)) + ELSE + QICONV(I,K,J)=(QCIS*QCOL(KFLIP)*CCLDFRA(I,K,J))/(1.-QCOL(KFLIP)) + QCCONV(I,K,J)=0. + ENDIF + ENDDO + ! + ENDIF + ! + ENDIF + ! + !----------------------------------------------------------------------- + !*** Begin debugging convection + IF(PRINT_DIAG)THEN + DELT=0. + DELQ=0. + PLYR=0. + IF(LBOT>0.AND.LTOP 1) then + if (options%physics%landsurface == kLSM_NOAH) then call options%alloc_vars( & [kVARS%water_vapor, kVARS%potential_temperature, kVARS%precipitation, kVARS%temperature, & kVARS%exner, kVARS%dz_interface, kVARS%density, kVARS%pressure_interface, kVARS%shortwave, & @@ -104,7 +125,7 @@ subroutine lsm_var_request(options) kVARS%sensible_heat, kVARS%latent_heat, kVARS%u_10m, kVARS%v_10m, kVARS%temperature_2m, & kVARS%humidity_2m, kVARS%surface_pressure, kVARS%longwave_up, kVARS%ground_heat_flux, & kVARS%soil_totalmoisture, kVARS%soil_deep_temperature, kVARS%roughness_z0, kVARS%ustar, & - kVARS%snow_height, & ! BK 2020/10/26 + kVARS%snow_height, kVARS%lai, kVARS%temperature_2m_veg, kVARS%albedo, & kVARS%veg_type, kVARS%soil_type, kVARS%land_mask]) call options%advect_vars([kVARS%potential_temperature, kVARS%water_vapor]) @@ -120,6 +141,64 @@ subroutine lsm_var_request(options) kVARS%soil_totalmoisture, kVARS%soil_deep_temperature, kVARS%roughness_z0, kVARS%veg_type]) ! BK uncommented 2021/03/20 ! kVARS%soil_type, kVARS%land_mask, kVARS%vegetation_fraction] endif + + if (options%physics%landsurface == kLSM_NOAHMP) then + call options%alloc_vars( & + [kVARS%water_vapor, kVARS%potential_temperature, kVARS%precipitation, kVARS%temperature, & + kVARS%exner, kVARS%dz_interface, kVARS%density, kVARS%pressure_interface, kVARS%shortwave, & + kVARS%shortwave_direct, kVARS%shortwave_diffuse, kVARS%albedo, & + kVARS%longwave, kVARS%vegetation_fraction, kVARS%canopy_water, kVARS%snow_water_equivalent, & + kVARS%skin_temperature, kVARS%soil_water_content, kVARS%soil_temperature, kVARS%terrain, & + kVARS%sensible_heat, kVARS%latent_heat, kVARS%u_10m, kVARS%v_10m, kVARS%temperature_2m, & + kVARS%humidity_2m, kVARS%surface_pressure, kVARS%longwave_up, kVARS%ground_heat_flux, & + kVARS%soil_totalmoisture, kVARS%soil_deep_temperature, kVARS%roughness_z0, kVARS%ustar, & + kVARS%snow_height, kVARS%canopy_vapor_pressure, kVARS%canopy_temperature, & + kVARS%veg_leaf_temperature, kVARS%coeff_momentum_drag, kVARS%coeff_heat_exchange, & + kVARS%canopy_fwet, kVARS%snow_water_eq_prev, kVARS%water_table_depth, kVARS%water_aquifer, & + kVARS%mass_leaf, kVARS%mass_root, kVARS%mass_stem, kVARS%mass_wood, kVARS%soil_carbon_fast, & + kVARS%soil_carbon_stable, kVARS%eq_soil_moisture, kVARS%smc_watertable_deep, kVARS%recharge, & + kVARS%recharge_deep, kVARS%storage_lake, kVARS%storage_gw, kVARS%mass_ag_grain, & + kVARS%growing_degree_days, kVARS%plant_growth_stage, kVARS%temperature_2m_veg, & + kVARS%temperature_2m_bare, kVARS%mixing_ratio_2m_veg, kVARS%mixing_ratio_2m_bare, & + kVARS%surface_rad_temperature, kVARS%net_ecosystem_exchange, kVARS%gross_primary_prod, & + kVARS%net_primary_prod, kVARS%runoff_surface, kVARS%runoff_subsurface, & + kVARS%evap_canopy, kVARS%evap_soil_surface, kVARS%rad_absorbed_total, kVARS%rad_net_longwave, & + kVARS%apar, kVARS%photosynthesis_total, kVARS%rad_absorbed_veg, kVARS%rad_absorbed_bare, & + kVARS%stomatal_resist_total, kVARS%stomatal_resist_sun, kVARS%stomatal_resist_shade, & + kVARS%lai, kVARS%sai, kVARS%snow_albedo_prev, kVARS%snow_age_factor, kVARS%canopy_water_ice, & + kVARS%canopy_water_liquid, kVARS%vegetation_fraction_max, kVARS%crop_category, & + kVARS%date_planting, kVARS%date_harvest, kVARS%growing_season_gdd, kVARS%transpiration_rate, & + kVARS%frac_within_gap, kVARS%frac_between_gap, kVARS%ground_temperature_canopy, & + kVARS%ground_temperature_bare, kVARS%ch_veg, kVARS%ch_veg_2m, kVARS%ch_bare, kVARS%ch_bare_2m, & + kVARS%ch_under_canopy, kVARS%ch_leaf, kVARS%sensible_heat_veg, kVARS%sensible_heat_bare, & + kVARS%sensible_heat_canopy, kVARS%evap_heat_veg, kVARS%evap_heat_bare, kVARS%evap_heat_canopy, & + kVARS%transpiration_heat, kVARS%ground_heat_veg, kVARS%ground_heat_bare, kVARS%snow_nlayers, & + kVARS%net_longwave_veg, kVARS%net_longwave_bare, kVARS%net_longwave_canopy, & + kVARS%irr_frac_total, kVARS%irr_frac_sprinkler, kVARS%irr_frac_micro, kVARS%irr_frac_flood, & + kVARS%irr_eventno_sprinkler, kVARS%irr_eventno_micro, kVARS%irr_eventno_flood, & + kVARS%irr_alloc_sprinkler, kVARS%irr_alloc_micro, kVARS%irr_alloc_flood, kVARS%irr_amt_flood, & + kVARS%irr_evap_loss_sprinkler, kVARS%irr_amt_sprinkler, kVARS%irr_amt_micro, & + kVARS%evap_heat_sprinkler, kVARS%snowfall_ground, kVARS%rainfall_ground, kVARS%crop_type, & + kVARS%ground_surf_temperature, kVARS%snow_temperature, kVARS%snow_layer_depth, & + kVARS%snow_layer_ice, kVARS%snow_layer_liquid_water, kVARS%soil_texture_1, kVARS%gecros_state, & + kVARS%soil_texture_2, kVARS%soil_texture_3, kVARS%soil_texture_4, kVARS%soil_sand_and_clay, & + kVARS%vegetation_fraction_out, kVARS%latitude, kVARS%longitude, kVARS%cosine_zenith_angle, & + kVARS%veg_type, kVARS%soil_type, kVARS%land_mask]) + + call options%advect_vars([kVARS%potential_temperature, kVARS%water_vapor]) + + call options%restart_vars( & + [kVARS%water_vapor, kVARS%potential_temperature, kVARS%precipitation, kVARS%temperature, & + kVARS%density, kVARS%pressure_interface, kVARS%shortwave, & + kVARS%longwave, kVARS%canopy_water, kVARS%snow_water_equivalent, & + kVARS%skin_temperature, kVARS%soil_water_content, kVARS%soil_temperature, kVARS%terrain, & + kVARS%sensible_heat, kVARS%latent_heat, kVARS%u_10m, kVARS%v_10m, kVARS%temperature_2m, & + kVARS%snow_height, kVARS%canopy_water_ice, kVARS%canopy_vapor_pressure, kVARS%canopy_temperature, & ! BK 2020/10/26 + kVARS%humidity_2m, kVARS%surface_pressure, kVARS%longwave_up, kVARS%ground_heat_flux, & + kVARS%soil_totalmoisture, kVARS%soil_deep_temperature, kVARS%roughness_z0, kVARS%veg_type]) ! BK uncommented 2021/03/20 + ! kVARS%soil_type, kVARS%land_mask, kVARS%vegetation_fraction] + endif + if (options%physics%watersurface > 1) then call options%alloc_vars( & [kVARS%sst, kVARS%ustar, kVARS%surface_pressure, kVARS%water_vapor, & @@ -134,6 +213,31 @@ subroutine lsm_var_request(options) kVARS%humidity_2m, kVARS%temperature_2m]) endif + if (options%physics%watersurface == kWATER_LAKE ) then + call options%alloc_vars( & + [kVARS%lake_depth,kVARS%veg_type,kVARS%soil_type, kVARS%land_mask,kVARS%terrain, & + kVARS%temperature,kVARS%pressure_interface, kVARS%dz_interface, kVARS%shortwave, kVARS%longwave, & + kVARS%water_vapor, kVARS%latitude, kVARS%longitude, kVARS%sensible_heat, kVARS%latent_heat, & + kVARS%ground_heat_flux, kVARS%snow_water_equivalent, kVARS%t_lake3d, kVARS%dz_lake3d, & + kVARS%t_soisno3d, kVARS%h2osoi_ice3d, kVARS%h2osoi_liq3d, kVARS%h2osoi_vol3d, kVARS%z3d, & + kVARS%dz3d, kVARS%watsat3d, kVARS%csol3d, kVARS%tkmg3d, kVARS%lakemask, kVARS%zi3d, & + kVARS%tksatu3d, kVARS%tkdry3d, kVARS%snl2d, kVARS%t_grnd2d, kVARS%savedtke12d, kVARS%lakedepth2d, & ! kVARS%snowdp2d, kVARS%h2osno2d, + kVARS%lake_icefrac3d, kVARS%z_lake3d,kVARS%water_vapor, kVARS%potential_temperature ]) + + ! call options%advect_vars([kVARS%potential_temperature, kVARS%water_vapor]) + + call options%restart_vars( & + [kVARS%lake_depth,kVARS%veg_type,kVARS%soil_type, kVARS%land_mask,kVARS%terrain, & + kVARS%temperature,kVARS%pressure_interface, kVARS%dz_interface, kVARS%shortwave, kVARS%longwave, & + kVARS%water_vapor, kVARS%latitude, kVARS%longitude, kVARS%sensible_heat, kVARS%latent_heat, & + kVARS%ground_heat_flux, kVARS%snow_water_equivalent, kVARS%t_lake3d, kVARS%dz_lake3d, & + kVARS%t_soisno3d, kVARS%h2osoi_ice3d, kVARS%h2osoi_liq3d, kVARS%h2osoi_vol3d, kVARS%z3d, & + kVARS%dz3d, kVARS%watsat3d, kVARS%csol3d, kVARS%tkmg3d, kVARS%lakemask, kVARS%zi3d, & + kVARS%tksatu3d, kVARS%tkdry3d, kVARS%snl2d, kVARS%t_grnd2d, kVARS%savedtke12d, kVARS%lakedepth2d, & !kVARS%snowdp2d, kVARS%h2osno2d, + kVARS%lake_icefrac3d, kVARS%z_lake3d,kVARS%water_vapor, kVARS%potential_temperature ]) + endif + + end subroutine lsm_var_request @@ -148,9 +252,11 @@ subroutine calc_exchange_coefficient(wind,tskin,airt,exchange_C) exchange_C = 0 Ri = gravity/airt(:,1,:) * (airt(:,1,:)-tskin)*z_atm/(wind**2) + ! Ri now is a function in atm_utlilities: + ! calc_Richardson_nr(Ri, airt, tskin, z_atm, wind) - ! print*,"--------------------------------------------------" - ! print*, "Surface Richardson number" + ! "--------------------------------------------------" + ! "Surface Richardson number" where(Ri<0) exchange_C = lnz_atm_term * (1.0-(15.0*Ri)/(1.0+(base_exchange_term * sqrt((-1.0)*Ri)))) where(Ri>=0) exchange_C = lnz_atm_term * 1.0/((1.0+15.0*Ri)*sqrt(1.0+5.0*Ri)) @@ -190,32 +296,61 @@ subroutine calc_mahrt_holtslag_exchange_coefficient(wind,tskin,airt,znt, exchang where(exchange_C < MIN_EXCHANGE_C) exchange_C=MIN_EXCHANGE_C end subroutine calc_mahrt_holtslag_exchange_coefficient - subroutine surface_diagnostics(HFX, QFX, TSK, QSFC, CHS2, CQS2,T2, Q2, PSFC) + subroutine surface_diagnostics(HFX, QFX, TSK, QSFC, CHS2, CQS2,T2, Q2, PSFC, & + VEGFRAC, veg_type, land_mask, T2veg, T2bare, Q2veg, Q2bare) ! taken almost directly / exactly from WRF's module_sf_sfcdiags.F + !-- HFX net upward heat flux at the surface (W/m^2) + !-- QFX net upward moisture flux at the surface (kg/m^2/s) + !-- TSK surface temperature (K) + !-- qsfc specific humidity at lower boundary (kg/kg) implicit none REAL, DIMENSION(ims:ime, jms:jme ), INTENT(IN) :: HFX, QFX, TSK, QSFC REAL, DIMENSION(ims:ime, jms:jme ), INTENT(INOUT) :: Q2, T2 REAL, DIMENSION(ims:ime, jms:jme ), INTENT(IN) :: PSFC, CHS2, CQS2 - integer :: i,j, nx,ny + REAL, DIMENSION( : , : ), POINTER, INTENT(IN) :: T2veg, T2bare, Q2veg, Q2bare + REAL, DIMENSION(ims:ime, jms:jme ), INTENT(IN) :: VEGFRAC + INTEGER, DIMENSION(ims:ime, jms:jme ), INTENT(IN) :: land_mask, veg_type + integer :: i,j real :: rho - !$omp parallel default(shared), private(nx,ny,i,j,rho) - nx=size(HFX,1) - ny=size(HFX,2) + !$omp parallel default(shared), private(i,j,rho) !$omp do do j=jts,jte do i=its,ite - RHO = PSFC(I,J)/(Rd * TSK(I,J)) - if(CQS2(I,J).lt.1.E-3) then - Q2(I,J) = QSFC(I,J) - else - Q2(I,J) = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J)) - endif - if(CHS2(I,J).lt.1.E-3) then - T2(I,J) = TSK(I,J) + + ! if ((domain%veg_type(i,j)/=13).and.(domain%veg_type(i,j)/=15).and.(domain%veg_type(i,j)/=16).and.(domain%veg_type(i,j)/=21)) then + ! over glacier, urban and barren, noahmp veg 2m T is 0 or -9999e35 + if ((T2veg(i,j) > 200).and.(land_mask(i,j)==kLC_LAND).and.(associated(T2bare))) then + T2(i,j) = VEGFRAC(i,j) * T2veg(i,j) & + + (1-VEGFRAC(i,j)) * T2bare(i,j) + Q2(i,j) = VEGFRAC(i,j) * Q2veg(i,j) & + + (1-VEGFRAC(i,j)) * Q2bare(i,j) else - T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J)) + ! over glacier we don't want to use the bare ground temperature though + if ((veg_type(i,j)/=ISICE) & ! was /=15 (15=snow/ice in MODIFIED_IGBP_MODIS_NOAH) + .and.(veg_type(i,j)/=ISLAKE) & ! was /=21 (ISLAKE = options%lsm_options%lake_category) # 17 is water, 21 is lakes (in MODIFIED_IGBP_MODIS_NOAH ) MODIFY FOR GENERIC LU TYPES!! + .and.(land_mask(i,j)==kLC_LAND) & + .and.(associated(T2bare))) then + T2(i,j) = T2bare(i,j) + Q2(i,j) = Q2bare(i,j) + else + RHO = PSFC(I,J)/(Rd * TSK(I,J)) + + if(CQS2(I,J).lt.1.E-3) then + Q2(I,J) = QSFC(I,J) + else + Q2(I,J) = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J)) + endif + + if(CHS2(I,J).lt.1.E-3) then + T2(I,J) = TSK(I,J) + else + T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J)) + endif + endif endif + if (Q2(i,j) < SMALL_QV) Q2(i,j) = SMALL_QV + ! TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP enddo enddo @@ -223,37 +358,65 @@ subroutine surface_diagnostics(HFX, QFX, TSK, QSFC, CHS2, CQS2,T2, Q2, PSFC) !$omp end parallel end subroutine surface_diagnostics - subroutine apply_fluxes(domain,dt) + subroutine apply_fluxes(domain,dt) ! add sensible and latent heat fluxes to the first atm level implicit none type(domain_t), intent(inout) :: domain real, intent(in) :: dt - - associate(density => domain%density%data_3d, & - sensible_heat => domain%sensible_heat%data_2d, & - latent_heat => domain%latent_heat%data_2d, & - dz => domain%dz_interface%data_3d, & - pii => domain%exner%data_3d, & + integer :: i,j,k + integer, SAVE :: nz = 0 + real :: layer_fraction + + if (nz==0) then + layer_fraction = 0 + do k=kts, kte + layer_fraction = maxval(domain%dz_interface%data_3d(:,k,:)) + layer_fraction + if (layer_fraction < sfc_layer_thickness) nz=k + end do + end if + + associate(density => domain%density%data_3d, & + sensible_heat => domain%sensible_heat%data_2d, & + latent_heat => domain%latent_heat%data_2d, & + dz => domain%dz_interface%data_3d, & + pii => domain%exner%data_3d, & th => domain%potential_temperature%data_3d, & - qv => domain%water_vapor%data_3d & + qv => domain%water_vapor%data_3d & ) - ! convert sensible heat flux to a temperature delta term - ! (J/(s*m^2) * s / (J/(kg*K)) => kg*K/m^2) ... /((kg/m^3) * m) => K - dTemp=(sensible_heat(its:ite,jts:jte) * dt/cp) & - / (density(its:ite,kts,jts:jte) * dz(its:ite,kts,jts:jte)) - ! add temperature delta and convert back to potential temperature - th(its:ite,kts,jts:jte) = th(its:ite,kts,jts:jte) + (dTemp / pii(its:ite,kts,jts:jte)) - ! convert latent heat flux to a mixing ratio tendancy term - ! (J/(s*m^2) * s / (J/kg) => kg/m^2) ... / (kg/m^3 * m) => kg/kg - lhdQV=(latent_heat(its:ite,jts:jte) / LH_vaporization * dt) & - / (density(its:ite,kts,jts:jte) * dz(its:ite,kts,jts:jte)) - ! add water vapor in kg/kg - qv(its:ite,kts,jts:jte) = qv(its:ite,kts,jts:jte) + lhdQV + do j = jts, jte + do k = kts, kts + nz + do i = its, ite + ! compute the fraction of the current gridcell that is within the surface layer + if (k==kts) Then + layer_fraction = min(1.0, sfc_layer_thickness / dz(i,k,j)) + else + layer_fraction = max(0.0, min(1.0, (sfc_layer_thickness - sum(dz(i,kts:k-1,j))) / dz(i,k,j) ) ) + endif + + ! convert sensible heat flux to a temperature delta term + ! (J/(s*m^2) * s / (J/(kg*K)) => kg*K/m^2) ... /((kg/m^3) * m) => K + dTemp(i,j) = (sh_feedback_fraction * sensible_heat(i,j) * dt/cp) & + / (density(i,k,j) * sfc_layer_thickness) + ! add temperature delta converted back to potential temperature + th(i,k,j) = th(i,k,j) + (dTemp(i,j) / pii(i,k,j)) * layer_fraction + + ! convert latent heat flux to a mixing ratio tendancy term + ! (J/(s*m^2) * s / (J/kg) => kg/m^2) ... / (kg/m^3 * m) => kg/kg + lhdQV(i,j) = (lh_feedback_fraction * latent_heat(i,j) / LH_vaporization * dt) & + / (density(i,k,j) * sfc_layer_thickness) + ! add water vapor in kg/kg + qv(i,k,j) = qv(i,k,j) + lhdQV(i,j) * layer_fraction + + end do ! i + end do ! k + end do ! j + + ! write(*,*) MINVAL(lhdQV), MAXVAL(lhdQV), 'kg/kg (min/max) added to QV at', domain%model_time%hour ! enforce some minimum water vapor content... just in case - where(qv(its:ite,kts,jts:jte) < SMALL_QV) qv(its:ite,kts,jts:jte) = SMALL_QV + where(qv < SMALL_QV) qv = SMALL_QV end associate @@ -297,17 +460,15 @@ subroutine allocate_noah_data(num_soil_layers) allocate(XICE(ims:ime,jms:jme)) XICE = 0 allocate(EMISS(ims:ime,jms:jme)) - EMISS = 0.95 + EMISS = 0.99 allocate(EMBCK(ims:ime,jms:jme)) - EMBCK = 0.95 + EMBCK = 0.99 allocate(CPM(ims:ime,jms:jme)) CPM = 0 allocate(SR(ims:ime,jms:jme)) SR = 0 allocate(CHKLOWQ(ims:ime,jms:jme)) CHKLOWQ = 0 - allocate(LAI(ims:ime,jms:jme)) - LAI = 3 allocate(QZ0(ims:ime,jms:jme)) QZ0 = 0 ! used to check for saturation? but only relevant if myj == True @@ -335,9 +496,11 @@ subroutine allocate_noah_data(num_soil_layers) allocate(VEGFRAC(ims:ime,jms:jme)) VEGFRAC = 50 + allocate(day_frac(ims:ime)) + allocate(solar_elevation(ims:ime)) XICE_THRESHOLD = 1 - RDLAI2D = .false. + RDLAI2D = .false. !TLE check back on this one USEMONALB = .false. MYJ = .false. FRPCPN = .false. ! set this to true and calculate snow ratio to use microphysics based snow/rain partitioning @@ -360,13 +523,14 @@ subroutine lsm_init(domain,options) implicit none type(domain_t), intent(inout) :: domain type(options_t),intent(in) :: options - integer :: i + integer :: i,j - if (options%physics%landsurface == 0) return + if (options%physics%landsurface == 0) return !! So we cannot (currently) run without lsm but with water. if (this_image()==1) write(*,*) "Initializing LSM" if (this_image()==1) write(*,*) " max soil_deep_temperature on init: ", maxval(domain%soil_deep_temperature%data_2d) + if (this_image()==1) write(*,*) " max skin_temperature on init: ", maxval(domain%skin_temperature%data_2d) exchange_term = 1 @@ -390,6 +554,10 @@ subroutine lsm_init(domain,options) kts = domain%grid%kts kte = domain%grid%kte + lh_feedback_fraction = options%lsm_options%lh_feedback_fraction + sh_feedback_fraction = options%lsm_options%sh_feedback_fraction + sfc_layer_thickness = options%lsm_options%sfc_layer_thickness + allocate(dTemp(its:ite,jts:jte)) dTemp = 0 allocate(lhdQV(its:ite,jts:jte)) @@ -397,7 +565,7 @@ subroutine lsm_init(domain,options) allocate(Z0(ims:ime,jms:jme)) Z0 = domain%roughness_z0%data_2d ! this should get updated by the LSM(?) allocate(QSFC(ims:ime,jms:jme)) - QSFC = domain%water_vapor%data_3d(:,kms,:) ! this should get updated by the lsm + QSFC = domain%water_vapor%data_3d(:,kms,:) ! this should get updated by the lsm (BK: BUT does not fed back to domain%water_vapor%data_3d ?) allocate(Ri(ims:ime,jms:jme)) Ri = 0 allocate(z_atm(ims:ime,jms:jme)) @@ -432,7 +600,7 @@ subroutine lsm_init(domain,options) allocate(RAINBL(ims:ime,jms:jme)) - RAINBL = domain%accumulated_precipitation%data_2d ! used to store last time step accumulated precip so that it can be subtracted from the current step + RAINBL = domain%accumulated_precipitation%data_2dd ! used to store last time step accumulated precip so that it can be subtracted from the current step ! set to domain%rain incase this is a restart run and rain is non-zero to start allocate(rain_bucket(ims:ime,jms:jme)) rain_bucket = domain%precipitation_bucket ! used to store last time step accumulated precip so that it can be subtracted from the current step @@ -451,7 +619,7 @@ subroutine lsm_init(domain,options) if (options%physics%landsurface==kLSM_NOAH) then if (this_image()==1) write(*,*) " Noah LSM" - num_soil_layers=4 + num_soil_layers=4 ! Make namelist argument maybe? ! if (this_image()==1) then ! write(*,*) " options%parameters%external_files: ", trim(options%parameters%external_files) @@ -480,9 +648,19 @@ subroutine lsm_init(domain,options) ISICE = options%lsm_options%ice_category ISWATER = options%lsm_options%water_category MMINLU = options%lsm_options%LU_Categories !"MODIFIED_IGBP_MODIS_NOAH" + ISLAKE = options%lsm_options%lake_category call allocate_noah_data(num_soil_layers) + if (options%lsm_options%monthly_albedo) then + if (.not.options%lsm_options%monthly_vegfrac) Then + print*, "ERROR, monthly albedo requires monthly vegfrac" + error stop + endif + ALBEDO = domain%albedo%data_3d(:, domain%model_time%month, :) + else + ALBEDO = domain%albedo%data_3d(:, 1, :) + endif if (options%lsm_options%monthly_vegfrac) then VEGFRAC = domain%vegetation_fraction%data_3d(:, domain%model_time%month, :) else @@ -497,38 +675,317 @@ subroutine lsm_init(domain,options) where(domain%soil_water_content%data_3d<0.0001) domain%soil_water_content%data_3d=0.0001 call LSM_NOAH_INIT( VEGFRAC, & - domain%snow_water_equivalent%data_2d, & !SNOW, & BK 18/03/2021 - SNOWC, & - domain%snow_height%data_2d, & !SNOWH, & BK 18/03/2021 - domain%canopy_water%data_2d, & - domain%soil_temperature%data_3d, & !-- SMSTAV Soil moisture availability for evapotranspiration ( fraction between SMCWLT and SMCMXA) - domain%soil_water_content%data_3d, & - SFCRUNOFF, & - UDRUNOFF, & - ACSNOW, & - ACSNOM, & - domain%veg_type, & - domain%soil_type, & - domain%soil_temperature%data_3d, & - domain%soil_water_content%data_3d, & - SH2O, & - ZS, & - DZS, & - MMINLU, & - SNOALB, & - FNDSOILW, & - FNDSNOWH, & - RDMAXALB, & - num_soil_layers, & - .False., & ! nlayers, is_restart (can't yet) - .True. , & ! allowed_to_read (e.g. soilparm.tbl) - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + domain%snow_water_equivalent%data_2d,& !SNOW, & BK 18/03/2021 + SNOWC, & + domain%snow_height%data_2d, & !SNOWH, & BK 18/03/2021 + domain%canopy_water%data_2d, & + domain%soil_temperature%data_3d, & !-- SMSTAV Soil moisture availability for evapotranspiration ( fraction between SMCWLT and SMCMXA) + domain%soil_water_content%data_3d, & + SFCRUNOFF, & + UDRUNOFF, & + ACSNOW, & + ACSNOM, & + domain%veg_type, & + domain%soil_type, & + domain%soil_temperature%data_3d, & + domain%soil_water_content%data_3d, & + SH2O, & + ZS, & + DZS, & + MMINLU, & + SNOALB, & + FNDSOILW, & + FNDSNOWH, & + RDMAXALB, & + num_soil_layers, & + .False., & ! nlayers, is_restart (can't yet) + .True. , & ! allowed_to_read (e.g. soilparm.tbl) + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) domain%canopy_water%data_2d = CQS2 CQS2=0.01 - where(domain%veg_type==ISWATER) domain%land_mask=kLC_WATER ! ensure VEGTYPE (land cover) and land-sea mask are consistent + ! where(domain%veg_type==ISWATER) domain%land_mask=kLC_WATER ! ensure VEGTYPE (land cover) and land-sea mask are consistent + where((domain%veg_type==ISWATER) .OR. (domain%veg_type==ISLAKE)) domain%land_mask=kLC_WATER ! include lakes. + endif + + ! Noah-MP Land Surface Model + if (options%physics%landsurface==kLSM_NOAHMP) then + if (this_image()==1) write(*,*) " Noah-MP LSM" + + num_soil_layers=4 ! to .nml? + + ! if (this_image()==1) then + ! write(*,*) " options%parameters%external_files: ", trim(options%parameters%external_files) + ! write(*,*) " options%parameters%restart: ", options%parameters%restart + ! write(*,*) " options%parameters%rho_snow_ext ", trim(options%parameters%rho_snow_ext) + ! write(*,*) " options%parameters%swe_ext ", trim(options%parameters%swe_ext ) + ! endif + + if (options%parameters%rho_snow_ext /="" .AND. options%parameters%swe_ext /="") then ! calculate snowheight from external swe and density, but only if both are provided. (Swe alone will give FNDSNW = F) + FNDSNOWH = .True. + if (this_image()==1) write(*,*) " Find snow height in file i.s.o. calculating them from SWE: FNDSNOWH=", FNDSNOWH + elseif(options%parameters%hsnow_ext /="" ) then ! read in external snowheight if supplied + FNDSNOWH= .True. + if (this_image()==1) write(*,*) " Find snow height in file i.s.o. calculating them from SWE: FNDSNOWH=", FNDSNOWH + elseif(options%parameters%restart) then ! If restarting read in snow height, but only if this is in restart file? + FNDSNOWH= .True. + if (this_image()==1) write(*,*) " Find snow height in file i.s.o. calculating them from SWE: FNDSNOWH=", FNDSNOWH + else + FNDSNOWH=.False. ! calculate SNOWH from SNOW + endif + + FNDSOILW=.False. ! calculate SOILW (this parameter is ignored in LSM_NOAH_INIT) + RDMAXALB=.False. + + ISURBAN = options%lsm_options%urban_category + ISICE = options%lsm_options%ice_category + ISWATER = options%lsm_options%water_category + MMINLU = options%lsm_options%LU_Categories !"MODIFIED_IGBP_MODIS_NOAH" + ISLAKE = options%lsm_options%lake_category + + call allocate_noah_data(num_soil_layers) + + if (options%lsm_options%monthly_albedo) then + if (.not.options%lsm_options%monthly_vegfrac) Then + print*, "ERROR, monthly albedo requires monthly vegfrac" + error stop + endif + ALBEDO = domain%albedo%data_3d(:, domain%model_time%month, :) + else + ALBEDO = domain%albedo%data_3d(:, 1, :) + endif + if (options%lsm_options%monthly_vegfrac) then + VEGFRAC = domain%vegetation_fraction%data_3d(:, domain%model_time%month, :) + else + VEGFRAC = domain%vegetation_fraction%data_3d(:, 1, :) + endif + cur_vegmonth = domain%model_time%month + + ! save the canopy water in a temporary variable in case this is a restart run because lsm_init resets it to 0 + CQS2 = domain%canopy_water%data_2d + ! prevents init from failing when processing water points that may have "soil_t"=0 + where(domain%soil_temperature%data_3d<200) domain%soil_temperature%data_3d=200 + where(domain%soil_water_content%data_3d<0.0001) domain%soil_water_content%data_3d=0.0001 + + ! Hard-coded Noah-MP input options (read in from namelist in future); TLE + IDVEG = 1 ! dynamic vegetation (1 = OFF; 2 = ON) + IOPT_CRS = 1 ! canopy stomatal resistance (1 = Ball-Berry; 2 = Jarvis) + IOPT_BTR = 1 ! soil moisture factor for stomatal resistance (1 = Noah; 2 = CLM; 3 = SSiB) + IOPT_RUN = 1 ! runoff and gw (1 = SIMGM; 2 = SIMTOP; 3 = Schaake96; 4 = BATS) + IOPT_SFC = 1 ! surface layer drag coefficient (CH & CM) (1 = M-O; 2 = Chen97) + IOPT_FRZ = 1 ! supercooled liquid water (1 = NY06; 2 = Koren99) + IOPT_INF = 1 ! frozen soil permeability (1 = NY06; 2 = Koren99) + IOPT_RAD = 1 ! radiation transfer (1 = gap=F(3D,cosz); 2 = gap=0; 3 = gap=1-Fveg) + IOPT_ALB = 1 ! snow surface albedo (1 = BATS; 2 = CLASS; 3 = Noah) + IOPT_SNF = 1 ! rain/snow partitioning (1 = Jordan91; 2 = BATS; 3 = CLASS) + IOPT_TBOT = 2 ! lower boundary of soil temperature (1 = zero-flux; 2 = Noah) + IOPT_STC = 1 ! snow/soil temp. time scheme + IOPT_GLA = 1 ! glacier option (1 = phase change; 2 = simple) + IOPT_RSF = 1 ! surface resistance (1 = Sakaguchi/Zeng; 2 = Sellers; 3 = modified Sellers; 4 = 1+snow) + IOPT_SOIL = 1 ! soil config. option (1 = homogeneous with depth; 2 & 3 = variable with depth--not currently set up) + IOPT_PEDO = 1 ! soil pedotransfer function option + IOPT_CROP = 0 ! crop model option (0 = none; 1 = Liu et al.; 2 = Gecros) + IOPT_IRR = 0 ! irrigation scheme (0 = OFF; 1 = ON) + IOPT_IRRM = 0 ! irrigation method + IZ0TLND = 0 ! option of Chen adjustment of Czil (not used) + SF_URBAN_PHYSICS = 0 ! urban physics (0 = off) + + !allocate dummy variable that doesn't do anything + allocate(chstarxy(ims:ime,jms:jme)) + chstarxy = 0 + + call NOAHMP_INIT ( MMINLU, & + domain%snow_water_equivalent%data_2d, & + domain%snow_height%data_2d, & + domain%canopy_water%data_2d, & + domain%soil_type, & + domain%veg_type, & + domain%latitude%data_2d, & + domain%soil_temperature%data_3d, & + domain%soil_water_content%data_3d, & + SH2O , DZS , & + FNDSOILW , FNDSNOWH , & + domain%skin_temperature%data_2d, & + domain%snow_nlayers, & + domain%veg_leaf_temperature%data_2d, & + domain%ground_surf_temperature%data_2d, & + domain%canopy_water_ice%data_2d, & + domain%soil_deep_temperature%data_2d, & + XICE, & + domain%canopy_water_liquid%data_2d, & + domain%canopy_vapor_pressure%data_2d, & + domain%canopy_temperature%data_2d, & + domain%coeff_momentum_drag%data_2d, & + domain%coeff_heat_exchange%data_2d, & + domain%canopy_fwet%data_2d, & + domain%snow_water_eq_prev%data_2d, & + domain%snow_albedo_prev%data_2d, & + domain%snowfall_ground%data_2d, & + domain%rainfall_ground%data_2d, & + domain%storage_lake%data_2d, & + domain%water_table_depth%data_2d, & + domain%water_aquifer%data_2d, & + domain%storage_gw%data_2d, & + domain%snow_temperature%data_3d, & + domain%snow_layer_depth%data_3d, & + domain%snow_layer_ice%data_3d, & + domain%snow_layer_liquid_water%data_3d, & + domain%mass_leaf%data_2d, & + domain%mass_root%data_2d, & + domain%mass_stem%data_2d, & + domain%mass_wood%data_2d, & + domain%soil_carbon_stable%data_2d, & + domain%soil_carbon_fast%data_2d, & + domain%lai%data_2d, & + domain%sai%data_2d, & + domain%mass_ag_grain%data_2d, & + domain%growing_degree_days%data_2d, & + domain%crop_type%data_3d, & + domain%crop_category, & + domain%irr_eventno_sprinkler, & + domain%irr_eventno_micro, & + domain%irr_eventno_flood, & + domain%irr_alloc_sprinkler%data_2d, & + domain%irr_alloc_micro%data_2d, & + domain%irr_alloc_flood%data_2d, & + domain%irr_evap_loss_sprinkler%data_2d, & + domain%irr_amt_sprinkler%data_2d, & + domain%irr_amt_micro%data_2d, & + domain%irr_amt_flood%data_2d, & + domain%evap_heat_sprinkler%data_2d, & + domain%temperature_2m_veg%data_2d, & + domain%temperature_2m_bare%data_2d, & + chstarxy, & !doesn't do anything -_- + num_soil_layers, & + .False., & !restart + .True., & !allowed_to_read + IOPT_RUN, IOPT_CROP, IOPT_IRR, IOPT_IRRM, & + SF_URBAN_PHYSICS, & ! urban scheme + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + ! TLE: GROUNDWATER OFF FOR NOW + ! smoiseq ,smcwtdxy ,rechxy ,deeprechxy, areaxy, dx, dy, msftx, msfty,& ! Optional groundwater + ! wtddt ,stepwtd ,dt ,qrfsxy ,qspringsxy , qslatxy , & ! Optional groundwater + ! fdepthxy ,ht ,riverbedxy ,eqzwt ,rivercondxy ,pexpxy , & ! Optional groundwater + ! rechclim, & ! Optional groundwater + ! gecros_state) ! Optional gecros crop + + domain%canopy_water%data_2d = CQS2 + CQS2=0.01 + ! where(domain%veg_type==ISWATER) domain%land_mask=kLC_WATER ! ensure VEGTYPE (land cover) and land-sea mask are consistent (BK 202208: this does not include lakes!!) + where((domain%veg_type==ISWATER) .OR. (domain%veg_type==ISLAKE)) domain%land_mask=kLC_WATER + + endif + + if(options%physics%watersurface==kWATER_LAKE) then + ! ____________ Lake model ______________________ + ! From WRF's /run/README.namelist: These could at some point become namelist options in ICAR? + ! lakedepth_default(max_dom) = 50, ! default lake depth (If there is no lake_depth information in the input data, then lake depth is assumed to be 50m) + ! lake_min_elev(max_dom) = 5, ! minimum elevation of lakes. May be used to determine whether a water point is a lake in the absence of lake + ! category. If the landuse type includes 'lake' (i.e. Modis_lake and USGS_LAKE), this variable is of no effects. + ! use_lakedepth (max_dom) = 1, ! option to use lake depth data. Lake depth data is available from 3.6 geogrid program. If one didn't process + ! the lake depth data, but this switch is set to 1, the program will stop and tell one to go back to geogrid + ! program. + ! = 0, do not use lake depth data. + + if (this_image()==1) write(*,*) "Initializing Lake model" + + ! allocate arrays: + allocate( lake_or_not(ims:ime, jms:jme)) + allocate( TH2( ims:ime, jms:jme )) + if( .not.(allocated(XICE))) then + allocate(XICE(ims:ime,jms:jme)) ! already allocated for NoahMP, so check? + XICE = 0 + endif + + ! ISURBAN = options%lsm_options%urban_category + ISICE = options%lsm_options%ice_category + ISWATER = options%lsm_options%water_category + ! MMINLU = options%lsm_options%LU_Categories !"MODIFIED_IGBP_MODIS_NOAH" + ISLAKE = options%lsm_options%lake_category + + ! allocate_noah_data already sets xice_threshold, so if we are using noah (mp/lsm) leave as is. + if(.not.(options%physics%landsurface==kLSM_NOAHMP .OR. options%physics%landsurface==kLSM_NOAH)) then + xice_threshold = 1.0 ! allocate_noah_data sets it to 1., BUT WRF's module_physics_init.F sets xice_threshold to 0.5 .... so? + endif + + lake_count=0 + if(ISLAKE==-1) then + if(this_image()==1) write(*,*) " WARNING: no lake category in LU data: The model will try to guess lake-gridpoints. This option has not been properly tested!" + lakeflag=0 ! If no lake cat is provided, the lake model will determine lakes based + ! on the criterion (ivgtyp(i,j)==iswater .and. ht(i,j)>=lake_min_elev)) + else + lakeflag=1 + ! from WRF's module_initialize_real.F: + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + ! IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN + if(domain%veg_type(i,j) .NE. ISLAKE ) then + domain%lakemask%data_2d(i,j) = 0 ! grid%lakemask(i,j) = 0 + ELSE + domain%lakemask%data_2d(i,j) = 1 ! grid%lakemask(i,j) = 1 + lake_count= lake_count + 1 + end if + END DO + END DO + endif + ! if(options%parameters%debug) write(*,*)" ",lake_count, " lake cells in image ", this_image() + + ! setlake_depth_flag and use_lakedepth flag. (They seem to be redundant, but whatever): + if( associated(domain%lake_depth%data_2d) ) then + if(this_image()==1) write(*,*) " Using Lake depth data " + use_lakedepth = 1 + lake_depth_flag = 1 + else + use_lakedepth = 0 + lake_depth_flag = 0 + endif + + call lakeini( & + IVGTYP = domain%veg_type & + ,ISLTYP = domain%soil_type & + ,HT=domain%terrain%data_2d & ! terrain height [m] if ht(i,j)>=lake_min_elev -> lake (grid%ht in WRF) + ,SNOW=domain%snow_water_equivalent%data_2d & !i ! SNOW in kg/m^2 (NoahLSM: SNOW liquid water-equivalent snow depth (m) + ,lake_min_elev=5. & ! minimum elevation of lakes. May be used to determine whether a water point is a lake in the absence of lake category. If the landuse type includes 'lake' (i.e. Modis_lake and USGS_LAKE), this variable is of no effects. + ,restart=options%parameters%restart & ! if restart, this (lakeini) subroutine is simply skipped. + ,lakedepth_default=50. & ! default lake depth (If there is no lake_depth information in the input data, then lake depth is assumed to be 50m) + ,lake_depth=domain%lake_depth%data_2d & !INTENT(IN) + ,lakedepth2d=domain%lakedepth2d%data_2d & !INTENT(OUT) (will be equal to lake_depth if lake_depth data is provided in hi-res input, otherwise lakedepth_default) + ,savedtke12d=domain%savedtke12d%data_2d & !INTENT(OUT) + ,snowdp2d=domain%snow_height%data_2d & ! domain%snowdp2d%data_2d + ,h2osno2d=domain%snow_water_equivalent%data_2d & !domain%h2osno2d%data_2d + ,snl2d=domain%snl2d%data_2d & ! snowlevel 2d? + ,t_grnd2d=domain%t_grnd2d%data_2d & ! ground temperature? + ,t_lake3d=domain%t_lake3d%data_3d & ! lake temperature 3d + ,lake_icefrac3d=domain%lake_icefrac3d%data_3d & ! lake ice fraction ? + ,z_lake3d=domain%z_lake3d%data_3d & ! + ,dz_lake3d=domain%dz_lake3d%data_3d & + ,t_soisno3d=domain%t_soisno3d%data_3d & ! temperature of both soil and snow + ,h2osoi_ice3d=domain%h2osoi_ice3d%data_3d & ! ice lens (kg/m2) + ,h2osoi_liq3d=domain%h2osoi_liq3d%data_3d & ! liquid water (kg/m2) + ,h2osoi_vol3d=domain%h2osoi_vol3d%data_3d & ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + ,z3d=domain%z3d%data_3d & ! layer depth for snow & soil (m) + ,dz3d=domain%dz3d%data_3d & ! layer thickness for soil or snow (m) + ,zi3d=domain%zi3d%data_3d & + ,watsat3d=domain%watsat3d%data_3d & + ,csol3d=domain%csol3d%data_3d & + ,tkmg3d=domain%tkmg3d%data_3d & + ,iswater=iswater, xice=xice, xice_threshold=xice_threshold & + ,xland=domain%land_mask & !-- XLAND land mask (1 for land, 2 for water) i/o + ,tsk=domain%skin_temperature%data_2d & + ,lakemask=domain%lakemask%data_2d & ! 2d var that says lake(1) or not lake(0) + ,lakeflag=lakeflag & ! flag to read in lakemask (lakeflag=1), or to determine lakemask from ivgtyp(i,j)==iswater.and.ht(i,j)>=lake_min_elev (lakeflag=0) + ,lake_depth_flag=lake_depth_flag, use_lakedepth=use_lakedepth & ! flags to use the provided lake depth data (in hi-res input domain file) or not. + ,tkdry3d=domain%tkdry3d%data_3d & + ,tksatu3d=domain%tksatu3d%data_3d & + ,lake=lake_or_not & ! Logical (:,:) if gridpoint is lake or not (INTENT(OUT)) not used further? + ,its=its, ite=ite, jts=jts, jte=jte & + ,ims=ims, ime=ime, jms=jms, jme=jme & + ) endif ! defines the height of the middle of the first model level @@ -591,9 +1048,13 @@ subroutine lsm(domain,options,dt) ! enddo ! enddo ! else - if (options%physics%watersurface==kWATER_SIMPLE) then + if( & + (options%physics%watersurface==kWATER_SIMPLE) .or. & + (options%physics%watersurface==kWATER_LAKE) & ! also call for kWATER_LAKE (for ocean cells) + )then - call water_simple(domain%sst%data_2d, & + call water_simple(options, & + domain%sst%data_2d, & domain%surface_pressure%data_2d, & windspd, & domain%ustar, & @@ -605,9 +1066,81 @@ subroutine lsm(domain,options,dt) domain%land_mask, & QSFC, & QFX, & - domain%skin_temperature%data_2d) + domain%skin_temperature%data_2d & + ,domain%veg_type & + ! ,domain%terrain%data_2d & ! terrain height [m] if ht(i,j)>=lake_min_elev -> lake (in case no lake category is provided, but lake model is selected, we need to not run the simple water as well - left comment in for future reference) + ) + endif + + !___________________ Lake model _____________________ + ! This lake model (ported from WRF V4.4) is run for the grid cells that are defined as lake in the hi-res input file. + ! It also is advised to supply a lake_depth parameter in the hi-res input, otherwise the default depth of 50m is used (see lakeini above) + ! It requires the VEGPARM.TBL landuse category to be one which has a separate lake category (i.e. MODIFIED_IGBP_MODIS_NOAH, USGS-RUC or MODI-RUC). + ! For the grid cells that are defined as water, but not as lake (i.e. oceans), the simple water model above will be run. + if (options%physics%watersurface==kWATER_LAKE) then ! WRF's lake model + + ! current_precipitation = (domain%accumulated_precipitation%data_2dd-RAINBL)+(domain%precipitation_bucket-rain_bucket)*kPRECIP_BUCKET_SIZE ! analogous to noah calls + + call lake( & + t_phy=domain%temperature%data_3d & !-- t_phy temperature (K) !Temprature at the mid points (K) + ,p8w=domain%pressure_interface%data_3d & !-- p8w pressure at full levels (Pa) ! Naming convention: 8~at => p8w reads as "p-at-w" (w=full levels) + ,dz8w=domain%dz_interface%data_3d & !-- dz8w dz between full levels (m) + ,qvcurr=domain%water_vapor%data_3d & !i + ,u_phy=domain%u_mass%data_3d & !-- u_phy u-velocity interpolated to theta points (m/s) + ,v_phy=domain%v_mass%data_3d & !-- v_phy v-velocity interpolated to theta points (m/s) + ,glw=domain%longwave%data_2d & !-- GLW downward long wave flux at ground surface (W/m^2) + ,emiss=EMISS & !-- EMISS surface emissivity (between 0 and 1) + ,rainbl=current_precipitation & ! RAINBL in mm (Accumulation between PBL calls) + ,dtbl=lsm_dt & !-- dtbl timestep (s) or ITIMESTEP? + ,swdown=domain%shortwave%data_2d & !-- SWDOWN downward short wave flux at ground surface (W/m^2) + ,albedo=ALBEDO & ! albedo? fixed at 0.17? + ,xlat_urb2d=domain%latitude%data_2d & ! optional ? + ,z_lake3d=domain%z_lake3d%data_3d & + ,dz_lake3d=domain%dz_lake3d%data_3d & + ,lakedepth2d=domain%lakedepth2d%data_2d & + ,watsat3d=domain%watsat3d%data_3d & + ,csol3d=domain%csol3d%data_3d & + ,tkmg3d=domain%tkmg3d%data_3d & + ,tkdry3d=domain%tkdry3d%data_3d & + ,tksatu3d=domain%tksatu3d%data_3d & + ,ivgtyp=domain%veg_type & + ,HT=domain%terrain%data_2d & + ,xland=real(domain%land_mask) & !-- XLAND land mask (1 for land, 2 OR 0 for water) i/o + ,iswater=iswater, xice=xice, xice_threshold=xice_threshold & + ,lake_min_elev=5. & ! if this value is changed, also change it in lake_ini + ,ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde & + ,ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme & + ,its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte & + ,h2osno2d=domain%snow_water_equivalent%data_2d & !domain%h2osno2d%data_2d + ,snowdp2d=domain%snow_height%data_2d & ! domain%snowdp2d%data_2d + ,snl2d=domain%snl2d%data_2d & + ,z3d=domain%z3d%data_3d & + ,dz3d=domain%dz3d%data_3d & + ,zi3d=domain%zi3d%data_3d & + ,h2osoi_vol3d=domain%h2osoi_vol3d%data_3d & + ,h2osoi_liq3d=domain%h2osoi_liq3d%data_3d & + ,h2osoi_ice3d=domain%h2osoi_ice3d%data_3d & + ,t_grnd2d=domain%t_grnd2d%data_2d & + ,t_soisno3d=domain%t_soisno3d%data_3d & + ,t_lake3d=domain%t_lake3d%data_3d & ! 3d lake temperature (K) + ,savedtke12d=domain%savedtke12d%data_2d & + ,lake_icefrac3d=domain%lake_icefrac3d%data_3d & + ,lakemask=domain%lakemask%data_2d & + ,lakeflag=lakeflag & + ,hfx= domain%sensible_heat%data_2d & !(OUT)-- HFX upward heat flux at the surface (W/m^2) (INTENT:OUT) + ,lh=domain%latent_heat%data_2d & !(OUT)-- LH net upward latent heat flux at surface (W/m^2) + ,grdflx=domain%ground_heat_flux%data_2d & !(OUT)-- GRDFLX(I,J) ground heat flux (W m-2) + ,tsk=domain%skin_temperature%data_2d & !(OUT)-- TSK skin temperature [K] + ,qfx=QFX & !(OUT)-- QFX upward moisture flux at the surface (kg/m^2/s) in + ,t2= domain%temperature_2m%data_2d & !(OUT)-- t2 diagnostic 2-m temperature from surface layer and lsm + ,th2=TH2 & !(OUT)-- th2 diagnostic 2-m theta from surface layer and lsm + ,q2=domain%humidity_2m%data_2d & !(OUT)-- q2 diagnostic 2-m mixing ratio from surface layer and lsm + ) + endif + + where(windspd<1) windspd=1 ! minimum wind speed to prevent the exchange coefficient from blowing up CHS = CHS * windspd CHS2 = CHS @@ -652,6 +1185,11 @@ subroutine lsm(domain,options,dt) endif enddo enddo + if (options%lsm_options%monthly_albedo) then + if (cur_vegmonth /= domain%model_time%month) then + ALBEDO = domain%albedo%data_3d(:, domain%model_time%month, :) + endif + endif if (options%lsm_options%monthly_vegfrac) then if (cur_vegmonth /= domain%model_time%month) then VEGFRAC = domain%vegetation_fraction%data_3d(:, domain%model_time%month, :) @@ -659,14 +1197,16 @@ subroutine lsm(domain,options,dt) endif endif - ! if (this_image()==1) write(*,*) " lsm start: accumulated_precipitation max:", MAXVAL(domain%accumulated_precipitation%data_2d) + ! if (this_image()==1) write(*,*) " lsm start: accumulated_precipitation max:", MAXVAL(domain%accumulated_precipitation%data_2dd) ! if (this_image()==1) write(*,*) " lsm start: RAINBL max:", MAXVAL(RAINBL) ! if (this_image()==1) write(*,*) " lsm start: domain%precipitation_bucket max:", MAXVAL(domain%precipitation_bucket) ! if (this_image()==1) write(*,*) " lsm start: rain_bucket max:", MAXVAL(rain_bucket) - ! RAINBL(i,j) = [kg m-2] RAINBL = domain%accumulated_precipitation%data_2d ! used to store last time step accumulated precip so that it can be subtracted from the current step - current_precipitation = (domain%accumulated_precipitation%data_2d-RAINBL)+(domain%precipitation_bucket-rain_bucket)*kPRECIP_BUCKET_SIZE + ! RAINBL(i,j) = [kg m-2] RAINBL = domain%accumulated_precipitation%data_2dd ! used to store last time step accumulated precip so that it can be subtracted from the current step + current_precipitation = (domain%accumulated_precipitation%data_2dd - RAINBL) !+(domain%precipitation_bucket-rain_bucket)*kPRECIP_BUCKET_SIZE + if (allocated(domain%rain_fraction)) current_precipitation = current_precipitation * domain%rain_fraction(:,:,domain%model_time%get_month()) + call lsm_noah(domain%dz_interface%data_3d, & domain%water_vapor%data_3d, & domain%pressure_interface%data_3d, & @@ -717,11 +1257,11 @@ subroutine lsm(domain,options,dt) ROVCP, & SR, & chklowq, & - lai, & + domain%lai%data_2d, & qz0, & !H myj,frpcpn, & SH2O, & - domain%snow_height%data_2d, & !SNOWH, & !H + domain%snow_height%data_2d, & !SNOWH, & !H SNOALB,SHDMIN,SHDMAX, & !I SNOTIME, & !? ACSNOM,ACSNOW, & !O @@ -737,6 +1277,7 @@ subroutine lsm(domain,options,dt) ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) + where(domain%snow_water_equivalent%data_2d > options%lsm_options%max_swe) domain%snow_water_equivalent%data_2d = options%lsm_options%max_swe ! now that znt (roughness_z0) has been updated, we need to recalculate terms lnz_atm_term = log((z_atm+domain%roughness_z0%data_2d)/domain%roughness_z0%data_2d) if (exchange_term==1) then @@ -746,9 +1287,235 @@ subroutine lsm(domain,options,dt) ! note this is more or less just diagnostic and could be removed domain%longwave_up%data_2d = stefan_boltzmann * EMISS * domain%skin_temperature%data_2d**4 - RAINBL = domain%accumulated_precipitation%data_2d + RAINBL = domain%accumulated_precipitation%data_2dd rain_bucket = domain%precipitation_bucket + else if (options%physics%landsurface == kLSM_NOAHMP) then + ! Call the Noah-MP Land Surface Model + + ! 2m saturated mixing ratio + do j=jms,jme + do i=ims,ime + if (domain%land_mask(i,j) == kLC_LAND) then + QGH(i,j) = sat_mr(domain%temperature_2m%data_2d(i,j),domain%surface_pressure%data_2d(i,j)) + endif + enddo + enddo + if (options%lsm_options%monthly_albedo) then + if (cur_vegmonth /= domain%model_time%month) then + ALBEDO = domain%albedo%data_3d(:, domain%model_time%month, :) + endif + endif + if (options%lsm_options%monthly_vegfrac) then + if (cur_vegmonth /= domain%model_time%month) then + VEGFRAC = domain%vegetation_fraction%data_3d(:, domain%model_time%month, :) + cur_vegmonth = domain%model_time%month + endif + endif + + !more parameters + landuse_name = options%lsm_options%LU_Categories !test whether this works or if we need something separate + + ! if (this_image()==1) write(*,*) " lsm start: accumulated_precipitation max:", MAXVAL(domain%accumulated_precipitation%data_2d) + ! if (this_image()==1) write(*,*) " lsm start: RAINBL max:", MAXVAL(RAINBL) + ! if (this_image()==1) write(*,*) " lsm start: domain%precipitation_bucket max:", MAXVAL(domain%precipitation_bucket) + ! if (this_image()==1) write(*,*) " lsm start: rain_bucket max:", MAXVAL(rain_bucket) + + current_precipitation = (domain%accumulated_precipitation%data_2dd - RAINBL) !+(domain%precipitation_bucket-rain_bucket)*kPRECIP_BUCKET_SIZE + if (allocated(domain%rain_fraction)) current_precipitation = current_precipitation * domain%rain_fraction(:,:,domain%model_time%get_month()) + +! do I = ims,ime +! do J = jms,jme +! call calc_declin(domain%model_time%day_of_year(),real(domain%model_time%hour),real(domain%model_time%minute),real(domain%model_time%second),domain%latitude%data_2d(I,J),domain%longitude%data_2d(I,J),domain%cos_zenith%data_2d(I,J)) +! enddo +! enddo + + + do j = jms,jme + solar_elevation = calc_solar_elevation(date=domain%model_time, lon=domain%longitude%data_2d, & + j=j, ims=ims,ime=ime,jms=jms,jme=jme,its=its,ite=ite,day_frac=day_frac) + domain%cosine_zenith_angle%data_2d(its:ite,j)=sin(solar_elevation(its:ite)) + enddo + + call noahmplsm(ITIMESTEP, & + domain%model_time%year, & + domain%model_time%day_of_year(), & + domain%cosine_zenith_angle%data_2d, & + domain%latitude%data_2d, & + domain%longitude%data_2d, & + domain%dz_interface%data_3d * options%lsm_options%dz_lsm_modification, & ! domain%dz_interface%data_3d, & ! + lsm_dt, & + DZS, & + num_soil_layers, & + domain%dx, & + domain%veg_type, & + domain%soil_type, & + VEGFRAC, & + domain%vegetation_fraction_max%data_2d, & + domain%soil_deep_temperature%data_2d, & + real(domain%land_mask), & + XICE, & + XICE_THRESHOLD, & + domain%crop_category, & !only used if iopt_crop>0; not currently set up + domain%date_planting%data_2d, & !only used if iopt_crop>0; not currently set up + domain%date_harvest%data_2d, & !only used if iopt_crop>0; not currently set up + domain%growing_season_gdd%data_2d, & !only used if iopt_crop>0; not currently set up + IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, & + IOPT_SFC, IOPT_FRZ, IOPT_INF, IOPT_RAD, & + IOPT_ALB, IOPT_SNF, IOPT_TBOT, IOPT_STC, & + IOPT_GLA, IOPT_RSF, IOPT_SOIL,IOPT_PEDO, & + IOPT_CROP, IOPT_IRR, IOPT_IRRM, IZ0TLND, & + SF_URBAN_PHYSICS, & + domain%soil_sand_and_clay%data_3d, & ! only used if iopt_soil = 3 + domain%soil_texture_1%data_2d, & ! only used if iopt_soil = 2 + domain%soil_texture_2%data_2d, & ! only used if iopt_soil = 2 + domain%soil_texture_3%data_2d, & ! only used if iopt_soil = 2 + domain%soil_texture_4%data_2d, & ! only used if iopt_soil = 2 + domain%temperature%data_3d, & + domain%water_vapor%data_3d, & + domain%u_mass%data_3d * options%lsm_options%wind_enhancement, & + domain%v_mass%data_3d * options%lsm_options%wind_enhancement, & + domain%shortwave%data_2d, & + domain%shortwave_direct%data_2d, & ! only used in urban modules, which are currently disabled + domain%shortwave_diffuse%data_2d, & ! only used in urban modules, which are currently disabled + domain%longwave%data_2d, & + domain%pressure_interface%data_3d, & + current_precipitation, & + SR, & + domain%irr_frac_total%data_2d, & ! only used if iopt_irr > 0 + domain%irr_frac_sprinkler%data_2d, & ! only used if iopt_irr > 0 + domain%irr_frac_micro%data_2d, & ! only used if iopt_irr > 0 + domain%irr_frac_flood%data_2d, & ! only used if iopt_irr > 0 + domain%skin_temperature%data_2d, & ! TSK + domain%sensible_heat%data_2d, & ! HFX + QFX, & + domain%latent_heat%data_2d, & ! LH + domain%ground_heat_flux%data_2d, & ! GRDFLX + SMSTAV, & + domain%soil_totalmoisture%data_2d, & + SFCRUNOFF, UDRUNOFF, ALBEDO, SNOWC, & + domain%soil_water_content%data_3d, & + SH2O, & + domain%soil_temperature%data_3d, & + domain%snow_water_equivalent%data_2d, & + domain%snow_height%data_2d, & + domain%canopy_water%data_2d, & + ACSNOM, ACSNOW, EMISS, QSFC, Z0, & + domain%roughness_z0%data_2d, & + domain%irr_eventno_sprinkler, & ! only used if iopt_irr > 0 + domain%irr_eventno_micro, & ! only used if iopt_irr > 0 + domain%irr_eventno_flood, & ! only used if iopt_irr > 0 + domain%irr_alloc_sprinkler%data_2d, & ! only used if iopt_irr > 0 + domain%irr_alloc_micro%data_2d, & ! only used if iopt_irr > 0 + domain%irr_alloc_flood%data_2d, & ! only used if iopt_irr > 0 + domain%irr_evap_loss_sprinkler%data_2d, & ! only used if iopt_irr > 0 + domain%irr_amt_sprinkler%data_2d, & ! only used if iopt_irr > 0 + domain%irr_amt_micro%data_2d, & ! only used if iopt_irr > 0 + domain%irr_amt_flood%data_2d, & ! only used if iopt_irr > 0 + domain%evap_heat_sprinkler%data_2d, & ! only used if iopt_irr > 0 + landuse_name, & + domain%snow_nlayers, & + domain%veg_leaf_temperature%data_2d, & + domain%ground_surf_temperature%data_2d, & + domain%canopy_water_ice%data_2d, & + domain%canopy_water_liquid%data_2d, & + domain%canopy_vapor_pressure%data_2d, & + domain%canopy_temperature%data_2d, & + domain%coeff_momentum_drag%data_2d, & + domain%coeff_heat_exchange%data_2d, & + domain%canopy_fwet%data_2d, & + domain%snow_water_eq_prev%data_2d, & + domain%snow_albedo_prev%data_2d, & + domain%snowfall_ground%data_2d, & + domain%rainfall_ground%data_2d, & + domain%storage_lake%data_2d, & + domain%water_table_depth%data_2d, & + domain%water_aquifer%data_2d, & + domain%storage_gw%data_2d, & + domain%snow_temperature%data_3d, & + domain%snow_layer_depth%data_3d, & + domain%snow_layer_ice%data_3d, & + domain%snow_layer_liquid_water%data_3d, & + domain%mass_leaf%data_2d, & + domain%mass_root%data_2d, & + domain%mass_stem%data_2d, & + domain%mass_wood%data_2d, & + domain%soil_carbon_stable%data_2d, & + domain%soil_carbon_fast%data_2d, & + domain%lai%data_2d, & + domain%sai%data_2d, & + domain%snow_age_factor%data_2d, & + domain%eq_soil_moisture%data_3d, & + domain%smc_watertable_deep%data_2d, & + domain%recharge_deep%data_2d, & + domain%recharge%data_2d, & + domain%mass_ag_grain%data_2d, & ! currently left as zeroes; not used if iopt_crop = 0? + domain%growing_degree_days%data_2d, & ! currently left as zeroes; not used if iopt_crop = 0? + domain%plant_growth_stage, & ! currently left as zeroes; not used if iopt_crop = 0? + domain%gecros_state%data_3d, & ! not set up; only used if iopt_crop = 2 + domain%temperature_2m_veg%data_2d, & + domain%temperature_2m_bare%data_2d, & + domain%mixing_ratio_2m_veg%data_2d, & + domain%mixing_ratio_2m_bare%data_2d, & + domain%surface_rad_temperature%data_2d, & + domain%net_ecosystem_exchange%data_2d, & + domain%gross_primary_prod%data_2d, & + domain%net_primary_prod%data_2d, & + domain%vegetation_fraction_out%data_2d, & + domain%runoff_surface%data_2d, & + domain%runoff_subsurface%data_2d, & + domain%evap_canopy%data_2d, & + domain%evap_soil_surface%data_2d, & + domain%transpiration_rate%data_2d, & + domain%rad_absorbed_total%data_2d, & + domain%rad_net_longwave%data_2d, & + domain%apar%data_2d, & + domain%photosynthesis_total%data_2d, & + domain%rad_absorbed_veg%data_2d, & + domain%rad_absorbed_bare%data_2d, & + domain%stomatal_resist_sun%data_2d, & + domain%stomatal_resist_shade%data_2d, & + domain%frac_between_gap%data_2d, & + domain%frac_within_gap%data_2d, & + domain%ground_temperature_canopy%data_2d, & + domain%ground_temperature_bare%data_2d, & + domain%ch_veg%data_2d, & + domain%ch_bare%data_2d, & + domain%sensible_heat_veg%data_2d, & + domain%sensible_heat_canopy%data_2d, & + domain%sensible_heat_bare%data_2d, & + domain%evap_heat_veg%data_2d, & + domain%evap_heat_bare%data_2d, & + domain%ground_heat_veg%data_2d, & + domain%ground_heat_bare%data_2d, & + domain%net_longwave_veg%data_2d, & + domain%net_longwave_canopy%data_2d, & + domain%net_longwave_bare%data_2d, & + domain%transpiration_heat%data_2d, & + domain%evap_heat_canopy%data_2d, & + domain%ch_leaf%data_2d, & + domain%ch_under_canopy%data_2d, & + domain%ch_veg_2m%data_2d, & + domain%ch_bare_2m%data_2d, & + domain%stomatal_resist_total%data_2d, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + ! TLE: OMITTING OPTIONAL PRECIP INPUTS FOR NOW + ! MP_RAINC, MP_RAINNC, MP_SHCV, MP_SNOW, MP_GRAUP, MP_HAIL ) + where(domain%snow_water_equivalent%data_2d > options%lsm_options%max_swe) domain%snow_water_equivalent%data_2d = options%lsm_options%max_swe + ! now that znt (roughness_z0) has been updated, we need to recalculate terms + lnz_atm_term = log((z_atm+domain%roughness_z0%data_2d)/domain%roughness_z0%data_2d) + if (exchange_term==1) then + base_exchange_term=(75*karman**2 * sqrt((z_atm+domain%roughness_z0%data_2d)/domain%roughness_z0%data_2d)) / (lnz_atm_term**2) + lnz_atm_term=(karman/lnz_atm_term)**2 + endif + + ! note this is more or less just diagnostic and could be removed + domain%longwave_up%data_2d = stefan_boltzmann * EMISS * domain%skin_temperature%data_2d**4 + RAINBL = domain%accumulated_precipitation%data_2dd + rain_bucket = domain%precipitation_bucket endif @@ -756,22 +1523,31 @@ subroutine lsm(domain,options,dt) ! accumulate soil moisture over the entire column domain%soil_totalmoisture%data_2d = domain%soil_water_content%data_3d(:,1,:) * DZS(1) * 1000 do i = 2,num_soil_layers - domain%soil_totalmoisture%data_2d = domain%soil_totalmoisture%data_2d + domain%soil_water_content%data_3d(:,i,:) * DZS(i) + domain%soil_totalmoisture%data_2d = domain%soil_totalmoisture%data_2d + domain%soil_water_content%data_3d(:,i,:) * DZS(i) * 1000 enddo ! 2m Air T and Q are not well defined if Tskin is not coupled with the surface fluxes - call surface_diagnostics(domain%sensible_heat%data_2d, & - QFX, & - domain%skin_temperature%data_2d, & - QSFC, & - CHS2, & - CQS2, & - domain%temperature_2m%data_2d, & - domain%humidity_2m%data_2d, & - domain%surface_pressure%data_2d) + call surface_diagnostics(domain%sensible_heat%data_2d, & + QFX, & + domain%skin_temperature%data_2d, & + QSFC, & + CHS2, & + CQS2, & + domain%temperature_2m%data_2d, & + domain%humidity_2m%data_2d, & + domain%surface_pressure%data_2d, & + VEGFRAC, & + domain%veg_type, & + domain%land_mask, & + domain%temperature_2m_veg%data_2d, & + domain%temperature_2m_bare%data_2d, & + domain%mixing_ratio_2m_veg%data_2d, & + domain%mixing_ratio_2m_bare%data_2d) + endif endif - if (options%physics%landsurface>0) then + ! if (options%physics%landsurface>0) then + if (options%physics%landsurface>0 .OR. options%physics%watersurface>0) then call apply_fluxes(domain, dt) endif diff --git a/src/physics/lsm_noahdrv.f90 b/src/physics/lsm_noahdrv.f90 index 89ab2d54..c4d03e91 100644 --- a/src/physics/lsm_noahdrv.f90 +++ b/src/physics/lsm_noahdrv.f90 @@ -1249,6 +1249,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) FIND_LUTYPE : DO WHILE (LUMATCH == 0) READ (19,*,END=2002) READ (19,*,END=2002)LUTYPE + if (this_image()==1) print *, LUTYPE READ (19,*)LUCATS,IINDEX IF(LUTYPE.EQ.MMINLU)THEN diff --git a/src/physics/lsm_noahmp_gecros.f90 b/src/physics/lsm_noahmp_gecros.f90 new file mode 100644 index 00000000..90dcbde0 --- /dev/null +++ b/src/physics/lsm_noahmp_gecros.f90 @@ -0,0 +1,2411 @@ +!*********************************************************************** +!* GECROS for early and late covering crops * +!* Genotype-by-Environment interaction on CROp growth Simulator * +!* * +!* Author: Xinyou YIN * +!* Crop and Weed Ecology Group * +!* Wageningen University & Research Centre * +!* PO Box 430, 6700 AK Wageningen, Netherlands * +!* * +!* Modified and extended for winter crops * +!* by Joachim INGWERSEN * +!* Biogeophysics Group * +!* University of Hohenheim * +!* * +!*********************************************************************** + +MODULE module_sf_gecros + +implicit none + +!Runtime constant variables defined within this subroutine +!Crop-specific parameters (former *.tbl file) +REAL, PARAMETER :: EG = 1. !Efficiency of germination +REAL, PARAMETER :: CFV = 0.48 !Carbon fraction in vegetative organs +REAL, PARAMETER :: YGV = 0.81 !Grwoth efficiency for vegetative growth +REAL, PARAMETER :: FFAT = 0.02 !Fraction of fat in storage organs +REAL, PARAMETER :: FLIG = 0.06 !Fraction of lignin in storage organs +REAL, PARAMETER :: FOAC = 0.02 !Fraction of organic acids in storage organs +REAL, PARAMETER :: FMIN = 0.02 !Fraction of minerals in storage organs +REAL, PARAMETER :: LNCI = 0.03586 !Initial value of LNC (g N g-1) +REAL, PARAMETER :: TBD = 0.0 !Base temperature of phenology (C) +REAL, PARAMETER :: TOD = 22.5 !Optimum temperature of phenology (C) +REAL, PARAMETER :: TCD = 37.0 !Ceiling temperature of phenology (C) +REAL, PARAMETER :: TSEN = 1.0 !Curvature of temperature response (1) +REAL, PARAMETER :: SPSP = 0.2 !DS for start of photoperiod-sensitive phase +REAL, PARAMETER :: EPSP = 0.7 !DS for end of photoperiod-sensitive phase +REAL, PARAMETER :: CDMHT = 492.6 !Stem dry weight per unit plant height (g m-2 m2) +REAL, PARAMETER :: PMEH = 0.6468 !Fraction of sigmoid curve inflexion in plant height growth period (1) +REAL, PARAMETER :: ESDI = 1.35 !ESD for indeterminate crops +REAL, PARAMETER :: PMES = 0.50 !Fraction of sigmoid curve inflexion in seed growth growth period (1) +REAL, PARAMETER :: TBDV = -1.3 !Base temperature of vernalization (C) +REAL, PARAMETER :: TODV = 4.9 !Optimum temperature of vernalization (C) +REAL, PARAMETER :: TCDV = 15.7 !Ceiling temperature of vernalization (C) +REAL, PARAMETER :: NUPTX = 0.5/24./3600. !Maximum crop nitrogen uptake (g N m-2 s-1) +REAL, PARAMETER :: SLA0 = 0.0237 !Specific leaf area constant (m2 leaf g-1) +REAL, PARAMETER :: SLNMIN = 0.35 !Base SLN for photosynthesis (g N m-2 leaf) +REAL, PARAMETER :: RNCMIN = 0.005 !Minimum N concentration in roots (g N g-1) +REAL, PARAMETER :: STEMNC = 0.01 !Minimum N concentration in stem (g N g-1) +REAL, PARAMETER :: RLVDS = 0.0904 !Rate of C turnover from dead leaves to litter (d-1) +REAL, PARAMETER :: DSCRIT = 0.225 !DS at which winter dormancy ends (1) +REAL, PARAMETER :: EAJMAX = 48270.!Energy of activation for JMAX (J mol-1) +REAL, PARAMETER :: XVN = 24.96 !Slope of linear relationship between JMAX and leaf N (mu-mol CO2 s-1 g-1 N) +REAL, PARAMETER :: XJN = 49.92 !Slope of linear relationship between VCMX and leaf N (mu-mol e- s-1 g-1 N) +REAL, PARAMETER :: NPL = 390.0 !Number of plants per m2 +REAL, PARAMETER :: SEEDW = 0.0475 !Seed weight (g seed-1) +REAL, PARAMETER :: SEEDNC = 0.020 !Seed N concentration (g N g-1) +REAL, PARAMETER :: BLD = 25.58 !Leaf angle (from horizontal) (degree) +REAL, PARAMETER :: HTMX = 1.1 !Maximum plant height (m) +REAL, PARAMETER :: MTDV = 46.12 !Minimum thermal days for vegetative growth phase (d) +REAL, PARAMETER :: MTDR = 40.22 !Minimum thermal days for reproductive phase (d) +REAL, PARAMETER :: PSEN = -.104 !Photoperiod sensitivity of phenological development (h-1) +REAL, PARAMETER :: C3C4 = 1. !C3C4 = 1. for C3 crops; C3C4 = -1. for C4 crops. + +!Runtime-constant general parameters +REAL, PARAMETER :: LEGUME = -1. !LEGUME = 1. for leguminous crops; = -1. for non-leguminous crops. +REAL, PARAMETER :: DETER = 1. !DETER = 1. for determinate crops; = -1. for indeterminate crops. +REAL, PARAMETER :: SLP = -1. !SLP = 1. for short-day crops; = -1. for long-day crops. +REAL, PARAMETER :: NSUP1 = 0. !NH4-N supply in g/m2/s +REAL, PARAMETER :: NSUP2 = 1./172800. !NO3-N supply in g/m2/s +REAL, PARAMETER :: CO2A=350. !Atmospherric CO2 concentration (ppm) +REAL, PARAMETER :: FCRSH=0.5 !Initial fraction of C in shoot (-) +REAL, PARAMETER :: FNRSH=0.63 !Initial fraction of N in shoot (-) +REAL, PARAMETER :: PNPRE=0.7 !Proportion of seed N that comes from non-structural stems during seed fill +REAL, PARAMETER :: CB=0.75 !Factor for initial N concentration of seed fill +REAL, PARAMETER :: CX=1.00 !Factor for final N concentration of seed fill +REAL, PARAMETER :: TM=1.5 !DS when transition from CB to CX is fastest +REAL, PARAMETER :: RSS=100. !Soil resistance to evaporation (s/m) +REAL, PARAMETER :: LS=0. !Lodging sverity (value between zero and unity) +REAL, PARAMETER :: WRB=0.25 !Critical root weight density (g/m2/cm depth) +REAL, PARAMETER :: THETA=0.7 !Convexity for light response curve of electron transport (J2) in photosynthesis +REAL, PARAMETER :: PNLS=1. !Fraction of dead leaf N incorporated into soil litter N +REAL, PARAMETER :: INSP=-2. !Inclination of sun angle (degree) +REAL, PARAMETER :: CCFIX=6. !Carbon cost of symbiotic N fixation (g C/g N) +REAL, PARAMETER :: RDMX=130. !Maximum rooting depth (m) +REAL, PARAMETER :: TCP=86400. !Conversion factor from day into sec +REAL, PARAMETER :: Z1244=0.272727272727 !12./44. +REAL, PARAMETER :: LOG005=-2.995732274 !LOG(0.05) + +!Runtime constant variables computed in driver.f +REAL :: YGO !Growth efficiency of storage organs (g C/g C) +REAL :: CFO !Carbon fraction in storage organs (g C/g) +REAL :: LNCMIN !Minimum N concentration in leaves (g N/g) +REAL :: CLVI !Initial value of CLV +REAL :: CRTI !Initial value of CRT +REAL :: NLVI !Initial value of NLV +REAL :: NRTI !Initial value of NRT +REAL :: HTI !Initial value of HT +REAL :: RDI !Initial value of RD + +!*** Debugging on/off +LOGICAL :: debugging=.false. + +CONTAINS + +SUBROUTINE gecros (DOY, DT, CROP, RB, RT, RTS, FB, SNOWH, & !I + WN, SFCTMP, EAIR, RSD, RLD, PRCP, WUL, WLL, WCMIN, LWIDTH, & !I & !I + STATE_GECROS, & !H + ATRJC, ATRJS, FSR, FRSU, ARSWSU, ARSWSH) !O + +IMPLICIT NONE + +! character(len=19), INTENT(IN) :: nowdate ! string of current date e.g. 2012-30-10_12:00:00 + INTEGER, INTENT(IN) :: CROP !CROP=1 -> early-covering crop, CROP=2 -> later covering crop + REAL, INTENT(IN) :: DOY !Julian day of the current time step + REAL, INTENT(IN) :: DT !Integration time step (s) + REAL, INTENT(IN) :: RB !Leaf boundary layer resistance (s/m) + REAL, INTENT(IN) :: RT !Aerodynamic canopy resistance (s/m) + REAL, INTENT(IN) :: RTS !Aerodynamic ground resistance (s/m) + REAL, INTENT(IN) :: FB !Fraction of vegetation cover by snow + REAL, INTENT(IN) :: SNOWH !Snow height (cm) + REAL, INTENT(IN) :: WN !Wind speed (m/s) + REAL, INTENT(IN) :: SFCTMP !Air temperature (K) + REAL, INTENT(IN) :: EAIR !Vapour pressure (Pa) + REAL, INTENT(IN) :: RSD !Downwelling shortwave radiation (W/m2) + REAL, INTENT(IN) :: RLD !Downwelling longwave raidation (W/m2) + REAL, INTENT(IN) :: PRCP !Precipiration (kg/m2/s) + REAL, INTENT(IN) :: WUL !Soil water in the upper layer (L/m2 or mm) + REAL, INTENT(IN) :: WLL !Soil water in the lower layer (L/m2 or mm) + REAL, INTENT(IN) :: WCMIN !Minimum soil watter content (m3/m3) + REAL, INTENT(IN) :: LWIDTH !Leaf width (m) read in from MPTABLE.TBL + REAL, INTENT(OUT) :: ATRJC !Absorbed global radiation by canopy (W/m2) + REAL, INTENT(OUT) :: ATRJS !Absorbed global radiation by soil (W/m2) + REAL, INTENT(OUT) :: FSR !Reflected shortwave radiation (W/m2) + REAL, INTENT(OUT) :: FRSU !Fraction of sunlit leaves in the canopy + REAL, INTENT(OUT) :: ARSWSU !Actual stomatal resistance of sunlit leaves (s/m) + REAL, INTENT(OUT) :: ARSWSH !Actual stomatal resistance of shaded leaves (s/m) + REAL, DIMENSION(1:60), INTENT(INOUT) :: STATE_GECROS !Array with Gecros state variables + + !*** Gecros state variables + REAL :: DS !Development stage + REAL :: LAI !Green leaf area index + REAL :: TLAI !Total leaf area index + REAL :: CTDU !Cumulative thermal day unit (d) + REAL :: CVDU !Cumulative thermal day unit of vernalization (d) + REAL :: CLV !Carbon in living leaves (g C/m2) + REAL :: CLVD !Carbon in dead leaves (g C/m2) + REAL :: CSST !Carbon in structural stems (g C/m2) + REAL :: CSO !Carbon in storage organs (g C/m2) + REAL :: CSRT !Carbon in structural roots (g C/m2) + REAL :: CRTD !Carbon in dead roots (g C/m2) + REAL :: CLVDS !Carbon in dead leaves that have become litter in soil (g C/m2) + REAL :: NRT !Nitrogen in living roots (g N/m2) + REAL :: NST !Nitrogen in stems (g N/m2) + REAL :: NLV !Nitrogen in living leaves (g N/m2) + REAL :: NSO !Nitrogen in storage organs (g N/m2) + REAL :: TNLV !Total leaf nitrogen (including N in senesced leaves) (g N/m2) + REAL :: NLVD !Nitrogen in dead leaves (g N/m2) + REAL :: NRTD !Nitrogen in dead roots (g N/m2) + REAL :: CRVS !Carbon in stem reserves (g C/m2) + REAL :: CRVR !Carbon in root reserves (g C/m2) + REAL :: NREOE !NRES accumulated till the end of seed number determining period (g N/m2) + REAL :: NREOF !NRES accumulated till the moment at which seed fill starts (g N/m2) + REAL :: DCDSR !Short fall of carbon demand for seed fill in previous time steps (g C/m2) + REAL :: DCDTR !Short fall of carbon demand for structural stems in previous time steps (g C/m2) + REAL :: SLNB !SLN in bottom leaves of canopy (g N/m2) + REAL :: LAIC !Carbon determined LAI (m2/m2) + REAL :: RMUL !Total of RMUN+RMUA+RMUS+RMLD + REAL :: NDEMP !Crop nitrogen demand of the previous time step (g N/m2/s) + REAL :: NSUPP !Nitrogen supply of the previous time step (g N/m2/s) + REAL :: NFIXT !Total symbiotically fixed nitrogen during growth (g N/m2) + REAL :: NFIXR !Reserve pool of symbiotically fixed nitrogen (g N/m2) + REAL :: DCDTP !Carbon demand for structural stem growth of the previous time step (g C/m2/s) + REAL :: HT !Canopy height (m) + REAL :: TPCAN !Cumulative canopy photosynthesis over growth period (g CO2/m2) + REAL :: TRESP !Total crop respiratory cost during growth (g CO2/m2) + REAL :: TNUPT !Total crop nitrogen uptake during growth (g N/m2) + REAL :: LITNT !Total litter nitrogen entering soil during growth (g N/m2) + REAL :: WSO !Yield (g/m2) + REAL :: WSTRAW !Straw (g/m2) + REAL :: GrainNC !Nitrogen in grain (kg N/ha) + REAL :: StrawNC !Nitrogen in straw (kg N/ha) + REAL :: APCAN !Actual gross canopy photosynthesis (g CO2/m2/d) + + character(Len=12) :: inputstring + INTEGER :: nowday, minutes + REAL :: SC !Solar constant (W/m2) + REAL :: SINLD !Seasonal offset of sine of solar height (-) + REAL :: COSLD !Amplitude of sine of solar height (-) + REAL :: DAYL !Day length (h) + REAL :: DDLP !Day length for photoperiodism (h) + REAL :: DSINBE !DSINB to correct for lower atmospheric transmission at lower solar elevation (s/d) + REAL :: DVP !Vapour pressure (kPa) + REAL :: WNM !Wind speed (m/s) + REAL :: TAIR !Air temperature (C) + REAL :: ROOTD !Rooting depth (m) + REAL :: WLV !Dry weight of living leaves (g/m2) + REAL :: WST !Dry weight of stems (g/m2) + REAL :: WRT !Dry weight of roots (g/m2) + REAL :: WSH !Dry weight of shoot (g/m2) + REAL :: WLVD !Dry weight of dead leaves (g/m2) + REAL :: WRTD !Dry weight of dead roots (g/m2) + REAL :: CRT !Carbon in living roots (g C/m2) + REAL :: CSH !Carbon in living shoot (g C/m2) + REAL :: NSH !Nitrogen in living shoot (g N/m2) + REAL :: DLAI !LAI of dead leaves still hanging on stem (m2/m2) + REAL :: ESD !DS for end of seed-number determing phase (-) + REAL :: KCRN !EXtinction coefficient of root nitrogen (m2/g C) + REAL :: NFIXD !Crop demand-determined NFIX (g N/2/s) + REAL :: KR !Extinction coefficient of root weight density over soil septh (1/cm) + REAL :: HNCCR !Critical shoot N concentration ( g N/g) + REAL :: FVPD !Slope of linear effect of VPD of intercelluar to ambient CO2 ratio (1/kPa) + REAL :: NRETS !Total crop-residue N returned to soil (g N/m2) + REAL :: WCUL !Soil water content in uppler layer (m3/m3) + REAL :: DWSUP !Water supply for evapotranspiration (mm/s) + REAL :: CSRTN !N determined CSRT (g C/m2) + REAL :: NRES !Estimated vegetative-organ N remobilizable for seed fill (g N/m2) + REAL :: ONC !N concentration in storage organ (g N/g) + REAL :: RNC !N concentration in roots (g N/g) + REAL :: LNC !N concentration in living leaves (g N/g) + REAL :: KL !Extinction coefficient diffuse component for PAE (m2/m2 leaf) + REAL :: CTOT !Total C in living shoots and roots (g C/m2) + REAL :: NSHH !N in shoots (excluding dead leaves incorporated into soil litter (g N/m2) + REAL :: NTOT !Total N in living shoots and roots (g N/m2) + REAL :: WSHH !Dry weight of shoots organs (excluding shadded leaves) (g/m2) + REAL :: TSN !Total seed number (seeds/m2) + REAL :: HNC !Actural N concentration in living shoot (g N/g) + REAL :: PSO !Protein content in storage organs (g protein/m2) + REAL :: KLN !Intermediate variable to compute KN (g N/m2 leaf) + REAL :: NBK !Intermediate variable to compute KN (g N/m2 leaf) + REAL :: KW !Wind speed extinction coefficient in canopy (m2/m2 leaf) + REAL :: WTOT !Dry weight of total living plant parts (g/m2) + REAL :: CCHKIN !C in crop accumulated since start of simulation + REAL :: NCHKIN !N in crop accumulated since start of simulation + REAL :: LCRT !Rate of C loss in rooots because of senescence (g C/m2/s) + REAL :: TSW !Thousand seed weight (g) + REAL :: PNC !N concentration in living plant material (g N/m2) + REAL :: NDEMD !Defiency-driven N demand (g N/m2/s) + REAL :: FCRVR !Fraction of new root C partitioned to root reserves (g C/g C) + REAL :: KN !Leaf N extinction coefficient in the canopy (m2/m2 leaf) + REAL :: CCHK !Diff. between C added to the crop since start and net total C fluxes rel. to CCHKIN (%) + REAL :: HI !Harvest index (g/g) + REAL :: LWRT !Rate of loss of root biomass because of senescence (g/m2/s) + REAL :: NCHK !As CCHK but for N + REAL :: LAIN !N-determined LAI (m2/m2) + REAL :: LNRT !Rate of loss of N because of senescence (g N/m2/s) + REAL :: LWLVM !Intermediate variable to compute LWLV (g/m2/s) + REAL :: SLNNT !Value of SLNT with small plant-N increment (g N/m2 leaf) + REAL :: SLNBC !SLNB calculated from exponential N profile in canopy (g N/m2 leaf) + REAL :: SLN !Specific leaf N content (g N/m2 leaf) + REAL :: SLA !Specific leaf area (m2 leaf/g) + REAL :: LWLV !Rate of loss of leaf weight because of leaf senescence (g/m2/s) + REAL :: AESOIL !Actual soil evaporation (mm/s) + REAL :: APCANN !APCANS with small plant-N increment (g CO2/m2/s) + REAL :: APCANS !Actual standing canopy CO2 assimilation (g CO2/m2/s) + REAL :: ATCAN !Actual canopy transpiration (mm/s) + REAL :: DAPAR !PAR absorbed by canopy (J/m2/s) + REAL :: DIFS !Daytime average soil-air temperature difference (C) + REAL :: DIFSH !Daytime average shaded leaf-air temperature difference (C) + REAL :: DIFSU !Daytime average sunlit leaf-air temperature difference (C) + REAL :: FRSH !Fraction of shaded leaves in the canopy + REAL :: HOD !Hour of the day + REAL :: PESOIL !Potential soil evaporation (mm/s) + REAL :: PPCAN !Potential canopy assimilation (g CO2/m2/s) + REAL :: PTCAN !Potential canopy transpiration (mm/s) + REAL :: RCAN !Canopy resistance (s/m) + REAL :: RSLNB !Rate of change in SLNB (g N/m2 leaf/s) + REAL :: LNLV !Rate of loss of leaf N because of senescence (g N/m2/s) + REAL :: LCLV !Rate of loss of leaf C because of senescence (g C/m2/s) + REAL :: RMRE !Residual maintenance respiration (g CO2/m2/s) + REAL :: TAVSS !Soil surface temperature (C) + REAL :: RMN !RM calculated with a small increment in plant N (g CO2/m2/s) + REAL :: VDU !Rate of Vernalization day unit increase (d/s) + REAL :: TDU !Rate of thermal day unit increase (d/s) + REAL :: RM !Non-growth components of respiration, excluding the cost of N fixation (g CO2/m2/s) + REAL :: LVDS !Rate of transfer of C from dead leaves to litter (g C/m2/s) + REAL :: NFIXE !Available energy-determined NFIX (g N/m2/s) + REAL :: DVR !Phenological development rate (1/s) + REAL :: RX !Respiratory cost of N fixation (g CO2/m2/s) + REAL :: RNSUPP !Rate of change in NSUPP (g N/m2/s) + REAL :: NSUP !N supply to crop (g N/m2/s) + REAL :: NFIX !Symbioticall fixed N (g N/m2/s) + REAL :: LITN !Litter N entering soil (g N/m2/s) + REAL :: LITC !Litter C entering soil (g C/m2/s) + REAL :: FDH !Expected relative growth rate of plant height (1/s) + REAL :: FDS !Expected relative growth rate of storage organs (1/s) + REAL :: SHSAN !SHSA calculated with a small increment in plant-N (g C/g C/s) + REAL :: SHSA !Relative shoot activity (g C/g C/s) + REAL :: RMUS !Respiratory cost of mineral uptake (g CO2/m2/s) + REAL :: NDEMAD !Intermediate variable related to NDEM (g N/m2/s) + REAL :: NDEMA !Activity-driven NDEM (g N/m2/s) + REAL :: NCR !Intermediate variable (g N/g C) + REAL :: DERI !First order-derivative of SHSA with respect to crop N/C ratio (g C/g N/s) + REAL :: ASSA !Assimilates available from current photosynthesis for growth (g CO2/m2/s) + REAL :: RNFIXR !Rate of change in NFIXR (g N/m2/s) + REAL :: RNDEMP !Rate of change in NDEMP (g N/m2/s) + REAL :: RMLD !Respiration due to phloem loading of C assimilates to root (g CO2/m2/s) + REAL :: RCSRT !Rate of change in CSRT (g C/m2/s) + REAL :: NUPTN !Nitrate-N uptake by the crop (g N/m2/s) + REAL :: NUPTA !Ammonium-N uptake by the crop (g N/m2/s) + REAL :: NDEM !Crop N demand (g N/m2/s)SUBROUTINE ENERGY + REAL :: FNSH !Fraction of newly absorbed N partitioned to shoot (g N/g N) + REAL :: FCSH !Fraction of new V partitioned to shoot (g C/g C) + REAL :: DCSR !C supply from current photosynthesis for root growth (g C/m2/s) + REAL :: SLNT !SLN for top leaves in canopy (g N/m2 leaf) + REAL :: RMUN !Respiratory cost of nitrate-N uptake (g CO2/m2/s) + REAL :: RMUA !Respiratory cost of ammonium-N uptake (g CO2/m2/s) + REAL :: NUPT !Crop N uptake (g N/m2/s) + REAL :: DCDSC !C demand for seed filling at current time step (g C/m2/s) + REAL :: DCDS !C demand for filling of storage organgs at current time step (g C/m2/s) + REAL :: FLWCS !Flow of current assimilated C to storage organs (g C/m2/s) + REAL :: DCSS !C supply from current photosynthesis for shoot growth (g C/m2/s) + REAL :: DCST !C suppyl from current photosynthesis for structural stem growth (g C/m2/s) + REAL :: FCSO !Fraction of new C partitioned to storage organs (g C/m2/s) + REAL :: RRMUL !Rate of change in RMUL (g CO2/m2/s) + REAL :: RHT !Rate of change in HT (m/s) + REAL :: IFSH !Integral factor of stresses on plant height growth (-) + REAL :: GAP !Gap betweeb C supply and C demand for seed growth (g C/m2/s) + REAL :: CREMSI !Intermediate variable to compute CREMS (g C/m2/s) + REAL :: CREMS !C remobilized from stem reserves to storage organs (g C/m2/s) + REAL :: CREMRI !Intermediate variable to compute CREMR (g C/m2/s) + REAL :: CREMR !C remobilized from root reserves to storage organs (g C/m2/s) + REAL :: RWSO !Rate of change in storage organs(g/m2/s) + REAL :: RWRT !Rate of change in roots (g/m2/s) + REAL :: RRD !Rate of change in RD (cm/s) + REAL :: RDCDTP !Rate of change in DCDTP (g C/m2/s) + REAL :: RDCDSR !Rate of change in DCDSR (g C/m2/s) + REAL :: RCSST !Rate of change in CSST (g C/m2/s) + REAL :: RCSO !Rate of change in CSO (g C/m2/s) + REAL :: RCRVR !Rate of change in CRVR (g C/m2/s) + REAL :: FLWCT !Flow of assimilated C to structural stems (g C/m2/s) + REAL :: FCSST !Fraction of new shoot C partitioned to structural stems (g C/m2/s) + REAL :: FCLV !Fraction of new shoot C partitioned to leaves (g C/m2/s) + REAL :: DCDTC !C demand of structural stem growth at current time step (g C/m2/s) + REAL :: DCDT !C demand for the growth of structural stems (g C/m2/s) + REAL :: FCRVS !Fraction of new C paritioned to stem reserves (g C/m2/s) + REAL :: RCLV !Rate of change in CLV (g C/m2/s) + REAL :: RCRVS !Rate of change in CRVS (g C/m2/s) + REAL :: RDCDTR !Rate of change in DCDTR (g C/m2/s) + REAL :: RESTOT !Total respiratory cost (g CO2/m2/s) + REAL :: RG !Growth respiration (g CO2/m2/s) + REAL :: RLAI !Rate of change in LAI (m2 leaf/m2/s) + REAL :: RNLV !Rate of change in NLV (g N/m2/s) + REAL :: RNREOE !Rate of change in NREOE (g N/m2/s) + REAL :: RNREOF !Rate of change in NREOF (g N/m2/s) + REAL :: RNRES !Rate of change in NRES (g N/m2/s) + REAL :: RNRT !Rate of change in NRT (g N/m2/s) + REAL :: RNSO !Rate of change in NSO (g N/m2/s) + REAL :: RNST !Rate of change in NSZ (g N/m2/s) + REAL :: RRP !Respiration/photosynthesis ratio (-) + REAL :: RTNLV !Rate of change in TNLV (g N/m2/s) + REAL :: RWLV !Rate of change in WLV (g/m2/s) + REAL :: RWST !Rate of change in WST (g/m2/s) + REAL :: GLAT !Latitude (degree) + REAL :: SD1 !Thickness of upper evaporative soil layer (cm) (equals RDI) + + !*** write STATE_GECROS array into Gecros variables + DS = STATE_GECROS(1) + CTDU = STATE_GECROS(2) + CVDU = STATE_GECROS(3) + CLV = STATE_GECROS(4) + CLVD = STATE_GECROS(5) + CSST = STATE_GECROS(6) + CSO = STATE_GECROS(7) + CSRT = STATE_GECROS(8) + CRTD = STATE_GECROS(9) + CLVDS = STATE_GECROS(10) + NRT = STATE_GECROS(11) + NST = STATE_GECROS(12) + NLV = STATE_GECROS(13) + NSO = STATE_GECROS(14) + TNLV = STATE_GECROS(15) + NLVD = STATE_GECROS(16) + NRTD = STATE_GECROS(17) + CRVS = STATE_GECROS(18) + CRVR = STATE_GECROS(19) + NREOE = STATE_GECROS(20) + NREOF = STATE_GECROS(21) + DCDSR = STATE_GECROS(22) + DCDTR = STATE_GECROS(23) + SLNB = STATE_GECROS(24) + LAIC = STATE_GECROS(25) + RMUL = STATE_GECROS(26) + NDEMP = STATE_GECROS(27) + NSUPP = STATE_GECROS(28) + NFIXT = STATE_GECROS(29) + NFIXR = STATE_GECROS(30) + DCDTP = STATE_GECROS(31) + HT = STATE_GECROS(32) + ROOTD = STATE_GECROS(33) + TPCAN = STATE_GECROS(34) + TRESP = STATE_GECROS(35) + TNUPT = STATE_GECROS(36) + LITNT = STATE_GECROS(37) + GLAT = STATE_GECROS(44) + WSO = STATE_GECROS(45) + WSTRAW = STATE_GECROS(46) + GrainNC = STATE_GECROS(47) + StrawNC = STATE_GECROS(48) + LAI = STATE_GECROS(49) + TLAI = STATE_GECROS(50) + SD1 = STATE_GECROS(52) + + ! Used for debugging +! if (nowdate(9:12).eq.'2500') then +! write(*,*) nowdate, ' 1 ', DS +! write(*,*) nowdate, ' 2 ', CTDU +! write(*,*) nowdate, ' 3 ', CVDU +! write(*,*) nowdate, ' 4 ', CLV +! write(*,*) nowdate, ' 5 ', CLVD +! write(*,*) nowdate, ' 6 ', CSST +! write(*,*) nowdate, ' 7 ', CSO +! write(*,*) nowdate, ' 8 ', CSRT +! write(*,*) nowdate, ' 9 ', CRTD +! write(*,*) nowdate, ' 10 ', CLVDS +! write(*,*) nowdate, ' 11 ', NRT +! write(*,*) nowdate, ' 12 ', NST +! write(*,*) nowdate, ' 13 ', NLV +! write(*,*) nowdate, ' 14 ', NSO +! write(*,*) nowdate, ' 15 ', TNLV +! write(*,*) nowdate, ' 16 ', NLVD +! write(*,*) nowdate, ' 17 ', NRTD +! write(*,*) nowdate, ' 18 ', CRVS +! write(*,*) nowdate, ' 19 ', CRVR +! write(*,*) nowdate, ' 20 ', NREOE +! write(*,*) nowdate, ' 21 ', NREOF +! write(*,*) nowdate, ' 22 ', DCDSR +! write(*,*) nowdate, ' 23 ', DCDTR +! write(*,*) nowdate, ' 24 ', SLNB +! write(*,*) nowdate, ' 25 ', LAIC +! write(*,*) nowdate, ' 26 ', RMUL +! write(*,*) nowdate, ' 27 ', NDEMP +! write(*,*) nowdate, ' 28 ', NSUPP +! write(*,*) nowdate, ' 29 ', NFIXT +! write(*,*) nowdate, ' 30 ', NFIXR +! write(*,*) nowdate, ' 31 ', DCDTP +! write(*,*) nowdate, ' 32 ', HT +! write(*,*) nowdate, ' 33 ', ROOTD +! write(*,*) nowdate, ' 34 ', TPCAN +! write(*,*) nowdate, ' 35 ', TRESP +! write(*,*) nowdate, ' 36 ', TNUPT +! write(*,*) nowdate, ' 37 ', LITNT +! read(*,*) +! endif + + PPCAN=0. + APCANS=0. + APCANN=0. + APCAN=0. + PTCAN=0. + ATCAN=0. + PESOIL=0. + AESOIL=0. + DIFS=0. + DIFSU=0. + DIFSH=0. + DAPAR=0. + RCAN=0. + DVR=0. + + nowday = INT(DOY) + HOD = float(nint((DOY-int(DOY))*86400.))/3600. + + ! Conversion from K to C + TAIR = SFCTMP - 273.15 + + ! Conversion of rel. humidity into VP (kPa) + DVP = EAIR*0.001 !Converts EAIR from Pa to kPa + WNM = MAX (0.1, WN) + + ! Photoperiod, solar constant and daily extraterrestrial radiation + CALL ASTRO(aint(DOY),GLAT,INSP,SC,SINLD,COSLD,DAYL,DDLP,DSINBE) + + ! Plant weights (g/m2) + WLV = CLV / CFV + WST = CSST / CFV + CRVS/0.444 + WSO = CSO / CFO + WRT = CSRT / CFV + CRVR/0.444 + WLVD = CLVD / CFV + WRTD = CRTD / CFV + + ! Carbon in shoot and root (g C/m2) + CSH = CLV + CSST + CRVS + CSO + CRT = CSRT + CRVR + + ! Nitrogen in shoot (g C/m2) + NSH = NST + NLV + NSO + + ! Extinction coefficient of root nitrogen (m2/g C) + KCRN = -LOG005/6.3424/CFV/WRB/RDMX + + ! DS for end of seed number determining period + ESD = INSW(DETER, ESDI, 1.) + + ! Dead leaves still hanging on the plant (m2/m2 + DLAI = (CLVD-CLVDS)/CFV*SLA0 + + ! Total leaf area index (dead plus living leaves) + TLAI = MAX(0.01,LAI + DLAI) + + ! Crop demand-determined NFIX + NFIXD = MAX(0., NDEMP - NSUPP) + + ! Critical shoot nitrogen concentration g N g-1 + HNCCR = LNCI*EXP(-.4*DS) + + !Extinction coefficient of root weight density over the soil depth cm-1 + KR = -LOG005/RDMX !cm-1 + + ! Slope of linear effect of VPD on intercelluar to ambient CO2 ratio (1/kPa) + FVPD = INSW (C3C4, 0.195127, 0.116214) + + ! Total crop-residue nitrogen returned to soil (g N/m2) + NRETS = LITNT+INSW(DS-2.,0.,NLV+NST+NRT+NFIXR+(CLVD-CLVDS)/ & + CFV*LNCMIN*(1.+PNLS)/2.) + + !if (nowdate(1:12).eq.'201110061930') then + !write(*,*) 'Bis hier her bin ich gekommen', ROOTD + !endif + + ! Soil water content of the upper and lower layer (m3/m3) + WCUL = (WUL+WCMIN*10.*ROOTD)/10./ROOTD + + ! Daily water supply for evapotranspiration (mm/s) + DWSUP = MAX(.1/TCP,WUL/TCP+.1/TCP) + + ! Nitrogen-determined CSRT (g C/m2) + CSRTN = 1./KCRN*LOG(1.+KCRN*MAX(0.,(NRT*CFV-CRVR*RNCMIN))/RNCMIN) + + ! Straw weight (g/m2) + WSTRAW = WLV + WST + (WLVD - CLVDS/CFV) + + ! Shoot weight (g/m2) + WSH = WLV + WST + WSO + + ! Estimated vegetative-organ N remobilizable for seed growth (g N/m2) + NRES = NREOF + (NREOE-NREOF)*(ESD-1.)/NOTNUL(MIN(DS,ESD)-1.) + + ! Nitrogen concentration in living leaves LAI(g N/m2) + LNC = NLV / NOTNUL(WLV) + + ! Nitrogen concentration in roots (g N/m2) + RNC = NRT / NOTNUL(WRT) + + ! Nitrogen concentration seeds (g N/m2) + ONC = INSW(-WSO, NSO/NOTNUL(WSO), 0.) + + ! Nitrogen in grain and straw in kg N per ha + GrainNC = NSO*10. + StrawNC = (NLV+NST)*10. + + ! Extinction coefficient of nitrogen and wind + CALL KDIFF (TLAI,BLD*3.141592654/180.,0.2, KL) + + CTOT = CSH + CRT + NSHH = NSH +(WLVD-CLVDS/CFV)*LNCMIN + NTOT = NSH + NRT + WSHH = WSH + (WLVD-CLVDS/CFV) + TSN = NRES/PNPRE/SEEDNC/SEEDW + HNC = NSH / NOTNUL(WSH) + + ! Amount of seed protein + PSO = 6.25*WSO*ONC + + KLN = KL*(TNLV-SLNMIN*TLAI) + + NBK = SLNMIN*(1.-EXP(-KL*TLAI)) + KW = KL + WTOT = WSH + WRT + + ! Crop carbon balance check + CCHKIN = CTOT + CLVD + CRTD -CLVI-CRTI + + ! Crop nitrogen balance check + NCHKIN = NTOT + NLVD + NRTD -NLVI-NRTI + + LCRT = MAX(MIN(CSRT-1.E-4,CSRT-MIN(CSRTN,CSRT)),0.)/TCP !Eq. 43, p. 38, DELT ok, gC m-2 s-1 + + FCRVR = INSW(CSRTN-CSRT, 1., 0.) + PNC = NTOT / NOTNUL(WTOT) + + KN = 1./TLAI*LOG(MAX(1.001,(KLN+NBK)/(KLN*EXP(-KL*TLAI)+NBK))) + + TSW = WSO/NOTNUL(TSN)*1000. + + NDEMD = INSW(DS-1., WSH*(HNCCR-HNC)*(1.+NRT/MAX(1E-2,NSH))/TCP, 0.) !Eq. 20, p.25, DELT ok, g N m-2 s-1 + + ! Biomass formation + HI = WSO / NOTNUL(WSHH) + CCHK = (CCHKIN-(TPCAN-TRESP)*Z1244)/NOTNUL(CCHKIN)*100. + NCHK = (NCHKIN-TNUPT)/NOTNUL(TNUPT)*100. + LWRT = LCRT/CFV !g m-2 s-1 + + ! Leaf area development + LAIN = LOG(1.+ KN*MAX(0.,NLV)/SLNMIN)/KN + LNRT = LWRT*RNCMIN !g N m-2 s-1 + + ! Green leaves still hanging on the plant (m2/m2) + LAI = MAX(0.01,MIN(LAIN, LAIC)) + + ! Leaf senescence + ! The equation differs somewhat from Yin. The right hand side is not divided by deltaT + ! This is done by computing LWLV + ! LWLVM = (LAIC-MIN(LAIC,LAIN))/SLA0/DELT !Eq. 42, p.36, DELT ok, g m-2 s-1 + + LWLVM = (LAIC-MIN(LAIC,LAIN))/SLA0 !Eq. 42, p.36, DELT ok, g m-2 s-1 + + ! Specific leaf nitrogen and its profile in the canopy + SLN = NLV/LAI + SLNT = NLV*KN/(1.-EXP(-KN*LAI)) + SLNBC = NLV*KN*EXP(-KN*LAI)/(1.-EXP(-KN*LAI)) + SLNNT = (NLV+0.001*NLV)*KN /(1.-EXP(-KN*LAI)) + SLA = LAI/NOTNUL(WLV) + + ! ji, 1402, Stay-green maize -> no senescense + LWLV = MIN((WLV-1.E-5)/TCP, (LWLVM+REANOR(ESD-DS,LWLVM)*0.03*WLV)/TCP) !g m-2 s-1, gecheckt ok + + !write(*,*) nowdate, DWSUP,CO2A,LS,EAJMAX,XVN,XJN,THETA,WCUL,FVPD,RB,RT,RTS + !read(*,*) + ! Call TOTPT: Computes daily total photosynthesis and stomatal resistance + CALL TOTPT(HOD,DS,SC,SINLD,COSLD,DAYL,DSINBE,RSD,TAIR,DVP,WNM,C3C4,LAI, & + TLAI,HT,LWIDTH,ROOTD,SD1,RSS,BLD,KN,KW,SLN,SLNT,SLNNT,SLNMIN,FB,& + DWSUP,CO2A,LS,EAJMAX,XVN,XJN,THETA,WCUL,FVPD,RB,RT,RTS, & + PPCAN,APCANS,APCANN,APCAN,PTCAN,ATCAN,PESOIL,AESOIL,DIFS,DIFSU, & + DIFSH,DAPAR,RCAN,ATRJC,ATRJS,FSR,FRSU,FRSH,ARSWSU,ARSWSH) + + RSLNB = (SLNBC-SLNB)/TCP !!Eq. 38, p. 35, DELT ok, g N m-2 leaf s-1 + + LNLV = MIN(LWLV,LWLVM)*LNCMIN + (LWLV-MIN(LWLV,LWLVM))*LNC !g m-2 s-1 + LCLV = LWLV*CFV !g m-2 s-1 + + ! Residual maintenance respiration g m-2 s-1 + RMRE = MAX(MIN(44./12.*0.218*(NTOT-WSH*LNCMIN-WRT*RNCMIN)/TCP & + ,APCAN-(1.E-5+RMUL)/TCP), 0.) !0.218 has the unit g C g-1 N d-1! + + TAVSS = TAIR + DIFS + + ! Call TUNIT: Computes cumulative thermal units (CTDU) + CALL TUNIT (1.*CROP, DS,TAIR,MAX(0.,DIFS),DAYL,TBD,TOD,TCD,TBDV,TODV,TCDV,TSEN,TDU,VDU) + + RMN = MAX(0., MIN(APCAN-1.E-5/TCP,RMUL/TCP) + MAX(MIN(44./12.*0.218* & + (1.001*NTOT-WSH*LNCMIN-WRT*RNCMIN)/TCP,APCAN-(1.E-5+RMUL)/TCP), 0.)) + + RM = MAX(0., MIN(APCAN-1.E-5/TCP,RMUL/TCP) + RMRE) !gC m-2 s-1 + + ! Daily and total C and N returns from crop to soil + ! ji: RLVDS eingefuehrt. Standardmaessig war der Wert von RLVDS auf 0.1 hard-gecoded + ! CLVD: Amount of carbon in dead leaves + ! CLVDS: Amount of carbon in dead leaves that have become litter in soil + + IF(DS.lt.0.25) THEN + LVDS = (CLVD-CLVDS)/TCP !gC m-2 s-1 + ELSE + LVDS = RLVDS*(CLVD-CLVDS)*(TAVSS-TBD)/(TOD-TBD)/TCP !gC m-2 s-1 + ENDIF + + CALL PHENO (1.*CROP,DS,SLP,DDLP,SPSP,EPSP,PSEN,MTDV,MTDR,TDU,CVDU,DVR) + + NFIXE = MAX(0., APCAN-(1.E-5+RM)/TCP)/CCFIX*Z1244 + + ! Daily carbon flow for seed filling + CALL BETAF(DVR,1.,PMES,LIMIT(1.,2.,DS)-1., FDS) + + LITC = LCRT + LVDS !gC m-2 s-1 + LITN = LNRT + LVDS/CFV *LNCMIN*PNLS !gN m-2 s-1 + + CALL BETAF(DVR,(1.+ESD)/2.,PMEH*(1.+ESD)/2.,MIN((1.+ESD)/2.,DS), FDH) + + NSUP = NSUP1 + NSUP2 !gN m-2 s-1 + + NFIX = INSW (LEGUME, 0., MIN(NFIXE, NFIXD)) !N fixation + + RNSUPP = (NSUP - NSUPP)/DT !RNSUPP g N m-2 s-2 + RX = 44./12.*(CCFIX*NFIX) + +!*** Current photo-assimilates (g CO2 m-2 s-1) for growth, and R/P ratio + ASSA = APCAN - RM - RX + +!*** Crop nitrogen demand and uptake (g N m-2 s-1) + + SHSA = Z1244 * YGV*MAX(1E-16,APCAN -RM -RX)/ MAX(0.1,CSH) + SHSAN = Z1244 * YGV*(APCANN-RMN-RX)/ MAX(0.1,CSH) + DERI = MAX(0.,(SHSAN - SHSA)/(0.001*MAX(0.01,NTOT)/MAX(0.1,CTOT))) + + RMUS = 0.06*0.05/0.454*YGV*ASSA + NDEMA = CRT * SHSA**2/NOTNUL(DERI) + NCR = INSW(SLNT-SLNMIN,0.,MIN(NUPTX,NDEMA))/(YGV*MAX(1E-16,APCANS-RM-RX)*Z1244) + NDEMAD = INSW(LNC-1.5*LNCI, MAX(NDEMA, NDEMD), 0.) + +!*** Nitrogen partitioning between shoots and roots + FNSH = 1./(1.+NCR*DERI/SHSA*CSH/MAX(1E-2,CRT)*NRT/MAX(1E-2,NSH)) + +!*** Carbon partitioning among organs and reserve pools + FCSH = 1./(1.+NCR*DERI/SHSA) + +!*** ji 10.02.14, winter dormancy +!*** ji 16.06.15, ecc/lcc switch + IF (CROP==1) THEN + NDEM = INSW(DS-DSCRIT,INSW(SLNMIN-SLN+1.E-5, MIN(NUPTX,.01*NDEMAD), 0.), & + INSW(SLNMIN-SLN+1.E-5, MIN(NUPTX,NDEMAD), 0.)) + ELSE + NDEM = INSW(SLNMIN-SLN+1.E-5, MIN(NUPTX,NDEMAD), 0.) + ENDIF + + DCSR = Z1244*(1.-FCSH)*ASSA + NUPTN = MIN(NSUP2, NSUP2/NOTNUL(NSUP)*MAX(0.,NDEM-NFIXR/TCP)) + RCSRT = Z1244*ASSA*(1.-FCSH)*(1.-FCRVR)*YGV - LCRT + RNFIXR = NFIX - MIN(NDEM,NFIXR/TCP) + RMLD = 0.06*(1.-FCSH)*ASSA + RNDEMP = (NDEM - NDEMP)/DT !as for RNSUPP, DELT ok + NUPTA = MIN(NSUP1, NSUP1/NOTNUL(NSUP)*MAX(0.,NDEM-NFIXR/TCP)) + + ! Carbon supply from current photo-assimilates for shoot & root growth + DCSS = Z1244* FCSH *ASSA + NUPT = MAX(0., NUPTA + NUPTN + MIN(NDEM, NFIXR/TCP)) + RMUA = 44./12.*0.17*NUPTA + + CALL SINKG(DS,1.,TSN*SEEDW*CFO,YGO,FDS,DCDSR,DCSS,DT,& + DCDSC,DCDS,FLWCS) + + ! Maintenance and total respiration (g CO2 m-2 d-1) + RMUN = 44./12.*2.05*NUPTN + + ! Daily carbon flow for structural stem growth + DCST = DCSS - FLWCS + FCSO = FLWCS/DCSS + + RRMUL = (RMUN+RMUA+RMUS+RMLD-RMUL)/DT + + GAP = MAX(0., DCDS-DCSS) + + !*** ji, 16.06.15, ecc/lcc switch + IF (CROP==1) THEN + IFSH = INSW(DCST-1E-11, 1., LIMIT(0.,1.,DCST/NOTNUL(DCDTP))) + ELSE + IFSH = LIMIT(0.,1.,DCST/NOTNUL(DCDTP)) + ENDIF + + CREMSI = MIN(0.94*CRVS, CRVS/NOTNUL(CRVS+CRVR)*GAP)/0.94 + CREMRI = MIN(0.94*CRVR, CRVR/NOTNUL(CRVS+CRVR)*GAP)/0.94 + CREMS = INSW(DCDS-DCSS, 0., CREMSI) + CREMR = INSW(DCDS-DCSS, 0., CREMRI) + + IF (CROP==1) THEN + RHT = MIN(HTMX-HT, FDH*HTMX*IFSH) + ELSE + RHT = MIN(HTMX-HT, FDH*HTMX*INSW(DCST-1E-4, 1., LIMIT(0.,1.,DCST/NOTNUL(DCDTP)))) + ENDIF + + IF (CROP==1) THEN + CALL SINKG(DS,.1,CDMHT*HTMX*CFV,YGV,FDH*IFSH,DCDTR,DCST,DT, & + DCDTC,DCDT,FLWCT) + ELSE + CALL SINKG(DS,.0,CDMHT*HTMX*CFV,YGV,FDH*IFSH,DCDTR,DCST,DT, & + DCDTC,DCDT,FLWCT) + ENDIF + + RCRVR = FCRVR*DCSR - CREMR + + IF (CROP==1) THEN + RDCDTP = (DCDTC-DCDTP)/DT + ELSE + DCDTP = DCDTC + RDCDTP = 0. + ENDIF + + !ji, the MIN function avoids that a situation occurs during which + !no assimilates are partioned to the leaves. FCSST max. 85% + IF (CROP==1) THEN + FCSST = MIN(.85,INSW(DS-(ESD+0.2), FLWCT/MAX(1E-16,DCSS), 0.)) + !FCSST = INSW(DS-(ESD+0.2), FLWCT/DCSS, 0.) original version + ELSE + FCSST = MIN(.85,INSW(DS-(ESD+0.2), FLWCT/MAX(1E-16,DCSS), 0.)) + ENDIF + + RCSO = Z1244*ASSA*FCSH*FCSO*YGO + 0.94*(CREMS+CREMR)*YGO + RWSO = RCSO / CFO + RDCDSR = MAX(0., (DCDSC-RCSO/YGO))-(FLWCS-MIN(DCDSC,DCSS)) + RWRT = RCSRT/CFV + RCRVR/0.444 + RCSST = Z1244*ASSA* FCSH * FCSST *YGV + + FCLV = REAAND(LAIN-LAIC,ESD-DS)*(1.-FCSO-FCSST) + + RRD = INSW(ROOTD-RDMX, MIN((RDMX-ROOTD)/TCP,(RWRT+LWRT)/(WRB+KR* & + (WRT+WRTD))), 0.) + + RCLV = Z1244*ASSA* FCSH * FCLV * YGV - LCLV + + FCRVS = 1. - FCLV - FCSO - FCSST + + RDCDTR = MAX(0., (DCDTC-RCSST/YGV))-(FLWCT-MIN(DCDTC,DCST)) + RCRVS = FCRVS*DCSS - CREMS + RWLV = RCLV / CFV + + RNRES = NUPT-(LNCMIN*(RCLV+LCLV)+RNCMIN*(RCSRT+LCRT)+STEMNC* & + RCSST)/CFV + + RG = 44./12.*((1.-YGV)/YGV*(RCLV+RCSST+RCSRT+LCLV+LCRT)+ & + (1.-YGO)/YGO* RCSO) + + RWST = RCSST/ CFV + RCRVS/0.444 + RNREOF = INSW (DS-1.0, RNRES, 0.) + RNREOE = INSW (DS-ESD, RNRES, 0.) + + RESTOT = RM+RX+RG + 44./12.*0.06*(CREMS+CREMR) + + CALL RNACC (FNSH,NUPT,RWST,STEMNC,LNCMIN,RNCMIN,LNC,RNC,NLV,NRT,WLV,WRT, & + DT,CB,CX,TM,DS,SEEDNC,RWSO,LNLV,LNRT, RNRT,RNST,RNLV,RTNLV,RNSO) + + RRP = RESTOT / APCAN + + CALL RLAIC(1.*CROP,DS,SLA0,RWLV,LAIC,KN,NLV,RNLV,SLNB,RSLNB, RLAI) + + ! Used for debugging +! if (nowdate(9:12).eq.'2500') then +! write(*,*) nowdate, ' 1 ', DVR +! write(*,*) nowdate, ' 2 ', TDU +! write(*,*) nowdate, ' 3 ', VDU +! write(*,*) nowdate, ' 4 ' +! write(*,*) nowdate, ' 5 ', RCLV +! write(*,*) nowdate, ' 6 ', LCLV +! write(*,*) nowdate, ' 7 ', RCSST +! write(*,*) nowdate, ' 8 ', RCSO +! write(*,*) nowdate, ' 9 ', RCSRT +! write(*,*) nowdate, ' 10 ',LCRT +! write(*,*) nowdate, ' 11 ',LVDS +! write(*,*) nowdate, ' 12 ',RNRT +! write(*,*) nowdate, ' 13 ',RNST +! write(*,*) nowdate, ' 14 ',RNLV +! write(*,*) nowdate, ' 15 ',RNSO +! write(*,*) nowdate, ' 16 ',RTNLV +! write(*,*) nowdate, ' 17 ',LNLV +! write(*,*) nowdate, ' 18 ',LNRT +! write(*,*) nowdate, ' 19 ',RCRVS +! write(*,*) nowdate, ' 20 ',RCRVR +! write(*,*) nowdate, ' 21 ',RNREOE +! write(*,*) nowdate, ' 22 ',RNREOF +! write(*,*) nowdate, ' 23 ',RDCDSR +! write(*,*) nowdate, ' 24 ',RDCDTR +! write(*,*) nowdate, ' 25 ',RSLNB +! write(*,*) nowdate, ' 26 ',RLAI +! write(*,*) nowdate, ' 27 ',RRMUL +! write(*,*) nowdate, ' 27 ',RRMUL +! write(*,*) nowdate, ' 28 ',RNDEMP +! write(*,*) nowdate, ' 29 ',RNSUPP +! write(*,*) nowdate, ' 30 ',NFIX +! write(*,*) nowdate, ' 31 ',RNFIXR +! write(*,*) nowdate, ' 32 ',RDCDTP +! write(*,*) nowdate, ' 33 ',RHT +! write(*,*) nowdate, ' 34 ',RRD +! write(*,*) nowdate, ' 35 ',APCAN +! write(*,*) nowdate, ' 36 ',RESTOT +! write(*,*) nowdate, ' 37 ',NUPT +! write(*,*) nowdate, ' 38 ',LITN +! read(*,*) +! endif + + ! Integration of ODEs + DS = MAX(0., INTGRL(DS, DVR, DT)) + CTDU = MAX(0., INTGRL(CTDU, TDU, DT)) + CVDU = MAX(0., INTGRL(CVDU, VDU, DT)) + CLV = MAX(0., INTGRL (CLV, RCLV, DT)) + CLVD = MAX(0., INTGRL (CLVD, LCLV, DT)) + CSST = MAX(0., INTGRL (CSST, RCSST, DT)) + CSO = MAX(0., INTGRL (CSO, RCSO, DT)) + CSRT = MAX(0., INTGRL (CSRT, RCSRT, DT)) + CRTD = MAX(0., INTGRL (CRTD, LCRT, DT)) + CLVDS = MAX(0.,INTGRL (CLVDS, LVDS, DT)) + NRT = MAX(0.,INTGRL (NRT, RNRT, DT)) + NST = MAX(0.,INTGRL (NST, RNST, DT)) + NLV = MAX(0.,INTGRL (NLV, RNLV, DT)) + NSO = MAX(0.,INTGRL (NSO, RNSO, DT)) + TNLV = MAX(0.,INTGRL (TNLV, RTNLV, DT)) + NLVD = MAX(0.,INTGRL (NLVD, LNLV, DT)) + NRTD = MAX(0.,INTGRL (NRTD, LNRT, DT)) + CRVS = MAX(0.,INTGRL (CRVS, RCRVS, DT)) + CRVR = MAX(0.,INTGRL (CRVR, RCRVR, DT)) + NREOE = MAX(0.,INTGRL(NREOE, RNREOE, DT)) + NREOF = MAX(0.,INTGRL(NREOF, RNREOF, DT)) + DCDSR = MAX(0.,INTGRL(DCDSR, RDCDSR, DT)) + DCDTR = MAX(0.,INTGRL(DCDTR, RDCDTR, DT)) + SLNB = MAX(0.,INTGRL(SLNB, RSLNB, DT)) + LAIC = MAX(0.,INTGRL(LAIC, RLAI, DT)) + RMUL = MAX(0.,INTGRL(RMUL, RRMUL, DT)) + NDEMP = MAX(0.,INTGRL(NDEMP, RNDEMP, DT)) + NSUPP = MAX(0.,INTGRL(NSUPP, RNSUPP, DT)) + NFIXT = MAX(0.,INTGRL(NFIXT, NFIX, DT)) + NFIXR = MAX(0.,INTGRL(NFIXR, RNFIXR, DT)) + DCDTP = MAX(0.,INTGRL(DCDTP, RDCDTP, DT)) + HT = MAX(0.,INTGRL(HT, RHT, DT)) + ROOTD = MAX(1.,INTGRL(ROOTD, RRD, DT)) + TPCAN = MAX(0.,INTGRL(TPCAN, APCAN, DT)) + TRESP = MAX(0.,INTGRL(TRESP, RESTOT, DT)) + TNUPT = MAX(0.,INTGRL(TNUPT, NUPT, DT)) + LITNT = MAX(1e-3,INTGRL(LITNT, LITN, DT)) + + ! Write updated Gecros variables into STATE_GECROS array + STATE_GECROS(1) = DS + STATE_GECROS(2) = CTDU + STATE_GECROS(3) = CVDU + STATE_GECROS(4) = CLV + STATE_GECROS(5) = CLVD + STATE_GECROS(6) = CSST + STATE_GECROS(7) = CSO + STATE_GECROS(8) = CSRT + STATE_GECROS(9) = CRTD + STATE_GECROS(10) = CLVDS + STATE_GECROS(11) = NRT + STATE_GECROS(12) = NST + STATE_GECROS(13) = NLV + STATE_GECROS(14) = NSO + STATE_GECROS(15) = TNLV + STATE_GECROS(16) = NLVD + STATE_GECROS(17) = NRTD + STATE_GECROS(18) = CRVS + STATE_GECROS(19) = CRVR + STATE_GECROS(20) = NREOE + STATE_GECROS(21) = NREOF + STATE_GECROS(22) = DCDSR + STATE_GECROS(23) = DCDTR + STATE_GECROS(24) = SLNB + STATE_GECROS(25) = LAIC + STATE_GECROS(26) = RMUL + STATE_GECROS(27) = NDEMP + STATE_GECROS(28) = NSUPP + STATE_GECROS(29) = NFIXT + STATE_GECROS(30) = NFIXR + STATE_GECROS(31) = DCDTP + STATE_GECROS(32) = HT + STATE_GECROS(33) = ROOTD + STATE_GECROS(34) = TPCAN + STATE_GECROS(35) = TRESP + STATE_GECROS(36) = TNUPT + STATE_GECROS(37) = LITNT + STATE_GECROS(45) = WSO + STATE_GECROS(46) = WSTRAW + STATE_GECROS(47) = GrainNC + STATE_GECROS(48) = StrawNC + STATE_GECROS(49) = LAI + STATE_GECROS(50) = TLAI + + ! Used for debugging +! if(debugging) then +! if (nowdate(9:12).eq.'1200') then +! write(*,*) nowdate, RSD +! write(*,*) "DS: ", DS +! write(*,*) "CTDU: ",CTDU +! write(*,*) "CVDU: ",CVDU +! write(*,*) "Carbon in living leaves CLV: ",CLV +! write(*,*) "Carbon in dead leaves CLVD: ",CLVD +! write(*,*) "Carbon in structural stems CSST: ",CSST +! write(*,*) "Carbon in storage organs CSO: ",CSO +! write(*,*) "Carbon in structural roots CSRT: ",CSRT +! write(*,*) "Carbon in living roots CRT: ",CRT +! write(*,*) "Carbon in dead roots CRTD: ",CRTD +! write(*,*) "Rooting depth ROOTD: ",ROOTD +! write(*,*) "Carbon litter on soil CLVDS: ",CLVDS +! write(*,*) "Carbon in stem reserves CRVS: ",CRVS +! write(*,*) "Carbon in root reserves CRVR: ",CRVR +! write(*,*) "Total leaf area index TLAI: ",TLAI +! write(*,*) "Dead leaf area index DLAI: ",DLAI +! write(*,*) "Living leaf area index GLAI: ",LAI, LAIC, LAIN +! write(*,*) "Specific leaf area index SLA: ",SLA +! write(*,*) "Carbon balance check CCHK: ",CCHK +! write(*,*) "Nitrogen balance check NCHK: ",NCHK +! read(*,*) +! endif +! endif + +! ---------------------------------------------------------------------- +END SUBROUTINE gecros +! ---------------------------------------------------------------------- + +!******************** SUBROUTINES FOR CROP SIMULATION ******************* +!*----------------------------------------------------------------------* +!* SUBROUTINE TUNIT * +!* Purpose: This subroutine calculates the daily amount of thermal day * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* DS R4 Development stage - I * +!* TMAX R4 Daily maximum temperature oC I * +!* TMIN R4 Daily minimum temperature oC I * +!* DIF R4 Daytime plant-air temperature differential oC I * +!* DAYL R4 Astronomic daylength (base = 0 degrees) h I * +!* TBD R4 Base temperature for phenology oC I * +!* TOD R4 Optimum temperature for phenology oC I * +!* TCD R4 Ceiling temperature for phenology oC I * +!* TSEN R4 Curvature for temperature response - I * +!* TDU R4 Rate of thermal days increase d s-1 O * +!* VDU R4 Rate of vernalization days increase d s-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE TUNIT(CROP,DS,TAIR,DIF,DAYL,TBD,TOD,TCD,TBDV,TODV,TCDV,TSEN,TDU,VDU) + IMPLICIT REAL (A-Z) + INTEGER I + +!*---assuming development rate at supra-optimum temperatures during +!* the reproductive phase equals that at the optimum temperature + IF (DS.GT.1.) THEN + TAIR = MIN (TAIR,TOD) + ELSE + TAIR = TAIR + ENDIF + +!*---vernalization response (Lenz 2007, p. 26) +!*---Ingwersen 29.6.2010 + IF (TAIR.LT.TBDV .OR. TAIR.GT.TCDV) THEN + TUV = 0. + ELSE + TUV = (((TCDV-TAIR)/(TCDV-TODV))*((TAIR-TBDV)/(TODV-TBDV))**((TODV-TBDV)/(TCDV-TODV)))**TSEN + ENDIF + +!*---instantaneous thermal unit based on bell-shaped temperature response + IF (TAIR.LT.TBD .OR. TAIR.GT.TCD) THEN + TU = 0. + ELSE + TU = (((TCD-TAIR)/(TCD-TOD))*((TAIR-TBD)/(TOD-TBD))**((TOD-TBD)/(TCD-TOD)))**TSEN + ENDIF + +!*---daily thermal unit +!*** ji, 16.6.15, ecc/lcc switch + IF (CROP==1) THEN + TDU = TU/TCP + ELSE + TDU = INSW(DS-2.,TU/TCP,0.) + ENDIF + VDU = TUV/TCP + + RETURN + END SUBROUTINE TUNIT + + +!*----------------------------------------------------------------------* +!* SUBROUTINE PHENO * +!* Purpose: This subroutine calculates phenological development rate. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* DS R4 Development stage - I * +!* SLP R4 Crop type(1. for short-day,-1. for long-day) - I * +!* DDLP R4 Daylength for photoperiodism h I * +!* SPSP R4 DS for start of photoperiod-sensitive phase - I * +!* EPSP R4 DS for end of photoperiod-sensitive phase - I * +!* PSEN R4 Photoperiod sensitivity (+ for SD, - for LD) h-1 I * +!* MTDV R4 Minimum thermal days for vegetative phase d I * +!* MTDR R4 Minimum thermal days for reproductive phase d I * +!* TDU R4 Thermal unit - I * +!* CVDU R4 Cumulative vernalization unit (ji, 29.6) - I * +!* DVR R4 Development rate s-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE PHENO (CROP,DS,SLP,DDLP,SPSP,EPSP,PSEN,MTDV,MTDR,TDU,CVDU,DVR) + IMPLICIT REAL (A-Z) + +!*---determining if it is for short-day or long-day crop + IF (SLP.LT.0.) THEN + MOP = 18. !minimum optimum photoperiod for long-day crop + DLP = MIN(MOP,DDLP) + ELSE + MOP = 11. !maximum optimum photoperiod for short-day crop + DLP = MAX(MOP,DDLP) + ENDIF + +!*---effect of photoperiod on development rate + IF (DS.LT.SPSP .OR. DS.GT.EPSP) THEN + EFP = 1. + ELSE + EFP = MAX(0., 1.-PSEN*(DLP-MOP)) + ENDIF + +!*---effect of vernalization (ji, 21.6.10) +!*** ji, 16.6.15, ecc/lcc switch + IF (CROP==1) THEN + EFV = CVDU**5./(22.5**5. + CVDU**5.) + ELSE + EFV = 1.0 + ENDIF + +!*---development rate of vegetative and reproductive phases +!*---extended for vernalization according to Lenz (2007); ji: 21.6.2010 + IF (DS.LE.0.4) THEN + DVR = 1./MTDV*TDU*EFP*EFV + ENDIF + + IF (DS.GT.0.4 .AND. DS.LE.1.0) THEN + DVR = 1./MTDV*TDU*EFP + ENDIF + + IF (DS.GT.1.0) THEN + DVR = 1./MTDR*TDU + ENDIF + + RETURN + END SUBROUTINE PHENO + + +!*----------------------------------------------------------------------* +!* SUBROUTINE RNACC * +!* Purpose: This subroutine calculates rate of N accumulation in organs* +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* FNSH R4 Fraction of new N partitioned to shoot - I * +!* NUPT R4 Nitrogen uptake at a time step gN/m2/s I * +!* RWST R4 Rate of stem weight g/m2/s I * +!* STEMNC R4 Nitrogen concentration in stem gN/g I * +!* LNCMIN R4 Minimum N concentration in leaf gN/g I * +!* RNCMIN R4 Minimum N concentration in root gN/g I * +!* LNC R4 Nitrogen concentration in leaf gN/g I * +!* RNC R4 Nitrogen concentration in root gN/g I * +!* NLV R4 Canopy (green)leaf N content gN/m2 I * +!* NRT R4 (living)root N content gN/m2 I * +!* WLV R4 Canopy (green)leaf weight g/m2 I * +!* WRT R4 (living)Root weight g/m2 I * +!* DELT R4 Time step of simulation s I * +!* CB R4 Factor for initial N concent. of seed-fill - I * +!* CX R4 Factor for final N concent. of seed-fill - I * +!* TM R4 DS when transition from CB to CX is fastest - I * +!* DS R4 Development stage - I * +!* SEEDNC R4 Standard seed N concentration gN/g I * +!* RWSO R4 growth rate of seed g/m2/s I * +!* LNLV R4 Loss rate of NLV due to senescence gN/m2/s I * +!* LNRT R4 Loss rate of NRT due to senescence gN/m2/s I * +!* RNRT R4 rate of N accumulation in root gN/m2/s O * +!* RNST R4 rate of N accumulation in stem gN/m2/s O * +!* RNLV R4 rate of N accumulation in leaf gN/m2/s O * +!* RTNLV R4 Positive value of RNLV gN/m2/s O * +!* RNSO R4 rate of N accumulation in seed(storage organ)gN/m2/s O * +!*----------------------------------------------------------------------* + SUBROUTINE RNACC (FNSH,NUPT,RWST,STEMNC,LNCMIN,RNCMIN,LNC,RNC, & + NLV,NRT,WLV,WRT,DELT,CB,CX,TM,DS,SEEDNC, & + RWSO,LNLV,LNRT, RNRT,RNST,RNLV,RTNLV,RNSO) + IMPLICIT REAL (A-Z) + +!*---amount of N partitioned to shoot + NSHN = FNSH * NUPT + +!*---leaf N (NLVA) or root N (NRTA) available for remobilization within a day + NLVA = INSW(LNCMIN-LNC, NLV-WLV*LNCMIN, 0.)/TCP + NRTA = INSW(RNCMIN-RNC, NRT-WRT*RNCMIN, 0.)/TCP + + NTA = NLVA + NRTA + +!*---rate of N accumulation in stem + RNST = RWST * INSW(-NTA,STEMNC,0.) + +!*---expected N dynamics during seed(storage organ) filling + CDS = CB+(CX-CB)*(4.-TM-DS)/(2.-TM)*(DS-1.)**(1./(2.-TM)) + ENSNC = LIMIT(CB,CX,CDS) * SEEDNC + +!*---rate of N accumulation in seed + NGS = NSHN - RNST - ENSNC*RWSO + NONC = MAX(0.,INSW(NTA+NGS,(NTA+NSHN-RNST)/NOTNUL(RWSO),ENSNC)) + RNSO = RWSO*NONC + +!*---rate of N accumulation in leaf! + + NLVN = INSW(NTA+NGS,-NLVA-LNLV,-NLVA/NOTNUL(NTA)*(-NGS)-LNLV) + GNLV = INSW(NGS, NLVN, NSHN-RNST-RNSO-LNLV) + RNLV = MAX (-NLV+1.E-7, GNLV) + RTNLV = MAX(0., RNLV) + +!*---rate of N accumulation in root + NRTN = INSW(NTA+NGS, NUPT-NSHN-NRTA-LNRT, & + NUPT-NSHN-NRTA/NOTNUL(NTA)*(-NGS)-LNRT) + GNRT = INSW(NGS, NRTN, NUPT-NSHN-LNRT) + RNRT = MAX (-NRT+5.E-8, GNRT) + + RETURN + END SUBROUTINE RNACC + + +!*----------------------------------------------------------------------* +!* SUBROUTINE RLAIC * +!* Purpose: This subroutine calculates the daily increase of leaf * +! area index (m2 leaf/m2 ground/day). * +! * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* DS R4 Development stage - I * +!* SLA0 R4 Specific leaf area constant m2 g-1 I * +!* RWLV R4 Rate of increment in leaf weight g m-2 s-1 I * +!* LAI R4 Leaf area index m2 m-2 I * +!* KN R4 Leaf nitrogen extinction coefficient m2 m-2 I * +!* NLV R4 Total leaf nitrogen content in a canopy g m-2 I * +!* RNLV R4 Rate of increment in NLV g m-2 s-1 I * +!* SLNB R4 Nitrogen content of bottom leaves g m-2 I * +!* RSLNB R4 Rate of increment in SLNB g m-2 s-1 I * +!* RLAI R4 Rate of increment in leaf area index m2 m-2s-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE RLAIC(CROP,DS,SLA0,RWLV,LAI,KN,NLV,RNLV,SLNB,RSLNB, RLAI) + IMPLICIT REAL (A-Z) + + SLNB = MAX(1E-2, SLNB) + !*---rate of LAI driven by carbon supply + RLAI = INSW(RWLV, MAX(-LAI+1.E-5,SLA0*RWLV), SLA0*RWLV) + + !*---rate of LAI driven by nitrogen during juvenile phase + !*** ji, 16.6.15, ecc/lcc switch + IF ((CROP==2) .AND. (LAI.LT.1.5) .AND. (DS.LT.0.75)) THEN + RLAI = MAX(0.,(SLNB*RNLV-NLV*RSLNB)/SLNB/(SLNB+KN*NLV)) + ENDIF + + + RETURN + END SUBROUTINE RLAIC + + +!*----------------------------------------------------------------------* +!* SUBROUTINE BETAF * +!* Purpose: This subroutine calculates the dynamics of expected growth * +!* of sinks, based on the beta sigmoid growth equation * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* DVR R4 Development rate s-1 I * +!* TE R4 Stage at which sink growth stops - I * +!* TX R4 Stage at which sink growth rate is maximal - I * +!* TI R4 Stage of a day considered - I * +!* FD R4 Relative expected growth of a sink at a day s-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE BETAF(DVRX,TE,TX,TI, FD) + + REAL, INTENT(IN) :: DVRX, TE, TX, TI + REAL, INTENT(OUT) :: FD + + FD = DVRX*(2.*TE-TX)*(TE-TI)/TE/(TE-TX)**2*(TI/TE)**(TX/(TE-TX)) + !FD = DVRX*(TE-TI)/(TE-TX)*(TI/TX)**(TX/(TE-TX)) !Eq. a 1a Yin et al 2003 + + END SUBROUTINE BETAF + + +!*----------------------------------------------------------------------* +!* SUBROUTINE SINKG * +!* Purpose: This subroutine calculates carbon demand for sink growth. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* DS R4 Development stage - I * +!* SSG R4 Stage at which sink growth starts - I * +!* TOTC R4 Total carbon in a sink at end of its growth g C/m2 I * +!* YG R4 Growth efficiency g C/g C I * +!* FD R4 Relative expected growth of a sink at a day s-1 I * +!* DCDR R4 Shortfall of C demand in previous days g C/m2 I * +!* DCS R4 Daily C supply for sink growth g C/m2/s I * +!* DELT R4 Time step of integration s I * +!* DCDC R4 C demand of the current day g C/m2/s O * +!* DCD R4 Daily C demand for sink growth g C/m2/s O * +!* FLWC R4 Flow of current assimilated C to sink g C/m2/s O * +!*----------------------------------------------------------------------* + SUBROUTINE SINKG(DS,SSG,TOTC,YG,FD,DCDR,DCS,DELT,DCDC,DCD,FLWC) + IMPLICIT REAL (A-Z) + +!*---expected demand for C of the current time step + DCDC = INSW (DS-SSG, 0., TOTC/YG*FD) + +!*---total demand for C at the time step considered + DCD = DCDC + MAX(0.,DCDR)/DELT + +!*---flow of current assimilated carbon to sink + FLWC = MIN(DCD, DCS) + + RETURN + END SUBROUTINE SINKG + + +!*----------------------------------------------------------------------* +!* SUBROUTINE ASTRO (from the SUCROS model) * +!* Purpose: This subroutine calculates astronomic daylength, * +!* diurnal radiation characteristics such as the daily * +!* integral of sine of solar elevation and solar constant. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* DOY R4 Daynumber (Jan 1st = 1) - I * +!* LAT R4 Latitude of the site degree I * +!* INSP R4 Inclination of sun angle for computing DDLP degree I * +!* SC R4 Solar constant J m-2 s-1 O * +!* SINLD R4 Seasonal offset of sine of solar height - O * +!* COSLD R4 Amplitude of sine of solar height - O * +!* DAYL R4 Astronomic daylength (base = 0 degrees) h O * +!* DDLP R4 Photoperiodic daylength h O * +!* DSINBE R4 Daily total of effective solar height s d-1 O * +!* * +!* FATAL ERROR CHECKS (execution terminated, message) * +!* condition: LAT > 67, LAT < -67 * +!* * +!* FILE usage : none * +!*----------------------------------------------------------------------* + SUBROUTINE ASTRO (DOY,LAT,INSP,SC,SINLD,COSLD,DAYL,DDLP,DSINBE) + IMPLICIT REAL (A-Z) + +!*---PI and conversion factor from degrees to radians + PI = 3.141592654 + RAD = PI/180. +!*---check on input range of parameters + IF (LAT.GT.67.) STOP 'ERROR IN ASTRO: LAT> 67' + IF (LAT.LT.-67.) STOP 'ERROR IN ASTRO: LAT>-67' + +!*---declination of the sun as function of daynumber (DOY) + DEC = -ASIN (SIN (23.45*RAD)*COS (2.*PI*(DOY+10.)/365.)) + +!*---SINLD, COSLD and AOB are intermediate variables + SINLD = SIN (RAD*LAT)*SIN (DEC) + COSLD = COS (RAD*LAT)*COS (DEC) + AOB = SINLD/COSLD + +!*---daylength (DAYL) + DAYL = 12.0*(1.+2.*ASIN (AOB)/PI) + DDLP = 12.0*(1.+2.*ASIN((-SIN(INSP*RAD)+SINLD)/COSLD)/PI) + + DSINB = 3600.*(DAYL*SINLD+24.*COSLD*SQRT (1.-AOB*AOB)/PI) + DSINBE = 3600.*(DAYL*(SINLD+0.4*(SINLD*SINLD+COSLD*COSLD*0.5))+ & + 12.0*COSLD*(2.0+3.0*0.4*SINLD)*SQRT (1.-AOB*AOB)/PI) + +!*---solar constant (SC) + SC = 1367.*(1.+0.033*COS(2.*PI*(DOY-10.)/365.)) + + RETURN + END SUBROUTINE ASTRO + + +!*----------------------------------------------------------------------* +!* SUBROUTINE TOTPT * +!* Purpose: This subroutine calculates daily total gross photosynthesis* +!* and transpiration by performing a Gaussian integration * +!* over time. At five different times of the day, temperature * +!* and radiation are computed to determine assimilation * +!* and transpiration whereafter integration takes place. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* HOD R4 Hour of the day h I * +!* SC R4 Solar constant J m-2 s-1 I * +!* SINLD R4 Seasonal offset of sine of solar height - I * +!* COSLD R4 Amplitude of sine of solar height - I * +!* DAYL R4 Astronomic daylength (base = 0 degrees) h I * +!* DSINBE R4 Daily total of effective solar height s d-1 I * +!* RSD R4 Global radiation J m-2 s-1 I * +!* TAIR R4 Air temperature oC I * +!* DVP R4 Vapour pressure kPa I * +!* WNM R4 daily average wind speed (>=0.1 m/s) m s-1 I * +!* C3C4 R4 Crop type (=1 for C3, -1 for C4 crops) - I * +!* LAI R4 (green)Leaf area index m2 m-2 I * +!* TLAI R4 Total Leaf area index m2 m-2 I * +!* HT R4 Plant height m I * +!* LWIDTH R4 Leaf width m I * +!* RD R4 Rooting depth cm I * +!* SD1 R4 Depth of evaporative upper soil layer cm I * +!* RSS R4 Soil resistance,equivalent to leaf stomata s m-1 I * +!* BLD R4 Leaf angle from horizontal degree I * +!* KN R4 Leaf nitrogen extinction coefficient m2 m-2 I * +!* KW R4 Windspeed extinction coefficient in canopy m2 m-2 I * +!* SLN R4 Average leaf nitrogen content in canopy g m-2 I * +!* SLNT R4 Top-leaf nitrogen content g m-2 I * +!* SLNN R4 Value of SLNT with small plant-N increment g m-2 I * +!* SLNMIN R4 Minimum or base SLNT for photosynthesis g m-2 I * +!* DWSUP R4 Daily water supply for evapotranspiration mm s-1 I * +!* CO2A R4 Ambient CO2 concentration ml m-3 I * +!* LS R4 Lodging severity - I * +!* EAJMAX R4 Energy of activation for Jmax J mol-1 I * +!* XVN R4 Slope of linearity between Vcmax & leaf N umol/g/s I * +!* XJN R4 Slope of linearity between Jmax & leaf N umol/g/s I * +!* THETA R4 Convexity for light response of e-transport - I * +!* WCUL R4 Water content of the upper soil layer m3 m-3 I * +!* FVPD R4 Slope for linear effect of VPD on Ci/Ca (kPa)-1 I * +!* PPCAN R4 Potential canopy CO2 assimilation g m-2 s-1 O * +!* APCANS R4 Actual standing-canopy CO2 assimilation g m-2 s-1 O * +!* APCANN R4 APCANS with small plant-N increment g m-2 s-1 O * +!* APCAN R4 Actual canopy CO2 assimilation g m-2 s-1 O * +!* PTCAN R4 Potential canopy transpiration mm s-1 O * +!* ATCAN R4 Actual canopy transpiration mm s-1 O * +!* PESOIL R4 Potential soil evaporation mm s-1 O * +!* AESOIL R4 Actual soil evaporation mm s-1 O * +!* DIFS R4 Soil-air temp. difference oC O * +!* DIFSU R4 Sunlit leaf-air temp. diff. oC O * +!* DIFSH R4 Shaded leaf-air temp. diff. oC O * +!* DAPAR R4 PAR absorbed by crop canopy J m-2 s-1 O * +!* RCAN R4 Canopy resistance s/m 0 * +!*----------------------------------------------------------------------* +SUBROUTINE TOTPT(HOD,DS, SC,SINLD,COSLD,DAYL,DSINBE,RSD,TAIR, DVP, & + WNM,C3C4,LAI,TLAI,HT,LWIDTH,RD,SD1,RSS,BLD,KN,KW, & + SLN,SLNT,SLNN,SLNMIN,FB,DWSUP,CO2A,LS,EAJMAX, & + XVN,XJN,THETA,WCUL,FVPD,RB,RT,RTS,PPCAN,APCANS, & + APCANN,APCAN,PTCAN,ATCAN,PESOIL,AESOIL,DIFS,DIFSU,DIFSH,DAPAR, & + RCAN, ATRJC, ATRJS, FSR, FRSU, FRSH, ARSWSU, ARSWSH) + + REAL, INTENT(IN) :: HOD,DS,SC,SINLD,COSLD,DAYL,DSINBE,RSD,TAIR, DVP, & + WNM,C3C4,LAI,TLAI,HT,LWIDTH,RD,SD1,RSS,BLD,KN,KW, & + SLN,SLNT,SLNN,SLNMIN,FB,DWSUP,CO2A,LS,EAJMAX, & + XVN,XJN,THETA,WCUL,FVPD,RT,RTS !RB + + REAL, INTENT(INOUT) :: PPCAN,APCANS,APCANN,APCAN,PTCAN,ATCAN,PESOIL, & + AESOIL,DIFS,DIFSU,DIFSH,DAPAR,RCAN,ATRJC,ATRJS,FSR,FRSU,FRSH,ARSWSU,ARSWSH + REAL :: ACO2I,ADIFS,ADIFSH,ADIFSU,ANIRSH,ANIRSU,ANRAD,APAR,APARSH + REAL :: APARSU,ASVP,ATMTR,ATRJSH,ATRJSU,ATSH,ATSU,AV_Albedo + REAL :: AV_RSWSH,AV_RSWSU,BL,CUMRSD,DATRJC,DATRJS,DNRAD,FRDF + REAL :: GBHC,GBHLF,GBHSH,GBHSU,IAE,IAP,IAPL,IAPN,IAPNN,IAPS,IAT,IPE + REAL :: IPH,IPHSOIL,IPP,IPPL,IPT,IRDL,KB,KBPNIR,KBPPAR,KDPNIR,KDPPAR + REAL :: NIR,NIRDF,NIRDR,NPSH,NPSHN,NPSU,NPSUN,NRADS,NRADSH,PANSH,PANSU + REAL :: PAR,NRADSU,PARDF,PARDR,PASSH,PASSU,PCBNIR,PCBPAR,PCDNIR,PCDPAR + REAL :: PHCAN,PHSH,PHSOIL,PHSU,PI,PLFSH,PLFSU,PSNIR,PSPAR,PT1,PTSH,PTSU + REAL :: RBHS,RBHSH,RBHSU,RBWS,RBWSH,RBWSU,RSWSH,RSWSU,SCPNIR + REAL :: SCPPAR,SINB,SLOPSH,SLOPSU,WND,WSUP,WSUP1,Albedo,RB, DSsw + REAL :: TLEAFSH, TLEAFSU + + PI = 3.141592654 + +!*---output-variables set to 0. and five different times of a day(HOUR) + PPCAN = 0. + APCANS = 0. + APCANN = 0. + APCAN = 0. + PTCAN = 0. + PHCAN = 0. + ATCAN = 0. + PESOIL = 0. + AESOIL = 0. + PHSOIL = 0. + DIFS = 0. + DIFSU = 0. + DIFSH = 0. + DAPAR = 0. + DNRAD = 0. + DATRJC = 0. + DATRJS = 0. + AV_RSWSU = 0. + AV_RSWSH = 0. + AV_Albedo = 0. + CUMRSD = 0. + +!*---sine of solar elevation + SINB = MAX (.01, SINLD+COSLD*COS(2.*PI*(HOD-12.)/24.)) + +!*---daytime course of water supply + WSUP = DWSUP + WSUP1 = WSUP*SD1/RD + +!*---daytime course of wind speed + WND = WNM !m s-1 + +!*---total incoming PAR and NIR + PAR = (1.-FB)*0.5*RSD !J m-2 s-1 + NIR = (1.-FB)*0.5*RSD !J m-2 s-1 + +!*---diffuse light fraction (FRDF) from atmospheric transmission (ATMTR) + ATMTR = PAR/(0.5*SC*SINB) ! unitless, fraction + + IF (ATMTR.LE.0.22) THEN + FRDF = 1. + ELSE IF (ATMTR.GT.0.22 .AND. ATMTR.LE.0.35) THEN + FRDF = 1.-6.4*(ATMTR-0.22)**2 + ELSE + FRDF = 1.47-1.66*ATMTR + ENDIF + + FRDF = MAX (FRDF, 0.15+0.85*(1.-EXP (-0.1/SINB))) + +!*---incoming diffuse PAR (PARDF) and direct PAR (PARDR) + PARDF = PAR * FRDF !J m-2 s-1 + PARDR = PAR - PARDF !J m-2 s-1 + +!*---incoming diffuse NIR (NIRDF) and direct NIR (NIRDR) + NIRDF = NIR * FRDF !J m-2 s-1 + NIRDR = NIR - NIRDF !J m-2 s-1 + +!*---extinction and reflection coefficients + BL = BLD*PI/180. !leaf angle, conversion to radians + CALL KBEAM (SINB,BL,KB) + + SCPPAR = 0.2 !leaf scattering coefficient for PAR + SCPNIR = 0.8 !leaf scattering coefficient for NIR + CALL KDIFF (TLAI,BL,SCPPAR, KDPPAR) + CALL KDIFF (TLAI,BL,SCPNIR, KDPNIR) + + CALL REFL (SCPPAR,KB, KBPPAR,PCBPAR) + CALL REFL (SCPNIR,KB, KBPNIR,PCBNIR) + + PCDPAR = 0.057 !canopy diffuse PAR reflection coefficient + PCDNIR = 0.389 !canopy diffuse NIR reflection coefficient + +!*---fraction of sunlit and shaded components in canopy +!* ji 4.7.11 LAI -> TLAI + FRSU = 1./KB/TLAI*(1.-EXP(-KB*TLAI)) + FRSH = 1.-FRSU + +!*---leaf boundary layer conductance for canopy, sunlit and shaded leaves !m s-1 + GBHLF = 0.01*SQRT(WND/LWIDTH) + RBHSU = RB/(FRSU*LAI) !boundary layer resistance to heat,sunlit part !s m-1 + RBWSU = RB/(FRSU*LAI) !boundary layer resistance to H2O, sunlit part + RBHSH = RB/(FRSH*LAI) !boundary layer resistance to heat,shaded part + RBWSH = RB/(FRSH*LAI) !boundary layer resistance to H2O, shaded part + RCAN = WNM*10. + +!*---boundary layer resistance for soil !s m-1 + RBHS = 172.*SQRT(0.05/MAX(0.1,WND*EXP(-KW*TLAI))) + RBWS = 0.93*RBHS + +!*---photosynthetically active nitrogen for sunlit and shaded leaves + CALL PAN (SLNT,SLNMIN,LAI,KN,KB, NPSU,NPSH) + CALL PAN (SLNN,SLNMIN,LAI,KN,KB, NPSUN,NPSHN) + +!*---absorbed PAR and NIR by sunlit leaves and shaded leaves +!* ji 4.7.11 LAI->TLAI +!* Ansonsten fuehrt es dazu, dass nach dem Abreifen die Albedo auf >0.7 ansteigt und vom Bestand viel +!* zu wenig Energie mehr absorbiert wird + CALL LIGAB (SCPPAR,KB,KBPPAR,KDPPAR,PCBPAR,PCDPAR,PARDR,PARDF,TLAI,APARSU,APARSH) + CALL LIGAB (SCPNIR,KB,KBPNIR,KDPNIR,PCBNIR,PCDNIR,NIRDR,NIRDF,TLAI,ANIRSU,ANIRSH) + APAR = APARSU+APARSH !J m-2 s-1 + +!*---absorbed total radiation (PAR+NIR) by sunlit and shaded leaves + ATRJSU = APARSU+ANIRSU !J m-2 s-1 + ATRJSH = APARSH+ANIRSH !J m-2 s-1 + ATRJC = ATRJSH + ATRJSU !J m-2 s-1 + +!*---absorbed total radiation (PAR+NIR) by soil + PSPAR = 0.1 !soil PAR reflection + PSNIR = INSW(WCUL-0.5, 0.52-0.68*WCUL, 0.18) !soil NIR reflection + ATRJS=(1.-PSPAR)*(PARDR*EXP(-KBPPAR*TLAI)+PARDF*EXP(-KDPPAR*TLAI)) & + +(1.-PSNIR)*(NIRDR*EXP(-KBPNIR*TLAI)+NIRDF*EXP(-KDPNIR*TLAI)) + +!* ji 4.7.11 Berechnung der Albedo eingefuegt. Nachts wird die Albedo auf einen Durchschnittswert gesetzt (.2) + FSR = RSD-ATRJC-ATRJS + + if (RSD.gt.0) then + Albedo = (RSD-ATRJC-ATRJS)/RSD + else + Albedo = .2 + endif + +!*---instantaneous potential photosynthesis and transpiration + CALL PPHTR(FRSU,TAIR,DVP,CO2A,C3C4,FVPD,APARSU,NPSU,RBWSU,RBHSU, & + RT*FRSU,ATRJSU,ATMTR,EAJMAX,XVN,XJN,THETA,PLFSU, & + PTSU,PHSU,RSWSU,NRADSU,SLOPSU) + + CALL PPHTR(FRSH,TAIR,DVP,CO2A,C3C4,FVPD,APARSH,NPSH,RBWSH,RBHSH, & + RT*FRSH,ATRJSH,ATMTR,EAJMAX,XVN,XJN,THETA,PLFSH, & + PTSH,PHSH,RSWSH,NRADSH,SLOPSH) + + IPP = PLFSU + PLFSH !gCO2/m2/s + IPT = PTSU + PTSH !mm s-1 + IPH = PHSU + PHSH !J m-2 s-1 + ANRAD = NRADSU + NRADSH !J m-2 s-1 + +!*--- PT1: Potential transpiration using water from the upper evaporative layer (mm s-1) +!*--- SD1: thickness of upper evaporative layer (cm); default value: 5 cm +!*--- RD: Rooting depth (cm) + PT1 = IPT * SD1/RD + +!*---instantaneous potential soil evaporation + CALL PEVAP (TAIR,DVP,RSS,RTS,RBWS,RBHS,ATRJS,ATMTR, & + PT1,WSUP1,IPE,IPHSOIL,NRADS) + +!*---instantaneous actual soil evaporation, actual canopy +!* transpiration and photosynthesis + IAE = MIN (IPE,IPE/(PT1+IPE)*WSUP1) !actual soil evaporation mm s-1 + IAT = MIN (IPT,PT1/(PT1+IPE)*WSUP1+WSUP-WSUP1) !actual transpiration mm s-1 + ATSU = PTSU/IPT*IAT !actual transpiration of sunlit leaves mm s-1 + ATSH = PTSH/IPT*IAT !actual transpiration of shaded leaves mm s-1 + + CALL DIFLA (NRADS,IAE,RBHS,RTS, ADIFS) + + CALL APHTR (TAIR,APARSU,DVP,CO2A,C3C4,FVPD,NRADSU,ATSU,PTSU, & + RT*FRSU,RBHSU,RBWSU,RSWSU,SLOPSU,NPSU,NPSUN, & + EAJMAX,XVN,XJN,THETA,PASSU,PANSU,ADIFSU,ARSWSU) + + CALL APHTR (TAIR,APARSH,DVP,CO2A,C3C4,FVPD,NRADSH,ATSH,PTSH, & + RT*FRSH,RBHSH,RBWSH,RSWSH,SLOPSH,NPSH,NPSHN, & + EAJMAX,XVN,XJN,THETA,PASSH,PANSH,ADIFSH,ARSWSH) + + IAPS = PASSU + PASSH !actual canopy photosynthesis gCO2 m-2 s-1 + IAPN = PANSU + PANSH !actual canopy photosynthesis with a small N increment gCO2 m-2 s-1 + IAP = IAPS + IAPNN = IAPN + +!*---integration of assimilation and transpiration to a daily total + PPCAN = IPP + APCANS = IAPS + APCANN = IAPNN + APCAN = IAP + PTCAN = IPT + PHCAN = IPH + ATCAN = IAT + PESOIL = IPE + AESOIL = IAE + PHSOIL = IPHSOIL + DIFS = ADIFS + DIFSU = ADIFSU + DIFSH = ADIFSH + DAPAR = APAR + DNRAD = ANRAD !net absorbed radiation by canopy + DATRJC = ATRJC !absorbed radiation by canopy + DATRJS = ATRJS !absorbed radiation by soil + CUMRSD = RSD !incoming solar radiation + AV_RSWSU = RSWSU + AV_RSWSH = RSWSH + AV_Albedo = Albedo + TLEAFSU = TAIR + DIFSU + TLEAFSH = TAIR + DIFSH + + RETURN + END SUBROUTINE TOTPT + + +!*----------------------------------------------------------------------* +!* SUBROUTINE PPHTR * +!* Purpose: This subroutine calculates potential leaf photosynthesis * +!* and transpiration. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* FRAC R4 Fraction of leaf classes (sunlit vs shaded) - I * +!* TAIR R4 Air temperature oC I * +!* DVP R4 Vapour pressure kPa I * +!* CO2A R4 Ambient CO2 concentration ml m-3 I * +!* C3C4 R4 Crop type (=1. for C3, -1 for C4 crops) - I * +!* FVPD R4 Slope for linear effect of VPD on Ci/Ca (kPa)-1 I * +!* PAR R4 Absorbed photosynth. active radiation J m-2 s-1 I * +!* NP R4 Photosynthetically active N content g m-2 I * +!* RBW R4 Leaf boundary layer resistance to water s m-1 I * +!* RBH R4 Leaf boundary layer resistance to heat s m-1 I * +!* RT R4 Turbulence resistance s m-1 I * +!* ATRJ R4 Absorbed global radiation J m-2 s-1 I * +!* ATMTR R4 Atmospheric transmissivity - I * +!* EAJMAX R4 Energy of activation for Jmax J mol-1 I * +!* XVN R4 Slope of linearity between Vcmax & leaf N umol/g/s I * +!* XJN R4 Slope of linearity between Jmax & leaf N umol/g/s I * +!* THETA R4 Convexity for light response of e-transport - I * +!* PLF R4 Potential leaf photosynthesis gCO2/m2/s O * +!* PT R4 Potential leaf transpiration mm s-1 O * +!* PH R4 Potential leaf sensible heat flux J m-2 s-1 O * +!* RSW R4 Potential stomatal resistance to water s m-1 O * +!* NRADC R4 Net leaf absorbed radiation J m-2 s-1 O * +!* SLOPEL R4 Slope of saturated vapour pressure curve kPa oC-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE PPHTR(FRAC,TAIR,DVP,CO2A,C3C4,FVPD,PAR,NP,RBW,RBH,RT, & + ATRJ,ATMTR,EAJMAX,XVN,XJN,THETA,PLF,PT,PH,RSW,NRADC,SLOPEL) + IMPLICIT REAL (A-Z) + +!*---first-round calculation to determine leaf temperature + CALL ICO2 (TAIR,DVP,FVPD,CO2A,C3C4, SVP,FCO2I) + + CALL PHOTO(C3C4,PAR,TAIR,FCO2I,NP,EAJMAX,XVN,XJN,THETA,FPLF, & + FLRD) + + VPD = MAX (0., SVP- DVP) + SLOPE = 4158.6 * SVP/(TAIR + 239.)**2 + CALL GCRSW(FPLF,FLRD,TAIR,CO2A,FCO2I,RBW,RT, FRSW) + + CALL PTRAN(FRSW,RT,RBW,RBH,ATRJ,ATMTR,FRAC,TAIR,DVP, & + SLOPE, VPD, FPT, FPH, FNRADC) + + CALL DIFLA (FNRADC,FPT,RBH,RT, FDIF) + + TLEAF = TAIR + FDIF + +!*---second-round calculation to determine potential photosynthesis +!* and transpiration + CALL ICO2 (TLEAF,DVP,FVPD,CO2A,C3C4, SVPL,CO2I) + CALL PHOTO (C3C4,PAR,TLEAF,CO2I,NP,EAJMAX,XVN,XJN,THETA,PLF,LRD) + + SLOPEL = (SVPL-SVP)/NOTNUL(TLEAF-TAIR) + + CALL GCRSW (PLF,LRD,TLEAF,CO2A,CO2I,RBW,RT, RSW) + CALL PTRAN (RSW,RT,RBW,RBH,ATRJ,ATMTR,FRAC,TLEAF,DVP, & + SLOPEL,VPD, PT, PH, NRADC) + + CALL DIFLA (FNRADC,FPT,RBH,RT, FDIF) + + TLEAF = TAIR + FDIF + +!*---third-round calculation to determine potential photosynthesis +!* and transpiration + CALL ICO2 (TLEAF,DVP,FVPD,CO2A,C3C4, SVPL,CO2I) + CALL PHOTO (C3C4,PAR,TLEAF,CO2I,NP,EAJMAX,XVN,XJN,THETA,PLF,LRD) + + SLOPEL = (SVPL-SVP)/NOTNUL(TLEAF-TAIR) + + CALL GCRSW (PLF,LRD,TLEAF,CO2A,CO2I,RBW,RT, RSW) + CALL PTRAN (RSW,RT,RBW,RBH,ATRJ,ATMTR,FRAC,TLEAF,DVP, & + SLOPEL,VPD, PT, PH, NRADC) + + CALL DIFLA (FNRADC,FPT,RBH,RT, FDIF) + + TLEAF = TAIR + FDIF + +!*---fourth-round calculation to determine potential photosynthesis +!* and transpiration + CALL ICO2 (TLEAF,DVP,FVPD,CO2A,C3C4, SVPL,CO2I) + CALL PHOTO (C3C4,PAR,TLEAF,CO2I,NP,EAJMAX,XVN,XJN,THETA,PLF,LRD) + + SLOPEL = (SVPL-SVP)/NOTNUL(TLEAF-TAIR) + + CALL GCRSW (PLF,LRD,TLEAF,CO2A,CO2I,RBW,RT, RSW) + CALL PTRAN (RSW,RT,RBW,RBH,ATRJ,ATMTR,FRAC,TLEAF,DVP, & + SLOPEL,VPD, PT, PH, NRADC) + + RETURN + END SUBROUTINE PPHTR + + +!*----------------------------------------------------------------------* +!* SUBROUTINE PEVAP * +!* Purpose: This subroutine calculates potential soil evaporation. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* TAIR R4 Air temperature oC I * +!* DVP R4 Vapour pressure kPa I * +!* RSS R4 Soil resistance,equivalent to leaf stomata s m-1 I * +!* RTS R4 Turbulence resistance for soil s m-1 I * +!* RBWS R4 Soil boundary layer resistance to water s m-1 I * +!* RBHS R4 Soil boundary layer resistance to heat s m-1 I * +!* ATRJS R4 Absorbed global radiation by soil J m-2 s-1 I * +!* ATMTR R4 Atmospheric transmissivity - I * +!* PT1 R4 Potential leaf transpiration using water mm s-1 I * +!* from upper evaporative soil layer * +!* WSUP1 R4 Water supply from upper evaporative soil mm s-1 I * +!* layer for evapotranspiration * +!* PESOIL R4 Potential soil evaporation mm s-1 O * +!* PHSOIL R4 Potential soil sensible heat flux J m-2 s-1 O * +!* NRADS R4 Net soil absorbed radiation J m-2 s-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE PEVAP (TAIR,DVP,RSS,RTS,RBWS,RBHS,ATRJS,ATMTR, & + PT1,WSUP1,PESOIL,PHSOIL,NRADS) + IMPLICIT REAL (A-Z) + +!*--- first-round calculation to estimate soil surface temperature (TAVS) + SVP = 0.611*EXP(17.4*TAIR/(TAIR+239.)) + VPD = MAX (0., SVP-DVP) + SLOPE = 4158.6 * SVP/(TAIR + 239.)**2 + CALL PTRAN(RSS,RTS,RBWS,RBHS,ATRJS,ATMTR,1.,TAIR,DVP, & + SLOPE,VPD, FPE, FPH, FNRADS) + FPESOL = MAX(0., FPE) + FAESOL = MIN(FPESOL,FPESOL/(PT1+FPESOL)*WSUP1) + CALL DIFLA (FNRADS,FAESOL,RBHS,RTS, FDIFS) + TAVS = TAIR + FDIFS + +!*---second-round calculation to estimate potential soil evaporation + SVPS = 0.611*EXP(17.4*TAVS/(TAVS+239.)) + SLOPES = (SVPS-SVP)/NOTNUL(FDIFS) + + CALL PTRAN(RSS,RTS,RBWS,RBHS,ATRJS,ATMTR,1.,TAVS,DVP, & + SLOPES,VPD, PE, PH, NRADS) + PESOIL = MAX(0., PE) + PHSOIL = PH + + RETURN + END SUBROUTINE PEVAP + +!*----------------------------------------------------------------------* +!* SUBROUTINE APHTR * +!* Purpose: This subroutine calculates actual leaf photosynthesis when * +!* water stress occurs. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* TAIR R4 Air temperature oC I * +!* PAR R4 Absorbed photosynth. active radiation J m-2 s-1 I * +!* DVP R4 Vapour pressure kPa I * +!* CO2A R4 Ambient CO2 concentration ml m-3 I * +!* C3C4 R4 Crop type (=1. for C3, -1 for C4 crops) - I * +!* FVPD R4 Slope for linear effect of VPD on Ci/Ca (kPa)-1 I * +!* NRADC R4 Net leaf absorbed radiation J m-2 s-1 I * +!* AT R4 Actual leaf transpiration mm s-1 I * +!* PT R4 Potential leaf transpiration mm s-1 I * +!* RT R4 Turbulence resistance s m-1 I * +!* RBH R4 Leaf boundary layer resistance to heat s m-1 I * +!* RBW R4 Leaf boundary layer resistance to water s m-1 I * +!* RSW R4 Potential stomatal resistance to water s m-1 I * +!* SLOPEL R4 Slope of saturated vapour pressure curve kPa oC-1 I * +!* NP R4 Photosynthet. active leaf N content g m-2 I * +!* NPN R4 NP with small plant-N increment g m-2 I * +!* EAJMAX R4 Energy of activation for Jmax J mol-1 I * +!* XVN R4 Slope of linearity between Vcmax & leaf N umol/g/s I * +!* XJN R4 Slope of linearity between Jmax & leaf N umol/g/s I * +!* THETA R4 Convexity for light response of e-transport - I * +!* PLFAS R4 Actual leaf photosynthesis gCO2/m2/s O * +!* PLFAN R4 PLFAS with small plant-N increment gCO2/m2/s O * +!* ADIF R4 Actual leaf-air temperature difference oC O * +!* ARSW R4 Actual stomatal resistance to water s m-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE APHTR(TAIR,PAR,DVP,CO2A,C3C4,FVPD,NRADC,AT,PT,RT,RBH, & + RBW,RSW,SLOPEL,NP,NPN,EAJMAX,XVN,XJN,THETA, & + PLFAS,PLFAN,ADIF,ARSW) + IMPLICIT REAL (A-Z) + + PSYCH = 0.067 !psychrometric constant (kPa/oC) + +!*---leaf temperature if water stress occurs + CALL DIFLA (NRADC,AT,RBH,RT, ADIF) + ATLEAF = TAIR + ADIF + +!*---stomatal resistance to water if water stress occurs + ARSW = (PT-AT)*(SLOPEL*(RBH+RT)+PSYCH*(RBW+RT))/AT/PSYCH+PT/AT*RSW + +!*---potential photosynthesis at the new leaf temperature + CALL ICO2 (ATLEAF,DVP,FVPD,CO2A,C3C4, SVPA,ACO2I) + CALL PHOTO(C3C4,PAR,ATLEAF,ACO2I,NPN,EAJMAX,XVN,XJN,THETA,APLFN,ARDN) + CALL PHOTO(C3C4,PAR,ATLEAF,ACO2I,NP,EAJMAX,XVN,XJN,THETA,APLF,ARD) + +!*---actual photosynthesis under water stress condition + PLFAS = (1.6*RSW+1.3*RBW+RT)/(1.6*ARSW+1.3*RBW+RT)*(APLF-ARD)+ARD + PLFAN = (1.6*RSW+1.3*RBW+RT)/(1.6*ARSW+1.3*RBW+RT)*(APLFN-ARDN)+ARDN + + RETURN + END SUBROUTINE APHTR + + +!*----------------------------------------------------------------------* +!* SUBROUTINE PTRAN * +!* Purpose: This subroutine calculates leaf transpiration, using the * +!* Penman-Monteith equation * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* RSW R4 Potential stomatal resistance to water s m-1 I * +!* RT R4 Turbulence resistance s m-1 I * +!* RBW R4 Leaf boundary layer resistance to water s m-1 I * +!* RBH R4 Leaf boundary layer resistance to heat s m-1 I * +!* ATRJ R4 Absorbed global radiation J m-2 s-1 I * +!* ATMTR R4 Atmospheric transmissivity - I * +!* FRAC R4 Fraction of leaf classes (sunlit vs shaded)- I * +!* TLEAF R4 Leaf temperature oC I * +!* DVP R4 Vapour pressure kPa I * +!* SLOPE R4 Slope of saturated vapour pressure curve kPa oC-1 I * +!* VPD R4 Saturation vapour pressure deficit of air kPa I * +!* PT R4 Potential leaf transpiration mm s-1 O * +!* PH R4 Potential leaf sensible heat flux J m-2 s-1 O * +!* NRADC R4 Net leaf absorbed radiation J m-2 s-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE PTRAN (RSW,RT,RBW,RBH,ATRJ, & + ATMTR,FRAC,TLEAF,DVP,SLOPE,VPD,PT,PH,NRADC) + IMPLICIT REAL (A-Z) + +!*---some physical constants + BOLTZM = 5.668E-8 !Stefan-Boltzmann constant(J/m2/s/K4) + LHVAP = 2.4E6 !latent heat of water vaporization(J/kg) + VHCA = 1200. !volumetric heat capacity (J/m3/oC) + PSYCH = 0.067 !psychrometric constant (kPa/oC) + +!*---net absorbed radiation + CLEAR = MAX(0., MIN(1., (ATMTR-0.25)/0.45)) !sky clearness + BBRAD = BOLTZM*(TLEAF +273.)**4 + RLWN = BBRAD*(0.56-0.079*SQRT(DVP*10.))*(0.1+0.9*CLEAR)*FRAC + NRADC = ATRJ - RLWN + +!*---intermediate variable related to resistances + PSR = PSYCH*(RBW+RT+RSW)/(RBH+RT) + +!*---Compute PT +!*---radiation-determined term + PTR = NRADC*SLOPE/(SLOPE+PSR)/LHVAP + +!*---vapour pressure-determined term + PTD = (VHCA*VPD/(RBH+RT))/(SLOPE+PSR)/LHVAP + +!*---potential evaporation or transpiration + PT = MAX(1.E-10,PTR+PTD) + +!*---ji +!*---Compute PH in W/m2 (see Bolan p. 202) +!*---radiation-determined term + PHR = NRADC*PSR/(SLOPE+PSR) + +!*---vapour pressure-determined term + PHD = (VHCA*VPD/(RBH+RT))/(SLOPE+PSR) + +!*---potential evaporation or transpiration + PH = PHR-PHD + + RETURN + END SUBROUTINE PTRAN + + +!*----------------------------------------------------------------------* +!* SUBROUTINE DIFLA * +!* Purpose: This subroutine calculates leaf(canopy)-air temperature * +!* differential. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* NRADC R4 Net leaf absorbed radiation J m-2 s-1 I * +!* PT R4 Potential leaf transpiration mm s-1 I * +!* RBH R4 Leaf boundary layer resistance to heat s m-1 I * +!* RT R4 Turbulence resistance s m-1 I * +!* DIF R4 Leaf-air temperature difference oC O * +!*----------------------------------------------------------------------* + SUBROUTINE DIFLA (NRADC,PT,RBH,RT, DIF) + IMPLICIT REAL (A-Z) + + LHVAP = 2.4E6 !latent heat of water vaporization(J/kg) + VHCA = 1200. !volumetric heat capacity (J/m3/oC) + + DIF = LIMIT (-25., 25., (NRADC-LHVAP*PT)*(RBH+RT)/VHCA) + + RETURN + END SUBROUTINE DIFLA +!*----------------------------------------------------------------------* +!* SUBROUTINE ICO2 * +!* Purpose: This subroutine calculates the internal CO2 concentration * +!* as affected by vapour pressure deficit. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* TLEAF R4 Leaf temperature oC I * +!* DVP R4 Vapour pressure kPa I * +!* FVPD R4 Slope for linear effect of VPDL on Ci/Ca (kPa)-1 I * +!* CO2A R4 Ambient CO2 concentration ml m-3 I * +!* C3C4 R4 Crop type (=1. for C3, -1 for C4 crops) - I * +!* SVPL R4 Saturated vapour pressure of leaf kPa O * +!* CO2I R4 intercellular CO2 concentration ml m-3 O * +!*----------------------------------------------------------------------* + SUBROUTINE ICO2 (TLEAF,DVP,FVPD,CO2A,C3C4, SVPL,CO2I) + IMPLICIT REAL (A-Z) + +!*---air-to-leaf vapour pressure deficit + SVPL = 0.611 * EXP(17.4 * TLEAF / (TLEAF + 239.)) + VPDL = MAX (0., SVPL - DVP) + +!*---Michaelis-Menten const. for CO2 at 25oC (umol/mol) + KMC25 = INSW(C3C4, 650., 404.9) !greater KMC25 for C4 than C3 + +!*---Michaelis-Menten const. for O2 at 25oC (mmol/mol) + KMO25 = INSW(C3C4, 450., 278.4) !greater KMO25 for C4 than C3 + +!*---CO2 compensation point in absence of dark respiration (GAMMAX) + O2 = 210. !oxygen concentration(mmol/mol) + EAVCMX = 65330. !energy of activation for Vcmx(J/mol) + EAKMC = 79430. !energy of activation for KMC (J/mol) + EAKMO = 36380. !energy of activation for KMO (J/mol) + EARD = 46390. !energy of activation for dark respiration(J/mol) + RDVX25 = 0.0089 !ratio of dark respiration to Vcmax at 25oC + TO = 298.15 + + KMC = KMC25*EXP((1./TO-1./(TLEAF+273.))*EAKMC/8.314) + KMO = KMO25*EXP((1./TO-1./(TLEAF+273.))*EAKMO/8.314) + GAMMAX = 0.5*EXP(-3.3801+5220./(TLEAF+273.)/8.314)*O2*KMC/KMO + +!*---CO2 compensation point (GAMMA) + RDVCX = RDVX25*EXP((1./TO-1./(TLEAF+273.))*(EARD-EAVCMX)/8.314) + GAMMA0 = (GAMMAX+RDVCX*KMC*(1.+O2/KMO))/(1.-RDVCX) + GAMMA_ = INSW (C3C4, GAMMA0/10., GAMMA0) + +!*---internal/ambient CO2 ratio, based on data of Morison & Gifford (1983) + RCICA = 1.-(1.-GAMMA_/CO2A)*(0.14+FVPD*VPDL) + +!*---intercellular CO2 concentration + CO2I = RCICA * CO2A + + RETURN + END SUBROUTINE ICO2 + + +!*----------------------------------------------------------------------* +!* SUBROUTINE GCRSW * +!* Purpose: This subroutine calculates overall leaf conductance * +!* for CO2 (GC) and the stomatal resistance to water (RSW). * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* PLEAF R4 Gross leaf photosynthesis gCO2/m2/s I * +!* RDLEAF R4 Leaf dark respiration gCO2/m2/s I * +!* TLEAF R4 Leaf temperature oC I * +!* CO2A R4 Ambient CO2 concentration ml m-3 I * +!* CO2I R4 Internal CO2 concentration ml m-3 I * +!* RT R4 Turbulence resistance s m-1 I * +!* RBW R4 Leaf boundary layer resistance to water s m-1 I * +!* RSW R4 Potential stomatal resistance to water s m-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE GCRSW (PLEAF,RDLEAF,TLEAF,CO2A,CO2I,RBW,RT, RSW) + IMPLICIT REAL (A-Z) + +!*---potential conductance for CO2 +!*ji 13.7.11 MAX routine faengt negative Leitfaehigkeiten ab + GC = MAX(1E-6,(PLEAF-RDLEAF)*(273.+TLEAF)/0.53717/(CO2A-CO2I)) + +!*---potential stomatal resistance to water + RSW = MAX(1E-30, 1./GC - RBW*1.3 - RT)/1.6 + + RETURN + END SUBROUTINE GCRSW + + +!*----------------------------------------------------------------------* +!* SUBROUTINE PAN * +!* Purpose: This subroutine calculates photosynthetically active * +!* nitrogen content for sunlit and shaded parts of canopy. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* SLNT R4 Top-leaf nitrogen content g m-2 I * +!* SLNMIN R4 Minimum or base SLNT for photosynthesis g m-2 I * +!* LAI R4 (green)Leaf area index m2 m-2 I * +!* KN R4 Leaf nitrogen extinction coefficient m2 m-2 I * +!* KB R4 Direct beam radiation extinction coeff. m2 m-2 I * +!* NPSU R4 Photosynthet. active N for sunlit leaves g m-2 O * +!* NPSH R4 Photosynthet. active N for shaded leaves g m-2 O * +!*----------------------------------------------------------------------* + SUBROUTINE PAN(SLNT,SLNMIN,LAI,KN,KB, NPSU,NPSH) + IMPLICIT REAL (A-Z) + +!*---total photosynthetic nitrogen in canopy + NPC = SLNT*(1.-EXP(-KN*LAI))/KN-SLNMIN*LAI + +!*---photosynthetic nitrogen for sunlit and shaded parts of canopy + NPSU = SLNT*(1.-EXP(-(KN+KB)*LAI))/(KN+KB)-SLNMIN*(1.-EXP(-KB*LAI))/KB + NPSH = NPC-NPSU + + RETURN + END SUBROUTINE PAN + + +!*----------------------------------------------------------------------* +!* SUBROUTINE PHOTO * +!* Purpose: This subroutine calculates leaf photosynthesis and dark * +!* respiration, based on a renewed Farquhar biochemistry * +!* (cf Yin et al.2004. Plant, Cell & Environment 27:1211-1222)* +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* C3C4 R4 Crop type (=1. for C3, -1. for C4 crops) - I * +!* PAR R4 Leaf absorbed photosynth. active radiance J m-2 s-1 I * +!* TLEAF R4 Leaf temperature oC I * +!* CO2I R4 Intercellular CO2 concentration ml m-3 I * +!* NP R4 Photosynthetically active leaf N content g m-2 I * +!* EAJMAX R4 Energy of activation for Jmax J mol-1 I * +!* XVN R4 Slope of linearity between Vcmax & leaf N umol/g/s I * +!* XJN R4 Slope of linearity between Jmax & leaf N umol/g/s I * +!* THETA R4 Convexity for light response of e-transport - I * +!* PLEAF R4 Gross leaf photosynthesis gCO2/m2/s O * +!* RDLEAF R4 Leaf dark respiration gCO2/m2/s O * +!*----------------------------------------------------------------------* + SUBROUTINE PHOTO(C3C4,PAR,TLEAF,CO2I,NP,EAJMAX,XVN,XJN, & + THETA,PLEAF,RDLEAF) + IMPLICIT REAL (A-Z) + +!*---Michaelis-Menten constants for CO2 and O2 at 25oC + IF (C3C4.LT.0.) THEN + KMC25 = 650. !greater KMC25 for C4 than C3; unit:(umol/mol) + KMO25 = 450. !greater KMO25 for C4 than C3; unit:(mmol/mol) + ELSE + KMC25 = 404.9 !unit:(umol/mol) + KMO25 = 278.4 !unit:(mmol/mol) + ENDIF + +!*---other constants related to the Farquhar-type photosynthesis model + O2 = 210. !oxygen concentration(mmol/mol) + EAVCMX = 65330. !energy of activation for Vcmx(J/mol) + EAKMC = 79430. !energy of activation for KMC (J/mol) + EAKMO = 36380. !energy of activation for KMO (J/mol) + EARD = 46390. !energy of activation for dark respiration(J/mol) + DEJMAX = 200000. !energy of deactivation for JMAX (J/mol) + SJ = 650. !entropy term in JT equation (J/mol/K) + PHI2M = 0.85 !maximum electron transport efficiency of PS II + HH = 3. !number of protons required to synthesise 1 ATP + KTMP = 1.0 !Factor for reducing photosynthesis in case of T<5C + JTMAX = 3.12 + TO = 298.15 + +!*---PAR photon flux in umol/m2/s absorbed by leaf photo-systems + UPAR = 4.56*PAR !4.56 conversion factor in umol/J + +!*---Michaelis-Menten constants for CO2 and O2 respectively + KMC = KMC25*EXP((1./TO-1./(TLEAF+273.))*EAKMC/8.314) + KMO = KMO25*EXP((1./TO-1./(TLEAF+273.))*EAKMO/8.314) + +!*---CO2 compensation point in the absence of dark respiration + GAMMAX = 0.5*EXP(-3.3801+5220./(TLEAF+273.)/8.314)*O2*KMC/KMO + +!*---Arrhenius function for the effect of temperature on carboxylation + VCT = EXP((1./TO-1./(TLEAF+273.))*EAVCMX/8.314) + +!*---function for the effect of temperature on electron transport + JT = EXP((1./TO-1./(TLEAF+273.))*EAJMAX/8.314)* & + (1.+EXP(SJ/8.314-DEJMAX/TO/8.314))/ & + (1.+EXP(SJ/8.314-1./(TLEAF+273.) *DEJMAX/8.314)) + + VCMX = XVN*VCT*NP + JMAX = XJN*JT *NP + +!*---CO2 concentration at carboxylation site & electron pathways and +!* their stoichiometries + FPSEUD = 0. !assuming no pseudocyclic e- transport + IF (C3C4.LT.0.) THEN + ZZ = 0.2 !CO2 leakage from bundle-sheath to mesophyll + CC = 10.*CO2I !to mimic C4 CO2 concentrating mechanism + SF = 2.*(CC-GAMMAX)/(1.-ZZ) + FQ = 1.- FPSEUD- 2.*(4.*CC+8.*GAMMAX)/HH/(SF+3.*CC+7.*GAMMAX) + FCYC = FQ + ELSE + CC = CO2I + SF = 0. + FQ = 0. + FCYC = 1.-(FPSEUD*HH*(SF+3.*CC+7.*GAMMAX)/(4.*CC+8.*GAMMAX)+1.)/ & + (HH*(SF+3.*CC+7.*GAMMAX)/(4.*CC+8.*GAMMAX)-1.) + ENDIF + +!*--- electron transport rate in dependence on PAR photon flux + ALPHA2 = (1.-FCYC)/(1.+(1.-FCYC)/PHI2M) + X = ALPHA2*UPAR/MAX(1.E-10,JMAX) + J2 = JMAX*(1.+X-((1.+X)**2.-4.*X*THETA)**0.5)/2./THETA + +!*---rates of carboxylation limited by Rubisco and electron transport + VC = VCMX * CC/(CC + KMC*(O2/KMO+1.)) + VJ = J2 * CC*(2.+FQ-FCYC)/HH/(SF+3.*CC+7.*GAMMAX)/(1.-FCYC) + +!*---gross rate of leaf photosynthesis + ALF = (1.-GAMMAX/CC)*MIN(VC,VJ) + PLEAF = MAX(1.E-10, (1.E-6)*44.*ALF) + +!*---rate of leaf dark respiration + RDVX25 = 0.0089 !ratio of dark respiration to Vcmax at 25oC + RDT = EXP((1./TO-1./(TLEAF+273.))*EARD/8.314) + RDLEAF = (1.E-6)*44. *RDVX25*(XVN*NP) * RDT + + RETURN + END SUBROUTINE PHOTO + + +!*----------------------------------------------------------------------* +!* SUBROUTINE REFL * +!* Purpose: This subroutine calculates reflection coefficients. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* SCP R4 Leaf scattering coefficient - I * +!* KB R4 Direct beam radiation extinction coeff. m2 m-2 I * +!* KBP R4 Scattered beam radiation extinction coeff. m2 m-2 O * +!* PCB R4 Canopy beam radiation reflection coeff. - O * +!*----------------------------------------------------------------------* + SUBROUTINE REFL (SCP,KB, KBP,PCB) + IMPLICIT REAL (A-Z) + +!*--- scattered beam radiation extinction coefficient + KBP = KB*SQRT(1.-SCP) + +!*---canopy reflection coefficient for horizontal leaves + PH = (1.-SQRT(1.-SCP))/(1.+SQRT(1.-SCP)) + +!*---Canopy beam radiation reflection coefficient + PCB = 1.-EXP(-2.*PH*KB/(1.+KB)) + + RETURN + END SUBROUTINE REFL + + +!*----------------------------------------------------------------------* +!* SUBROUTINE LIGAB * +!* Purpose: This subroutine calculates absorbed light for sunlit and * +!* shaded leaves. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* SCP R4 Leaf scattering coefficient - I * +!* KB R4 Direct beam radiation extinction coeff. m2 m-2 I * +!* KBP R4 Scattered beam radiation extinction coeff. m2 m-2 I * +!* KDP R4 Diffuse radiation extinction coefficient m2 m-2 I * +!* PCB R4 Canopy beam radiation reflection coeff. - I * +!* PCD R4 Canopy diffuse radiation reflection coeff. - I * +!* IB0 R4 Incident direct-beam radiation J m-2 s-1 I * +!* ID0 R4 Incident diffuse radiation J m-2 s-1 I * +!* LAI R4 (green)Leaf area index m2 m-2 I * +!* ISU R4 Absorbed radiation by sunlit leaves J m-2 s-1 O * +!* ISH R4 Absorbed radiation by shaded leaves J m-2 s-1 O * +!*----------------------------------------------------------------------* + SUBROUTINE LIGAB (SCP,KB,KBP,KDP,PCB,PCD,IB0,ID0,LAI, ISU,ISH) + IMPLICIT REAL (A-Z) + +!*---total absorbed light by canopy + IC = (1.-PCB)*MAX(1e-30,IB0)*(1.-EXP(-KBP*LAI))+ & + (1.-PCD)*MAX(1e-30,ID0)*(1.-EXP(-KDP*LAI)) + +!*---absorbed light by sunlit and shaded fractions of canopy + ISU = (1.-SCP)*MAX(1e-30,IB0)*(1.-EXP(-KB *LAI))+(1.-PCD)*MAX(1e-30,ID0)/(KDP+KB)* & + KDP*(1.-EXP(-(KDP+KB)*LAI))+MAX(1e-30,IB0)*((1.-PCB)/(KBP+KB)*KBP* & + (1.-EXP(-(KBP+KB)*LAI))-(1.-SCP)*(1.-EXP(-2.*KB*LAI))/2.) + + ISH = IC-ISU + + RETURN + END SUBROUTINE LIGAB + + +!*----------------------------------------------------------------------* +!* SUBROUTINE KBEAM * +!* Purpose: This subroutine calculates extinction coefficient for * +!* direct beam radiation. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* SINB R4 Sine of solar elevation - I * +!* BL R4 Leaf angle (from horizontal) radians I * +!* KB R4 Direct beam radiation extinction coeff. m2 m-2 O * +!*----------------------------------------------------------------------* + SUBROUTINE KBEAM (SINB,BL, KB) + IMPLICIT REAL (A-Z) + +!*---solar elevation in radians + B = ASIN(SINB) + +!*---average projection of leaves in the direction of a solar beam + IF (SINB.GE.SIN(BL)) THEN + OAV = SINB*COS(BL) + ELSE + OAV = 2./3.141592654*(SINB*COS(BL)*ASIN(TAN(B)/TAN(BL)) & + +((SIN(BL))**2-SINB**2)**0.5) + ENDIF + +!*---beam radiation extinction coefficient + KB = OAV/SINB + + RETURN + END SUBROUTINE KBEAM + + +!*----------------------------------------------------------------------* +!* SUBROUTINE KDIFF * +!* Purpose: This subroutine calculates extinction coefficient for * +!* diffuse radiation. * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* LAI R4 Total leaf area index m2 m-2 I * +!* BL R4 Leaf angle (from horizontal) radians I * +!* SCP R4 Leaf scattering coefficient - I * +!* KDP R4 Diffuse radiation extinction coefficient m2 m-2 O * +!*----------------------------------------------------------------------* + SUBROUTINE KDIFF (LAI,BL,SCP, KDP) + IMPLICIT REAL (A-Z) + + PI = 3.141592654 + +!*---extinction coefficient of beam lights from 15, 45 and 75 elevations + CALL KBEAM (SIN(15.*PI/180.),BL, KB15) + CALL KBEAM (SIN(45.*PI/180.),BL, KB45) + CALL KBEAM (SIN(75.*PI/180.),BL, KB75) + +!*---diffuse light extinction coefficient + KDP = -1./LAI*LOG(0.178*EXP(-KB15*(1.-SCP)**0.5*LAI) & + +0.514*EXP(-KB45*(1.-SCP)**0.5*LAI) & + +0.308*EXP(-KB75*(1.-SCP)**0.5*LAI)) + + RETURN + END SUBROUTINE KDIFF + +!*----------------------------------------------------------------------* +!* FUNCTION INTGRL * +!* Purpose: This function integrates a differential equation * +!* using the Euler method. Substitutes the intrinsic FST function * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* POOL R4 Currenmt stock size g X m-2 I * +!* RATE R4 Rate of change 1/d I * +!* DT R4 Time step d I * +!* INTGRL R4 Returns the stock size in next time step g X m-2 0 * +FUNCTION INTGRL(POOL, RATE, DT) +IMPLICIT NONE +real:: INTGRL, POOL, RATE, DT + +INTGRL = POOL + RATE*DT + +RETURN +END FUNCTION INTGRL + +!*----------------------------------------------------------------------* +!* FUNCTION NOTNUL * +!* Y = NOTNUL(X) * +!* Y is equal to X but 1.0 in case of x=0.0. Note that X is * +!* evaluated without any tolerance interval * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* X R4 Variable to be checked I * +!*----------------------------------------------------------------------* +FUNCTION NOTNUL(X) +IMPLICIT NONE +real:: NOTNUL, X + +if (X.ne.0) then + NOTNUL = X +else + NOTNUL = 1 +endif + +RETURN +END FUNCTION NOTNUL + +!*----------------------------------------------------------------------* +!* FUNCTION LIMIT * +!* Y = LIMIT(XL, XH, X) * +!* Y is equal to X but limited between XL and XH * +!* Y - Returned as X bounded on [Xl,XH] * +!* XL- Lower bound of X * +!* XH- Upper bound of X * +!* ---- ---- ------- * +!* X R4 Variable to be checken I * +!*----------------------------------------------------------------------* +FUNCTION LIMIT(XL, XH, X) +IMPLICIT NONE +real:: LIMIT, XL, XH, X + +if (X.ge.XL.and.X.le.XH) then + LIMIT = X +else + if (X.gt.XH) then + LIMIT = XH + else + LIMIT = XL + endif +endif + +RETURN +END FUNCTION LIMIT + +!*----------------------------------------------------------------------* +!* FUNCTION INSW * +!* Y = INSW(X, Y1, Y2) * +!* Input switch. Y is set equal to Y1 orY2 depending on the value of X * +!* Y - Returned as either Y1 or Y2 * +!* X - Control variable * +!* Y1- Returned value of Y if X<0 * +!* Y2- Returned value of Y if X>=0 * +!* ---- ---- ------- * +!* X R4 Variable to be checken I * +!*----------------------------------------------------------------------* +FUNCTION INSW(X, Y1, Y2) +implicit none +real :: INSW, X, Y1, Y2 + +if (X.lt.0) then + INSW = Y1 +else + INSW = Y2 +endif + +RETURN +END FUNCTION INSW + + +!*----------------------------------------------------------------------* +!* FUNCTION REAAND * +!* Y = REAAND(X1, X2) * +!* Returns 1.0 if both input variables are positive, otherwise Y=0.0 * +!* ---- ---- ------- * +!* X1 R4 1. variable to be checked I * +!* X2 R4 2. variable to be checked I * +!*----------------------------------------------------------------------* +FUNCTION REAAND(X1, X2) +implicit none +real :: REAAND, X1, X2 + +if (X1.gt.0.and.X2.gt.0) then + REAAND = 1. +else + REAAND = 0. +endif + +RETURN +END FUNCTION REAAND + + +!*----------------------------------------------------------------------* +!* FUNCTION REAnOR * +!* Y = REANOR(X1, X2) * +!* Returns 1.0 if both input variables are less than or equal to 0., * +!* otherwise Y=0. +!* ---- ---- ------- * +!* X1 R4 1. variable to be checked I * +!* X2 R4 2. variable to be checked I * +!*----------------------------------------------------------------------* +FUNCTION REANOR(X1, X2) +implicit none +real :: REANOR, X1, X2 + +if (X1.le.0.and.X2.le.0) then + REANOR = 1. +else + REANOR = 0. +endif + +RETURN +END FUNCTION REANOR + +END MODULE module_sf_gecros diff --git a/src/physics/lsm_noahmp_glacier.f90 b/src/physics/lsm_noahmp_glacier.f90 new file mode 100644 index 00000000..ac47e647 --- /dev/null +++ b/src/physics/lsm_noahmp_glacier.f90 @@ -0,0 +1,3084 @@ +MODULE NOAHMP_GLACIER_GLOBALS + + implicit none + +! ================================================================================================== +!------------------------------------------------------------------------------------------! +! Physical Constants: ! +!------------------------------------------------------------------------------------------! + + REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL, PARAMETER :: VKC = 0.40 !von Karman constant + REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) + REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) + +! =====================================options for different schemes================================ + +! options for ground snow surface albedo +! 1-> BATS; 2 -> CLASS + + INTEGER :: OPT_ALB != 2 !(suggested 2) + +! options for partitioning precipitation into rainfall & snowfall +! 1 -> Jordan (1991); 2 -> BATS: when SFCTMP SFCTMP zero heat flux from bottom (ZBOT and TBOT not used) +! 2 -> TBOT at ZBOT (8m) read from a file (original Noah) + + INTEGER :: OPT_TBOT != 2 !(suggested 2) + +! options for snow/soil temperature time scheme (only layer 1) +! 1 -> semi-implicit; 2 -> full implicit (original Noah) + + INTEGER :: OPT_STC != 1 !(suggested 1) + +! options for glacier treatment +! 1 -> include phase change of ice; 2 -> ice treatment more like original Noah + + INTEGER :: OPT_GLA != 1 !(suggested 1) + +! adjustable parameters for snow processes + + REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + REAL, PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL, PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + +!------------------------------------------------------------------------------------------! +END MODULE NOAHMP_GLACIER_GLOBALS +!------------------------------------------------------------------------------------------! + +MODULE NOAHMP_GLACIER_ROUTINES + USE NOAHMP_GLACIER_GLOBALS + IMPLICIT NONE + + public :: NOAHMP_OPTIONS_GLACIER + public :: NOAHMP_GLACIER + + private :: ATM_GLACIER + private :: ENERGY_GLACIER + private :: THERMOPROP_GLACIER + private :: CSNOW_GLACIER + private :: RADIATION_GLACIER + private :: SNOW_AGE_GLACIER + private :: SNOWALB_BATS_GLACIER + private :: SNOWALB_CLASS_GLACIER + private :: GLACIER_FLUX + private :: SFCDIF1_GLACIER + private :: TSNOSOI_GLACIER + private :: HRT_GLACIER + private :: HSTEP_GLACIER + private :: ROSR12_GLACIER + private :: PHASECHANGE_GLACIER + + private :: WATER_GLACIER + private :: SNOWWATER_GLACIER + private :: SNOWFALL_GLACIER + private :: COMBINE_GLACIER + private :: DIVIDE_GLACIER + private :: COMBO_GLACIER + private :: COMPACT_GLACIER + private :: SNOWH2O_GLACIER + + private :: ERROR_GLACIER + +contains +! +! ================================================================================================== + + SUBROUTINE NOAHMP_GLACIER (& + ILOC ,JLOC ,COSZ ,NSNOW ,NSOIL ,DT , & ! IN : Time/Space/Model-related + SFCTMP ,SFCPRS ,UU ,VV ,Q2 ,SOLDN , & ! IN : Forcing + PRCP ,LWDN ,TBOT ,ZLVL ,FICEOLD ,ZSOIL , & ! IN : Forcing + QSNOW ,SNEQVO ,ALBOLD ,CM ,CH ,ISNOW , & ! IN/OUT : + SNEQV ,SMC ,ZSNSO ,SNOWH ,SNICE ,SNLIQ , & ! IN/OUT : + TG ,STC ,SH2O ,TAUSS ,QSFC , & ! IN/OUT : + FSA ,FSR ,FIRA ,FSH ,FGEV ,SSOIL , & ! OUT : + TRAD ,EDIR ,RUNSRF ,RUNSUB ,SAG ,ALBEDO , & ! OUT : + QSNBOT ,PONDING ,PONDING1,PONDING2,T2M ,Q2E , & ! OUT : + EMISSI, FPICE, CH2B & ! OUT : +!#ifdef WRF_HYDRO +! , sfcheadrt & +!#endif + ) + +! -------------------------------------------------------------------------------------------------- +! Initial code: Guo-Yue Niu, Oct. 2007 +! Modified to glacier: Michael Barlage, June 2012 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !no. of soil layers + REAL , INTENT(IN) :: DT !time step [sec] + REAL , INTENT(IN) :: SFCTMP !surface air temperature [K] + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(IN) :: UU !wind speed in eastward dir (m/s) + REAL , INTENT(IN) :: VV !wind speed in northward dir (m/s) + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) lowest model layer + REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) + REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) + REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) + REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. [K] + REAL , INTENT(IN) :: ZLVL !reference height (m) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + +!#ifdef WRF_HYDRO +! REAL , INTENT(INOUT) :: sfcheadrt +!#endif + +! input/output : need arbitary intial values + REAL , INTENT(INOUT) :: QSNOW !snowfall [mm/s] + REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) + REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL , INTENT(INOUT) :: CM !momentum drag coefficient + REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient + +! prognostic variables + INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers [-] + REAL , INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , INTENT(INOUT) :: SNOWH !snow height [m] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL , INTENT(INOUT) :: TG !ground temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] + REAL , INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + +! output + REAL , INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL , INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: FIRA !total net LW rad (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FGEV !ground evap heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , INTENT(OUT) :: TRAD !surface radiative temperature (k) + REAL , INTENT(OUT) :: EDIR !soil surface evaporation rate (mm/s] + REAL , INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(OUT) :: RUNSUB !baseflow (saturation excess) [mm/s] + REAL , INTENT(OUT) :: SAG !solar rad absorbed by ground (w/m2) + REAL , INTENT(OUT) :: ALBEDO !surface albedo [-] + REAL , INTENT(OUT) :: QSNBOT !snowmelt [mm/s] + REAL , INTENT(OUT) :: PONDING!surface ponding [mm] + REAL , INTENT(OUT) :: PONDING1!surface ponding [mm] + REAL , INTENT(OUT) :: PONDING2!surface ponding [mm] + REAL , INTENT(OUT) :: T2M !2-m air temperature over bare ground part [k] + REAL , INTENT(OUT) :: Q2E + REAL , INTENT(OUT) :: EMISSI + REAL , INTENT(OUT) :: FPICE + REAL , INTENT(OUT) :: CH2B + +! local + INTEGER :: IZ !do-loop index + INTEGER, DIMENSION(-NSNOW+1:NSOIL) :: IMELT !phase change index [1-melt; 2-freeze] + REAL :: RHOAIR !density air (kg/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZSNSO !snow/soil layer thickness [m] + REAL :: THAIR !potential temperature (k) + REAL :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) + REAL :: EAIR !vapor pressure air (pa) + REAL, DIMENSION( 1: 2) :: SOLAD !incoming direct solar rad (w/m2) + REAL, DIMENSION( 1: 2) :: SOLAI !incoming diffuse solar rad (w/m2) + REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content (m3/m3) + REAL, DIMENSION(-NSNOW+1: 0) :: SNICEV !partial volume ice of snow [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0) :: SNLIQV !partial volume liq of snow [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0) :: EPORE !effective porosity [m3/m3] + REAL :: QDEW !ground surface dew rate [mm/s] + REAL :: QVAP !ground surface evap. rate [mm/s] + REAL :: LATHEA !latent heat [j/kg] + REAL :: QMELT !internal pack melt + REAL :: SWDOWN !downward solar [w/m2] + REAL :: BEG_WB !beginning water for error check + REAL :: ZBOT = -8.0 + + CHARACTER*256 message + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + CALL ATM_GLACIER (SFCPRS ,SFCTMP ,Q2 ,SOLDN ,COSZ ,THAIR , & + QAIR ,EAIR ,RHOAIR ,SOLAD ,SOLAI ,SWDOWN ) + + BEG_WB = SNEQV + +! snow/soil layer thickness (m); interface depth: ZSNSO < 0; layer thickness DZSNSO > 0 + + DO IZ = ISNOW+1, NSOIL + IF(IZ == ISNOW+1) THEN + DZSNSO(IZ) = - ZSNSO(IZ) + ELSE + DZSNSO(IZ) = ZSNSO(IZ-1) - ZSNSO(IZ) + END IF + END DO + +! compute energy budget (momentum & energy fluxes and phase changes) + + CALL ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !in + EAIR ,SFCPRS ,QAIR ,SFCTMP ,LWDN ,UU , & !in + VV ,SOLAD ,SOLAI ,COSZ ,ZLVL , & !in + TBOT ,ZBOT ,ZSNSO ,DZSNSO , & !in + TG ,STC ,SNOWH ,SNEQV ,SNEQVO ,SH2O , & !inout + SMC ,SNICE ,SNLIQ ,ALBOLD ,CM ,CH , & !inout + TAUSS ,QSFC , & !inout + IMELT ,SNICEV ,SNLIQV ,EPORE ,QMELT ,PONDING, & !out + SAG ,FSA ,FSR ,FIRA ,FSH ,FGEV , & !out + TRAD ,T2M ,SSOIL ,LATHEA ,Q2E ,EMISSI, CH2B ) !out + + SICE = MAX(0.0, SMC - SH2O) + SNEQVO = SNEQV + + QVAP = MAX( FGEV/LATHEA, 0.) ! positive part of fgev [mm/s] > 0 + QDEW = ABS( MIN(FGEV/LATHEA, 0.)) ! negative part of fgev [mm/s] > 0 + EDIR = QVAP - QDEW + +! compute water budgets (water storages, ET components, and runoff) + + CALL WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in + QVAP ,QDEW ,FICEOLD,ZSOIL , & !in + ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout + DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO ,FSH , & !inout + RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE & !out +!#ifdef WRF_HYDRO +! , sfcheadrt & +!#endif + ) + + IF(OPT_GLA == 2) THEN + EDIR = QVAP - QDEW + FGEV = EDIR * LATHEA + END IF + + IF(MAXVAL(SICE) < 0.0001) THEN + WRITE(message,*) "GLACIER HAS MELTED AT:",ILOC,JLOC," ARE YOU SURE THIS SHOULD BE A GLACIER POINT?" +! CALL wrf_debug(10,TRIM(message)) + END IF + +! water and energy balance check + + CALL ERROR_GLACIER (ILOC ,JLOC ,SWDOWN ,FSA ,FSR ,FIRA , & + FSH ,FGEV ,SSOIL ,SAG ,PRCP ,EDIR , & + RUNSRF ,RUNSUB ,SNEQV ,DT ,BEG_WB ) + + IF(SNOWH <= 1.E-6 .OR. SNEQV <= 1.E-3) THEN + SNOWH = 0.0 + SNEQV = 0.0 + END IF + + IF(SWDOWN.NE.0.) THEN + ALBEDO = FSR / SWDOWN + ELSE + ALBEDO = -999.9 + END IF + + + END SUBROUTINE NOAHMP_GLACIER +! ================================================================================================== + SUBROUTINE ATM_GLACIER (SFCPRS ,SFCTMP ,Q2 ,SOLDN ,COSZ ,THAIR , & + QAIR ,EAIR ,RHOAIR ,SOLAD ,SOLAI , & + SWDOWN ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) + REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] + +! outputs + + REAL , INTENT(OUT) :: THAIR !potential temperature (k) + REAL , INTENT(OUT) :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) + REAL , INTENT(OUT) :: EAIR !vapor pressure air (pa) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL , INTENT(OUT) :: RHOAIR !density air (kg/m3) + REAL , INTENT(OUT) :: SWDOWN !downward solar filtered by sun angle [w/m2] + +!locals + + REAL :: PAIR !atm bottom level pressure (pa) +! -------------------------------------------------------------------------------------------------- + + PAIR = SFCPRS ! atm bottom level pressure (pa) + THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) +! QAIR = Q2 / (1.0+Q2) ! mixing ratio to specific humidity [kg/kg] + QAIR = Q2 ! In WRF, driver converts to specific humidity + + EAIR = QAIR*SFCPRS / (0.622+0.378*QAIR) + RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP) + + IF(COSZ <= 0.) THEN + SWDOWN = 0. + ELSE + SWDOWN = SOLDN + END IF + + SOLAD(1) = SWDOWN*0.7*0.5 ! direct vis + SOLAD(2) = SWDOWN*0.7*0.5 ! direct nir + SOLAI(1) = SWDOWN*0.3*0.5 ! diffuse vis + SOLAI(2) = SWDOWN*0.3*0.5 ! diffuse nir + + END SUBROUTINE ATM_GLACIER +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + SUBROUTINE ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !in + EAIR ,SFCPRS ,QAIR ,SFCTMP ,LWDN ,UU , & !in + VV ,SOLAD ,SOLAI ,COSZ ,ZREF , & !in + TBOT ,ZBOT ,ZSNSO ,DZSNSO , & !in + TG ,STC ,SNOWH ,SNEQV ,SNEQVO ,SH2O , & !inout + SMC ,SNICE ,SNLIQ ,ALBOLD ,CM ,CH , & !inout + TAUSS ,QSFC , & !inout + IMELT ,SNICEV ,SNLIQV ,EPORE ,QMELT ,PONDING, & !out + SAG ,FSA ,FSR ,FIRA ,FSH ,FGEV , & !out + TRAD ,T2M ,SSOIL ,LATHEA ,Q2E ,EMISSI, CH2B ) !out + +! -------------------------------------------------------------------------------------------------- +! -------------------------------------------------------------------------------------------------- +! USE NOAHMP_VEG_PARAMETERS +! USE NOAHMP_RAD_PARAMETERS +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers + REAL , INTENT(IN) :: DT !time step [sec] + REAL , INTENT(IN) :: QSNOW !snowfall on the ground (mm/s) + REAL , INTENT(IN) :: RHOAIR !density air (kg/m3) + REAL , INTENT(IN) :: EAIR !vapor pressure air (pa) + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(IN) :: QAIR !specific humidity (kg/kg) + REAL , INTENT(IN) :: SFCTMP !air temperature (k) + REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) + REAL , INTENT(IN) :: UU !wind speed in e-w dir (m/s) + REAL , INTENT(IN) :: VV !wind speed in n-s dir (m/s) + REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAD !incoming direct solar rad. (w/m2) + REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAI !incoming diffuse solar rad. (w/m2) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL , INTENT(IN) :: ZREF !reference height (m) + REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. (k) + REAL , INTENT(IN) :: ZBOT !depth for TBOT [m] + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !depth of snow & soil layer-bottom [m] + +! input & output + REAL , INTENT(INOUT) :: TG !ground temperature (k) + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] + REAL , INTENT(INOUT) :: SNOWH !snow height [m] + REAL , INTENT(INOUT) :: SNEQV !snow mass (mm) + REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) + REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] + REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow ice mass (kg/m2) + REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow liq mass (kg/m2) + REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step(CLASS type) + REAL , INTENT(INOUT) :: CM !momentum drag coefficient + REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient + REAL , INTENT(INOUT) :: TAUSS !snow aging factor + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + +! outputs + INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index [1-melt; 2-freeze] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume ice [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume liq. water [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + REAL , INTENT(OUT) :: QMELT !snowmelt [mm/s] + REAL , INTENT(OUT) :: PONDING!pounding at ground [mm] + REAL , INTENT(OUT) :: SAG !solar rad. absorbed by ground (w/m2) + REAL , INTENT(OUT) :: FSA !tot. absorbed solar radiation (w/m2) + REAL , INTENT(OUT) :: FSR !tot. reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: FIRA !total net LW. rad (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FGEV !ground evaporation (w/m2) [+ to atm] + REAL , INTENT(OUT) :: TRAD !radiative temperature (k) + REAL , INTENT(OUT) :: T2M !2 m height air temperature (k) + REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , INTENT(OUT) :: LATHEA !latent heat vap./sublimation (j/kg) + REAL , INTENT(OUT) :: Q2E + REAL , INTENT(OUT) :: EMISSI + REAL , INTENT(OUT) :: CH2B !sensible heat conductance, canopy air to ZLVL air (m/s) + + +! local + REAL :: UR !wind speed at height ZLVL (m/s) + REAL :: ZLVL !reference height (m) + REAL :: RSURF !ground surface resistance (s/m) + REAL :: ZPD !zero plane displacement (m) + REAL :: Z0MG !z0 momentum, ground (m) + REAL :: EMG !ground emissivity + REAL :: FIRE !emitted IR (w/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL) :: FACT !temporary used in phase change + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: HCPCT !heat capacity [j/m3/k] + REAL :: GAMMA !psychrometric constant (pa/k) + REAL :: RHSUR !raltive humidity in surface soil/snow air space (-) + +! --------------------------------------------------------------------------------------------------- + +! wind speed at reference height: ur >= 1 + + UR = MAX( SQRT(UU**2.+VV**2.), 1. ) + +! roughness length and displacement height + + Z0MG = Z0SNO + ZPD = SNOWH + + ZLVL = ZPD + ZREF + +! Thermal properties of soil, snow, lake, and frozen soil + + CALL THERMOPROP_GLACIER (NSOIL ,NSNOW ,ISNOW ,DZSNSO , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in + DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out + FACT ) !out + +! Solar radiation: absorbed & reflected by the ground + + CALL RADIATION_GLACIER (DT ,TG ,SNEQVO ,SNEQV ,COSZ , & !in + QSNOW ,SOLAD ,SOLAI , & !in + ALBOLD ,TAUSS , & !inout + SAG ,FSR ,FSA) !out + +! vegetation and ground emissivity + + EMG = 0.98 + +! soil surface resistance for ground evap. + + RHSUR = 1.0 + RSURF = 1.0 + +! set psychrometric constant + + LATHEA = HSUB + GAMMA = CPAIR*SFCPRS/(0.622*LATHEA) + +! Surface temperatures of the ground and energy fluxes + + CALL GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z0MG , & !in + ZLVL ,ZPD ,QAIR ,SFCTMP ,RHOAIR ,SFCPRS , & !in + UR ,GAMMA ,RSURF ,LWDN ,RHSUR ,SMC , & !in + EAIR ,STC ,SAG ,SNOWH ,LATHEA ,SH2O , & !in + CM ,CH ,TG ,QSFC , & !inout + FIRA ,FSH ,FGEV ,SSOIL , & !out + T2M ,Q2E ,CH2B) !out + +!energy balance at surface: SAG=(IRB+SHB+EVB+GHB) + + FIRE = LWDN + FIRA + + IF(FIRE <=0.) THEN !call wrf_error_fatal("STOP in Noah-MP: emitted longwave <0") + WRITE(*,*) "STOP in Noah-MP: emitted longwave <0" + STOP + ENDIF + + ! Compute a net emissivity + EMISSI = EMG + + ! When we're computing a TRAD, subtract from the emitted IR the + ! reflected portion of the incoming LWDN, so we're just + ! considering the IR originating in the canopy/ground system. + + TRAD = ( ( FIRE - (1-EMISSI)*LWDN ) / (EMISSI*SB) ) ** 0.25 + +! 3L snow & 4L soil temperatures + + CALL TSNOSOI_GLACIER (NSOIL ,NSNOW ,ISNOW ,DT ,TBOT , & !in + SSOIL ,SNOWH ,ZBOT ,ZSNSO ,DF , & !in + HCPCT , & !in + STC ) !inout + +! adjusting snow surface temperature + IF(OPT_STC == 2) THEN + IF (SNOWH > 0.05 .AND. TG > TFRZ) TG = TFRZ + END IF + +! Energy released or consumed by snow & ice + + CALL PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in + DZSNSO , & !in + STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout + SMC ,SH2O , & !inout + QMELT ,IMELT ,PONDING ) !out + + + END SUBROUTINE ENERGY_GLACIER +! ================================================================================================== + SUBROUTINE THERMOPROP_GLACIER (NSOIL ,NSNOW ,ISNOW ,DZSNSO , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in + DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out + FACT ) !out +! ------------------------------------------------------------------------------------------------- +! ------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers + REAL , INTENT(IN) :: DT !time step [s] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers [m] + REAL , INTENT(IN) :: SNOWH !snow height [m] + +! outputs + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: HCPCT !heat capacity [j/m3/k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: FACT !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + INTEGER :: IZ, IZ2 + REAL, DIMENSION(-NSNOW+1: 0) :: CVSNO !volumetric specific heat (j/m3/k) + REAL, DIMENSION(-NSNOW+1: 0) :: TKSNO !snow thermal conductivity (j/m3/k) + REAL :: ZMID !mid-point soil depth +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + CALL CSNOW_GLACIER (ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in + TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out + + DO IZ = ISNOW+1, 0 + DF (IZ) = TKSNO(IZ) + HCPCT(IZ) = CVSNO(IZ) + END DO + +! compute soil thermal properties (using Noah glacial ice approximations) + + DO IZ = 1, NSOIL + ZMID = 0.5 * (DZSNSO(IZ)) + DO IZ2 = 1, IZ-1 + ZMID = ZMID + DZSNSO(IZ2) + END DO + HCPCT(IZ) = 1.E6 * ( 0.8194 + 0.1309*ZMID ) + DF(IZ) = 0.32333 + ( 0.10073 * ZMID ) + END DO + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + DO IZ = ISNOW+1,NSOIL + FACT(IZ) = DT/(HCPCT(IZ)*DZSNSO(IZ)) + END DO + +! snow/soil interface + + IF(ISNOW == 0) THEN + DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH) / (SNOWH +DZSNSO(1)) + ELSE + DF(1) = (DF(1)*DZSNSO(1)+DF(0)*DZSNSO(0)) / (DZSNSO(0)+DZSNSO(1)) + END IF + + + END SUBROUTINE THERMOPROP_GLACIER +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + SUBROUTINE CSNOW_GLACIER (ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in + TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out +! -------------------------------------------------------------------------------------------------- +! Snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------------------------------------- +! inputs + + INTEGER, INTENT(IN) :: ISNOW !number of snow layers (-) + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + +! outputs + + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: CVSNO !volumetric specific heat (j/m3/k) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: TKSNO !thermal conductivity (w/m/k) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + +! locals + + INTEGER :: IZ + REAL, DIMENSION(-NSNOW+1: 0) :: BDSNOI !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + DO IZ = ISNOW+1, 0 + SNICEV(IZ) = MIN(1., SNICE(IZ)/(DZSNSO(IZ)*DENICE) ) + EPORE(IZ) = 1. - SNICEV(IZ) + SNLIQV(IZ) = MIN(EPORE(IZ),SNLIQ(IZ)/(DZSNSO(IZ)*DENH2O)) + ENDDO + + DO IZ = ISNOW+1, 0 + BDSNOI(IZ) = (SNICE(IZ)+SNLIQ(IZ))/DZSNSO(IZ) + CVSNO(IZ) = CICE*SNICEV(IZ)+CWAT*SNLIQV(IZ) +! CVSNO(IZ) = 0.525E06 ! constant + enddo + +! thermal conductivity of snow + + DO IZ = ISNOW+1, 0 + TKSNO(IZ) = 3.2217E-6*BDSNOI(IZ)**2. ! Stieglitz(yen,1965) +! TKSNO(IZ) = 2E-2+2.5E-6*BDSNOI(IZ)*BDSNOI(IZ) ! Anderson, 1976 +! TKSNO(IZ) = 0.35 ! constant +! TKSNO(IZ) = 2.576E-6*BDSNOI(IZ)**2. + 0.074 ! Verseghy (1991) +! TKSNO(IZ) = 2.22*(BDSNOI(IZ)/1000.)**1.88 ! Douvill(Yen, 1981) + ENDDO + + END SUBROUTINE CSNOW_GLACIER +!=================================================================================================== + SUBROUTINE RADIATION_GLACIER (DT ,TG ,SNEQVO ,SNEQV ,COSZ , & !in + QSNOW ,SOLAD ,SOLAI , & !in + ALBOLD ,TAUSS , & !inout + SAG ,FSR ,FSA) !out +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + REAL, INTENT(IN) :: DT !time step [s] + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow mass (mm) + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL, INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + +! inout + REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + +! output + REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + +! local + INTEGER :: IB !number of radiation bands + INTEGER :: NBAND !number of radiation bands + REAL :: FAGE !snow age function (0 - new snow) + REAL, DIMENSION(1:2) :: ALBSND !snow albedo (direct) + REAL, DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) + REAL :: ALB !current CLASS albedo + REAL :: ABS !temporary absorbed rad + REAL :: REF !temporary reflected rad + REAL :: FSNO !snow-cover fraction, = 1 if any snow + REAL, DIMENSION(1:2) :: ALBICE !albedo land ice: 1=vis, 2=nir + + REAL,PARAMETER :: MPE = 1.E-6 + +! -------------------------------------------------------------------------------------------------- + + NBAND = 2 + ALBSND = 0.0 + ALBSNI = 0.0 + ALBICE(1) = 0.80 !albedo land ice: 1=vis, 2=nir + ALBICE(2) = 0.55 + +! snow age + + CALL SNOW_AGE_GLACIER (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) + +! snow albedos: age even when sun is not present + + IF(OPT_ALB == 1) & + CALL SNOWALB_BATS_GLACIER (NBAND,COSZ,FAGE,ALBSND,ALBSNI) + IF(OPT_ALB == 2) THEN + CALL SNOWALB_CLASS_GLACIER(NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI) + ALBOLD = ALB + END IF + +! zero summed solar fluxes + + SAG = 0. + FSA = 0. + FSR = 0. + + FSNO = 0.0 + IF(SNEQV > 0.0) FSNO = 1.0 + +! loop over nband wavebands + + DO IB = 1, NBAND + + ALBSND(IB) = ALBICE(IB)*(1.-FSNO) + ALBSND(IB)*FSNO + ALBSNI(IB) = ALBICE(IB)*(1.-FSNO) + ALBSNI(IB)*FSNO + +! solar radiation absorbed by ground surface + + ABS = SOLAD(IB)*(1.-ALBSND(IB)) + SOLAI(IB)*(1.-ALBSNI(IB)) + SAG = SAG + ABS + FSA = FSA + ABS + + REF = SOLAD(IB)*ALBSND(IB) + SOLAI(IB)*ALBSNI(IB) + FSR = FSR + REF + + END DO + + END SUBROUTINE RADIATION_GLACIER +! ================================================================================================== + SUBROUTINE SNOW_AGE_GLACIER (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ code history ------------------------------------------------------------ +! from BATS +! ------------------------ input/output variables -------------------------------------------------- +!input + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow water per unit ground area (mm) + +! inout + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + +!output + REAL, INTENT(OUT) :: FAGE !snow age + +!local + REAL :: TAGE !total aging effects + REAL :: AGE1 !effects of grain growth due to vapor diffusion + REAL :: AGE2 !effects of grain growth at freezing of melt water + REAL :: AGE3 !effects of soot + REAL :: DELA !temporary variable + REAL :: SGE !temporary variable + REAL :: DELS !temporary variable + REAL :: DELA0 !temporary variable + REAL :: ARG !temporary variable +! See Yang et al. (1997) J.of Climate for detail. +!--------------------------------------------------------------------------------------------------- + + IF(SNEQV.LE.0.0) THEN + TAUSS = 0. + ELSE IF (SNEQV.GT.800.) THEN + TAUSS = 0. + ELSE +! TAUSS = 0. + DELA0 = 1.E-6*DT + ARG = 5.E3*(1./TFRZ-1./TG) + AGE1 = EXP(ARG) + AGE2 = EXP(AMIN1(0.,10.*ARG)) + AGE3 = 0.3 + TAGE = AGE1+AGE2+AGE3 + DELA = DELA0*TAGE + DELS = AMAX1(0.0,SNEQV-SNEQVO) / SWEMX + SGE = (TAUSS+DELA)*(1.0-DELS) + TAUSS = AMAX1(0.,SGE) + ENDIF + + FAGE= TAUSS/(TAUSS+1.) + + END SUBROUTINE SNOW_AGE_GLACIER +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + SUBROUTINE SNOWALB_BATS_GLACIER (NBAND,COSZ,FAGE,ALBSND,ALBSNI) +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + + INTEGER,INTENT(IN) :: NBAND !number of waveband classes + + REAL,INTENT(IN) :: COSZ !cosine solar zenith angle + REAL,INTENT(IN) :: FAGE !snow age correction + +! output + + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + + REAL :: FZEN !zenith angle correction + REAL :: CF1 !temperary variable + REAL :: SL2 !2.*SL + REAL :: SL1 !1/SL + REAL :: SL !adjustable parameter + REAL, PARAMETER :: C1 = 0.2 !default in BATS + REAL, PARAMETER :: C2 = 0.5 !default in BATS +! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's +! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + ALBSND(1: NBAND) = 0. + ALBSNI(1: NBAND) = 0. + +! when cosz > 0 + + SL=2.0 + SL1=1./SL + SL2=2.*SL + CF1=((1.+SL1)/(1.+SL2*COSZ)-SL1) + FZEN=AMAX1(CF1,0.) + + ALBSNI(1)=0.95*(1.-C1*FAGE) + ALBSNI(2)=0.65*(1.-C2*FAGE) + + ALBSND(1)=ALBSNI(1)+0.4*FZEN*(1.-ALBSNI(1)) ! vis direct + ALBSND(2)=ALBSNI(2)+0.4*FZEN*(1.-ALBSNI(2)) ! nir direct + + END SUBROUTINE SNOWALB_BATS_GLACIER +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + SUBROUTINE SNOWALB_CLASS_GLACIER (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI) +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + + INTEGER,INTENT(IN) :: NBAND !number of waveband classes + + REAL,INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL,INTENT(IN) :: DT !time step (sec) + REAL,INTENT(IN) :: ALBOLD !snow albedo at last time step + +! in & out + + REAL, INTENT(INOUT) :: ALB ! +! output + + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + ALBSND(1: NBAND) = 0. + ALBSNI(1: NBAND) = 0. + +! when cosz > 0 + + ALB = 0.55 + (ALBOLD-0.55) * EXP(-0.01*DT/3600.) + +! 1 mm fresh snow(SWE) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + IF (QSNOW > 0.) then + ALB = ALB + MIN(QSNOW*DT,SWEMX) * (0.84-ALB)/(SWEMX) + ENDIF + + ALBSNI(1)= ALB ! vis diffuse + ALBSNI(2)= ALB ! nir diffuse + ALBSND(1)= ALB ! vis direct + ALBSND(2)= ALB ! nir direct + + END SUBROUTINE SNOWALB_CLASS_GLACIER +! ================================================================================================== + SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z0M , & !in + ZLVL ,ZPD ,QAIR ,SFCTMP ,RHOAIR ,SFCPRS , & !in + UR ,GAMMA ,RSURF ,LWDN ,RHSUR ,SMC , & !in + EAIR ,STC ,SAG ,SNOWH ,LATHEA ,SH2O , & !in + CM ,CH ,TGB ,QSFC , & !inout + IRB ,SHB ,EVB ,GHB , & !out + T2MB ,Q2B ,EHB2) !out + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for glacier. + +! bare soil: +! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 +! ---------------------------------------------------------------------- +! USE MODULE_MODEL_CONSTANTS +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + REAL, INTENT(IN) :: EMG !ground emissivity + INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity of snow/soil (w/m/k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers (m) + REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: ZLVL !reference height (m) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: QAIR !specific humidity at height zlvl (kg/kg) + REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL, INTENT(IN) :: RHOAIR !density air (kg/m3) + REAL, INTENT(IN) :: SFCPRS !density air (kg/m3) + REAL, INTENT(IN) :: UR !wind speed at height zlvl (m/s) + REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/k) + REAL, INTENT(IN) :: RSURF !ground surface resistance (s/m) + REAL, INTENT(IN) :: LWDN !atmospheric longwave radiation (w/m2) + REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) + REAL, INTENT(IN) :: EAIR !vapor pressure air at height (pa) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !soil/snow temperature (k) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SH2O !soil liquid water + REAL, INTENT(IN) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(IN) :: SNOWH !actual snow depth [m] + REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) + +! input/output + REAL, INTENT(INOUT) :: CM !momentum drag coefficient + REAL, INTENT(INOUT) :: CH !sensible heat exchange coefficient + REAL, INTENT(INOUT) :: TGB !ground temperature (k) + REAL, INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + +! output +! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 + REAL, INTENT(OUT) :: IRB !net longwave rad (w/m2) [+ to atm] + REAL, INTENT(OUT) :: SHB !sensible heat flux (w/m2) [+ to atm] + REAL, INTENT(OUT) :: EVB !latent heat flux (w/m2) [+ to atm] + REAL, INTENT(OUT) :: GHB !ground heat flux (w/m2) [+ to soil] + REAL, INTENT(OUT) :: T2MB !2 m height air temperature (k) + REAL, INTENT(OUT) :: Q2B !bare ground heat conductance + REAL, INTENT(OUT) :: EHB2 !sensible heat conductance for diagnostics + + +! local variables + INTEGER :: NITERB !number of iterations for surface temperature + REAL :: MPE !prevents overflow error if division by zero + REAL :: DTG !change in tg, last iteration (k) + INTEGER :: MOZSGN !number of times MOZ changes sign + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: FM2 !Monin-Obukhov momentum adjustment at 2m + REAL :: FH2 !Monin-Obukhov heat adjustment at 2m + REAL :: CH2 !Surface exchange at 2m + REAL :: H !temporary sensible heat flux (w/m2) + REAL :: FV !friction velocity (m/s) + REAL :: CIR !coefficients for ir as function of ts**4 + REAL :: CGH !coefficients for st as function of ts + REAL :: CSH !coefficients for sh as function of ts + REAL :: CEV !coefficients for ev as function of esat[ts] + REAL :: CQ2B ! + INTEGER :: ITER !iteration index + REAL :: Z0H !roughness length, sensible heat, ground (m) + REAL :: MOZ !Monin-Obukhov stability parameter + REAL :: FM !momentum stability correction, weighted by prior iters + REAL :: FH !sen heat stability correction, weighted by prior iters + REAL :: RAMB !aerodynamic resistance for momentum (s/m) + REAL :: RAHB !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWB !aerodynamic resistance for water vapor (s/m) + REAL :: ESTG !saturation vapor pressure at tg (pa) + REAL :: DESTG !d(es)/dt at tg (pa/K) + REAL :: ESATW !es for water + REAL :: ESATI !es for ice + REAL :: DSATW !d(es)/dt at tg (pa/K) for water + REAL :: DSATI !d(es)/dt at tg (pa/K) for ice + REAL :: A !temporary calculation + REAL :: B !temporary calculation + REAL :: T, TDC !Kelvin to degree Celsius with limit -50 to +50 + REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice + + TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + NITERB = 5 + MPE = 1E-6 + DTG = 0. + MOZ = 0. + MOZSGN = 0 + MOZOLD = 0. + H = 0. + FV = 0.1 + + CIR = EMG*SB + CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1) + +! ----------------------------------------------------------------- + loop3: DO ITER = 1, NITERB ! begin stability iteration + + Z0H = Z0M + +! For now, only allow SFCDIF1 until others can be fixed + + CALL SFCDIF1_GLACIER(ITER ,ZLVL ,ZPD ,Z0H ,Z0M , & !in + QAIR ,SFCTMP ,H ,RHOAIR ,MPE ,UR , & !in + & MOZ ,MOZSGN ,FM ,FH ,FM2 ,FH2 , & !inout + & FV ,CM ,CH ,CH2) !out + + RAMB = MAX(1.,1./(CM*UR)) + RAHB = MAX(1.,1./(CH*UR)) + RAWB = RAHB + +! es and d(es)/dt evaluated at tg + + T = TDC(TGB) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + DESTG = DSATW + ELSE + ESTG = ESATI + DESTG = DSATI + END IF + + CSH = RHOAIR*CPAIR/RAHB + IF(SNOWH > 0.0 .OR. OPT_GLA == 1) THEN + CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB) + ELSE + CEV = 0.0 ! don't allow any sublimation of glacier in opt_gla=2 + END IF + +! surface fluxes and dtg + + IRB = CIR * TGB**4 - EMG*LWDN + SHB = CSH * (TGB - SFCTMP ) + EVB = CEV * (ESTG*RHSUR - EAIR ) + GHB = CGH * (TGB - STC(ISNOW+1)) + + B = SAG-IRB-SHB-EVB-GHB + A = 4.*CIR*TGB**3 + CSH + CEV*DESTG + CGH + DTG = B/A + + IRB = IRB + 4.*CIR*TGB**3*DTG + SHB = SHB + CSH*DTG + EVB = EVB + CEV*DESTG*DTG + GHB = GHB + CGH*DTG + +! update ground surface temperature + TGB = TGB + DTG + +! for M-O length + H = CSH * (TGB - SFCTMP) + + T = TDC(TGB) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + ELSE + ESTG = ESATI + END IF + QSFC = 0.622*(ESTG*RHSUR)/(SFCPRS-0.378*(ESTG*RHSUR)) + + END DO loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. + + SICE = SMC - SH2O + IF(OPT_STC == 1 .OR. OPT_STC ==3) THEN + IF ((MAXVAL(SICE) > 0.0 .OR. SNOWH > 0.0) .AND. TGB > TFRZ .AND. OPT_GLA == 1) THEN + TGB = TFRZ + T = TDC(TGB) ! MB: recalculate ESTG + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + ESTG = ESATI + QSFC = 0.622*(ESTG*RHSUR)/(SFCPRS-0.378*(ESTG*RHSUR)) + IRB = CIR * TGB**4 - EMG*LWDN + SHB = CSH * (TGB - SFCTMP) + EVB = CEV * (ESTG*RHSUR - EAIR ) !ESTG reevaluate ? + GHB = SAG - (IRB+SHB+EVB) + END IF + END IF + +! 2m air temperature + EHB2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2) + CQ2B = EHB2 + IF (EHB2.lt.1.E-5 ) THEN + T2MB = TGB + Q2B = QSFC + ELSE + T2MB = TGB - SHB/(RHOAIR*CPAIR) * 1./EHB2 + Q2B = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF) + ENDIF + +! update CH + CH = 1./RAHB + + END SUBROUTINE GLACIER_FLUX +! ================================================================================================== + SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + IMPLICIT NONE +!--------------------------------------------------------------------------------------------------- +! in + + REAL, intent(in) :: T !temperature + +!out + + REAL, intent(out) :: ESW !saturation vapor pressure over water (pa) + REAL, intent(out) :: ESI !saturation vapor pressure over ice (pa) + REAL, intent(out) :: DESW !d(esat)/dt over water (pa/K) + REAL, intent(out) :: DESI !d(esat)/dt over ice (pa/K) + +! local + + REAL :: A0,A1,A2,A3,A4,A5,A6 !coefficients for esat over water + REAL :: B0,B1,B2,B3,B4,B5,B6 !coefficients for esat over ice + REAL :: C0,C1,C2,C3,C4,C5,C6 !coefficients for dsat over water + REAL :: D0,D1,D2,D3,D4,D5,D6 !coefficients for dsat over ice + + PARAMETER (A0=6.107799961 , A1=4.436518521E-01, & + A2=1.428945805E-02, A3=2.650648471E-04, & + A4=3.031240396E-06, A5=2.034080948E-08, & + A6=6.136820929E-11) + + PARAMETER (B0=6.109177956 , B1=5.034698970E-01, & + B2=1.886013408E-02, B3=4.176223716E-04, & + B4=5.824720280E-06, B5=4.838803174E-08, & + B6=1.838826904E-10) + + PARAMETER (C0= 4.438099984E-01, C1=2.857002636E-02, & + C2= 7.938054040E-04, C3=1.215215065E-05, & + C4= 1.036561403E-07, C5=3.532421810e-10, & + C6=-7.090244804E-13) + + PARAMETER (D0=5.030305237E-01, D1=3.773255020E-02, & + D2=1.267995369E-03, D3=2.477563108E-05, & + D4=3.005693132E-07, D5=2.158542548E-09, & + D6=7.131097725E-12) + + ESW = 100.*(A0+T*(A1+T*(A2+T*(A3+T*(A4+T*(A5+T*A6)))))) + ESI = 100.*(B0+T*(B1+T*(B2+T*(B3+T*(B4+T*(B5+T*B6)))))) + DESW = 100.*(C0+T*(C1+T*(C2+T*(C3+T*(C4+T*(C5+T*C6)))))) + DESI = 100.*(D0+T*(D1+T*(D2+T*(D3+T*(D4+T*(D5+T*D6)))))) + + END SUBROUTINE ESAT +! ================================================================================================== + + SUBROUTINE SFCDIF1_GLACIER(ITER ,ZLVL ,ZPD ,Z0H ,Z0M , & !in + QAIR ,SFCTMP ,H ,RHOAIR ,MPE ,UR , & !in + & MOZ ,MOZSGN ,FM ,FH ,FM2 ,FH2 , & !inout + & FV ,CM ,CH ,CH2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient CM for momentum and CH for heat +! ------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------------------------------------------------------------------------------- +! inputs + INTEGER, INTENT(IN) :: ITER !iteration index + REAL, INTENT(IN) :: ZLVL !reference height (m) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0H !roughness length, sensible heat, ground (m) + REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: QAIR !specific humidity at reference height (kg/kg) + REAL, INTENT(IN) :: SFCTMP !temperature at reference height (k) + REAL, INTENT(IN) :: H !sensible heat flux (w/m2) [+ to atm] + REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) + REAL, INTENT(IN) :: MPE !prevents overflow error if division by zero + REAL, INTENT(IN) :: UR !wind speed (m/s) + +! in & out + REAL, INTENT(INOUT) :: MOZ !Monin-Obukhov stability (z/L) + INTEGER, INTENT(INOUT) :: MOZSGN !number of times moz changes sign + REAL, INTENT(INOUT) :: FM !momentum stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FH !sen heat stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FM2 !sen heat stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FH2 !sen heat stability correction, weighted by prior iters + +! outputs + REAL, INTENT(OUT) :: FV !friction velocity (m/s) + REAL, INTENT(OUT) :: CM !drag coefficient for momentum + REAL, INTENT(OUT) :: CH !drag coefficient for heat + REAL, INTENT(OUT) :: CH2 !drag coefficient for heat + +! locals + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: TMPCM !temporary calculation for CM + REAL :: TMPCH !temporary calculation for CH + REAL :: MOL !Monin-Obukhov length (m) + REAL :: TVIR !temporary virtual temperature (k) + REAL :: TMP1,TMP2,TMP3 !temporary calculation + REAL :: FMNEW !stability correction factor, momentum, for current moz + REAL :: FHNEW !stability correction factor, sen heat, for current moz + REAL :: MOZ2 !2/L + REAL :: TMPCM2 !temporary calculation for CM2 + REAL :: TMPCH2 !temporary calculation for CH2 + REAL :: FM2NEW !stability correction factor, momentum, for current moz + REAL :: FH2NEW !stability correction factor, sen heat, for current moz + REAL :: TMP12,TMP22,TMP32 !temporary calculation + + REAL :: CMFM, CHFH, CM2FM2, CH2FH2 + + +! ------------------------------------------------------------------------------------------------- +! Monin-Obukhov stability parameter moz for next iteration + + MOZOLD = MOZ + + IF(ZLVL <= ZPD) THEN + write(*,*) 'critical glacier problem: ZLVL <= ZPD; model stops', zlvl, zpd + WRITE(*,*) "STOP in Noah-MP Glacier" + STOP +! call wrf_error_fatal("STOP in Noah-MP glacier") + ENDIF + + TMPCM = LOG((ZLVL-ZPD) / Z0M) + TMPCH = LOG((ZLVL-ZPD) / Z0H) + TMPCM2 = LOG((2.0 + Z0M) / Z0M) + TMPCH2 = LOG((2.0 + Z0H) / Z0H) + + IF(ITER == 1) THEN + FV = 0.0 + MOZ = 0.0 + MOL = 0.0 + MOZ2 = 0.0 + ELSE + TVIR = (1. + 0.61*QAIR) * SFCTMP + TMP1 = VKC * (GRAV/TVIR) * H/(RHOAIR*CPAIR) + IF (ABS(TMP1) .LE. MPE) TMP1 = MPE + MOL = -1. * FV**3 / TMP1 + MOZ = MIN( (ZLVL-ZPD)/MOL, 1.) + MOZ2 = MIN( (2.0 + Z0H)/MOL, 1.) + ENDIF + +! accumulate number of times moz changes sign. + + IF (MOZOLD*MOZ .LT. 0.) MOZSGN = MOZSGN+1 + IF (MOZSGN .GE. 2) THEN + MOZ = 0. + FM = 0. + FH = 0. + MOZ2 = 0. + FM2 = 0. + FH2 = 0. + ENDIF + +! evaluate stability-dependent variables using moz from prior iteration + IF (MOZ .LT. 0.) THEN + TMP1 = (1. - 16.*MOZ)**0.25 + TMP2 = LOG((1.+TMP1*TMP1)/2.) + TMP3 = LOG((1.+TMP1)/2.) + FMNEW = 2.*TMP3 + TMP2 - 2.*ATAN(TMP1) + 1.5707963 + FHNEW = 2*TMP2 + +! 2-meter + TMP12 = (1. - 16.*MOZ2)**0.25 + TMP22 = LOG((1.+TMP12*TMP12)/2.) + TMP32 = LOG((1.+TMP12)/2.) + FM2NEW = 2.*TMP32 + TMP22 - 2.*ATAN(TMP12) + 1.5707963 + FH2NEW = 2*TMP22 + ELSE + FMNEW = -5.*MOZ + FHNEW = FMNEW + FM2NEW = -5.*MOZ2 + FH2NEW = FM2NEW + ENDIF + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + IF (ITER == 1) THEN + FM = FMNEW + FH = FHNEW + FM2 = FM2NEW + FH2 = FH2NEW + ELSE + FM = 0.5 * (FM+FMNEW) + FH = 0.5 * (FH+FHNEW) + FM2 = 0.5 * (FM2+FM2NEW) + FH2 = 0.5 * (FH2+FH2NEW) + ENDIF + +! exchange coefficients + + FH = MIN(FH,0.9*TMPCH) + FM = MIN(FM,0.9*TMPCM) + FH2 = MIN(FH2,0.9*TMPCH2) + FM2 = MIN(FM2,0.9*TMPCM2) + + CMFM = TMPCM-FM + CHFH = TMPCH-FH + CM2FM2 = TMPCM2-FM2 + CH2FH2 = TMPCH2-FH2 + IF(ABS(CMFM) <= MPE) CMFM = MPE + IF(ABS(CHFH) <= MPE) CHFH = MPE + IF(ABS(CM2FM2) <= MPE) CM2FM2 = MPE + IF(ABS(CH2FH2) <= MPE) CH2FH2 = MPE + CM = VKC*VKC/(CMFM*CMFM) + CH = VKC*VKC/(CMFM*CHFH) + CH2 = VKC*VKC/(CM2FM2*CH2FH2) + +! friction velocity + + FV = UR * SQRT(CM) + CH2 = VKC*FV/CH2FH2 + + END SUBROUTINE SFCDIF1_GLACIER +! ================================================================================================== + SUBROUTINE TSNOSOI_GLACIER (NSOIL ,NSNOW ,ISNOW ,DT ,TBOT , & !in + SSOIL ,SNOWH ,ZBOT ,ZSNSO ,DF , & !in + HCPCT , & !in + STC ) !inout +! -------------------------------------------------------------------------------------------------- +! Compute snow (up to 3L) and soil (4L) temperature. Note that snow temperatures +! during melting season may exceed melting point (TFRZ) but later in PHASECHANGE +! subroutine the snow temperatures are reset to TFRZ for melting snow. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +!input + + INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) + INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) + INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers + + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: TBOT ! + REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) + REAL, INTENT(IN) :: SNOWH !snow depth (m) + REAL, INTENT(IN) :: ZBOT !from soil surface (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bot. depth from snow surf.(m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity (J/m3/k) + +!input and output + + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC + +!local + + INTEGER :: IZ + REAL :: ZBOTSNO !ZBOT from snow surface + REAL, DIMENSION(-NSNOW+1:NSOIL) :: AI, BI, CI, RHSTS + REAL :: EFLXB !energy influx from soil bottom (w/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI !light through water (w/m2) + +! ---------------------------------------------------------------------- + +! prescribe solar penetration into ice/snow + + PHI(ISNOW+1:NSOIL) = 0. + +! adjust ZBOT from soil surface to ZBOTSNO from snow surface + + ZBOTSNO = ZBOT - SNOWH !from snow surface + +! compute ice temperatures + + CALL HRT_GLACIER (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & + STC ,TBOT ,ZBOTSNO ,DF , & + HCPCT ,SSOIL ,PHI , & + AI ,BI ,CI ,RHSTS , & + EFLXB ) + + CALL HSTEP_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT , & + AI ,BI ,CI ,RHSTS , & + STC ) + + END SUBROUTINE TSNOSOI_GLACIER +! ================================================================================================== +! ---------------------------------------------------------------------- + SUBROUTINE HRT_GLACIER (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & !in + STC ,TBOT ,ZBOT ,DF , & !in + HCPCT ,SSOIL ,PHI , & !in + AI ,BI ,CI ,RHSTS , & !out + BOTFLX ) !out +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) + INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) + INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers + REAL, INTENT(IN) :: TBOT !bottom soil temp. at ZBOT (k) + REAL, INTENT(IN) :: ZBOT !depth of lower boundary condition (m) + !from soil surface not snow surface + REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !depth of layer-bottom of snow/soil (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity [j/m3/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: PHI !light through water (w/m2) + +! output + + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: RHSTS !right-hand side of the matrix + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: AI !left-hand side coefficient + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: BI !left-hand side coefficient + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: CI !left-hand side coefficient + REAL, INTENT(OUT) :: BOTFLX !energy influx from soil bottom (w/m2) + +! local + + INTEGER :: K + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DDZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DENOM + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DTSDZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: EFLUX + REAL :: TEMP1 +! ---------------------------------------------------------------------- + + DO K = ISNOW+1, NSOIL + IF (K == ISNOW+1) THEN + DENOM(K) = - ZSNSO(K) * HCPCT(K) + TEMP1 = - ZSNSO(K+1) + DDZ(K) = 2.0 / TEMP1 + DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 + EFLUX(K) = DF(K) * DTSDZ(K) - SSOIL - PHI(K) + ELSE IF (K < NSOIL) THEN + DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) + TEMP1 = ZSNSO(K-1) - ZSNSO(K+1) + DDZ(K) = 2.0 / TEMP1 + DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 + EFLUX(K) = (DF(K)*DTSDZ(K) - DF(K-1)*DTSDZ(K-1)) - PHI(K) + ELSE IF (K == NSOIL) THEN + DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) + TEMP1 = ZSNSO(K-1) - ZSNSO(K) + IF(OPT_TBOT == 1) THEN + BOTFLX = 0. + END IF + IF(OPT_TBOT == 2) THEN + DTSDZ(K) = (STC(K) - TBOT) / ( 0.5*(ZSNSO(K-1)+ZSNSO(K)) - ZBOT) + BOTFLX = -DF(K) * DTSDZ(K) + END IF + EFLUX(K) = (-BOTFLX - DF(K-1)*DTSDZ(K-1) ) - PHI(K) + END IF + END DO + + DO K = ISNOW+1, NSOIL + IF (K == ISNOW+1) THEN + AI(K) = 0.0 + CI(K) = - DF(K) * DDZ(K) / DENOM(K) + IF (OPT_STC == 1 .OR. OPT_STC == 3) THEN + BI(K) = - CI(K) + END IF + IF (OPT_STC == 2) THEN + BI(K) = - CI(K) + DF(K)/(0.5*ZSNSO(K)*ZSNSO(K)*HCPCT(K)) + END IF + ELSE IF (K < NSOIL) THEN + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = - DF(K ) * DDZ(K ) / DENOM(K) + BI(K) = - (AI(K) + CI (K)) + ELSE IF (K == NSOIL) THEN + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = 0.0 + BI(K) = - (AI(K) + CI(K)) + END IF + RHSTS(K) = EFLUX(K)/ (-DENOM(K)) + END DO + + END SUBROUTINE HRT_GLACIER +! ================================================================================================== +! ---------------------------------------------------------------------- + SUBROUTINE HSTEP_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT , & !in + AI ,BI ,CI ,RHSTS , & !inout + STC ) !inout +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + INTEGER, INTENT(IN) :: NSOIL + INTEGER, INTENT(IN) :: NSNOW + INTEGER, INTENT(IN) :: ISNOW + REAL, INTENT(IN) :: DT + +! output & input + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: AI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: BI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: CI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: RHSTS + +! local + INTEGER :: K + REAL, DIMENSION(-NSNOW+1:NSOIL) :: RHSTSIN + REAL, DIMENSION(-NSNOW+1:NSOIL) :: CIIN +! ---------------------------------------------------------------------- + + DO K = ISNOW+1,NSOIL + RHSTS(K) = RHSTS(K) * DT + AI(K) = AI(K) * DT + BI(K) = 1. + BI(K) * DT + CI(K) = CI(K) * DT + END DO + +! copy values for input variables before call to rosr12 + + DO K = ISNOW+1,NSOIL + RHSTSIN(K) = RHSTS(K) + CIIN(K) = CI(K) + END DO + +! solve the tri-diagonal matrix equation + + CALL ROSR12_GLACIER (CI,AI,BI,CIIN,RHSTSIN,RHSTS,ISNOW+1,NSOIL,NSNOW) + +! update snow & soil temperature + + DO K = ISNOW+1,NSOIL + STC (K) = STC (K) + CI (K) + END DO + + END SUBROUTINE HSTEP_GLACIER +! ================================================================================================== + SUBROUTINE ROSR12_GLACIER (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW) +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NTOP + INTEGER, INTENT(IN) :: NSOIL,NSNOW + INTEGER :: K, KK + + REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(IN):: A, B, D + REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(INOUT):: C,P,DELTA + +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C (NSOIL) = 0.0 + P (NTOP) = - C (NTOP) / B (NTOP) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR THE 1ST SOIL LAYER +! ---------------------------------------------------------------------- + DELTA (NTOP) = D (NTOP) / B (NTOP) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = NTOP+1,NSOIL + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& + * P (K -1))) + END DO +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P (NSOIL) = DELTA (NSOIL) +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = NTOP+1,NSOIL + KK = NSOIL - K + (NTOP-1) + 1 + P (KK) = P (KK) * P (KK +1) + DELTA (KK) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12_GLACIER +! ---------------------------------------------------------------------- +! ================================================================================================== + SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in + DZSNSO , & !in + STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout + SMC ,SH2O , & !inout + QMELT ,IMELT ,PONDING ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! inputs + + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [=3] + INTEGER, INTENT(IN) :: NSOIL !No. of soil layers [=4] + INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers [<=3] + REAL, INTENT(IN) :: DT !land model time step (sec) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: FACT !temporary + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + +! inputs/outputs + + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, INTENT(INOUT) :: SNEQV + REAL, INTENT(INOUT) :: SNOWH + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water [m3/m3] + +! outputs + REAL, INTENT(OUT) :: QMELT !snowmelt rate [mm/s] + INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index + REAL, INTENT(OUT) :: PONDING!snowmelt when snow has no layer [mm] + +! local + + INTEGER :: J,K !do loop index + REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM !energy residual [w/m2] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM !melting or freezing water [kg/m2] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE !soil/snow ice mass [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ !soil/snow liquid water mass [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: HEATR !energy residual or loss after melting/freezing + REAL :: TEMP1 !temporary variables [kg/m2] + REAL :: PROPOR + REAL :: XMF !total latent heat of phase change + +! ---------------------------------------------------------------------- +! Initialization + + QMELT = 0. + PONDING = 0. + XMF = 0. + + DO J = ISNOW+1,0 ! all snow layers + MICE(J) = SNICE(J) + MLIQ(J) = SNLIQ(J) + END DO + + DO J = ISNOW+1,0 ! all snow layers; do ice later + IMELT(J) = 0 + HM(J) = 0. + XM(J) = 0. + WICE0(J) = MICE(J) + WLIQ0(J) = MLIQ(J) + WMASS0(J) = MICE(J) + MLIQ(J) + ENDDO + + DO J = ISNOW+1,0 + IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting + IMELT(J) = 1 + ENDIF + IF (MLIQ(J) > 0. .AND. STC(J) < TFRZ) THEN ! freezing + IMELT(J) = 2 + ENDIF + + ENDDO + +! Calculate the energy surplus and loss for melting and freezing + + DO J = ISNOW+1,0 + IF (IMELT(J) > 0) THEN + HM(J) = (STC(J)-TFRZ)/FACT(J) + STC(J) = TFRZ + ENDIF + + IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + XM(J) = HM(J)*DT/HFUS + ENDDO + +! The rate of melting and freezing for snow without a layer, opt_gla==1 treated below + +IF (OPT_GLA == 2) THEN + + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. STC(1) >= TFRZ) THEN + HM(1) = (STC(1)-TFRZ)/FACT(1) ! available heat + STC(1) = TFRZ ! set T to freezing + XM(1) = HM(1)*DT/HFUS ! total snow melt possible + + TEMP1 = SNEQV + SNEQV = MAX(0.,TEMP1-XM(1)) ! snow remaining + PROPOR = SNEQV/TEMP1 ! fraction melted + SNOWH = MAX(0.,PROPOR * SNOWH) ! new snow height + HEATR(1) = HM(1) - HFUS*(TEMP1-SNEQV)/DT ! excess heat + IF (HEATR(1) > 0.) THEN + XM(1) = HEATR(1)*DT/HFUS + STC(1) = STC(1) + FACT(1)*HEATR(1) ! re-heat ice + ELSE + XM(1) = 0. ! heat used up + HM(1) = 0. + ENDIF + QMELT = MAX(0.,(TEMP1-SNEQV))/DT ! melted snow rate + XMF = HFUS*QMELT ! melted snow energy + PONDING = TEMP1-SNEQV ! melt water + ENDIF + +END IF ! OPT_GLA == 2 + +! The rate of melting and freezing for snow + + DO J = ISNOW+1,0 + IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN + + HEATR(J) = 0. + IF (XM(J) > 0.) THEN + MICE(J) = MAX(0., WICE0(J)-XM(J)) + HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ELSE IF (XM(J) < 0.) THEN + MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) + HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ENDIF + + MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J)) + + IF (ABS(HEATR(J)) > 0.) THEN + STC(J) = STC(J) + FACT(J)*HEATR(J) + IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ + ENDIF + + QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT + + ENDIF + ENDDO + +IF (OPT_GLA == 1) THEN ! operate on the ice layers + + DO J = 1, NSOIL ! all soil layers + MLIQ(J) = SH2O(J) * DZSNSO(J) * 1000. + MICE(J) = (SMC(J) - SH2O(J)) * DZSNSO(J) * 1000. + END DO + + DO J = 1,NSOIL ! all layers + IMELT(J) = 0 + HM(J) = 0. + XM(J) = 0. + WICE0(J) = MICE(J) + WLIQ0(J) = MLIQ(J) + WMASS0(J) = MICE(J) + MLIQ(J) + ENDDO + + DO J = 1,NSOIL + IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting + IMELT(J) = 1 + ENDIF + IF (MLIQ(J) > 0. .AND. STC(J) < TFRZ) THEN ! freezing + IMELT(J) = 2 + ENDIF + + ! If snow exists, but its thickness is not enough to create a layer + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. J == 1) THEN + IF (STC(J) >= TFRZ) THEN + IMELT(J) = 1 + ENDIF + ENDIF + ENDDO + +! Calculate the energy surplus and loss for melting and freezing + + DO J = 1,NSOIL + IF (IMELT(J) > 0) THEN + HM(J) = (STC(J)-TFRZ)/FACT(J) + STC(J) = TFRZ + ENDIF + + IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + XM(J) = HM(J)*DT/HFUS + ENDDO + +! The rate of melting and freezing for snow without a layer, needs more work. + + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN + TEMP1 = SNEQV + SNEQV = MAX(0.,TEMP1-XM(1)) + PROPOR = SNEQV/TEMP1 + SNOWH = MAX(0.,PROPOR * SNOWH) + HEATR(1) = HM(1) - HFUS*(TEMP1-SNEQV)/DT + IF (HEATR(1) > 0.) THEN + XM(1) = HEATR(1)*DT/HFUS + HM(1) = HEATR(1) + IMELT(1) = 1 + ELSE + XM(1) = 0. + HM(1) = 0. + IMELT(1) = 0 + ENDIF + QMELT = MAX(0.,(TEMP1-SNEQV))/DT + XMF = HFUS*QMELT + PONDING = TEMP1-SNEQV + ENDIF + +! The rate of melting and freezing for soil + + DO J = 1,NSOIL + IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN + + HEATR(J) = 0. + IF (XM(J) > 0.) THEN + MICE(J) = MAX(0., WICE0(J)-XM(J)) + HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ELSE IF (XM(J) < 0.) THEN + MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) + HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ENDIF + + MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J)) + + IF (ABS(HEATR(J)) > 0.) THEN + STC(J) = STC(J) + FACT(J)*HEATR(J) + IF (J <= 0) THEN ! snow + IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ + END IF + ENDIF + + IF (J > 0) XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT + + IF (J < 1) THEN + QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT + ENDIF + ENDIF + ENDDO + HEATR = 0.0 + XM = 0.0 + +! Deal with residuals in ice/soil + +! FIRST REMOVE EXCESS HEAT BY REDUCING TEMPERATURE OF LAYERS + + IF (ANY(STC(1:4) > TFRZ) .AND. ANY(STC(1:4) < TFRZ)) THEN + DO J = 1,NSOIL + IF ( STC(J) > TFRZ ) THEN + HEATR(J) = (STC(J)-TFRZ)/FACT(J) + DO K = 1,NSOIL + IF (J .NE. K .AND. STC(K) < TFRZ .AND. HEATR(J) > 0.1) THEN + HEATR(K) = (STC(K)-TFRZ)/FACT(K) + IF (ABS(HEATR(K)) > HEATR(J)) THEN ! LAYER ABSORBS ALL + HEATR(K) = HEATR(K) + HEATR(J) + STC(K) = TFRZ + HEATR(K)*FACT(K) + HEATR(J) = 0.0 + ELSE + HEATR(J) = HEATR(J) + HEATR(K) + HEATR(K) = 0.0 + STC(K) = TFRZ + END IF + END IF + END DO + STC(J) = TFRZ + HEATR(J)*FACT(J) + END IF + END DO + END IF + +! NOW REMOVE EXCESS COLD BY INCREASING TEMPERATURE OF LAYERS (MAY NOT BE NECESSARY WITH ABOVE LOOP) + + IF (ANY(STC(1:4) > TFRZ) .AND. ANY(STC(1:4) < TFRZ)) THEN + DO J = 1,NSOIL + IF ( STC(J) < TFRZ ) THEN + HEATR(J) = (STC(J)-TFRZ)/FACT(J) + DO K = 1,NSOIL + IF (J .NE. K .AND. STC(K) > TFRZ .AND. HEATR(J) < -0.1) THEN + HEATR(K) = (STC(K)-TFRZ)/FACT(K) + IF (HEATR(K) > ABS(HEATR(J))) THEN ! LAYER ABSORBS ALL + HEATR(K) = HEATR(K) + HEATR(J) + STC(K) = TFRZ + HEATR(K)*FACT(K) + HEATR(J) = 0.0 + ELSE + HEATR(J) = HEATR(J) + HEATR(K) + HEATR(K) = 0.0 + STC(K) = TFRZ + END IF + END IF + END DO + STC(J) = TFRZ + HEATR(J)*FACT(J) + END IF + END DO + END IF + +! NOW REMOVE EXCESS HEAT BY MELTING ICE + + IF (ANY(STC(1:4) > TFRZ) .AND. ANY(MICE(1:4) > 0.)) THEN + DO J = 1,NSOIL + IF ( STC(J) > TFRZ ) THEN + HEATR(J) = (STC(J)-TFRZ)/FACT(J) + XM(J) = HEATR(J)*DT/HFUS + DO K = 1,NSOIL + IF (J .NE. K .AND. MICE(K) > 0. .AND. XM(J) > 0.1) THEN + IF (MICE(K) > XM(J)) THEN ! LAYER ABSORBS ALL + MICE(K) = MICE(K) - XM(J) + XMF = XMF + HFUS * XM(J)/DT + STC(K) = TFRZ + XM(J) = 0.0 + ELSE + XM(J) = XM(J) - MICE(K) + XMF = XMF + HFUS * MICE(K)/DT + MICE(K) = 0.0 + STC(K) = TFRZ + END IF + MLIQ(K) = MAX(0.,WMASS0(K)-MICE(K)) + END IF + END DO + HEATR(J) = XM(J)*HFUS/DT + STC(J) = TFRZ + HEATR(J)*FACT(J) + END IF + END DO + END IF + +! NOW REMOVE EXCESS COLD BY FREEZING LIQUID OF LAYERS (MAY NOT BE NECESSARY WITH ABOVE LOOP) + + IF (ANY(STC(1:4) < TFRZ) .AND. ANY(MLIQ(1:4) > 0.)) THEN + DO J = 1,NSOIL + IF ( STC(J) < TFRZ ) THEN + HEATR(J) = (STC(J)-TFRZ)/FACT(J) + XM(J) = HEATR(J)*DT/HFUS + DO K = 1,NSOIL + IF (J .NE. K .AND. MLIQ(K) > 0. .AND. XM(J) < -0.1) THEN + IF (MLIQ(K) > ABS(XM(J))) THEN ! LAYER ABSORBS ALL + MICE(K) = MICE(K) - XM(J) + XMF = XMF + HFUS * XM(J)/DT + STC(K) = TFRZ + XM(J) = 0.0 + ELSE + XM(J) = XM(J) + MLIQ(K) + XMF = XMF - HFUS * MLIQ(K)/DT + MICE(K) = WMASS0(K) + STC(K) = TFRZ + END IF + MLIQ(K) = MAX(0.,WMASS0(K)-MICE(K)) + END IF + END DO + HEATR(J) = XM(J)*HFUS/DT + STC(J) = TFRZ + HEATR(J)*FACT(J) + END IF + END DO + END IF + +END IF ! OPT_GLA == 1 + + DO J = ISNOW+1,0 ! snow + SNLIQ(J) = MLIQ(J) + SNICE(J) = MICE(J) + END DO + + DO J = 1, NSOIL ! soil + IF(OPT_GLA == 1) THEN + SH2O(J) = MLIQ(J) / (1000. * DZSNSO(J)) + SH2O(J) = MAX(0.0,MIN(1.0,SH2O(J))) +! SMC(J) = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J)) + ELSEIF(OPT_GLA == 2) THEN + SH2O(J) = 0.0 ! ice, assume all frozen...forever + END IF + SMC(J) = 1.0 + END DO + + END SUBROUTINE PHASECHANGE_GLACIER +! ================================================================================================== + SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in + QVAP ,QDEW ,FICEOLD,ZSOIL , & !in + ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout + DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO ,FSH , & !inout + RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE & !out +!#ifdef WRF_HYDRO +! , sfcheadrt & +!#endif + ) !out +! ---------------------------------------------------------------------- +! Code history: +! Initial code: Guo-Yue Niu, Oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [1-melt; 2-freeze] + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: PRCP !precipitation (mm/s) + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL, INTENT(INOUT) :: QVAP !soil surface evaporation rate[mm/s] + REAL, INTENT(INOUT) :: QDEW !soil surface dew rate[mm/s] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD !ice fraction at last timestep + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + +! input/output + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice content [m3/m3] + REAL , INTENT(INOUT) :: PONDING ![mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , INTENT(INOUT) :: FSH !total sensible heat (w/m2) [+ to atm] + +! output + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: RUNSUB !baseflow (sturation excess) [mm/s] + REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + REAL, INTENT(OUT) :: FPICE !precipitation frozen fraction + +! local + REAL :: QRAIN !rain at ground srf (mm) [+] + REAL :: QSEVA !soil surface evap rate [mm/s] + REAL :: QSDEW !soil surface dew rate [mm/s] + REAL :: QSNFRO !snow surface frost rate[mm/s] + REAL :: QSNSUB !snow surface sublimation rate [mm/s] + REAL :: SNOWHIN !snow depth increasing rate (m/s) + REAL :: SNOFLOW !glacier flow [mm/s] + REAL :: BDFALL !density of new snow (mm water/m snow) + REAL :: REPLACE !replacement water due to sublimation of glacier + REAL, DIMENSION( 1:NSOIL) :: SICE_SAVE !soil ice content [m3/m3] + REAL, DIMENSION( 1:NSOIL) :: SH2O_SAVE !soil liquid water content [m3/m3] + INTEGER :: ILEV + +!#ifdef WRF_HYDRO +! REAL , INTENT(INOUT) :: sfcheadrt +!#endif + +! ---------------------------------------------------------------------- +! initialize + + SNOFLOW = 0. + RUNSUB = 0. + RUNSRF = 0. + SICE_SAVE = SICE + SH2O_SAVE = SH2O + +! -------------------------------------------------------------------- +! partition precipitation into rain and snow (from CANWATER) + +! Jordan (1991) + + IF(OPT_SNF == 1 .OR. OPT_SNF == 4) THEN + IF(SFCTMP > TFRZ+2.5)THEN + FPICE = 0. + ELSE + IF(SFCTMP <= TFRZ+0.5)THEN + FPICE = 1.0 + ELSE IF(SFCTMP <= TFRZ+2.)THEN + FPICE = 1.-(-54.632 + 0.2*SFCTMP) + ELSE + FPICE = 0.6 + ENDIF + ENDIF + ENDIF + + IF(OPT_SNF == 2) THEN + IF(SFCTMP >= TFRZ+2.2) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF + + IF(OPT_SNF == 3) THEN + IF(SFCTMP >= TFRZ) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF +! print*, 'fpice: ',fpice + +! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 +! fresh snow density + + BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) !MB: change to MIN v3.7 + + QRAIN = PRCP * (1.-FPICE) + QSNOW = PRCP * FPICE + SNOWHIN = QSNOW/BDFALL +! print *, 'qrain, qsnow',qrain,qsnow,qrain*dt,qsnow*dt + +! sublimation, frost, evaporation, and dew + + QSNSUB = QVAP ! send total sublimation/frost to SNOWWATER and deal with it there + QSNFRO = QDEW + + CALL SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in + SNOWHIN,QSNOW ,QSNFRO ,QSNSUB ,QRAIN , & !in + FICEOLD,ZSOIL , & !in + ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout + SH2O ,SICE ,STC ,DZSNSO ,ZSNSO , & !inout + FSH , & !inout + QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out + + !PONDING: melting water from snow when there is no layer + + RUNSRF = (PONDING+PONDING1+PONDING2)/DT + + IF(ISNOW == 0) THEN + RUNSRF = RUNSRF + QSNBOT + QRAIN + ELSE + RUNSRF = RUNSRF + QSNBOT + ENDIF + +!#ifdef WRF_HYDRO +! RUNSRF = RUNSRF + sfcheadrt/DT !sfcheadrt units (mm) +!#endif + + IF(OPT_GLA == 1) THEN + REPLACE = 0.0 + DO ILEV = 1,NSOIL + REPLACE = REPLACE + DZSNSO(ILEV)*(SICE(ILEV) - SICE_SAVE(ILEV) + SH2O(ILEV) - SH2O_SAVE(ILEV)) + END DO + REPLACE = REPLACE * 1000.0 / DT ! convert to [mm/s] + + SICE = MIN(1.0,SICE_SAVE) + ELSEIF(OPT_GLA == 2) THEN + SICE = 1.0 + END IF + SH2O = 1.0 - SICE + + ! use RUNSUB as a water balancer, SNOFLOW is snow that disappears, REPLACE is + ! water from below that replaces glacier loss + + IF(OPT_GLA == 1) THEN + RUNSUB = SNOFLOW + REPLACE + ELSEIF(OPT_GLA == 2) THEN + RUNSUB = SNOFLOW + QVAP = QSNSUB + QDEW = QSNFRO + END IF + + END SUBROUTINE WATER_GLACIER +! ================================================================================================== +! ---------------------------------------------------------------------- + SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in + SNOWHIN,QSNOW ,QSNFRO ,QSNSUB ,QRAIN , & !in + FICEOLD,ZSOIL , & !in + ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout + SH2O ,SICE ,STC ,DZSNSO ,ZSNSO , & !inout + FSH , & !inout + QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) + REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(INOUT) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(INOUT) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: FICEOLD!ice fraction at last timestep + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + +! input & output + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , INTENT(INOUT) :: FSH !total sensible heat (w/m2) [+ to atm] + +! output + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + REAL, INTENT(OUT) :: SNOFLOW!glacier flow [mm] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 + +! local + INTEGER :: IZ + REAL :: BDSNOW !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + SNOFLOW = 0.0 + PONDING1 = 0.0 + PONDING2 = 0.0 + + CALL SNOWFALL_GLACIER (NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN, & !in + SFCTMP , & !in + ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout + SNLIQ ,SNEQV ) !inout + + IF(ISNOW < 0) THEN !WHEN MORE THAN ONE LAYER + CALL COMPACT_GLACIER (NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in + SNLIQ ,IMELT ,FICEOLD, & !in + ISNOW ,DZSNSO ) !inout + + CALL COMBINE_GLACIER (NSNOW ,NSOIL , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1 ,PONDING2) !out + + CALL DIVIDE_GLACIER (NSNOW ,NSOIL , & !in + ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout + END IF + +!SET EMPTY SNOW LAYERS TO ZERO + + DO IZ = -NSNOW+1, ISNOW + SNICE(IZ) = 0. + SNLIQ(IZ) = 0. + STC(IZ) = 0. + DZSNSO(IZ)= 0. + ZSNSO(IZ) = 0. + ENDDO + + CALL SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + QRAIN , & !in + ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout + SNLIQ ,SH2O ,SICE ,STC , & !inout + PONDING1 ,PONDING2 ,FSH , & !inout + QSNBOT ) !out + +!to obtain equilibrium state of snow in glacier region + + IF(SNEQV > 2000.) THEN ! 2000 mm -> maximum water depth + BDSNOW = SNICE(0) / DZSNSO(0) + SNOFLOW = (SNEQV - 2000.) + SNICE(0) = SNICE(0) - SNOFLOW + DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW + SNOFLOW = SNOFLOW / DT + END IF + +! sum up snow mass for layered snow + + IF(ISNOW /= 0) THEN + SNEQV = 0. + DO IZ = ISNOW+1,0 + SNEQV = SNEQV + SNICE(IZ) + SNLIQ(IZ) + ENDDO + END IF + +! Reset ZSNSO and layer thinkness DZSNSO + + DO IZ = ISNOW+1, 0 + DZSNSO(IZ) = -DZSNSO(IZ) + END DO + + DZSNSO(1) = ZSOIL(1) + DO IZ = 2,NSOIL + DZSNSO(IZ) = (ZSOIL(IZ) - ZSOIL(IZ-1)) + END DO + + ZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + DO IZ = ISNOW+2 ,NSOIL + ZSNSO(IZ) = ZSNSO(IZ-1) + DZSNSO(IZ) + ENDDO + + DO IZ = ISNOW+1 ,NSOIL + DZSNSO(IZ) = -DZSNSO(IZ) + END DO + + END SUBROUTINE SNOWWATER_GLACIER +! ================================================================================================== + SUBROUTINE SNOWFALL_GLACIER (NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , & !in + SFCTMP , & !in + ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout + SNLIQ ,SNEQV ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + +! input and output + + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: SNOWH !snow depth [m] + REAL, INTENT(INOUT) :: SNEQV !swow water equivalent [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !thickness of snow/soil layers (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + +! local + + INTEGER :: NEWNODE ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + NEWNODE = 0 + +! shallow snow / no layer + + IF(ISNOW == 0 .and. QSNOW > 0.) THEN + SNOWH = SNOWH + SNOWHIN * DT + SNEQV = SNEQV + QSNOW * DT + END IF + +! creating a new layer + + IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.05) THEN + ISNOW = -1 + NEWNODE = 1 + DZSNSO(0)= SNOWH + SNOWH = 0. + STC(0) = MIN(273.16, SFCTMP) ! temporary setup + SNICE(0) = SNEQV + SNLIQ(0) = 0. + END IF + +! snow with layers + + IF(ISNOW < 0 .AND. NEWNODE == 0 .AND. QSNOW > 0.) then + SNICE(ISNOW+1) = SNICE(ISNOW+1) + QSNOW * DT + DZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + SNOWHIN * DT + ENDIF + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWFALL_GLACIER +! ================================================================================================== +! ---------------------------------------------------------------------- + SUBROUTINE COMPACT_GLACIER (NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in + SNLIQ ,IMELT ,FICEOLD, & !in + ISNOW ,DZSNSO ) !inout +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] + REAL, INTENT(IN) :: DT !time step (sec) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep + +! input and output + INTEGER, INTENT(INOUT) :: ISNOW ! actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer thickness [m] + +! local + REAL, PARAMETER :: C2 = 21.e-3 ![m3/kg] ! default 21.e-3 + REAL, PARAMETER :: C3 = 2.5e-6 ![1/s] + REAL, PARAMETER :: C4 = 0.04 ![1/k] + REAL, PARAMETER :: C5 = 2.0 ! + REAL, PARAMETER :: DM = 100.0 !upper Limit on destructive metamorphism compaction [kg/m3] + REAL, PARAMETER :: ETA0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to Anderson, it is between 0.52e6~1.38e6 + REAL :: BURDEN !pressure of overlying snow [kg/m2] + REAL :: DDZ1 !rate of settling of snow pack due to destructive metamorphism. + REAL :: DDZ2 !rate of compaction of snow pack due to overburden. + REAL :: DDZ3 !rate of compaction of snow pack due to melt [1/s] + REAL :: DEXPF !EXPF=exp(-c4*(273.15-STC)). + REAL :: TD !STC - TFRZ [K] + REAL :: PDZDTC !nodal rate of change in fractional-thickness due to compaction [fraction/s] + REAL :: VOID !void (1 - SNICE - SNLIQ) + REAL :: WX !water mass (ice + liquid) [kg/m2] + REAL :: BI !partial density of ice [kg/m3] + REAL, DIMENSION(-NSNOW+1:0) :: FICE !fraction of ice at current time step + + INTEGER :: J + +! ---------------------------------------------------------------------- + BURDEN = 0.0 + + DO J = ISNOW+1, 0 + + WX = SNICE(J) + SNLIQ(J) + FICE(J) = SNICE(J) / WX + VOID = 1. - (SNICE(J)/DENICE + SNLIQ(J)/DENH2O) / DZSNSO(J) + + ! Allow compaction only for non-saturated node and higher ice lens node. + IF (VOID > 0.001 .AND. SNICE(J) > 0.1) THEN + BI = SNICE(J) / DZSNSO(J) + TD = MAX(0.,TFRZ-STC(J)) + DEXPF = EXP(-C4*TD) + + ! Settling as a result of destructive metamorphism + + DDZ1 = -C3*DEXPF + + IF (BI > DM) DDZ1 = DDZ1*EXP(-46.0E-3*(BI-DM)) + + ! Liquid water term + + IF (SNLIQ(J) > 0.01*DZSNSO(J)) DDZ1=DDZ1*C5 + + ! Compaction due to overburden + + DDZ2 = -(BURDEN+0.5*WX)*EXP(-0.08*TD-C2*BI)/ETA0 ! 0.5*WX -> self-burden + + ! Compaction occurring during melt + + IF (IMELT(J) == 1) THEN + DDZ3 = MAX(0.,(FICEOLD(J) - FICE(J))/MAX(1.E-6,FICEOLD(J))) + DDZ3 = - DDZ3/DT ! sometimes too large + ELSE + DDZ3 = 0. + END IF + + ! Time rate of fractional change in DZ (units of s-1) + + PDZDTC = (DDZ1 + DDZ2 + DDZ3)*DT + PDZDTC = MAX(-0.5,PDZDTC) + + ! The change in DZ due to compaction + + DZSNSO(J) = DZSNSO(J)*(1.+PDZDTC) + END IF + + ! Pressure of overlying snow + + BURDEN = BURDEN + WX + + END DO + + END SUBROUTINE COMPACT_GLACIER +! ================================================================================================== + SUBROUTINE COMBINE_GLACIER (NSNOW ,NSOIL , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1 ,PONDING2) !inout +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + +! input and output + + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] + REAL, INTENT(INOUT) :: SNEQV !snow water equivalent [m] + REAL, INTENT(INOUT) :: SNOWH !snow depth [m] + REAL, INTENT(INOUT) :: PONDING1 + REAL, INTENT(INOUT) :: PONDING2 + +! local variables: + + INTEGER :: I,J,K,L ! node indices + INTEGER :: ISNOW_OLD ! number of top snow layer + INTEGER :: MSSI ! node index + INTEGER :: NEIBOR ! adjacent node selected for combination + REAL :: ZWICE ! total ice mass in snow + REAL :: ZWLIQ ! total liquid water in snow + REAL :: DZMIN(3) ! minimum of top snow layer + DATA DZMIN /0.045, 0.05, 0.2/ +! DATA DZMIN /0.025, 0.025, 0.1/ ! MB: change limit +!----------------------------------------------------------------------- + + ISNOW_OLD = ISNOW + + DO J = ISNOW_OLD+1,0 + IF (SNICE(J) <= .1) THEN + IF(J /= 0) THEN + SNLIQ(J+1) = SNLIQ(J+1) + SNLIQ(J) + SNICE(J+1) = SNICE(J+1) + SNICE(J) + ELSE + IF (ISNOW_OLD < -1) THEN + SNLIQ(J-1) = SNLIQ(J-1) + SNLIQ(J) + SNICE(J-1) = SNICE(J-1) + SNICE(J) + ELSE + PONDING1 = PONDING1 + SNLIQ(J) ! ISNOW WILL GET SET TO ZERO BELOW + SNEQV = SNICE(J) ! PONDING WILL GET ADDED TO PONDING FROM + SNOWH = DZSNSO(J) ! PHASECHANGE WHICH SHOULD BE ZERO HERE + SNLIQ(J) = 0.0 ! BECAUSE THERE IT WAS ONLY CALCULATED + SNICE(J) = 0.0 ! FOR THIN SNOW + DZSNSO(J) = 0.0 + ENDIF +! SH2O(1) = SH2O(1)+SNLIQ(J)/(DZSNSO(1)*1000.) +! SICE(1) = SICE(1)+SNICE(J)/(DZSNSO(1)*1000.) + ENDIF + + ! shift all elements above this down by one. + IF (J > ISNOW+1 .AND. ISNOW < -1) THEN + DO I = J, ISNOW+2, -1 + STC(I) = STC(I-1) + SNLIQ(I) = SNLIQ(I-1) + SNICE(I) = SNICE(I-1) + DZSNSO(I)= DZSNSO(I-1) + END DO + END IF + ISNOW = ISNOW + 1 + END IF + END DO + +! to conserve water in case of too large surface sublimation + + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + + IF(ISNOW ==0) RETURN ! MB: get out if no longer multi-layer + + SNEQV = 0. + SNOWH = 0. + ZWICE = 0. + ZWLIQ = 0. + + DO J = ISNOW+1,0 + SNEQV = SNEQV + SNICE(J) + SNLIQ(J) + SNOWH = SNOWH + DZSNSO(J) + ZWICE = ZWICE + SNICE(J) + ZWLIQ = ZWLIQ + SNLIQ(J) + END DO + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + +! IF (SNOWH < 0.025 .AND. ISNOW < 0 ) THEN ! MB: change limit + IF (SNOWH < 0.05 .AND. ISNOW < 0 ) THEN + ISNOW = 0 + SNEQV = ZWICE + PONDING2 = PONDING2 + ZWLIQ ! LIMIT OF ISNOW < 0 MEANS INPUT PONDING + IF(SNEQV <= 0.) SNOWH = 0. ! SHOULD BE ZERO; SEE ABOVE + END IF + +! IF (SNOWH < 0.05 ) THEN +! ISNOW = 0 +! SNEQV = ZWICE +! SH2O(1) = SH2O(1) + ZWLIQ / (DZSNSO(1) * 1000.) +! IF(SNEQV <= 0.) SNOWH = 0. +! END IF + +! check the snow depth - snow layers combined + + IF (ISNOW < -1) THEN + + ISNOW_OLD = ISNOW + MSSI = 1 + + DO I = ISNOW_OLD+1,0 + IF (DZSNSO(I) < DZMIN(MSSI)) THEN + + IF (I == ISNOW+1) THEN + NEIBOR = I + 1 + ELSE IF (I == 0) THEN + NEIBOR = I - 1 + ELSE + NEIBOR = I + 1 + IF ((DZSNSO(I-1)+DZSNSO(I)) < (DZSNSO(I+1)+DZSNSO(I))) NEIBOR = I-1 + END IF + + ! Node l and j are combined and stored as node j. + IF (NEIBOR > I) THEN + J = NEIBOR + L = I + ELSE + J = I + L = NEIBOR + END IF + + CALL COMBO_GLACIER (DZSNSO(J), SNLIQ(J), SNICE(J), & + STC(J), DZSNSO(L), SNLIQ(L), SNICE(L), STC(L) ) + + ! Now shift all elements above this down one. + IF (J-1 > ISNOW+1) THEN + DO K = J-1, ISNOW+2, -1 + STC(K) = STC(K-1) + SNICE(K) = SNICE(K-1) + SNLIQ(K) = SNLIQ(K-1) + DZSNSO(K) = DZSNSO(K-1) + END DO + END IF + + ! Decrease the number of snow layers + ISNOW = ISNOW + 1 + IF (ISNOW >= -1) EXIT + ELSE + + ! The layer thickness is greater than the prescribed minimum value + MSSI = MSSI + 1 + + END IF + END DO + + END IF + + END SUBROUTINE COMBINE_GLACIER +! ================================================================================================== + +! ---------------------------------------------------------------------- + SUBROUTINE COMBO_GLACIER(DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + REAL, INTENT(IN) :: DZ2 !nodal thickness of 2 elements being combined [m] + REAL, INTENT(IN) :: WLIQ2 !liquid water of element 2 [kg/m2] + REAL, INTENT(IN) :: WICE2 !ice of element 2 [kg/m2] + REAL, INTENT(IN) :: T2 !nodal temperature of element 2 [k] + REAL, INTENT(INOUT) :: DZ !nodal thickness of 1 elements being combined [m] + REAL, INTENT(INOUT) :: WLIQ !liquid water of element 1 + REAL, INTENT(INOUT) :: WICE !ice of element 1 [kg/m2] + REAL, INTENT(INOUT) :: T !node temperature of element 1 [k] + +! local + + REAL :: DZC !total thickness of nodes 1 and 2 (DZC=DZ+DZ2). + REAL :: WLIQC !combined liquid water [kg/m2] + REAL :: WICEC !combined ice [kg/m2] + REAL :: TC !combined node temperature [k] + REAL :: H !enthalpy of element 1 [J/m2] + REAL :: H2 !enthalpy of element 2 [J/m2] + REAL :: HC !temporary + +!----------------------------------------------------------------------- + + DZC = DZ+DZ2 + WICEC = (WICE+WICE2) + WLIQC = (WLIQ+WLIQ2) + H = (CICE*WICE+CWAT*WLIQ) * (T-TFRZ)+HFUS*WLIQ + H2= (CICE*WICE2+CWAT*WLIQ2) * (T2-TFRZ)+HFUS*WLIQ2 + + HC = H + H2 + IF(HC < 0.)THEN + TC = TFRZ + HC/(CICE*WICEC + CWAT*WLIQC) + ELSE IF (HC.LE.HFUS*WLIQC) THEN + TC = TFRZ + ELSE + TC = TFRZ + (HC - HFUS*WLIQC) / (CICE*WICEC + CWAT*WLIQC) + END IF + + DZ = DZC + WICE = WICEC + WLIQ = WLIQC + T = TC + + END SUBROUTINE COMBO_GLACIER +! ================================================================================================== + SUBROUTINE DIVIDE_GLACIER (NSNOW ,NSOIL , & !in + ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] + +! input and output + + INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] + +! local variables: + + INTEGER :: J !indices + INTEGER :: MSNO !number of layer (top) to MSNO (bot) + REAL :: DRR !thickness of the combined [m] + REAL, DIMENSION( 1:NSNOW) :: DZ !snow layer thickness [m] + REAL, DIMENSION( 1:NSNOW) :: SWICE !partial volume of ice [m3/m3] + REAL, DIMENSION( 1:NSNOW) :: SWLIQ !partial volume of liquid water [m3/m3] + REAL, DIMENSION( 1:NSNOW) :: TSNO !node temperature [k] + REAL :: ZWICE !temporary + REAL :: ZWLIQ !temporary + REAL :: PROPOR!temporary + REAL :: DTDZ !temporary +! ---------------------------------------------------------------------- + + DO J = 1,NSNOW + IF (J <= ABS(ISNOW)) THEN + DZ(J) = DZSNSO(J+ISNOW) + SWICE(J) = SNICE(J+ISNOW) + SWLIQ(J) = SNLIQ(J+ISNOW) + TSNO(J) = STC(J+ISNOW) + END IF + END DO + + MSNO = ABS(ISNOW) + + IF (MSNO == 1) THEN + ! Specify a new snow layer + IF (DZ(1) > 0.05) THEN + MSNO = 2 + DZ(1) = DZ(1)/2. + SWICE(1) = SWICE(1)/2. + SWLIQ(1) = SWLIQ(1)/2. + DZ(2) = DZ(1) + SWICE(2) = SWICE(1) + SWLIQ(2) = SWLIQ(1) + TSNO(2) = TSNO(1) + END IF + END IF + + IF (MSNO > 1) THEN + IF (DZ(1) > 0.05) THEN + DRR = DZ(1) - 0.05 + PROPOR = DRR/DZ(1) + ZWICE = PROPOR*SWICE(1) + ZWLIQ = PROPOR*SWLIQ(1) + PROPOR = 0.05/DZ(1) + SWICE(1) = PROPOR*SWICE(1) + SWLIQ(1) = PROPOR*SWLIQ(1) + DZ(1) = 0.05 + + CALL COMBO_GLACIER (DZ(2), SWLIQ(2), SWICE(2), TSNO(2), DRR, & + ZWLIQ, ZWICE, TSNO(1)) + + ! subdivide a new layer +! IF (MSNO <= 2 .AND. DZ(2) > 0.20) THEN ! MB: change limit + IF (MSNO <= 2 .AND. DZ(2) > 0.10) THEN + MSNO = 3 + DTDZ = (TSNO(1) - TSNO(2))/((DZ(1)+DZ(2))/2.) + DZ(2) = DZ(2)/2. + SWICE(2) = SWICE(2)/2. + SWLIQ(2) = SWLIQ(2)/2. + DZ(3) = DZ(2) + SWICE(3) = SWICE(2) + SWLIQ(3) = SWLIQ(2) + TSNO(3) = TSNO(2) - DTDZ*DZ(2)/2. + IF (TSNO(3) >= TFRZ) THEN + TSNO(3) = TSNO(2) + ELSE + TSNO(2) = TSNO(2) + DTDZ*DZ(2)/2. + ENDIF + + END IF + END IF + END IF + + IF (MSNO > 2) THEN + IF (DZ(2) > 0.2) THEN + DRR = DZ(2) - 0.2 + PROPOR = DRR/DZ(2) + ZWICE = PROPOR*SWICE(2) + ZWLIQ = PROPOR*SWLIQ(2) + PROPOR = 0.2/DZ(2) + SWICE(2) = PROPOR*SWICE(2) + SWLIQ(2) = PROPOR*SWLIQ(2) + DZ(2) = 0.2 + CALL COMBO_GLACIER (DZ(3), SWLIQ(3), SWICE(3), TSNO(3), DRR, & + ZWLIQ, ZWICE, TSNO(2)) + END IF + END IF + + ISNOW = -MSNO + + DO J = ISNOW+1,0 + DZSNSO(J) = DZ(J-ISNOW) + SNICE(J) = SWICE(J-ISNOW) + SNLIQ(J) = SWLIQ(J-ISNOW) + STC(J) = TSNO(J-ISNOW) + END DO + + +! DO J = ISNOW+1,NSOIL +! WRITE(*,'(I5,7F10.3)') J, DZSNSO(J), SNICE(J), SNLIQ(J),STC(J) +! END DO + + END SUBROUTINE DIVIDE_GLACIER +! ================================================================================================== + SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + QRAIN , & !in + ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout + SNLIQ ,SH2O ,SICE ,STC , & !inout + PONDING1 ,PONDING2 ,FSH , & !inout + QSNBOT ) !out +! ---------------------------------------------------------------------- +! Renew the mass of ice lens (SNICE) and liquid (SNLIQ) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers[=3] + INTEGER, INTENT(IN) :: NSOIL !No. of soil layers[=4] + REAL, INTENT(IN) :: DT !time step + REAL, INTENT(INOUT) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(INOUT) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] + +! output + + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + +! input and output + + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer depth [m] + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, INTENT(INOUT) :: PONDING1 + REAL, INTENT(INOUT) :: PONDING2 + REAL, INTENT(INOUT) :: FSH !total sensible heat (w/m2) [+ to atm] + +! local variables: + + INTEGER :: J !do loop/array indices + REAL :: QIN !water flow into the element (mm/s) + REAL :: QOUT !water flow out of the element (mm/s) + REAL :: WGDIF !ice mass after minus sublimation + REAL, DIMENSION(-NSNOW+1:0) :: VOL_LIQ !partial volume of liquid water in layer + REAL, DIMENSION(-NSNOW+1:0) :: VOL_ICE !partial volume of ice lens in layer + REAL, DIMENSION(-NSNOW+1:0) :: EPORE !effective porosity = porosity - VOL_ICE + REAL :: PROPOR, TEMP +! ---------------------------------------------------------------------- + +!for the case when SNEQV becomes '0' after 'COMBINE' + + IF(SNEQV == 0.) THEN + IF(OPT_GLA == 1) THEN + SICE(1) = SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.) + ELSEIF(OPT_GLA == 2) THEN + FSH = FSH - (QSNFRO-QSNSUB)*HSUB + QSNFRO = 0.0 + QSNSUB = 0.0 + END IF + END IF + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. To conserve water, +! excessive sublimation is used to reduce soil water. Smaller time steps would tend +! to aviod this problem. + + IF(ISNOW == 0 .and. SNEQV > 0.) THEN + IF(OPT_GLA == 1) THEN + TEMP = SNEQV + SNEQV = SNEQV - QSNSUB*DT + QSNFRO*DT + PROPOR = SNEQV/TEMP + SNOWH = MAX(0.,PROPOR * SNOWH) + ELSEIF(OPT_GLA == 2) THEN + FSH = FSH - (QSNFRO-QSNSUB)*HSUB + QSNFRO = 0.0 + QSNSUB = 0.0 + END IF + + IF(SNEQV < 0.) THEN + SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.) + SNEQV = 0. + SNOWH = 0. + END IF + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + END IF + + IF(SNOWH <= 1.E-8 .OR. SNEQV <= 1.E-6) THEN + SNOWH = 0.0 + SNEQV = 0.0 + END IF + +! for deep snow + + IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references + + WGDIF = SNICE(ISNOW+1) - QSNSUB*DT + QSNFRO*DT + SNICE(ISNOW+1) = WGDIF + IF (WGDIF < 1.e-6 .and. ISNOW <0) THEN + CALL COMBINE_GLACIER (NSNOW ,NSOIL , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1, PONDING2 ) !inout + ENDIF + !KWM: Subroutine COMBINE can change ISNOW to make it 0 again? + IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references + SNLIQ(ISNOW+1) = SNLIQ(ISNOW+1) + QRAIN * DT + SNLIQ(ISNOW+1) = MAX(0., SNLIQ(ISNOW+1)) + ENDIF + + ENDIF !KWM -- Can the ENDIF be moved toward the end of the subroutine (Just set QSNBOT=0)? + +! Porosity and partial volume + + !KWM Looks to me like loop index / IF test can be simplified. + + DO J = -NSNOW+1, 0 + IF (J >= ISNOW+1) THEN + VOL_ICE(J) = MIN(1., SNICE(J)/(DZSNSO(J)*DENICE)) + EPORE(J) = 1. - VOL_ICE(J) + VOL_LIQ(J) = MIN(EPORE(J),SNLIQ(J)/(DZSNSO(J)*DENH2O)) + END IF + END DO + + QIN = 0. + QOUT = 0. + + !KWM Looks to me like loop index / IF test can be simplified. + + DO J = -NSNOW+1, 0 + IF (J >= ISNOW+1) THEN + SNLIQ(J) = SNLIQ(J) + QIN + IF (J <= -1) THEN + IF (EPORE(J) < 0.05 .OR. EPORE(J+1) < 0.05) THEN + QOUT = 0. + ELSE + QOUT = MAX(0.,(VOL_LIQ(J)-SSI*EPORE(J))*DZSNSO(J)) + QOUT = MIN(QOUT,(1.-VOL_ICE(J+1)-VOL_LIQ(J+1))*DZSNSO(J+1)) + END IF + ELSE + QOUT = MAX(0.,(VOL_LIQ(J) - SSI*EPORE(J))*DZSNSO(J)) + END IF + QOUT = QOUT*1000. + SNLIQ(J) = SNLIQ(J) - QOUT + QIN = QOUT + END IF + END DO + +! Liquid water from snow bottom to soil + + QSNBOT = QOUT / DT ! mm/s + + END SUBROUTINE SNOWH2O_GLACIER +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + SUBROUTINE ERROR_GLACIER (ILOC ,JLOC ,SWDOWN ,FSA ,FSR ,FIRA , & + FSH ,FGEV ,SSOIL ,SAG ,PRCP ,EDIR , & + RUNSRF ,RUNSUB ,SNEQV ,DT ,BEG_WB ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + REAL , INTENT(IN) :: SWDOWN !downward solar filtered by sun angle [w/m2] + REAL , INTENT(IN) :: FSA !total absorbed solar radiation (w/m2) + REAL , INTENT(IN) :: FSR !total reflected solar radiation (w/m2) + REAL , INTENT(IN) :: FIRA !total net longwave rad (w/m2) [+ to atm] + REAL , INTENT(IN) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: FGEV !ground evaporation heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , INTENT(IN) :: SAG + + REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) + REAL , INTENT(IN) :: EDIR !soil surface evaporation rate[mm/s] + REAL , INTENT(IN) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(IN) :: RUNSUB !baseflow (saturation excess) [mm/s] + REAL , INTENT(IN) :: SNEQV !snow water eqv. [mm] + REAL , INTENT(IN) :: DT !time step [sec] + REAL , INTENT(IN) :: BEG_WB !water storage at begin of a timesetp [mm] + + REAL :: END_WB !water storage at end of a timestep [mm] + REAL :: ERRWAT !error in water balance [mm/timestep] + REAL :: ERRENG !error in surface energy balance [w/m2] + REAL :: ERRSW !error in shortwave radiation balance [w/m2] + CHARACTER(len=256) :: message +! -------------------------------------------------------------------------------------------------- + ERRSW = SWDOWN - (FSA + FSR) + IF (ERRSW > 0.01) THEN ! w/m2 + WRITE(*,*) "SAG =",SAG + WRITE(*,*) "FSA =",FSA + WRITE(*,*) "FSR =",FSR + WRITE(message,*) 'ERRSW =',ERRSW + WRITE(*,*) "FATAL: Radiation budget problem in Noah-MP Glacier" + STOP +! call wrf_message(trim(message)) +! call wrf_error_fatal("Radiation budget problem in NOAHMP GLACIER") + END IF + + ERRENG = SAG-(FIRA+FSH+FGEV+SSOIL) + IF(ERRENG > 0.01) THEN + write(message,*) 'ERRENG =',ERRENG +! call wrf_message(trim(message)) + WRITE(message,'(i6,1x,i6,1x,5F10.4)')ILOC,JLOC,SAG,FIRA,FSH,FGEV,SSOIL + WRITE(*,*) "FATAL: Energy budget problem in Noah-MP Glacier" + STOP +! call wrf_message(trim(message)) +! call wrf_error_fatal("Energy budget problem in NOAHMP GLACIER") + END IF + + END_WB = SNEQV + ERRWAT = END_WB-BEG_WB-(PRCP-EDIR-RUNSRF-RUNSUB)*DT + +!#ifndef WRF_HYDRO +! IF(ABS(ERRWAT) > 0.1) THEN +! if (ERRWAT > 0) then +! call wrf_message ('The model is gaining water (ERRWAT is positive)') +! else +! call wrf_message('The model is losing water (ERRWAT is negative)') +! endif +! write(message, *) 'ERRWAT =',ERRWAT, "kg m{-2} timestep{-1}" +! call wrf_message(trim(message)) +! WRITE(message,'(" I J END_WB BEG_WB PRCP EDIR RUNSRF RUNSUB")') +! call wrf_message(trim(message)) +! WRITE(message,'(i6,1x,i6,1x,2f15.3,4f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,& +! EDIR*DT,RUNSRF*DT,RUNSUB*DT +! call wrf_message(trim(message)) +! call wrf_error_fatal("Water budget problem in NOAHMP GLACIER") +! END IF +!#endif + + END SUBROUTINE ERROR_GLACIER +! ================================================================================================== + + SUBROUTINE NOAHMP_OPTIONS_GLACIER(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: iopt_alb !snow surface albedo (1->BATS; 2->CLASS) + INTEGER, INTENT(IN) :: iopt_snf !rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) + INTEGER, INTENT(IN) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->Noah) + INTEGER, INTENT(IN) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original Noah) + INTEGER, INTENT(IN) :: IOPT_GLA ! glacier option (1->phase change; 2->simple) + +! ------------------------------------------------------------------------------------------------- + + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + opt_gla = iopt_gla + + end subroutine noahmp_options_glacier + +END MODULE NOAHMP_GLACIER_ROUTINES +! ================================================================================================== + +MODULE MODULE_SF_NOAHMP_GLACIER + + USE NOAHMP_GLACIER_ROUTINES + USE NOAHMP_GLACIER_GLOBALS + +END MODULE MODULE_SF_NOAHMP_GLACIER diff --git a/src/physics/lsm_noahmpdrv.f90 b/src/physics/lsm_noahmpdrv.f90 new file mode 100644 index 00000000..7daec2a1 --- /dev/null +++ b/src/physics/lsm_noahmpdrv.f90 @@ -0,0 +1,3464 @@ +MODULE module_sf_noahmpdrv + +!------------------------------- +!#if ( WRF_CHEM == 1 ) +! USE module_data_gocart_dust +!#endif +!------------------------------- + +! +CONTAINS +! + SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN,XLAT,XLONG, & ! IN : Time/Space-related + DZ8W, DT, DZS, NSOIL, DX, & ! IN : Model configuration + IVGTYP, ISLTYP, VEGFRA, VEGMAX, TMN, & ! IN : Vegetation/Soil characteristics + XLAND, XICE,XICE_THRES, CROPCAT, & ! IN : Vegetation/Soil characteristics + PLANTING, HARVEST,SEASON_GDD, & + IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & ! IN : User options + IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF,IOPT_TBOT, IOPT_STC, & ! IN : User options + IOPT_GLA, IOPT_RSF, IOPT_SOIL,IOPT_PEDO,IOPT_CROP, IOPT_IRR, & ! IN : User options + IOPT_IRRM, & ! IN : User options + IZ0TLND, SF_URBAN_PHYSICS, & ! IN : User options + SOILCOMP, SOILCL1, SOILCL2, SOILCL3, SOILCL4, & ! IN : User options + T3D, QV3D, U_PHY, V_PHY, SWDOWN, SWDDIR,& + SWDDIF, GLW, & ! IN : Forcing + P8W3D,PRECIP_IN, SR, & ! IN : Forcing + IRFRACT, SIFRACT, MIFRACT, FIFRACT, & ! IN : Noah MP only + TSK, HFX, QFX, LH, GRDFLX, SMSTAV, & ! IN/OUT LSM eqv + SMSTOT,SFCRUNOFF, UDRUNOFF, ALBEDO, SNOWC, SMOIS, & ! IN/OUT LSM eqv + SH2O, TSLB, SNOW, SNOWH, CANWAT, ACSNOM, & ! IN/OUT LSM eqv + ACSNOW, EMISS, QSFC, & ! IN/OUT LSM eqv + Z0, ZNT, & ! IN/OUT LSM eqv + IRNUMSI, IRNUMMI, IRNUMFI, IRWATSI, IRWATMI, IRWATFI, & ! IN/OUT Noah MP only + IRELOSS, IRSIVOL, IRMIVOL, IRFIVOL, IRRSPLH, LLANDUSE, & ! IN/OUT Noah MP only + ISNOWXY, TVXY, TGXY, CANICEXY, CANLIQXY, EAHXY, & ! IN/OUT Noah MP only + TAHXY, CMXY, CHXY, FWETXY, SNEQVOXY, ALBOLDXY, & ! IN/OUT Noah MP only + QSNOWXY, QRAINXY, WSLAKEXY, ZWTXY, WAXY, WTXY, TSNOXY, & ! IN/OUT Noah MP only + ZSNSOXY, SNICEXY, SNLIQXY, LFMASSXY, RTMASSXY, STMASSXY, & ! IN/OUT Noah MP only + WOODXY, STBLCPXY, FASTCPXY, XLAIXY, XSAIXY, TAUSSXY, & ! IN/OUT Noah MP only + SMOISEQ, SMCWTDXY,DEEPRECHXY, RECHXY, GRAINXY, GDDXY,PGSXY, & ! IN/OUT Noah MP only + GECROS_STATE, & ! IN/OUT gecros model + T2MVXY, T2MBXY, Q2MVXY, Q2MBXY, & ! OUT Noah MP only + TRADXY, NEEXY, GPPXY, NPPXY, FVEGXY, RUNSFXY, & ! OUT Noah MP only + RUNSBXY, ECANXY, EDIRXY, ETRANXY, FSAXY, FIRAXY, & ! OUT Noah MP only + APARXY, PSNXY, SAVXY, SAGXY, RSSUNXY, RSSHAXY, & ! OUT Noah MP only + BGAPXY, WGAPXY, TGVXY, TGBXY, CHVXY, CHBXY, & ! OUT Noah MP only + SHGXY, SHCXY, SHBXY, EVGXY, EVBXY, GHVXY, & ! OUT Noah MP only + GHBXY, IRGXY, IRCXY, IRBXY, TRXY, EVCXY, & ! OUT Noah MP only + CHLEAFXY, CHUCXY, CHV2XY, CHB2XY, RS, & ! OUT Noah MP only +! BEXP_3D,SMCDRY_3D,SMCWLT_3D,SMCREF_3D,SMCMAX_3D, & ! placeholders to activate 3D soil +! DKSAT_3D,DWSAT_3D,PSISAT_3D,QUARTZ_3D, & +! REFDK_2D,REFKDT_2D, & +! IRR_FRAC_2D,IRR_HAR_2D,IRR_LAI_2D,IRR_MAD_2D,FILOSS_2D, & +! SPRIR_RATE_2D,MICIR_RATE_2D,FIRTFAC_2D,IR_RAIN_2D, & +!#ifdef WRF_HYDRO +! sfcheadrt,INFXSRT,soldrain, & +!#endif + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + MP_RAINC, MP_RAINNC, MP_SHCV, MP_SNOW, MP_GRAUP, MP_HAIL ) +!---------------------------------------------------------------- +! USE MODULE_SF_NOAHMPLSM + USE MODULE_SF_NOAHMPLSM, only: noahmp_options, NOAHMP_SFLX, noahmp_parameters + USE module_sf_noahmp_glacier + USE NOAHMP_TABLES, ONLY: ISICE_TABLE, CO2_TABLE, O2_TABLE, DEFAULT_CROP_TABLE, ISCROP_TABLE, ISURBAN_TABLE, NATURAL_TABLE, & + LCZ_1_TABLE,LCZ_2_TABLE,LCZ_3_TABLE,LCZ_4_TABLE,LCZ_5_TABLE,LCZ_6_TABLE,LCZ_7_TABLE,LCZ_8_TABLE, & + LCZ_9_TABLE,LCZ_10_TABLE,LCZ_11_TABLE + +! USE module_sf_urban, only: IRI_SCHEME +! USE module_ra_gfdleta, only: cal_mon_day +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- + +! IN only + + INTEGER, INTENT(IN ) :: ITIMESTEP ! timestep number + INTEGER, INTENT(IN ) :: YR ! 4-digit year + REAL, INTENT(IN ) :: JULIAN ! Julian day + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: COSZIN ! cosine zenith angle + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT ! latitude [rad] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLONG ! latitude [rad] + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: DZ8W ! thickness of atmo layers [m] + REAL, INTENT(IN ) :: DT ! timestep [s] + REAL, DIMENSION(1:nsoil), INTENT(IN ) :: DZS ! thickness of soil layers [m] + INTEGER, INTENT(IN ) :: NSOIL ! number of soil layers + REAL, INTENT(IN ) :: DX ! horizontal grid spacing [m] + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: IVGTYP ! vegetation type + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ISLTYP ! soil type + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: VEGFRA ! vegetation fraction [] + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: VEGMAX ! annual max vegetation fraction [] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: TMN ! deep soil temperature [K] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAND ! =2 ocean; =1 land/seaice + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XICE ! fraction of grid that is seaice + REAL, INTENT(IN ) :: XICE_THRES! fraction of grid determining seaice + INTEGER, INTENT(IN ) :: IDVEG ! dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + INTEGER, INTENT(IN ) :: IOPT_CRS ! canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) + INTEGER, INTENT(IN ) :: IOPT_BTR ! soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) + INTEGER, INTENT(IN ) :: IOPT_RUN ! runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) + INTEGER, INTENT(IN ) :: IOPT_SFC ! surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97) + INTEGER, INTENT(IN ) :: IOPT_FRZ ! supercooled liquid water (1-> NY06; 2->Koren99) + INTEGER, INTENT(IN ) :: IOPT_INF ! frozen soil permeability (1-> NY06; 2->Koren99) + INTEGER, INTENT(IN ) :: IOPT_RAD ! radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg) + INTEGER, INTENT(IN ) :: IOPT_ALB ! snow surface albedo (1->BATS; 2->CLASS) + INTEGER, INTENT(IN ) :: IOPT_SNF ! rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) + INTEGER, INTENT(IN ) :: IOPT_TBOT ! lower boundary of soil temperature (1->zero-flux; 2->Noah) + INTEGER, INTENT(IN ) :: IOPT_STC ! snow/soil temperature time scheme + INTEGER, INTENT(IN ) :: IOPT_GLA ! glacier option (1->phase change; 2->simple) + INTEGER, INTENT(IN ) :: IOPT_RSF ! surface resistance (1->Sakaguchi/Zeng; 2->Seller; 3->mod Sellers; 4->1+snow) + INTEGER, INTENT(IN ) :: IOPT_SOIL ! soil configuration option + INTEGER, INTENT(IN ) :: IOPT_PEDO ! soil pedotransfer function option + INTEGER, INTENT(IN ) :: IOPT_CROP ! crop model option (0->none; 1->Liu et al.; 2->Gecros) + INTEGER, INTENT(IN ) :: IOPT_IRR ! irrigation scheme (0->none; >1 irrigation scheme ON) + INTEGER, INTENT(IN ) :: IOPT_IRRM ! irrigation method + INTEGER, INTENT(IN ) :: IZ0TLND ! option of Chen adjustment of Czil (not used) + INTEGER, INTENT(IN ) :: sf_urban_physics ! urban physics option + REAL, DIMENSION( ims:ime, 8, jms:jme ), INTENT(IN ) :: SOILCOMP ! soil sand and clay percentage + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SOILCL1 ! soil texture in layer 1 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SOILCL2 ! soil texture in layer 2 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SOILCL3 ! soil texture in layer 3 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SOILCL4 ! soil texture in layer 4 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: T3D ! 3D atmospheric temperature valid at mid-levels [K] + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: QV3D ! 3D water vapor mixing ratio [kg/kg_dry] + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: U_PHY ! 3D U wind component [m/s] + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: V_PHY ! 3D V wind component [m/s] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SWDOWN ! solar down at surface [W m-2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SWDDIF ! solar down at surface [W m-2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SWDDIR ! solar down at surface [W m-2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: GLW ! longwave down at surface [W m-2] + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: P8W3D ! 3D pressure, valid at interface [Pa] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: PRECIP_IN ! total input precipitation [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SR ! frozen precipitation ratio [-] + +!Optional Detailed Precipitation Partitioning Inputs + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_RAINC ! convective precipitation entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_RAINNC ! large-scale precipitation entering land model [mm]! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_SHCV ! shallow conv precip entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_SNOW ! snow precipitation entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_GRAUP ! graupel precipitation entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_HAIL ! hail precipitation entering land model [mm] ! MB/AN : v3.7 + +! Crop Model + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: CROPCAT ! crop catagory + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: PLANTING ! planting date + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: HARVEST ! harvest date + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SEASON_GDD! growing season GDD + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: GRAINXY ! mass of grain XING [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: GDDXY ! growing degree days XING (based on 10C) + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: PGSXY + +! gecros model + REAL, DIMENSION( ims:ime, 60,jms:jme ), INTENT(INOUT) :: gecros_state ! gecros crop + +!#ifdef WRF_HYDRO +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain ! for WRF-Hydro +!#endif +! placeholders for 3D soil +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: BEXP_3D ! C-H B exponent +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCDRY_3D ! Soil Moisture Limit: Dry +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCWLT_3D ! Soil Moisture Limit: Wilt +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCREF_3D ! Soil Moisture Limit: Reference +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCMAX_3D ! Soil Moisture Limit: Max +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: DKSAT_3D ! Saturated Soil Conductivity +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: DWSAT_3D ! Saturated Soil Diffusivity +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: PSISAT_3D ! Saturated Matric Potential +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: QUARTZ_3D ! Soil quartz content +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: REFDK_2D ! Reference Soil Conductivity +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: REFKDT_2D ! Soil Infiltration Parameter + +! placeholders for 2D irrigation parameters +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IRR_FRAC_2D ! irrigation Fraction +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IRR_HAR_2D ! number of days before harvest date to stop irrigation +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IRR_LAI_2D ! Minimum lai to trigger irrigation +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IRR_MAD_2D ! management allowable deficit (0-1) +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FILOSS_2D ! fraction of flood irrigation loss (0-1) +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: SPRIR_RATE_2D ! mm/h, sprinkler irrigation rate +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: MICIR_RATE_2D ! mm/h, micro irrigation rate +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FIRTFAC_2D ! flood application rate factor +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IR_RAIN_2D ! maximum precipitation to stop irrigation trigger + +! INOUT (with generic LSM equivalent) + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TSK ! surface radiative temperature [K] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: HFX ! sensible heat flux [W m-2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QFX ! latent heat flux [kg s-1 m-2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH ! latent heat flux [W m-2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: GRDFLX ! ground/snow heat flux [W m-2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SMSTAV ! soil moisture avail. [not used] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SMSTOT ! total soil water [mm][not used] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFCRUNOFF ! accumulated surface runoff [m] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UDRUNOFF ! accumulated sub-surface runoff [m] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ALBEDO ! total grid albedo [] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SNOWC ! snow cover fraction [] + REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(INOUT) :: SMOIS ! volumetric soil moisture [m3/m3] + REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(INOUT) :: SH2O ! volumetric liquid soil moisture [m3/m3] + REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(INOUT) :: TSLB ! soil temperature [K] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SNOW ! snow water equivalent [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SNOWH ! physical snow depth [m] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CANWAT ! total canopy water + ice [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ACSNOM ! accumulated snow melt leaving pack + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ACSNOW ! accumulated snow on grid + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: EMISS ! surface bulk emissivity + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QSFC ! bulk surface specific humidity + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: Z0 ! combined z0 sent to coupled model + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZNT ! combined z0 sent to coupled model + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RS ! Total stomatal resistance (s/m) + + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ISNOWXY ! actual no. of snow layers + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TVXY ! vegetation leaf temperature + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGXY ! bulk ground surface temperature + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CANICEXY ! canopy-intercepted ice (mm) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CANLIQXY ! canopy-intercepted liquid water (mm) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: EAHXY ! canopy air vapor pressure (pa) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TAHXY ! canopy air temperature (k) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMXY ! bulk momentum drag coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHXY ! bulk sensible heat exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FWETXY ! wetted or snowed fraction of the canopy (-) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SNEQVOXY ! snow mass at last time step(mm h2o) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ALBOLDXY ! snow albedo at last time step (-) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QSNOWXY ! snowfall on the ground [mm/s] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QRAINXY ! rainfall on the ground [mm/s] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: WSLAKEXY ! lake water storage [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZWTXY ! water table depth [m] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: WAXY ! water in the "aquifer" [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: WTXY ! groundwater storage [mm] + REAL, DIMENSION( ims:ime,-2:0, jms:jme ), INTENT(INOUT) :: TSNOXY ! snow temperature [K] + REAL, DIMENSION( ims:ime,-2:NSOIL, jms:jme ), INTENT(INOUT) :: ZSNSOXY ! snow layer depth [m] + REAL, DIMENSION( ims:ime,-2:0, jms:jme ), INTENT(INOUT) :: SNICEXY ! snow layer ice [mm] + REAL, DIMENSION( ims:ime,-2:0, jms:jme ), INTENT(INOUT) :: SNLIQXY ! snow layer liquid water [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFMASSXY ! leaf mass [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RTMASSXY ! mass of fine roots [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: STMASSXY ! stem mass [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: WOODXY ! mass of wood (incl. woody roots) [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: STBLCPXY ! stable carbon in deep soil [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FASTCPXY ! short-lived carbon, shallow soil [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XLAIXY ! leaf area index + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XSAIXY ! stem area index + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TAUSSXY ! snow age factor + REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(INOUT) :: SMOISEQ ! eq volumetric soil moisture [m3/m3] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SMCWTDXY ! soil moisture content in the layer to the water table when deep + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DEEPRECHXY ! recharge to the water table when deep + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RECHXY ! recharge to the water table (diagnostic) + +! OUT (with no Noah LSM equivalent) + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: T2MVXY ! 2m temperature of vegetation part + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: T2MBXY ! 2m temperature of bare ground part + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: Q2MVXY ! 2m mixing ratio of vegetation part + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: Q2MBXY ! 2m mixing ratio of bare ground part + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: TRADXY ! surface radiative temperature (k) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: NEEXY ! net ecosys exchange (g/m2/s CO2) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: GPPXY ! gross primary assimilation [g/m2/s C] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: NPPXY ! net primary productivity [g/m2/s C] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: FVEGXY ! Noah-MP vegetation fraction [-] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: RUNSFXY ! surface runoff [mm/s] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: RUNSBXY ! subsurface runoff [mm/s] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: ECANXY ! evaporation of intercepted water (mm/s) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: EDIRXY ! soil surface evaporation rate (mm/s] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: ETRANXY ! transpiration rate (mm/s) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: FSAXY ! total absorbed solar radiation (w/m2) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: FIRAXY ! total net longwave rad (w/m2) [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: APARXY ! photosyn active energy by canopy (w/m2) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: PSNXY ! total photosynthesis (umol co2/m2/s) [+] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: SAVXY ! solar rad absorbed by veg. (w/m2) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: SAGXY ! solar rad absorbed by ground (w/m2) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: RSSUNXY ! sunlit leaf stomatal resistance (s/m) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: RSSHAXY ! shaded leaf stomatal resistance (s/m) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: BGAPXY ! between gap fraction + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: WGAPXY ! within gap fraction + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: TGVXY ! under canopy ground temperature[K] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: TGBXY ! bare ground temperature [K] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHVXY ! sensible heat exchange coefficient vegetated + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHBXY ! sensible heat exchange coefficient bare-ground + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: SHGXY ! veg ground sen. heat [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: SHCXY ! canopy sen. heat [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: SHBXY ! bare sensible heat [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: EVGXY ! veg ground evap. heat [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: EVBXY ! bare soil evaporation [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: GHVXY ! veg ground heat flux [w/m2] [+ to soil] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: GHBXY ! bare ground heat flux [w/m2] [+ to soil] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: IRGXY ! veg ground net LW rad. [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: IRCXY ! canopy net LW rad. [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: IRBXY ! bare net longwave rad. [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: TRXY ! transpiration [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: EVCXY ! canopy evaporation heat [w/m2] [+ to atm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHLEAFXY ! leaf exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHUCXY ! under canopy exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHV2XY ! veg 2m exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHB2XY ! bare 2m exchange coefficient + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ! d -> domain + & ims,ime, jms,jme, kms,kme, & ! m -> memory + & its,ite, jts,jte, kts,kte ! t -> tile + +!2D inout irrigation variables + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IRFRACT ! irrigation fraction + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: SIFRACT ! sprinkler irrigation fraction + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: MIFRACT ! micro irrigation fraction + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FIFRACT ! flood irrigation fraction + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRNUMSI ! irrigation event number, Sprinkler + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRNUMMI ! irrigation event number, Micro + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRNUMFI ! irrigation event number, Flood + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRWATSI ! irrigation water amount [m] to be applied, Sprinkler + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRWATMI ! irrigation water amount [m] to be applied, Micro + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRWATFI ! irrigation water amount [m] to be applied, Flood + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRELOSS ! loss of irrigation water to evaporation,sprinkler [m/timestep] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRSIVOL ! amount of irrigation by sprinkler (mm) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRMIVOL ! amount of irrigation by micro (mm) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRFIVOL ! amount of irrigation by micro (mm) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IRRSPLH ! latent heating from sprinkler evaporation (w/m2) + CHARACTER(LEN=256), INTENT(IN) :: LLANDUSE ! landuse data name (USGS or MODIS_IGBP) + +!ID local irrigation variables + REAL :: IRRFRA ! irrigation fraction + REAL :: SIFAC ! sprinkler irrigation fraction + REAL :: MIFAC ! micro irrigation fraction + REAL :: FIFAC ! flood irrigation fraction + INTEGER :: IRCNTSI ! irrigation event number, Sprinkler + INTEGER :: IRCNTMI ! irrigation event number, Micro + INTEGER :: IRCNTFI ! irrigation event number, Flood + REAL :: IRAMTSI ! irrigation water amount [m] to be applied, Sprinkler + REAL :: IRAMTMI ! irrigation water amount [m] to be applied, Micro + REAL :: IRAMTFI ! irrigation water amount [m] to be applied, Flood + REAL :: IREVPLOS ! loss of irrigation water to evaporation,sprinkler [m/timestep] + REAL :: IRSIRATE ! rate of irrigation by sprinkler [m/timestep] + REAL :: IRMIRATE ! rate of irrigation by micro [m/timestep] + REAL :: IRFIRATE ! rate of irrigation by micro [m/timestep] + REAL :: FIRR ! latent heating due to sprinkler evaporation (w m-2) + REAL :: EIRR ! evaporation due to sprinkler evaporation (mm/s) + +! 1D equivalent of 2D/3D fields + +! IN only + + REAL :: COSZ ! cosine zenith angle + REAL :: LAT ! latitude [rad] + REAL :: Z_ML ! model height [m] + INTEGER :: VEGTYP ! vegetation type + INTEGER, DIMENSION(NSOIL) :: SOILTYP ! soil type + INTEGER :: CROPTYPE ! crop type + REAL :: FVEG ! vegetation fraction [-] + REAL :: FVGMAX ! annual max vegetation fraction [] + REAL :: TBOT ! deep soil temperature [K] + REAL :: T_ML ! temperature valid at mid-levels [K] + REAL :: Q_ML ! water vapor mixing ratio [kg/kg_dry] + REAL :: U_ML ! U wind component [m/s] + REAL :: V_ML ! V wind component [m/s] + REAL :: SWDN ! solar down at surface [W m-2] + REAL :: LWDN ! longwave down at surface [W m-2] + REAL :: P_ML ! pressure, valid at interface [Pa] + REAL :: PSFC ! surface pressure [Pa] + REAL :: PRCP ! total precipitation entering [mm] ! MB/AN : v3.7 + REAL :: PRCPCONV ! convective precipitation entering [mm] ! MB/AN : v3.7 + REAL :: PRCPNONC ! non-convective precipitation entering [mm] ! MB/AN : v3.7 + REAL :: PRCPSHCV ! shallow convective precip entering [mm] ! MB/AN : v3.7 + REAL :: PRCPSNOW ! snow entering land model [mm] ! MB/AN : v3.7 + REAL :: PRCPGRPL ! graupel entering land model [mm] ! MB/AN : v3.7 + REAL :: PRCPHAIL ! hail entering land model [mm] ! MB/AN : v3.7 + REAL :: PRCPOTHR ! other precip, e.g. fog [mm] ! MB/AN : v3.7 + +! INOUT (with generic LSM equivalent) + + REAL :: FSH ! total sensible heat (w/m2) [+ to atm] + REAL :: SSOIL ! soil heat heat (w/m2) + REAL :: SALB ! surface albedo (-) + REAL :: FSNO ! snow cover fraction (-) + REAL, DIMENSION( 1:NSOIL) :: SMCEQ ! eq vol. soil moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL) :: SMC ! vol. soil moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL) :: SMH2O ! vol. soil liquid water (m3/m3) + REAL, DIMENSION(-2:NSOIL) :: STC ! snow/soil tmperatures + REAL :: SWE ! snow water equivalent (mm) + REAL :: SNDPTH ! snow depth (m) + REAL :: EMISSI ! net surface emissivity + REAL :: QSFC1D ! bulk surface specific humidity + +! INOUT (with no Noah LSM equivalent) + + INTEGER :: ISNOW ! actual no. of snow layers + REAL :: TV ! vegetation canopy temperature + REAL :: TG ! ground surface temperature + REAL :: CANICE ! canopy-intercepted ice (mm) + REAL :: CANLIQ ! canopy-intercepted liquid water (mm) + REAL :: EAH ! canopy air vapor pressure (pa) + REAL :: TAH ! canopy air temperature (k) + REAL :: CM ! momentum drag coefficient + REAL :: CH ! sensible heat exchange coefficient + REAL :: FWET ! wetted or snowed fraction of the canopy (-) + REAL :: SNEQVO ! snow mass at last time step(mm h2o) + REAL :: ALBOLD ! snow albedo at last time step (-) + REAL :: QSNOW ! snowfall on the ground [mm/s] + REAL :: QRAIN ! rainfall on the ground [mm/s] + REAL :: WSLAKE ! lake water storage [mm] + REAL :: ZWT ! water table depth [m] + REAL :: WA ! water in the "aquifer" [mm] + REAL :: WT ! groundwater storage [mm] + REAL :: SMCWTD ! soil moisture content in the layer to the water table when deep + REAL :: DEEPRECH ! recharge to the water table when deep + REAL :: RECH ! recharge to the water table (diagnostic) + REAL, DIMENSION(-2:NSOIL) :: ZSNSO ! snow layer depth [m] + REAL, DIMENSION(-2: 0) :: SNICE ! snow layer ice [mm] + REAL, DIMENSION(-2: 0) :: SNLIQ ! snow layer liquid water [mm] + REAL :: LFMASS ! leaf mass [g/m2] + REAL :: RTMASS ! mass of fine roots [g/m2] + REAL :: STMASS ! stem mass [g/m2] + REAL :: WOOD ! mass of wood (incl. woody roots) [g/m2] + REAL :: GRAIN ! mass of grain XING [g/m2] + REAL :: GDD ! mass of grain XING[g/m2] + INTEGER :: PGS !stem respiration [g/m2/s] + REAL :: STBLCP ! stable carbon in deep soil [g/m2] + REAL :: FASTCP ! short-lived carbon, shallow soil [g/m2] + REAL :: PLAI ! leaf area index + REAL :: PSAI ! stem area index + REAL :: TAUSS ! non-dimensional snow age + +! OUT (with no Noah LSM equivalent) + + REAL :: Z0WRF ! combined z0 sent to coupled model + REAL :: T2MV ! 2m temperature of vegetation part + REAL :: T2MB ! 2m temperature of bare ground part + REAL :: Q2MV ! 2m mixing ratio of vegetation part + REAL :: Q2MB ! 2m mixing ratio of bare ground part + REAL :: TRAD ! surface radiative temperature (k) + REAL :: NEE ! net ecosys exchange (g/m2/s CO2) + REAL :: GPP ! gross primary assimilation [g/m2/s C] + REAL :: NPP ! net primary productivity [g/m2/s C] + REAL :: FVEGMP ! greenness vegetation fraction [-] + REAL :: RUNSF ! surface runoff [mm/s] + REAL :: RUNSB ! subsurface runoff [mm/s] + REAL :: ECAN ! evaporation of intercepted water (mm/s) + REAL :: ETRAN ! transpiration rate (mm/s) + REAL :: ESOIL ! soil surface evaporation rate (mm/s] + REAL :: FSA ! total absorbed solar radiation (w/m2) + REAL :: FIRA ! total net longwave rad (w/m2) [+ to atm] + REAL :: APAR ! photosyn active energy by canopy (w/m2) + REAL :: PSN ! total photosynthesis (umol co2/m2/s) [+] + REAL :: SAV ! solar rad absorbed by veg. (w/m2) + REAL :: SAG ! solar rad absorbed by ground (w/m2) + REAL :: RSSUN ! sunlit leaf stomatal resistance (s/m) + REAL :: RSSHA ! shaded leaf stomatal resistance (s/m) + REAL, DIMENSION(1:2) :: ALBSND ! snow albedo (direct) + REAL, DIMENSION(1:2) :: ALBSNI ! snow albedo (diffuse) + REAL :: RB ! leaf boundary layer resistance (s/m) + REAL :: LAISUN ! sunlit leaf area index (m2/m2) + REAL :: LAISHA ! shaded leaf area index (m2/m2) + REAL :: BGAP ! between gap fraction + REAL :: WGAP ! within gap fraction + REAL :: TGV ! under canopy ground temperature[K] + REAL :: TGB ! bare ground temperature [K] + REAL :: CHV ! sensible heat exchange coefficient vegetated + REAL :: CHB ! sensible heat exchange coefficient bare-ground + REAL :: IRC ! canopy net LW rad. [w/m2] [+ to atm] + REAL :: IRG ! veg ground net LW rad. [w/m2] [+ to atm] + REAL :: SHC ! canopy sen. heat [w/m2] [+ to atm] + REAL :: SHG ! veg ground sen. heat [w/m2] [+ to atm] + REAL :: EVG ! veg ground evap. heat [w/m2] [+ to atm] + REAL :: GHV ! veg ground heat flux [w/m2] [+ to soil] + REAL :: IRB ! bare net longwave rad. [w/m2] [+ to atm] + REAL :: SHB ! bare sensible heat [w/m2] [+ to atm] + REAL :: EVB ! bare evaporation heat [w/m2] [+ to atm] + REAL :: GHB ! bare ground heat flux [w/m2] [+ to soil] + REAL :: TR ! transpiration [w/m2] [+ to atm] + REAL :: EVC ! canopy evaporation heat [w/m2] [+ to atm] + REAL :: CHLEAF ! leaf exchange coefficient + REAL :: CHUC ! under canopy exchange coefficient + REAL :: CHV2 ! veg 2m exchange coefficient + REAL :: CHB2 ! bare 2m exchange coefficient + REAL :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL :: PAHB !precipitation advected heat - bare ground net (W/m2) + REAL :: PAH !precipitation advected heat - total (W/m2) + +! Intermediate terms + + REAL :: FPICE ! snow fraction of precip + REAL :: FCEV ! canopy evaporation heat (w/m2) [+ to atm] + REAL :: FGEV ! ground evaporation heat (w/m2) [+ to atm] + REAL :: FCTR ! transpiration heat flux (w/m2) [+ to atm] + REAL :: QSNBOT ! snowmelt out bottom of pack [mm/s] + REAL :: PONDING ! snowmelt with no pack [mm] + REAL :: PONDING1 ! snowmelt with no pack [mm] + REAL :: PONDING2 ! snowmelt with no pack [mm] + +! Local terms + + REAL, DIMENSION(1:60) :: gecros1d ! gecros crop + REAL :: gecros_dd ,gecros_tbem,gecros_emb ,gecros_ema, & + gecros_ds1,gecros_ds2 ,gecros_ds1x,gecros_ds2x + + REAL :: FSR ! total reflected solar radiation (w/m2) + REAL, DIMENSION(-2:0) :: FICEOLD ! snow layer ice fraction [] + REAL :: CO2PP ! CO2 partial pressure [Pa] + REAL :: O2PP ! O2 partial pressure [Pa] + REAL, DIMENSION(1:NSOIL) :: ZSOIL ! depth to soil interfaces [m] + REAL :: FOLN ! nitrogen saturation [%] + + REAL :: QC ! cloud specific humidity for MYJ [not used] + REAL :: PBLH ! PBL height for MYJ [not used] + REAL :: DZ8W1D ! model level heights for MYJ [not used] + + INTEGER :: I + INTEGER :: J + INTEGER :: K + INTEGER :: ICE + INTEGER :: SLOPETYP + LOGICAL :: IPRINT + + INTEGER :: SOILCOLOR ! soil color index + INTEGER :: IST ! surface type 1-soil; 2-lake + INTEGER :: YEARLEN + REAL :: SOLAR_TIME + INTEGER :: JMONTH, JDAY + + INTEGER, PARAMETER :: NSNOW = 3 ! number of snow layers fixed to 3 + REAL, PARAMETER :: undefined_value = -1.E36 + + REAL, DIMENSION( 1:nsoil ) :: SAND + REAL, DIMENSION( 1:nsoil ) :: CLAY + REAL, DIMENSION( 1:nsoil ) :: ORGM + + type(noahmp_parameters) :: parameters + + +! ---------------------------------------------------------------------- + + CALL NOAHMP_OPTIONS(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & + IOPT_INF ,IOPT_RAD ,IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC , & + IOPT_RSF ,IOPT_SOIL ,IOPT_PEDO ,IOPT_CROP ,IOPT_IRR ,IOPT_IRRM) + + IPRINT = .false. ! debug printout + + YEARLEN = 365 ! find length of year for phenology (also S Hemisphere) + if (mod(YR,4) == 0) then + YEARLEN = 366 + if (mod(YR,100) == 0) then + YEARLEN = 365 + if (mod(YR,400) == 0) then + YEARLEN = 366 + endif + endif + endif + + ZSOIL(1) = -DZS(1) ! depth to soil interfaces (<0) [m] + DO K = 2, NSOIL + ZSOIL(K) = -DZS(K) + ZSOIL(K-1) + END DO + + JLOOP : DO J=jts,jte + + IF(ITIMESTEP == 1)THEN + DO I=its,ite + ! IF((XLAND(I,J)-1.5) >= 0.) THEN ! Open water case + IF( ((XLAND(I,J)-1.5) >= 0.) .OR. & ! skip if XLAND = 2 + ((XLAND(I,J)-0.5) < 0.) & ! skip if XLAND = 0 + ) THEN + IF(XICE(I,J) == 1. .AND. IPRINT) PRINT *,' sea-ice at water point, I=',I,'J=',J + SMSTAV(I,J) = 1.0 + SMSTOT(I,J) = 1.0 + DO K = 1, NSOIL + SMOIS(I,K,J) = 1.0 + TSLB(I,K,J) = 273.16 + ENDDO + ELSE + IF(XICE(I,J) == 1.) THEN ! Sea-ice case + SMSTAV(I,J) = 1.0 + SMSTOT(I,J) = 1.0 + DO K = 1, NSOIL + SMOIS(I,K,J) = 1.0 + ENDDO + ENDIF + ENDIF + ENDDO + ENDIF ! end of initialization over ocean + + +!----------------------------------------------------------------------- + ILOOP : DO I = its, ite + + IF (XICE(I,J) >= XICE_THRES) THEN + ICE = 1 ! Sea-ice point + + SH2O (i,1:NSOIL,j) = 1.0 + XLAIXY(i,j) = 0.01 + + CYCLE ILOOP ! Skip any processing at sea-ice points + + ELSE + + ! IF((XLAND(I,J)-1.5) >= 0.) CYCLE ILOOP ! Open water case (BK: should also skip in the case landmask =0, which this doesnt) + IF( ((XLAND(I,J)-1.5) >= 0.) .OR. & ! skip if XLAND = 2 + ((XLAND(I,J)-0.5) < 0.) & ! skip if XLAND = 0 + ) THEN + CYCLE ILOOP ! Open water case + ENDIF + +! 2D to 1D + +! IN only + + COSZ = COSZIN (I,J) ! cos zenith angle [] + LAT = XLAT (I,J) ! latitude [rad] + Z_ML = 0.5*DZ8W(I,1,J) ! DZ8W: thickness of full levels; ZLVL forcing height [m] + VEGTYP = IVGTYP(I,J) ! vegetation type + if(iopt_soil == 1) then + SOILTYP= ISLTYP(I,J) ! soil type same in all layers + elseif(iopt_soil == 2) then + SOILTYP(1) = nint(SOILCL1(I,J)) ! soil type in layer1 + SOILTYP(2) = nint(SOILCL2(I,J)) ! soil type in layer2 + SOILTYP(3) = nint(SOILCL3(I,J)) ! soil type in layer3 + SOILTYP(4) = nint(SOILCL4(I,J)) ! soil type in layer4 + elseif(iopt_soil == 3) then + SOILTYP= ISLTYP(I,J) ! to initialize with default + end if + FVEG = VEGFRA(I,J)/100. ! vegetation fraction [0-1] + FVGMAX = VEGMAX (I,J)/100. ! Vegetation fraction annual max [0-1] + TBOT = TMN(I,J) ! Fixed deep soil temperature for land + T_ML = T3D(I,1,J) ! temperature defined at intermediate level [K] + Q_ML = QV3D(I,1,J)/(1.0+QV3D(I,1,J)) ! convert from mixing ratio to specific humidity [kg/kg] + U_ML = U_PHY(I,1,J) ! u-wind at interface [m/s] + V_ML = V_PHY(I,1,J) ! v-wind at interface [m/s] + SWDN = SWDOWN(I,J) ! shortwave down from SW scheme [W/m2] + LWDN = GLW(I,J) ! total longwave down from LW scheme [W/m2] + P_ML =(P8W3D(I,KTS+1,J)+P8W3D(I,KTS,J))*0.5 ! surface pressure defined at intermediate level [Pa] + ! consistent with temperature, mixing ratio + PSFC = P8W3D(I,1,J) ! surface pressure defined a full levels [Pa] + PRCP = PRECIP_IN (I,J) / DT ! timestep total precip rate (glacier) [mm/s]! MB: v3.7 + + CROPTYPE = 0 + IF (IOPT_CROP > 0 .AND. VEGTYP == ISCROP_TABLE) CROPTYPE = DEFAULT_CROP_TABLE ! default croptype is generic dynamic vegetation crop + IF (IOPT_CROP > 0 .AND. CROPCAT(I,J) > 0) THEN + CROPTYPE = CROPCAT(I,J) ! crop type + VEGTYP = ISCROP_TABLE + FVGMAX = 0.95 + FVEG = 0.95 + END IF + + IF (PRESENT(MP_RAINC) .AND. PRESENT(MP_RAINNC) .AND. PRESENT(MP_SHCV) .AND. & + PRESENT(MP_SNOW) .AND. PRESENT(MP_GRAUP) .AND. PRESENT(MP_HAIL) ) THEN + + PRCPCONV = MP_RAINC (I,J)/DT ! timestep convective precip rate [mm/s] ! MB: v3.7 + PRCPNONC = MP_RAINNC(I,J)/DT ! timestep non-convective precip rate [mm/s] ! MB: v3.7 + PRCPSHCV = MP_SHCV(I,J) /DT ! timestep shallow conv precip rate [mm/s] ! MB: v3.7 + PRCPSNOW = MP_SNOW(I,J) /DT ! timestep snow precip rate [mm/s] ! MB: v3.7 + PRCPGRPL = MP_GRAUP(I,J) /DT ! timestep graupel precip rate [mm/s] ! MB: v3.7 + PRCPHAIL = MP_HAIL(I,J) /DT ! timestep hail precip rate [mm/s] ! MB: v3.7 + + PRCPOTHR = PRCP - PRCPCONV - PRCPNONC - PRCPSHCV ! take care of other (fog) contained in rainbl + PRCPOTHR = MAX(0.0,PRCPOTHR) + PRCPNONC = PRCPNONC + PRCPOTHR + PRCPSNOW = PRCPSNOW + SR(I,J) * PRCPOTHR + ELSE + PRCPCONV = 0. + PRCPNONC = PRCP + PRCPSHCV = 0. + PRCPSNOW = SR(I,J) * PRCP + PRCPGRPL = 0. + PRCPHAIL = 0. + ENDIF + +! IN/OUT fields + + ISNOW = ISNOWXY (I,J) ! snow layers [] + SMC ( 1:NSOIL) = SMOIS (I, 1:NSOIL,J) ! soil total moisture [m3/m3] + SMH2O( 1:NSOIL) = SH2O (I, 1:NSOIL,J) ! soil liquid moisture [m3/m3] + STC (-NSNOW+1: 0) = TSNOXY (I,-NSNOW+1: 0,J) ! snow temperatures [K] + STC ( 1:NSOIL) = TSLB (I, 1:NSOIL,J) ! soil temperatures [K] + SWE = SNOW (I,J) ! snow water equivalent [mm] + SNDPTH = SNOWH (I,J) ! snow depth [m] + QSFC1D = QSFC (I,J) + +! INOUT (with no Noah LSM equivalent) + + TV = TVXY (I,J) ! leaf temperature [K] + TG = TGXY (I,J) ! ground temperature [K] + CANLIQ = CANLIQXY(I,J) ! canopy liquid water [mm] + CANICE = CANICEXY(I,J) ! canopy frozen water [mm] + EAH = EAHXY (I,J) ! canopy vapor pressure [Pa] + TAH = TAHXY (I,J) ! canopy temperature [K] + CM = CMXY (I,J) ! avg. momentum exchange (MP only) [m/s] + CH = CHXY (I,J) ! avg. heat exchange (MP only) [m/s] + FWET = FWETXY (I,J) ! canopy fraction wet or snow + SNEQVO = SNEQVOXY(I,J) ! SWE previous timestep + ALBOLD = ALBOLDXY(I,J) ! albedo previous timestep, for snow aging + QSNOW = QSNOWXY (I,J) ! snow falling on ground + QRAIN = QRAINXY (I,J) ! rain falling on ground + WSLAKE = WSLAKEXY(I,J) ! lake water storage (can be neg.) (mm) + ZWT = ZWTXY (I,J) ! depth to water table [m] + WA = WAXY (I,J) ! water storage in aquifer [mm] + WT = WTXY (I,J) ! water in aquifer&saturated soil [mm] + ZSNSO(-NSNOW+1:NSOIL) = ZSNSOXY (I,-NSNOW+1:NSOIL,J) ! depth to layer interface + SNICE(-NSNOW+1: 0) = SNICEXY (I,-NSNOW+1: 0,J) ! snow layer ice content + SNLIQ(-NSNOW+1: 0) = SNLIQXY (I,-NSNOW+1: 0,J) ! snow layer water content + LFMASS = LFMASSXY(I,J) ! leaf mass + RTMASS = RTMASSXY(I,J) ! root mass + STMASS = STMASSXY(I,J) ! stem mass + WOOD = WOODXY (I,J) ! mass of wood (incl. woody roots) [g/m2] + STBLCP = STBLCPXY(I,J) ! stable carbon pool + FASTCP = FASTCPXY(I,J) ! fast carbon pool + PLAI = XLAIXY (I,J) ! leaf area index [-] (no snow effects) + PSAI = XSAIXY (I,J) ! stem area index [-] (no snow effects) + TAUSS = TAUSSXY (I,J) ! non-dimensional snow age + SMCEQ( 1:NSOIL) = SMOISEQ (I, 1:NSOIL,J) + SMCWTD = SMCWTDXY(I,J) + RECH = 0. + DEEPRECH = 0. + +! irrigation vars + IRRFRA = IRFRACT(I,J) ! irrigation fraction + SIFAC = SIFRACT(I,J) ! sprinkler irrigation fraction + MIFAC = MIFRACT(I,J) ! micro irrigation fraction + FIFAC = FIFRACT(I,J) ! flood irrigation fraction + IRCNTSI = IRNUMSI(I,J) ! irrigation event number, Sprinkler + IRCNTMI = IRNUMMI(I,J) ! irrigation event number, Micro + IRCNTFI = IRNUMFI(I,J) ! irrigation event number, Flood + IRAMTSI = IRWATSI(I,J) ! irrigation water amount [m] to be applied, Sprinkler + IRAMTMI = IRWATMI(I,J) ! irrigation water amount [m] to be applied, Micro + IRAMTFI = IRWATFI(I,J) ! irrigation water amount [m] to be applied, Flood + IREVPLOS = 0.0 ! loss of irrigation water to evaporation,sprinkler [m/timestep] + IRSIRATE = 0.0 ! rate of irrigation by sprinkler (mm) + IRMIRATE = 0.0 ! rate of irrigation by micro (mm) + IRFIRATE = 0.0 ! rate of irrigation by micro (mm) + FIRR = 0.0 ! latent heating due to sprinkler evaporation (W m-2) + EIRR = 0.0 ! evaporation from sprinkler (mm/s) + + if(iopt_crop == 2) then ! gecros crop model + + gecros1d(1:60) = gecros_state(I,1:60,J) ! Gecros variables 2D -> local + + if(croptype == 1) then + gecros_dd = 2.5 + gecros_tbem = 2.0 + gecros_emb = 10.2 + gecros_ema = 40.0 + gecros_ds1 = 2.1 !BBCH 92 + gecros_ds2 = 2.0 !BBCH 90 + gecros_ds1x = 0.0 + gecros_ds2x = 10.0 + end if + + if(croptype == 2) then + gecros_dd = 5.0 + gecros_tbem = 8.0 + gecros_emb = 15.0 + gecros_ema = 6.0 + gecros_ds1 = 1.78 !BBCH 85 + gecros_ds2 = 1.63 !BBCH 80 + gecros_ds1x = 0.0 + gecros_ds2x = 14.0 + end if + + end if + + SLOPETYP = 1 ! set underground runoff slope term + IST = 1 ! MP surface type: 1 = land; 2 = lake + SOILCOLOR = 4 ! soil color: assuming a middle color category ????????? + + IF(any(SOILTYP == 14) .AND. XICE(I,J) == 0.) THEN + IF(IPRINT) PRINT *, ' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' + IF(IPRINT) PRINT *, i,j,'RESET SOIL in surfce.F' + SOILTYP = 7 + ENDIF + IF( IVGTYP(I,J) == ISURBAN_TABLE .or. IVGTYP(I,J) == LCZ_1_TABLE .or. IVGTYP(I,J) == LCZ_2_TABLE .or. & + IVGTYP(I,J) == LCZ_3_TABLE .or. IVGTYP(I,J) == LCZ_4_TABLE .or. IVGTYP(I,J) == LCZ_5_TABLE .or. & + IVGTYP(I,J) == LCZ_6_TABLE .or. IVGTYP(I,J) == LCZ_7_TABLE .or. IVGTYP(I,J) == LCZ_8_TABLE .or. & + IVGTYP(I,J) == LCZ_9_TABLE .or. IVGTYP(I,J) == LCZ_10_TABLE .or. IVGTYP(I,J) == LCZ_11_TABLE ) THEN + + + IF(SF_URBAN_PHYSICS == 0 ) THEN + VEGTYP = ISURBAN_TABLE + ELSE + VEGTYP = NATURAL_TABLE ! set urban vegetation type based on table natural + FVGMAX = 0.96 + ENDIF + + ENDIF + +! placeholders for 3D soil +! parameters%bexp = BEXP_3D (I,1:NSOIL,J) ! C-H B exponent +! parameters%smcdry = SMCDRY_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Dry +! parameters%smcwlt = SMCWLT_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Wilt +! parameters%smcref = SMCREF_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Reference +! parameters%smcmax = SMCMAX_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Max +! parameters%dksat = DKSAT_3D (I,1:NSOIL,J) ! Saturated Soil Conductivity +! parameters%dwsat = DWSAT_3D (I,1:NSOIL,J) ! Saturated Soil Diffusivity +! parameters%psisat = PSISAT_3D(I,1:NSOIL,J) ! Saturated Matric Potential +! parameters%quartz = QUARTZ_3D(I,1:NSOIL,J) ! Soil quartz content +! parameters%refdk = REFDK_2D (I,J) ! Reference Soil Conductivity +! parameters%refkdt = REFKDT_2D(I,J) ! Soil Infiltration Parameter + +! placeholders for 2D irrigation params +! parameters%IRR_FRAC = IRR_FRAC_2D(I,J) ! irrigation Fraction +! parameters%IRR_HAR = IRR_HAR_2D(I,J) ! number of days before harvest date to stop irrigation +! parameters%IRR_LAI = IRR_LAI_2D(I,J) ! Minimum lai to trigger irrigation +! parameters%IRR_MAD = IRR_MAD_2D(I,J) ! management allowable deficit (0-1) +! parameters%FILOSS = FILOSS_2D(I,J) ! fraction of flood irrigation loss (0-1) +! parameters%SPRIR_RATE = SPRIR_RATE_2D(I,J) ! mm/h, sprinkler irrigation rate +! parameters%MICIR_RATE = MICIR_RATE_2D(I,J) ! mm/h, micro irrigation rate +! parameters%FIRTFAC = FIRTFAC_2D(I,J) ! flood application rate factor +! parameters%IR_RAIN = IR_RAIN_2D(I,J) ! maximum precipitation to stop irrigation trigger + + CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,CROPTYPE,parameters) + + if(iopt_soil == 3 .and. .not. parameters%urban_flag) then + + sand = 0.01 * soilcomp(i,1:4,j) + clay = 0.01 * soilcomp(i,5:8,j) + orgm = 0.0 + + if(iopt_pedo == 1) call pedotransfer_sr2006(nsoil,sand,clay,orgm,parameters) + + end if + + GRAIN = GRAINXY (I,J) ! mass of grain XING [g/m2] + GDD = GDDXY (I,J) ! growing degree days XING + PGS = PGSXY (I,J) ! growing degree days XING + + if(iopt_crop == 1 .and. croptype > 0) then + parameters%PLTDAY = PLANTING(I,J) + parameters%HSDAY = HARVEST (I,J) + parameters%GDDS1 = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS1 + parameters%GDDS2 = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS2 + parameters%GDDS3 = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS3 + parameters%GDDS4 = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS4 + parameters%GDDS5 = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS5 + end if + + if(iopt_irr == 2) then ! based on planting and harvesting dates. + parameters%PLTDAY = PLANTING(I,J) + parameters%HSDAY = HARVEST (I,J) + end if + +!=== hydrological processes for vegetation in urban model === +!=== irrigate vegetaion only in urban area, MAY-SEP, 9-11pm + + ! IF( IVGTYP(I,J) == ISURBAN_TABLE .or. IVGTYP(I,J) == LCZ_1_TABLE .or. IVGTYP(I,J) == LCZ_2_TABLE .or. & + ! IVGTYP(I,J) == LCZ_3_TABLE .or. IVGTYP(I,J) == LCZ_4_TABLE .or. IVGTYP(I,J) == LCZ_5_TABLE .or. & + ! IVGTYP(I,J) == LCZ_6_TABLE .or. IVGTYP(I,J) == LCZ_7_TABLE .or. IVGTYP(I,J) == LCZ_8_TABLE .or. & + ! IVGTYP(I,J) == LCZ_9_TABLE .or. IVGTYP(I,J) == LCZ_10_TABLE .or. IVGTYP(I,J) == LCZ_11_TABLE ) THEN + ! +!!!TLE: commenting this block so as to remove necessity for module_ra_gfdleta and module_sf_urban. +!!! Can be reinstated at a later date. +! IF(SF_URBAN_PHYSICS > 0 .AND. IRI_SCHEME == 1 ) THEN +! SOLAR_TIME = (JULIAN - INT(JULIAN))*24 + XLONG(I,J)/15.0 +! IF(SOLAR_TIME < 0.) SOLAR_TIME = SOLAR_TIME + 24. +! CALL CAL_MON_DAY(INT(JULIAN),YR,JMONTH,JDAY) +! IF (SOLAR_TIME >= 21. .AND. SOLAR_TIME <= 23. .AND. JMONTH >= 5 .AND. JMONTH <= 9) THEN +! SMC(1) = max(SMC(1),parameters%SMCREF(1)) +! SMC(2) = max(SMC(2),parameters%SMCREF(2)) +! ENDIF +! ENDIF +! +! ENDIF + +! Initialized local + + FICEOLD = 0.0 + FICEOLD(ISNOW+1:0) = SNICEXY(I,ISNOW+1:0,J) & ! snow ice fraction + /(SNICEXY(I,ISNOW+1:0,J)+SNLIQXY(I,ISNOW+1:0,J)) + CO2PP = CO2_TABLE * P_ML ! partial pressure co2 [Pa] + O2PP = O2_TABLE * P_ML ! partial pressure o2 [Pa] + FOLN = 1.0 ! for now, set to nitrogen saturation + QC = undefined_value ! test dummy value + PBLH = undefined_value ! test dummy value ! PBL height + DZ8W1D = DZ8W (I,1,J) ! thickness of atmospheric layers + + IF(VEGTYP == 25) FVEG = 0.0 ! Set playa, lava, sand to bare + IF(VEGTYP == 25) PLAI = 0.0 + IF(VEGTYP == 26) FVEG = 0.0 ! hard coded for USGS + IF(VEGTYP == 26) PLAI = 0.0 + IF(VEGTYP == 27) FVEG = 0.0 + IF(VEGTYP == 27) PLAI = 0.0 + + IF ( VEGTYP == ISICE_TABLE ) THEN + ICE = -1 ! Land-ice point + CALL NOAHMP_OPTIONS_GLACIER(IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC, IOPT_GLA ) + + TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C + CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related + T_ML, P_ML, U_ML, V_ML, Q_ML, SWDN, & ! IN : Forcing + PRCP, LWDN, TBOT, Z_ML, FICEOLD, ZSOIL, & ! IN : Forcing + QSNOW, SNEQVO, ALBOLD, CM, CH, ISNOW, & ! IN/OUT : + SWE, SMC, ZSNSO, SNDPTH, SNICE, SNLIQ, & ! IN/OUT : + TG, STC, SMH2O, TAUSS, QSFC1D, & ! IN/OUT : + FSA, FSR, FIRA, FSH, FGEV, SSOIL, & ! OUT : + TRAD, ESOIL, RUNSF, RUNSB, SAG, SALB, & ! OUT : + QSNBOT,PONDING,PONDING1,PONDING2, T2MB, Q2MB, & ! OUT : + EMISSI, FPICE, CHB2 & ! OUT : +!#ifdef WRF_HYDRO +! , sfcheadrt(i,j) & +!#endif + ) + + FSNO = 1.0 + TV = undefined_value ! Output from standard Noah-MP undefined for glacier points + TGB = TG + CANICE = undefined_value + CANLIQ = undefined_value + EAH = undefined_value + TAH = undefined_value + FWET = undefined_value + WSLAKE = undefined_value +! ZWT = undefined_value + WA = undefined_value + WT = undefined_value + LFMASS = undefined_value + RTMASS = undefined_value + STMASS = undefined_value + WOOD = undefined_value + GRAIN = undefined_value + GDD = undefined_value + STBLCP = undefined_value + FASTCP = undefined_value + PLAI = undefined_value + PSAI = undefined_value + T2MV = undefined_value + Q2MV = undefined_value + NEE = undefined_value + GPP = undefined_value + NPP = undefined_value + FVEGMP = 0.0 + ECAN = undefined_value + ETRAN = undefined_value + APAR = undefined_value + PSN = undefined_value + SAV = undefined_value + RSSUN = undefined_value + RSSHA = undefined_value + RB = undefined_value + LAISUN = undefined_value + LAISHA = undefined_value + RS(I,J)= undefined_value + BGAP = undefined_value + WGAP = undefined_value + TGV = undefined_value + CHV = undefined_value + CHB = CH + IRC = undefined_value + IRG = undefined_value + SHC = undefined_value + SHG = undefined_value + EVG = undefined_value + GHV = undefined_value + IRB = FIRA + SHB = FSH + EVB = FGEV + GHB = SSOIL + TR = undefined_value + EVC = undefined_value + CHLEAF = undefined_value + CHUC = undefined_value + CHV2 = undefined_value + FCEV = undefined_value + FCTR = undefined_value + Z0WRF = 0.002 + QFX(I,J) = ESOIL + LH (I,J) = FGEV + + + ELSE + ICE=0 ! Neither sea ice or land ice. + CALL NOAHMP_SFLX (parameters, & + I , J , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related + DT , DX , DZ8W1D , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration + FVEG , FVGMAX , VEGTYP , ICE , IST , CROPTYPE, & ! IN : Vegetation/Soil characteristics + SMCEQ , & ! IN : Vegetation/Soil characteristics + T_ML , P_ML , PSFC , U_ML , V_ML , Q_ML , & ! IN : Forcing + QC , SWDN , LWDN , & ! IN : Forcing + PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, & ! IN : Forcing + TBOT , CO2PP , O2PP , FOLN , FICEOLD , Z_ML , & ! IN : Forcing + IRRFRA , SIFAC , MIFAC , FIFAC , LLANDUSE, & ! IN : Irrigation: fractions + ALBOLD , SNEQVO , & ! IN/OUT : + STC , SMH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : + CANLIQ , CANICE , TV , TG , QSFC1D , QSNOW , & ! IN/OUT : + QRAIN , & ! IN/OUT : + ISNOW , ZSNSO , SNDPTH , SWE , SNICE , SNLIQ , & ! IN/OUT : + ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , & ! IN/OUT : + STMASS , WOOD , STBLCP , FASTCP , PLAI , PSAI , & ! IN/OUT : + CM , CH , TAUSS , & ! IN/OUT : + GRAIN , GDD , PGS , & ! IN/OUT + SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : + GECROS1D, & ! IN/OUT : + Z0WRF , & + IRCNTSI , IRCNTMI , IRCNTFI , IRAMTSI , IRAMTMI , IRAMTFI , & ! IN/OUT : Irrigation: vars + IRSIRATE, IRMIRATE, IRFIRATE, FIRR , EIRR , & ! IN/OUT : Irrigation: vars + FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : + FGEV , FCTR , ECAN , ETRAN , ESOIL , TRAD , & ! OUT : + TGB , TGV , T2MV , T2MB , Q2MV , Q2MB , & ! OUT : + RUNSF , RUNSB , APAR , PSN , SAV , SAG , & ! OUT : + FSNO , NEE , GPP , NPP , FVEGMP , SALB , & ! OUT : + QSNBOT , PONDING , PONDING1, PONDING2, RSSUN , RSSHA , & ! OUT : + ALBSND , ALBSNI , & ! OUT : + BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : + SHG , SHC , SHB , EVG , EVB , GHV , & ! OUT : + GHB , IRG , IRC , IRB , TR , EVC , & ! OUT : + CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & + PAHG , PAHB , PAH , LAISUN , LAISHA , RB & +!#ifdef WRF_HYDRO +! , sfcheadrt(i,j) & +!#endif + ) ! OUT : + + QFX(I,J) = ECAN + ESOIL + ETRAN + EIRR + LH(I,J) = FCEV + FGEV + FCTR + FIRR + + ENDIF ! glacial split ends + +!#ifdef WRF_HYDRO +!!AD_CHANGE: Glacier cells can produce small negative subsurface runoff for mass balance. +!! This will crash channel routing, so only pass along positive runoff. +! soldrain(i,j) = max(RUNSB*dt, 0.) !mm , underground runoff +! INFXSRT(i,j) = RUNSF*dt !mm , surface runoff +!#endif + + +! INPUT/OUTPUT + + TSK (I,J) = TRAD + HFX (I,J) = FSH + GRDFLX (I,J) = SSOIL + SMSTAV (I,J) = 0.0 ! [maintained as Noah consistency] + SMSTOT (I,J) = 0.0 ! [maintained as Noah consistency] + SFCRUNOFF(I,J) = SFCRUNOFF(I,J) + RUNSF * DT + UDRUNOFF (I,J) = UDRUNOFF(I,J) + RUNSB * DT + IF ( SALB > -999 ) THEN + ALBEDO(I,J) = SALB + ENDIF + SNOWC (I,J) = FSNO + SMOIS (I, 1:NSOIL,J) = SMC ( 1:NSOIL) + SH2O (I, 1:NSOIL,J) = SMH2O ( 1:NSOIL) + TSLB (I, 1:NSOIL,J) = STC ( 1:NSOIL) + SNOW (I,J) = SWE + SNOWH (I,J) = SNDPTH + CANWAT (I,J) = CANLIQ + CANICE + ACSNOW (I,J) = ACSNOW(I,J) + PRECIP_IN(I,J) * FPICE + ACSNOM (I,J) = ACSNOM(I,J) + QSNBOT*DT + PONDING + PONDING1 + PONDING2 + EMISS (I,J) = EMISSI + QSFC (I,J) = QSFC1D + + ISNOWXY (I,J) = ISNOW + TVXY (I,J) = TV + TGXY (I,J) = TG + CANLIQXY (I,J) = CANLIQ + CANICEXY (I,J) = CANICE + EAHXY (I,J) = EAH + TAHXY (I,J) = TAH + CMXY (I,J) = CM + CHXY (I,J) = CH + FWETXY (I,J) = FWET + SNEQVOXY (I,J) = SNEQVO + ALBOLDXY (I,J) = ALBOLD + QSNOWXY (I,J) = QSNOW + QRAINXY (I,J) = QRAIN + WSLAKEXY (I,J) = WSLAKE + ZWTXY (I,J) = ZWT + WAXY (I,J) = WA + WTXY (I,J) = WT + TSNOXY (I,-NSNOW+1: 0,J) = STC (-NSNOW+1: 0) + ZSNSOXY (I,-NSNOW+1:NSOIL,J) = ZSNSO (-NSNOW+1:NSOIL) + SNICEXY (I,-NSNOW+1: 0,J) = SNICE (-NSNOW+1: 0) + SNLIQXY (I,-NSNOW+1: 0,J) = SNLIQ (-NSNOW+1: 0) + LFMASSXY (I,J) = LFMASS + RTMASSXY (I,J) = RTMASS + STMASSXY (I,J) = STMASS + WOODXY (I,J) = WOOD + STBLCPXY (I,J) = STBLCP + FASTCPXY (I,J) = FASTCP + XLAIXY (I,J) = PLAI + XSAIXY (I,J) = PSAI + TAUSSXY (I,J) = TAUSS + +! OUTPUT + + Z0 (I,J) = Z0WRF + ZNT (I,J) = Z0WRF + T2MVXY (I,J) = T2MV + T2MBXY (I,J) = T2MB + Q2MVXY (I,J) = Q2MV/(1.0 - Q2MV) ! specific humidity to mixing ratio + Q2MBXY (I,J) = Q2MB/(1.0 - Q2MB) ! consistent with registry def of Q2 + TRADXY (I,J) = TRAD + NEEXY (I,J) = NEE + GPPXY (I,J) = GPP + NPPXY (I,J) = NPP + FVEGXY (I,J) = FVEGMP + RUNSFXY (I,J) = RUNSF + RUNSBXY (I,J) = RUNSB + ECANXY (I,J) = ECAN + EDIRXY (I,J) = ESOIL + ETRANXY (I,J) = ETRAN + FSAXY (I,J) = FSA + FIRAXY (I,J) = FIRA + APARXY (I,J) = APAR + PSNXY (I,J) = PSN + SAVXY (I,J) = SAV + SAGXY (I,J) = SAG + RSSUNXY (I,J) = RSSUN + RSSHAXY (I,J) = RSSHA + LAISUN = MAX(LAISUN, 0.0) + LAISHA = MAX(LAISHA, 0.0) + RB = MAX(RB, 0.0) +! New Calculation of total Canopy/Stomatal Conductance Based on Bonan et al. (2011) +! -- Inverse of Canopy Resistance (below) + IF(RSSUN .le. 0.0 .or. RSSHA .le. 0.0 .or. LAISUN .eq. 0.0 .or. LAISHA .eq. 0.0) THEN + RS (I,J) = 0.0 + ELSE + RS (I,J) = ((1.0/(RSSUN+RB)*LAISUN) + ((1.0/(RSSHA+RB))*LAISHA)) + RS (I,J) = 1.0/RS(I,J) !Resistance + ENDIF + BGAPXY (I,J) = BGAP + WGAPXY (I,J) = WGAP + TGVXY (I,J) = TGV + TGBXY (I,J) = TGB + CHVXY (I,J) = CHV + CHBXY (I,J) = CHB + IRCXY (I,J) = IRC + IRGXY (I,J) = IRG + SHCXY (I,J) = SHC + SHGXY (I,J) = SHG + EVGXY (I,J) = EVG + GHVXY (I,J) = GHV + IRBXY (I,J) = IRB + SHBXY (I,J) = SHB + EVBXY (I,J) = EVB + GHBXY (I,J) = GHB + TRXY (I,J) = TR + EVCXY (I,J) = EVC + CHLEAFXY (I,J) = CHLEAF + CHUCXY (I,J) = CHUC + CHV2XY (I,J) = CHV2 + CHB2XY (I,J) = CHB2 + RECHXY (I,J) = RECHXY(I,J) + RECH*1.E3 !RECHARGE TO THE WATER TABLE + DEEPRECHXY(I,J) = DEEPRECHXY(I,J) + DEEPRECH + SMCWTDXY(I,J) = SMCWTD + + GRAINXY (I,J) = GRAIN !GRAIN XING + GDDXY (I,J) = GDD !XING + PGSXY (I,J) = PGS + + ! irrigation + IRNUMSI(I,J) = IRCNTSI + IRNUMMI(I,J) = IRCNTMI + IRNUMFI(I,J) = IRCNTFI + IRWATSI(I,J) = IRAMTSI + IRWATMI(I,J) = IRAMTMI + IRWATFI(I,J) = IRAMTFI + IRSIVOL(I,J) = IRSIVOL(I,J)+(IRSIRATE*1000.0) + IRMIVOL(I,J) = IRMIVOL(I,J)+(IRMIRATE*1000.0) + IRFIVOL(I,J) = IRFIVOL(I,J)+(IRFIRATE*1000.0) + IRELOSS(I,J) = IRELOSS(I,J)+(EIRR*DT) ! mm + IRRSPLH(I,J) = IRRSPLH(I,J)+(FIRR*DT) ! Joules/m^2 + + if(iopt_crop == 2) then ! gecros crop model + + !*** Check for harvest + if ((gecros1d(1) >= gecros_ds1).and.(gecros1d(42) < 0)) then + if (checkIfHarvest(gecros_state, DT, gecros_ds1, gecros_ds2, gecros_ds1x, & + gecros_ds2x) == 1) then + + call gecros_reinit(gecros1d) + endif + endif + + gecros_state (i,1:60,j) = gecros1d(1:60) + end if + + ENDIF ! endif of land-sea test + + ENDDO ILOOP ! of I loop + ENDDO JLOOP ! of J loop + +!------------------------------------------------------ + END SUBROUTINE noahmplsm +!------------------------------------------------------ + +SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE,parameters) + + USE NOAHMP_TABLES + USE MODULE_SF_NOAHMPLSM + + implicit none + + INTEGER, INTENT(IN) :: VEGTYPE + INTEGER, INTENT(IN) :: SOILTYPE(4) + INTEGER, INTENT(IN) :: SLOPETYPE + INTEGER, INTENT(IN) :: SOILCOLOR + INTEGER, INTENT(IN) :: CROPTYPE + + type (noahmp_parameters), intent(inout) :: parameters + + REAL :: REFDK + REAL :: REFKDT + REAL :: FRZK + REAL :: FRZFACT + INTEGER :: ISOIL + + parameters%ISWATER = ISWATER_TABLE + parameters%ISBARREN = ISBARREN_TABLE + parameters%ISICE = ISICE_TABLE + parameters%ISCROP = ISCROP_TABLE + parameters%EBLFOREST = EBLFOREST_TABLE + + parameters%URBAN_FLAG = .FALSE. + IF( VEGTYPE == ISURBAN_TABLE .or. VEGTYPE == LCZ_1_TABLE .or. VEGTYPE == LCZ_2_TABLE .or. & + VEGTYPE == LCZ_3_TABLE .or. VEGTYPE == LCZ_4_TABLE .or. VEGTYPE == LCZ_5_TABLE .or. & + VEGTYPE == LCZ_6_TABLE .or. VEGTYPE == LCZ_7_TABLE .or. VEGTYPE == LCZ_8_TABLE .or. & + VEGTYPE == LCZ_9_TABLE .or. VEGTYPE == LCZ_10_TABLE .or. VEGTYPE == LCZ_11_TABLE ) THEN + parameters%URBAN_FLAG = .TRUE. + ENDIF + +!------------------------------------------------------------------------------------------! +! Transfer veg parameters +!------------------------------------------------------------------------------------------! + + parameters%CH2OP = CH2OP_TABLE(VEGTYPE) !maximum intercepted h2o per unit lai+sai (mm) + parameters%DLEAF = DLEAF_TABLE(VEGTYPE) !characteristic leaf dimension (m) + parameters%Z0MVT = Z0MVT_TABLE(VEGTYPE) !momentum roughness length (m) + parameters%HVT = HVT_TABLE(VEGTYPE) !top of canopy (m) + parameters%HVB = HVB_TABLE(VEGTYPE) !bottom of canopy (m) + parameters%DEN = DEN_TABLE(VEGTYPE) !tree density (no. of trunks per m2) + parameters%RC = RC_TABLE(VEGTYPE) !tree crown radius (m) + parameters%MFSNO = MFSNO_TABLE(VEGTYPE) !snowmelt m parameter () + parameters%SCFFAC = SCFFAC_TABLE(VEGTYPE) !snow cover factor (m) (originally hard-coded 2.5*z0 in SCF formulation) + parameters%SAIM = SAIM_TABLE(VEGTYPE,:) !monthly stem area index, one-sided + parameters%LAIM = LAIM_TABLE(VEGTYPE,:) !monthly leaf area index, one-sided + parameters%SLA = SLA_TABLE(VEGTYPE) !single-side leaf area per Kg [m2/kg] + parameters%DILEFC = DILEFC_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] + parameters%DILEFW = DILEFW_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] + parameters%FRAGR = FRAGR_TABLE(VEGTYPE) !fraction of growth respiration !original was 0.3 + parameters%LTOVRC = LTOVRC_TABLE(VEGTYPE) !leaf turnover [1/s] + + parameters%C3PSN = C3PSN_TABLE(VEGTYPE) !photosynthetic pathway: 0. = c4, 1. = c3 + parameters%KC25 = KC25_TABLE(VEGTYPE) !co2 michaelis-menten constant at 25c (pa) + parameters%AKC = AKC_TABLE(VEGTYPE) !q10 for kc25 + parameters%KO25 = KO25_TABLE(VEGTYPE) !o2 michaelis-menten constant at 25c (pa) + parameters%AKO = AKO_TABLE(VEGTYPE) !q10 for ko25 + parameters%VCMX25 = VCMX25_TABLE(VEGTYPE) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + parameters%AVCMX = AVCMX_TABLE(VEGTYPE) !q10 for vcmx25 + parameters%BP = BP_TABLE(VEGTYPE) !minimum leaf conductance (umol/m**2/s) + parameters%MP = MP_TABLE(VEGTYPE) !slope of conductance-to-photosynthesis relationship + parameters%QE25 = QE25_TABLE(VEGTYPE) !quantum efficiency at 25c (umol co2 / umol photon) + parameters%AQE = AQE_TABLE(VEGTYPE) !q10 for qe25 + parameters%RMF25 = RMF25_TABLE(VEGTYPE) !leaf maintenance respiration at 25c (umol co2/m**2/s) + parameters%RMS25 = RMS25_TABLE(VEGTYPE) !stem maintenance respiration at 25c (umol co2/kg bio/s) + parameters%RMR25 = RMR25_TABLE(VEGTYPE) !root maintenance respiration at 25c (umol co2/kg bio/s) + parameters%ARM = ARM_TABLE(VEGTYPE) !q10 for maintenance respiration + parameters%FOLNMX = FOLNMX_TABLE(VEGTYPE) !foliage nitrogen concentration when f(n)=1 (%) + parameters%TMIN = TMIN_TABLE(VEGTYPE) !minimum temperature for photosynthesis (k) + + parameters%XL = XL_TABLE(VEGTYPE) !leaf/stem orientation index + parameters%RHOL = RHOL_TABLE(VEGTYPE,:) !leaf reflectance: 1=vis, 2=nir + parameters%RHOS = RHOS_TABLE(VEGTYPE,:) !stem reflectance: 1=vis, 2=nir + parameters%TAUL = TAUL_TABLE(VEGTYPE,:) !leaf transmittance: 1=vis, 2=nir + parameters%TAUS = TAUS_TABLE(VEGTYPE,:) !stem transmittance: 1=vis, 2=nir + + parameters%MRP = MRP_TABLE(VEGTYPE) !microbial respiration parameter (umol co2 /kg c/ s) + parameters%CWPVT = CWPVT_TABLE(VEGTYPE) !empirical canopy wind parameter + + parameters%WRRAT = WRRAT_TABLE(VEGTYPE) !wood to non-wood ratio + parameters%WDPOOL = WDPOOL_TABLE(VEGTYPE) !wood pool (switch 1 or 0) depending on woody or not [-] + parameters%TDLEF = TDLEF_TABLE(VEGTYPE) !characteristic T for leaf freezing [K] + + parameters%NROOT = NROOT_TABLE(VEGTYPE) !number of soil layers with root present + parameters%RGL = RGL_TABLE(VEGTYPE) !Parameter used in radiation stress function + parameters%RSMIN = RS_TABLE(VEGTYPE) !Minimum stomatal resistance [s m-1] + parameters%HS = HS_TABLE(VEGTYPE) !Parameter used in vapor pressure deficit function + parameters%TOPT = TOPT_TABLE(VEGTYPE) !Optimum transpiration air temperature [K] + parameters%RSMAX = RSMAX_TABLE(VEGTYPE) !Maximal stomatal resistance [s m-1] + +!------------------------------------------------------------------------------------------! +! Transfer rad parameters +!------------------------------------------------------------------------------------------! + + parameters%ALBSAT = ALBSAT_TABLE(SOILCOLOR,:) + parameters%ALBDRY = ALBDRY_TABLE(SOILCOLOR,:) + parameters%ALBICE = ALBICE_TABLE + parameters%ALBLAK = ALBLAK_TABLE + parameters%OMEGAS = OMEGAS_TABLE + parameters%BETADS = BETADS_TABLE + parameters%BETAIS = BETAIS_TABLE + parameters%EG = EG_TABLE + +!------------------------------------------------------------------------------------------! +! Transfer crop parameters +!------------------------------------------------------------------------------------------! + + IF(CROPTYPE > 0) THEN + parameters%PLTDAY = PLTDAY_TABLE(CROPTYPE) ! Planting date + parameters%HSDAY = HSDAY_TABLE(CROPTYPE) ! Harvest date + parameters%PLANTPOP = PLANTPOP_TABLE(CROPTYPE) ! Plant density [per ha] - used? + parameters%IRRI = IRRI_TABLE(CROPTYPE) ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + parameters%GDDTBASE = GDDTBASE_TABLE(CROPTYPE) ! Base temperature for GDD accumulation [C] + parameters%GDDTCUT = GDDTCUT_TABLE(CROPTYPE) ! Upper temperature for GDD accumulation [C] + parameters%GDDS1 = GDDS1_TABLE(CROPTYPE) ! GDD from seeding to emergence + parameters%GDDS2 = GDDS2_TABLE(CROPTYPE) ! GDD from seeding to initial vegetative + parameters%GDDS3 = GDDS3_TABLE(CROPTYPE) ! GDD from seeding to post vegetative + parameters%GDDS4 = GDDS4_TABLE(CROPTYPE) ! GDD from seeding to intial reproductive + parameters%GDDS5 = GDDS5_TABLE(CROPTYPE) ! GDD from seeding to pysical maturity + parameters%C3PSN = C3PSNI_TABLE(CROPTYPE) ! parameters from stomata ! Zhe Zhang 2020-07-13 + parameters%KC25 = KC25I_TABLE(CROPTYPE) + parameters%AKC = AKCI_TABLE(CROPTYPE) + parameters%KO25 = KO25I_TABLE(CROPTYPE) + parameters%AKO = AKOI_TABLE(CROPTYPE) + parameters%AVCMX = AVCMXI_TABLE(CROPTYPE) + parameters%VCMX25 = VCMX25I_TABLE(CROPTYPE) + parameters%BP = BPI_TABLE(CROPTYPE) + parameters%MP = MPI_TABLE(CROPTYPE) + parameters%FOLNMX = FOLNMXI_TABLE(CROPTYPE) + parameters%QE25 = QE25I_TABLE(CROPTYPE) ! ends here + parameters%C3C4 = C3C4_TABLE(CROPTYPE) ! photosynthetic pathway: 1. = c3 2. = c4 + parameters%AREF = AREF_TABLE(CROPTYPE) ! reference maximum CO2 assimulation rate + parameters%PSNRF = PSNRF_TABLE(CROPTYPE) ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + parameters%I2PAR = I2PAR_TABLE(CROPTYPE) ! Fraction of incoming solar radiation to photosynthetically active radiation + parameters%TASSIM0 = TASSIM0_TABLE(CROPTYPE) ! Minimum temperature for CO2 assimulation [C] + parameters%TASSIM1 = TASSIM1_TABLE(CROPTYPE) ! CO2 assimulation linearly increasing until temperature reaches T1 [C] + parameters%TASSIM2 = TASSIM2_TABLE(CROPTYPE) ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + parameters%K = K_TABLE(CROPTYPE) ! light extinction coefficient + parameters%EPSI = EPSI_TABLE(CROPTYPE) ! initial light use efficiency + parameters%Q10MR = Q10MR_TABLE(CROPTYPE) ! q10 for maintainance respiration + parameters%FOLN_MX = FOLN_MX_TABLE(CROPTYPE) ! foliage nitrogen concentration when f(n)=1 (%) + parameters%LEFREEZ = LEFREEZ_TABLE(CROPTYPE) ! characteristic T for leaf freezing [K] + parameters%DILE_FC = DILE_FC_TABLE(CROPTYPE,:) ! coeficient for temperature leaf stress death [1/s] + parameters%DILE_FW = DILE_FW_TABLE(CROPTYPE,:) ! coeficient for water leaf stress death [1/s] + parameters%FRA_GR = FRA_GR_TABLE(CROPTYPE) ! fraction of growth respiration + parameters%LF_OVRC = LF_OVRC_TABLE(CROPTYPE,:) ! fraction of leaf turnover [1/s] + parameters%ST_OVRC = ST_OVRC_TABLE(CROPTYPE,:) ! fraction of stem turnover [1/s] + parameters%RT_OVRC = RT_OVRC_TABLE(CROPTYPE,:) ! fraction of root tunrover [1/s] + parameters%LFMR25 = LFMR25_TABLE(CROPTYPE) ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] + parameters%STMR25 = STMR25_TABLE(CROPTYPE) ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + parameters%RTMR25 = RTMR25_TABLE(CROPTYPE) ! root maintenance respiration at 25C [umol CO2/kg bio/s] + parameters%GRAINMR25 = GRAINMR25_TABLE(CROPTYPE) ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + parameters%LFPT = LFPT_TABLE(CROPTYPE,:) ! fraction of carbohydrate flux to leaf + parameters%STPT = STPT_TABLE(CROPTYPE,:) ! fraction of carbohydrate flux to stem + parameters%RTPT = RTPT_TABLE(CROPTYPE,:) ! fraction of carbohydrate flux to root + parameters%GRAINPT = GRAINPT_TABLE(CROPTYPE,:) ! fraction of carbohydrate flux to grain + parameters%LFCT = LFCT_TABLE(CROPTYPE,:) ! fraction of translocation to grain ! Zhe Zhang 2020-07-13 + parameters%STCT = STCT_TABLE(CROPTYPE,:) ! fraction of translocation to grain + parameters%RTCT = RTCT_TABLE(CROPTYPE,:) ! fraction of translocation to grain + parameters%BIO2LAI = BIO2LAI_TABLE(CROPTYPE) ! leaf are per living leaf biomass [m^2/kg] + END IF + +!------------------------------------------------------------------------------------------! +! Transfer global parameters +!------------------------------------------------------------------------------------------! + + parameters%CO2 = CO2_TABLE + parameters%O2 = O2_TABLE + parameters%TIMEAN = TIMEAN_TABLE + parameters%FSATMX = FSATMX_TABLE + parameters%Z0SNO = Z0SNO_TABLE + parameters%SSI = SSI_TABLE + parameters%SNOW_RET_FAC = SNOW_RET_FAC_TABLE + parameters%SNOW_EMIS = SNOW_EMIS_TABLE + parameters%SWEMX = SWEMX_TABLE + parameters%TAU0 = TAU0_TABLE + parameters%GRAIN_GROWTH = GRAIN_GROWTH_TABLE + parameters%EXTRA_GROWTH = EXTRA_GROWTH_TABLE + parameters%DIRT_SOOT = DIRT_SOOT_TABLE + parameters%BATS_COSZ = BATS_COSZ_TABLE + parameters%BATS_VIS_NEW = BATS_VIS_NEW_TABLE + parameters%BATS_NIR_NEW = BATS_NIR_NEW_TABLE + parameters%BATS_VIS_AGE = BATS_VIS_AGE_TABLE + parameters%BATS_NIR_AGE = BATS_NIR_AGE_TABLE + parameters%BATS_VIS_DIR = BATS_VIS_DIR_TABLE + parameters%BATS_NIR_DIR = BATS_NIR_DIR_TABLE + parameters%RSURF_SNOW = RSURF_SNOW_TABLE + parameters%RSURF_EXP = RSURF_EXP_TABLE + +! ---------------------------------------------------------------------- +! Transfer soil parameters +! ---------------------------------------------------------------------- + + do isoil = 1, size(soiltype) + parameters%BEXP(isoil) = BEXP_TABLE (SOILTYPE(isoil)) + parameters%DKSAT(isoil) = DKSAT_TABLE (SOILTYPE(isoil)) + parameters%DWSAT(isoil) = DWSAT_TABLE (SOILTYPE(isoil)) + parameters%PSISAT(isoil) = PSISAT_TABLE (SOILTYPE(isoil)) + parameters%QUARTZ(isoil) = QUARTZ_TABLE (SOILTYPE(isoil)) + parameters%SMCDRY(isoil) = SMCDRY_TABLE (SOILTYPE(isoil)) + parameters%SMCMAX(isoil) = SMCMAX_TABLE (SOILTYPE(isoil)) + parameters%SMCREF(isoil) = SMCREF_TABLE (SOILTYPE(isoil)) + parameters%SMCWLT(isoil) = SMCWLT_TABLE (SOILTYPE(isoil)) + end do + + parameters%F1 = F1_TABLE(SOILTYPE(1)) + parameters%REFDK = REFDK_TABLE + parameters%REFKDT = REFKDT_TABLE + +!------------------------------------------------------------------------------------------! +! Transfer irrigation parameters +!------------------------------------------------------------------------------------------! + parameters%IRR_FRAC = IRR_FRAC_TABLE ! irrigation Fraction + parameters%IRR_HAR = IRR_HAR_TABLE ! number of days before harvest date to stop irrigation + parameters%IRR_LAI = IRR_LAI_TABLE ! minimum lai to trigger irrigation + parameters%IRR_MAD = IRR_MAD_TABLE ! management allowable deficit (0-1) + parameters%FILOSS = FILOSS_TABLE ! fraction of flood irrigation loss (0-1) + parameters%SPRIR_RATE = SPRIR_RATE_TABLE ! mm/h, sprinkler irrigation rate + parameters%MICIR_RATE = MICIR_RATE_TABLE ! mm/h, micro irrigation rate + parameters%FIRTFAC = FIRTFAC_TABLE ! flood application rate factor + parameters%IR_RAIN = IR_RAIN_TABLE ! maximum precipitation to stop irrigation trigger + +! ---------------------------------------------------------------------- +! Transfer GENPARM parameters +! ---------------------------------------------------------------------- + parameters%CSOIL = CSOIL_TABLE + parameters%ZBOT = ZBOT_TABLE + parameters%CZIL = CZIL_TABLE + + FRZK = FRZK_TABLE + parameters%KDT = parameters%REFKDT * parameters%DKSAT(1) / parameters%REFDK + parameters%SLOPE = SLOPE_TABLE(SLOPETYPE) + + IF(parameters%URBAN_FLAG)THEN ! Hardcoding some urban parameters for soil + parameters%SMCMAX = 0.45 + parameters%SMCREF = 0.42 + parameters%SMCWLT = 0.40 + parameters%SMCDRY = 0.40 + parameters%CSOIL = 3.E6 + ENDIF + +! adjust FRZK parameter to actual soil type: FRZK * FRZFACT + + IF(SOILTYPE(1) /= 14) then + FRZFACT = (parameters%SMCMAX(1) / parameters%SMCREF(1)) * (0.412 / 0.468) + parameters%FRZX = FRZK * FRZFACT + END IF + + END SUBROUTINE TRANSFER_MP_PARAMETERS + +SUBROUTINE PEDOTRANSFER_SR2006(nsoil,sand,clay,orgm,parameters) + + use module_sf_noahmplsm + use noahmp_tables + + implicit none + + integer, intent(in ) :: nsoil ! number of soil layers + real, dimension( 1:nsoil ), intent(inout) :: sand + real, dimension( 1:nsoil ), intent(inout) :: clay + real, dimension( 1:nsoil ), intent(inout) :: orgm + + real, dimension( 1:nsoil ) :: theta_1500t + real, dimension( 1:nsoil ) :: theta_1500 + real, dimension( 1:nsoil ) :: theta_33t + real, dimension( 1:nsoil ) :: theta_33 + real, dimension( 1:nsoil ) :: theta_s33t + real, dimension( 1:nsoil ) :: theta_s33 + real, dimension( 1:nsoil ) :: psi_et + real, dimension( 1:nsoil ) :: psi_e + + type(noahmp_parameters), intent(inout) :: parameters + integer :: k + + do k = 1,4 + if(sand(k) <= 0 .or. clay(k) <= 0) then + sand(k) = 0.41 + clay(k) = 0.18 + end if + if(orgm(k) <= 0 ) orgm(k) = 0.0 + end do + + theta_1500t = sr2006_theta_1500t_a*sand & + + sr2006_theta_1500t_b*clay & + + sr2006_theta_1500t_c*orgm & + + sr2006_theta_1500t_d*sand*orgm & + + sr2006_theta_1500t_e*clay*orgm & + + sr2006_theta_1500t_f*sand*clay & + + sr2006_theta_1500t_g + + theta_1500 = theta_1500t & + + sr2006_theta_1500_a*theta_1500t & + + sr2006_theta_1500_b + + theta_33t = sr2006_theta_33t_a*sand & + + sr2006_theta_33t_b*clay & + + sr2006_theta_33t_c*orgm & + + sr2006_theta_33t_d*sand*orgm & + + sr2006_theta_33t_e*clay*orgm & + + sr2006_theta_33t_f*sand*clay & + + sr2006_theta_33t_g + + theta_33 = theta_33t & + + sr2006_theta_33_a*theta_33t*theta_33t & + + sr2006_theta_33_b*theta_33t & + + sr2006_theta_33_c + + theta_s33t = sr2006_theta_s33t_a*sand & + + sr2006_theta_s33t_b*clay & + + sr2006_theta_s33t_c*orgm & + + sr2006_theta_s33t_d*sand*orgm & + + sr2006_theta_s33t_e*clay*orgm & + + sr2006_theta_s33t_f*sand*clay & + + sr2006_theta_s33t_g + + theta_s33 = theta_s33t & + + sr2006_theta_s33_a*theta_s33t & + + sr2006_theta_s33_b + + psi_et = sr2006_psi_et_a*sand & + + sr2006_psi_et_b*clay & + + sr2006_psi_et_c*theta_s33 & + + sr2006_psi_et_d*sand*theta_s33 & + + sr2006_psi_et_e*clay*theta_s33 & + + sr2006_psi_et_f*sand*clay & + + sr2006_psi_et_g + + psi_e = psi_et & + + sr2006_psi_e_a*psi_et*psi_et & + + sr2006_psi_e_b*psi_et & + + sr2006_psi_e_c + + parameters%smcwlt = theta_1500 + parameters%smcref = theta_33 + parameters%smcmax = theta_33 & + + theta_s33 & + + sr2006_smcmax_a*sand & + + sr2006_smcmax_b + + parameters%bexp = 3.816712826 / (log(theta_33) - log(theta_1500) ) + parameters%psisat = psi_e + parameters%dksat = 1930.0 * (parameters%smcmax - theta_33) ** (3.0 - 1.0/parameters%bexp) + parameters%quartz = sand + +! Units conversion + + parameters%psisat = max(0.1,parameters%psisat) ! arbitrarily impose a limit of 0.1kpa + parameters%psisat = 0.101997 * parameters%psisat ! convert kpa to m + parameters%dksat = parameters%dksat / 3600000.0 ! convert mm/h to m/s + parameters%dwsat = parameters%dksat * parameters%psisat *parameters%bexp / parameters%smcmax ! units should be m*m/s + parameters%smcdry = parameters%smcwlt + +! Introducing somewhat arbitrary limits (based on SOILPARM) to prevent bad things + + parameters%smcmax = max(0.32 ,min(parameters%smcmax, 0.50 )) + parameters%smcref = max(0.17 ,min(parameters%smcref,parameters%smcmax )) + parameters%smcwlt = max(0.01 ,min(parameters%smcwlt,parameters%smcref )) + parameters%smcdry = max(0.01 ,min(parameters%smcdry,parameters%smcref )) + parameters%bexp = max(2.50 ,min(parameters%bexp, 12.0 )) + parameters%psisat = max(0.03 ,min(parameters%psisat, 1.00 )) + parameters%dksat = max(5.e-7,min(parameters%dksat, 1.e-5)) + parameters%dwsat = max(1.e-6,min(parameters%dwsat, 3.e-5)) + parameters%quartz = max(0.05 ,min(parameters%quartz, 0.95 )) + + END SUBROUTINE PEDOTRANSFER_SR2006 + + SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, XLAT, & + TSLB , SMOIS , SH2O , DZS , FNDSOILW , FNDSNOWH , & + TSK, isnowxy , tvxy ,tgxy ,canicexy , TMN, XICE, & + canliqxy ,eahxy ,tahxy ,cmxy ,chxy , & + fwetxy ,sneqvoxy ,alboldxy ,qsnowxy, qrainxy, wslakexy, zwtxy, waxy, & + wtxy ,tsnoxy ,zsnsoxy ,snicexy ,snliqxy ,lfmassxy ,rtmassxy , & + stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy ,lai , & + grainxy ,gddxy , & + croptype ,cropcat , & + irnumsi ,irnummi ,irnumfi ,irwatsi, & + irwatmi ,irwatfi ,ireloss ,irsivol, & + irmivol ,irfivol ,irrsplh , & +!jref:start + t2mvxy ,t2mbxy ,chstarxy, & +!jref:end + NSOIL, restart, & + allowed_to_read , iopt_run, iopt_crop, iopt_irr, iopt_irrm, & + sf_urban_physics, & ! urban scheme + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + smoiseq ,smcwtdxy ,rechxy ,deeprechxy, areaxy, dx, dy, msftx, msfty,& ! Optional groundwater + wtddt ,stepwtd ,dt ,qrfsxy ,qspringsxy , qslatxy , & ! Optional groundwater + fdepthxy ,ht ,riverbedxy ,eqzwt ,rivercondxy ,pexpxy , & ! Optional groundwater + rechclim, & ! Optional groundwater + gecros_state) ! Optional gecros crop + + USE NOAHMP_TABLES + use module_sf_gecros, only: seednc,sla0,slnmin,ffat,flig,foac,fmin,npl,seedw,eg,fcrsh,seednc,lnci,cfv + + + IMPLICIT NONE + +! Initializing Canopy air temperature to 287 K seems dangerous to me [KWM]. + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: NSOIL, iopt_run, iopt_crop, iopt_irr, iopt_irrm + + LOGICAL, INTENT(IN) :: restart, & + & allowed_to_read + INTEGER, INTENT(IN) :: sf_urban_physics ! urban, by yizhou + + REAL, DIMENSION( NSOIL), INTENT(IN) :: DZS ! Thickness of the soil layers [m] + REAL, INTENT(IN) , OPTIONAL :: DX, DY + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN) , OPTIONAL :: MSFTX,MSFTY + + REAL, DIMENSION( ims:ime, NSOIL, jms:jme ) , & + & INTENT(INOUT) :: SMOIS, & + & SH2O, & + & TSLB + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(INOUT) :: SNOW, & + & SNOWH, & + & CANWAT + + INTEGER, DIMENSION( ims:ime, jms:jme ), & + & INTENT(IN) :: ISLTYP, & + IVGTYP + + LOGICAL, INTENT(IN) :: FNDSOILW, & + & FNDSNOWH + + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: XLAT !latitude + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: TSK !skin temperature (k) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: TMN !deep soil temperature (k) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: XICE !sea ice fraction + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isnowxy !actual no. of snow layers + REAL, DIMENSION(ims:ime,-2:NSOIL,jms:jme), INTENT(INOUT) :: zsnsoxy !snow layer depth [m] + REAL, DIMENSION(ims:ime,-2: 0,jms:jme), INTENT(INOUT) :: tsnoxy !snow temperature [K] + REAL, DIMENSION(ims:ime,-2: 0,jms:jme), INTENT(INOUT) :: snicexy !snow layer ice [mm] + REAL, DIMENSION(ims:ime,-2: 0,jms:jme), INTENT(INOUT) :: snliqxy !snow layer liquid water [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: tvxy !vegetation canopy temperature + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: tgxy !ground surface temperature + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: canicexy !canopy-intercepted ice (mm) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: canliqxy !canopy-intercepted liquid water (mm) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: eahxy !canopy air vapor pressure (pa) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: tahxy !canopy air temperature (k) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: cmxy !momentum drag coefficient + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: chxy !sensible heat exchange coefficient + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fwetxy !wetted or snowed fraction of the canopy (-) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: sneqvoxy !snow mass at last time step(mm h2o) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: alboldxy !snow albedo at last time step (-) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: qsnowxy !snowfall on the ground [mm/s] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: qrainxy !rainfall on the ground [mm/s] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: wslakexy !lake water storage [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: zwtxy !water table depth [m] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: waxy !water in the "aquifer" [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: wtxy !groundwater storage [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: lfmassxy !leaf mass [g/m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: rtmassxy !mass of fine roots [g/m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: stmassxy !stem mass [g/m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: woodxy !mass of wood (incl. woody roots) [g/m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: grainxy !mass of grain [g/m2] !XING + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: gddxy !growing degree days !XING + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: stblcpxy !stable carbon in deep soil [g/m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fastcpxy !short-lived carbon, shallow soil [g/m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: xsaixy !stem area index + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: lai !leaf area index + + INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: cropcat + REAL , DIMENSION(ims:ime,5,jms:jme), INTENT(IN ) :: croptype + + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irnumsi + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irnummi + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irnumfi + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irwatsi + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irwatmi + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irwatfi + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: ireloss + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irsivol + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irmivol + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irfivol + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: irrsplh + +! IOPT_RUN = 5 option + + REAL, DIMENSION(ims:ime,1:nsoil,jms:jme), INTENT(INOUT) , OPTIONAL :: smoiseq !equilibrium soil moisture content [m3m-3] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: smcwtdxy !deep soil moisture content [m3m-3] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: deeprechxy !deep recharge [m] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: rechxy !accumulated recharge [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: qrfsxy !accumulated flux from groundwater to rivers [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: qspringsxy !accumulated seeping water [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: qslatxy !accumulated lateral flow [mm] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: areaxy !grid cell area [m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: FDEPTHXY !efolding depth for transmissivity (m) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: HT !terrain height (m) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: RIVERBEDXY !riverbed depth (m) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: EQZWT !equilibrium water table depth (m) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT), OPTIONAL :: RIVERCONDXY !river conductance + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT), OPTIONAL :: PEXPXY !factor for river conductance + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: rechclim + + REAL, DIMENSION(ims:ime,60,jms:jme), INTENT(INOUT), OPTIONAL :: gecros_state ! Optional gecros crop + + INTEGER, INTENT(OUT) , OPTIONAL :: STEPWTD + REAL, INTENT(IN) , OPTIONAL :: DT, WTDDT + +!jref:start + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: t2mvxy !2m temperature vegetation part (k) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: t2mbxy !2m temperature bare ground part (k) + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: chstarxy !dummy +!jref:end + + + REAL, DIMENSION(1:NSOIL) :: ZSOIL ! Depth of the soil layer bottom (m) from + ! the surface (negative) + + REAL :: BEXP, SMCMAX, PSISAT + REAL :: FK, masslai,masssai + +! gecros local variables + REAL :: hti,rdi,fpro,lncmin,fcar,cfo,clvi,crti,ygo,nlvi,laii,nrti,slnbi + + + REAL, PARAMETER :: BLIM = 5.5 + REAL, PARAMETER :: HLICE = 3.335E5 + REAL, PARAMETER :: GRAV = 9.81 + REAL, PARAMETER :: T0 = 273.15 + + INTEGER :: errflag, i,j,itf,jtf,ns + + character(len=240) :: err_message + character(len=4) :: MMINSL + character(len=*), intent(in) :: MMINLU + MMINSL='STAS' + + call read_mp_veg_parameters(trim(MMINLU)) + call read_mp_soil_parameters() + call read_mp_rad_parameters() + call read_mp_global_parameters() + call read_mp_crop_parameters() + call read_mp_optional_parameters() + if(iopt_irr >= 1) call read_mp_irrigation_parameters() + + IF( .NOT. restart ) THEN + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + ! + ! initialize physical snow height SNOWH + ! + IF(.NOT.FNDSNOWH)THEN + ! If no SNOWH do the following + ! CALL wrf_message( 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' ) + if (this_image()==1) WRITE(*,*) 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' + DO J = jts,jtf + DO I = its,itf + SNOWH(I,J)=SNOW(I,J)*0.005 ! SNOW in mm and SNOWH in m + ENDDO + ENDDO + ENDIF + + + ! Check if snow/snowh are consistent and cap SWE at 5000mm; + ! the Noah-MP code does it internally but if we don't do it here, problems ensue + DO J = jts,jtf + DO I = its,itf + IF ( SNOW(i,j) > 0. .AND. SNOWH(i,j) == 0. .OR. SNOWH(i,j) > 0. .AND. SNOW(i,j) == 0.) THEN + IF (this_image()==1) THEN + WRITE(err_message,*)"problem with initial snow fields: snow/snowh>0 while snowh/snow=0 at i,j" & + ,i,j,snow(i,j),snowh(i,j) + ENDIF +! CALL wrf_message(err_message) + ENDIF + IF ( SNOW( i,j ) > 5000. ) THEN + SNOWH(I,J) = SNOWH(I,J) * 5000. / SNOW(I,J) ! SNOW in mm and SNOWH in m + SNOW (I,J) = 5000. ! cap SNOW at 5000, maintain density + ENDIF + ENDDO + ENDDO + + errflag = 0 + DO j = jts,jtf + DO i = its,itf + IF ( ISLTYP( i,j ) .LT. 1 ) THEN + errflag = 1 + IF (this_image()==1) THEN + WRITE(err_message,*)"module_sf_noahlsm.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j ) + ENDIF + ! CALL wrf_message(err_message) + ENDIF + ENDDO + ENDDO + IF ( errflag .EQ. 1 ) THEN + WRITE(*,*) "FATAL ERROR: module_sf_noahlsm.F: lsminit: out of range value "// & + "of ISLTYP. Is this field in the input?" + STOP + ! CALL wrf_error_fatal( "module_sf_noahlsm.F: lsminit: out of range value "// & + ! "of ISLTYP. Is this field in the input?" ) + ENDIF +! GAC-->LATERALFLOW +! 20130219 - No longer need this - see module_data_gocart_dust +!#if ( WRF_CHEM == 1 ) +! ! +! ! need this parameter for dust parameterization in wrf/chem +! ! +! do I=1,NSLTYPE +! porosity(i)=maxsmc(i) +! enddo +!#endif +! <--GAC + +! initialize soil liquid water content SH2O + + DO J = jts , jtf + DO I = its , itf + IF(IVGTYP(I,J)==ISICE_TABLE .AND. XICE(I,J) <= 0.0) THEN + DO NS=1, NSOIL + SMOIS(I,NS,J) = 1.0 ! glacier starts all frozen + SH2O(I,NS,J) = 0.0 + TSLB(I,NS,J) = MIN(TSLB(I,NS,J),263.15) ! set glacier temp to at most -10C + END DO + !TMN(I,J) = MIN(TMN(I,J),263.15) ! set deep temp to at most -10C + SNOW(I,J) = MAX(SNOW(I,J), 10.0) ! set SWE to at least 10mm + SNOWH(I,J)=SNOW(I,J)*0.01 ! SNOW in mm and SNOWH in m + ELSE + + BEXP = BEXP_TABLE(ISLTYP(I,J)) + SMCMAX = SMCMAX_TABLE(ISLTYP(I,J)) + PSISAT = PSISAT_TABLE(ISLTYP(I,J)) + + DO NS=1, NSOIL + IF ( SMOIS(I,NS,J) > SMCMAX ) SMOIS(I,NS,J) = SMCMAX + END DO + IF ( ( BEXP > 0.0 ) .AND. ( SMCMAX > 0.0 ) .AND. ( PSISAT > 0.0 ) ) THEN + DO NS=1, NSOIL + IF ( TSLB(I,NS,J) < 273.149 ) THEN ! Use explicit as initial soil ice + FK=(( (HLICE/(GRAV*(-PSISAT))) * & + ((TSLB(I,NS,J)-T0)/TSLB(I,NS,J)) )**(-1/BEXP) )*SMCMAX + FK = MAX(FK, 0.02) + SH2O(I,NS,J) = MIN( FK, SMOIS(I,NS,J) ) + ELSE + SH2O(I,NS,J)=SMOIS(I,NS,J) + ENDIF + END DO + ELSE + DO NS=1, NSOIL + SH2O(I,NS,J)=SMOIS(I,NS,J) + END DO + ENDIF + ENDIF + ENDDO + ENDDO +! ENDIF + + + DO J = jts,jtf + DO I = its,itf + tvxy (I,J) = TSK(I,J) + if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) tvxy(I,J) = 273.15 + tgxy (I,J) = TSK(I,J) + if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) tgxy(I,J) = 273.15 + CANWAT (I,J) = 0.0 + canliqxy (I,J) = CANWAT(I,J) + canicexy (I,J) = 0. + eahxy (I,J) = 2000. + tahxy (I,J) = TSK(I,J) + if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) tahxy(I,J) = 273.15 +! tahxy (I,J) = 287. +!jref:start + t2mvxy (I,J) = TSK(I,J) + if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) t2mvxy(I,J) = 273.15 + t2mbxy (I,J) = TSK(I,J) + if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) t2mbxy(I,J) = 273.15 + chstarxy (I,J) = 0.1 +!jref:end + + cmxy (I,J) = 0.0 + chxy (I,J) = 0.0 + fwetxy (I,J) = 0.0 + sneqvoxy (I,J) = 0.0 + alboldxy (I,J) = 0.65 + qsnowxy (I,J) = 0.0 + qrainxy (I,J) = 0.0 + wslakexy (I,J) = 0.0 + + if(iopt_run.ne.5) then + waxy (I,J) = 4900. !??? + wtxy (I,J) = waxy(i,j) !??? + zwtxy (I,J) = (25. + 2.0) - waxy(i,j)/1000/0.2 !??? + else + waxy (I,J) = 0. + wtxy (I,J) = 0. + areaxy (I,J) = (DX * DY) / ( MSFTX(I,J) * MSFTY(I,J) ) + endif + + IF(IVGTYP(I,J) == ISBARREN_TABLE .OR. IVGTYP(I,J) == ISICE_TABLE .OR. & + ( SF_URBAN_PHYSICS == 0 .AND. IVGTYP(I,J) == ISURBAN_TABLE ) .OR. & + IVGTYP(I,J) == ISWATER_TABLE ) THEN + + lai (I,J) = 0.0 + xsaixy (I,J) = 0.0 + lfmassxy (I,J) = 0.0 + stmassxy (I,J) = 0.0 + rtmassxy (I,J) = 0.0 + woodxy (I,J) = 0.0 + stblcpxy (I,J) = 0.0 + fastcpxy (I,J) = 0.0 + grainxy (I,J) = 1E-10 + gddxy (I,J) = 0 + cropcat (I,J) = 0 + + ELSE + + lai (I,J) = max(lai(i,j),0.05) ! at least start with 0.05 for arbitrary initialization (v3.7) + xsaixy (I,J) = max(0.1*lai(I,J),0.05) ! MB: arbitrarily initialize SAI using input LAI (v3.7) + masslai = 1000. / max(SLA_TABLE(IVGTYP(I,J)),1.0) ! conversion from lai to mass (v3.7) + lfmassxy (I,J) = lai(i,j)*masslai ! use LAI to initialize (v3.7) + masssai = 1000. / 3.0 ! conversion from lai to mass (v3.7) + stmassxy (I,J) = xsaixy(i,j)*masssai ! use SAI to initialize (v3.7) + rtmassxy (I,J) = 500.0 ! these are all arbitrary and probably should be + woodxy (I,J) = 500.0 ! in the table or read from initialization + stblcpxy (I,J) = 1000.0 ! + fastcpxy (I,J) = 1000.0 ! + grainxy (I,J) = 1E-10 + gddxy (I,J) = 0 + +! Initialize crop for Liu crop model + + if(iopt_crop == 1 ) then + cropcat (i,j) = default_crop_table + if(croptype(i,5,j) >= 0.5) then + rtmassxy(i,j) = 0.0 + woodxy (i,j) = 0.0 + + if( croptype(i,1,j) > croptype(i,2,j) .and. & + croptype(i,1,j) > croptype(i,3,j) .and. & + croptype(i,1,j) > croptype(i,4,j) ) then ! choose corn + + cropcat (i,j) = 1 + lfmassxy(i,j) = lai(i,j)/0.015 ! Initialize lfmass Zhe Zhang 2020-07-13 + stmassxy(i,j) = xsaixy(i,j)/0.003 + + elseif(croptype(i,2,j) > croptype(i,1,j) .and. & + croptype(i,2,j) > croptype(i,3,j) .and. & + croptype(i,2,j) > croptype(i,4,j) ) then ! choose soybean + + cropcat (i,j) = 2 + lfmassxy(i,j) = lai(i,j)/0.030 ! Initialize lfmass Zhe Zhang 2020-07-13 + stmassxy(i,j) = xsaixy(i,j)/0.003 + + else + + cropcat (i,j) = default_crop_table + lfmassxy(i,j) = lai(i,j)/0.035 + stmassxy(i,j) = xsaixy(i,j)/0.003 + + end if + + end if + end if + +! Initialize cropcat for gecros crop model + + if(iopt_crop == 2) then + cropcat (i,j) = 0 + if(croptype(i,5,j) >= 0.5) then + if(croptype(i,3,j) > 0.0) cropcat(i,j) = 1 ! if any wheat, set to wheat + if(croptype(i,1,j) > croptype(i,3,j)) cropcat(i,j) = 2 ! change to maize + end if + + hti = 0.01 + rdi = 10. + fpro = 6.25*seednc + lncmin = sla0*slnmin + fcar = 1.-fpro-ffat-flig-foac-fmin + cfo = 0.444*fcar+0.531*fpro+0.774*ffat+0.667*flig+0.368*foac + clvi = npl * seedw * cfo * eg * fcrsh + crti = npl * seedw * cfo * eg * (1.-fcrsh) + ygo = cfo/(1.275*fcar+1.887*fpro+3.189*ffat+2.231*flig+0.954* & + foac)*30./12. + nlvi = min(0.75 * npl * seedw * eg * seednc, lnci * clvi/cfv) + laii = clvi/cfv*sla0 + nrti = npl * seedw * eg * seednc - nlvi + slnbi = nlvi/laii + + call gecros_init(xlat(i,j),hti,rdi,clvi,crti,nlvi,laii,nrti,slnbi,gecros_state(i,:,j)) + + end if + +! Noah-MP irrigation scheme !pvk + if(iopt_irr >= 1 .and. iopt_irr <= 3) then + if(iopt_irrm == 0 .or. iopt_irrm ==1) then ! sprinkler + irnumsi(i,j) = 0 + irwatsi(i,j) = 0. + ireloss(i,j) = 0. + irrsplh(i,j) = 0. + else if (iopt_irrm == 0 .or. iopt_irrm ==2) then ! micro or drip + irnummi(i,j) = 0 + irwatmi(i,j) = 0. + irmivol(i,j) = 0. + else if (iopt_irrm == 0 .or. iopt_irrm ==3) then ! flood + irnumfi(i,j) = 0 + irwatfi(i,j) = 0. + irfivol(i,j) = 0. + end if + end if + + END IF + + enddo + enddo + + + ! Given the soil layer thicknesses (in DZS), initialize the soil layer + ! depths from the surface. + ZSOIL(1) = -DZS(1) ! negative + DO NS=2, NSOIL + ZSOIL(NS) = ZSOIL(NS-1) - DZS(NS) + END DO + + ! Initialize snow/soil layer arrays ZSNSOXY, TSNOXY, SNICEXY, SNLIQXY, + ! and ISNOWXY + CALL snow_init ( ims , ime , jms , jme , its , itf , jts , jtf , 3 , & + & NSOIL , zsoil , snow , tgxy , snowh , & + & zsnsoxy , tsnoxy , snicexy , snliqxy , isnowxy ) + + !initialize arrays for groundwater dynamics iopt_run=5 + + if(iopt_run.eq.5) then + IF ( PRESENT(smoiseq) .AND. & + PRESENT(smcwtdxy) .AND. & + PRESENT(rechxy) .AND. & + PRESENT(deeprechxy) .AND. & + PRESENT(areaxy) .AND. & + PRESENT(dx) .AND. & + PRESENT(dy) .AND. & + PRESENT(msftx) .AND. & + PRESENT(msfty) .AND. & + PRESENT(wtddt) .AND. & + PRESENT(stepwtd) .AND. & + PRESENT(dt) .AND. & + PRESENT(qrfsxy) .AND. & + PRESENT(qspringsxy) .AND. & + PRESENT(qslatxy) .AND. & + PRESENT(fdepthxy) .AND. & + PRESENT(ht) .AND. & + PRESENT(riverbedxy) .AND. & + PRESENT(eqzwt) .AND. & + PRESENT(rivercondxy) .AND. & + PRESENT(pexpxy) .AND. & + PRESENT(rechclim) ) THEN + + STEPWTD = nint(WTDDT*60./DT) + STEPWTD = max(STEPWTD,1) + + ELSE + WRITE(*,*) "FATAL ERROR: Not enough fields to use groundwater option in Noah-MP" + STOP + !CALL wrf_error_fatal ('Not enough fields to use groundwater option in Noah-MP') + END IF + endif + + ENDIF + + END SUBROUTINE NOAHMP_INIT + +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + + SUBROUTINE SNOW_INIT ( ims , ime , jms , jme , its , itf , jts , jtf , & + & NSNOW , NSOIL , ZSOIL , SWE , TGXY , SNODEP , & + & ZSNSOXY , TSNOXY , SNICEXY ,SNLIQXY , ISNOWXY ) +!------------------------------------------------------------------------------------------ +! Initialize snow arrays for Noah-MP LSM, based in input SNOWDEP, NSNOW +! ISNOWXY is an index array, indicating the index of the top snow layer. Valid indices +! for snow layers range from 0 (no snow) and -1 (shallow snow) to (-NSNOW)+1 (deep snow). +! TSNOXY holds the temperature of the snow layer. Snow layers are initialized with +! temperature = ground temperature [?]. Snow-free levels in the array have value 0.0 +! SNICEXY is the frozen content of a snow layer. Initial estimate based on SNODEP and SWE +! SNLIQXY is the liquid content of a snow layer. Initialized to 0.0 +! ZNSNOXY is the layer depth from the surface. +!------------------------------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------------------------------ + INTEGER, INTENT(IN) :: ims, ime, jms, jme + INTEGER, INTENT(IN) :: its, itf, jts, jtf + INTEGER, INTENT(IN) :: NSNOW + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: SWE + REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: SNODEP + REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: TGXY + REAL, INTENT(IN), DIMENSION(1:NSOIL) :: ZSOIL + + INTEGER, INTENT(OUT), DIMENSION(ims:ime, jms:jme) :: ISNOWXY ! Top snow layer index + REAL, INTENT(OUT), DIMENSION(ims:ime, -NSNOW+1:NSOIL,jms:jme) :: ZSNSOXY ! Snow/soil layer depth from surface [m] + REAL, INTENT(OUT), DIMENSION(ims:ime, -NSNOW+1: 0,jms:jme) :: TSNOXY ! Snow layer temperature [K] + REAL, INTENT(OUT), DIMENSION(ims:ime, -NSNOW+1: 0,jms:jme) :: SNICEXY ! Snow layer ice content [mm] + REAL, INTENT(OUT), DIMENSION(ims:ime, -NSNOW+1: 0,jms:jme) :: SNLIQXY ! snow layer liquid content [mm] + +! Local variables: +! DZSNO holds the thicknesses of the various snow layers. +! DZSNOSO holds the thicknesses of the various soil/snow layers. + INTEGER :: I,J,IZ + REAL, DIMENSION(-NSNOW+1: 0) :: DZSNO + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZSNSO + +!------------------------------------------------------------------------------------------ + + DO J = jts , jtf + DO I = its , itf + IF ( SNODEP(I,J) < 0.025 ) THEN + ISNOWXY(I,J) = 0 + DZSNO(-NSNOW+1:0) = 0. + ELSE + IF ( ( SNODEP(I,J) >= 0.025 ) .AND. ( SNODEP(I,J) <= 0.05 ) ) THEN + ISNOWXY(I,J) = -1 + DZSNO(0) = SNODEP(I,J) + ELSE IF ( ( SNODEP(I,J) > 0.05 ) .AND. ( SNODEP(I,J) <= 0.10 ) ) THEN + ISNOWXY(I,J) = -2 + DZSNO(-1) = SNODEP(I,J)/2. + DZSNO( 0) = SNODEP(I,J)/2. + ELSE IF ( (SNODEP(I,J) > 0.10 ) .AND. ( SNODEP(I,J) <= 0.25 ) ) THEN + ISNOWXY(I,J) = -2 + DZSNO(-1) = 0.05 + DZSNO( 0) = SNODEP(I,J) - DZSNO(-1) + ELSE IF ( ( SNODEP(I,J) > 0.25 ) .AND. ( SNODEP(I,J) <= 0.45 ) ) THEN + ISNOWXY(I,J) = -3 + DZSNO(-2) = 0.05 + DZSNO(-1) = 0.5*(SNODEP(I,J)-DZSNO(-2)) + DZSNO( 0) = 0.5*(SNODEP(I,J)-DZSNO(-2)) + ELSE IF ( SNODEP(I,J) > 0.45 ) THEN + ISNOWXY(I,J) = -3 + DZSNO(-2) = 0.05 + DZSNO(-1) = 0.20 + DZSNO( 0) = SNODEP(I,J) - DZSNO(-1) - DZSNO(-2) + ELSE + WRITE(*,*) "FATAL ERROR: Problem with the logic assigning snow layers." + STOP + !CALL wrf_error_fatal("Problem with the logic assigning snow layers.") + END IF + END IF + + TSNOXY (I,-NSNOW+1:0,J) = 0. + SNICEXY(I,-NSNOW+1:0,J) = 0. + SNLIQXY(I,-NSNOW+1:0,J) = 0. + DO IZ = ISNOWXY(I,J)+1 , 0 + TSNOXY(I,IZ,J) = TGXY(I,J) ! [k] + SNLIQXY(I,IZ,J) = 0.00 + SNICEXY(I,IZ,J) = 1.00 * DZSNO(IZ) * (SWE(I,J)/SNODEP(I,J)) ! [kg/m3] + END DO + + ! Assign local variable DZSNSO, the soil/snow layer thicknesses, for snow layers + DO IZ = ISNOWXY(I,J)+1 , 0 + DZSNSO(IZ) = -DZSNO(IZ) + END DO + + ! Assign local variable DZSNSO, the soil/snow layer thicknesses, for soil layers + DZSNSO(1) = ZSOIL(1) + DO IZ = 2 , NSOIL + DZSNSO(IZ) = (ZSOIL(IZ) - ZSOIL(IZ-1)) + END DO + + ! Assign ZSNSOXY, the layer depths, for soil and snow layers + ZSNSOXY(I,ISNOWXY(I,J)+1,J) = DZSNSO(ISNOWXY(I,J)+1) + DO IZ = ISNOWXY(I,J)+2 , NSOIL + ZSNSOXY(I,IZ,J) = ZSNSOXY(I,IZ-1,J) + DZSNSO(IZ) + ENDDO + + END DO + END DO + + END SUBROUTINE SNOW_INIT +!!!TLE: commented out groundwater_init and related modules to get simple Noah-MP test case up and running in ICAR. +!!! Uncomment these subroutines and integrate necessary modules from WRF (e.g. module_domain, module_dm, etc.) when the time comes. +!! ================================================================================================== +!! ---------------------------------------------------------------------- +! SUBROUTINE GROUNDWATER_INIT ( & +! & GRID, NSOIL , DZS, ISLTYP, IVGTYP, WTDDT , & +! & FDEPTH, TOPO, RIVERBED, EQWTD, RIVERCOND, PEXP , AREA ,WTD , & +! & SMOIS,SH2O, SMOISEQ, SMCWTDXY, DEEPRECHXY, RECHXY , & +! & QSLATXY, QRFSXY, QSPRINGSXY, & +! & rechclim , & +! & ids,ide, jds,jde, kds,kde, & +! & ims,ime, jms,jme, kms,kme, & +! & ips,ipe, jps,jpe, kps,kpe, & +! & its,ite, jts,jte, kts,kte ) +! +! +! USE NOAHMP_TABLES, ONLY : BEXP_TABLE,SMCMAX_TABLE,PSISAT_TABLE,SMCWLT_TABLE,DWSAT_TABLE,DKSAT_TABLE, & +! ISURBAN_TABLE, ISICE_TABLE ,ISWATER_TABLE +! USE module_sf_noahmp_groundwater, ONLY : LATERALFLOW +! USE module_domain, only: domain +!#if (EM_CORE == 1) +!#ifdef DM_PARALLEL +! USE module_dm , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks +! USE module_comm_dm , ONLY : halo_em_hydro_noahmp_sub +!#endif +!#endif +! +!! ---------------------------------------------------------------------- +! IMPLICIT NONE +!! ---------------------------------------------------------------------- +! +! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & +! & ims,ime, jms,jme, kms,kme, & +! & ips,ipe, jps,jpe, kps,kpe, & +! & its,ite, jts,jte, kts,kte +! TYPE(domain) , TARGET :: grid ! state +! INTEGER, INTENT(IN) :: NSOIL +! REAL, INTENT(IN) :: WTDDT +! REAL, INTENT(IN), DIMENSION(1:NSOIL) :: DZS +! INTEGER, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: ISLTYP, IVGTYP +! REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: FDEPTH, TOPO , AREA +! REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: rechclim +! REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme) :: RIVERCOND +! REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme) :: WTD, RIVERBED, EQWTD, PEXP +! REAL, DIMENSION( ims:ime , 1:nsoil, jms:jme ), & +! & INTENT(INOUT) :: SMOIS, & +! & SH2O, & +! & SMOISEQ +! REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme) :: & +! SMCWTDXY, & +! DEEPRECHXY, & +! RECHXY, & +! QSLATXY, & +! QRFSXY, & +! QSPRINGSXY +!! local +! INTEGER :: I,J,K,ITER,itf,jtf, NITER, NCOUNT,NS +! REAL :: BEXP,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT +! REAL :: FRLIQ,SMCEQDEEP +! REAL :: DELTAT,RCOND,TOTWATER +! REAL :: AA,BBB,CC,DD,DX,FUNC,DFUNC,DDZ,EXPON,SMC,FLUX +! REAL, DIMENSION(1:NSOIL) :: SMCEQ,ZSOIL +! REAL, DIMENSION( ims:ime, jms:jme ) :: QLAT, QRF +! INTEGER, DIMENSION( ims:ime, jms:jme ) :: LANDMASK !-1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations +! +! ! Given the soil layer thicknesses (in DZS), calculate the soil layer +! ! depths from the surface. +! ZSOIL(1) = -DZS(1) ! negative +! DO NS=2, NSOIL +! ZSOIL(NS) = ZSOIL(NS-1) - DZS(NS) +! END DO +! +! +! itf=min0(ite,ide-1) +! jtf=min0(jte,jde-1) +! +! +! WHERE(IVGTYP.NE.ISWATER_TABLE.AND.IVGTYP.NE.ISICE_TABLE) +! LANDMASK=1 +! ELSEWHERE +! LANDMASK=-1 +! ENDWHERE +! +! PEXP = 1.0 +! +! DELTAT=365.*24*3600. !1 year +! +!!readjust the raw aggregated water table from hires, so that it is better compatible with topography +! +!!use WTD here, to use the lateral communication routine +! WTD=EQWTD +! +! NCOUNT=0 +! +! DO NITER=1,500 +! +!#if (EM_CORE == 1) +!#ifdef DM_PARALLEL +!# include "HALO_EM_HYDRO_NOAHMP.inc" +!#endif +!#endif +! +!!Calculate lateral flow +! +!IF(NCOUNT.GT.0.OR.NITER.eq.1)THEN +! QLAT = 0. +! CALL LATERALFLOW(ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & +! ,ids,ide,jds,jde,kds,kde & +! ,ims,ime,jms,jme,kms,kme & +! ,its,ite,jts,jte,kts,kte ) +! +! NCOUNT=0 +! DO J=jts,jtf +! DO I=its,itf +! IF(LANDMASK(I,J).GT.0)THEN +! IF(QLAT(i,j).GT.1.e-2)THEN +! NCOUNT=NCOUNT+1 +! WTD(i,j)=min(WTD(i,j)+0.25,0.) +! ENDIF +! ENDIF +! ENDDO +! ENDDO +!ENDIF +! +! ENDDO +! +!#if (EM_CORE == 1) +!#ifdef DM_PARALLEL +!# include "HALO_EM_HYDRO_NOAHMP.inc" +!#endif +!#endif +! +!EQWTD=WTD +! +!!after adjusting, where qlat > 1cm/year now wtd is at the surface. +!!it may still happen that qlat + rech > 0 and eqwtd-rbed <0. There the wtd can +!!rise to the surface (poor drainage) but the et will then increase. +! +! +!!now, calculate rcond: +! +! DO J=jts,jtf +! DO I=its,itf +! +! DDZ = EQWTD(I,J)- ( RIVERBED(I,J)-TOPO(I,J) ) +!!dont allow riverbed above water table +! IF(DDZ.LT.0.)then +! RIVERBED(I,J)=TOPO(I,J)+EQWTD(I,J) +! DDZ=0. +! ENDIF +! +! +! TOTWATER = AREA(I,J)*(QLAT(I,J)+RECHCLIM(I,J)*0.001)/DELTAT +! +! IF (TOTWATER.GT.0) THEN +! RIVERCOND(I,J) = TOTWATER / MAX(DDZ,0.05) +! ELSE +! RIVERCOND(I,J)=0.01 +!!and make riverbed equal to eqwtd, otherwise qrf might be too big... +! RIVERBED(I,J)=TOPO(I,J)+EQWTD(I,J) +! ENDIF +! +! +! ENDDO +! ENDDO +! +!!make riverbed to be height down from the surface instead of above sea level +! +! RIVERBED = min( RIVERBED-TOPO, 0.) +! +!!now recompute lateral flow and flow to rivers to initialize deep soil moisture +! +! DELTAT = WTDDT * 60. !timestep in seconds for this calculation +! +! +!!recalculate lateral flow +! +! QLAT = 0. +! CALL LATERALFLOW(ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & +! ,ids,ide,jds,jde,kds,kde & +! ,ims,ime,jms,jme,kms,kme & +! ,its,ite,jts,jte,kts,kte ) +! +!!compute flux from grounwater to rivers in the cell +! +! DO J=jts,jtf +! DO I=its,itf +! IF(LANDMASK(I,J).GT.0)THEN +! IF(WTD(I,J) .GT. RIVERBED(I,J) .AND. EQWTD(I,J) .GT. RIVERBED(I,J)) THEN +! RCOND = RIVERCOND(I,J) * EXP(PEXP(I,J)*(WTD(I,J)-EQWTD(I,J))) +! ELSE +! RCOND = RIVERCOND(I,J) +! ENDIF +! QRF(I,J) = RCOND * (WTD(I,J)-RIVERBED(I,J)) * DELTAT/AREA(I,J) +!!for now, dont allow it to go from river to groundwater +! QRF(I,J) = MAX(QRF(I,J),0.) +! ELSE +! QRF(I,J) = 0. +! ENDIF +! ENDDO +! ENDDO +! +!!now compute eq. soil moisture, change soil moisture to be compatible with the water table and compute deep soil moisture +! +! DO J = jts,jtf +! DO I = its,itf +! BEXP = BEXP_TABLE(ISLTYP(I,J)) +! SMCMAX = SMCMAX_TABLE(ISLTYP(I,J)) +! SMCWLT = SMCWLT_TABLE(ISLTYP(I,J)) +! IF(IVGTYP(I,J)==ISURBAN_TABLE)THEN +! SMCMAX = 0.45 +! SMCWLT = 0.40 +! ENDIF +! DWSAT = DWSAT_TABLE(ISLTYP(I,J)) +! DKSAT = DKSAT_TABLE(ISLTYP(I,J)) +! PSISAT = -PSISAT_TABLE(ISLTYP(I,J)) +! IF ( ( BEXP > 0.0 ) .AND. ( smcmax > 0.0 ) .AND. ( -psisat > 0.0 ) ) THEN +! !initialize equilibrium soil moisture for water table diagnostic +! CALL EQSMOISTURE(NSOIL , ZSOIL , SMCMAX , SMCWLT ,DWSAT, DKSAT ,BEXP , & !in +! SMCEQ ) !out +! +! SMOISEQ (I,1:NSOIL,J) = SMCEQ (1:NSOIL) +! +! +! !make sure that below the water table the layers are saturated and initialize the deep soil moisture +! IF(WTD(I,J) < ZSOIL(NSOIL)-DZS(NSOIL)) THEN +! +!!initialize deep soil moisture so that the flux compensates qlat+qrf +!!use Newton-Raphson method to find soil moisture +! +! EXPON = 2. * BEXP + 3. +! DDZ = ZSOIL(NSOIL) - WTD(I,J) +! CC = PSISAT/DDZ +! FLUX = (QLAT(I,J)-QRF(I,J))/DELTAT +! +! SMC = 0.5 * SMCMAX +! +! DO ITER = 1, 100 +! DD = (SMC+SMCMAX)/(2.*SMCMAX) +! AA = -DKSAT * DD ** EXPON +! BBB = CC * ( (SMCMAX/SMC)**BEXP - 1. ) + 1. +! FUNC = AA * BBB - FLUX +! DFUNC = -DKSAT * (EXPON/(2.*SMCMAX)) * DD ** (EXPON - 1.) * BBB & +! + AA * CC * (-BEXP) * SMCMAX ** BEXP * SMC ** (-BEXP-1.) +! +! DX = FUNC/DFUNC +! SMC = SMC - DX +! IF ( ABS (DX) < 1.E-6)EXIT +! ENDDO +! +! SMCWTDXY(I,J) = MAX(SMC,1.E-4) +! +! ELSEIF(WTD(I,J) < ZSOIL(NSOIL))THEN +! SMCEQDEEP = SMCMAX * ( PSISAT / ( PSISAT - DZS(NSOIL) ) ) ** (1./BEXP) +!! SMCEQDEEP = MAX(SMCEQDEEP,SMCWLT) +! SMCEQDEEP = MAX(SMCEQDEEP,1.E-4) +! SMCWTDXY(I,J) = SMCMAX * ( WTD(I,J) - (ZSOIL(NSOIL)-DZS(NSOIL))) + & +! SMCEQDEEP * (ZSOIL(NSOIL) - WTD(I,J)) +! +! ELSE !water table within the resolved layers +! SMCWTDXY(I,J) = SMCMAX +! DO K=NSOIL,2,-1 +! IF(WTD(I,J) .GE. ZSOIL(K-1))THEN +! FRLIQ = SH2O(I,K,J) / SMOIS(I,K,J) +! SMOIS(I,K,J) = SMCMAX +! SH2O(I,K,J) = SMCMAX * FRLIQ +! ELSE +! IF(SMOIS(I,K,J).LT.SMCEQ(K))THEN +! WTD(I,J) = ZSOIL(K) +! ELSE +! WTD(I,J) = ( SMOIS(I,K,J)*DZS(K) - SMCEQ(K)*ZSOIL(K-1) + SMCMAX*ZSOIL(K) ) / & +! (SMCMAX - SMCEQ(K)) +! ENDIF +! EXIT +! ENDIF +! ENDDO +! ENDIF +! ELSE +! SMOISEQ (I,1:NSOIL,J) = SMCMAX +! SMCWTDXY(I,J) = SMCMAX +! WTD(I,J) = 0. +! ENDIF +! +!!zero out some arrays +! +! DEEPRECHXY(I,J) = 0. +! RECHXY(I,J) = 0. +! QSLATXY(I,J) = 0. +! QRFSXY(I,J) = 0. +! QSPRINGSXY(I,J) = 0. +! +! ENDDO +! ENDDO +! +! +! +! +! END SUBROUTINE GROUNDWATER_INIT +! ================================================================================================== +! ---------------------------------------------------------------------- +! SUBROUTINE EQSMOISTURE(NSOIL , ZSOIL , SMCMAX , SMCWLT, DWSAT , DKSAT ,BEXP , & !in +! SMCEQ ) !out +!! ---------------------------------------------------------------------- +! IMPLICIT NONE +!! ---------------------------------------------------------------------- +!! input +! INTEGER, INTENT(IN) :: NSOIL !no. of soil layers +! REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] +! REAL, INTENT(IN) :: SMCMAX , SMCWLT, BEXP , DWSAT, DKSAT +!!output +! REAL, DIMENSION( 1:NSOIL), INTENT(OUT) :: SMCEQ !equilibrium soil water content [m3/m3] +!!local +! INTEGER :: K , ITER +! REAL :: DDZ , SMC, FUNC, DFUNC , AA, BB , EXPON, DX +! +!!gmmcompute equilibrium soil moisture content for the layer when wtd=zsoil(k) +! +! +! DO K=1,NSOIL +! +! IF ( K == 1 )THEN +! DDZ = -ZSOIL(K+1) * 0.5 +! ELSEIF ( K < NSOIL ) THEN +! DDZ = ( ZSOIL(K-1) - ZSOIL(K+1) ) * 0.5 +! ELSE +! DDZ = ZSOIL(K-1) - ZSOIL(K) +! ENDIF +! +!!use Newton-Raphson method to find eq soil moisture +! +! EXPON = BEXP +1. +! AA = DWSAT/DDZ +! BB = DKSAT / SMCMAX ** EXPON +! +! SMC = 0.5 * SMCMAX +! +! DO ITER = 1, 100 +! FUNC = (SMC - SMCMAX) * AA + BB * SMC ** EXPON +! DFUNC = AA + BB * EXPON * SMC ** BEXP +! +! DX = FUNC/DFUNC +! SMC = SMC - DX +! IF ( ABS (DX) < 1.E-6)EXIT +! ENDDO +! +!! SMCEQ(K) = MIN(MAX(SMC,SMCWLT),SMCMAX*0.99) +! SMCEQ(K) = MIN(MAX(SMC,1.E-4),SMCMAX*0.99) +! ENDDO +! +!END SUBROUTINE EQSMOISTURE +! +!! gecros initialization routines + +SUBROUTINE gecros_init(xlat,hti,rdi,clvi,crti,nlvi,laii,nrti,slnbi,state_gecros) +implicit none +REAL, INTENT(IN) :: HTI +REAL, INTENT(IN) :: RDI +REAL, INTENT(IN) :: CLVI +REAL, INTENT(IN) :: CRTI +REAL, INTENT(IN) :: NLVI +REAL, INTENT(IN) :: LAII +REAL, INTENT(IN) :: NRTI +REAL, INTENT(IN) :: SLNBI +REAL, INTENT(IN) :: XLAT +REAL, DIMENSION(1:60), INTENT(INOUT) :: STATE_GECROS + + !Inititalization of Gecros variables + STATE_GECROS(1) = 0. !DS + STATE_GECROS(2) = 0. !CTDURDI, HTI, CLVI, CRTI, NLVI, LAII, NRTI, SLNBI, + STATE_GECROS(3) = 0. !CVDU + STATE_GECROS(4) = CLVI !CLV + STATE_GECROS(5) = 0. !CLVD + STATE_GECROS(6) = 0. !CSST + STATE_GECROS(7) = 0. !CSO + STATE_GECROS(8) = CRTI !CSRT + STATE_GECROS(9) = 0. !CRTD + STATE_GECROS(10) = 0. !CLVDS + STATE_GECROS(11) = NRTI !NRT + STATE_GECROS(12) = 0. !NST + STATE_GECROS(13) = NLVI !NLV + STATE_GECROS(14) = 0. !NSO + STATE_GECROS(15) = NLVI !TNLV + STATE_GECROS(16) = 0. !NLVD + STATE_GECROS(17) = 0. !NRTD + STATE_GECROS(18) = 0. !CRVS + STATE_GECROS(19) = 0. !CRVR + STATE_GECROS(20) = 0. !NREOE + STATE_GECROS(21) = 0. !NREOF + STATE_GECROS(22) = 0. !DCDSR + STATE_GECROS(23) = 0. !DCDTR + STATE_GECROS(24) = SLNBI !SLNB + STATE_GECROS(25) = LAII !LAIC + STATE_GECROS(26) = 0. !RMUL + STATE_GECROS(27) = 0. !NDEMP + STATE_GECROS(28) = 0. !NSUPP + STATE_GECROS(29) = 0. !NFIXT + STATE_GECROS(30) = 0. !NFIXR + STATE_GECROS(31) = 0. !DCDTP + STATE_GECROS(32) = 0.01 !HTI + STATE_GECROS(33) = RDI !RDI + STATE_GECROS(34) = 0. !TPCAN + STATE_GECROS(35) = 0. !TRESP + STATE_GECROS(36) = 0. !TNUPT + STATE_GECROS(37) = 0. !LITNT + STATE_GECROS(38) = 0. !daysSinceDS1 + STATE_GECROS(39) = 0. !daysSinceDS2 + STATE_GECROS(40) = -1. !drilled -1:false, 1:true + STATE_GECROS(41) = -1. !emerged -1:false, 1:true + STATE_GECROS(42) = -1. !harvested -1:false, 1:true + STATE_GECROS(43) = 0. !TTEM + STATE_GECROS(44) = XLAT !GLAT + STATE_GECROS(45) = 0. !WSO + STATE_GECROS(46) = 0. !WSTRAW + STATE_GECROS(47) = 0. !GrainNC + STATE_GECROS(48) = 0. !StrawNC + STATE_GECROS(49) = 0.01 !GLAI + STATE_GECROS(50) = 0.01 !TLAI + STATE_GECROS(51) = HTI !Fields 51-58 set for reinitialization + STATE_GECROS(52) = RDI + STATE_GECROS(53) = CLVI + STATE_GECROS(54) = CRTI + STATE_GECROS(55) = NRTI + STATE_GECROS(56) = NLVI + STATE_GECROS(57) = SLNBI + STATE_GECROS(58) = LAII + +END SUBROUTINE gecros_init + +SUBROUTINE gecros_reinit(STATE_GECROS) +implicit none +REAL, DIMENSION(1:60), INTENT(INOUT) :: STATE_GECROS + + !Re-inititalization of Gecros variables after harvest + STATE_GECROS(1) = 0. !DS + STATE_GECROS(2) = 0. !CTDU + STATE_GECROS(3) = 0. !CVDU + STATE_GECROS(4) = STATE_GECROS(53) !CLV + STATE_GECROS(5) = 0. !CLVD + STATE_GECROS(6) = 0. !CSST + STATE_GECROS(7) = 0. !CSO + STATE_GECROS(8) = STATE_GECROS(54) !CRT + STATE_GECROS(9) = 0. !CRTD + STATE_GECROS(10) = 0. !CLVDS + STATE_GECROS(11) = STATE_GECROS(55)!NRT + STATE_GECROS(12) = 0. !NST + STATE_GECROS(13) = STATE_GECROS(56)!NLV + STATE_GECROS(14) = 0. !NSO + STATE_GECROS(15) = STATE_GECROS(56)!TNLV + STATE_GECROS(16) = 0. !NLVD + STATE_GECROS(17) = 0. !NRTD + STATE_GECROS(18) = 0. !CRVS + STATE_GECROS(19) = 0. !CRVR + STATE_GECROS(20) = 0. !NREOE + STATE_GECROS(21) = 0. !NREOF + STATE_GECROS(22) = 0. !DCDSR + STATE_GECROS(23) = 0. !DCDTR + STATE_GECROS(24) = STATE_GECROS(57)!SLNB + STATE_GECROS(25) = STATE_GECROS(58)!LAIC + STATE_GECROS(26) = 0. !RMUL + STATE_GECROS(27) = 0. !NDEMP + STATE_GECROS(28) = 0. !NSUPP + STATE_GECROS(29) = 0. !NFIXT + STATE_GECROS(30) = 0. !NFIXR + STATE_GECROS(31) = 0. !DCDTP + STATE_GECROS(32) = STATE_GECROS(51)!HT + STATE_GECROS(33) = STATE_GECROS(52)!ROOTD + STATE_GECROS(34) = 0. !TPCAN + STATE_GECROS(35) = 0. !TRESP + STATE_GECROS(36) = 0. !TNUPT + STATE_GECROS(37) = 0. !LITNT + STATE_GECROS(38) = 0. !daysSinceDS1 + STATE_GECROS(39) = 0. !daysSinceDS2 + STATE_GECROS(40) = -1. !drilled -1:false, 1:true + STATE_GECROS(41) = -1. !emerged -1:false, 1:true + STATE_GECROS(42) = 1. !harvested -1:false, 1:true + STATE_GECROS(43) = 0. !TTEM + STATE_GECROS(45) = 0. !WSO + STATE_GECROS(46) = 0. !WSTRAW + STATE_GECROS(47) = 0. !GrainNC + STATE_GECROS(48) = 0. !StrawNC + STATE_GECROS(49) = 0.01 !GLAI + STATE_GECROS(50) = 0.01 !TLAI + +END SUBROUTINE gecros_reinit + +!***Function for HARVEST DATES: + +!Determine if crop is to be harvested today +!function to be called once a day +!return codes: 0 - no, 1- yes +!requires two counters 'daysSinceDS2', 'daysSinceDS1' , zero-initialized to be maintained within caller +!STATE_GECROS(1) = current DS +!STATE_GECROS(38)=daysSinceDS1 +!STATE_GECROS(39)=daysSinceDS2 + +function checkIfHarvest(STATE_GECROS, DT, harvestDS1, harvestDS2, harvestDS1ExtraDays, harvestDS2ExtraDays) +implicit none +real :: DT, harvestDS1, harvestDS2 +real :: daysSinceDS1, daysSinceDS2 +real :: harvestDS1ExtraDays, harvestDS2ExtraDays +integer :: checkIfHarvest +REAL, DIMENSION(1:60), INTENT(INOUT) :: STATE_GECROS + + + !***check whether maturity (DS1) has been reached + if (STATE_GECROS(1) >= harvestDS1) then + + if (STATE_GECROS(38) >= harvestDS1ExtraDays) then + checkIfHarvest=1 + !if we are > DS1, but not over the limit, increase the counter of days + else + STATE_GECROS(38) = STATE_GECROS(38) + DT/86400. + endif + else + + !if maturity has not been reached, but we are close (> DS2) + !check the number of days for which we have been > DS2 + !and harvest in case we are over the limit given for that stage + !(in case that maturity will not be reached at all) + + checkIfHarvest=0 + if (STATE_GECROS(1) >= harvestDS2 ) then + + if (STATE_GECROS(39) >= harvestDS2ExtraDays) then + checkIfHarvest=1 + else !if we are > DS2, but not over the limit, increase the counter of days + STATE_GECROS(39) = STATE_GECROS(39) + DT/86400. + checkIfHarvest=0 + endif + endif + endif + return +end function checkIfHarvest + +!!!!TLE: commenting out urban functionality in order to get simplified Noah-MP running in ICAR. +!!!! Uncomment urban subroutines and incorporate modules from WRF when setting up to run urban model. +!!!! A call to the urban subroutines will also need to be implemented in the ICAR lsm_driver +!!------------------------------------------------------------------------------------------ +! +! SUBROUTINE noahmp_urban(sf_urban_physics, NSOIL, IVGTYP, ITIMESTEP, & ! IN : Model configuration +! DT, COSZ_URB2D, XLAT_URB2D, & ! IN : Time/Space-related +! T3D, QV3D, U_PHY, V_PHY, SWDOWN, & ! IN : Forcing +! SWDDIR, SWDDIF, & +! GLW, P8W3D, RAINBL, DZ8W, ZNT, & ! IN : Forcing +! TSK, HFX, QFX, LH, GRDFLX, & ! IN/OUT : LSM +! ALBEDO, EMISS, QSFC, & ! IN/OUT : LSM +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte, & +! cmr_sfcdif, chr_sfcdif, cmc_sfcdif, & +! chc_sfcdif, cmgr_sfcdif, chgr_sfcdif, & +! tr_urb2d, tb_urb2d, tg_urb2d, & !H urban +! tc_urb2d, qc_urb2d, uc_urb2d, & !H urban +! xxxr_urb2d, xxxb_urb2d, xxxg_urb2d, xxxc_urb2d, & !H urban +! trl_urb3d, tbl_urb3d, tgl_urb3d, & !H urban +! sh_urb2d, lh_urb2d, g_urb2d, rn_urb2d, ts_urb2d, & !H urban +! psim_urb2d, psih_urb2d, u10_urb2d, v10_urb2d, & !O urban +! GZ1OZ0_urb2d, AKMS_URB2D, & !O urban +! th2_urb2d, q2_urb2d, ust_urb2d, & !O urban +! declin_urb, omg_urb2d, & !I urban +! num_roof_layers,num_wall_layers,num_road_layers, & !I urban +! dzr, dzb, dzg, & !I urban +! cmcr_urb2d, tgr_urb2d, tgrl_urb3d, smr_urb3d, & !H urban +! drelr_urb2d, drelb_urb2d, drelg_urb2d, & !H urban +! flxhumr_urb2d, flxhumb_urb2d, flxhumg_urb2d, & !H urban +! julian, julyr, & !H urban +! frc_urb2d, utype_urb2d, & !I urban +! chs, chs2, cqs2, & !H +! num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & !I multi-layer urban +! urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & !I multi-layer urban +! urban_map_gbd, urban_map_fbd, urban_map_zgrd, & !I multi-layer urban +! num_urban_hi, & !I multi-layer urban +! trb_urb4d, tw1_urb4d, tw2_urb4d, tgb_urb4d, & !H multi-layer urban +! tlev_urb3d, qlev_urb3d, & !H multi-layer urban +! tw1lev_urb3d, tw2lev_urb3d, & !H multi-layer urban +! tglev_urb3d, tflev_urb3d, & !H multi-layer urban +! sf_ac_urb3d, lf_ac_urb3d, cm_ac_urb3d, & !H multi-layer urban +! sfvent_urb3d, lfvent_urb3d, & !H multi-layer urban +! sfwin1_urb3d, sfwin2_urb3d, & !H multi-layer urban +! sfw1_urb3d, sfw2_urb3d, sfr_urb3d, sfg_urb3d, & !H multi-layer urban +! ep_pv_urb3d, t_pv_urb3d, & !RMS +! trv_urb4d, qr_urb4d, qgr_urb3d, tgr_urb3d, & !RMS +! drain_urb4d, draingr_urb3d, sfrv_urb3d, lfrv_urb3d, & !RMS +! dgr_urb3d, dg_urb3d, lfr_urb3d, lfg_urb3d, & !RMS +! lp_urb2d, hi_urb2d, lb_urb2d, hgt_urb2d, & !H multi-layer urban +! mh_urb2d, stdh_urb2d, lf_urb2d, & !SLUCM +! th_phy, rho, p_phy, ust, & !I multi-layer urban +! gmt, julday, xlong, xlat, & !I multi-layer urban +! a_u_bep, a_v_bep, a_t_bep, a_q_bep, & !O multi-layer urban +! a_e_bep, b_u_bep, b_v_bep, & !O multi-layer urban +! b_t_bep, b_q_bep, b_e_bep, dlg_bep, & !O multi-layer urban +! dl_u_bep, sf_bep, vl_bep & !O multi-layer urban +! ) +! +! USE module_sf_urban, only: urban +! USE module_sf_bep, only: bep +! USE module_sf_bep_bem, only: bep_bem +! USE module_ra_gfdleta, only: cal_mon_day +! USE NOAHMP_TABLES, ONLY: ISURBAN_TABLE +! USE module_model_constants, only: KARMAN, CP, XLV +!!---------------------------------------------------------------- +! IMPLICIT NONE +!!---------------------------------------------------------------- +! +! INTEGER, INTENT(IN ) :: sf_urban_physics ! urban physics option +! INTEGER, INTENT(IN ) :: NSOIL ! number of soil layers +! INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: IVGTYP ! vegetation type +! INTEGER, INTENT(IN ) :: ITIMESTEP ! timestep number +! REAL, INTENT(IN ) :: DT ! timestep [s] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: COSZ_URB2D +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT_URB2D +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: T3D ! 3D atmospheric temperature valid at mid-levels [K] +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: QV3D ! 3D water vapor mixing ratio [kg/kg_dry] +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: U_PHY ! 3D U wind component [m/s] +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: V_PHY ! 3D V wind component [m/s] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SWDOWN ! solar down at surface [W m-2] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SWDDIF ! solar down at surface [W m-2] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SWDDIR ! solar down at surface [W m-2] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: GLW ! longwave down at surface [W m-2] +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: P8W3D ! 3D pressure, valid at interface [Pa] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: RAINBL ! total input precipitation [mm] +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: DZ8W ! thickness of atmo layers [m] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZNT ! combined z0 sent to coupled model +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TSK ! surface radiative temperature [K] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: HFX ! sensible heat flux [W m-2] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QFX ! latent heat flux [kg s-1 m-2] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH ! latent heat flux [W m-2] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: GRDFLX ! ground/snow heat flux [W m-2] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ALBEDO ! total grid albedo [] +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: EMISS ! surface bulk emissivity +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QSFC ! bulk surface mixing ratio +! +! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ! d -> domain +! & ims,ime, jms,jme, kms,kme, & ! m -> memory +! & its,ite, jts,jte, kts,kte ! t -> tile +! +!! input variables surface_driver --> lsm +! +! INTEGER, INTENT(IN ) :: num_roof_layers +! INTEGER, INTENT(IN ) :: num_wall_layers +! INTEGER, INTENT(IN ) :: num_road_layers +! +! INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: UTYPE_URB2D +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: FRC_URB2D +! +! REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN ) :: DZR +! REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN ) :: DZB +! REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN ) :: DZG +! REAL, OPTIONAL, INTENT(IN ) :: DECLIN_URB +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: OMG_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: TH_PHY +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: P_PHY +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: RHO +! +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHS, CHS2, CQS2 +! +! INTEGER, INTENT(IN ) :: julian, julyr !urban +! +!! local variables lsm --> urban +! +! INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3] +! REAL :: TA_URB ! potential temp at 1st atmospheric level [K] +! REAL :: QA_URB ! mixing ratio at 1st atmospheric level [kg/kg] +! REAL :: UA_URB ! wind speed at 1st atmospheric level [m/s] +! REAL :: U1_URB ! u at 1st atmospheric level [m/s] +! REAL :: V1_URB ! v at 1st atmospheric level [m/s] +! REAL :: SSG_URB ! downward total short wave radiation [W/m/m] +! REAL :: LLG_URB ! downward long wave radiation [W/m/m] +! REAL :: RAIN_URB ! precipitation [mm/h] +! REAL :: RHOO_URB ! air density [kg/m^3] +! REAL :: ZA_URB ! first atmospheric level [m] +! REAL :: DELT_URB ! time step [s] +! REAL :: SSGD_URB ! downward direct short wave radiation [W/m/m] +! REAL :: SSGQ_URB ! downward diffuse short wave radiation [W/m/m] +! REAL :: XLAT_URB ! latitude [deg] +! REAL :: COSZ_URB ! cosz +! REAL :: OMG_URB ! hour angle +! REAL :: ZNT_URB ! roughness length [m] +! REAL :: TR_URB +! REAL :: TB_URB +! REAL :: TG_URB +! REAL :: TC_URB +! REAL :: QC_URB +! REAL :: UC_URB +! REAL :: XXXR_URB +! REAL :: XXXB_URB +! REAL :: XXXG_URB +! REAL :: XXXC_URB +! REAL, DIMENSION(1:num_roof_layers) :: TRL_URB ! roof layer temp [K] +! REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K] +! REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K] +! LOGICAL :: LSOLAR_URB +! +!!===hydrological variable for single layer UCM=== +! +! INTEGER :: jmonth, jday +! REAL :: DRELR_URB +! REAL :: DRELB_URB +! REAL :: DRELG_URB +! REAL :: FLXHUMR_URB +! REAL :: FLXHUMB_URB +! REAL :: FLXHUMG_URB +! REAL :: CMCR_URB +! REAL :: TGR_URB +! +! REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture +! REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K] +! +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D +! +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D +! +! +!! state variable surface_driver <--> lsm <--> urban +! +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D +! +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D +! +!! output variable lsm --> surface_driver +! +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D +! +! +!! output variables urban --> lsm +! +! REAL :: TS_URB ! surface radiative temperature [K] +! REAL :: QS_URB ! surface humidity [-] +! REAL :: SH_URB ! sensible heat flux [W/m/m] +! REAL :: LH_URB ! latent heat flux [W/m/m] +! REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic [kg/m/m/s] +! REAL :: SW_URB ! upward short wave radiation flux [W/m/m] +! REAL :: ALB_URB ! time-varying albedo [fraction] +! REAL :: LW_URB ! upward long wave radiation flux [W/m/m] +! REAL :: G_URB ! heat flux into the ground [W/m/m] +! REAL :: RN_URB ! net radiation [W/m/m] +! REAL :: PSIM_URB ! shear f for momentum [-] +! REAL :: PSIH_URB ! shear f for heat [-] +! REAL :: GZ1OZ0_URB ! shear f for heat [-] +! REAL :: U10_URB ! wind u component at 10 m [m/s] +! REAL :: V10_URB ! wind v component at 10 m [m/s] +! REAL :: TH2_URB ! potential temperature at 2 m [K] +! REAL :: Q2_URB ! humidity at 2 m [-] +! REAL :: CHS_URB +! REAL :: CHS2_URB +! REAL :: UST_URB +! +!! NUDAPT Parameters urban --> lam +! +! REAL :: mh_urb +! REAL :: stdh_urb +! REAL :: lp_urb +! REAL :: hgt_urb +! REAL, DIMENSION(4) :: lf_urb +! +!! Local variables +! +! INTEGER :: I,J,K +! REAL :: Q1 +! +!! Noah UA changes +! +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF +! +!! Variables for multi-layer UCM +! +! REAL, OPTIONAL, INTENT(IN ) :: GMT +! INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT, XLONG +! INTEGER, INTENT(IN ) :: num_urban_ndm +! INTEGER, INTENT(IN ) :: urban_map_zrd +! INTEGER, INTENT(IN ) :: urban_map_zwd +! INTEGER, INTENT(IN ) :: urban_map_gd +! INTEGER, INTENT(IN ) :: urban_map_zd +! INTEGER, INTENT(IN ) :: urban_map_zdf +! INTEGER, INTENT(IN ) :: urban_map_bd +! INTEGER, INTENT(IN ) :: urban_map_wd +! INTEGER, INTENT(IN ) :: urban_map_gbd +! INTEGER, INTENT(IN ) :: urban_map_fbd +! INTEGER, INTENT(IN ) :: urban_map_zgrd +! INTEGER, INTENT(IN ) :: NUM_URBAN_HI +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN ) :: hi_urb2d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lp_urb2d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lb_urb2d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: hgt_urb2d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mh_urb2d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: stdh_urb2d +! REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ), INTENT(IN ) :: lf_urb2d +! +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: tlev_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: trv_urb4d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: qr_urb4d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: qgr_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: tgr_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: drain_urb4d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: sfrv_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfrv_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !GRZ +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: a_u_bep !Implicit momemtum component X-direction +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: a_v_bep !Implicit momemtum component Y-direction +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: a_t_bep !Implicit component pot. temperature +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: a_q_bep !Implicit momemtum component X-direction +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: a_e_bep !Implicit component TKE +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: b_u_bep !Explicit momentum component X-direction +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: b_v_bep !Explicit momentum component Y-direction +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: b_t_bep !Explicit component pot. temperature +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: b_q_bep !Implicit momemtum component Y-direction +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: b_e_bep !Explicit component TKE +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: vl_bep !Fraction air volume in grid cell +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: dlg_bep !Height above ground +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: sf_bep !Fraction air at the face of grid cell +! REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: dl_u_bep !Length scale +! +!! Local variables for multi-layer UCM +! +! REAL, DIMENSION( its:ite, jts:jte) :: HFX_RURAL,GRDFLX_RURAL ! ,LH_RURAL,RN_RURAL +! REAL, DIMENSION( its:ite, jts:jte) :: QFX_RURAL ! ,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL +! REAL, DIMENSION( its:ite, jts:jte) :: ALB_RURAL,EMISS_RURAL,TSK_RURAL ! ,UST_RURAL +! REAL, DIMENSION( its:ite, jts:jte) :: HFX_URB,UMOM_URB,VMOM_URB +! REAL, DIMENSION( its:ite, jts:jte) :: QFX_URB +! REAL, DIMENSION( its:ite, jts:jte) :: EMISS_URB +! REAL, DIMENSION( its:ite, jts:jte) :: RL_UP_URB +! REAL, DIMENSION( its:ite, jts:jte) :: RS_ABS_URB +! REAL, DIMENSION( its:ite, jts:jte) :: GRDFLX_URB +! +! REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM +! REAL :: r1,r2,r3 +! REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB +! REAL :: frc_urb,lb_urb +! REAL :: check +! +! character(len=80) :: message +! +! DO J=JTS,JTE +! DO I=ITS,ITE +! HFX_RURAL(I,J) = HFX(I,J) +! QFX_RURAL(I,J) = QFX(I,J) +! GRDFLX_RURAL(I,J) = GRDFLX(I,J) +! EMISS_RURAL(I,J) = EMISS(I,J) +! TSK_RURAL(I,J) = TSK(I,J) +! ALB_RURAL(I,J) = ALBEDO(I,J) +! END DO +! END DO +! +!IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block +! +!!-------------------------------------- +!! URBAN CANOPY MODEL START +!!-------------------------------------- +! +!JLOOP : DO J = jts, jte +! +!ILOOP : DO I = its, ite +! +! +! IF( IVGTYP(I,J) == ISURBAN_TABLE .or. IVGTYP(I,J) == 31 .or. & +! IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN +! +! UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) +! +! TA_URB = T3D(I,1,J) ! [K] +! QA_URB = QV3D(I,1,J)/(1.0+QV3D(I,1,J)) ! [kg/kg] +! UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.) +! U1_URB = U_PHY(I,1,J) +! V1_URB = V_PHY(I,1,J) +! IF(UA_URB < 1.) UA_URB=1. ! [m/s] +! SSG_URB = SWDOWN(I,J) ! [W/m/m] +! SSGD_URB = 0.8*SWDOWN(I,J) ! [W/m/m] +! SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] +! LLG_URB = GLW(I,J) ! [W/m/m] +! RAIN_URB = RAINBL(I,J) ! [mm] +! RHOO_URB = (P8W3D(I,KTS+1,J)+P8W3D(I,KTS,J))*0.5 / (287.04 * TA_URB * (1.0+ 0.61 * QA_URB)) ![kg/m/m/m] +! ZA_URB = 0.5*DZ8W(I,1,J) ! [m] +! DELT_URB = DT ! [sec] +! XLAT_URB = XLAT_URB2D(I,J) ! [deg] +! COSZ_URB = COSZ_URB2D(I,J) +! OMG_URB = OMG_URB2D(I,J) +! ZNT_URB = ZNT(I,J) +! +! LSOLAR_URB = .FALSE. +! +! TR_URB = TR_URB2D(I,J) +! TB_URB = TB_URB2D(I,J) +! TG_URB = TG_URB2D(I,J) +! TC_URB = TC_URB2D(I,J) +! QC_URB = QC_URB2D(I,J) +! UC_URB = UC_URB2D(I,J) +! +! TGR_URB = TGR_URB2D(I,J) +! CMCR_URB = CMCR_URB2D(I,J) +! FLXHUMR_URB = FLXHUMR_URB2D(I,J) +! FLXHUMB_URB = FLXHUMB_URB2D(I,J) +! FLXHUMG_URB = FLXHUMG_URB2D(I,J) +! DRELR_URB = DRELR_URB2D(I,J) +! DRELB_URB = DRELB_URB2D(I,J) +! DRELG_URB = DRELG_URB2D(I,J) +! +! DO K = 1,num_roof_layers +! TRL_URB(K) = TRL_URB3D(I,K,J) +! SMR_URB(K) = SMR_URB3D(I,K,J) +! TGRL_URB(K)= TGRL_URB3D(I,K,J) +! END DO +! +! DO K = 1,num_wall_layers +! TBL_URB(K) = TBL_URB3D(I,K,J) +! END DO +! +! DO K = 1,num_road_layers +! TGL_URB(K) = TGL_URB3D(I,K,J) +! END DO +! +! XXXR_URB = XXXR_URB2D(I,J) +! XXXB_URB = XXXB_URB2D(I,J) +! XXXG_URB = XXXG_URB2D(I,J) +! XXXC_URB = XXXC_URB2D(I,J) +! +!! Limits to avoid dividing by small number +! IF (CHS(I,J) < 1.0E-02) THEN +! CHS(I,J) = 1.0E-02 +! ENDIF +! IF (CHS2(I,J) < 1.0E-02) THEN +! CHS2(I,J) = 1.0E-02 +! ENDIF +! IF (CQS2(I,J) < 1.0E-02) THEN +! CQS2(I,J) = 1.0E-02 +! ENDIF +! +! CHS_URB = CHS(I,J) +! CHS2(I,J)= CQS2(I,J) +! CHS2_URB = CHS2(I,J) +! IF (PRESENT(CMR_SFCDIF)) THEN +! CMR_URB = CMR_SFCDIF(I,J) +! CHR_URB = CHR_SFCDIF(I,J) +! CMGR_URB = CMGR_SFCDIF(I,J) +! CHGR_URB = CHGR_SFCDIF(I,J) +! CMC_URB = CMC_SFCDIF(I,J) +! CHC_URB = CHC_SFCDIF(I,J) +! ENDIF +! +!! NUDAPT for SLUCM +! +! MH_URB = MH_URB2D(I,J) +! STDH_URB = STDH_URB2D(I,J) +! LP_URB = LP_URB2D(I,J) +! HGT_URB = HGT_URB2D(I,J) +! LF_URB = 0.0 +! DO K = 1,4 +! LF_URB(K) = LF_URB2D(I,K,J) +! ENDDO +! FRC_URB = FRC_URB2D(I,J) +! LB_URB = LB_URB2D(I,J) +! CHECK = 0 +! IF (I.EQ.73.AND.J.EQ.125)THEN +! CHECK = 1 +! END IF +! +!! Call urban +! +! CALL cal_mon_day(julian,julyr,jmonth,jday) +! CALL urban(LSOLAR_URB, & ! I +! num_roof_layers, num_wall_layers, num_road_layers, & ! C +! DZR, DZB, DZG, & ! C +! UTYPE_URB, TA_URB, QA_URB, UA_URB, U1_URB, V1_URB, SSG_URB, & ! I +! SSGD_URB, SSGQ_URB, LLG_URB, RAIN_URB, RHOO_URB, & ! I +! ZA_URB, DECLIN_URB, COSZ_URB, OMG_URB, & ! I +! XLAT_URB, DELT_URB, ZNT_URB, & ! I +! CHS_URB, CHS2_URB, & ! I +! TR_URB, TB_URB, TG_URB, TC_URB, QC_URB, UC_URB, & ! H +! TRL_URB, TBL_URB, TGL_URB, & ! H +! XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H +! TS_URB, QS_URB, SH_URB, LH_URB, LH_KINEMATIC_URB, & ! O +! SW_URB, ALB_URB, LW_URB, G_URB, RN_URB, PSIM_URB, PSIH_URB, & ! O +! GZ1OZ0_URB, & !O +! CMR_URB, CHR_URB, CMC_URB, CHC_URB, & +! U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O +! UST_URB, mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 +! hgt_urb, frc_urb, lb_urb, check, CMCR_URB,TGR_URB, & ! H +! TGRL_URB, SMR_URB, CMGR_URB, CHGR_URB, jmonth, & ! H +! DRELR_URB, DRELB_URB, & ! H +! DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB ) +! +! TS_URB2D(I,J) = TS_URB +! +! ALBEDO(I,J) = FRC_URB2D(I,J) * ALB_URB + (1-FRC_URB2D(I,J)) * ALBEDO(I,J) ![-] +! HFX(I,J) = FRC_URB2D(I,J) * SH_URB + (1-FRC_URB2D(I,J)) * HFX(I,J) ![W/m/m] +! QFX(I,J) = FRC_URB2D(I,J) * LH_KINEMATIC_URB & +! + (1-FRC_URB2D(I,J))* QFX(I,J) ![kg/m/m/s] +! LH(I,J) = FRC_URB2D(I,J) * LH_URB + (1-FRC_URB2D(I,J)) * LH(I,J) ![W/m/m] +! GRDFLX(I,J) = FRC_URB2D(I,J) * (G_URB) + (1-FRC_URB2D(I,J)) * GRDFLX(I,J) ![W/m/m] +! TSK(I,J) = FRC_URB2D(I,J) * TS_URB + (1-FRC_URB2D(I,J)) * TSK(I,J) ![K] +!! Q1 = QSFC(I,J)/(1.0+QSFC(I,J)) +!! Q1 = FRC_URB2D(I,J) * QS_URB + (1-FRC_URB2D(I,J)) * Q1 ![-] +! +!! Convert QSFC back to mixing ratio +! +!! QSFC(I,J) = Q1/(1.0-Q1) +! QSFC(I,J)= FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*QSFC(I,J) !! QSFC(I,J)=QSFC1D +! UST(I,J) = FRC_URB2D(I,J) * UST_URB + (1-FRC_URB2D(I,J)) * UST(I,J) ![m/s] +! +!! Renew Urban State Variables +! +! TR_URB2D(I,J) = TR_URB +! TB_URB2D(I,J) = TB_URB +! TG_URB2D(I,J) = TG_URB +! TC_URB2D(I,J) = TC_URB +! QC_URB2D(I,J) = QC_URB +! UC_URB2D(I,J) = UC_URB +! +! TGR_URB2D(I,J) = TGR_URB +! CMCR_URB2D(I,J) = CMCR_URB +! FLXHUMR_URB2D(I,J) = FLXHUMR_URB +! FLXHUMB_URB2D(I,J) = FLXHUMB_URB +! FLXHUMG_URB2D(I,J) = FLXHUMG_URB +! DRELR_URB2D(I,J) = DRELR_URB +! DRELB_URB2D(I,J) = DRELB_URB +! DRELG_URB2D(I,J) = DRELG_URB +! +! DO K = 1,num_roof_layers +! TRL_URB3D(I,K,J) = TRL_URB(K) +! SMR_URB3D(I,K,J) = SMR_URB(K) +! TGRL_URB3D(I,K,J)= TGRL_URB(K) +! END DO +! DO K = 1,num_wall_layers +! TBL_URB3D(I,K,J) = TBL_URB(K) +! END DO +! DO K = 1,num_road_layers +! TGL_URB3D(I,K,J) = TGL_URB(K) +! END DO +! +! XXXR_URB2D(I,J) = XXXR_URB +! XXXB_URB2D(I,J) = XXXB_URB +! XXXG_URB2D(I,J) = XXXG_URB +! XXXC_URB2D(I,J) = XXXC_URB +! +! SH_URB2D(I,J) = SH_URB +! LH_URB2D(I,J) = LH_URB +! G_URB2D(I,J) = G_URB +! RN_URB2D(I,J) = RN_URB +! PSIM_URB2D(I,J) = PSIM_URB +! PSIH_URB2D(I,J) = PSIH_URB +! GZ1OZ0_URB2D(I,J) = GZ1OZ0_URB +! U10_URB2D(I,J) = U10_URB +! V10_URB2D(I,J) = V10_URB +! TH2_URB2D(I,J) = TH2_URB +! Q2_URB2D(I,J) = Q2_URB +! UST_URB2D(I,J) = UST_URB +! AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J)) +! IF (PRESENT(CMR_SFCDIF)) THEN +! CMR_SFCDIF(I,J) = CMR_URB +! CHR_SFCDIF(I,J) = CHR_URB +! CMGR_SFCDIF(I,J) = CMGR_URB +! CHGR_SFCDIF(I,J) = CHGR_URB +! CMC_SFCDIF(I,J) = CMC_URB +! CHC_SFCDIF(I,J) = CHC_URB +! ENDIF +! +! ENDIF ! urban land used type block +! +!ENDDO ILOOP ! of I loop +!ENDDO JLOOP ! of J loop +! +!ENDIF ! sf_urban_physics = 1 block +! +!!-------------------------------------- +!! URBAN CANOPY MODEL END +!!-------------------------------------- +! +!!-------------------------------------- +!! URBAN BEP and BEM MODEL BEGIN +!!-------------------------------------- +! +!IF (SF_URBAN_PHYSICS == 2) THEN +! +!DO J=JTS,JTE +!DO I=ITS,ITE +! +! EMISS_URB(I,J) = 0. +! RL_UP_URB(I,J) = 0. +! RS_ABS_URB(I,J) = 0. +! GRDFLX_URB(I,J) = 0. +! B_Q_BEP(I,KTS:KTE,J) = 0. +! +!END DO +!END DO +! +! CALL BEP(frc_urb2d, utype_urb2d, itimestep, dz8w, & +! dt, u_phy, v_phy, & +! th_phy, rho, p_phy, swdown, glw, & +! gmt, julday, xlong, xlat, & +! declin_urb, cosz_urb2d, omg_urb2d, & +! num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & +! urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & +! urban_map_gbd, urban_map_fbd, num_urban_hi, & +! trb_urb4d, tw1_urb4d, tw2_urb4d, tgb_urb4d, & +! sfw1_urb3d, sfw2_urb3d, sfr_urb3d, sfg_urb3d, & +! lp_urb2d, hi_urb2d, lb_urb2d, hgt_urb2d, & +! a_u_bep, a_v_bep, a_t_bep, & +! a_e_bep, b_u_bep, b_v_bep, & +! b_t_bep, b_e_bep, b_q_bep, dlg_bep, & +! dl_u_bep, sf_bep, vl_bep, & +! rl_up_urb, rs_abs_urb, emiss_urb, grdflx_urb, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) +! +!ENDIF ! SF_URBAN_PHYSICS == 2 +! +!IF (SF_URBAN_PHYSICS == 3) THEN +! +!DO J=JTS,JTE +!DO I=ITS,ITE +! +! EMISS_URB(I,J) = 0. +! RL_UP_URB(I,J) = 0. +! RS_ABS_URB(I,J) = 0. +! GRDFLX_URB(I,J) = 0. +! B_Q_BEP(I,KTS:KTE,J) = 0. +! +!END DO +!END DO +! +! CALL BEP_BEM( frc_urb2d, utype_urb2d, itimestep, dz8w, & +! dt, u_phy, v_phy, & +! th_phy, rho, p_phy, swdown, glw, & +! gmt, julday, xlong, xlat, & +! declin_urb, cosz_urb2d, omg_urb2d, & +! num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & +! urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & +! urban_map_gbd, urban_map_fbd, urban_map_zgrd,num_urban_hi, & +! trb_urb4d, tw1_urb4d, tw2_urb4d, tgb_urb4d, & +! tlev_urb3d, qlev_urb3d, tw1lev_urb3d, tw2lev_urb3d, & +! tglev_urb3d, tflev_urb3d, sf_ac_urb3d, lf_ac_urb3d, & +! cm_ac_urb3d, sfvent_urb3d, lfvent_urb3d, & +! sfwin1_urb3d, sfwin2_urb3d, & +! sfw1_urb3d, sfw2_urb3d, sfr_urb3d, sfg_urb3d, & +! ep_pv_urb3d, t_pv_urb3d, & !RMS +! trv_urb4d, qr_urb4d, qgr_urb3d, tgr_urb3d, & !RMS +! drain_urb4d,draingr_urb3d, sfrv_urb3d, lfrv_urb3d, & !RMS +! dgr_urb3d, dg_urb3d, lfr_urb3d, lfg_urb3d, & !RMS +! rainbl, swddir, swddif, & +! lp_urb2d, hi_urb2d, lb_urb2d, hgt_urb2d, & +! a_u_bep, a_v_bep, a_t_bep, & +! a_e_bep, b_u_bep, b_v_bep, & +! b_t_bep, b_e_bep, b_q_bep, dlg_bep, & +! dl_u_bep, sf_bep, vl_bep, & +! rl_up_urb, rs_abs_urb, emiss_urb, grdflx_urb, qv3d, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) +! +!ENDIF ! SF_URBAN_PHYSICS == 3 +! +!IF((SF_URBAN_PHYSICS == 2).OR.(SF_URBAN_PHYSICS == 3))THEN +! +! sigma_sb=5.67e-08 +! do j = jts, jte +! do i = its, ite +! UMOM_URB(I,J) = 0. +! VMOM_URB(I,J) = 0. +! HFX_URB(I,J) = 0. +! QFX_URB(I,J) = 0. +! +! do k=kts,kte +! a_u_bep(i,k,j) = a_u_bep(i,k,j)*frc_urb2d(i,j) +! a_v_bep(i,k,j) = a_v_bep(i,k,j)*frc_urb2d(i,j) +! a_t_bep(i,k,j) = a_t_bep(i,k,j)*frc_urb2d(i,j) +! a_q_bep(i,k,j) = 0. +! a_e_bep(i,k,j) = 0. +! b_u_bep(i,k,j) = b_u_bep(i,k,j)*frc_urb2d(i,j) +! b_v_bep(i,k,j) = b_v_bep(i,k,j)*frc_urb2d(i,j) +! b_t_bep(i,k,j) = b_t_bep(i,k,j)*frc_urb2d(i,j) +! b_q_bep(i,k,j) = b_q_bep(i,k,j)*frc_urb2d(i,j) +! b_e_bep(i,k,j) = b_e_bep(i,k,j)*frc_urb2d(i,j) +! HFX_URB(I,J) = HFX_URB(I,J) + B_T_BEP(I,K,J)*RHO(I,K,J)*CP*DZ8W(I,K,J)*VL_BEP(I,K,J) +! QFX_URB(I,J) = QFX_URB(I,J) + B_Q_BEP(I,K,J)*DZ8W(I,K,J)*VL_BEP(I,K,J) +! UMOM_URB(I,J) = UMOM_URB(I,J)+ (A_U_BEP(I,K,J)*U_PHY(I,K,J)+B_U_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J) +! VMOM_URB(I,J) = VMOM_URB(I,J)+ (A_V_BEP(I,K,J)*V_PHY(I,K,J)+B_V_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J) +! vl_bep(i,k,j) = (1.-frc_urb2d(i,j)) + vl_bep(i,k,j)*frc_urb2d(i,j) +! sf_bep(i,k,j) = (1.-frc_urb2d(i,j)) + sf_bep(i,k,j)*frc_urb2d(i,j) +! end do +! +! a_u_bep(i,1,j) = (1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/ & +! ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_u_bep(i,1,j) +! +! a_v_bep(i,1,j) = (1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/ & +! ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_v_bep(i,1,j) +! +! b_t_bep(i,1,j) = (1.-frc_urb2d(i,j))*hfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)/CP+ & +! b_t_bep(i,1,j) +! +! b_q_bep(i,1,j) = (1.-frc_urb2d(i,j))*qfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)+b_q_bep(i,1,j) +! +! umom = (1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*u_phy(i,1,j)/ & +! ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+umom_urb(i,j) +! +! vmom = (1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*v_phy(i,1,j)/ & +! ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+vmom_urb(i,j) +! sf_bep(i,1,j) = 1. +! +!! using the emissivity and the total longwave upward radiation estimate the averaged skin temperature +! +! IF (FRC_URB2D(I,J).GT.0.) THEN +! rl_up_rural = -emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j) +! rl_up_tot = (1.-frc_urb2d(i,j))*rl_up_rural + frc_urb2d(i,j)*rl_up_urb(i,j) +! emiss(i,j) = (1.-frc_urb2d(i,j))*emiss_rural(i,j)+ frc_urb2d(i,j)*emiss_urb(i,j) +! ts_urb2d(i,j) = (max(0.,(-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb))**0.25 +! tsk(i,j) = (max(0., (-1.*rl_up_tot-(1.-emiss(i,j))*glw(i,j) )/emiss(i,j)/sigma_sb))**.25 +! rs_abs_tot = (1.-frc_urb2d(i,j))*swdown(i,j)*(1.-albedo(i,j))+frc_urb2d(i,j)*rs_abs_urb(i,j) +! +! if(swdown(i,j) > 0.)then +! albedo(i,j) = 1.-rs_abs_tot/swdown(i,j) +! else +! albedo(i,j) = alb_rural(i,j) +! endif +! +!! rename *_urb to sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d +! +! grdflx(i,j) = (1.-frc_urb2d(i,j))*grdflx_rural(i,j)+ frc_urb2d(i,j)*grdflx_urb(i,j) +! qfx(i,j) = (1.-frc_urb2d(i,j))*qfx_rural(i,j) + qfx_urb(i,j) +! lh(i,j) = qfx(i,j)*xlv +! hfx(i,j) = hfx_urb(i,j) + (1-frc_urb2d(i,j))*hfx_rural(i,j) ![W/m/m] +! sh_urb2d(i,j) = hfx_urb(i,j)/frc_urb2d(i,j) +! lh_urb2d(i,j) = qfx_urb(i,j)*xlv/frc_urb2d(i,j) +! g_urb2d(i,j) = grdflx_urb(i,j) +! rn_urb2d(i,j) = rs_abs_urb(i,j)+emiss_urb(i,j)*glw(i,j)-rl_up_urb(i,j) +! ust(i,j) = (umom**2.+vmom**2.)**.25 +! +! ELSE +! +! sh_urb2d(i,j) = 0. +! lh_urb2d(i,j) = 0. +! g_urb2d(i,j) = 0. +! rn_urb2d(i,j) = 0. +! +! ENDIF +! +! enddo ! jloop +! enddo ! iloop +! +!ENDIF ! SF_URBAN_PHYSICS == 2 or 3 +! +!!-------------------------------------- +!! URBAN BEP and BEM MODEL END +!!-------------------------------------- +! +! +!END SUBROUTINE noahmp_urban +! +!------------------------------------------------------------------------------------------ +! +END MODULE module_sf_noahmpdrv diff --git a/src/physics/lsm_noahmplsm.f90 b/src/physics/lsm_noahmplsm.f90 new file mode 100644 index 00000000..917a2b4c --- /dev/null +++ b/src/physics/lsm_noahmplsm.f90 @@ -0,0 +1,10933 @@ +! Program Name: +! Author(s)/Contact(s): +! Abstract: +! History Log: +! +! Usage: +! Parameters: +! Input Files: +! +! Output Files: +! +! +! Condition codes: +! +! If appropriate, descriptive troubleshooting instructions or +! likely causes for failures could be mentioned here with the +! appropriate error code +! +! User controllable options: + +MODULE MODULE_SF_NOAHMPLSM + + use module_sf_gecros, only : gecros + + IMPLICIT NONE + + public :: noahmp_options + public :: NOAHMP_SFLX + + private :: ATM + private :: PHENOLOGY + private :: PRECIP_HEAT + private :: ENERGY + private :: THERMOPROP + private :: CSNOW + private :: TDFCND + private :: RADIATION + private :: ALBEDO + private :: SNOW_AGE + private :: SNOWALB_BATS + private :: SNOWALB_CLASS + private :: GROUNDALB + private :: TWOSTREAM + private :: SURRAD + private :: VEGE_FLUX + private :: SFCDIF1 + private :: SFCDIF2 + private :: STOMATA + private :: CANRES + private :: ESAT + private :: RAGRB + private :: BARE_FLUX + private :: TSNOSOI + private :: HRT + private :: HSTEP + private :: ROSR12 + private :: PHASECHANGE + private :: FRH2O + + private :: WATER + private :: CANWATER + private :: SNOWWATER + private :: SNOWFALL + private :: COMBINE + private :: DIVIDE + private :: COMBO + private :: COMPACT + private :: SNOWH2O + private :: SOILWATER + private :: ZWTEQ + private :: INFIL + private :: SRT + private :: WDFCND1 + private :: WDFCND2 + private :: SSTEP + private :: GROUNDWATER + private :: SHALLOWWATERTABLE + + private :: CARBON + private :: CO2FLUX +! private :: BVOCFLUX +! private :: CH4FLUX + + private :: ERROR + +! =====================================options for different schemes================================ +! **recommended + + INTEGER :: DVEG ! options for dynamic vegetation: + ! 1 -> off (use table LAI; use FVEG = SHDFAC from input) + ! 2 -> on (together with OPT_CRS = 1) + ! 3 -> off (use table LAI; calculate FVEG) + ! **4 -> off (use table LAI; use maximum vegetation fraction) + ! **5 -> on (use maximum vegetation fraction) + ! 6 -> on (use FVEG = SHDFAC from input) + ! 7 -> off (use input LAI; use FVEG = SHDFAC from input) + ! 8 -> off (use input LAI; calculate FVEG) + ! 9 -> off (use input LAI; use maximum vegetation fraction) + ! 10 -> crop model on (use maximum vegetation fraction) + + INTEGER :: OPT_CRS ! options for canopy stomatal resistance + ! **1 -> Ball-Berry + ! 2 -> Jarvis + + INTEGER :: OPT_BTR ! options for soil moisture factor for stomatal resistance + ! **1 -> Noah (soil moisture) + ! 2 -> CLM (matric potential) + ! 3 -> SSiB (matric potential) + + INTEGER :: OPT_RUN ! options for runoff and groundwater + ! **1 -> TOPMODEL with groundwater (Niu et al. 2007 JGR) ; + ! 2 -> TOPMODEL with an equilibrium water table (Niu et al. 2005 JGR) ; + ! 3 -> original surface and subsurface runoff (free drainage) + ! 4 -> BATS surface and subsurface runoff (free drainage) + ! 5 -> Miguez-Macho&Fan groundwater scheme (Miguez-Macho et al. 2007 JGR; Fan et al. 2007 JGR) + ! (needs further testing for public use) + + INTEGER :: OPT_SFC ! options for surface layer drag coeff (CH & CM) + ! **1 -> M-O + ! **2 -> original Noah (Chen97) + ! **3 -> MYJ consistent; 4->YSU consistent. MB: removed in v3.7 for further testing + + INTEGER :: OPT_FRZ ! options for supercooled liquid water (or ice fraction) + ! **1 -> no iteration (Niu and Yang, 2006 JHM) + ! 2 -> Koren's iteration + + INTEGER :: OPT_INF ! options for frozen soil permeability + ! **1 -> linear effects, more permeable (Niu and Yang, 2006, JHM) + ! 2 -> nonlinear effects, less permeable (old) + + INTEGER :: OPT_RAD ! options for radiation transfer + ! 1 -> modified two-stream (gap = F(solar angle, 3D structure ...)<1-FVEG) + ! 2 -> two-stream applied to grid-cell (gap = 0) + ! **3 -> two-stream applied to vegetated fraction (gap=1-FVEG) + + INTEGER :: OPT_ALB ! options for ground snow surface albedo + ! 1 -> BATS + ! **2 -> CLASS + + INTEGER :: OPT_SNF ! options for partitioning precipitation into rainfall & snowfall + ! **1 -> Jordan (1991) + ! 2 -> BATS: when SFCTMP SFCTMP < TFRZ + ! 4 -> Use WRF microphysics output + ! 5 -> Use wetbulb temperature (Wang et al., 2019 GRL) C.He, 12/18/2020 + + INTEGER :: OPT_TBOT ! options for lower boundary condition of soil temperature + ! 1 -> zero heat flux from bottom (ZBOT and TBOT not used) + ! **2 -> TBOT at ZBOT (8m) read from a file (original Noah) + + INTEGER :: OPT_STC ! options for snow/soil temperature time scheme (only layer 1) + ! **1 -> semi-implicit; flux top boundary condition + ! 2 -> full implicit (original Noah); temperature top boundary condition + ! 3 -> same as 1, but FSNO for TS calculation (generally improves snow; v3.7) + + INTEGER :: OPT_RSF ! options for surface resistent to evaporation/sublimation + ! **1 -> Sakaguchi and Zeng, 2009 + ! 2 -> Sellers (1992) + ! 3 -> adjusted Sellers to decrease RSURF for wet soil + ! 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set in MPTABLE); AD v3.8 + + INTEGER :: OPT_SOIL ! options for defining soil properties + ! **1 -> use input dominant soil texture + ! 2 -> use input soil texture that varies with depth + ! 3 -> use soil composition (sand, clay, orgm) and pedotransfer functions (OPT_PEDO) + ! 4 -> use input soil properties (BEXP_3D, SMCMAX_3D, etc.) + + INTEGER :: OPT_PEDO ! options for pedotransfer functions (used when OPT_SOIL = 3) + ! **1 -> Saxton and Rawls (2006) + + INTEGER :: OPT_CROP ! options for crop model + ! **0 -> No crop model, will run default dynamic vegetation + ! 1 -> Liu, et al. 2016 + ! 2 -> Gecros (Genotype-by-Environment interaction on CROp growth Simulator) Yin and van Laar, 2005 + + INTEGER :: OPT_IRR ! options for irrigation + ! **0 -> No irrigation + ! 1 -> Irrigation ON + ! 2 -> irrigation trigger based on crop season Planting and harvesting dates + ! *3 -> irrigation trigger based on LAI threshold + + INTEGER :: OPT_IRRM ! options for irrigation method + ! **0 -> method based on geo_em fractions + ! 1 -> sprinkler method + ! 2 -> micro/drip irrigation + ! 3 -> surface flooding + +!------------------------------------------------------------------------------------------! +! Physical Constants: ! +!------------------------------------------------------------------------------------------! + + REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL, PARAMETER :: VKC = 0.40 !von Karman constant + REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) (not used MB: 20140718) + REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) + + INTEGER, PRIVATE, PARAMETER :: MBAND = 2 + INTEGER, PRIVATE, PARAMETER :: NSOIL = 4 + INTEGER, PRIVATE, PARAMETER :: NSTAGE = 8 + + TYPE noahmp_parameters ! define a NoahMP parameters type + +!------------------------------------------------------------------------------------------! +! From the veg section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + LOGICAL :: URBAN_FLAG + INTEGER :: ISWATER + INTEGER :: ISBARREN + INTEGER :: ISICE + INTEGER :: ISCROP + INTEGER :: EBLFOREST + + REAL :: CH2OP !maximum intercepted h2o per unit lai+sai (mm) + REAL :: DLEAF !characteristic leaf dimension (m) + REAL :: Z0MVT !momentum roughness length (m) + REAL :: HVT !top of canopy (m) + REAL :: HVB !bottom of canopy (m) + REAL :: DEN !tree density (no. of trunks per m2) + REAL :: RC !tree crown radius (m) + REAL :: MFSNO !snowmelt m parameter () + REAL :: SCFFAC !snow cover factor (m) (originally hard-coded 2.5*z0 in SCF formulation) + REAL :: SAIM(12) !monthly stem area index, one-sided + REAL :: LAIM(12) !monthly leaf area index, one-sided + REAL :: SLA !single-side leaf area per Kg [m2/kg] + REAL :: DILEFC !coeficient for leaf stress death [1/s] + REAL :: DILEFW !coeficient for leaf stress death [1/s] + REAL :: FRAGR !fraction of growth respiration !original was 0.3 + REAL :: LTOVRC !leaf turnover [1/s] + + REAL :: C3PSN !photosynthetic pathway: 0. = c4, 1. = c3 + REAL :: KC25 !co2 michaelis-menten constant at 25c (pa) + REAL :: AKC !q10 for kc25 + REAL :: KO25 !o2 michaelis-menten constant at 25c (pa) + REAL :: AKO !q10 for ko25 + REAL :: VCMX25 !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMX !q10 for vcmx25 + REAL :: BP !minimum leaf conductance (umol/m**2/s) + REAL :: MP !slope of conductance-to-photosynthesis relationship + REAL :: QE25 !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: AQE !q10 for qe25 + REAL :: RMF25 !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL :: RMS25 !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: RMR25 !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: ARM !q10 for maintenance respiration + REAL :: FOLNMX !foliage nitrogen concentration when f(n)=1 (%) + REAL :: TMIN !minimum temperature for photosynthesis (k) + + REAL :: XL !leaf/stem orientation index + REAL :: RHOL(MBAND) !leaf reflectance: 1=vis, 2=nir + REAL :: RHOS(MBAND) !stem reflectance: 1=vis, 2=nir + REAL :: TAUL(MBAND) !leaf transmittance: 1=vis, 2=nir + REAL :: TAUS(MBAND) !stem transmittance: 1=vis, 2=nir + + REAL :: MRP !microbial respiration parameter (umol co2 /kg c/ s) + REAL :: CWPVT !empirical canopy wind parameter + + REAL :: WRRAT !wood to non-wood ratio + REAL :: WDPOOL !wood pool (switch 1 or 0) depending on woody or not [-] + REAL :: TDLEF !characteristic T for leaf freezing [K] + + INTEGER :: NROOT !number of soil layers with root present + REAL :: RGL !Parameter used in radiation stress function + REAL :: RSMIN !Minimum stomatal resistance [s m-1] + REAL :: HS !Parameter used in vapor pressure deficit function + REAL :: TOPT !Optimum transpiration air temperature [K] + REAL :: RSMAX !Maximal stomatal resistance [s m-1] + + REAL :: SLAREA + REAL :: EPS(5) + +!------------------------------------------------------------------------------------------! +! From the rad section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + REAL :: ALBSAT(MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL :: ALBDRY(MBAND) !dry soil albedos: 1=vis, 2=nir + REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow + REAL :: BETADS !two-stream parameter betad for snow + REAL :: BETAIS !two-stream parameter betad for snow + REAL :: EG(2) !emissivity + +!------------------------------------------------------------------------------------------! +! From the globals section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + REAL :: CO2 !co2 partial pressure + REAL :: O2 !o2 partial pressure + REAL :: TIMEAN !gridcell mean topgraphic index (global mean) + REAL :: FSATMX !maximum surface saturated fraction (global mean) + REAL :: Z0SNO !snow surface roughness length (m) (0.002) + REAL :: SSI !liquid water holding capacity for snowpack (m3/m3) + REAL :: SNOW_RET_FAC !snowpack water release timescale factor (1/s) + REAL :: SNOW_EMIS !snow emissivity + REAL :: SWEMX !new snow mass to fully cover old snow (mm) + REAL :: TAU0 !tau0 from Yang97 eqn. 10a + REAL :: GRAIN_GROWTH !growth from vapor diffusion Yang97 eqn. 10b + REAL :: EXTRA_GROWTH !extra growth near freezing Yang97 eqn. 10c + REAL :: DIRT_SOOT !dirt and soot term Yang97 eqn. 10d + REAL :: BATS_COSZ !zenith angle snow albedo adjustment; b in Yang97 eqn. 15 + REAL :: BATS_VIS_NEW !new snow visible albedo + REAL :: BATS_NIR_NEW !new snow NIR albedo + REAL :: BATS_VIS_AGE !age factor for diffuse visible snow albedo Yang97 eqn. 17 + REAL :: BATS_NIR_AGE !age factor for diffuse NIR snow albedo Yang97 eqn. 18 + REAL :: BATS_VIS_DIR !cosz factor for direct visible snow albedo Yang97 eqn. 15 + REAL :: BATS_NIR_DIR !cosz factor for direct NIR snow albedo Yang97 eqn. 16 + REAL :: RSURF_SNOW !surface resistance for snow(s/m) + REAL :: RSURF_EXP !exponent in the shape parameter for soil resistance option 1 + +!------------------------------------------------------------------------------------------! +! From the irrigation section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + REAL :: IRR_FRAC ! irrigation Fraction + INTEGER :: IRR_HAR ! number of days before harvest date to stop irrigation + REAL :: IRR_LAI ! Minimum lai to trigger irrigation + REAL :: IRR_MAD ! management allowable deficit (0-1) + REAL :: FILOSS ! fraction of flood irrigation loss (0-1) + REAL :: SPRIR_RATE ! mm/h, sprinkler irrigation rate + REAL :: MICIR_RATE ! mm/h, micro irrigation rate + REAL :: FIRTFAC ! flood application rate factor + REAL :: IR_RAIN ! maximum precipitation to stop irrigation trigger + +!------------------------------------------------------------------------------------------! +! From the crop section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + INTEGER :: PLTDAY ! Planting date + INTEGER :: HSDAY ! Harvest date + REAL :: PLANTPOP ! Plant density [per ha] - used? + REAL :: IRRI ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + REAL :: GDDTBASE ! Base temperature for GDD accumulation [C] + REAL :: GDDTCUT ! Upper temperature for GDD accumulation [C] + REAL :: GDDS1 ! GDD from seeding to emergence + REAL :: GDDS2 ! GDD from seeding to initial vegetative + REAL :: GDDS3 ! GDD from seeding to post vegetative + REAL :: GDDS4 ! GDD from seeding to intial reproductive + REAL :: GDDS5 ! GDD from seeding to pysical maturity + INTEGER :: C3C4 ! photosynthetic pathway: 1 = c3 2 = c4 + REAL :: AREF ! reference maximum CO2 assimulation rate + REAL :: PSNRF ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + REAL :: I2PAR ! Fraction of incoming solar radiation to photosynthetically active radiation + REAL :: TASSIM0 ! Minimum temperature for CO2 assimulation [C] + REAL :: TASSIM1 ! CO2 assimulation linearly increasing until temperature reaches T1 [C] + REAL :: TASSIM2 ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + REAL :: K ! light extinction coefficient + REAL :: EPSI ! initial light use efficiency + REAL :: Q10MR ! q10 for maintainance respiration + REAL :: FOLN_MX ! foliage nitrogen concentration when f(n)=1 (%) + REAL :: LEFREEZ ! characteristic T for leaf freezing [K] + REAL :: DILE_FC(NSTAGE) ! coeficient for temperature leaf stress death [1/s] + REAL :: DILE_FW(NSTAGE) ! coeficient for water leaf stress death [1/s] + REAL :: FRA_GR ! fraction of growth respiration + REAL :: LF_OVRC(NSTAGE) ! fraction of leaf turnover [1/s] + REAL :: ST_OVRC(NSTAGE) ! fraction of stem turnover [1/s] + REAL :: RT_OVRC(NSTAGE) ! fraction of root tunrover [1/s] + REAL :: LFMR25 ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] + REAL :: STMR25 ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: RTMR25 ! root maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: GRAINMR25 ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: LFPT(NSTAGE) ! fraction of carbohydrate flux to leaf + REAL :: STPT(NSTAGE) ! fraction of carbohydrate flux to stem + REAL :: RTPT(NSTAGE) ! fraction of carbohydrate flux to root + REAL :: LFCT(NSTAGE) ! fraction of carbohydrate flux transallocate from leaf to grain ! Zhe Zhang 2020-07-13 + REAL :: STCT(NSTAGE) ! fraction of carbohydrate flux transallocate from stem to grain + REAL :: RTCT(NSTAGE) ! fraction of carbohydrate flux transallocate from root to grain + REAL :: GRAINPT(NSTAGE) ! fraction of carbohydrate flux to grain + REAL :: BIO2LAI ! leaf are per living leaf biomass [m^2/kg] + +!------------------------------------------------------------------------------------------! +! From the SOILPARM.TBL tables, as functions of soil category. +!------------------------------------------------------------------------------------------! + REAL :: BEXP(NSOIL) !B parameter + REAL :: SMCDRY(NSOIL) !dry soil moisture threshold where direct evap from top + !layer ends (volumetric) (not used MB: 20140718) + REAL :: SMCWLT(NSOIL) !wilting point soil moisture (volumetric) + REAL :: SMCREF(NSOIL) !reference soil moisture (field capacity) (volumetric) + REAL :: SMCMAX(NSOIL) !porosity, saturated value of soil moisture (volumetric) + REAL :: PSISAT(NSOIL) !saturated soil matric potential + REAL :: DKSAT(NSOIL) !saturated soil hydraulic conductivity + REAL :: DWSAT(NSOIL) !saturated soil hydraulic diffusivity + REAL :: QUARTZ(NSOIL) !soil quartz content + REAL :: F1 !soil thermal diffusivity/conductivity coef (not used MB: 20140718) +!------------------------------------------------------------------------------------------! +! From the GENPARM.TBL file +!------------------------------------------------------------------------------------------! + REAL :: SLOPE !slope index (0 - 1) + REAL :: CSOIL !vol. soil heat capacity [j/m3/K] + REAL :: ZBOT !Depth (m) of lower boundary soil temperature + REAL :: CZIL !Calculate roughness length of heat + REAL :: REFDK + REAL :: REFKDT + + REAL :: KDT !used in compute maximum infiltration rate (in INFIL) + REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) + + END TYPE noahmp_parameters + +contains +! +!== begin noahmp_sflx ============================================================================== + + SUBROUTINE NOAHMP_SFLX (parameters, & + ILOC , JLOC , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related + DT , DX , DZ8W , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration + SHDFAC , SHDMAX , VEGTYP , ICE , IST , CROPTYPE, & ! IN : Vegetation/Soil characteristics + SMCEQ , & ! IN : Vegetation/Soil characteristics + SFCTMP , SFCPRS , PSFC , UU , VV , Q2 , & ! IN : Forcing + QC , SOLDN , LWDN , & ! IN : Forcing + PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, & ! IN : Forcing + TBOT , CO2AIR , O2AIR , FOLN , FICEOLD , ZLVL , & ! IN : Forcing + IRRFRA , SIFRA , MIFRA , FIFRA , LLANDUSE, & ! IN : Irrigation: fractions + ALBOLD , SNEQVO , & ! IN/OUT : + STC , SH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : + CANLIQ , CANICE , TV , TG , QSFC , QSNOW , & ! IN/OUT : + QRAIN , & ! IN/OUT : + ISNOW , ZSNSO , SNOWH , SNEQV , SNICE , SNLIQ , & ! IN/OUT : + ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , & ! IN/OUT : + STMASS , WOOD , STBLCP , FASTCP , LAI , SAI , & ! IN/OUT : + CM , CH , TAUSS , & ! IN/OUT : + GRAIN , GDD , PGS , & ! IN/OUT + SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : + GECROS1D, & ! IN/OUT : + Z0WRF , & + IRCNTSI , IRCNTMI , IRCNTFI , IRAMTSI , IRAMTMI , IRAMTFI , & ! IN/OUT : Irrigation: vars + IRSIRATE, IRMIRATE, IRFIRATE, FIRR , EIRR , & ! IN/OUT : Irrigation: vars + FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : + FGEV , FCTR , ECAN , ETRAN , EDIR , TRAD , & ! OUT : + TGB , TGV , T2MV , T2MB , Q2V , Q2B , & ! OUT : + RUNSRF , RUNSUB , APAR , PSN , SAV , SAG , & ! OUT : + FSNO , NEE , GPP , NPP , FVEG , ALBEDO , & ! OUT : + QSNBOT , PONDING , PONDING1, PONDING2, RSSUN , RSSHA , & ! OUT : + ALBSND , ALBSNI , & ! OUT : + BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : + SHG , SHC , SHB , EVG , EVB , GHV , & ! OUT : + GHB , IRG , IRC , IRB , TR , EVC , & ! OUT : + CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & + PAHG , PAHB , PAH , LAISUN , LAISHA , RB & ! OUT +! #ifdef WRF_HYDRO +! ,SFCHEADRT & ! IN/OUT : +!#endif + ) + +! -------------------------------------------------------------------------------------------------- +! Initial code: Guo-Yue Niu, Oct. 2007 +! -------------------------------------------------------------------------------------------------- + + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), INTENT(IN) :: parameters + + INTEGER , INTENT(IN) :: ICE !ice (ice = 1) + INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake + INTEGER , INTENT(IN) :: VEGTYP !vegetation type + INTEGER , INTENT(IN) :: CROPTYPE !crop type + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !no. of soil layers + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + REAL , INTENT(IN) :: DT !time step [sec] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) lowest model layer + REAL , INTENT(IN) :: SFCTMP !surface air temperature [K] + REAL , INTENT(IN) :: UU !wind speed in eastward dir (m/s) + REAL , INTENT(IN) :: VV !wind speed in northward dir (m/s) + REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) + REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(INOUT) :: ZLVL !reference height (m) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] + REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. [K] + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) [1-saturated] + REAL , INTENT(IN) :: SHDFAC !green vegetation fraction [0.0-1.0] + INTEGER , INTENT(IN) :: YEARLEN!Number of days in the particular year. + REAL , INTENT(IN) :: JULIAN !Julian day of year (floating point) + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] + REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 + +!jref:start; in + REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL , INTENT(IN) :: PSFC !pressure at lowest model layer + REAL , INTENT(IN) :: DZ8W !thickness of lowest layer + REAL , INTENT(IN) :: DX + REAL , INTENT(IN) :: SHDMAX !yearly max vegetation fraction +!jref:end + +!#ifdef WRF_HYDRO +! REAL , INTENT(INOUT) :: sfcheadrt +!#endif + +! input/output : need arbitary intial values + REAL , INTENT(INOUT) :: QSNOW !snowfall [mm/s] + REAL , INTENT(INOUT) :: QRAIN !rain at ground surface (mm/s) + REAL , INTENT(INOUT) :: FWET !wetted or snowed fraction of canopy (-) + REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) + REAL , INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) + REAL , INTENT(INOUT) :: TAH !canopy air tmeperature (k) + REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL , INTENT(INOUT) :: CM !momentum drag coefficient + REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient + REAL , INTENT(INOUT) :: TAUSS !non-dimensional snow age + +! prognostic variables + INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers [-] + REAL , INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL , INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + REAL , INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , INTENT(INOUT) :: SNOWH !snow height [m] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL , INTENT(INOUT) :: TV !vegetation temperature (k) + REAL , INTENT(INOUT) :: TG !ground temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] + REAL , INTENT(INOUT) :: ZWT !depth to water table [m] + REAL , INTENT(INOUT) :: WA !water storage in aquifer [mm] + REAL , INTENT(INOUT) :: WT !water in aquifer&saturated soil [mm] + REAL , INTENT(INOUT) :: WSLAKE !lake water storage (can be neg.) (mm) + REAL, INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3] + REAL, INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m] + REAL, INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic) + + REAL, DIMENSION(1:60) , INTENT(INOUT) :: gecros1d ! gecros crop + +! output + REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model + REAL , INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL , INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: FIRA !total net LW rad (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCEV !canopy evap heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FGEV !ground evap heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCTR !transpiration heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , INTENT(OUT) :: TRAD !surface radiative temperature (k) + REAL :: TS !surface temperature (k) + REAL , INTENT(OUT) :: ECAN !evaporation of intercepted water (mm/s) + REAL , INTENT(OUT) :: ETRAN !transpiration rate (mm/s) + REAL , INTENT(OUT) :: EDIR !soil surface evaporation rate (mm/s] + REAL , INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(OUT) :: RUNSUB !baseflow (saturation excess) [mm/s] + REAL , INTENT(OUT) :: PSN !total photosynthesis (umol co2/m2/s) [+] + REAL , INTENT(OUT) :: APAR !photosyn active energy by canopy (w/m2) + REAL , INTENT(OUT) :: SAV !solar rad absorbed by veg. (w/m2) + REAL , INTENT(OUT) :: SAG !solar rad absorbed by ground (w/m2) + REAL , INTENT(OUT) :: FSNO !snow cover fraction on the ground (-) + REAL , INTENT(OUT) :: FVEG !green vegetation fraction [0.0-1.0] + REAL , INTENT(OUT) :: ALBEDO !surface albedo [-] + REAL :: ERRWAT !water error [kg m{-2}] + REAL , INTENT(OUT) :: QSNBOT !snowmelt out bottom of pack [mm/s] + REAL , INTENT(OUT) :: PONDING!surface ponding [mm] + REAL , INTENT(OUT) :: PONDING1!surface ponding [mm] + REAL , INTENT(OUT) :: PONDING2!surface ponding [mm] + REAL , INTENT(OUT) :: RB ! leaf boundary layer resistance (s/m) + REAL , INTENT(OUT) :: LAISUN ! sunlit leaf area index (m2/m2) + REAL , INTENT(OUT) :: LAISHA ! shaded leaf area index (m2/m2) + +!jref:start; output + REAL , INTENT(OUT) :: T2MV !2-m air temperature over vegetated part [k] + REAL , INTENT(OUT) :: T2MB !2-m air temperature over bare ground part [k] + REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP + REAL, DIMENSION(1:2) , INTENT(OUT) :: ALBSND !snow albedo (direct) + REAL, DIMENSION(1:2) , INTENT(OUT) :: ALBSNI !snow albedo (diffuse) + REAL, INTENT(OUT) :: TGV + REAL, INTENT(OUT) :: TGB + REAL :: Q1 + REAL, INTENT(OUT) :: EMISSI +!jref:end + +! local + INTEGER :: IZ !do-loop index + INTEGER, DIMENSION(-NSNOW+1:NSOIL) :: IMELT !phase change index [1-melt; 2-freeze] + REAL :: CMC !intercepted water (CANICE+CANLIQ) (mm) + REAL :: TAUX !wind stress: e-w (n/m2) + REAL :: TAUY !wind stress: n-s (n/m2) + REAL :: RHOAIR !density air (kg/m3) +! REAL, DIMENSION( 1: 5) :: VOCFLX !voc fluxes [ug C m-2 h-1] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZSNSO !snow/soil layer thickness [m] + REAL :: THAIR !potential temperature (k) + REAL :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) + REAL :: EAIR !vapor pressure air (pa) + REAL, DIMENSION( 1: 2) :: SOLAD !incoming direct solar rad (w/m2) + REAL, DIMENSION( 1: 2) :: SOLAI !incoming diffuse solar rad (w/m2) + REAL :: QPRECC !convective precipitation (mm/s) + REAL :: QPRECL !large-scale precipitation (mm/s) + REAL :: IGS !growing season index (0=off, 1=on) + REAL :: ELAI !leaf area index, after burying by snow + REAL :: ESAI !stem area index, after burying by snow + REAL :: BEVAP !soil water evaporation factor (0 - 1) + REAL, DIMENSION( 1:NSOIL) :: BTRANI !Soil water transpiration factor (0 - 1) + REAL :: BTRAN !soil water transpiration factor (0 - 1) + REAL :: QIN !groundwater recharge [mm/s] + REAL :: QDIS !groundwater discharge [mm/s] + REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content (m3/m3) + REAL, DIMENSION(-NSNOW+1: 0) :: SNICEV !partial volume ice of snow [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0) :: SNLIQV !partial volume liq of snow [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0) :: EPORE !effective porosity [m3/m3] + REAL :: TOTSC !total soil carbon (g/m2) + REAL :: TOTLB !total living carbon (g/m2) + REAL :: T2M !2-meter air temperature (k) + REAL :: QDEW !ground surface dew rate [mm/s] + REAL :: QVAP !ground surface evap. rate [mm/s] + REAL :: LATHEA !latent heat [j/kg] + REAL :: SWDOWN !downward solar [w/m2] + REAL :: QMELT !snowmelt [mm/s] + REAL :: BEG_WB !water storage at begin of a step [mm] + REAL,INTENT(OUT) :: IRC !canopy net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: IRG !ground net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHC !canopy sen. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHG !ground sen. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVG !ground evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHV !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: IRB !net longwave rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHB !sensible heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVB !evaporation heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHB !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: EVC !canopy evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: TR !transpiration heat [w/m2] [+ to atm] + REAL, INTENT(OUT) :: FPICE !snow fraction in precipitation + REAL, INTENT(OUT) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(OUT) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(OUT) :: PAHB !precipitation advected heat - bare ground net (W/m2) + REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) + +!jref:start + REAL :: FSRV + REAL :: FSRG + REAL,INTENT(OUT) :: Q2V + REAL,INTENT(OUT) :: Q2B + REAL :: Q2E + REAL :: QFX + REAL,INTENT(OUT) :: CHV !sensible heat exchange coefficient over vegetated fraction + REAL,INTENT(OUT) :: CHB !sensible heat exchange coefficient over bare-ground + REAL,INTENT(OUT) :: CHLEAF !leaf exchange coefficient + REAL,INTENT(OUT) :: CHUC !under canopy exchange coefficient + REAL,INTENT(OUT) :: CHV2 !sensible heat exchange coefficient over vegetated fraction + REAL,INTENT(OUT) :: CHB2 !sensible heat exchange coefficient over bare-ground +!jref:end + +! carbon +! inputs + REAL , INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) + REAL , INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) + +! inputs and outputs : prognostic variables + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon in deep soil [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short-lived carbon, shallow soil [g/m2] + REAL , INTENT(INOUT) :: LAI !leaf area index [-] + REAL , INTENT(INOUT) :: SAI !stem area index [-] + REAL , INTENT(INOUT) :: GRAIN !grain mass [g/m2] + REAL , INTENT(INOUT) :: GDD !growing degree days + INTEGER , INTENT(INOUT) :: PGS !plant growing stage [-] + +! irrigation variables + REAL , INTENT(IN) :: IRRFRA ! irrigation fraction + REAL , INTENT(IN) :: SIFRA ! sprinkler irrigation fraction + REAL , INTENT(IN) :: MIFRA ! micro irrigation fraction + REAL , INTENT(IN) :: FIFRA ! flood irrigation fraction + INTEGER , INTENT(INOUT) :: IRCNTSI ! irrigation event number, Sprinkler + INTEGER , INTENT(INOUT) :: IRCNTMI ! irrigation event number, Micro + INTEGER , INTENT(INOUT) :: IRCNTFI ! irrigation event number, Flood + REAL , INTENT(INOUT) :: IRAMTSI ! irrigation water amount [m] to be applied, Sprinkler + REAL , INTENT(INOUT) :: IRAMTMI ! irrigation water amount [m] to be applied, Micro + REAL , INTENT(INOUT) :: IRAMTFI ! irrigation water amount [m] to be applied, Flood + REAL , INTENT(INOUT) :: IRSIRATE ! rate of irrigation by sprinkler [m/timestep] + REAL , INTENT(INOUT) :: IRMIRATE ! rate of irrigation by micro [m/timestep] + REAL , INTENT(INOUT) :: IRFIRATE ! rate of irrigation by micro [m/timestep] + REAL , INTENT(INOUT) :: FIRR ! irrigation:latent heating due to sprinkler evaporation [w/m2] + REAL , INTENT(INOUT) :: EIRR ! evaporation of irrigation water to evaporation,sprinkler [mm/s] + CHARACTER(LEN=256) , INTENT(IN) :: LLANDUSE ! landuse data name (USGS or MODIS_IGBP) + REAL :: IREVPLOS ! loss of irrigation water to evaporation,sprinkler [m/timestep] + REAL :: SIFAC ! sprinkler irrigation fraction (local) + REAL :: MIFAC ! micro irrigation fraction (local) + REAL :: FIFAC ! flood irrigation fraction (local) + +! outputs + REAL , INTENT(OUT) :: NEE !net ecosys exchange (g/m2/s CO2) + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] + REAL :: AUTORS !net ecosystem respiration (g/m2/s C) + REAL :: HETERS !organic respiration (g/m2/s C) + REAL :: TROOT !root-zone averaged temperature (k) + REAL :: BDFALL !bulk density of new snow (kg/m3) ! MB/AN: v3.7 + REAL :: RAIN !rain rate (mm/s) ! MB/AN: v3.7 + REAL :: SNOW !liquid equivalent snow rate (mm/s) ! MB/AN: v3.7 + REAL :: FP ! MB/AN: v3.7 + REAL :: PRCP ! MB/AN: v3.7 +!more local variables for precip heat MB + REAL :: QINTR !interception rate for rain (mm/s) + REAL :: QDRIPR !drip rate for rain (mm/s) + REAL :: QTHROR !throughfall for rain (mm/s) + REAL :: QINTS !interception (loading) rate for snowfall (mm/s) + REAL :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) + REAL :: QTHROS !throughfall of snowfall (mm/s) + REAL :: SNOWHIN !snow depth increasing rate (m/s) + REAL :: LATHEAV !latent heat vap./sublimation (j/kg) + REAL :: LATHEAG !latent heat vap./sublimation (j/kg) + LOGICAL :: FROZEN_GROUND ! used to define latent heat pathway + LOGICAL :: FROZEN_CANOPY ! used to define latent heat pathway + LOGICAL :: dveg_active ! flag to run dynamic vegetation + LOGICAL :: crop_active ! flag to run crop model + LOGICAL :: CROPLU ! flag to identify croplands + REAL :: SIFCUK ! Sprinkler fraction for unknown irrigation methods + REAL :: FB + + ! INTENT (OUT) variables need to be assigned a value. These normally get assigned values + ! only if DVEG == 2. + nee = 0.0 + npp = 0.0 + gpp = 0.0 + PAHV = 0. + PAHG = 0. + PAHB = 0. + PAH = 0. + CROPLU = .FALSE. + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + CALL ATM (parameters,SFCPRS ,SFCTMP ,Q2 , & + PRCPCONV, PRCPNONC,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL, & + SOLDN ,COSZ ,THAIR ,QAIR , & + EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD ,SOLAI , & + SWDOWN ,BDFALL ,RAIN ,SNOW ,FP ,FPICE , PRCP ) + +! snow/soil layer thickness (m) + + DO IZ = ISNOW+1, NSOIL + IF(IZ == ISNOW+1) THEN + DZSNSO(IZ) = - ZSNSO(IZ) + ELSE + DZSNSO(IZ) = ZSNSO(IZ-1) - ZSNSO(IZ) + END IF + END DO + +! root-zone temperature + + TROOT = 0. + DO IZ=1,parameters%NROOT + TROOT = TROOT + STC(IZ)*DZSNSO(IZ)/(-ZSOIL(parameters%NROOT)) + ENDDO + +! total water storage for water balance check + + IF(IST == 1) THEN + BEG_WB = CANLIQ + CANICE + SNEQV + WA + DO IZ = 1,NSOIL + BEG_WB = BEG_WB + SMC(IZ) * DZSNSO(IZ) * 1000. + END DO + END IF + +! vegetation phenology + + CALL PHENOLOGY (parameters,VEGTYP ,croptype, SNOWH , TV , LAT , YEARLEN , JULIAN , & !in + LAI , SAI , TROOT , ELAI , ESAI ,IGS, PGS) + +!input GVF should be consistent with LAI + IF(DVEG == 1 .or. DVEG == 6 .or. DVEG == 7) THEN + FVEG = SHDFAC + IF(FVEG <= 0.05) FVEG = 0.05 + ELSE IF (DVEG == 2 .or. DVEG == 3 .or. DVEG == 8) THEN + FVEG = 1.-EXP(-0.52*(LAI+SAI)) + IF(FVEG <= 0.05) FVEG = 0.05 + ELSE IF (DVEG == 4 .or. DVEG == 5 .or. DVEG == 9) THEN + FVEG = SHDMAX + IF(FVEG <= 0.05) FVEG = 0.05 + ELSE + IF (this_image()==1) THEN + WRITE(*,*) "-------- FATAL CALLED IN SFLX -----------" + WRITE(*,*) "Namelist parameter DVEG unknown" + STOP + !CALL wrf_error_fatal("Namelist parameter DVEG unknown") + ENDIF + ENDIF + IF(OPT_CROP > 0 .and. CROPTYPE > 0) THEN + FVEG = SHDMAX + IF(FVEG <= 0.05) FVEG = 0.05 + ENDIF + IF(parameters%urban_flag .OR. VEGTYP == parameters%ISBARREN) FVEG = 0.0 + IF(ELAI+ESAI == 0.0) FVEG = 0.0 + +! Calling dynamic irrigation scheme-prasanth + IF ( TRIM(LLANDUSE) == "USGS" ) THEN + IF(VEGTYP .GE. 3 .AND. VEGTYP .LE. 6) CROPLU = .TRUE. + ELSE IF ( TRIM(LLANDUSE) == "MODIFIED_IGBP_MODIS_NOAH") THEN + IF(VEGTYP == 12 .OR. VEGTYP == 14) CROPLU = .TRUE. + END IF + + SIFAC = SIFRA + MIFAC = MIFRA + FIFAC = FIFRA + + +! If OPT_IRRM = 0 and if methods are unknown for certain area, then use sprinkler irrigation method + IF (OPT_IRR .GT. 0) THEN + IF (OPT_IRRM .EQ. 0) THEN + IF ((SIFAC .EQ. 0.) .AND. (MIFAC .EQ. 0.) .AND. (FIFAC .EQ. 0.) & + .AND. (IRRFRA .GE. parameters%IRR_FRAC)) THEN + SIFAC = 1.0 + ENDIF + ENDIF + END IF +! choose method based on user namelist choice + IF(OPT_IRRM .EQ. 1) THEN + SIFAC = 1. + MIFAC = 0. + FIFAC = 0. + ELSE IF(OPT_IRRM .EQ. 2) THEN + SIFAC = 0. + MIFAC = 1. + FIFAC = 0. + ELSE IF(OPT_IRRM .EQ. 3) THEN + SIFAC = 0. + MIFAC = 0. + FIFAC = 1. + END IF + +! Call triggering function + IF(OPT_IRR .GT. 0) THEN + IF (CROPLU .EQV. .TRUE.) THEN + IF ((IRRFRA .GE. parameters%IRR_FRAC) .AND. & + (RAIN .LT. (parameters%IR_RAIN/3600.)) .AND. ((IRAMTSI+IRAMTMI+IRAMTFI) .EQ. 0.0) )THEN + CALL TRIGGER_IRRIGATION(parameters,NSOIL,ZSOIL,SH2O,FVEG,JULIAN,IRRFRA,LAI, & !in + SIFAC,MIFAC,FIFAC, & !in + IRCNTSI,IRCNTMI,IRCNTFI, & !inout + IRAMTSI,IRAMTMI,IRAMTFI) !inout + END IF + END IF + END IF +! set irrigation off if parameters%IR_RAIN mm/h for this time step and irr triggered last time step + IF(OPT_IRR .GT. 0) THEN + IF((RAIN .GE. (parameters%IR_RAIN/3600.)) .OR. (IRRFRA .LT. parameters%IRR_FRAC))THEN + IRAMTSI = 0. + IRAMTMI = 0. + IRAMTFI = 0. + END IF + END IF +! call sprinkler irrigation before CANWAT/PRECIP_HEAT to have canopy interception + IF((CROPLU .EQV. .TRUE.) .AND. (IRAMTSI .GT. 0.0)) THEN + CALL SPRINKLER_IRRIGATION(parameters,NSOIL,DT,SH2O,SMC,SICE,& !in + SFCTMP,UU,VV,EAIR,SIFAC, & !in + IRAMTSI,IREVPLOS,IRSIRATE) !inout + RAIN = RAIN + (IRSIRATE*1000./DT) ![mm/s] + ! cooling and humidification due to sprinkler evaporation, per m^2 calculation + FIRR = IREVPLOS*1000.*HVAP/DT ! heat used for evaporation (W/m2) + EIRR = IREVPLOS*1000./DT ! sprinkler evaporation (mm/s) + END IF +! call for micro irrigation and flood irrigation are implemented in WATER subroutine +! end irrigation call-prasanth + + CALL PRECIP_HEAT(parameters,ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in + ELAI ,ESAI ,FVEG ,IST , & !in + BDFALL ,RAIN ,SNOW ,FP , & !in + CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in + QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out + PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out + FWET ,CMC ) !out + +! compute energy budget (momentum & energy fluxes and phase changes) + + CALL ENERGY (parameters,ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in + ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in + SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZLVL , & !in + CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in + EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in + ELAI ,ESAI ,FWET ,FOLN , & !in + FVEG ,PAHV ,PAHG ,PAHB , & !in + QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,iloc, jloc , & !in + Z0WRF , & + IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out + SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out + TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out + TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , & !out + PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !out + TV ,TG ,STC ,SNOWH ,EAH ,TAH , & !inout + SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , & !inout + ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout + TAUSS ,LAISUN ,LAISHA ,RB , & !inout +!jref:start + QC ,QSFC ,PSFC , & !in + T2MV ,T2MB ,FSRV , & + FSRG ,RSSUN ,RSSHA ,ALBSND ,ALBSNI, BGAP ,WGAP,TGV,TGB,& + Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB , & !out + EMISSI ,PAH , & + SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2,& + JULIAN, SWDOWN, PRCP, FB, GECROS1D ) +!jref:end + + SICE(:) = MAX(0.0, SMC(:) - SH2O(:)) + SNEQVO = SNEQV + + QVAP = MAX( FGEV/LATHEAG, 0.) ! positive part of fgev; Barlage change to ground v3.6 + QDEW = ABS( MIN(FGEV/LATHEAG, 0.)) ! negative part of fgev + EDIR = QVAP - QDEW + +! compute water budgets (water storages, ET components, and runoff) + + CALL WATER (parameters,VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in + VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in + ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in + IRRFRA ,MIFAC ,FIFAC ,CROPLU , & !in + FICEOLD,PONDING,TG ,IST ,FVEG ,iloc,jloc , SMCEQ , & !in + BDFALL ,FP ,RAIN ,SNOW , & !in MB/AN: v3.7 + QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB + ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout + SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout + SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout + SMCWTD ,DEEPRECH,RECH , & !inout + IRAMTFI,IRAMTMI ,IRFIRATE ,IRMIRATE, & !inout + CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out + QIN ,QDIS ,PONDING1 ,PONDING2,& + QSNBOT & +!#ifdef WRF_HYDRO +! ,sfcheadrt & +!#endif + ) !out + +! write(*,'(a20,10F15.5)') 'SFLX:RUNOFF=',RUNSRF*DT,RUNSUB*DT,EDIR*DT + +! compute carbon budgets (carbon storages and co2 & bvoc fluxes) + + crop_active = .false. + dveg_active = .false. + IF (DVEG == 2 .OR. DVEG == 5 .OR. DVEG == 6) dveg_active = .true. + IF (OPT_CROP > 0 .and. CROPTYPE > 0) THEN + crop_active = .true. + dveg_active = .false. + ENDIF + + IF (dveg_active) THEN + CALL CARBON (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in + DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in + FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in + TROOT ,IST ,LAT ,iloc ,jloc , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out + TOTLB ,LAI ,SAI ) !out + END IF + + IF (OPT_CROP == 1 .and. crop_active) THEN + CALL CARBON_CROP (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL ,JULIAN , & !in + DZSNSO ,STC ,SMC ,TV ,PSN ,FOLN ,BTRAN , & !in + SOLDN ,T2M , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP ,GRAIN , & !inout + LAI ,SAI ,GDD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC ,TOTLB, PGS ) !out + END IF + +! before waterbalance check add irrigation water to precipitation + +IF (OPT_IRR .GT. 0) THEN + IF (CROPLU .EQV. .TRUE.) THEN + IF (IRRFRA .GE. parameters%IRR_FRAC) THEN + PRCP = PRCP + ((IRSIRATE+IRMIRATE+IRFIRATE)*1000./DT) ! irrigation + FSH = FSH - FIRR ! (W/m2) + END IF + END IF +END IF + +! water and energy balance check + + CALL ERROR (parameters,SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & !in + FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , & !in + SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & !in + ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & !in + NSNOW ,IST ,ERRWAT ,ILOC , JLOC ,FVEG , & + SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & + PAHV ,PAHG ,PAHB ,FIRR) !in ( Except ERRWAT, which is out ) + +! urban - jref + QFX = ETRAN + ECAN + EDIR + IF ( parameters%urban_flag ) THEN + QSFC = QFX/(RHOAIR*CH) + QAIR + Q2B = QSFC + END IF + + IF(SNOWH <= 1.E-6 .OR. SNEQV <= 1.E-3) THEN + SNOWH = 0.0 + SNEQV = 0.0 + END IF + + IF(SWDOWN.NE.0.) THEN + ALBEDO = FSR / SWDOWN + ELSE + ALBEDO = -999.9 + END IF + + + END SUBROUTINE NOAHMP_SFLX + +!== begin atm ====================================================================================== + + SUBROUTINE ATM (parameters,SFCPRS ,SFCTMP ,Q2 , & + PRCPCONV,PRCPNONC ,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL , & + SOLDN ,COSZ ,THAIR ,QAIR , & + EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD , SOLAI , & + SWDOWN ,BDFALL ,RAIN ,SNOW ,FP , FPICE ,PRCP ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! ---------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) + REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] + +! outputs + + REAL , INTENT(OUT) :: THAIR !potential temperature (k) + REAL , INTENT(OUT) :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) + REAL , INTENT(OUT) :: EAIR !vapor pressure air (pa) + REAL , INTENT(OUT) :: RHOAIR !density air (kg/m3) + REAL , INTENT(OUT) :: QPRECC !convective precipitation (mm/s) + REAL , INTENT(OUT) :: QPRECL !large-scale precipitation (mm/s) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL , INTENT(OUT) :: SWDOWN !downward solar filtered by sun angle [w/m2] + REAL , INTENT(OUT) :: BDFALL !!bulk density of snowfall (kg/m3) AJN + REAL , INTENT(OUT) :: RAIN !rainfall (mm/s) AJN + REAL , INTENT(OUT) :: SNOW !liquid equivalent snowfall (mm/s) AJN + REAL , INTENT(OUT) :: FP !fraction of area receiving precipitation AJN + REAL , INTENT(OUT) :: FPICE !fraction of ice AJN + REAL , INTENT(OUT) :: PRCP !total precipitation [mm/s] ! MB/AN : v3.7 + +!locals + + REAL :: PAIR !atm bottom level pressure (pa) + REAL :: PRCP_FROZEN !total frozen precipitation [mm/s] ! MB/AN : v3.7 + REAL, PARAMETER :: RHO_GRPL = 500.0 ! graupel bulk density [kg/m3] ! MB/AN : v3.7 + REAL, PARAMETER :: RHO_HAIL = 917.0 ! hail bulk density [kg/m3] ! MB/AN : v3.7 +! wet-bulb scheme Wang et al., 2019 GRL, C.He, 12/18/2020 + REAL :: ESATAIR ! saturated vapor pressure of air + REAL :: LATHEA ! latent heat of vapor/sublimation + REAL :: GAMMA_b ! (cp*p)/(eps*L) + REAL :: TDC ! air temperature [C] + REAL :: TWET ! wetbulb temperature + INTEGER :: ITER + INTEGER, PARAMETER :: NITER = 10 ! iterations for Twet calculation + +! -------------------------------------------------------------------------------------------------- + +!jref: seems like PAIR should be P1000mb?? + PAIR = SFCPRS ! atm bottom level pressure (pa) + THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) + + QAIR = Q2 ! In WRF, driver converts to specific humidity + + EAIR = QAIR*SFCPRS / (0.622+0.378*QAIR) + RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP) + + IF(COSZ <= 0.) THEN + SWDOWN = 0. + ELSE + SWDOWN = SOLDN + END IF + + SOLAD(1) = SWDOWN*0.7*0.5 ! direct vis + SOLAD(2) = SWDOWN*0.7*0.5 ! direct nir + SOLAI(1) = SWDOWN*0.3*0.5 ! diffuse vis + SOLAI(2) = SWDOWN*0.3*0.5 ! diffuse nir + + PRCP = PRCPCONV + PRCPNONC + PRCPSHCV + + IF(OPT_SNF == 4) THEN + QPRECC = PRCPCONV + PRCPSHCV + QPRECL = PRCPNONC + ELSE + QPRECC = 0.10 * PRCP ! should be from the atmospheric model + QPRECL = 0.90 * PRCP ! should be from the atmospheric model + END IF + +! fractional area that receives precipitation (see, Niu et al. 2005) + + FP = 0.0 + IF(QPRECC + QPRECL > 0.) & + FP = (QPRECC + QPRECL) / (10.*QPRECC + QPRECL) + +! partition precipitation into rain and snow. Moved from CANWAT MB/AN: v3.7 + +! Jordan (1991) + + IF(OPT_SNF == 1) THEN + IF(SFCTMP > TFRZ+2.5)THEN + FPICE = 0. + ELSE + IF(SFCTMP <= TFRZ+0.5)THEN + FPICE = 1.0 + ELSE IF(SFCTMP <= TFRZ+2.)THEN + FPICE = 1.-(-54.632 + 0.2*SFCTMP) + ELSE + FPICE = 0.6 + ENDIF + ENDIF + ENDIF + + IF(OPT_SNF == 2) THEN + IF(SFCTMP >= TFRZ+2.2) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF + + IF(OPT_SNF == 3) THEN + IF(SFCTMP >= TFRZ) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF + +! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 +! fresh snow density + + BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) !MB/AN: change to MIN + IF(OPT_SNF == 4) THEN + PRCP_FROZEN = PRCPSNOW + PRCPGRPL + PRCPHAIL + IF(PRCPNONC > 0. .and. PRCP_FROZEN > 0.) THEN + FPICE = MIN(1.0,PRCP_FROZEN/PRCPNONC) + FPICE = MAX(0.0,FPICE) + BDFALL = BDFALL*(PRCPSNOW/PRCP_FROZEN) + RHO_GRPL*(PRCPGRPL/PRCP_FROZEN) + & + RHO_HAIL*(PRCPHAIL/PRCP_FROZEN) + ELSE + FPICE = 0.0 + ENDIF + + ENDIF + +! wet-bulb scheme (Wang et al., 2019 GRL), C.He, 12/18/2020 + IF(OPT_SNF == 5) THEN + TDC = MIN( 50., MAX(-50.,(SFCTMP-TFRZ)) ) !Kelvin to degree Celsius with limit -50 to +50 + IF (SFCTMP > TFRZ) THEN + LATHEA = HVAP + ELSE + LATHEA = HSUB + END IF + GAMMA_b = CPAIR*SFCPRS/(0.622*LATHEA) + TWET = TDC - 5. ! first guess wetbulb temperature + DO ITER = 1, NITER + ESATAIR = 610.8 * EXP((17.27*TWET)/(237.3+TWET)) + TWET = TWET - (ESATAIR-EAIR)/ GAMMA_b ! Wang et al., 2019 GRL Eq.2 + END DO + FPICE = 1.0/(1.0+6.99E-5*exp(2.0*(TWET+3.97))) ! Wang et al., 2019 GRL Eq. 1 + ENDIF + + RAIN = PRCP * (1.-FPICE) + SNOW = PRCP * FPICE + +! IF(SFCTMP < TFRZ+2.5) THEN +! print *, 'FPICE = ', FPICE, '; PRCP = ', PRCP +! ENDIF + + + END SUBROUTINE ATM + +!== begin phenology ================================================================================ + + SUBROUTINE PHENOLOGY (parameters,VEGTYP ,croptype, SNOWH , TV , LAT , YEARLEN , JULIAN , & !in + LAI , SAI , TROOT , ELAI , ESAI , IGS, PGS) + +! -------------------------------------------------------------------------------------------------- +! vegetation phenology considering vegeation canopy being buries by snow and evolution in time +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN ) :: VEGTYP !vegetation type + INTEGER , INTENT(IN ) :: CROPTYPE !vegetation type + REAL , INTENT(IN ) :: SNOWH !snow height [m] + REAL , INTENT(IN ) :: TV !vegetation temperature (k) + REAL , INTENT(IN ) :: LAT !latitude (radians) + INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year + REAL , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) + real , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) + REAL , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow + REAL , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow + +! outputs + REAL , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow + REAL , INTENT(OUT ) :: ESAI !stem area index, after burying by snow + REAL , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) + INTEGER , INTENT(IN ) :: PGS !plant growing stage + +! locals + + REAL :: DB !thickness of canopy buried by snow (m) + REAL :: FB !fraction of canopy buried by snow + REAL :: SNOWHC !critical snow depth at which short vege + !is fully covered by snow + + INTEGER :: K !index + INTEGER :: IT1,IT2 !interpolation months + REAL :: DAY !current day of year ( 0 <= DAY < YEARLEN ) + REAL :: WT1,WT2 !interpolation weights + REAL :: T !current month (1.00, ..., 12.00) +! -------------------------------------------------------------------------------------------------- + +IF (CROPTYPE == 0) THEN + + IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN + + IF (LAT >= 0.) THEN + ! Northern Hemisphere + DAY = JULIAN + ELSE + ! Southern Hemisphere. DAY is shifted by 1/2 year. + DAY = MOD ( JULIAN + ( 0.5 * YEARLEN ) , REAL(YEARLEN) ) + ENDIF + + T = 12. * DAY / REAL(YEARLEN) + IT1 = T + 0.5 + IT2 = IT1 + 1 + WT1 = (IT1+0.5) - T + WT2 = 1.-WT1 + IF (IT1 .LT. 1) IT1 = 12 + IF (IT2 .GT. 12) IT2 = 1 + + LAI = WT1*parameters%LAIM(IT1) + WT2*parameters%LAIM(IT2) + SAI = WT1*parameters%SAIM(IT1) + WT2*parameters%SAIM(IT2) + ENDIF + + IF(DVEG == 7 .or. DVEG == 8 .or. DVEG == 9) THEN + SAI = MAX(0.05,0.1 * LAI) ! when reading LAI, set SAI to 10% LAI, but not below 0.05 MB: v3.8 + IF (LAI < 0.05) SAI = 0.0 ! if LAI below minimum, make sure SAI = 0 + ENDIF + + IF (SAI < 0.05) SAI = 0.0 ! MB: SAI CHECK, change to 0.05 v3.6 + IF (LAI < 0.05 .OR. SAI == 0.0) LAI = 0.0 ! MB: LAI CHECK + + IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. & + ( VEGTYP == parameters%ISICE ) .or. ( parameters%urban_flag ) ) THEN + LAI = 0. + SAI = 0. + ENDIF + +ENDIF ! CROPTYPE == 0 + +!buried by snow + + DB = MIN( MAX(SNOWH - parameters%HVB,0.), parameters%HVT-parameters%HVB ) + FB = DB / MAX(1.E-06,parameters%HVT-parameters%HVB) + + IF(parameters%HVT> 0. .AND. parameters%HVT <= 1.0) THEN !MB: change to 1.0 and 0.2 to reflect + SNOWHC = parameters%HVT*EXP(-SNOWH/0.2) ! changes to HVT in MPTABLE + FB = MIN(SNOWH,SNOWHC)/SNOWHC + ENDIF + + ELAI = LAI*(1.-FB) + ESAI = SAI*(1.-FB) + IF (ESAI < 0.05 .and. CROPTYPE == 0) ESAI = 0.0 ! MB: ESAI CHECK, change to 0.05 v3.6 + IF ((ELAI < 0.05 .OR. ESAI == 0.0) .and. CROPTYPE == 0) ELAI = 0.0 ! MB: LAI CHECK + +! set growing season flag + + IF ((TV .GT. parameters%TMIN .and. CROPTYPE == 0).or.(PGS > 2 .and. PGS < 7 .and. CROPTYPE > 0)) THEN + IGS = 1. + ELSE + IGS = 0. + ENDIF + + END SUBROUTINE PHENOLOGY + +!== begin precip_heat ============================================================================== + + SUBROUTINE PRECIP_HEAT (parameters,ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in + ELAI ,ESAI ,FVEG ,IST , & !in + BDFALL ,RAIN ,SNOW ,FP , & !in + CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in + QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out + PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out + FWET ,CMC ) !out + +! ------------------------ code history ------------------------------ +! Michael Barlage: Oct 2013 - split CANWATER to calculate precip movement for +! tracking of advected heat +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: VEGTYP !vegetation type + INTEGER,INTENT(IN) :: IST !surface type 1-soil; 2-lake + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] + REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] + REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow + REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow + REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL, INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) + REAL, INTENT(IN) :: RAIN !rainfall (mm/s) + REAL, INTENT(IN) :: SNOW !snowfall (mm/s) + REAL, INTENT(IN) :: FP !fraction of the gridcell that receives precipitation + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: SFCTMP !model-level temperature (k) + REAL, INTENT(IN) :: TG !ground temperature (k) + +! input & output + REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + +! output + REAL, INTENT(OUT) :: QINTR !interception rate for rain (mm/s) + REAL, INTENT(OUT) :: QDRIPR !drip rate for rain (mm/s) + REAL, INTENT(OUT) :: QTHROR !throughfall for rain (mm/s) + REAL, INTENT(OUT) :: QINTS !interception (loading) rate for snowfall (mm/s) + REAL, INTENT(OUT) :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) + REAL, INTENT(OUT) :: QTHROS !throughfall of snowfall (mm/s) + REAL, INTENT(OUT) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(OUT) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(OUT) :: PAHB !precipitation advected heat - bare ground net (W/m2) + REAL, INTENT(OUT) :: QRAIN !rain at ground srf (mm/s) [+] + REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(OUT) :: SNOWHIN !snow depth increasing rate (m/s) + REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) + REAL, INTENT(OUT) :: CMC !intercepted water (mm) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + REAL :: MAXSNO !canopy capacity for snow interception (mm) + REAL :: MAXLIQ !canopy capacity for rain interception (mm) + REAL :: FT !temperature factor for unloading rate + REAL :: FV !wind factor for unloading rate + REAL :: PAH_AC !precipitation advected heat - air to canopy (W/m2) + REAL :: PAH_CG !precipitation advected heat - canopy to ground (W/m2) + REAL :: PAH_AG !precipitation advected heat - air to ground (W/m2) + REAL :: ICEDRIP !canice unloading +! -------------------------------------------------------------------- +! initialization + + QINTR = 0. + QDRIPR = 0. + QTHROR = 0. + QINTR = 0. + QINTS = 0. + QDRIPS = 0. + QTHROS = 0. + PAH_AC = 0. + PAH_CG = 0. + PAH_AG = 0. + PAHV = 0. + PAHG = 0. + PAHB = 0. + QRAIN = 0.0 + QSNOW = 0.0 + SNOWHIN = 0.0 + ICEDRIP = 0.0 +! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt +! print*, "precip_heat snow*3600.0:",snow*3600.0 +! print*, "precip_heat rain*3600.0:",rain*3600.0 +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + MAXLIQ = parameters%CH2OP * (ELAI+ ESAI) + +! average interception and throughfall + + IF((ELAI+ ESAI).GT.0.) THEN + QINTR = FVEG * RAIN * FP ! interception capability + QINTR = MIN(QINTR, (MAXLIQ - CANLIQ)/DT * (1.-EXP(-RAIN*DT/MAXLIQ)) ) + QINTR = MAX(QINTR, 0.) + QDRIPR = FVEG * RAIN - QINTR + QTHROR = (1.-FVEG) * RAIN + CANLIQ=MAX(0.,CANLIQ+QINTR*DT) + ELSE + QINTR = 0. + QDRIPR = 0. + QTHROR = RAIN + IF(CANLIQ > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED + QDRIPR = QDRIPR + CANLIQ/DT + CANLIQ = 0.0 + END IF + END IF + +! heat transported by liquid water + + PAH_AC = FVEG * RAIN * (CWAT/1000.0) * (SFCTMP - TV) + PAH_CG = QDRIPR * (CWAT/1000.0) * (TV - TG) + PAH_AG = QTHROR * (CWAT/1000.0) * (SFCTMP - TG) +! print*, "precip_heat PAH_AC:",PAH_AC +! print*, "precip_heat PAH_CG:",PAH_CG +! print*, "precip_heat PAH_AG:",PAH_AG + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) + + IF((ELAI+ ESAI).GT.0.) THEN + QINTS = FVEG * SNOW * FP + QINTS = MIN(QINTS, (MAXSNO - CANICE)/DT * (1.-EXP(-SNOW*DT/MAXSNO)) ) + QINTS = MAX(QINTS, 0.) + FT = MAX(0.0,(TV - 270.15) / 1.87E5) + FV = SQRT(UU*UU + VV*VV) / 1.56E5 + ! MB: changed below to reflect the rain assumption that all precip gets intercepted + ICEDRIP = MAX(0.,CANICE) * (FV+FT) !MB: removed /DT + QDRIPS = (FVEG * SNOW - QINTS) + ICEDRIP + QTHROS = (1.0-FVEG) * SNOW + CANICE= MAX(0.,CANICE + (QINTS - ICEDRIP)*DT) + ELSE + QINTS = 0. + QDRIPS = 0. + QTHROS = SNOW + IF(CANICE > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED + QDRIPS = QDRIPS + CANICE/DT + CANICE = 0.0 + END IF + ENDIF +! print*, "precip_heat canopy through:",3600.0*(FVEG * SNOW - QINTS) +! print*, "precip_heat canopy drip:",3600.0*MAX(0.,CANICE) * (FV+FT) + +! wetted fraction of canopy + + IF(CANICE.GT.0.) THEN + FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06) + ELSE + FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06) + ENDIF + FWET = MIN(FWET, 1.) ** 0.667 + +! total canopy water + + CMC = CANLIQ + CANICE + +! heat transported by snow/ice + + PAH_AC = PAH_AC + FVEG * SNOW * (CICE/1000.0) * (SFCTMP - TV) + PAH_CG = PAH_CG + QDRIPS * (CICE/1000.0) * (TV - TG) + PAH_AG = PAH_AG + QTHROS * (CICE/1000.0) * (SFCTMP - TG) + + PAHV = PAH_AC - PAH_CG + PAHG = PAH_CG + PAHB = PAH_AG + + IF (FVEG > 0.0 .AND. FVEG < 1.0) THEN + PAHG = PAHG / FVEG ! these will be multiplied by fraction later + PAHB = PAHB / (1.0-FVEG) + ELSEIF (FVEG <= 0.0) THEN + PAHB = PAHG + PAHB ! for case of canopy getting buried + PAHG = 0.0 + PAHV = 0.0 + ELSEIF (FVEG >= 1.0) THEN + PAHB = 0.0 + END IF + + PAHV = MAX(PAHV,-20.0) ! Put some artificial limits here for stability + PAHV = MIN(PAHV,20.0) + PAHG = MAX(PAHG,-20.0) + PAHG = MIN(PAHG,20.0) + PAHB = MAX(PAHB,-20.0) + PAHB = MIN(PAHB,20.0) + +! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg +! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros) +! print*, "precip_heat maxsno:",maxsno +! print*, "precip_heat PAH_AC:",PAH_AC +! print*, "precip_heat PAH_CG:",PAH_CG +! print*, "precip_heat PAH_AG:",PAH_AG + +! print*, "precip_heat PAHV:",PAHV +! print*, "precip_heat PAHG:",PAHG +! print*, "precip_heat PAHB:",PAHB +! print*, "precip_heat fveg:",fveg +! print*, "precip_heat qints*3600.0:",qints*3600.0 +! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0 +! print*, "precip_heat qthros*3600.0:",qthros*3600.0 + +! rain or snow on the ground + + QRAIN = QDRIPR + QTHROR + QSNOW = QDRIPS + QTHROS + SNOWHIN = QSNOW/BDFALL + + IF (IST == 2 .AND. TG > TFRZ) THEN + QSNOW = 0. + SNOWHIN = 0. + END IF +! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0 +! print*, "precip_heat qrain*3600.0:",qrain*3600.0 +! print*, "precip_heat SNOWHIN:",SNOWHIN +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq +! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt + + + END SUBROUTINE PRECIP_HEAT + +!== begin error ==================================================================================== + + SUBROUTINE ERROR (parameters,SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & + FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , & + SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & + ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & + NSNOW ,IST ,ERRWAT, ILOC ,JLOC ,FVEG , & + SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & + PAHV ,PAHG ,PAHB ,FIRR) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + REAL , INTENT(IN) :: SWDOWN !downward solar filtered by sun angle [w/m2] + REAL , INTENT(IN) :: FSA !total absorbed solar radiation (w/m2) + REAL , INTENT(IN) :: FSR !total reflected solar radiation (w/m2) + REAL , INTENT(IN) :: FIRA !total net longwave rad (w/m2) [+ to atm] + REAL , INTENT(IN) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: FCEV !canopy evaporation heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: FGEV !ground evaporation heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: FCTR !transpiration heat flux (w/m2) [+ to atm] + REAL , INTENT(IN) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , INTENT(IN) :: FVEG + REAL , INTENT(IN) :: SAV + REAL , INTENT(IN) :: SAG + REAL , INTENT(IN) :: FSRV + REAL , INTENT(IN) :: FSRG + REAL , INTENT(IN) :: ZWT + + REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) + REAL , INTENT(IN) :: ECAN !evaporation of intercepted water (mm/s) + REAL , INTENT(IN) :: ETRAN !transpiration rate (mm/s) + REAL , INTENT(IN) :: EDIR !soil surface evaporation rate[mm/s] + REAL , INTENT(IN) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(IN) :: RUNSUB !baseflow (saturation excess) [mm/s] + REAL , INTENT(IN) :: CANLIQ !intercepted liquid water (mm) + REAL , INTENT(IN) :: CANICE !intercepted ice mass (mm) + REAL , INTENT(IN) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL , INTENT(IN) :: WA !water storage in aquifer [mm] + REAL , INTENT(IN) :: DT !time step [sec] + REAL , INTENT(IN) :: BEG_WB !water storage at begin of a timesetp [mm] + REAL , INTENT(OUT) :: ERRWAT !error in water balance [mm/timestep] + REAL, INTENT(IN) :: PAH !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHV !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHB !precipitation advected heat - total (W/m2) + REAL , INTENT(IN) :: FIRR ! latent heating due to sprinkler evaporation (w/m2) [+ to atm] + + INTEGER :: IZ !do-loop index + REAL :: END_WB !water storage at end of a timestep [mm] + !KWM REAL :: ERRWAT !error in water balance [mm/timestep] + REAL :: ERRENG !error in surface energy balance [w/m2] + REAL :: ERRSW !error in shortwave radiation balance [w/m2] + REAL :: FSRVG + CHARACTER(len=256) :: message +! -------------------------------------------------------------------------------------------------- +!jref:start + ERRSW = SWDOWN - (FSA + FSR) +! ERRSW = SWDOWN - (SAV+SAG + FSRV+FSRG) +! WRITE(*,*) "ERRSW =",ERRSW + IF (ABS(ERRSW) > 0.01) THEN ! w/m2 + WRITE(*,*) "VEGETATION!" + WRITE(*,*) "SWDOWN*FVEG =",SWDOWN*FVEG + WRITE(*,*) "FVEG*(SAV+SAG) =",FVEG*SAV + SAG + WRITE(*,*) "FVEG*(FSRV +FSRG)=",FVEG*FSRV + FSRG + WRITE(*,*) "GROUND!" + WRITE(*,*) "(1-.FVEG)*SWDOWN =",(1.-FVEG)*SWDOWN + WRITE(*,*) "(1.-FVEG)*SAG =",(1.-FVEG)*SAG + WRITE(*,*) "(1.-FVEG)*FSRG=",(1.-FVEG)*FSRG + WRITE(*,*) "FSRV =",FSRV + WRITE(*,*) "FSRG =",FSRG + WRITE(*,*) "FSR =",FSR + WRITE(*,*) "SAV =",SAV + WRITE(*,*) "SAG =",SAG + WRITE(*,*) "FSA =",FSA +!jref:end + WRITE(message,*) 'ERRSW =',ERRSW + WRITE(*,*) "Stop in Noah-MP" + STOP +! call wrf_message(trim(message)) +! call wrf_error_fatal("Stop in Noah-MP") + END IF + + ERRENG = SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL+FIRR) +PAH +! ERRENG = FVEG*SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) +! WRITE(*,*) "ERRENG =",ERRENG + IF(ABS(ERRENG) > 0.01) THEN + WRITE(message,*) 'ERRENG =',ERRENG,' at i,j: ',ILOC,JLOC +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Net solar: ",FSA +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Net longwave: ",FIRA +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Total sensible: ",FSH +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Canopy evap: ",FCEV +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Ground evap: ",FGEV +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Transpiration: ",FCTR +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Total ground: ",SSOIL +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Sprinkler: ",FIRR +! call wrf_message(trim(message)) + WRITE(message,'(a17,4F10.4)') "Precip advected: ",PAH,PAHV,PAHG,PAHB +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Precip: ",PRCP +! call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Veg fraction: ",FVEG +! call wrf_message(trim(message)) + WRITE(*,*) "Energy budget problem in Noah-MP LSM" + STOP +! call wrf_error_fatal("Energy budget problem in NOAHMP LSM") + END IF + + IF (IST == 1) THEN !soil + END_WB = CANLIQ + CANICE + SNEQV + WA + DO IZ = 1,NSOIL + END_WB = END_WB + SMC(IZ) * DZSNSO(IZ) * 1000. + END DO + ERRWAT = END_WB-BEG_WB-(PRCP-ECAN-ETRAN-EDIR-RUNSRF-RUNSUB)*DT + +!#ifndef WRF_HYDRO +! IF(ABS(ERRWAT) > 0.1) THEN +! if (ERRWAT > 0) then +! call wrf_message ('The model is gaining water (ERRWAT is positive)') +! else +! call wrf_message('The model is losing water (ERRWAT is negative)') +! endif +! write(message, *) 'ERRWAT =',ERRWAT, "kg m{-2} timestep{-1}" +! call wrf_message(trim(message)) +! WRITE(message, & +! '(" I J END_WB BEG_WB PRCP ECAN EDIR ETRAN RUNSRF RUNSUB")') +! call wrf_message(trim(message)) +! WRITE(message,'(i6,1x,i6,1x,2f15.3,9f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,ECAN*DT,& +! EDIR*DT,ETRAN*DT,RUNSRF*DT,RUNSUB*DT,ZWT +! call wrf_message(trim(message)) +! call wrf_error_fatal("Water budget problem in NOAHMP LSM") +! END IF +!#endif + ELSE !KWM + ERRWAT = 0.0 !KWM + ENDIF + + END SUBROUTINE ERROR + +!== begin energy =================================================================================== + + SUBROUTINE ENERGY (parameters,ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in + ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in + SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZREF , & !in + CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in + EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in + ELAI ,ESAI ,FWET ,FOLN , & !in + FVEG ,PAHV ,PAHG ,PAHB , & !in + QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,ILOC , JLOC, & !in + Z0WRF , & + IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out + SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out + TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out + TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , & !out + PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !out + TV ,TG ,STC ,SNOWH ,EAH ,TAH , & !inout + SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , & !inout + ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout + TAUSS ,LAISUN ,LAISHA ,RB , & !inout +!jref:start + QC ,QSFC ,PSFC , & !in + T2MV ,T2MB ,FSRV , & + FSRG ,RSSUN ,RSSHA ,ALBSND ,ALBSNI,BGAP ,WGAP,TGV,TGB,& + Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB, EMISSI,PAH ,& + SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2, & + JULIAN, SWDOWN, PRCP, FB, GECROS1D ) +!jref:end + +! -------------------------------------------------------------------------------------------------- +! we use different approaches to deal with subgrid features of radiation transfer and turbulent +! transfer. We use 'tile' approach to compute turbulent fluxes, while we use modified two- +! stream to compute radiation transfer. Tile approach, assemblying vegetation canopies together, +! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. The +! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree +! crowns. +! -------------------------------------------------------------------------------------------------- +! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and +! bare fraction separately and then sum them up weighted by fraction +! -------------------------------------- +! / O O O O O O O O / / +! / | | | | | | | | / / +! / O O O O O O O O / / +! / | | |tile1| | | | / tile2 / +! / O O O O O O O O / bare / +! / | | | vegetated | | / / +! / O O O O O O O O / / +! / | | | | | | | | / / +! -------------------------------------- +! -------------------------------------------------------------------------------------------------- +! radiation transfer : modified two-stream (Yang and Friedl, 2003, JGR; Niu ang Yang, 2004, JGR) +! -------------------------------------- two-stream treats leaves as +! / O O O O O O O O / cloud over the entire grid-cell, +! / | | | | | | | | / while the modified two-stream +! / O O O O O O O O / aggregates cloudy leaves into +! / | | | | | | | | / tree crowns with gaps (as shown in +! / O O O O O O O O / the left figure). We assume these +! / | | | | | | | | / tree crowns are evenly distributed +! / O O O O O O O O / within the gridcell with 100% veg +! / | | | | | | | | / fraction, but with gaps. The 'tile' +! -------------------------------------- approach overlaps too much shadows. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , INTENT(IN) :: ILOC + integer , INTENT(IN) :: JLOC + INTEGER , INTENT(IN) :: ICE !ice (ice = 1) + INTEGER , INTENT(IN) :: VEGTYP !vegetation physiology type + INTEGER , INTENT(IN) :: IST !surface type: 1->soil; 2->lake + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers + REAL , INTENT(IN) :: DT !time step [sec] + REAL , INTENT(IN) :: QSNOW !snowfall on the ground (mm/s) + REAL , INTENT(IN) :: RHOAIR !density air (kg/m3) + REAL , INTENT(IN) :: EAIR !vapor pressure air (pa) + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(IN) :: QAIR !specific humidity (kg/kg) + REAL , INTENT(IN) :: SFCTMP !air temperature (k) + REAL , INTENT(IN) :: THAIR !potential temperature (k) + REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) + REAL , INTENT(IN) :: UU !wind speed in e-w dir (m/s) + REAL , INTENT(IN) :: VV !wind speed in n-s dir (m/s) + REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAD !incoming direct solar rad. (w/m2) + REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAI !incoming diffuse solar rad. (w/m2) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL , INTENT(IN) :: ELAI !LAI adjusted for burying by snow + REAL , INTENT(IN) :: ESAI !LAI adjusted for burying by snow + REAL , INTENT(IN) :: FWET !fraction of canopy that is wet [-] + REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL , INTENT(IN) :: CANLIQ !canopy-intercepted liquid water (mm) + REAL , INTENT(IN) :: CANICE !canopy-intercepted ice mass (mm) + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) + REAL , INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) + REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) + + REAL , INTENT(IN) :: ZREF !reference height (m) + REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. (k) + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf [m] + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !depth of snow & soil layer-bottom [m] + REAL, INTENT(IN) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(IN) :: PAHB !precipitation advected heat - bare ground net (W/m2) + +!jref:start; in + REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL , INTENT(IN) :: PSFC !pressure at lowest model layer + REAL , INTENT(IN) :: DX !horisontal resolution + REAL , INTENT(IN) :: DZ8W !thickness of lowest layer + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) +!jref:end + +! outputs + REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model + INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index [1-melt; 2-freeze] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume ice [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume liq. water [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + REAL , INTENT(OUT) :: FSNO !snow cover fraction (-) + REAL , INTENT(OUT) :: QMELT !snowmelt [mm/s] + REAL , INTENT(OUT) :: PONDING!pounding at ground [mm] + REAL , INTENT(OUT) :: SAV !solar rad. absorbed by veg. (w/m2) + REAL , INTENT(OUT) :: SAG !solar rad. absorbed by ground (w/m2) + REAL , INTENT(OUT) :: FSA !tot. absorbed solar radiation (w/m2) + REAL , INTENT(OUT) :: FSR !tot. reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: TAUX !wind stress: e-w (n/m2) + REAL , INTENT(OUT) :: TAUY !wind stress: n-s (n/m2) + REAL , INTENT(OUT) :: FIRA !total net LW. rad (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCEV !canopy evaporation (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FGEV !ground evaporation (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCTR !transpiration (w/m2) [+ to atm] + REAL , INTENT(OUT) :: TRAD !radiative temperature (k) + REAL , INTENT(OUT) :: T2M !2 m height air temperature (k) + REAL , INTENT(OUT) :: PSN !total photosyn. (umolco2/m2/s) [+] + REAL , INTENT(OUT) :: APAR !total photosyn. active energy (w/m2) + REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , DIMENSION( 1:NSOIL), INTENT(OUT) :: BTRANI !soil water transpiration factor (0-1) + REAL , INTENT(OUT) :: BTRAN !soil water transpiration factor (0-1) +! REAL , INTENT(OUT) :: LATHEA !latent heat vap./sublimation (j/kg) + REAL , INTENT(OUT) :: LATHEAV !latent heat vap./sublimation (j/kg) + REAL , INTENT(OUT) :: LATHEAG !latent heat vap./sublimation (j/kg) + LOGICAL , INTENT(OUT) :: FROZEN_GROUND ! used to define latent heat pathway + LOGICAL , INTENT(OUT) :: FROZEN_CANOPY ! used to define latent heat pathway + +!jref:start + REAL , INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) +!jref:end - out for debug + +!jref:start; output + REAL , INTENT(OUT) :: T2MV !2-m air temperature over vegetated part [k] + REAL , INTENT(OUT) :: T2MB !2-m air temperature over bare ground part [k] + REAL , INTENT(OUT) :: BGAP + REAL , INTENT(OUT) :: WGAP + REAL, DIMENSION(1:2) , INTENT(OUT) :: ALBSND !snow albedo (direct) + REAL, DIMENSION(1:2) , INTENT(OUT) :: ALBSNI !snow albedo (diffuse) +!jref:end + +! input & output + REAL , INTENT(INOUT) :: TS !surface temperature (k) + REAL , INTENT(INOUT) :: TV !vegetation temperature (k) + REAL , INTENT(INOUT) :: TG !ground temperature (k) + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] + REAL , INTENT(INOUT) :: SNOWH !snow height [m] + REAL , INTENT(INOUT) :: SNEQV !snow mass (mm) + REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) + REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] + REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow ice mass (kg/m2) + REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow liq mass (kg/m2) + REAL , INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) + REAL , INTENT(INOUT) :: TAH !canopy air temperature (k) + REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step(CLASS type) + REAL , INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL , INTENT(INOUT) :: CM !momentum drag coefficient + REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient + REAL , INTENT(INOUT) :: Q1 + REAL , INTENT(INOUT) :: RB !leaf boundary layer resistance (s/m) + REAL , INTENT(INOUT) :: LAISUN !sunlit leaf area index (m2/m2) + REAL , INTENT(INOUT) :: LAISHA !shaded leaf area index (m2/m2) +! REAL :: Q2E + REAL, INTENT(OUT) :: EMISSI + REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) + +! local + INTEGER :: IZ !do-loop index + LOGICAL :: VEG !true if vegetated surface + REAL :: UR !wind speed at height ZLVL (m/s) + REAL :: ZLVL !reference height (m) + REAL :: FSUN !sunlit fraction of canopy [-] + ! REAL :: RB !leaf boundary layer resistance (s/m) + REAL :: RSURF !ground surface resistance (s/m) + REAL :: L_RSURF!Dry-layer thickness for computing RSURF (Sakaguchi and Zeng, 2009) + REAL :: D_RSURF!Reduced vapor diffusivity in soil for computing RSURF (SZ09) + REAL :: BEVAP !soil water evaporation factor (0- 1) + REAL :: MOL !Monin-Obukhov length (m) + REAL :: VAI !sum of LAI + stem area index [m2/m2] + REAL :: CWP !canopy wind extinction parameter + REAL :: ZPD !zero plane displacement (m) + REAL :: Z0M !z0 momentum (m) + REAL :: ZPDG !zero plane displacement (m) + REAL :: Z0MG !z0 momentum, ground (m) + REAL :: EMV !vegetation emissivity + REAL :: EMG !ground emissivity + REAL :: FIRE !emitted IR (w/m2) + + REAL :: PSNSUN !sunlit photosynthesis (umolco2/m2/s) + REAL :: PSNSHA !shaded photosynthesis (umolco2/m2/s) +!jref:start - for debug +! REAL :: RSSUN !sunlit stomatal resistance (s/m) +! REAL :: RSSHA !shaded stomatal resistance (s/m) +!jref:end - for debug + REAL :: PARSUN !par absorbed per sunlit LAI (w/m2) + REAL :: PARSHA !par absorbed per shaded LAI (w/m2) + + REAL, DIMENSION(-NSNOW+1:NSOIL) :: FACT !temporary used in phase change + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: HCPCT !heat capacity [j/m3/k] + REAL :: BDSNO !bulk density of snow (kg/m3) + REAL :: FMELT !melting factor for snow cover frac + REAL :: GX !temporary variable + REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI !light through water (w/m2) +! REAL :: GAMMA !psychrometric constant (pa/k) + REAL :: GAMMAV !psychrometric constant (pa/k) + REAL :: GAMMAG !psychrometric constant (pa/k) + REAL :: PSI !surface layer soil matrix potential (m) + REAL :: RHSUR !raltive humidity in surface soil/snow air space (-) + +! temperature and fluxes over vegetated fraction + + REAL :: TAUXV !wind stress: e-w dir [n/m2] + REAL :: TAUYV !wind stress: n-s dir [n/m2] + REAL,INTENT(OUT) :: IRC !canopy net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: IRG !ground net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHC !canopy sen. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHG !ground sen. heat [w/m2] [+ to atm] +!jref:start + REAL,INTENT(OUT) :: Q2V + REAL,INTENT(OUT) :: Q2B + REAL,INTENT(OUT) :: Q2E +!jref:end + REAL,INTENT(OUT) :: EVC !canopy evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVG !ground evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: TR !transpiration heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHV !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: TGV !ground surface temp. [k] + REAL :: CMV !momentum drag coefficient + REAL,INTENT(OUT) :: CHV !sensible heat exchange coefficient + +! temperature and fluxes over bare soil fraction + + REAL :: TAUXB !wind stress: e-w dir [n/m2] + REAL :: TAUYB !wind stress: n-s dir [n/m2] + REAL,INTENT(OUT) :: IRB !net longwave rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHB !sensible heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVB !evaporation heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHB !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: TGB !ground surface temp. [k] + REAL :: CMB !momentum drag coefficient + REAL,INTENT(OUT) :: CHB !sensible heat exchange coefficient + REAL,INTENT(OUT) :: CHLEAF !leaf exchange coefficient + REAL,INTENT(OUT) :: CHUC !under canopy exchange coefficient +!jref:start + REAL,INTENT(OUT) :: CHV2 !sensible heat conductance, canopy air to ZLVL air (m/s) + REAL,INTENT(OUT) :: CHB2 !sensible heat conductance, canopy air to ZLVL air (m/s) + REAL :: noahmpres + + REAL, INTENT(IN) :: JULIAN, SWDOWN, PRCP, FB + REAL,DIMENSION(1:60),INTENT(INOUT) :: GECROS1D + +!jref:end + + REAL, PARAMETER :: MPE = 1.E-6 + REAL, PARAMETER :: PSIWLT = -150. !metric potential for wilting point (m) + REAL, PARAMETER :: Z0 = 0.002 ! Bare-soil roughness length (m) (i.e., under the canopy) + +! --------------------------------------------------------------------------------------------------- +! initialize fluxes from veg. fraction + + TAUXV = 0. + TAUYV = 0. + IRC = 0. + SHC = 0. + IRG = 0. + SHG = 0. + EVG = 0. + EVC = 0. + TR = 0. + GHV = 0. + PSNSUN = 0. + PSNSHA = 0. + T2MV = 0. + Q2V = 0. + CHV = 0. + CHLEAF = 0. + CHUC = 0. + CHV2 = 0. + RB = 0. + +! wind speed at reference height: ur >= 1 + + UR = MAX( SQRT(UU**2.+VV**2.), 1. ) + +! vegetated or non-vegetated + + VAI = ELAI + ESAI + VEG = .FALSE. + IF(VAI > 0.) VEG = .TRUE. + +! ground snow cover fraction [Niu and Yang, 2007, JGR] + + FSNO = 0. + IF(SNOWH.GT.0.) THEN + BDSNO = SNEQV / SNOWH + FMELT = (BDSNO/100.)**parameters%MFSNO + !FSNO = TANH( SNOWH /(2.5* Z0 * FMELT)) + FSNO = TANH( SNOWH /(parameters%SCFFAC * FMELT)) ! C.He: bring hard-coded 2.5*z0 to MPTABLE tunable parameter SCFFAC + ENDIF + +! ground roughness length + + IF(IST == 2) THEN + IF(TG .LE. TFRZ) THEN + Z0MG = 0.01 * (1.0-FSNO) + FSNO * parameters%Z0SNO + ELSE + Z0MG = 0.01 + END IF + ELSE + Z0MG = Z0 * (1.0-FSNO) + FSNO * parameters%Z0SNO + END IF + +! roughness length and displacement height + + ZPDG = SNOWH + IF(VEG) THEN + Z0M = parameters%Z0MVT + ZPD = 0.65 * parameters%HVT + IF(SNOWH.GT.ZPD) ZPD = SNOWH + ELSE + Z0M = Z0MG + ZPD = ZPDG + END IF + +! special case for urban + + IF (parameters%urban_flag) THEN + Z0MG = parameters%Z0MVT + ZPDG = 0.65 * parameters%HVT + Z0M = Z0MG + ZPD = ZPDG + END IF + + ZLVL = MAX(ZPD,parameters%HVT) + ZREF + IF(ZPDG >= ZLVL) ZLVL = ZPDG + ZREF +! UR = UR*LOG(ZLVL/Z0M)/LOG(10./Z0M) !input UR is at 10m + +! canopy wind absorption coeffcient + + CWP = parameters%CWPVT + +! Thermal properties of soil, snow, lake, and frozen soil + + CALL THERMOPROP (parameters,NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in + SMC ,SH2O ,TG ,STC ,UR , & !in + LAT ,Z0M ,ZLVL ,VEGTYP , & !in + DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out + FACT ) !out + +! Solar radiation: absorbed & reflected by the ground and canopy + + CALL RADIATION (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in + TG ,TV ,FSNO ,QSNOW ,FWET , & !in + ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in + FVEG ,ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , & !out + SAV ,SAG ,FSR ,FSA ,FSRV , & + FSRG ,ALBSND ,ALBSNI ,BGAP ,WGAP ) !out + +! vegetation and ground emissivity + + EMV = 1. - EXP(-(ELAI+ESAI)/1.0) + IF (ICE == 1) THEN + EMG = 0.98*(1.-FSNO) + parameters%SNOW_EMIS*FSNO ! move hard-coded snow emissivity as a global parameter to MPTABLE + ELSE + EMG = parameters%EG(IST)*(1.-FSNO) + parameters%SNOW_EMIS*FSNO + END IF + +! soil moisture factor controlling stomatal resistance + + BTRAN = 0. + + IF(IST ==1 ) THEN + DO IZ = 1, parameters%NROOT + IF(OPT_BTR == 1) then ! Noah + GX = (SH2O(IZ)-parameters%SMCWLT(IZ)) / (parameters%SMCREF(IZ)-parameters%SMCWLT(IZ)) + END IF + IF(OPT_BTR == 2) then ! CLM + PSI = MAX(PSIWLT,-parameters%PSISAT(IZ)*(MAX(0.01,SH2O(IZ))/parameters%SMCMAX(IZ))**(-parameters%BEXP(IZ)) ) + GX = (1.-PSI/PSIWLT)/(1.+parameters%PSISAT(IZ)/PSIWLT) + END IF + IF(OPT_BTR == 3) then ! SSiB + PSI = MAX(PSIWLT,-parameters%PSISAT(IZ)*(MAX(0.01,SH2O(IZ))/parameters%SMCMAX(IZ))**(-parameters%BEXP(IZ)) ) + GX = 1.-EXP(-5.8*(LOG(PSIWLT/PSI))) + END IF + + GX = MIN(1.,MAX(0.,GX)) + BTRANI(IZ) = MAX(MPE,DZSNSO(IZ) / (-ZSOIL(parameters%NROOT)) * GX) + BTRAN = BTRAN + BTRANI(IZ) + END DO + BTRAN = MAX(MPE,BTRAN) + + BTRANI(1:parameters%NROOT) = BTRANI(1:parameters%NROOT)/BTRAN + END IF + +! soil surface resistance for ground evap. + + BEVAP = MAX(0.0,SH2O(1)/parameters%SMCMAX(1)) + IF(IST == 2) THEN + RSURF = 1. ! avoid being divided by 0 + RHSUR = 1.0 + ELSE + + IF(OPT_RSF == 1 .OR. OPT_RSF == 4) THEN + ! RSURF based on Sakaguchi and Zeng, 2009 + ! taking the "residual water content" to be the wilting point, + ! and correcting the exponent on the D term (typo in SZ09 ?) + L_RSURF = (-ZSOIL(1)) * ( exp ( (1.0 - MIN(1.0,SH2O(1)/parameters%SMCMAX(1))) ** parameters%RSURF_EXP ) - 1.0 ) / ( 2.71828 - 1.0 ) + D_RSURF = 2.2E-5 * parameters%SMCMAX(1) * parameters%SMCMAX(1) * ( 1.0 - parameters%SMCWLT(1) / parameters%SMCMAX(1) ) ** (2.0+3.0/parameters%BEXP(1)) + RSURF = L_RSURF / D_RSURF + ELSEIF(OPT_RSF == 2) THEN + RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-4.225*BEVAP) !Sellers (1992) ! Older RSURF computations + ELSEIF(OPT_RSF == 3) THEN + RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-6.0 *BEVAP) !adjusted to decrease RSURF for wet soil + ENDIF + + IF(OPT_RSF == 4) THEN ! AD: FSNO weighted; snow RSURF set in MPTABLE v3.8 + RSURF = 1. / (FSNO * (1./parameters%RSURF_SNOW) + (1.-FSNO) * (1./max(RSURF, 0.001))) + ENDIF + + IF(SH2O(1) < 0.01 .and. SNOWH == 0.) RSURF = 1.E6 + PSI = -parameters%PSISAT(1)*(MAX(0.01,SH2O(1))/parameters%SMCMAX(1))**(-parameters%BEXP(1)) + RHSUR = FSNO + (1.-FSNO) * EXP(PSI*GRAV/(RW*TG)) + END IF + +! urban - jref + IF (parameters%urban_flag .and. SNOWH == 0. ) THEN + RSURF = 1.E6 + ENDIF + +! set psychrometric constant + + IF (TV .GT. TFRZ) THEN ! Barlage: add distinction between ground and + LATHEAV = HVAP ! vegetation in v3.6 + frozen_canopy = .false. + ELSE + LATHEAV = HSUB + frozen_canopy = .true. + END IF + GAMMAV = CPAIR*SFCPRS/(0.622*LATHEAV) + + IF (TG .GT. TFRZ) THEN + LATHEAG = HVAP + frozen_ground = .false. + ELSE + LATHEAG = HSUB + frozen_ground = .true. + END IF + GAMMAG = CPAIR*SFCPRS/(0.622*LATHEAG) + +! IF (SFCTMP .GT. TFRZ) THEN +! LATHEA = HVAP +! ELSE +! LATHEA = HSUB +! END IF +! GAMMA = CPAIR*SFCPRS/(0.622*LATHEA) + +! Surface temperatures of the ground and canopy and energy fluxes + + IF (VEG .AND. FVEG > 0) THEN + TGV = TG + CMV = CM + CHV = CH + CALL VEGE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in + DT ,SAV ,SAG ,LWDN ,UR , & !in + UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in + EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG , & !in + FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in + ZLVL ,ZPD ,Z0M ,FVEG , & !in + Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in + CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in + RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in + FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in + RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in + EAH ,TAH ,TV ,TGV ,CMV , & !inout + CHV ,DX ,DZ8W , & !inout + TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out + SHC ,EVG ,EVC ,TR ,GHV , & !out + T2MV ,PSNSUN ,PSNSHA , & !out +!jref:start + QC ,QSFC ,PSFC , & !in + Q2V ,CHV2, CHLEAF, CHUC, & + SH2O,JULIAN, SWDOWN, PRCP, FB, FSR, GECROS1D) ! Gecros +!jref:end + END IF + + TGB = TG + CMB = CM + CHB = CH + CALL BARE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in + LWDN ,UR ,UU ,VV ,SFCTMP , & !in + THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in + DZSNSO ,ZLVL ,ZPDG ,Z0MG ,FSNO, & !in + EMG ,STC ,DF ,RSURF ,LATHEAG , & !in + GAMMAG ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in + TGB ,CMB ,CHB , & !inout + TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out + GHB ,T2MB ,DX ,DZ8W ,VEGTYP , & !out +!jref:start + QC ,QSFC ,PSFC , & !in + SFCPRS ,Q2B, CHB2) !in +!jref:end + +!energy balance at vege canopy: SAV =(IRC+SHC+EVC+TR) *FVEG at FVEG +!energy balance at vege ground: SAG* FVEG =(IRG+SHG+EVG+GHV) *FVEG at FVEG +!energy balance at bare ground: SAG*(1.-FVEG)=(IRB+SHB+EVB+GHB)*(1.-FVEG) at 1-FVEG + + IF (VEG .AND. FVEG > 0) THEN + TAUX = FVEG * TAUXV + (1.0 - FVEG) * TAUXB + TAUY = FVEG * TAUYV + (1.0 - FVEG) * TAUYB + FIRA = FVEG * IRG + (1.0 - FVEG) * IRB + IRC + FSH = FVEG * SHG + (1.0 - FVEG) * SHB + SHC + FGEV = FVEG * EVG + (1.0 - FVEG) * EVB + SSOIL = FVEG * GHV + (1.0 - FVEG) * GHB + FCEV = EVC + FCTR = TR + PAH = FVEG * PAHG + (1.0 - FVEG) * PAHB + PAHV + TG = FVEG * TGV + (1.0 - FVEG) * TGB + T2M = FVEG * T2MV + (1.0 - FVEG) * T2MB + TS = FVEG * TV + (1.0 - FVEG) * TGB + CM = FVEG * CMV + (1.0 - FVEG) * CMB ! better way to average? + CH = FVEG * CHV + (1.0 - FVEG) * CHB + Q1 = FVEG * (EAH*0.622/(SFCPRS - 0.378*EAH)) + (1.0 - FVEG)*QSFC + Q2E = FVEG * Q2V + (1.0 - FVEG) * Q2B + Z0WRF = Z0M + ELSE + TAUX = TAUXB + TAUY = TAUYB + FIRA = IRB + FSH = SHB + FGEV = EVB + SSOIL = GHB + TG = TGB + T2M = T2MB + FCEV = 0. + FCTR = 0. + PAH = PAHB + TS = TG + CM = CMB + CH = CHB + Q1 = QSFC + Q2E = Q2B + RSSUN = 0.0 + RSSHA = 0.0 + TGV = TGB + CHV = CHB + Z0WRF = Z0MG + END IF + + FIRE = LWDN + FIRA + + IF(FIRE <=0.) THEN + WRITE(6,*) 'emitted longwave <0; skin T may be wrong due to inconsistent' + WRITE(6,*) 'input of SHDFAC with LAI' + WRITE(6,*) ILOC, JLOC, 'SHDFAC=',FVEG,'VAI=',VAI,'TV=',TV,'TG=',TG + WRITE(6,*) 'LWDN=',LWDN,'FIRA=',FIRA,'SNOWH=',SNOWH + WRITE(*,*) "STOP in Noah-MP" +! call wrf_error_fatal("STOP in Noah-MP") + END IF + + ! Compute a net emissivity + EMISSI = FVEG * ( EMG*(1-EMV) + EMV + EMV*(1-EMV)*(1-EMG) ) + & + (1-FVEG) * EMG + + ! When we're computing a TRAD, subtract from the emitted IR the + ! reflected portion of the incoming LWDN, so we're just + ! considering the IR originating in the canopy/ground system. + + TRAD = ( ( FIRE - (1-EMISSI)*LWDN ) / (EMISSI*SB) ) ** 0.25 + + ! Old TRAD calculation not taking into account Emissivity: + ! TRAD = (FIRE/SB)**0.25 + + APAR = PARSUN*LAISUN + PARSHA*LAISHA + PSN = PSNSUN*LAISUN + PSNSHA*LAISHA + +! 3L snow & 4L soil temperatures + + CALL TSNOSOI (parameters,ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in + TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in + SAG ,DT ,SNOWH ,DZSNSO , & !in + TG ,ILOC ,JLOC , & !in + STC ) !inout + +! adjusting snow surface temperature + IF(OPT_STC == 2) THEN + IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN + TGV = TFRZ + TGB = TFRZ + IF (VEG .AND. FVEG > 0) THEN + TG = FVEG * TGV + (1.0 - FVEG) * TGB + TS = FVEG * TV + (1.0 - FVEG) * TGB + ELSE + TG = TGB + TS = TGB + END IF + END IF + END IF + +! Energy released or consumed by snow & frozen soil + + CALL PHASECHANGE (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in + DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , & !in + STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout + SMC ,SH2O , & !inout + QMELT ,IMELT ,PONDING ) !out + + + END SUBROUTINE ENERGY + +!== begin thermoprop =============================================================================== + + SUBROUTINE THERMOPROP (parameters,NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in + SMC ,SH2O ,TG ,STC ,UR , & !in + LAT ,Z0M ,ZLVL ,VEGTYP , & !in + DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out + FACT ) !out +! ------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers + INTEGER , INTENT(IN) :: IST !surface type + REAL , INTENT(IN) :: DT !time step [s] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SH2O !liquid soil moisture [m3/m3] + REAL , INTENT(IN) :: SNOWH !snow height [m] + REAL, INTENT(IN) :: TG !surface temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil/lake temp. (k) + REAL, INTENT(IN) :: UR !wind speed at ZLVL (m/s) + REAL, INTENT(IN) :: LAT !latitude (radians) + REAL, INTENT(IN) :: Z0M !roughness length (m) + REAL, INTENT(IN) :: ZLVL !reference height (m) + INTEGER , INTENT(IN) :: VEGTYP !vegtyp type + +! outputs + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: HCPCT !heat capacity [j/m3/k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: FACT !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + INTEGER :: IZ + REAL, DIMENSION(-NSNOW+1: 0) :: CVSNO !volumetric specific heat (j/m3/k) + REAL, DIMENSION(-NSNOW+1: 0) :: TKSNO !snow thermal conductivity (j/m3/k) + REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + CALL CSNOW (parameters,ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in + TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out + + DO IZ = ISNOW+1, 0 + DF (IZ) = TKSNO(IZ) + HCPCT(IZ) = CVSNO(IZ) + END DO + +! compute soil thermal properties + + DO IZ = 1, NSOIL + SICE(IZ) = SMC(IZ) - SH2O(IZ) + HCPCT(IZ) = SH2O(IZ)*CWAT + (1.0-parameters%SMCMAX(IZ))*parameters%CSOIL & + + (parameters%SMCMAX(IZ)-SMC(IZ))*CPAIR + SICE(IZ)*CICE + CALL TDFCND (parameters,IZ,DF(IZ), SMC(IZ), SH2O(IZ)) + END DO + + IF ( parameters%urban_flag ) THEN + DO IZ = 1,NSOIL + DF(IZ) = 3.24 + END DO + ENDIF + +! heat flux reduction effect from the overlying green canopy, adapted from +! section 2.1.2 of Peters-Lidard et al. (1997, JGR, VOL 102(D4)). +! not in use because of the separation of the canopy layer from the ground. +! but this may represent the effects of leaf litter (Niu comments) +! DF1 = DF1 * EXP (SBETA * SHDFAC) + +! compute lake thermal properties +! (no consideration of turbulent mixing for this version) + + IF(IST == 2) THEN + DO IZ = 1, NSOIL + IF(STC(IZ) > TFRZ) THEN + HCPCT(IZ) = CWAT + DF(IZ) = TKWAT !+ KEDDY * CWAT + ELSE + HCPCT(IZ) = CICE + DF(IZ) = TKICE + END IF + END DO + END IF + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + DO IZ = ISNOW+1,NSOIL + FACT(IZ) = DT/(HCPCT(IZ)*DZSNSO(IZ)) + END DO + +! snow/soil interface + + IF(ISNOW == 0) THEN + DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH) / (SNOWH +DZSNSO(1)) + ELSE + DF(1) = (DF(1)*DZSNSO(1)+DF(0)*DZSNSO(0)) / (DZSNSO(0)+DZSNSO(1)) + END IF + + + END SUBROUTINE THERMOPROP + +!== begin csnow ==================================================================================== + + SUBROUTINE CSNOW (parameters,ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in + TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out +! -------------------------------------------------------------------------------------------------- +! Snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ISNOW !number of snow layers (-) + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + +! outputs + + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: CVSNO !volumetric specific heat (j/m3/k) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: TKSNO !thermal conductivity (w/m/k) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + +! locals + + INTEGER :: IZ + REAL, DIMENSION(-NSNOW+1: 0) :: BDSNOI !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + DO IZ = ISNOW+1, 0 + SNICEV(IZ) = MIN(1., SNICE(IZ)/(DZSNSO(IZ)*DENICE) ) + EPORE(IZ) = 1. - SNICEV(IZ) + SNLIQV(IZ) = MIN(EPORE(IZ),SNLIQ(IZ)/(DZSNSO(IZ)*DENH2O)) + ENDDO + + DO IZ = ISNOW+1, 0 + BDSNOI(IZ) = (SNICE(IZ)+SNLIQ(IZ))/DZSNSO(IZ) + CVSNO(IZ) = CICE*SNICEV(IZ)+CWAT*SNLIQV(IZ) +! CVSNO(IZ) = 0.525E06 ! constant + enddo + +! thermal conductivity of snow + + DO IZ = ISNOW+1, 0 + TKSNO(IZ) = 3.2217E-6*BDSNOI(IZ)**2. ! Stieglitz(yen,1965) +! TKSNO(IZ) = 2E-2+2.5E-6*BDSNOI(IZ)*BDSNOI(IZ) ! Anderson, 1976 +! TKSNO(IZ) = 0.35 ! constant +! TKSNO(IZ) = 2.576E-6*BDSNOI(IZ)**2. + 0.074 ! Verseghy (1991) +! TKSNO(IZ) = 2.22*(BDSNOI(IZ)/1000.)**1.88 ! Douvill(Yen, 1981) + ENDDO + + END SUBROUTINE CSNOW + +!== begin tdfcnd =================================================================================== + + SUBROUTINE TDFCND (parameters, ISOIL, DF, SMC, SH2O) +! -------------------------------------------------------------------------------------------------- +! Calculate thermal diffusivity and conductivity of the soil. +! Peters-Lidard approach (Peters-Lidard et al., 1998) +! -------------------------------------------------------------------------------------------------- +! Code history: +! June 2001 changes: frozen soil condition. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ISOIL ! soil layer + REAL, INTENT(IN) :: SMC ! total soil water + REAL, INTENT(IN) :: SH2O ! liq. soil water + REAL, INTENT(OUT) :: DF ! thermal diffusivity + +! local variables + REAL :: AKE + REAL :: GAMMD + REAL :: THKDRY + REAL :: THKO ! thermal conductivity for other soil components + REAL :: THKQTZ ! thermal conductivity for quartz + REAL :: THKSAT ! + REAL :: THKS ! thermal conductivity for the solids + REAL :: THKW ! water thermal conductivity + REAL :: SATRATIO + REAL :: XU + REAL :: XUNFROZ +! -------------------------------------------------------------------------------------------------- +! We now get quartz as an input argument (set in routine redprm): +! DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! -------------------------------------------------------------------------------------------------- +! If the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils +! -------------------------------------------------------------------------------------------------- +! QUARTZ ....QUARTZ CONTENT (SOIL TYPE DEPENDENT) +! -------------------------------------------------------------------------------------------------- +! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). + +! PABLO GRUNMANN, 08/17/98 +! Refs.: +! Farouki, O.T.,1986: Thermal properties of soils. Series on Rock +! and Soil Mechanics, Vol. 11, Trans Tech, 136 pp. +! Johansen, O., 1975: Thermal conductivity of soils. PH.D. Thesis, +! University of Trondheim, +! Peters-Lidard, C. D., et al., 1998: The effect of soil thermal +! conductivity parameterization on surface energy fluxes +! and temperatures. Journal of The Atmospheric Sciences, +! Vol. 55, pp. 1209-1224. +! -------------------------------------------------------------------------------------------------- +! NEEDS PARAMETERS +! POROSITY(SOIL TYPE): +! POROS = SMCMAX +! SATURATION RATIO: +! PARAMETERS W/(M.K) + SATRATIO = SMC / parameters%SMCMAX(ISOIL) + THKW = 0.57 +! IF (QUARTZ .LE. 0.2) THKO = 3.0 + THKO = 2.0 +! SOLIDS' CONDUCTIVITY +! QUARTZ' CONDUCTIVITY + THKQTZ = 7.7 + +! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) + THKS = (THKQTZ ** parameters%QUARTZ(ISOIL))* (THKO ** (1. - parameters%QUARTZ(ISOIL))) + +! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ) + XUNFROZ = 1.0 ! Prevent divide by zero (suggested by D. Mocko) + IF(SMC > 0.) XUNFROZ = SH2O / SMC +! SATURATED THERMAL CONDUCTIVITY + XU = XUNFROZ * parameters%SMCMAX(ISOIL) + +! DRY DENSITY IN KG/M3 + THKSAT = THKS ** (1. - parameters%SMCMAX(ISOIL))* TKICE ** (parameters%SMCMAX(ISOIL) - XU)* THKW ** & + (XU) + +! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + GAMMD = (1. - parameters%SMCMAX(ISOIL))*2700. + + THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) +! FROZEN + IF ( (SH2O + 0.0005) < SMC ) THEN + AKE = SATRATIO +! UNFROZEN +! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) + ELSE + +! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT +! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) +! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + + IF ( SATRATIO > 0.1 ) THEN + + AKE = LOG10 (SATRATIO) + 1.0 + +! USE K = KDRY + ELSE + + AKE = 0.0 + END IF +! THERMAL CONDUCTIVITY + + END IF + + DF = AKE * (THKSAT - THKDRY) + THKDRY + + + end subroutine TDFCND + +!== begin radiation ================================================================================ + + SUBROUTINE RADIATION (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in + TG ,TV ,FSNO ,QSNOW ,FWET , & !in + ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in + FVEG ,ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , & !out + SAV ,SAG ,FSR ,FSA ,FSRV , & + FSRG ,ALBSND ,ALBSNI ,BGAP ,WGAP ) !out +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + INTEGER, INTENT(IN) :: IST !surface type + INTEGER, INTENT(IN) :: ICE !ice (ice = 1) + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + + REAL, INTENT(IN) :: DT !time step [s] + REAL, INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow mass (mm) + REAL, INTENT(IN) :: SNOWH !snow height (mm) + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: FWET !fraction of canopy that is wet + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL, INTENT(IN) :: FSNO !snow cover fraction (-) + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + +! inout + REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age. + +! output + REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL, INTENT(OUT) :: LAISUN !sunlit leaf area (-) + REAL, INTENT(OUT) :: LAISHA !shaded leaf area (-) + REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + +!jref:start + REAL, INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP + REAL, DIMENSION(1:2), INTENT(OUT) :: ALBSND !snow albedo (direct) + REAL, DIMENSION(1:2), INTENT(OUT) :: ALBSNI !snow albedo (diffuse) +!jref:end + +! local + REAL :: FAGE !snow age function (0 - new snow) + REAL, DIMENSION(1:2) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1:2) :: ALBD !surface albedo (direct) + REAL, DIMENSION(1:2) :: ALBI !surface albedo (diffuse) + REAL, DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) + REAL, DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) + REAL, DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) + REAL, DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL, DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) +!jref:start + REAL, DIMENSION(1:2) :: FREVI + REAL, DIMENSION(1:2) :: FREVD + REAL, DIMENSION(1:2) :: FREGI + REAL, DIMENSION(1:2) :: FREGD +!jref:end + + REAL :: FSHA !shaded fraction of canopy + REAL :: VAI !total LAI + stem area index, one sided + + REAL,PARAMETER :: MPE = 1.E-6 + LOGICAL VEG !true: vegetated for surface temperature calculation + +! -------------------------------------------------------------------------------------------------- + +! surface abeldo + + CALL ALBEDO (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in + TG ,TV ,SNOWH ,FSNO ,FWET , & !in + SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in + ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out + FABI ,FTDD ,FTID ,FTII ,FSUN , & !) !out + FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !inout + WGAP ,ALBSND ,ALBSNI ) + +! surface radiation + + FSHA = 1.-FSUN + LAISUN = ELAI*FSUN + LAISHA = ELAI*FSHA + VAI = ELAI+ ESAI + IF (VAI .GT. 0.) THEN + VEG = .TRUE. + ELSE + VEG = .FALSE. + END IF + + CALL SURRAD (parameters,MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in + LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in + FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in + ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in + PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out + FSR , & !out + FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & !inout + FSRG) + + END SUBROUTINE RADIATION + +!== begin albedo =================================================================================== + + SUBROUTINE ALBEDO (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in + TG ,TV ,SNOWH ,FSNO ,FWET , & !in + SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in + ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out + FABI ,FTDD ,FTID ,FTII ,FSUN , & !out + FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !out + WGAP ,ALBSND ,ALBSNI ) + +! -------------------------------------------------------------------------------------------------- +! surface albedos. also fluxes (per unit incoming direct and diffuse +! radiation) reflected, transmitted, and absorbed by vegetation. +! also sunlit fraction of the canopy. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + INTEGER, INTENT(IN) :: IST !surface type + INTEGER, INTENT(IN) :: ICE !ice (ice = 1) + + REAL, INTENT(IN) :: DT !time step [sec] + REAL, INTENT(IN) :: QSNOW !snowfall + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle for next time step + REAL, INTENT(IN) :: SNOWH !snow height (mm) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: FSNO !fraction of grid covered by snow + REAL, INTENT(IN) :: FWET !fraction of canopy that is wet + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow mass (mm) + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) + +! inout + REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + +! output + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) +!jref:start + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVD + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVI + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGD + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGI + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP +!jref:end + +! ------------------------------------------------------------------------ +! ------------------------ local variables ------------------------------- +! local + REAL :: FAGE !snow age function + REAL :: ALB + INTEGER :: IB !indices + INTEGER :: NBAND !number of solar radiation wave bands + INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 + + REAL :: WL !fraction of LAI+SAI that is LAI + REAL :: WS !fraction of LAI+SAI that is SAI + REAL :: MPE !prevents overflow for division by zero + + REAL, DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI + REAL, DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI + REAL, DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 + REAL, DIMENSION(1:2), INTENT(OUT) :: ALBSND !snow albedo (direct) + REAL, DIMENSION(1:2), INTENT(OUT) :: ALBSNI !snow albedo (diffuse) + + REAL :: VAI !ELAI+ESAI + REAL :: GDIR !average projected leaf/stem area in solar direction + REAL :: EXT !optical depth direct beam per unit leaf + stem area + +! -------------------------------------------------------------------------------------------------- + + NBAND = 2 + MPE = 1.E-06 + BGAP = 0. + WGAP = 0. + +! initialize output because solar radiation only done if COSZ > 0 + + DO IB = 1, NBAND + ALBD(IB) = 0. + ALBI(IB) = 0. + ALBGRD(IB) = 0. + ALBGRI(IB) = 0. + ALBSND(IB) = 0. + ALBSNI(IB) = 0. + FABD(IB) = 0. + FABI(IB) = 0. + FTDD(IB) = 0. + FTID(IB) = 0. + FTII(IB) = 0. + IF (IB.EQ.1) FSUN = 0. + END DO + + IF(COSZ <= 0) GOTO 100 + +! weight reflectance/transmittance by LAI and SAI + + DO IB = 1, NBAND + VAI = ELAI + ESAI + WL = ELAI / MAX(VAI,MPE) + WS = ESAI / MAX(VAI,MPE) + RHO(IB) = MAX(parameters%RHOL(IB)*WL+parameters%RHOS(IB)*WS, MPE) + TAU(IB) = MAX(parameters%TAUL(IB)*WL+parameters%TAUS(IB)*WS, MPE) + END DO + +! snow age + + CALL SNOW_AGE (parameters,DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) + +! snow albedos: only if COSZ > 0 and FSNO > 0 + + IF(OPT_ALB == 1) & + CALL SNOWALB_BATS (parameters,NBAND, FSNO,COSZ,FAGE,ALBSND,ALBSNI) + IF(OPT_ALB == 2) THEN + CALL SNOWALB_CLASS (parameters,NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) + ALBOLD = ALB + END IF + +! ground surface albedo + + CALL GROUNDALB (parameters,NSOIL ,NBAND ,ICE ,IST , & !in + FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in + TG ,ILOC ,JLOC , & !in + ALBGRD ,ALBGRI ) !out + +! loop over NBAND wavebands to calculate surface albedos and solar +! fluxes for unit incoming direct (IC=0) and diffuse flux (IC=1) + + DO IB = 1, NBAND + IC = 0 ! direct + CALL TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , & !in + FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in + TAU ,FVEG ,IST ,ILOC ,JLOC , & !in + FABD ,ALBD ,FTDD ,FTID ,GDIR , &!) !out + FREVD ,FREGD ,BGAP ,WGAP) + + IC = 1 ! diffuse + CALL TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , & !in + FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in + TAU ,FVEG ,IST ,ILOC ,JLOC , & !in + FABI ,ALBI ,FTDI ,FTII ,GDIR , & !) !out + FREVI ,FREGI ,BGAP ,WGAP) + + END DO + +! sunlit fraction of canopy. set FSUN = 0 if FSUN < 0.01. + + EXT = GDIR/COSZ * SQRT(1.-RHO(1)-TAU(1)) + FSUN = (1.-EXP(-EXT*VAI)) / MAX(EXT*VAI,MPE) + EXT = FSUN + + IF (EXT .LT. 0.01) THEN + WL = 0. + ELSE + WL = EXT + END IF + FSUN = WL + +100 CONTINUE + + END SUBROUTINE ALBEDO + +!== begin surrad =================================================================================== + + SUBROUTINE SURRAD (parameters,MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in + LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in + FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in + ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in + PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out + FSR , & !) !out + FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & + FSRG) !inout + +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + REAL, INTENT(IN) :: MPE !prevents underflow errors if division by zero + + REAL, INTENT(IN) :: FSUN !sunlit fraction of canopy + REAL, INTENT(IN) :: FSHA !shaded fraction of canopy + REAL, INTENT(IN) :: ELAI !leaf area, one-sided + REAL, INTENT(IN) :: VAI !leaf + stem area, one-sided + REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided + REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided + + REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL, DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) + + REAL, DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) + REAL, DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) + +! output + + REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSRV !reflected solar radiation by vegetation + REAL, INTENT(OUT) :: FSRG !reflected solar radiation by ground + +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: IB !waveband number (1=vis, 2=nir) + INTEGER :: NBAND !number of solar radiation waveband classes + + REAL :: ABS !absorbed solar radiation (w/m2) + REAL :: RNIR !reflected solar radiation [nir] (w/m2) + REAL :: RVIS !reflected solar radiation [vis] (w/m2) + REAL :: LAIFRA !leaf area fraction of canopy + REAL :: TRD !transmitted solar radiation: direct (w/m2) + REAL :: TRI !transmitted solar radiation: diffuse (w/m2) + REAL, DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) + REAL, DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) +! --------------------------------------------------------------------------------------------- + NBAND = 2 + +! zero summed solar fluxes + + SAG = 0. + SAV = 0. + FSA = 0. + +! loop over nband wavebands + + DO IB = 1, NBAND + +! absorbed by canopy + + CAD(IB) = SOLAD(IB)*FABD(IB) + CAI(IB) = SOLAI(IB)*FABI(IB) + SAV = SAV + CAD(IB) + CAI(IB) + FSA = FSA + CAD(IB) + CAI(IB) + +! transmitted solar fluxes incident on ground + + TRD = SOLAD(IB)*FTDD(IB) + TRI = SOLAD(IB)*FTID(IB) + SOLAI(IB)*FTII(IB) + +! solar radiation absorbed by ground surface + + ABS = TRD*(1.-ALBGRD(IB)) + TRI*(1.-ALBGRI(IB)) + SAG = SAG + ABS + FSA = FSA + ABS + END DO + +! partition visible canopy absorption to sunlit and shaded fractions +! to get average absorbed par for sunlit and shaded leaves + + LAIFRA = ELAI / MAX(VAI,MPE) + IF (FSUN .GT. 0.) THEN + PARSUN = (CAD(1)+FSUN*CAI(1)) * LAIFRA / MAX(LAISUN,MPE) + PARSHA = (FSHA*CAI(1))*LAIFRA / MAX(LAISHA,MPE) + ELSE + PARSUN = 0. + PARSHA = (CAD(1)+CAI(1))*LAIFRA /MAX(LAISHA,MPE) + ENDIF + +! reflected solar radiation + + RVIS = ALBD(1)*SOLAD(1) + ALBI(1)*SOLAI(1) + RNIR = ALBD(2)*SOLAD(2) + ALBI(2)*SOLAI(2) + FSR = RVIS + RNIR + +! reflected solar radiation of veg. and ground (combined ground) + FSRV = FREVD(1)*SOLAD(1)+FREVI(1)*SOLAI(1)+FREVD(2)*SOLAD(2)+FREVI(2)*SOLAI(2) + FSRG = FREGD(1)*SOLAD(1)+FREGI(1)*SOLAI(1)+FREGD(2)*SOLAD(2)+FREGI(2)*SOLAI(2) + + + END SUBROUTINE SURRAD + +!== begin snow_age ================================================================================= + + SUBROUTINE SNOW_AGE (parameters,DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ code history ------------------------------------------------------------ +! from BATS +! ------------------------ input/output variables -------------------------------------------------- +!input + type (noahmp_parameters), intent(in) :: parameters + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow water per unit ground area (mm) + +!output + REAL, INTENT(OUT) :: FAGE !snow age + +!input/output + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age +!local + REAL :: TAGE !total aging effects + REAL :: AGE1 !effects of grain growth due to vapor diffusion + REAL :: AGE2 !effects of grain growth at freezing of melt water + REAL :: AGE3 !effects of soot + REAL :: DELA !temporary variable + REAL :: SGE !temporary variable + REAL :: DELS !temporary variable + REAL :: DELA0 !temporary variable + REAL :: ARG !temporary variable +! See Yang et al. (1997) J.of Climate for detail. +!--------------------------------------------------------------------------------------------------- + + IF(SNEQV.LE.0.0) THEN + TAUSS = 0. + ELSE + DELA0 = DT/parameters%TAU0 + ARG = parameters%GRAIN_GROWTH*(1./TFRZ-1./TG) + AGE1 = EXP(ARG) + AGE2 = EXP(AMIN1(0.,parameters%EXTRA_GROWTH*ARG)) + AGE3 = parameters%DIRT_SOOT + TAGE = AGE1+AGE2+AGE3 + DELA = DELA0*TAGE + DELS = AMAX1(0.0,SNEQV-SNEQVO) / parameters%SWEMX + SGE = (TAUSS+DELA)*(1.0-DELS) + TAUSS = AMAX1(0.,SGE) + ENDIF + + FAGE= TAUSS/(TAUSS+1.) + + END SUBROUTINE SNOW_AGE + +!== begin snowalb_bats ============================================================================= + + SUBROUTINE SNOWALB_BATS (parameters,NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: NBAND !number of waveband classes + + REAL,INTENT(IN) :: COSZ !cosine solar zenith angle + REAL,INTENT(IN) :: FSNO !snow cover fraction (-) + REAL,INTENT(IN) :: FAGE !snow age correction + +! output + + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: IB !waveband class + + REAL :: FZEN !zenith angle correction + REAL :: CF1 !temperary variable + REAL :: SL2 !2.*SL + REAL :: SL1 !1/SL + REAL :: SL !adjustable parameter +! REAL, PARAMETER :: C1 = 0.2 !default in BATS +! REAL, PARAMETER :: C2 = 0.5 !default in BATS +! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's +! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + ALBSND(1: NBAND) = 0. + ALBSNI(1: NBAND) = 0. + +! when cosz > 0 + + SL=parameters%BATS_COSZ + SL1=1./SL + SL2=2.*SL + CF1=((1.+SL1)/(1.+SL2*COSZ)-SL1) + FZEN=AMAX1(CF1,0.) + + ALBSNI(1)=parameters%BATS_VIS_NEW*(1.-parameters%BATS_VIS_AGE*FAGE) + ALBSNI(2)=parameters%BATS_NIR_NEW*(1.-parameters%BATS_NIR_AGE*FAGE) + + ALBSND(1)=ALBSNI(1)+parameters%BATS_VIS_DIR*FZEN*(1.-ALBSNI(1)) ! vis direct + ALBSND(2)=ALBSNI(2)+parameters%BATS_VIS_DIR*FZEN*(1.-ALBSNI(2)) ! nir direct + + END SUBROUTINE SNOWALB_BATS + +!== begin snowalb_class ============================================================================ + + SUBROUTINE SNOWALB_CLASS (parameters,NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: NBAND !number of waveband classes + + REAL,INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL,INTENT(IN) :: DT !time step (sec) + REAL,INTENT(IN) :: ALBOLD !snow albedo at last time step + +! in & out + + REAL, INTENT(INOUT) :: ALB ! +! output + + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: IB !waveband class + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + ALBSND(1: NBAND) = 0. + ALBSNI(1: NBAND) = 0. + +! when cosz > 0 + + ALB = 0.55 + (ALBOLD-0.55) * EXP(-0.01*DT/3600.) + +! 1 mm fresh snow(SWE) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + IF (QSNOW > 0.) then + ALB = ALB + MIN(QSNOW,parameters%SWEMX/DT) * (0.84-ALB)/(parameters%SWEMX/DT) + ENDIF + + ALBSNI(1)= ALB ! vis diffuse + ALBSNI(2)= ALB ! nir diffuse + ALBSND(1)= ALB ! vis direct + ALBSND(2)= ALB ! nir direct + + END SUBROUTINE SNOWALB_CLASS + +!== begin groundalb ================================================================================ + + SUBROUTINE GROUNDALB (parameters,NSOIL ,NBAND ,ICE ,IST , & !in + FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in + TG ,ILOC ,JLOC , & !in + ALBGRD ,ALBGRI ) !out +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + INTEGER, INTENT(IN) :: NBAND !number of solar radiation waveband classes + INTEGER, INTENT(IN) :: ICE !value of ist for land ice + INTEGER, INTENT(IN) :: IST !surface type + REAL, INTENT(IN) :: FSNO !fraction of surface covered with snow (-) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) + REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) + REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) + +!output + + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) + +!local + + INTEGER :: IB !waveband number (1=vis, 2=nir) + REAL :: INC !soil water correction factor for soil albedo + REAL :: ALBSOD !soil albedo (direct) + REAL :: ALBSOI !soil albedo (diffuse) +! -------------------------------------------------------------------------------------------------- + + DO IB = 1, NBAND + INC = MAX(0.11-0.40*SMC(1), 0.) + IF (IST .EQ. 1) THEN !soil + ALBSOD = MIN(parameters%ALBSAT(IB)+INC,parameters%ALBDRY(IB)) + ALBSOI = ALBSOD + ELSE IF (TG .GT. TFRZ) THEN !unfrozen lake, wetland + ALBSOD = 0.06/(MAX(0.01,COSZ)**1.7 + 0.15) + ALBSOI = 0.06 + ELSE !frozen lake, wetland + ALBSOD = parameters%ALBLAK(IB) + ALBSOI = ALBSOD + END IF + +! increase desert and semi-desert albedos + +! IF (IST .EQ. 1 .AND. ISC .EQ. 9) THEN +! ALBSOD = ALBSOD + 0.10 +! ALBSOI = ALBSOI + 0.10 +! end if + + ALBGRD(IB) = ALBSOD*(1.-FSNO) + ALBSND(IB)*FSNO + ALBGRI(IB) = ALBSOI*(1.-FSNO) + ALBSNI(IB)*FSNO + END DO + + END SUBROUTINE GROUNDALB + +!== begin twostream ================================================================================ + + SUBROUTINE TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , & !in + FWET ,T ,ALBGRD ,ALBGRI ,RHO , & !in + TAU ,FVEG ,IST ,ILOC ,JLOC , & !in + FAB ,FRE ,FTD ,FTI ,GDIR , & !) !out + FREV ,FREG ,BGAP ,WGAP) + +! -------------------------------------------------------------------------------------------------- +! use two-stream approximation of Dickinson (1983) Adv Geophysics +! 25:305-353 and Sellers (1985) Int J Remote Sensing 6:1335-1372 +! to calculate fluxes absorbed by vegetation, reflected by vegetation, +! and transmitted through vegetation for unit incoming direct or diffuse +! flux given an underlying surface with known albedo. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: IST !surface type + INTEGER, INTENT(IN) :: IB !waveband number + INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + + REAL, INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) + REAL, INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) + REAL, INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) + REAL, INTENT(IN) :: T !surface temperature (k) + + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) + REAL, DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance + REAL, DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + +! output + + REAL, DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) + REAL, INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction + REAL, DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) + +! local + REAL :: OMEGA !fraction of intercepted radiation that is scattered + REAL :: OMEGAL !omega for leaves + REAL :: BETAI !upscatter parameter for diffuse radiation + REAL :: BETAIL !betai for leaves + REAL :: BETAD !upscatter parameter for direct beam radiation + REAL :: BETADL !betad for leaves + REAL :: EXT !optical depth of direct beam per unit leaf area + REAL :: AVMU !average diffuse optical depth + + REAL :: COSZI !0.001 <= cosz <= 1.000 + REAL :: ASU !single scattering albedo + REAL :: CHIL ! -0.4 <= xl <= 0.6 + + REAL :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 + REAL :: P1,P2,P3,P4,S1,S2,U1,U2,U3 + REAL :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 + REAL :: PHI1,PHI2,SIGMA + REAL :: FTDS,FTIS,FRES + REAL :: DENFVEG + REAL :: VAI_SPREAD +!jref:start + REAL :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR + REAL :: THETAZ +!jref:end + +! variables for the modified two-stream scheme +! Niu and Yang (2004), JGR + + REAL, PARAMETER :: PAI = 3.14159265 + REAL :: HD !crown depth (m) + REAL :: BB !vertical crown radius (m) + REAL :: THETAP !angle conversion from SZA + REAL :: FA !foliage volume density (m-1) + REAL :: NEWVAI !effective LSAI (-) + + REAL,INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) + REAL,INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) + + REAL :: KOPEN !gap fraction for diffue light (-) + REAL :: GAP !total gap fraction for beam ( <=1-shafac ) + +! ----------------------------------------------------------------- +! compute within and between gaps + VAI_SPREAD = VAI + if(VAI == 0.0) THEN + GAP = 1.0 + KOPEN = 1.0 + ELSE + IF(OPT_RAD == 1) THEN + DENFVEG = -LOG(MAX(1.0-FVEG,0.01))/(PAI*parameters%RC**2) + HD = parameters%HVT - parameters%HVB + BB = 0.5 * HD + THETAP = ATAN(BB/parameters%RC * TAN(ACOS(MAX(0.01,COSZ))) ) + ! BGAP = EXP(-parameters%DEN * PAI * parameters%RC**2/COS(THETAP) ) + BGAP = EXP(-DENFVEG * PAI * parameters%RC**2/COS(THETAP) ) + FA = VAI/(1.33 * PAI * parameters%RC**3.0 *(BB/parameters%RC)*DENFVEG) + NEWVAI = HD*FA + WGAP = (1.0-BGAP) * EXP(-0.5*NEWVAI/COSZ) + GAP = MIN(1.0-FVEG, BGAP+WGAP) + + KOPEN = 0.05 + END IF + + IF(OPT_RAD == 2) THEN + GAP = 0.0 + KOPEN = 0.0 + END IF + + IF(OPT_RAD == 3) THEN + GAP = 1.0-FVEG + KOPEN = 1.0-FVEG + END IF + end if + +! calculate two-stream parameters OMEGA, BETAD, BETAI, AVMU, GDIR, EXT. +! OMEGA, BETAD, BETAI are adjusted for snow. values for OMEGA*BETAD +! and OMEGA*BETAI are calculated and then divided by the new OMEGA +! because the product OMEGA*BETAI, OMEGA*BETAD is used in solution. +! also, the transmittances and reflectances (TAU, RHO) are linear +! weights of leaf and stem values. + + COSZI = MAX(0.001, COSZ) + CHIL = MIN( MAX(parameters%XL, -0.4), 0.6) + IF (ABS(CHIL) .LE. 0.01) CHIL = 0.01 + PHI1 = 0.5 - 0.633*CHIL - 0.330*CHIL*CHIL + PHI2 = 0.877 * (1.-2.*PHI1) + GDIR = PHI1 + PHI2*COSZI + EXT = GDIR/COSZI + AVMU = ( 1. - PHI1/PHI2 * LOG((PHI1+PHI2)/PHI1) ) / PHI2 + OMEGAL = RHO(IB) + TAU(IB) + TMP0 = GDIR + PHI2*COSZI + TMP1 = PHI1*COSZI + ASU = 0.5*OMEGAL*GDIR/TMP0 * ( 1.-TMP1/TMP0*LOG((TMP1+TMP0)/TMP1) ) + BETADL = (1.+AVMU*EXT)/(OMEGAL*AVMU*EXT)*ASU + BETAIL = 0.5 * ( RHO(IB)+TAU(IB) + (RHO(IB)-TAU(IB)) & + * ((1.+CHIL)/2.)**2 ) / OMEGAL + +! adjust omega, betad, and betai for intercepted snow + + IF (T .GT. TFRZ) THEN !no snow + TMP0 = OMEGAL + TMP1 = BETADL + TMP2 = BETAIL + ELSE + TMP0 = (1.-FWET)*OMEGAL + FWET*parameters%OMEGAS(IB) + TMP1 = ( (1.-FWET)*OMEGAL*BETADL + FWET*parameters%OMEGAS(IB)*parameters%BETADS ) / TMP0 + TMP2 = ( (1.-FWET)*OMEGAL*BETAIL + FWET*parameters%OMEGAS(IB)*parameters%BETAIS ) / TMP0 + END IF + + OMEGA = TMP0 + BETAD = TMP1 + BETAI = TMP2 + +! absorbed, reflected, transmitted fluxes per unit incoming radiation + + B = 1. - OMEGA + OMEGA*BETAI + C = OMEGA*BETAI + TMP0 = AVMU*EXT + D = TMP0 * OMEGA*BETAD + F = TMP0 * OMEGA*(1.-BETAD) + TMP1 = B*B - C*C + H = SQRT(TMP1) / AVMU + SIGMA = TMP0*TMP0 - TMP1 + if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,SIGMA) + P1 = B + AVMU*H + P2 = B - AVMU*H + P3 = B + TMP0 + P4 = B - TMP0 + S1 = EXP(-H*VAI) + S2 = EXP(-EXT*VAI) + IF (IC .EQ. 0) THEN + U1 = B - C/ALBGRD(IB) + U2 = B - C*ALBGRD(IB) + U3 = F + C*ALBGRD(IB) + ELSE + U1 = B - C/ALBGRI(IB) + U2 = B - C*ALBGRI(IB) + U3 = F + C*ALBGRI(IB) + END IF + TMP2 = U1 - AVMU*H + TMP3 = U1 + AVMU*H + D1 = P1*TMP2/S1 - P2*TMP3*S1 + TMP4 = U2 + AVMU*H + TMP5 = U2 - AVMU*H + D2 = TMP4/S1 - TMP5*S1 + H1 = -D*P4 - C*F + TMP6 = D - H1*P3/SIGMA + TMP7 = ( D - C - H1/SIGMA*(U1+TMP0) ) * S2 + H2 = ( TMP6*TMP2/S1 - P2*TMP7 ) / D1 + H3 = - ( TMP6*TMP3*S1 - P1*TMP7 ) / D1 + H4 = -F*P3 - C*D + TMP8 = H4/SIGMA + TMP9 = ( U3 - TMP8*(U2-TMP0) ) * S2 + H5 = - ( TMP8*TMP4/S1 + TMP9 ) / D2 + H6 = ( TMP8*TMP5*S1 + TMP9 ) / D2 + H7 = (C*TMP2) / (D1*S1) + H8 = (-C*TMP3*S1) / D1 + H9 = TMP4 / (D2*S1) + H10 = (-TMP5*S1) / D2 + +! downward direct and diffuse fluxes below vegetation +! Niu and Yang (2004), JGR. + + IF (IC .EQ. 0) THEN + FTDS = S2 *(1.0-GAP) + GAP + FTIS = (H4*S2/SIGMA + H5*S1 + H6/S1)*(1.0-GAP) + ELSE + FTDS = 0. + FTIS = (H9*S1 + H10/S1)*(1.0-KOPEN) + KOPEN + END IF + FTD(IB) = FTDS + FTI(IB) = FTIS + +! flux reflected by the surface (veg. and ground) + + IF (IC .EQ. 0) THEN + FRES = (H1/SIGMA + H2 + H3)*(1.0-GAP ) + ALBGRD(IB)*GAP + FREVEG = (H1/SIGMA + H2 + H3)*(1.0-GAP ) + FREBAR = ALBGRD(IB)*GAP !jref - separate veg. and ground reflection + ELSE + FRES = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN + FREVEG = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN + FREBAR = 0 !jref - separate veg. and ground reflection + END IF + FRE(IB) = FRES + + FREV(IB) = FREVEG + FREG(IB) = FREBAR + +! flux absorbed by vegetation + + FAB(IB) = 1. - FRE(IB) - (1.-ALBGRD(IB))*FTD(IB) & + - (1.-ALBGRI(IB))*FTI(IB) + +!if(iloc == 1.and.jloc == 2) then +! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," GAP: ",GAP," FTD: ",FTD(IB)," FTI: ",FTI(IB)," FRE: ", & +! FRE(IB)," FAB: ",FAB(IB)," ALBGRD: ",ALBGRD(IB)," ALBGRI: ",ALBGRI(IB) +!end if + + END SUBROUTINE TWOSTREAM + +!== begin vege_flux ================================================================================ + + SUBROUTINE VEGE_FLUX(parameters,NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in + DT ,SAV ,SAG ,LWDN ,UR , & !in + UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in + EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG, & !in + FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in + ZLVL ,ZPD ,Z0M ,FVEG , & !in + Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in + CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in + RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in + FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in + RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in + EAH ,TAH ,TV ,TG ,CM , & !inout + CH ,DX ,DZ8W , & ! + TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out + SHC ,EVG ,EVC ,TR ,GH , & !out + T2MV ,PSNSUN ,PSNSHA , & !out + QC ,QSFC ,PSFC , & !in + Q2V ,CAH2 ,CHLEAF ,CHUC, & !inout + SH2O,JULIAN, SWDOWN, PRCP, FB, FSR, GECROS1D) ! Gecros + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve for vegetation (tv) and +! ground (tg) temperatures that balance the surface energy budgets + +! vegetated: +! -SAV + IRC[TV] + SHC[TV] + EVC[TV] + TR[TV] = 0 +! -SAG + IRG[TG] + SHG[TG] + EVG[TG] + GH[TG] = 0 +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + LOGICAL, INTENT(IN) :: VEG !true if vegetated surface + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers + INTEGER, INTENT(IN) :: VEGTYP !vegetation physiology type + REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL, INTENT(INOUT) :: SAV !solar rad absorbed by veg (w/m2) + REAL, INTENT(INOUT) :: SAG !solar rad absorbed by ground (w/m2) + REAL, INTENT(IN) :: LWDN !atmospheric longwave radiation (w/m2) + REAL, INTENT(IN) :: UR !wind speed at height zlvl (m/s) + REAL, INTENT(IN) :: UU !wind speed in eastward dir (m/s) + REAL, INTENT(IN) :: VV !wind speed in northward dir (m/s) + REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL, INTENT(IN) :: THAIR !potential temp at reference height (k) + REAL, INTENT(IN) :: EAIR !vapor pressure air at zlvl (pa) + REAL, INTENT(IN) :: QAIR !specific humidity at zlvl (kg/kg) + REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: FSNO !snow fraction + + REAL, INTENT(IN) :: SNOWH !actual snow depth [m] + REAL, INTENT(IN) :: FWET !wetted fraction of canopy + REAL, INTENT(IN) :: CWP !canopy wind parameter + + REAL, INTENT(IN) :: VAI !total leaf area index + stem area index + REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided (m2/m2) + REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided (m2/m2) + REAL, INTENT(IN) :: ZLVL !reference height (m) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0M !roughness length, momentum (m) + REAL, INTENT(IN) :: Z0MG !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: EMV !vegetation emissivity + REAL, INTENT(IN) :: EMG !ground emissivity + + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !soil/snow temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity of snow/soil (w/m/k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thinkness of snow/soil layers (m) + REAL, INTENT(IN) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(IN) :: CANICE !intercepted ice mass (mm) + REAL, INTENT(IN) :: RSURF !ground surface resistance (s/m) +! REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/K) +! REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: GAMMAV !psychrometric constant (pa/K) + REAL, INTENT(IN) :: LATHEAV !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: GAMMAG !psychrometric constant (pa/K) + REAL, INTENT(IN) :: LATHEAG !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: PARSUN !par absorbed per unit sunlit lai (w/m2) + REAL, INTENT(IN) :: PARSHA !par absorbed per unit shaded lai (w/m2) + REAL, INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL, INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) + REAL, INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) + REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL, INTENT(IN) :: SFCPRS !pressure (pa) + REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) + + REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(IN) :: PSFC !pressure at lowest model layer + REAL , INTENT(IN) :: DX !grid spacing + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) + REAL , INTENT(IN) :: DZ8W !thickness of lowest layer + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL, INTENT(IN) :: PAHV !precipitation advected heat - canopy net IN (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - ground net IN (W/m2) + +! input/output + REAL, INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) + REAL, INTENT(INOUT) :: TAH !canopy air temperature (k) + REAL, INTENT(INOUT) :: TV !vegetation temperature (k) + REAL, INTENT(INOUT) :: TG !ground temperature (k) + REAL, INTENT(INOUT) :: CM !momentum drag coefficient + REAL, INTENT(INOUT) :: CH !sensible heat exchange coefficient + +! output +! -FSA + FIRA + FSH + (FCEV + FCTR + FGEV) + FCST + SSOIL = 0 + REAL, INTENT(OUT) :: TAUXV !wind stress: e-w (n/m2) + REAL, INTENT(OUT) :: TAUYV !wind stress: n-s (n/m2) + REAL, INTENT(OUT) :: IRC !net longwave radiation (w/m2) [+= to atm] + REAL, INTENT(OUT) :: SHC !sensible heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: EVC !evaporation heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: IRG !net longwave radiation (w/m2) [+= to atm] + REAL, INTENT(OUT) :: SHG !sensible heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: EVG !evaporation heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: TR !transpiration heat flux (w/m2)[+= to atm] + REAL, INTENT(OUT) :: GH !ground heat (w/m2) [+ = to soil] + REAL, INTENT(OUT) :: T2MV !2 m height air temperature (k) + REAL, INTENT(OUT) :: PSNSUN !sunlit leaf photosynthesis (umolco2/m2/s) + REAL, INTENT(OUT) :: PSNSHA !shaded leaf photosynthesis (umolco2/m2/s) + REAL, INTENT(OUT) :: CHLEAF !leaf exchange coefficient + REAL, INTENT(OUT) :: CHUC !under canopy exchange coefficient + + REAL, INTENT(OUT) :: Q2V + REAL :: CAH !sensible heat conductance, canopy air to ZLVL air (m/s) + REAL :: U10V !10 m wind speed in eastward dir (m/s) + REAL :: V10V !10 m wind speed in eastward dir (m/s) + REAL :: WSPD + +! ------------------------ local variables ---------------------------------------------------- + REAL :: CW !water vapor exchange coefficient + REAL :: FV !friction velocity (m/s) + REAL :: WSTAR !friction velocity n vertical direction (m/s) (only for SFCDIF2) + REAL :: Z0H !roughness length, sensible heat (m) + REAL :: Z0HG !roughness length, sensible heat (m) + REAL :: RB !bulk leaf boundary layer resistance (s/m) + REAL :: RAMC !aerodynamic resistance for momentum (s/m) + REAL :: RAHC !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWC !aerodynamic resistance for water vapor (s/m) + REAL :: RAMG !aerodynamic resistance for momentum (s/m) + REAL :: RAHG !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWG !aerodynamic resistance for water vapor (s/m) + + REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) + + REAL :: MOL !Monin-Obukhov length (m) + REAL :: DTV !change in tv, last iteration (k) + REAL :: DTG !change in tg, last iteration (k) + + REAL :: AIR,CIR !coefficients for ir as function of ts**4 + REAL :: CSH !coefficients for sh as function of ts + REAL :: CEV !coefficients for ev as function of esat[ts] + REAL :: CGH !coefficients for st as function of ts + REAL :: ATR,CTR !coefficients for tr as function of esat[ts] + REAL :: ATA,BTA !coefficients for tah as function of ts + REAL :: AEA,BEA !coefficients for eah as function of esat[ts] + + REAL :: ESTV !saturation vapor pressure at tv (pa) + REAL :: ESTG !saturation vapor pressure at tg (pa) + REAL :: DESTV !d(es)/dt at ts (pa/k) + REAL :: DESTG !d(es)/dt at tg (pa/k) + REAL :: ESATW !es for water + REAL :: ESATI !es for ice + REAL :: DSATW !d(es)/dt at tg (pa/k) for water + REAL :: DSATI !d(es)/dt at tg (pa/k) for ice + + REAL :: FM !momentum stability correction, weighted by prior iters + REAL :: FH !sen heat stability correction, weighted by prior iters + REAL :: FHG !sen heat stability correction, ground + REAL :: HCAN !canopy height (m) [note: hcan >= z0mg] + + REAL :: A !temporary calculation + REAL :: B !temporary calculation + REAL :: CVH !sensible heat conductance, leaf surface to canopy air (m/s) + REAL :: CAW !latent heat conductance, canopy air ZLVL air (m/s) + REAL :: CTW !transpiration conductance, leaf to canopy air (m/s) + REAL :: CEW !evaporation conductance, leaf to canopy air (m/s) + REAL :: CGW !latent heat conductance, ground to canopy air (m/s) + REAL :: COND !sum of conductances (s/m) + REAL :: UC !wind speed at top of canopy (m/s) + REAL :: KH !turbulent transfer coefficient, sensible heat, (m2/s) + REAL :: H !temporary sensible heat flux (w/m2) + REAL :: HG !temporary sensible heat flux (w/m2) + REAL :: MOZ !Monin-Obukhov stability parameter + REAL :: MOZG !Monin-Obukhov stability parameter + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: FM2 !Monin-Obukhov momentum adjustment at 2m + REAL :: FH2 !Monin-Obukhov heat adjustment at 2m + REAL :: CH2 !Surface exchange at 2m + REAL :: THSTAR !Surface exchange at 2m + + REAL :: THVAIR + REAL :: THAH + REAL :: RAHC2 !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWC2 !aerodynamic resistance for water vapor (s/m) + REAL, INTENT(OUT):: CAH2 !sensible heat conductance for diagnostics + REAL :: CH2V !exchange coefficient for 2m over vegetation. + REAL :: CQ2V !exchange coefficient for 2m over vegetation. + REAL :: EAH2 !2m vapor pressure over canopy + REAL :: QFX !moisture flux + REAL :: E1 + + + REAL :: VAIE !total leaf area index + stem area index,effective + REAL :: LAISUNE !sunlit leaf area index, one-sided (m2/m2),effective + REAL :: LAISHAE !shaded leaf area index, one-sided (m2/m2),effective + + INTEGER :: K !index + INTEGER :: ITER !iteration index + +!jref - NITERC test from 5 to 20 + INTEGER, PARAMETER :: NITERC = 20 !number of iterations for surface temperature +!jref - NITERG test from 3-5 + INTEGER, PARAMETER :: NITERG = 5 !number of iterations for ground temperature + INTEGER :: MOZSGN !number of times MOZ changes sign + REAL :: MPE !prevents overflow error if division by zero + + INTEGER :: LITER !Last iteration + + REAL, INTENT(IN) :: JULIAN, SWDOWN, PRCP, FB + REAL, INTENT(INOUT) :: FSR + REAL,DIMENSION(1:60), INTENT(INOUT) :: GECROS1D + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil liquid water + + REAL :: ROOTD, WUL, WLL, Thickness, TLAIE, GLAIE, TLAI, GLAI, FRSU + INTEGER :: NROOT, J + + + REAL :: T, TDC !Kelvin to degree Celsius with limit -50 to +50 + + character(len=80) :: message + + TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) ) +! --------------------------------------------------------------------------------------------- + + MPE = 1E-6 + LITER = 0 + FV = 0.1 + +! --------------------------------------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! --------------------------------------------------------------------------------------------- + DTV = 0. + DTG = 0. + MOZ = 0. + MOZSGN = 0 + MOZOLD = 0. + FH2 = 0. + HG = 0. + H = 0. + QFX = 0. + +! limit LAI + + VAIE = MIN(6.,VAI ) + LAISUNE = MIN(6.,LAISUN) + LAISHAE = MIN(6.,LAISHA) + +! saturation vapor pressure at ground temperature + + T = TDC(TG) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + ELSE + ESTG = ESATI + END IF + +!jref - consistent surface specific humidity for sfcdif3 and sfcdif4 + + QSFC = 0.622*EAIR/(PSFC-0.378*EAIR) + +! canopy height + + HCAN = parameters%HVT + UC = UR*LOG(HCAN/Z0M)/LOG(ZLVL/Z0M) + UC = UR*LOG((HCAN-ZPD+Z0M)/Z0M)/LOG(ZLVL/Z0M) ! MB: add ZPD v3.7 + IF((HCAN-ZPD) <= 0.) THEN + WRITE(message,*) "CRITICAL PROBLEM: HCAN <= ZPD" + ! call wrf_message ( message ) + WRITE(message,*) 'i,j point=',ILOC, JLOC + ! call wrf_message ( message ) + WRITE(message,*) 'HCAN =',HCAN + ! call wrf_message ( message ) + WRITE(message,*) 'ZPD =',ZPD + ! call wrf_message ( message ) + write (message, *) 'SNOWH =',SNOWH + ! call wrf_message ( message ) + WRITE(*,*) "FATAL ERROR: CRITICAL PROBLEM IN MODULE_SF_NOAHMPLSM: VEGEFLUX" + STOP + ! call wrf_error_fatal ( "CRITICAL PROBLEM IN MODULE_SF_NOAHMPLSM:VEGEFLUX" ) + END IF + +! prepare for longwave rad. + + AIR = -EMV*(1.+(1.-EMV)*(1.-EMG))*LWDN - EMV*EMG*SB*TG**4 + CIR = (2.-EMV*(1.-EMG))*EMV*SB +! --------------------------------------------------------------------------------------------- + loop1: DO ITER = 1, NITERC ! begin stability iteration + + IF(ITER == 1) THEN + Z0H = Z0M + Z0HG = Z0MG + ELSE + Z0H = Z0M !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M)) + Z0HG = Z0MG !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0MG)) + END IF + +! aerodyn resistances between heights zlvl and d+z0v + + IF(OPT_SFC == 1) THEN + CALL SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in + ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in + MPE ,ILOC ,JLOC , & !in + MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout + CM ,CH ,FV ,CH2 ) !out + ENDIF + + IF(OPT_SFC == 2) THEN + CALL SFCDIF2(parameters,ITER ,Z0M ,TAH ,THAIR ,UR , & !in + ZLVL ,ILOC ,JLOC , & !in + CM ,CH ,MOZ ,WSTAR , & !in + FV ) !out + ! Undo the multiplication by windspeed that SFCDIF2 + ! applies to exchange coefficients CH and CM: + CH = CH / UR + CM = CM / UR + ENDIF + + RAMC = MAX(1.,1./(CM*UR)) + RAHC = MAX(1.,1./(CH*UR)) + RAWC = RAHC + +! aerodyn resistance between heights z0g and d+z0v, RAG, and leaf +! boundary layer resistance, RB + + CALL RAGRB(parameters,ITER ,VAIE ,RHOAIR ,HG ,TAH , & !in + ZPD ,Z0MG ,Z0HG ,HCAN ,UC , & !in + Z0H ,FV ,CWP ,VEGTYP ,MPE , & !in + TV ,MOZG ,FHG ,ILOC ,JLOC , & !inout + RAMG ,RAHG ,RAWG ,RB ) !out + +! es and d(es)/dt evaluated at tv + + T = TDC(TV) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTV = ESATW + DESTV = DSATW + ELSE + ESTV = ESATI + DESTV = DSATI + END IF + +! stomatal resistance + + IF(ITER == 1) THEN + IF (OPT_CRS == 1) then ! Ball-Berry + CALL STOMATA (parameters,VEGTYP,MPE ,PARSUN ,FOLN ,ILOC , JLOC , & !in + TV ,ESTV ,EAH ,SFCTMP,SFCPRS, & !in + O2AIR ,CO2AIR,IGS ,BTRAN ,RB , & !in + RSSUN ,PSNSUN) !out + + CALL STOMATA (parameters,VEGTYP,MPE ,PARSHA ,FOLN ,ILOC , JLOC , & !in + TV ,ESTV ,EAH ,SFCTMP,SFCPRS, & !in + O2AIR ,CO2AIR,IGS ,BTRAN ,RB , & !in + RSSHA ,PSNSHA) !out + END IF + + IF (OPT_CRS == 2) then ! Jarvis + CALL CANRES (parameters,PARSUN,TV ,BTRAN ,EAH ,SFCPRS, & !in + RSSUN ,PSNSUN,ILOC ,JLOC ) !out + + CALL CANRES (parameters,PARSHA,TV ,BTRAN ,EAH ,SFCPRS, & !in + RSSHA ,PSNSHA,ILOC ,JLOC ) !out + END IF + + ! Call Gecros + IF (opt_crop == 2) then + IF ((GECROS1D(41).GT.0).and.(GECROS1D(42).LT.0.)) then !Gecros + Thickness = 0. + NROOT = 0 + ROOTD = GECROS1D(33) + WUL = 0. + WLL = 0. + + DO J = 1,NSOIL + Thickness = Thickness + DZSNSO (J) + if (Thickness.lt.ROOTD/100.) then + NROOT = NROOT + 1 + endif + ENDDO + + NROOT = NROOT + 1 + NROOT = MAX(1,NROOT) + + Thickness = 0. + + DO J = 1,NROOT + Thickness = Thickness + DZSNSO (J) + if (Thickness.gt.ROOTD/100.) then + WUL = WUL + ((ROOTD/100.-Thickness+DZSNSO(J))*1000.*(SH2O(J)-parameters%SMCWLT(J))) + else + WUL = WUL + (DZSNSO(J)*1000.*(SH2O(J)-parameters%SMCWLT(J))) + endif + ENDDO + + DO J = 1,NSOIL + WLL = WLL + (DZSNSO(J)*1000.*(SH2O(J)-parameters%SMCWLT(J))) + ENDDO + WLL = WLL - WUL + + CALL gecros (JULIAN, DT, 1, RB, RAHC, RAHG+RSURF, FB, SNOWH , & !I + UR, SFCTMP, EAIR, SWDOWN, LWDN, PRCP, WUL, WLL , & !I + parameters%SMCWLT(1), parameters%DLEAF , & !I + GECROS1D , & !H + SAV, SAG, FSR, FRSU, RSSUN, RSSHA) !O + + GLAI = GECROS1D(49) + TLAI = GECROS1D(50) + + ! effective LAIs + TLAIE = MIN(6.,TLAI / FVEG) + GLAIE = MIN(6.,GLAI / FVEG) + ENDIF + ENDIF + + END IF + +! prepare for sensible heat flux above veg. + + CAH = 1./RAHC + CVH = 2.*VAIE/RB + CGH = 1./RAHG + COND = CAH + CVH + CGH + ATA = (SFCTMP*CAH + TG*CGH) / COND + BTA = CVH/COND + CSH = (1.-BTA)*RHOAIR*CPAIR*CVH + +! prepare for latent heat flux above veg. + + CAW = 1./RAWC + CEW = FWET*VAIE/RB + + IF (OPT_CROP /= 2) THEN + CTW = (1.-FWET)*(LAISUNE/(RB+RSSUN) + LAISHAE/(RB+RSSHA)) + ELSE + !RSSUN and RSSHA are in resistance per unit LAI in the Jarvis and Ball-Berry!. RSSUN and RSSHA of Gecros are in s/m + CTW = (1.-FWET)*(1./(RB/(FRSU*GLAIE)+RSSUN) + 1./(RB/((1.-FRSU)*GLAIE)+RSSHA)) !transpiration conductance leaf to canopy air + ENDIF + CGW = 1./(RAWG+RSURF) + COND = CAW + CEW + CTW + CGW + AEA = (EAIR*CAW + ESTG*CGW) / COND + BEA = (CEW+CTW)/COND + CEV = (1.-BEA)*CEW*RHOAIR*CPAIR/GAMMAV ! Barlage: change to vegetation v3.6 + CTR = (1.-BEA)*CTW*RHOAIR*CPAIR/GAMMAV + +! evaluate surface fluxes with current temperature and solve for dts + + TAH = ATA + BTA*TV ! canopy air T. + EAH = AEA + BEA*ESTV ! canopy air e + + IRC = FVEG*(AIR + CIR*TV**4) + SHC = FVEG*RHOAIR*CPAIR*CVH * ( TV-TAH) + EVC = FVEG*RHOAIR*CPAIR*CEW * (ESTV-EAH) / GAMMAV ! Barlage: change to v in v3.6 + TR = FVEG*RHOAIR*CPAIR*CTW * (ESTV-EAH) / GAMMAV + IF (TV > TFRZ) THEN + EVC = MIN(CANLIQ*LATHEAV/DT,EVC) ! Barlage: add if block for canice in v3.6 + ELSE + EVC = MIN(CANICE*LATHEAV/DT,EVC) + END IF + + B = SAV-IRC-SHC-EVC-TR+PAHV !additional w/m2 + A = FVEG*(4.*CIR*TV**3 + CSH + (CEV+CTR)*DESTV) !volumetric heat capacity + DTV = B/A + + IRC = IRC + FVEG*4.*CIR*TV**3*DTV + SHC = SHC + FVEG*CSH*DTV + EVC = EVC + FVEG*CEV*DESTV*DTV + TR = TR + FVEG*CTR*DESTV*DTV + +! update vegetation surface temperature + TV = TV + DTV +! TAH = ATA + BTA*TV ! canopy air T; update here for consistency + +! for computing M-O length in the next iteration + H = RHOAIR*CPAIR*(TAH - SFCTMP) /RAHC + HG = RHOAIR*CPAIR*(TG - TAH) /RAHG + +! consistent specific humidity from canopy air vapor pressure + QSFC = (0.622*EAH)/(SFCPRS-0.378*EAH) + + IF (LITER == 1) THEN + exit loop1 + ENDIF + IF (ITER >= 5 .AND. ABS(DTV) <= 0.01 .AND. LITER == 0) THEN + LITER = 1 + ENDIF + + END DO loop1 ! end stability iteration + +! under-canopy fluxes and tg + + AIR = - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4 + CIR = EMG*SB + CSH = RHOAIR*CPAIR/RAHG + CEV = RHOAIR*CPAIR / (GAMMAG*(RAWG+RSURF)) ! Barlage: change to ground v3.6 + CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1) + + loop2: DO ITER = 1, NITERG + + T = TDC(TG) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + DESTG = DSATW + ELSE + ESTG = ESATI + DESTG = DSATI + END IF + + IRG = CIR*TG**4 + AIR + SHG = CSH * (TG - TAH ) + EVG = CEV * (ESTG*RHSUR - EAH ) + GH = CGH * (TG - STC(ISNOW+1)) + + B = SAG-IRG-SHG-EVG-GH+PAHG + A = 4.*CIR*TG**3+CSH+CEV*DESTG+CGH + DTG = B/A + + IRG = IRG + 4.*CIR*TG**3*DTG + SHG = SHG + CSH*DTG + EVG = EVG + CEV*DESTG*DTG + GH = GH + CGH*DTG + TG = TG + DTG + + END DO loop2 + +! TAH = (CAH*SFCTMP + CVH*TV + CGH*TG)/(CAH + CVH + CGH) + +! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. + + IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN + IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN + IF(OPT_STC == 1) TG = TFRZ + IF(OPT_STC == 3) TG = (1.-FSNO)*TG + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 + IRG = CIR*TG**4 - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4 + SHG = CSH * (TG - TAH) + EVG = CEV * (ESTG*RHSUR - EAH) + GH = SAG+PAHG - (IRG+SHG+EVG) + END IF + END IF + +! wind stresses + + TAUXV = -RHOAIR*CM*UR*UU + TAUYV = -RHOAIR*CM*UR*VV + +! consistent vegetation air temperature and vapor pressure since TG is not consistent with the TAH/EAH +! calculation. +! TAH = SFCTMP + (SHG+SHC)/(RHOAIR*CPAIR*CAH) +! TAH = SFCTMP + (SHG*FVEG+SHC)/(RHOAIR*CPAIR*CAH) ! ground flux need fveg +! EAH = EAIR + (EVC+FVEG*(TR+EVG))/(RHOAIR*CAW*CPAIR/GAMMAG ) +! QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMAG + +! 2m temperature over vegetation ( corrected for low CQ2V values ) + IF (OPT_SFC == 1 .OR. OPT_SFC == 2) THEN +! CAH2 = FV*1./VKC*LOG((2.+Z0H)/Z0H) + CAH2 = FV*VKC/LOG((2.+Z0H)/Z0H) + CAH2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2) + CQ2V = CAH2 + IF (CAH2 .LT. 1.E-5 ) THEN + T2MV = TAH +! Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH)) + Q2V = QSFC + ELSE + T2MV = TAH - (SHG+SHC/FVEG)/(RHOAIR*CPAIR) * 1./CAH2 +! Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH))- QFX/(RHOAIR*FV)* 1./VKC * LOG((2.+Z0H)/Z0H) + Q2V = QSFC - ((EVC+TR)/FVEG+EVG)/(LATHEAV*RHOAIR) * 1./CQ2V + ENDIF + ENDIF + +! update CH for output + CH = CAH + CHLEAF = CVH + CHUC = 1./RAHG + + END SUBROUTINE VEGE_FLUX + +!== begin bare_flux ================================================================================ + + SUBROUTINE BARE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in + LWDN ,UR ,UU ,VV ,SFCTMP , & !in + THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in + DZSNSO ,ZLVL ,ZPD ,Z0M ,FSNO , & !in + EMG ,STC ,DF ,RSURF ,LATHEA , & !in + GAMMA ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in + TGB ,CM ,CH , & !inout + TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out + GHB ,T2MB ,DX ,DZ8W ,IVGTYP , & !out + QC ,QSFC ,PSFC , & !in + SFCPRS ,Q2B ,EHB2 ) !in + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for bare soil fraction. + +! bare soil: +! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer , INTENT(IN) :: ILOC !grid index + integer , INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(IN) :: LWDN !atmospheric longwave radiation (w/m2) + REAL, INTENT(IN) :: UR !wind speed at height zlvl (m/s) + REAL, INTENT(IN) :: UU !wind speed in eastward dir (m/s) + REAL, INTENT(IN) :: VV !wind speed in northward dir (m/s) + REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL, INTENT(IN) :: THAIR !potential temperature at height zlvl (k) + REAL, INTENT(IN) :: QAIR !specific humidity at height zlvl (kg/kg) + REAL, INTENT(IN) :: EAIR !vapor pressure air at height (pa) + REAL, INTENT(IN) :: RHOAIR !density air (kg/m3) + REAL, INTENT(IN) :: SNOWH !actual snow depth [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers (m) + REAL, INTENT(IN) :: ZLVL !reference height (m) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: EMG !ground emissivity + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !soil/snow temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity of snow/soil (w/m/k) + REAL, INTENT(IN) :: RSURF !ground surface resistance (s/m) + REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/k) + REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) + REAL, INTENT(IN) :: FSNO !snow fraction + +!jref:start; in + INTEGER , INTENT(IN) :: IVGTYP + REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL , INTENT(IN) :: PSFC !pressure at lowest model layer + REAL , INTENT(IN) :: SFCPRS !pressure at lowest model layer + REAL , INTENT(IN) :: DX !horisontal grid spacing + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) + REAL , INTENT(IN) :: DZ8W !thickness of lowest layer +!jref:end + REAL, INTENT(IN) :: PAHB !precipitation advected heat - ground net IN (W/m2) + +! input/output + REAL, INTENT(INOUT) :: TGB !ground temperature (k) + REAL, INTENT(INOUT) :: CM !momentum drag coefficient + REAL, INTENT(INOUT) :: CH !sensible heat exchange coefficient + +! output +! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 + + REAL, INTENT(OUT) :: TAUXB !wind stress: e-w (n/m2) + REAL, INTENT(OUT) :: TAUYB !wind stress: n-s (n/m2) + REAL, INTENT(OUT) :: IRB !net longwave rad (w/m2) [+ to atm] + REAL, INTENT(OUT) :: SHB !sensible heat flux (w/m2) [+ to atm] + REAL, INTENT(OUT) :: EVB !latent heat flux (w/m2) [+ to atm] + REAL, INTENT(OUT) :: GHB !ground heat flux (w/m2) [+ to soil] + REAL, INTENT(OUT) :: T2MB !2 m height air temperature (k) +!jref:start + REAL, INTENT(OUT) :: Q2B !bare ground heat conductance + REAL :: EHB !bare ground heat conductance + REAL :: U10B !10 m wind speed in eastward dir (m/s) + REAL :: V10B !10 m wind speed in eastward dir (m/s) + REAL :: WSPD +!jref:end + +! local variables + + REAL :: TAUX !wind stress: e-w (n/m2) + REAL :: TAUY !wind stress: n-s (n/m2) + REAL :: FIRA !total net longwave rad (w/m2) [+ to atm] + REAL :: FSH !total sensible heat flux (w/m2) [+ to atm] + REAL :: FGEV !ground evaporation heat flux (w/m2)[+ to atm] + REAL :: SSOIL !soil heat flux (w/m2) [+ to soil] + REAL :: FIRE !emitted ir (w/m2) + REAL :: TRAD !radiative temperature (k) + REAL :: TAH !"surface" temperature at height z0h+zpd (k) + + REAL :: CW !water vapor exchange coefficient + REAL :: FV !friction velocity (m/s) + REAL :: WSTAR !friction velocity n vertical direction (m/s) (only for SFCDIF2) + REAL :: Z0H !roughness length, sensible heat, ground (m) + REAL :: RB !bulk leaf boundary layer resistance (s/m) + REAL :: RAMB !aerodynamic resistance for momentum (s/m) + REAL :: RAHB !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWB !aerodynamic resistance for water vapor (s/m) + REAL :: MOL !Monin-Obukhov length (m) + REAL :: DTG !change in tg, last iteration (k) + + REAL :: CIR !coefficients for ir as function of ts**4 + REAL :: CSH !coefficients for sh as function of ts + REAL :: CEV !coefficients for ev as function of esat[ts] + REAL :: CGH !coefficients for st as function of ts + +!jref:start + REAL :: RAHB2 !aerodynamic resistance for sensible heat 2m (s/m) + REAL :: RAWB2 !aerodynamic resistance for water vapor 2m (s/m) + REAL,INTENT(OUT) :: EHB2 !sensible heat conductance for diagnostics + REAL :: CH2B !exchange coefficient for 2m temp. + REAL :: CQ2B !exchange coefficient for 2m temp. + REAL :: THVAIR !virtual potential air temp + REAL :: THGH !potential ground temp + REAL :: EMB !momentum conductance + REAL :: QFX !moisture flux + REAL :: ESTG2 !saturation vapor pressure at 2m (pa) + INTEGER :: VEGTYP !vegetation type set to isbarren + REAL :: E1 +!jref:end + + REAL :: ESTG !saturation vapor pressure at tg (pa) + REAL :: DESTG !d(es)/dt at tg (pa/K) + REAL :: ESATW !es for water + REAL :: ESATI !es for ice + REAL :: DSATW !d(es)/dt at tg (pa/K) for water + REAL :: DSATI !d(es)/dt at tg (pa/K) for ice + + REAL :: A !temporary calculation + REAL :: B !temporary calculation + REAL :: H !temporary sensible heat flux (w/m2) + REAL :: MOZ !Monin-Obukhov stability parameter + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: FM !momentum stability correction, weighted by prior iters + REAL :: FH !sen heat stability correction, weighted by prior iters + INTEGER :: MOZSGN !number of times MOZ changes sign + REAL :: FM2 !Monin-Obukhov momentum adjustment at 2m + REAL :: FH2 !Monin-Obukhov heat adjustment at 2m + REAL :: CH2 !Surface exchange at 2m + + INTEGER :: ITER !iteration index + INTEGER :: NITERB !number of iterations for surface temperature + REAL :: MPE !prevents overflow error if division by zero +!jref:start +! DATA NITERB /3/ + DATA NITERB /5/ + SAVE NITERB + REAL :: T, TDC !Kelvin to degree Celsius with limit -50 to +50 + TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + MPE = 1E-6 + DTG = 0. + MOZ = 0. + MOZSGN = 0 + MOZOLD = 0. + FH2 = 0. + H = 0. + QFX = 0. + FV = 0.1 + + CIR = EMG*SB + CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1) + +! ----------------------------------------------------------------- + loop3: DO ITER = 1, NITERB ! begin stability iteration + + IF(ITER == 1) THEN + Z0H = Z0M + ELSE + Z0H = Z0M !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M)) + END IF + + IF(OPT_SFC == 1) THEN + CALL SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in + ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in + MPE ,ILOC ,JLOC , & !in + MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout + CM ,CH ,FV ,CH2 ) !out + ENDIF + + IF(OPT_SFC == 2) THEN + CALL SFCDIF2(parameters,ITER ,Z0M ,TGB ,THAIR ,UR , & !in + ZLVL ,ILOC ,JLOC , & !in + CM ,CH ,MOZ ,WSTAR , & !in + FV ) !out + ! Undo the multiplication by windspeed that SFCDIF2 + ! applies to exchange coefficients CH and CM: + CH = CH / UR + CM = CM / UR + IF(SNOWH > 0.) THEN + CM = MIN(0.01,CM) ! CM & CH are too large, causing + CH = MIN(0.01,CH) ! computational instability + END IF + + ENDIF + + RAMB = MAX(1.,1./(CM*UR)) + RAHB = MAX(1.,1./(CH*UR)) + RAWB = RAHB + +!jref - variables for diagnostics + EMB = 1./RAMB + EHB = 1./RAHB + +! es and d(es)/dt evaluated at tg + + T = TDC(TGB) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + DESTG = DSATW + ELSE + ESTG = ESATI + DESTG = DSATI + END IF + + CSH = RHOAIR*CPAIR/RAHB + CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB) + +! surface fluxes and dtg + + IRB = CIR * TGB**4 - EMG*LWDN + SHB = CSH * (TGB - SFCTMP ) + EVB = CEV * (ESTG*RHSUR - EAIR ) + GHB = CGH * (TGB - STC(ISNOW+1)) + + B = SAG-IRB-SHB-EVB-GHB+PAHB + A = 4.*CIR*TGB**3 + CSH + CEV*DESTG + CGH + DTG = B/A + + IRB = IRB + 4.*CIR*TGB**3*DTG + SHB = SHB + CSH*DTG + EVB = EVB + CEV*DESTG*DTG + GHB = GHB + CGH*DTG + +! update ground surface temperature + TGB = TGB + DTG + +! for M-O length + H = CSH * (TGB - SFCTMP) + + T = TDC(TGB) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + ELSE + ESTG = ESATI + END IF + QSFC = 0.622*(ESTG*RHSUR)/(PSFC-0.378*(ESTG*RHSUR)) + + QFX = (QSFC-QAIR)*CEV*GAMMA/CPAIR + + END DO loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. + + IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN + IF (SNOWH > 0.05 .AND. TGB > TFRZ) THEN + IF(OPT_STC == 1) TGB = TFRZ + IF(OPT_STC == 3) TGB = (1.-FSNO)*TGB + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 + IRB = CIR * TGB**4 - EMG*LWDN + SHB = CSH * (TGB - SFCTMP) + EVB = CEV * (ESTG*RHSUR - EAIR ) !ESTG reevaluate ? + GHB = SAG+PAHB - (IRB+SHB+EVB) + END IF + END IF + +! wind stresses + + TAUXB = -RHOAIR*CM*UR*UU + TAUYB = -RHOAIR*CM*UR*VV + +!jref:start; errors in original equation corrected. +! 2m air temperature + IF(OPT_SFC == 1 .OR. OPT_SFC ==2) THEN + EHB2 = FV*VKC/LOG((2.+Z0H)/Z0H) + EHB2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2) + CQ2B = EHB2 + IF (EHB2.lt.1.E-5 ) THEN + T2MB = TGB + Q2B = QSFC + ELSE + T2MB = TGB - SHB/(RHOAIR*CPAIR) * 1./EHB2 + Q2B = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF) + ENDIF + IF (parameters%urban_flag) Q2B = QSFC + END IF + +! update CH + CH = EHB + + END SUBROUTINE BARE_FLUX + +!== begin ragrb ==================================================================================== + + SUBROUTINE RAGRB(parameters,ITER ,VAI ,RHOAIR ,HG ,TAH , & !in + ZPD ,Z0MG ,Z0HG ,HCAN ,UC , & !in + Z0H ,FV ,CWP ,VEGTYP ,MPE , & !in + TV ,MOZG ,FHG ,ILOC ,JLOC , & !inout + RAMG ,RAHG ,RAWG ,RB ) !out +! -------------------------------------------------------------------------------------------------- +! compute under-canopy aerodynamic resistance RAG and leaf boundary layer +! resistance RB +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: ITER !iteration index + INTEGER, INTENT(IN) :: VEGTYP !vegetation physiology type + REAL, INTENT(IN) :: VAI !total LAI + stem area index, one sided + REAL, INTENT(IN) :: RHOAIR !density air (kg/m3) + REAL, INTENT(IN) :: HG !ground sensible heat flux (w/m2) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: TAH !air temperature at height z0h+zpd (k) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0MG !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: HCAN !canopy height (m) [note: hcan >= z0mg] + REAL, INTENT(IN) :: UC !wind speed at top of canopy (m/s) + REAL, INTENT(IN) :: Z0H !roughness length, sensible heat (m) + REAL, INTENT(IN) :: Z0HG !roughness length, sensible heat, ground (m) + REAL, INTENT(IN) :: FV !friction velocity (m/s) + REAL, INTENT(IN) :: CWP !canopy wind parameter + REAL, INTENT(IN) :: MPE !prevents overflow error if division by zero + +! in & out + + REAL, INTENT(INOUT) :: MOZG !Monin-Obukhov stability parameter + REAL, INTENT(INOUT) :: FHG !stability correction + +! outputs + REAL :: RAMG !aerodynamic resistance for momentum (s/m) + REAL :: RAHG !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWG !aerodynamic resistance for water vapor (s/m) + REAL :: RB !bulk leaf boundary layer resistance (s/m) + + + REAL :: KH !turbulent transfer coefficient, sensible heat, (m2/s) + REAL :: TMP1 !temporary calculation + REAL :: TMP2 !temporary calculation + REAL :: TMPRAH2 !temporary calculation for aerodynamic resistances + REAL :: TMPRB !temporary calculation for rb + real :: MOLG,FHGNEW,CWPC +! -------------------------------------------------------------------------------------------------- +! stability correction to below canopy resistance + + MOZG = 0. + MOLG = 0. + + IF(ITER > 1) THEN + TMP1 = VKC * (GRAV/TAH) * HG/(RHOAIR*CPAIR) + IF (ABS(TMP1) .LE. MPE) TMP1 = MPE + MOLG = -1. * FV**3 / TMP1 + MOZG = MIN( (ZPD-Z0MG)/MOLG, 1.) + END IF + + IF (MOZG < 0.) THEN + FHGNEW = (1. - 15.*MOZG)**(-0.25) + ELSE + FHGNEW = 1.+ 4.7*MOZG + ENDIF + + IF (ITER == 1) THEN + FHG = FHGNEW + ELSE + FHG = 0.5 * (FHG+FHGNEW) + ENDIF + + CWPC = (CWP * VAI * HCAN * FHG)**0.5 +! CWPC = (CWP*FHG)**0.5 + + TMP1 = EXP( -CWPC*Z0HG/HCAN ) + TMP2 = EXP( -CWPC*(Z0H+ZPD)/HCAN ) + TMPRAH2 = HCAN*EXP(CWPC) / CWPC * (TMP1-TMP2) + +! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. + + KH = MAX ( VKC*FV*(HCAN-ZPD), MPE ) + RAMG = 0. + RAHG = TMPRAH2 / KH + RAWG = RAHG + +! leaf boundary layer resistance + + TMPRB = CWPC*50. / (1. - EXP(-CWPC/2.)) + RB = TMPRB * SQRT(parameters%DLEAF/UC) + RB = MIN(MAX(RB, 5.0),50.0) ! limit RB to 5-50, typically RB<50 + + END SUBROUTINE RAGRB + +!== begin sfcdif1 ================================================================================== + + SUBROUTINE SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in + & ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in + & MPE ,ILOC ,JLOC , & !in + & MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout + & CM ,CH ,FV ,CH2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient CM for momentum and CH for heat +! ------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: ITER !iteration index + REAL, INTENT(IN) :: SFCTMP !temperature at reference height (k) + REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) + REAL, INTENT(IN) :: H !sensible heat flux (w/m2) [+ to atm] + REAL, INTENT(IN) :: QAIR !specific humidity at reference height (kg/kg) + REAL, INTENT(IN) :: ZLVL !reference height (m) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0H !roughness length, sensible heat, ground (m) + REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: UR !wind speed (m/s) + REAL, INTENT(IN) :: MPE !prevents overflow error if division by zero +! in & out + + INTEGER, INTENT(INOUT) :: MOZSGN !number of times moz changes sign + REAL, INTENT(INOUT) :: MOZ !Monin-Obukhov stability (z/L) + REAL, INTENT(INOUT) :: FM !momentum stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FH !sen heat stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FM2 !sen heat stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FH2 !sen heat stability correction, weighted by prior iters + +! outputs + + REAL, INTENT(OUT) :: CM !drag coefficient for momentum + REAL, INTENT(OUT) :: CH !drag coefficient for heat + REAL, INTENT(OUT) :: FV !friction velocity (m/s) + REAL, INTENT(OUT) :: CH2 !drag coefficient for heat + +! locals + REAL :: MOL !Monin-Obukhov length (m) + REAL :: TMPCM !temporary calculation for CM + REAL :: TMPCH !temporary calculation for CH + REAL :: FMNEW !stability correction factor, momentum, for current moz + REAL :: FHNEW !stability correction factor, sen heat, for current moz + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: TMP1,TMP2,TMP3,TMP4,TMP5 !temporary calculation + REAL :: TVIR !temporary virtual temperature (k) + REAL :: MOZ2 !2/L + REAL :: TMPCM2 !temporary calculation for CM2 + REAL :: TMPCH2 !temporary calculation for CH2 + REAL :: FM2NEW !stability correction factor, momentum, for current moz + REAL :: FH2NEW !stability correction factor, sen heat, for current moz + REAL :: TMP12,TMP22,TMP32 !temporary calculation + + REAL :: CMFM, CHFH, CM2FM2, CH2FH2 +! ------------------------------------------------------------------------------------------------- +! Monin-Obukhov stability parameter moz for next iteration + + MOZOLD = MOZ + + IF(ZLVL <= ZPD) THEN + write(*,*) 'WARNING: critical problem: ZLVL <= ZPD; model stops' + STOP + ! call wrf_error_fatal("STOP in Noah-MP") + ENDIF + + TMPCM = LOG((ZLVL-ZPD) / Z0M) + TMPCH = LOG((ZLVL-ZPD) / Z0H) + TMPCM2 = LOG((2.0 + Z0M) / Z0M) + TMPCH2 = LOG((2.0 + Z0H) / Z0H) + + IF(ITER == 1) THEN + FV = 0.0 + MOZ = 0.0 + MOL = 0.0 + MOZ2 = 0.0 + ELSE + TVIR = (1. + 0.61*QAIR) * SFCTMP + TMP1 = VKC * (GRAV/TVIR) * H/(RHOAIR*CPAIR) + IF (ABS(TMP1) .LE. MPE) TMP1 = MPE + MOL = -1. * FV**3 / TMP1 + MOZ = MIN( (ZLVL-ZPD)/MOL, 1.) + MOZ2 = MIN( (2.0 + Z0H)/MOL, 1.) + ENDIF + +! accumulate number of times moz changes sign. + + IF (MOZOLD*MOZ .LT. 0.) MOZSGN = MOZSGN+1 + IF (MOZSGN .GE. 2) THEN + MOZ = 0. + FM = 0. + FH = 0. + MOZ2 = 0. + FM2 = 0. + FH2 = 0. + ENDIF + +! evaluate stability-dependent variables using moz from prior iteration + IF (MOZ .LT. 0.) THEN + TMP1 = (1. - 16.*MOZ)**0.25 + TMP2 = LOG((1.+TMP1*TMP1)/2.) + TMP3 = LOG((1.+TMP1)/2.) + FMNEW = 2.*TMP3 + TMP2 - 2.*ATAN(TMP1) + 1.5707963 + FHNEW = 2*TMP2 + +! 2-meter + TMP12 = (1. - 16.*MOZ2)**0.25 + TMP22 = LOG((1.+TMP12*TMP12)/2.) + TMP32 = LOG((1.+TMP12)/2.) + FM2NEW = 2.*TMP32 + TMP22 - 2.*ATAN(TMP12) + 1.5707963 + FH2NEW = 2*TMP22 + ELSE + FMNEW = -5.*MOZ + FHNEW = FMNEW + FM2NEW = -5.*MOZ2 + FH2NEW = FM2NEW + ENDIF + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + IF (ITER == 1) THEN + FM = FMNEW + FH = FHNEW + FM2 = FM2NEW + FH2 = FH2NEW + ELSE + FM = 0.5 * (FM+FMNEW) + FH = 0.5 * (FH+FHNEW) + FM2 = 0.5 * (FM2+FM2NEW) + FH2 = 0.5 * (FH2+FH2NEW) + ENDIF + +! exchange coefficients + + FH = MIN(FH,0.9*TMPCH) + FM = MIN(FM,0.9*TMPCM) + FH2 = MIN(FH2,0.9*TMPCH2) + FM2 = MIN(FM2,0.9*TMPCM2) + + CMFM = TMPCM-FM + CHFH = TMPCH-FH + CM2FM2 = TMPCM2-FM2 + CH2FH2 = TMPCH2-FH2 + IF(ABS(CMFM) <= MPE) CMFM = MPE + IF(ABS(CHFH) <= MPE) CHFH = MPE + IF(ABS(CM2FM2) <= MPE) CM2FM2 = MPE + IF(ABS(CH2FH2) <= MPE) CH2FH2 = MPE + CM = VKC*VKC/(CMFM*CMFM) + CH = VKC*VKC/(CMFM*CHFH) + CH2 = VKC*VKC/(CM2FM2*CH2FH2) + +! friction velocity + + FV = UR * SQRT(CM) + CH2 = VKC*FV/CH2FH2 + + END SUBROUTINE SFCDIF1 + +!== begin sfcdif2 ================================================================================== + + SUBROUTINE SFCDIF2(parameters,ITER ,Z0 ,THZ0 ,THLM ,SFCSPD , & !in + ZLM ,ILOC ,JLOC , & !in + AKMS ,AKHS ,RLMO ,WSTAR2 , & !in + USTAR ) !out + +! ------------------------------------------------------------------------------------------------- +! SUBROUTINE SFCDIF (renamed SFCDIF_off to avoid clash with Eta PBL) +! ------------------------------------------------------------------------------------------------- +! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. +! SEE CHEN ET AL (1997, BLM) +! ------------------------------------------------------------------------------------------------- + IMPLICIT NONE + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: ITER + REAL, INTENT(IN) :: ZLM, Z0, THZ0, THLM, SFCSPD + REAL, intent(INOUT) :: AKMS + REAL, intent(INOUT) :: AKHS + REAL, intent(INOUT) :: RLMO + REAL, intent(INOUT) :: WSTAR2 + REAL, intent(OUT) :: USTAR + + REAL ZZ, PSLMU, PSLMS, PSLHU, PSLHS + REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS + REAL ZILFC, ZU, ZT, RDZ, CXCH + REAL DTHV, DU2, BTGH, ZSLU, ZSLT, RLOGU, RLOGT + REAL ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 + + REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, & + & RLMA + + INTEGER ILECH, ITR + + INTEGER, PARAMETER :: ITRMX = 5 + REAL, PARAMETER :: WWST = 1.2 + REAL, PARAMETER :: WWST2 = WWST * WWST + REAL, PARAMETER :: VKRM = 0.40 + REAL, PARAMETER :: EXCM = 0.001 + REAL, PARAMETER :: BETA = 1.0 / 270.0 + REAL, PARAMETER :: BTG = BETA * GRAV + REAL, PARAMETER :: ELFC = VKRM * BTG + REAL, PARAMETER :: WOLD = 0.15 + REAL, PARAMETER :: WNEW = 1.0 - WOLD + REAL, PARAMETER :: PIHF = 3.14159265 / 2. + REAL, PARAMETER :: EPSU2 = 1.E-4 + REAL, PARAMETER :: EPSUST = 0.07 + REAL, PARAMETER :: EPSIT = 1.E-4 + REAL, PARAMETER :: EPSA = 1.E-8 + REAL, PARAMETER :: ZTMIN = -5.0 + REAL, PARAMETER :: ZTMAX = 1.0 + REAL, PARAMETER :: HPBL = 1000.0 + REAL, PARAMETER :: SQVISC = 258.2 + REAL, PARAMETER :: RIC = 0.183 + REAL, PARAMETER :: RRIC = 1.0 / RIC + REAL, PARAMETER :: FHNEU = 0.8 + REAL, PARAMETER :: RFC = 0.191 + REAL, PARAMETER :: RFAC = RIC / ( FHNEU * RFC * RFC ) + +! ---------------------------------------------------------------------- +! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS +! ---------------------------------------------------------------------- +! LECH'S SURFACE FUNCTIONS + PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ) + PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.)) + PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ) + PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.)) +! PAULSON'S SURFACE FUNCTIONS + PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) & + & +2.* ATAN (XX) & + &- PIHF + PSPMS (YY)= 5.* YY + PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5) + PSPHS (YY)= 5.* YY + +! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND +! OVER SOLID SURFACE (LAND, SEA-ICE). +! ---------------------------------------------------------------------- +! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 +! C......ZTFC=0.1 +! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT +! ---------------------------------------------------------------------- + ILECH = 0 + +! ---------------------------------------------------------------------- + ZILFC = - parameters%CZIL * VKRM * SQVISC + ZU = Z0 + RDZ = 1./ ZLM + CXCH = EXCM * RDZ + DTHV = THLM - THZ0 + +! BELJARS CORRECTION OF USTAR + DU2 = MAX (SFCSPD * SFCSPD,EPSU2) + BTGH = BTG * HPBL + + IF(ITER == 1) THEN + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + RLMO = ELFC * AKHS * DTHV / USTAR **3 + END IF + +! ZILITINKEVITCH APPROACH FOR ZT + ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0) + ZSLU = ZLM + ZU + ZSLT = ZLM + ZT + RLOGU = log (ZSLU / ZU) + RLOGT = log (ZSLT / ZT) + +! ---------------------------------------------------------------------- +! 1./MONIN-OBUKKHOV LENGTH-SCALE +! ---------------------------------------------------------------------- + ZETALT = MAX (ZSLT * RLMO,ZTMIN) + RLMO = ZETALT / ZSLT + ZETALU = ZSLU * RLMO + ZETAU = ZU * RLMO + ZETAT = ZT * RLMO + + IF (ILECH .eq. 0) THEN + IF (RLMO .lt. 0.)THEN + XLU4 = 1. -16.* ZETALU + XLT4 = 1. -16.* ZETALT + XU4 = 1. -16.* ZETAU + XT4 = 1. -16.* ZETAT + XLU = SQRT (SQRT (XLU4)) + XLT = SQRT (SQRT (XLT4)) + XU = SQRT (SQRT (XU4)) + + XT = SQRT (SQRT (XT4)) + PSMZ = PSPMU (XU) + SIMM = PSPMU (XLU) - PSMZ + RLOGU + PSHZ = PSPHU (XT) + SIMH = PSPHU (XLT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) + ZETAU = MIN (ZETAU,ZTMAX/(ZSLU/ZU)) ! Barlage: add limit on ZETAU/ZETAT + ZETAT = MIN (ZETAT,ZTMAX/(ZSLT/ZT)) ! Barlage: prevent SIMM/SIMH < 0 + PSMZ = PSPMS (ZETAU) + SIMM = PSPMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS (ZETAT) + SIMH = PSPHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! LECH'S FUNCTIONS +! ---------------------------------------------------------------------- + ELSE + IF (RLMO .lt. 0.)THEN + PSMZ = PSLMU (ZETAU) + SIMM = PSLMU (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU (ZETAT) + SIMH = PSLHU (ZETALT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) + PSMZ = PSLMS (ZETAU) + SIMM = PSLMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS (ZETAT) + SIMH = PSLHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- + END IF + +! ---------------------------------------------------------------------- +! BELJAARS CORRECTION FOR USTAR +! ---------------------------------------------------------------------- + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + +! ZILITINKEVITCH FIX FOR ZT + ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0) + ZSLT = ZLM + ZT +!----------------------------------------------------------------------- + RLOGT = log (ZSLT / ZT) + USTARK = USTAR * VKRM + IF(SIMM < 1.e-6) SIMM = 1.e-6 ! Limit stability function + AKMS = MAX (USTARK / SIMM,CXCH) +!----------------------------------------------------------------------- +! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO +!----------------------------------------------------------------------- + IF(SIMH < 1.e-6) SIMH = 1.e-6 ! Limit stability function + AKHS = MAX (USTARK / SIMH,CXCH) + + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF +!----------------------------------------------------------------------- + RLMN = ELFC * AKHS * DTHV / USTAR **3 +!----------------------------------------------------------------------- +! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110 +!----------------------------------------------------------------------- + RLMA = RLMO * WOLD+ RLMN * WNEW +!----------------------------------------------------------------------- + RLMO = RLMA + +! write(*,'(a20,10f15.6)')'SFCDIF: RLMO=',RLMO,RLMN,ELFC , AKHS , DTHV , USTAR +! END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SFCDIF2 + +!== begin esat ===================================================================================== + + SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + IMPLICIT NONE +!--------------------------------------------------------------------------------------------------- +! in + + REAL, intent(in) :: T !temperature + +!out + + REAL, intent(out) :: ESW !saturation vapor pressure over water (pa) + REAL, intent(out) :: ESI !saturation vapor pressure over ice (pa) + REAL, intent(out) :: DESW !d(esat)/dt over water (pa/K) + REAL, intent(out) :: DESI !d(esat)/dt over ice (pa/K) + +! local + + REAL :: A0,A1,A2,A3,A4,A5,A6 !coefficients for esat over water + REAL :: B0,B1,B2,B3,B4,B5,B6 !coefficients for esat over ice + REAL :: C0,C1,C2,C3,C4,C5,C6 !coefficients for dsat over water + REAL :: D0,D1,D2,D3,D4,D5,D6 !coefficients for dsat over ice + + PARAMETER (A0=6.107799961 , A1=4.436518521E-01, & + A2=1.428945805E-02, A3=2.650648471E-04, & + A4=3.031240396E-06, A5=2.034080948E-08, & + A6=6.136820929E-11) + + PARAMETER (B0=6.109177956 , B1=5.034698970E-01, & + B2=1.886013408E-02, B3=4.176223716E-04, & + B4=5.824720280E-06, B5=4.838803174E-08, & + B6=1.838826904E-10) + + PARAMETER (C0= 4.438099984E-01, C1=2.857002636E-02, & + C2= 7.938054040E-04, C3=1.215215065E-05, & + C4= 1.036561403E-07, C5=3.532421810e-10, & + C6=-7.090244804E-13) + + PARAMETER (D0=5.030305237E-01, D1=3.773255020E-02, & + D2=1.267995369E-03, D3=2.477563108E-05, & + D4=3.005693132E-07, D5=2.158542548E-09, & + D6=7.131097725E-12) + + ESW = 100.*(A0+T*(A1+T*(A2+T*(A3+T*(A4+T*(A5+T*A6)))))) + ESI = 100.*(B0+T*(B1+T*(B2+T*(B3+T*(B4+T*(B5+T*B6)))))) + DESW = 100.*(C0+T*(C1+T*(C2+T*(C3+T*(C4+T*(C5+T*C6)))))) + DESI = 100.*(D0+T*(D1+T*(D2+T*(D3+T*(D4+T*(D5+T*D6)))))) + + END SUBROUTINE ESAT + +!== begin stomata ================================================================================== + + SUBROUTINE STOMATA (parameters,VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in + TV ,EI ,EA ,SFCTMP ,SFCPRS , & !in + O2 ,CO2 ,IGS ,BTRAN ,RB , & !in + RS ,PSN ) !out +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type + + REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL, INTENT(IN) :: MPE !prevents division by zero errors + + REAL, INTENT(IN) :: TV !foliage temperature (k) + REAL, INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) + REAL, INTENT(IN) :: EA !vapor pressure of canopy air (pa) + REAL, INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) + REAL, INTENT(IN) :: O2 !atmospheric o2 concentration (pa) + REAL, INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) + REAL, INTENT(IN) :: SFCPRS !air pressure at reference height (pa) + REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL, INTENT(IN) :: FOLN !foliage nitrogen concentration (%) + REAL, INTENT(IN) :: RB !boundary layer resistance (s/m) + +! output + REAL, INTENT(OUT) :: RS !leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] + +! in&out + REAL :: RLB !boundary layer resistance (s m2 / umol) +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: ITER !iteration index + INTEGER :: NITER !number of iterations + + DATA NITER /3/ + SAVE NITER + + REAL :: AB !used in statement functions + REAL :: BC !used in statement functions + REAL :: F1 !generic temperature response (statement function) + REAL :: F2 !generic temperature inhibition (statement function) + REAL :: TC !foliage temperature (degree Celsius) + REAL :: CS !co2 concentration at leaf surface (pa) + REAL :: KC !co2 Michaelis-Menten constant (pa) + REAL :: KO !o2 Michaelis-Menten constant (pa) + REAL :: A,B,C,Q !intermediate calculations for RS + REAL :: R1,R2 !roots for RS + REAL :: FNF !foliage nitrogen adjustment factor (0 to 1) + REAL :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) + REAL :: WC !Rubisco limited photosynthesis (umol co2/m2/s) + REAL :: WJ !light limited photosynthesis (umol co2/m2/s) + REAL :: WE !export limited photosynthesis (umol co2/m2/s) + REAL :: CP !co2 compensation point (pa) + REAL :: CI !internal co2 (pa) + REAL :: AWC !intermediate calculation for wc + REAL :: VCMX !maximum rate of carbonylation (umol co2/m2/s) + REAL :: J !electron transport (umol co2/m2/s) + REAL :: CEA !constrain ea or else model blows up + REAL :: CF !s m2/umol -> s/m + + F1(AB,BC) = AB**((BC-25.)/10.) + F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) + REAL :: T +! --------------------------------------------------------------------------------------------- + +! initialize RS=RSMAX and PSN=0 because will only do calculations +! for APAR > 0, in which case RS <= RSMAX and PSN >= 0 + + CF = SFCPRS/(8.314*SFCTMP)*1.e06 + RS = 1./parameters%BP * CF + PSN = 0. + + IF (APAR .LE. 0.) RETURN + + FNF = MIN( FOLN/MAX(MPE,parameters%FOLNMX), 1.0 ) + TC = TV-TFRZ + PPF = 4.6*APAR + J = PPF*parameters%QE25 + KC = parameters%KC25 * F1(parameters%AKC,TC) + KO = parameters%KO25 * F1(parameters%AKO,TC) + AWC = KC * (1.+O2/KO) + CP = 0.5*KC/KO*O2*0.21 + VCMX = parameters%VCMX25 / F2(TC) * FNF * BTRAN * F1(parameters%AVCMX,TC) + +! first guess ci + + CI = 0.7*CO2*parameters%C3PSN + 0.4*CO2*(1.-parameters%C3PSN) + +! rb: s/m -> s m**2 / umol + + RLB = RB/CF + +! constrain ea + + CEA = MAX(0.25*EI*parameters%C3PSN+0.40*EI*(1.-parameters%C3PSN), MIN(EA,EI) ) + +! ci iteration +!jref: C3PSN is equal to 1 for all veg types. + DO ITER = 1, NITER + WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*parameters%C3PSN + J*(1.-parameters%C3PSN) + WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*parameters%C3PSN + VCMX*(1.-parameters%C3PSN) + WE = 0.5*VCMX*parameters%C3PSN + 4000.*VCMX*CI/SFCPRS*(1.-parameters%C3PSN) + PSN = MIN(WJ,WC,WE) * IGS + + CS = MAX( CO2-1.37*RLB*SFCPRS*PSN, MPE ) + A = parameters%MP*PSN*SFCPRS*CEA / (CS*EI) + parameters%BP + B = ( parameters%MP*PSN*SFCPRS/CS + parameters%BP ) * RLB - 1. + C = -RLB + IF (B .GE. 0.) THEN + Q = -0.5*( B + SQRT(B*B-4.*A*C) ) + ELSE + Q = -0.5*( B - SQRT(B*B-4.*A*C) ) + END IF + R1 = Q/A + R2 = C/Q + RS = MAX(R1,R2) + CI = MAX( CS-PSN*SFCPRS*1.65*RS, 0. ) + END DO + +! rs, rb: s m**2 / umol -> s/m + + RS = RS*CF + + END SUBROUTINE STOMATA + +!== begin canres =================================================================================== + + SUBROUTINE CANRES (parameters,PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in + RC ,PSN ,ILOC ,JLOC ) !out + +! -------------------------------------------------------------------------------------------------- +! calculate canopy resistance which depends on incoming solar radiation, +! air temperature, atmospheric water vapor pressure deficit at the +! lowest model level, and soil moisture (preferably unfrozen soil +! moisture rather than total) +! -------------------------------------------------------------------------------------------------- +! source: Jarvis (1976), Noilhan and Planton (1989, MWR), Jacquemin and +! Noilhan (1990, BLM). Chen et al (1996, JGR, Vol 101(D3), 7251-7268), +! eqns 12-14 and table 2 of sec. 3.1.2 +! -------------------------------------------------------------------------------------------------- +!niu USE module_Noahlsm_utility +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + REAL, INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) + REAL, INTENT(IN) :: SFCTMP !canopy air temperature + REAL, INTENT(IN) :: SFCPRS !surface pressure (pa) + REAL, INTENT(IN) :: EAH !water vapor pressure (pa) + REAL, INTENT(IN) :: RCSOIL !soil moisture stress factor + +!outputs + + REAL, INTENT(OUT) :: RC !canopy resistance per unit LAI + REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) + +!local + + REAL :: RCQ + REAL :: RCS + REAL :: RCT + REAL :: FF + REAL :: Q2 !water vapor mixing ratio (kg/kg) + REAL :: Q2SAT !saturation Q2 + REAL :: DQSDT2 !d(Q2SAT)/d(T) + +! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM +! ---------------------------------------------------------------------- +! initialize canopy resistance multiplier terms. +! ---------------------------------------------------------------------- + RC = 0.0 + RCS = 0.0 + RCT = 0.0 + RCQ = 0.0 + +! compute Q2 and Q2SAT + + Q2 = 0.622 * EAH / (SFCPRS - 0.378 * EAH) !specific humidity [kg/kg] + Q2 = Q2 / (1.0 + Q2) !mixing ratio [kg/kg] + + CALL CALHUM(parameters,SFCTMP, SFCPRS, Q2SAT, DQSDT2) + +! contribution due to incoming solar radiation + + FF = 2.0 * PAR / parameters%RGL + RCS = (FF + parameters%RSMIN / parameters%RSMAX) / (1.0+ FF) + RCS = MAX (RCS,0.0001) + +! contribution due to air temperature + + RCT = 1.0- 0.0016* ( (parameters%TOPT - SFCTMP)**2.0) + RCT = MAX (RCT,0.0001) + +! contribution due to vapor pressure deficit + + RCQ = 1.0/ (1.0+ parameters%HS * MAX(0.,Q2SAT-Q2)) + RCQ = MAX (RCQ,0.01) + +! determine canopy resistance due to all factors + + RC = parameters%RSMIN / (RCS * RCT * RCQ * RCSOIL) + PSN = -999.99 ! PSN not applied for dynamic carbon + + END SUBROUTINE CANRES + +!== begin calhum =================================================================================== + + SUBROUTINE CALHUM(parameters,SFCTMP, SFCPRS, Q2SAT, DQSDT2) + + IMPLICIT NONE + + type (noahmp_parameters), intent(in) :: parameters + REAL, INTENT(IN) :: SFCTMP, SFCPRS + REAL, INTENT(OUT) :: Q2SAT, DQSDT2 + REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + A23M4=A2*(A3-A4), E0=0.611, RV=461.0, & + EPSILON=0.622 + REAL :: ES, SFCPRSX + +! Q2SAT: saturated mixing ratio + ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) +! convert SFCPRS from Pa to KPa + SFCPRSX = SFCPRS*1.E-3 + Q2SAT = EPSILON * ES / (SFCPRSX-ES) +! convert from g/g to g/kg + Q2SAT = Q2SAT * 1.E3 +! Q2SAT is currently a 'mixing ratio' + +! DQSDT2 is calculated assuming Q2SAT is a specific humidity + DQSDT2=(Q2SAT/(1+Q2SAT))*A23M4/(SFCTMP-A4)**2 + +! DG Q2SAT needs to be in g/g when returned for SFLX + Q2SAT = Q2SAT / 1.E3 + + END SUBROUTINE CALHUM + +!== begin tsnosoi ================================================================================== + + SUBROUTINE TSNOSOI (parameters,ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in + TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in + SAG ,DT ,SNOWH ,DZSNSO , & !in + TG ,ILOC ,JLOC , & !in + STC ) !inout +! -------------------------------------------------------------------------------------------------- +! Compute snow (up to 3L) and soil (4L) temperature. Note that snow temperatures +! during melting season may exceed melting point (TFRZ) but later in PHASECHANGE +! subroutine the snow temperatures are reset to TFRZ for melting snow. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: ICE ! + INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) + INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) + INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers + INTEGER, INTENT(IN) :: IST !surface type + + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: TBOT ! + REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) + REAL, INTENT(IN) :: SAG !solar rad. absorbed by ground (w/m2) + REAL, INTENT(IN) :: SNOWH !snow depth (m) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bot. depth from snow surf.(m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity (J/m3/k) + +!input and output + + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC + +!local + + INTEGER :: IZ + REAL :: ZBOTSNO !ZBOT from snow surface + REAL, DIMENSION(-NSNOW+1:NSOIL) :: AI, BI, CI, RHSTS + REAL :: EFLXB !energy influx from soil bottom (w/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI !light through water (w/m2) + + REAL, DIMENSION(-NSNOW+1:NSOIL) :: TBEG + REAL :: ERR_EST !heat storage error (w/m2) + REAL :: SSOIL2 !ground heat flux (w/m2) (for energy check) + REAL :: EFLXB2 !heat flux from the bottom (w/m2) (for energy check) + character(len=256) :: message +! ---------------------------------------------------------------------- +! compute solar penetration through water, needs more work + + PHI(ISNOW+1:NSOIL) = 0. + +! adjust ZBOT from soil surface to ZBOTSNO from snow surface + + ZBOTSNO = parameters%ZBOT - SNOWH !from snow surface + +! snow/soil heat storage for energy balance check + + DO IZ = ISNOW+1, NSOIL + TBEG(IZ) = STC(IZ) + ENDDO + +! compute soil temperatures + + CALL HRT (parameters,NSNOW ,NSOIL ,ISNOW ,ZSNSO , & + STC ,TBOT ,ZBOTSNO ,DT , & + DF ,HCPCT ,SSOIL ,PHI , & + AI ,BI ,CI ,RHSTS , & + EFLXB ) + + CALL HSTEP (parameters,NSNOW ,NSOIL ,ISNOW ,DT , & + AI ,BI ,CI ,RHSTS , & + STC ) + +! update ground heat flux just for energy check, but not for final output +! otherwise, it would break the surface energy balance + + IF(OPT_TBOT == 1) THEN + EFLXB2 = 0. + ELSE IF(OPT_TBOT == 2) THEN + EFLXB2 = DF(NSOIL)*(TBOT-STC(NSOIL)) / & + (0.5*(ZSNSO(NSOIL-1)+ZSNSO(NSOIL)) - ZBOTSNO) + END IF + + ! Skip the energy balance check for now, until we can make it work + ! right for small time steps. + return + +! energy balance check + + ERR_EST = 0.0 + DO IZ = ISNOW+1, NSOIL + ERR_EST = ERR_EST + (STC(IZ)-TBEG(IZ)) * DZSNSO(IZ) * HCPCT(IZ) / DT + ENDDO + + if (OPT_STC == 1 .OR. OPT_STC == 3) THEN ! semi-implicit + ERR_EST = ERR_EST - (SSOIL +EFLXB) + ELSE ! full-implicit + SSOIL2 = DF(ISNOW+1)*(TG-STC(ISNOW+1))/(0.5*DZSNSO(ISNOW+1)) !M. Barlage + ERR_EST = ERR_EST - (SSOIL2+EFLXB2) + ENDIF + + IF (ABS(ERR_EST) > 1.) THEN + IF (this_image()==1) THEN + ! W/m2 + WRITE(message,*) 'TSNOSOI is losing(-)/gaining(+) false energy',ERR_EST,' W/m2' +! call wrf_message(trim(message)) + WRITE(message,'(i6,1x,i6,1x,i3,F18.13,5F20.12)') & + ILOC, JLOC, IST,ERR_EST,SSOIL,SNOWH,TG,STC(ISNOW+1),EFLXB +! call wrf_message(trim(message)) + !niu STOP + ENDIF + END IF + + END SUBROUTINE TSNOSOI + +!== begin hrt ====================================================================================== + + SUBROUTINE HRT (parameters,NSNOW ,NSOIL ,ISNOW ,ZSNSO , & + STC ,TBOT ,ZBOT ,DT , & + DF ,HCPCT ,SSOIL ,PHI , & + AI ,BI ,CI ,RHSTS , & + BOTFLX ) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) + INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) + INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers + REAL, INTENT(IN) :: TBOT !bottom soil temp. at ZBOT (k) + REAL, INTENT(IN) :: ZBOT !depth of lower boundary condition (m) + !from soil surface not snow surface + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !depth of layer-bottom of snow/soil (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity [j/m3/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: PHI !light through water (w/m2) + +! output + + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: RHSTS !right-hand side of the matrix + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: AI !left-hand side coefficient + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: BI !left-hand side coefficient + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: CI !left-hand side coefficient + REAL, INTENT(OUT) :: BOTFLX !energy influx from soil bottom (w/m2) + +! local + + INTEGER :: K + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DDZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DENOM + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DTSDZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: EFLUX + REAL :: TEMP1 +! ---------------------------------------------------------------------- + + DO K = ISNOW+1, NSOIL + IF (K == ISNOW+1) THEN + DENOM(K) = - ZSNSO(K) * HCPCT(K) + TEMP1 = - ZSNSO(K+1) + DDZ(K) = 2.0 / TEMP1 + DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 + EFLUX(K) = DF(K) * DTSDZ(K) - SSOIL - PHI(K) + ELSE IF (K < NSOIL) THEN + DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) + TEMP1 = ZSNSO(K-1) - ZSNSO(K+1) + DDZ(K) = 2.0 / TEMP1 + DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 + EFLUX(K) = (DF(K)*DTSDZ(K) - DF(K-1)*DTSDZ(K-1)) - PHI(K) + ELSE IF (K == NSOIL) THEN + DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) + TEMP1 = ZSNSO(K-1) - ZSNSO(K) + IF(OPT_TBOT == 1) THEN + BOTFLX = 0. + END IF + IF(OPT_TBOT == 2) THEN + DTSDZ(K) = (STC(K) - TBOT) / ( 0.5*(ZSNSO(K-1)+ZSNSO(K)) - ZBOT) + BOTFLX = -DF(K) * DTSDZ(K) + END IF + EFLUX(K) = (-BOTFLX - DF(K-1)*DTSDZ(K-1) ) - PHI(K) + END IF + END DO + + DO K = ISNOW+1, NSOIL + IF (K == ISNOW+1) THEN + AI(K) = 0.0 + CI(K) = - DF(K) * DDZ(K) / DENOM(K) + IF (OPT_STC == 1 .OR. OPT_STC == 3 ) THEN + BI(K) = - CI(K) + END IF + IF (OPT_STC == 2) THEN + BI(K) = - CI(K) + DF(K)/(0.5*ZSNSO(K)*ZSNSO(K)*HCPCT(K)) + END IF + ELSE IF (K < NSOIL) THEN + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = - DF(K ) * DDZ(K ) / DENOM(K) + BI(K) = - (AI(K) + CI (K)) + ELSE IF (K == NSOIL) THEN + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = 0.0 + BI(K) = - (AI(K) + CI(K)) + END IF + RHSTS(K) = EFLUX(K)/ (-DENOM(K)) + END DO + + END SUBROUTINE HRT + +!== begin hstep ==================================================================================== + + SUBROUTINE HSTEP (parameters,NSNOW ,NSOIL ,ISNOW ,DT , & + AI ,BI ,CI ,RHSTS , & + STC ) +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL + INTEGER, INTENT(IN) :: NSNOW + INTEGER, INTENT(IN) :: ISNOW + REAL, INTENT(IN) :: DT + +! output & input + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: RHSTS + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: AI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: BI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: CI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC + +! local + INTEGER :: K + REAL, DIMENSION(-NSNOW+1:NSOIL) :: RHSTSIN + REAL, DIMENSION(-NSNOW+1:NSOIL) :: CIIN +! ---------------------------------------------------------------------- + + DO K = ISNOW+1,NSOIL + RHSTS(K) = RHSTS(K) * DT + AI(K) = AI(K) * DT + BI(K) = 1. + BI(K) * DT + CI(K) = CI(K) * DT + END DO + +! copy values for input variables before call to rosr12 + + DO K = ISNOW+1,NSOIL + RHSTSIN(K) = RHSTS(K) + CIIN(K) = CI(K) + END DO + +! solve the tri-diagonal matrix equation + + CALL ROSR12 (CI,AI,BI,CIIN,RHSTSIN,RHSTS,ISNOW+1,NSOIL,NSNOW) + +! update snow & soil temperature + + DO K = ISNOW+1,NSOIL + STC (K) = STC (K) + CI (K) + END DO + + END SUBROUTINE HSTEP + +!== begin rosr12 =================================================================================== + + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW) +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NTOP + INTEGER, INTENT(IN) :: NSOIL,NSNOW + INTEGER :: K, KK + + REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(IN):: A, B, D + REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(INOUT):: C,P,DELTA + +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C (NSOIL) = 0.0 + P (NTOP) = - C (NTOP) / B (NTOP) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR THE 1ST SOIL LAYER +! ---------------------------------------------------------------------- + DELTA (NTOP) = D (NTOP) / B (NTOP) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = NTOP+1,NSOIL + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& + * P (K -1))) + END DO +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P (NSOIL) = DELTA (NSOIL) +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = NTOP+1,NSOIL + KK = NSOIL - K + (NTOP-1) + 1 + P (KK) = P (KK) * P (KK +1) + DELTA (KK) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12 + +!== begin phasechange ============================================================================== + + SUBROUTINE PHASECHANGE (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in + DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , & !in + STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout + SMC ,SH2O , & !inout + QMELT ,IMELT ,PONDING ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [=3] + INTEGER, INTENT(IN) :: NSOIL !No. of soil layers [=4] + INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers [<=3] + INTEGER, INTENT(IN) :: IST !surface type: 1->soil; 2->lake + REAL, INTENT(IN) :: DT !land model time step (sec) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: FACT !temporary + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity (J/m3/k) + +! outputs + INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index + REAL, INTENT(OUT) :: QMELT !snowmelt rate [mm/s] + REAL, INTENT(OUT) :: PONDING!snowmelt when snow has no layer [mm] + +! inputs and outputs + + REAL, INTENT(INOUT) :: SNEQV + REAL, INTENT(INOUT) :: SNOWH + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water [m3/m3] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + +! local + + INTEGER :: J !do loop index + REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM !energy residual [w/m2] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM !melting or freezing water [kg/m2] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE !soil/snow ice mass [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ !soil/snow liquid water mass [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: SUPERCOOL !supercooled water in soil (kg/m2) + REAL :: HEATR !energy residual or loss after melting/freezing + REAL :: TEMP1 !temporary variables [kg/m2] + REAL :: PROPOR + REAL :: SMP !frozen water potential (mm) + REAL :: XMF !total latent heat of phase change + +! ---------------------------------------------------------------------- +! Initialization + + QMELT = 0. + PONDING = 0. + XMF = 0. + + DO J = -NSNOW+1, NSOIL + SUPERCOOL(J) = 0.0 + END DO + + DO J = ISNOW+1,0 ! all layers + MICE(J) = SNICE(J) + MLIQ(J) = SNLIQ(J) + END DO + + DO J = 1, NSOIL ! soil + MLIQ(J) = SH2O(J) * DZSNSO(J) * 1000. + MICE(J) = (SMC(J) - SH2O(J)) * DZSNSO(J) * 1000. + END DO + + DO J = ISNOW+1,NSOIL ! all layers + IMELT(J) = 0 + HM(J) = 0. + XM(J) = 0. + WICE0(J) = MICE(J) + WLIQ0(J) = MLIQ(J) + WMASS0(J) = MICE(J) + MLIQ(J) + ENDDO + + if(ist == 1) then + DO J = 1,NSOIL + IF (OPT_FRZ == 1) THEN + IF(STC(J) < TFRZ) THEN + SMP = HFUS*(TFRZ-STC(J))/(GRAV*STC(J)) !(m) + SUPERCOOL(J) = parameters%SMCMAX(J)*(SMP/parameters%PSISAT(J))**(-1./parameters%BEXP(J)) + SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000. !(mm) + END IF + END IF + IF (OPT_FRZ == 2) THEN + CALL FRH2O (parameters,J,SUPERCOOL(J),STC(J),SMC(J),SH2O(J)) + SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000. !(mm) + END IF + ENDDO + end if + + DO J = ISNOW+1,NSOIL + IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN !melting + IMELT(J) = 1 + ENDIF + IF (MLIQ(J) > SUPERCOOL(J) .AND. STC(J) < TFRZ) THEN + IMELT(J) = 2 + ENDIF + + ! If snow exists, but its thickness is not enough to create a layer + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. J == 1) THEN + IF (STC(J) >= TFRZ) THEN + IMELT(J) = 1 + ENDIF + ENDIF + ENDDO + +! Calculate the energy surplus and loss for melting and freezing + + DO J = ISNOW+1,NSOIL + IF (IMELT(J) > 0) THEN + HM(J) = (STC(J)-TFRZ)/FACT(J) + STC(J) = TFRZ + ENDIF + + IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + XM(J) = HM(J)*DT/HFUS + ENDDO + +! The rate of melting and freezing for snow without a layer, needs more work. + + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN + TEMP1 = SNEQV + SNEQV = MAX(0.,TEMP1-XM(1)) + PROPOR = SNEQV/TEMP1 + SNOWH = MAX(0.,PROPOR * SNOWH) + SNOWH = MIN(MAX(SNOWH,SNEQV/500.0),SNEQV/50.0) ! limit adjustment to a reasonable density + HEATR = HM(1) - HFUS*(TEMP1-SNEQV)/DT + IF (HEATR > 0.) THEN + XM(1) = HEATR*DT/HFUS + HM(1) = HEATR + ELSE + XM(1) = 0. + HM(1) = 0. + ENDIF + QMELT = MAX(0.,(TEMP1-SNEQV))/DT + XMF = HFUS*QMELT + PONDING = TEMP1-SNEQV + ENDIF + +! The rate of melting and freezing for snow and soil + + DO J = ISNOW+1,NSOIL + IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN + + HEATR = 0. + IF (XM(J) > 0.) THEN + MICE(J) = MAX(0., WICE0(J)-XM(J)) + HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ELSE IF (XM(J) < 0.) THEN + IF (J <= 0) THEN ! snow + MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) + ELSE ! soil + IF (WMASS0(J) < SUPERCOOL(J)) THEN + MICE(J) = 0. + ELSE + MICE(J) = MIN(WMASS0(J) - SUPERCOOL(J),WICE0(J)-XM(J)) + MICE(J) = MAX(MICE(J),0.0) + ENDIF + ENDIF + HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ENDIF + + MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J)) + + IF (ABS(HEATR) > 0.) THEN + STC(J) = STC(J) + FACT(J)*HEATR + IF (J <= 0) THEN ! snow + IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ + IF (MICE(J) == 0.) THEN ! BARLAGE + STC(J) = TFRZ ! BARLAGE + HM(J+1) = HM(J+1) + HEATR ! BARLAGE + XM(J+1) = HM(J+1)*DT/HFUS ! BARLAGE + ENDIF + END IF + ENDIF + + XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT + + IF (J < 1) THEN + QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT + ENDIF + ENDIF + ENDDO + + DO J = ISNOW+1,0 ! snow + SNLIQ(J) = MLIQ(J) + SNICE(J) = MICE(J) + END DO + + DO J = 1, NSOIL ! soil + SH2O(J) = MLIQ(J) / (1000. * DZSNSO(J)) + SMC(J) = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J)) + END DO + + END SUBROUTINE PHASECHANGE + +!== begin frh2o ==================================================================================== + + SUBROUTINE FRH2O (parameters,ISOIL,FREE,TKELV,SMC,SH2O) + +! ---------------------------------------------------------------------- +! SUBROUTINE FRH2O +! ---------------------------------------------------------------------- +! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF +! TEMPERATURE IS BELOW 273.15K (TFRZ). REQUIRES NEWTON-TYPE ITERATION +! TO SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL +! (1999, JGR, VOL 104(D16), 19569-19585). +! ---------------------------------------------------------------------- +! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON +! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN +! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT +! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH +! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, +! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE +! LIMIT OF FREEZING POINT TEMPERATURE TFRZ. +! ---------------------------------------------------------------------- +! INPUT: + +! TKELV.........TEMPERATURE (Kelvin) +! SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC) +! SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC) +! B.............SOIL TYPE "B" PARAMETER (FROM REDPRM) +! PSISAT........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM) + +! OUTPUT: +! FREE..........SUPERCOOLED LIQUID WATER CONTENT [m3/m3] +! ---------------------------------------------------------------------- + IMPLICIT NONE + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ISOIL + REAL, INTENT(IN) :: SH2O,SMC,TKELV + REAL, INTENT(OUT) :: FREE + REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK + INTEGER :: NLOG,KCOUNT +! PARAMETER(CK = 0.0) + REAL, PARAMETER :: CK = 8.0, BLIM = 5.5, ERROR = 0.005, & + DICE = 920.0 + CHARACTER(LEN=80) :: message + +! ---------------------------------------------------------------------- +! LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM) +! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS +! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES. +! ---------------------------------------------------------------------- + BX = parameters%BEXP(ISOIL) +! ---------------------------------------------------------------------- +! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG. +! ---------------------------------------------------------------------- + + IF (parameters%BEXP(ISOIL) > BLIM) BX = BLIM + NLOG = 0 + +! ---------------------------------------------------------------------- +! IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (TFRZ), SH2O = SMC +! ---------------------------------------------------------------------- + KCOUNT = 0 + IF (TKELV > (TFRZ- 1.E-3)) THEN + FREE = SMC + ELSE + +! ---------------------------------------------------------------------- +! OPTION 1: ITERATED SOLUTION IN KOREN ET AL, JGR, 1999, EQN 17 +! ---------------------------------------------------------------------- +! INITIAL GUESS FOR SWL (frozen content) +! ---------------------------------------------------------------------- + IF (CK /= 0.0) THEN + SWL = SMC - SH2O +! ---------------------------------------------------------------------- +! KEEP WITHIN BOUNDS. +! ---------------------------------------------------------------------- + IF (SWL > (SMC -0.02)) SWL = SMC -0.02 +! ---------------------------------------------------------------------- +! START OF ITERATIONS +! ---------------------------------------------------------------------- + IF (SWL < 0.) SWL = 0. +1001 Continue + IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002 + NLOG = NLOG +1 + DF = ALOG ( ( parameters%PSISAT(ISOIL) * GRAV / HFUS ) * ( ( 1. + CK * SWL )**2.) * & + ( parameters%SMCMAX(ISOIL) / (SMC - SWL) )** BX) - ALOG ( - ( & + TKELV - TFRZ)/ TKELV) + DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL ) + SWLK = SWL - DF / DENOM +! ---------------------------------------------------------------------- +! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. +! ---------------------------------------------------------------------- + IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02 + IF (SWLK < 0.) SWLK = 0. + +! ---------------------------------------------------------------------- +! MATHEMATICAL SOLUTION BOUNDS APPLIED. +! ---------------------------------------------------------------------- + DSWL = ABS (SWLK - SWL) +! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.) +! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED. +! ---------------------------------------------------------------------- + SWL = SWLK + IF ( DSWL <= ERROR ) THEN + KCOUNT = KCOUNT +1 + END IF +! ---------------------------------------------------------------------- +! END OF ITERATIONS +! ---------------------------------------------------------------------- +! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. +! ---------------------------------------------------------------------- + goto 1001 +1002 continue + FREE = SMC - SWL + END IF +! ---------------------------------------------------------------------- +! END OPTION 1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 +! IN KOREN ET AL., JGR, 1999, EQN 17 +! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION +! ---------------------------------------------------------------------- + IF (KCOUNT == 0) THEN + IF (this_image()==1) THEN + write(message, '("Flerchinger used in NEW version. Iterations=", I6)') NLOG + ENDIF + ! call wrf_message(trim(message)) + FK = ( ( (HFUS / (GRAV * ( - parameters%PSISAT(ISOIL))))* & + ( (TKELV - TFRZ)/ TKELV))** ( -1/ BX))* parameters%SMCMAX(ISOIL) + IF (FK < 0.02) FK = 0.02 + FREE = MIN (FK, SMC) +! ---------------------------------------------------------------------- +! END OPTION 2 +! ---------------------------------------------------------------------- + END IF + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE FRH2O +! ---------------------------------------------------------------------- +! ================================================================================================== +! **********************End of energy subroutines*********************** +! ================================================================================================== + +!== begin water ==================================================================================== + + SUBROUTINE WATER (parameters,VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in + VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in + ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in + IRRFRA ,MIFAC ,FIFAC ,CROPLU , & !in + FICEOLD,PONDING,TG ,IST ,FVEG ,ILOC ,JLOC ,SMCEQ , & !in + BDFALL ,FP ,RAIN ,SNOW, & !in MB/AN: v3.7 + QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB + ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout + SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout + SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout + SMCWTD ,DEEPRECH,RECH , & !inout + IRAMTFI,IRAMTMI ,IRFIRATE ,IRMIRATE, & !inout + CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out + QIN ,QDIS ,PONDING1 ,PONDING2, & + QSNBOT & +!#ifdef WRF_HYDRO +! ,sfcheadrt & +!#endif + ) !out +! ---------------------------------------------------------------------- +! Code history: +! Initial code: Guo-Yue Niu, Oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: IST !surface type 1-soil; 2-lake + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [1-melt; 2-freeze] + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] + REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] + REAL, INTENT(IN) :: FCEV !canopy evaporation (w/m2) [+ to atm ] + REAL, INTENT(IN) :: FCTR !transpiration (w/m2) [+ to atm] + REAL, INTENT(IN) :: QPRECC !convective precipitation (mm/s) + REAL, INTENT(IN) :: QPRECL !large-scale precipitation (mm/s) + REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow + REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL, INTENT(IN) :: QVAP !soil surface evaporation rate[mm/s] + REAL, INTENT(IN) :: QDEW !soil surface dew rate[mm/s] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: BTRANI !soil water stress factor (0 to 1) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD !ice fraction at last timestep +! REAL , INTENT(IN) :: PONDING ![mm] + REAL , INTENT(IN) :: TG !ground temperature (k) + REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 + REAL , INTENT(IN) :: FP !fraction of the gridcell that receives precipitation ! MB/AN: v3.7 + REAL , INTENT(IN) :: RAIN !rainfall (mm/s) ! MB/AN: v3.7 + REAL , INTENT(IN) :: SNOW !snowfall (mm/s) ! MB/AN: v3.7 + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics) + REAL , INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL , INTENT(IN) :: QRAIN !rain at ground srf (mm) [+] + REAL , INTENT(IN) :: SNOWHIN !snow depth increasing rate (m/s) + +! input/output + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + REAL, INTENT(INOUT) :: TV !vegetation temperature (k) + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !depth of snow/soil layer-bottom + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] + REAL, INTENT(INOUT) :: ZWT !the depth to water table [m] + REAL, INTENT(INOUT) :: WA !water storage in aquifer [mm] + REAL, INTENT(INOUT) :: WT !water storage in aquifer + !+ stuarated soil [mm] + REAL, INTENT(INOUT) :: WSLAKE !water storage in lake (can be -) (mm) + REAL , INTENT(INOUT) :: PONDING ![mm] + REAL, INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3] + REAL, INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m] + REAL, INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic) + +! output + REAL, INTENT(OUT) :: CMC !intercepted water per ground area (mm) + REAL, INTENT(OUT) :: ECAN !evap of intercepted water (mm/s) [+] + REAL, INTENT(OUT) :: ETRAN !transpiration rate (mm/s) [+] + REAL, INTENT(OUT) :: FWET !wetted/snowed fraction of canopy (-) + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: RUNSUB !baseflow (sturation excess) [mm/s] + REAL, INTENT(OUT) :: QIN !groundwater recharge [mm/s] + REAL, INTENT(OUT) :: QDIS !groundwater discharge [mm/s] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + REAL , INTENT(IN) :: LATHEAV !latent heat vap./sublimation (j/kg) + REAL , INTENT(IN) :: LATHEAG !latent heat vap./sublimation (j/kg) + LOGICAL , INTENT(IN) :: FROZEN_GROUND ! used to define latent heat pathway + LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway + +! irrigation + REAL, INTENT(IN) :: IRRFRA ! irrigation fraction + REAL, INTENT(IN) :: MIFAC ! micro irrigation fraction + REAL, INTENT(IN) :: FIFAC ! flood irrigation fraction + REAL, INTENT(INOUT):: IRAMTFI ! irrigation water amount [m] to be applied, Sprinkler + REAL, INTENT(INOUT):: IRAMTMI ! irrigation water amount [m] to be applied, Micro + REAL, INTENT(INOUT):: IRFIRATE ! rate of irrigation by micro [m/timestep] + REAL, INTENT(INOUT):: IRMIRATE ! rate of irrigation by micro [m/timestep] + LOGICAL, INTENT(IN) :: CROPLU ! flag to identify croplands + +! local + INTEGER :: IZ + REAL :: QINSUR !water input on soil surface [m/s] + REAL :: QSEVA !soil surface evap rate [mm/s] + REAL :: QSDEW !soil surface dew rate [mm/s] + REAL :: QSNFRO !snow surface frost rate[mm/s] + REAL :: QSNSUB !snow surface sublimation rate [mm/s] + REAL, DIMENSION( 1:NSOIL) :: ETRANI !transpiration rate (mm/s) [+] + REAL, DIMENSION( 1:NSOIL) :: WCND !hydraulic conductivity (m/s) + REAL :: QDRAIN !soil-bottom free drainage [mm/s] + REAL :: SNOFLOW !glacier flow [mm/s] + REAL :: FCRMAX !maximum of FCR (-) + + REAL, PARAMETER :: WSLMAX = 5000. !maximum lake water storage (mm) + +!#ifdef WRF_HYDRO +! REAL , INTENT(INOUT) :: sfcheadrt +!#endif + +! ---------------------------------------------------------------------- +! initialize + + ETRANI(1:NSOIL) = 0. + SNOFLOW = 0. + RUNSUB = 0. + QINSUR = 0. + +! canopy-intercepted snowfall/rainfall, drips, and throughfall + + CALL CANWATER (parameters,VEGTYP ,DT , & !in + FCEV ,FCTR ,ELAI , & !in + ESAI ,TG ,FVEG ,ILOC , JLOC, & !in + BDFALL ,FROZEN_CANOPY , & !in + CANLIQ ,CANICE ,TV , & !inout + CMC ,ECAN ,ETRAN , & !out + FWET ) !out + +! sublimation, frost, evaporation, and dew + + QSNSUB = 0. + IF (SNEQV > 0.) THEN + QSNSUB = MIN(QVAP, SNEQV/DT) + ENDIF + QSEVA = QVAP-QSNSUB + + QSNFRO = 0. + IF (SNEQV > 0.) THEN + QSNFRO = QDEW + ENDIF + QSDEW = QDEW - QSNFRO + + CALL SNOWWATER (parameters,NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in + & SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , & !in + & QRAIN ,FICEOLD,ILOC ,JLOC , & !in + & ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout + & SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , & !inout + & QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out + + IF(FROZEN_GROUND) THEN + SICE(1) = SICE(1) + (QSDEW-QSEVA)*DT/(DZSNSO(1)*1000.) + QSDEW = 0.0 + QSEVA = 0.0 + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + END IF + +! convert units (mm/s -> m/s) + + !PONDING: melting water from snow when there is no layer + QINSUR = (PONDING+PONDING1+PONDING2)/DT * 0.001 +! QINSUR = PONDING/DT * 0.001 + + IF(ISNOW == 0) THEN + QINSUR = QINSUR+(QSNBOT + QSDEW + QRAIN) * 0.001 + ELSE + QINSUR = QINSUR+(QSNBOT + QSDEW) * 0.001 + ENDIF + + QSEVA = QSEVA * 0.001 + + DO IZ = 1, parameters%NROOT + ETRANI(IZ) = ETRAN * BTRANI(IZ) * 0.001 + ENDDO + +!#ifdef WRF_HYDRO +! QINSUR = QINSUR+sfcheadrt/DT*0.001 !sfcheadrt units (m) +!#endif + +! irrigation: call flood irrigation-pvk + IF((CROPLU .EQV. .TRUE.) .AND. (IRAMTFI .GT. 0.0))THEN + ! call flood irrigation and add to QINSUR + CALL FLOOD_IRRIGATION(parameters,NSOIL,DT,SH2O,SMC,SICE,FIFAC,& !in + IRAMTFI,IRFIRATE) !inout + QINSUR = QINSUR + (IRFIRATE/DT) ![m/s] + END IF +! irrigation: call micro irrigation-pvk + IF((CROPLU .EQV. .TRUE.) .AND. (IRAMTMI .GT. 0.0))THEN + ! call micro irrigation, assuming we implement drip in first layer + ! of the Noah-MP. Change layer 1 moisture wrt to MI rate-pvk + CALL MICRO_IRRIGATION(parameters,NSOIL,DT,SH2O,SMC,SICE,MIFAC, & !in + IRAMTMI,IRMIRATE) !inout + SH2O(1) = SH2O(1) + (IRMIRATE/(-1*ZSOIL(1))) + END IF + +! lake/soil water balances + + IF (IST == 2) THEN ! lake + RUNSRF = 0. + IF(WSLAKE >= WSLMAX) RUNSRF = QINSUR*1000. !mm/s + WSLAKE = WSLAKE + (QINSUR-QSEVA)*1000.*DT -RUNSRF*DT !mm + ELSE ! soil + CALL SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in + QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC , & !in + SH2O ,SMC ,ZWT ,VEGTYP , & !inout + SMCWTD, DEEPRECH , & !inout + RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out + + IF(OPT_RUN == 1) THEN + CALL GROUNDWATER (parameters,NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in + STC ,WCND ,FCRMAX ,ILOC ,JLOC , & !in + SH2O ,ZWT ,WA ,WT , & !inout + QIN ,QDIS ) !out + RUNSUB = QDIS !mm/s + END IF + + IF(OPT_RUN == 3 .or. OPT_RUN == 4) THEN + RUNSUB = RUNSUB + QDRAIN !mm/s + END IF + + DO IZ = 1,NSOIL + SMC(IZ) = SH2O(IZ) + SICE(IZ) + ENDDO + + IF(OPT_RUN == 5) THEN + CALL SHALLOWWATERTABLE (parameters,NSNOW ,NSOIL, ZSOIL, DT , & !in + DZSNSO ,SMCEQ ,ILOC , JLOC , & !in + SMC ,ZWT ,SMCWTD ,RECH, QDRAIN ) !inout + + SH2O(NSOIL) = SMC(NSOIL) - SICE(NSOIL) + RUNSUB = RUNSUB + QDRAIN !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here + WA = 0. + ENDIF + + ENDIF + + RUNSUB = RUNSUB + SNOFLOW !mm/s + + END SUBROUTINE WATER + +!== begin canwater ================================================================================= + + SUBROUTINE CANWATER (parameters,VEGTYP ,DT , & !in + FCEV ,FCTR ,ELAI , & !in + ESAI ,TG ,FVEG ,ILOC , JLOC , & !in + BDFALL ,FROZEN_CANOPY , & !in + CANLIQ ,CANICE ,TV , & !inout + CMC ,ECAN ,ETRAN , & !out + FWET ) !out + +! ------------------------ code history ------------------------------ +! canopy hydrology +! -------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: VEGTYP !vegetation type + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: FCEV !canopy evaporation (w/m2) [+ = to atm] + REAL, INTENT(IN) :: FCTR !transpiration (w/m2) [+ = to atm] + REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow + REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) + LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway + REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 + +! input & output + REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + REAL, INTENT(INOUT) :: TV !vegetation temperature (k) + +! output + REAL, INTENT(OUT) :: CMC !intercepted water (mm) + REAL, INTENT(OUT) :: ECAN !evaporation of intercepted water (mm/s) [+] + REAL, INTENT(OUT) :: ETRAN !transpiration rate (mm/s) [+] + REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + REAL :: MAXSNO !canopy capacity for snow interception (mm) + REAL :: MAXLIQ !canopy capacity for rain interception (mm) + REAL :: QEVAC !evaporation rate (mm/s) + REAL :: QDEWC !dew rate (mm/s) + REAL :: QFROC !frost rate (mm/s) + REAL :: QSUBC !sublimation rate (mm/s) + REAL :: QMELTC !melting rate of canopy snow (mm/s) + REAL :: QFRZC !refreezing rate of canopy liquid water (mm/s) + REAL :: CANMAS !total canopy mass (kg/m2) +! -------------------------------------------------------------------- +! initialization + + ECAN = 0.0 + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + MAXLIQ = parameters%CH2OP * (ELAI+ ESAI) + +! evaporation, transpiration, and dew + + IF (.NOT.FROZEN_CANOPY) THEN ! Barlage: change to frozen_canopy + ETRAN = MAX( FCTR/HVAP, 0. ) + QEVAC = MAX( FCEV/HVAP, 0. ) + QDEWC = ABS( MIN( FCEV/HVAP, 0. ) ) + QSUBC = 0. + QFROC = 0. + ELSE + ETRAN = MAX( FCTR/HSUB, 0. ) + QEVAC = 0. + QDEWC = 0. + QSUBC = MAX( FCEV/HSUB, 0. ) + QFROC = ABS( MIN( FCEV/HSUB, 0. ) ) + ENDIF + +! canopy water balance. for convenience allow dew to bring CANLIQ above +! maxh2o or else would have to re-adjust drip + + QEVAC = MIN(CANLIQ/DT,QEVAC) + CANLIQ=MAX(0.,CANLIQ+(QDEWC-QEVAC)*DT) + IF(CANLIQ <= 1.E-06) CANLIQ = 0.0 + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) + + QSUBC = MIN(CANICE/DT,QSUBC) + CANICE= MAX(0.,CANICE + (QFROC-QSUBC)*DT) + IF(CANICE.LE.1.E-6) CANICE = 0. + +! wetted fraction of canopy + + IF(CANICE.GT.0.) THEN + FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06) + ELSE + FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06) + ENDIF + FWET = MIN(FWET, 1.) ** 0.667 + +! phase change + + QMELTC = 0. + QFRZC = 0. + + IF(CANICE.GT.1.E-6.AND.TV.GT.TFRZ) THEN + QMELTC = MIN(CANICE/DT,(TV-TFRZ)*CICE*CANICE/DENICE/(DT*HFUS)) + CANICE = MAX(0.,CANICE - QMELTC*DT) + CANLIQ = MAX(0.,CANLIQ + QMELTC*DT) + TV = FWET*TFRZ + (1.-FWET)*TV + ENDIF + + IF(CANLIQ.GT.1.E-6.AND.TV.LT.TFRZ) THEN + QFRZC = MIN(CANLIQ/DT,(TFRZ-TV)*CWAT*CANLIQ/DENH2O/(DT*HFUS)) + CANLIQ = MAX(0.,CANLIQ - QFRZC*DT) + CANICE = MAX(0.,CANICE + QFRZC*DT) + TV = FWET*TFRZ + (1.-FWET)*TV + ENDIF + +! total canopy water + + CMC = CANLIQ + CANICE + +! total canopy evaporation + + ECAN = QEVAC + QSUBC - QDEWC - QFROC + + END SUBROUTINE CANWATER + +!== begin snowwater ================================================================================ + + SUBROUTINE SNOWWATER (parameters,NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in + SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , & !in + QRAIN ,FICEOLD,ILOC ,JLOC , & !in + ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout + SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , & !inout + QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] + REAL, INTENT(IN) :: DT !time step (s) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) + REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: FICEOLD!ice fraction at last timestep + +! input & output + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !depth of snow/soil layer-bottom + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] + +! output + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + REAL, INTENT(OUT) :: SNOFLOW!glacier flow [mm] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 + +! local + INTEGER :: IZ,i + REAL :: BDSNOW !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + SNOFLOW = 0.0 + PONDING1 = 0.0 + PONDING2 = 0.0 + + CALL SNOWFALL (parameters,NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN, & !in + SFCTMP ,ILOC ,JLOC , & !in + ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout + SNLIQ ,SNEQV ) !inout + +! MB: do each if block separately + + IF(ISNOW < 0) & ! when multi-layer + CALL COMPACT (parameters,NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in + SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC ,& !in + ISNOW ,DZSNSO ,ZSNSO ) !inout + + IF(ISNOW < 0) & !when multi-layer + CALL COMBINE (parameters,NSNOW ,NSOIL ,ILOC ,JLOC , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1 ,PONDING2) !out + + IF(ISNOW < 0) & !when multi-layer + CALL DIVIDE (parameters,NSNOW ,NSOIL , & !in + ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout + + CALL SNOWH2O (parameters,NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + QRAIN ,ILOC ,JLOC , & !in + ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout + SNLIQ ,SH2O ,SICE ,STC , & !inout + QSNBOT ,PONDING1 ,PONDING2) !out + +!set empty snow layers to zero + + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo + +!to obtain equilibrium state of snow in glacier region + + IF(SNEQV > 5000.) THEN ! 5000 mm -> maximum water depth + BDSNOW = SNICE(0) / DZSNSO(0) + SNOFLOW = (SNEQV - 5000.) + SNICE(0) = SNICE(0) - SNOFLOW + DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW + SNOFLOW = SNOFLOW / DT + END IF + +! sum up snow mass for layered snow + + IF(ISNOW < 0) THEN ! MB: only do for multi-layer + SNEQV = 0. + DO IZ = ISNOW+1,0 + SNEQV = SNEQV + SNICE(IZ) + SNLIQ(IZ) + ENDDO + END IF + +! Reset ZSNSO and layer thinkness DZSNSO + + DO IZ = ISNOW+1, 0 + DZSNSO(IZ) = -DZSNSO(IZ) + END DO + + DZSNSO(1) = ZSOIL(1) + DO IZ = 2,NSOIL + DZSNSO(IZ) = (ZSOIL(IZ) - ZSOIL(IZ-1)) + END DO + + ZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + DO IZ = ISNOW+2 ,NSOIL + ZSNSO(IZ) = ZSNSO(IZ-1) + DZSNSO(IZ) + ENDDO + + DO IZ = ISNOW+1 ,NSOIL + DZSNSO(IZ) = -DZSNSO(IZ) + END DO + + END SUBROUTINE SNOWWATER + +!== begin snowfall ================================================================================= + + SUBROUTINE SNOWFALL (parameters,NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , & !in + SFCTMP ,ILOC ,JLOC , & !in + ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout + SNLIQ ,SNEQV ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + +! input and output + + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: SNOWH !snow depth [m] + REAL, INTENT(INOUT) :: SNEQV !swow water equivalent [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !thickness of snow/soil layers (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + +! local + + INTEGER :: NEWNODE ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + NEWNODE = 0 + +! shallow snow / no layer + + IF(ISNOW == 0 .and. QSNOW > 0.) THEN + SNOWH = SNOWH + SNOWHIN * DT + SNEQV = SNEQV + QSNOW * DT + END IF + +! creating a new layer + + IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.025) THEN !MB: change limit +! IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.05) THEN + ISNOW = -1 + NEWNODE = 1 + DZSNSO(0)= SNOWH + SNOWH = 0. + STC(0) = MIN(273.16, SFCTMP) ! temporary setup + SNICE(0) = SNEQV + SNLIQ(0) = 0. + END IF + +! snow with layers + + IF(ISNOW < 0 .AND. NEWNODE == 0 .AND. QSNOW > 0.) then + SNICE(ISNOW+1) = SNICE(ISNOW+1) + QSNOW * DT + DZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + SNOWHIN * DT + ENDIF + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWFALL + +!== begin combine ================================================================================== + + SUBROUTINE COMBINE (parameters,NSNOW ,NSOIL ,ILOC ,JLOC , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1 ,PONDING2) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + +! input and output + + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] + REAL, INTENT(INOUT) :: sneqv !snow water equivalent [m] + REAL, INTENT(INOUT) :: snowh !snow depth [m] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 + +! local variables: + + INTEGER :: I,J,K,L ! node indices + INTEGER :: ISNOW_OLD ! number of top snow layer + INTEGER :: MSSI ! node index + INTEGER :: NEIBOR ! adjacent node selected for combination + REAL :: ZWICE ! total ice mass in snow + REAL :: ZWLIQ ! total liquid water in snow + + REAL :: DZMIN(3) ! minimum of top snow layer +! DATA DZMIN /0.045, 0.05, 0.2/ + DATA DZMIN /0.025, 0.025, 0.1/ ! MB: change limit +!----------------------------------------------------------------------- + + ISNOW_OLD = ISNOW + + DO J = ISNOW_OLD+1,0 + IF (SNICE(J) <= .1) THEN + IF(J /= 0) THEN + SNLIQ(J+1) = SNLIQ(J+1) + SNLIQ(J) + SNICE(J+1) = SNICE(J+1) + SNICE(J) + DZSNSO(J+1) = DZSNSO(J+1) + DZSNSO(J) + ELSE + IF (ISNOW_OLD < -1) THEN ! MB/KM: change to ISNOW + SNLIQ(J-1) = SNLIQ(J-1) + SNLIQ(J) + SNICE(J-1) = SNICE(J-1) + SNICE(J) + DZSNSO(J-1) = DZSNSO(J-1) + DZSNSO(J) + ELSE + IF(SNICE(J) >= 0.) THEN + PONDING1 = SNLIQ(J) ! ISNOW WILL GET SET TO ZERO BELOW; PONDING1 WILL GET + SNEQV = SNICE(J) ! ADDED TO PONDING FROM PHASECHANGE PONDING SHOULD BE + SNOWH = DZSNSO(J) ! ZERO HERE BECAUSE IT WAS CALCULATED FOR THIN SNOW + ELSE ! SNICE OVER-SUBLIMATED EARLIER + PONDING1 = SNLIQ(J) + SNICE(J) + IF(PONDING1 < 0.) THEN ! IF SNICE AND SNLIQ SUBLIMATES REMOVE FROM SOIL + SICE(1) = MAX(0.0,SICE(1)+PONDING1/(DZSNSO(1)*1000.)) + PONDING1 = 0.0 + END IF + SNEQV = 0.0 + SNOWH = 0.0 + END IF + SNLIQ(J) = 0.0 + SNICE(J) = 0.0 + DZSNSO(J) = 0.0 + ENDIF +! SH2O(1) = SH2O(1)+SNLIQ(J)/(DZSNSO(1)*1000.) +! SICE(1) = SICE(1)+SNICE(J)/(DZSNSO(1)*1000.) + ENDIF + + ! shift all elements above this down by one. + IF (J > ISNOW+1 .AND. ISNOW < -1) THEN + DO I = J, ISNOW+2, -1 + STC(I) = STC(I-1) + SNLIQ(I) = SNLIQ(I-1) + SNICE(I) = SNICE(I-1) + DZSNSO(I)= DZSNSO(I-1) + END DO + END IF + ISNOW = ISNOW + 1 + END IF + END DO + +! to conserve water in case of too large surface sublimation + + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + + IF(ISNOW ==0) RETURN ! MB: get out if no longer multi-layer + + SNEQV = 0. + SNOWH = 0. + ZWICE = 0. + ZWLIQ = 0. + + DO J = ISNOW+1,0 + SNEQV = SNEQV + SNICE(J) + SNLIQ(J) + SNOWH = SNOWH + DZSNSO(J) + ZWICE = ZWICE + SNICE(J) + ZWLIQ = ZWLIQ + SNLIQ(J) + END DO + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + + IF (SNOWH < 0.025 .AND. ISNOW < 0 ) THEN ! MB: change limit +! IF (SNOWH < 0.05 .AND. ISNOW < 0 ) THEN + ISNOW = 0 + SNEQV = ZWICE + PONDING2 = ZWLIQ ! LIMIT OF ISNOW < 0 MEANS INPUT PONDING + IF(SNEQV <= 0.) SNOWH = 0. ! SHOULD BE ZERO; SEE ABOVE + END IF + +! IF (SNOWH < 0.05 ) THEN +! ISNOW = 0 +! SNEQV = ZWICE +! SH2O(1) = SH2O(1) + ZWLIQ / (DZSNSO(1) * 1000.) +! IF(SNEQV <= 0.) SNOWH = 0. +! END IF + +! check the snow depth - snow layers combined + + IF (ISNOW < -1) THEN + + ISNOW_OLD = ISNOW + MSSI = 1 + + DO I = ISNOW_OLD+1,0 + IF (DZSNSO(I) < DZMIN(MSSI)) THEN + + IF (I == ISNOW+1) THEN + NEIBOR = I + 1 + ELSE IF (I == 0) THEN + NEIBOR = I - 1 + ELSE + NEIBOR = I + 1 + IF ((DZSNSO(I-1)+DZSNSO(I)) < (DZSNSO(I+1)+DZSNSO(I))) NEIBOR = I-1 + END IF + + ! Node l and j are combined and stored as node j. + IF (NEIBOR > I) THEN + J = NEIBOR + L = I + ELSE + J = I + L = NEIBOR + END IF + + CALL COMBO (parameters,DZSNSO(J), SNLIQ(J), SNICE(J), & + STC(J), DZSNSO(L), SNLIQ(L), SNICE(L), STC(L) ) + + ! Now shift all elements above this down one. + IF (J-1 > ISNOW+1) THEN + DO K = J-1, ISNOW+2, -1 + STC(K) = STC(K-1) + SNICE(K) = SNICE(K-1) + SNLIQ(K) = SNLIQ(K-1) + DZSNSO(K) = DZSNSO(K-1) + END DO + END IF + + ! Decrease the number of snow layers + ISNOW = ISNOW + 1 + IF (ISNOW >= -1) EXIT + ELSE + + ! The layer thickness is greater than the prescribed minimum value + MSSI = MSSI + 1 + + END IF + END DO + + END IF + + END SUBROUTINE COMBINE + +!== begin divide =================================================================================== + + SUBROUTINE DIVIDE (parameters,NSNOW ,NSOIL , & !in + ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] + +! input and output + + INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] + +! local variables: + + INTEGER :: J !indices + INTEGER :: MSNO !number of layer (top) to MSNO (bot) + REAL :: DRR !thickness of the combined [m] + REAL, DIMENSION( 1:NSNOW) :: DZ !snow layer thickness [m] + REAL, DIMENSION( 1:NSNOW) :: SWICE !partial volume of ice [m3/m3] + REAL, DIMENSION( 1:NSNOW) :: SWLIQ !partial volume of liquid water [m3/m3] + REAL, DIMENSION( 1:NSNOW) :: TSNO !node temperature [k] + REAL :: ZWICE !temporary + REAL :: ZWLIQ !temporary + REAL :: PROPOR!temporary + REAL :: DTDZ !temporary +! ---------------------------------------------------------------------- + + DO J = 1,NSNOW + IF (J <= ABS(ISNOW)) THEN + DZ(J) = DZSNSO(J+ISNOW) + SWICE(J) = SNICE(J+ISNOW) + SWLIQ(J) = SNLIQ(J+ISNOW) + TSNO(J) = STC(J+ISNOW) + END IF + END DO + + MSNO = ABS(ISNOW) + + IF (MSNO == 1) THEN + ! Specify a new snow layer + IF (DZ(1) > 0.05) THEN + MSNO = 2 + DZ(1) = DZ(1)/2. + SWICE(1) = SWICE(1)/2. + SWLIQ(1) = SWLIQ(1)/2. + DZ(2) = DZ(1) + SWICE(2) = SWICE(1) + SWLIQ(2) = SWLIQ(1) + TSNO(2) = TSNO(1) + END IF + END IF + + IF (MSNO > 1) THEN + IF (DZ(1) > 0.05) THEN + DRR = DZ(1) - 0.05 + PROPOR = DRR/DZ(1) + ZWICE = PROPOR*SWICE(1) + ZWLIQ = PROPOR*SWLIQ(1) + PROPOR = 0.05/DZ(1) + SWICE(1) = PROPOR*SWICE(1) + SWLIQ(1) = PROPOR*SWLIQ(1) + DZ(1) = 0.05 + + CALL COMBO (parameters,DZ(2), SWLIQ(2), SWICE(2), TSNO(2), DRR, & + ZWLIQ, ZWICE, TSNO(1)) + + ! subdivide a new layer + IF (MSNO <= 2 .AND. DZ(2) > 0.20) THEN ! MB: change limit +! IF (MSNO <= 2 .AND. DZ(2) > 0.10) THEN + MSNO = 3 + DTDZ = (TSNO(1) - TSNO(2))/((DZ(1)+DZ(2))/2.) + DZ(2) = DZ(2)/2. + SWICE(2) = SWICE(2)/2. + SWLIQ(2) = SWLIQ(2)/2. + DZ(3) = DZ(2) + SWICE(3) = SWICE(2) + SWLIQ(3) = SWLIQ(2) + TSNO(3) = TSNO(2) - DTDZ*DZ(2)/2. + IF (TSNO(3) >= TFRZ) THEN + TSNO(3) = TSNO(2) + ELSE + TSNO(2) = TSNO(2) + DTDZ*DZ(2)/2. + ENDIF + + END IF + END IF + END IF + + IF (MSNO > 2) THEN + IF (DZ(2) > 0.2) THEN + DRR = DZ(2) - 0.2 + PROPOR = DRR/DZ(2) + ZWICE = PROPOR*SWICE(2) + ZWLIQ = PROPOR*SWLIQ(2) + PROPOR = 0.2/DZ(2) + SWICE(2) = PROPOR*SWICE(2) + SWLIQ(2) = PROPOR*SWLIQ(2) + DZ(2) = 0.2 + CALL COMBO (parameters,DZ(3), SWLIQ(3), SWICE(3), TSNO(3), DRR, & + ZWLIQ, ZWICE, TSNO(2)) + END IF + END IF + + ISNOW = -MSNO + + DO J = ISNOW+1,0 + DZSNSO(J) = DZ(J-ISNOW) + SNICE(J) = SWICE(J-ISNOW) + SNLIQ(J) = SWLIQ(J-ISNOW) + STC(J) = TSNO(J-ISNOW) + END DO + + +! DO J = ISNOW+1,NSOIL +! WRITE(*,'(I5,7F10.3)') J, DZSNSO(J), SNICE(J), SNLIQ(J),STC(J) +! END DO + + END SUBROUTINE DIVIDE + +!== begin combo ==================================================================================== + + SUBROUTINE COMBO(parameters,DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + type (noahmp_parameters), intent(in) :: parameters + REAL, INTENT(IN) :: DZ2 !nodal thickness of 2 elements being combined [m] + REAL, INTENT(IN) :: WLIQ2 !liquid water of element 2 [kg/m2] + REAL, INTENT(IN) :: WICE2 !ice of element 2 [kg/m2] + REAL, INTENT(IN) :: T2 !nodal temperature of element 2 [k] + REAL, INTENT(INOUT) :: DZ !nodal thickness of 1 elements being combined [m] + REAL, INTENT(INOUT) :: WLIQ !liquid water of element 1 + REAL, INTENT(INOUT) :: WICE !ice of element 1 [kg/m2] + REAL, INTENT(INOUT) :: T !node temperature of element 1 [k] + +! local + + REAL :: DZC !total thickness of nodes 1 and 2 (DZC=DZ+DZ2). + REAL :: WLIQC !combined liquid water [kg/m2] + REAL :: WICEC !combined ice [kg/m2] + REAL :: TC !combined node temperature [k] + REAL :: H !enthalpy of element 1 [J/m2] + REAL :: H2 !enthalpy of element 2 [J/m2] + REAL :: HC !temporary + +!----------------------------------------------------------------------- + + DZC = DZ+DZ2 + WICEC = (WICE+WICE2) + WLIQC = (WLIQ+WLIQ2) + H = (CICE*WICE+CWAT*WLIQ) * (T-TFRZ)+HFUS*WLIQ + H2= (CICE*WICE2+CWAT*WLIQ2) * (T2-TFRZ)+HFUS*WLIQ2 + + HC = H + H2 + IF(HC < 0.)THEN + TC = TFRZ + HC/(CICE*WICEC + CWAT*WLIQC) + ELSE IF (HC.LE.HFUS*WLIQC) THEN + TC = TFRZ + ELSE + TC = TFRZ + (HC - HFUS*WLIQC) / (CICE*WICEC + CWAT*WLIQC) + END IF + + DZ = DZC + WICE = WICEC + WLIQ = WLIQC + T = TC + + END SUBROUTINE COMBO + +!== begin compact ================================================================================== + + SUBROUTINE COMPACT (parameters,NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in + SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC , & !in + ISNOW ,DZSNSO ,ZSNSO ) !inout +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] + REAL, INTENT(IN) :: DT !time step (sec) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil srf + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep + +! input and output + INTEGER, INTENT(INOUT) :: ISNOW ! actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO ! depth of snow/soil layer-bottom + +! local + REAL, PARAMETER :: C2 = 21.e-3 ![m3/kg] ! default 21.e-3 + REAL, PARAMETER :: C3 = 2.5e-6 ![1/s] + REAL, PARAMETER :: C4 = 0.04 ![1/k] + REAL, PARAMETER :: C5 = 2.0 ! + REAL, PARAMETER :: DM = 100.0 !upper Limit on destructive metamorphism compaction [kg/m3] + REAL, PARAMETER :: ETA0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to Anderson, it is between 0.52e6~1.38e6 + REAL :: BURDEN !pressure of overlying snow [kg/m2] + REAL :: DDZ1 !rate of settling of snow pack due to destructive metamorphism. + REAL :: DDZ2 !rate of compaction of snow pack due to overburden. + REAL :: DDZ3 !rate of compaction of snow pack due to melt [1/s] + REAL :: DEXPF !EXPF=exp(-c4*(273.15-STC)). + REAL :: TD !STC - TFRZ [K] + REAL :: PDZDTC !nodal rate of change in fractional-thickness due to compaction [fraction/s] + REAL :: VOID !void (1 - SNICE - SNLIQ) + REAL :: WX !water mass (ice + liquid) [kg/m2] + REAL :: BI !partial density of ice [kg/m3] + REAL, DIMENSION(-NSNOW+1:0) :: FICE !fraction of ice at current time step + + INTEGER :: J + +! ---------------------------------------------------------------------- + BURDEN = 0.0 + + DO J = ISNOW+1, 0 + + WX = SNICE(J) + SNLIQ(J) + FICE(J) = SNICE(J) / WX + VOID = 1. - (SNICE(J)/DENICE + SNLIQ(J)/DENH2O) / DZSNSO(J) + + ! Allow compaction only for non-saturated node and higher ice lens node. + IF (VOID > 0.001 .AND. SNICE(J) > 0.1) THEN + BI = SNICE(J) / DZSNSO(J) + TD = MAX(0.,TFRZ-STC(J)) + DEXPF = EXP(-C4*TD) + + ! Settling as a result of destructive metamorphism + + DDZ1 = -C3*DEXPF + + IF (BI > DM) DDZ1 = DDZ1*EXP(-46.0E-3*(BI-DM)) + + ! Liquid water term + + IF (SNLIQ(J) > 0.01*DZSNSO(J)) DDZ1=DDZ1*C5 + + ! Compaction due to overburden + + DDZ2 = -(BURDEN+0.5*WX)*EXP(-0.08*TD-C2*BI)/ETA0 ! 0.5*WX -> self-burden + + ! Compaction occurring during melt + + IF (IMELT(J) == 1) THEN + DDZ3 = MAX(0.,(FICEOLD(J) - FICE(J))/MAX(1.E-6,FICEOLD(J))) + DDZ3 = - DDZ3/DT ! sometimes too large + ELSE + DDZ3 = 0. + END IF + + ! Time rate of fractional change in DZ (units of s-1) + + PDZDTC = (DDZ1 + DDZ2 + DDZ3)*DT + PDZDTC = MAX(-0.5,PDZDTC) + + ! The change in DZ due to compaction + + DZSNSO(J) = DZSNSO(J)*(1.+PDZDTC) + DZSNSO(J) = max(DZSNSO(J),SNICE(J)/DENICE + SNLIQ(J)/DENH2O) + END IF + + ! Pressure of overlying snow + + BURDEN = BURDEN + WX + + END DO + + END SUBROUTINE COMPACT + +!== begin snowh2o ================================================================================== + + SUBROUTINE SNOWH2O (parameters,NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + QRAIN ,ILOC ,JLOC , & !in + ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout + SNLIQ ,SH2O ,SICE ,STC , & !inout + QSNBOT ,PONDING1 ,PONDING2) !out +! ---------------------------------------------------------------------- +! Renew the mass of ice lens (SNICE) and liquid (SNLIQ) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers[=3] + INTEGER, INTENT(IN) :: NSOIL !No. of soil layers[=4] + REAL, INTENT(IN) :: DT !time step + REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] + +! output + + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + +! input and output + + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer depth [m] + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + +! local variables: + + INTEGER :: J !do loop/array indices + REAL :: QIN !water flow into the element (mm/s) + REAL :: QOUT !water flow out of the element (mm/s) + REAL :: WGDIF !ice mass after minus sublimation + REAL, DIMENSION(-NSNOW+1:0) :: VOL_LIQ !partial volume of liquid water in layer + REAL, DIMENSION(-NSNOW+1:0) :: VOL_ICE !partial volume of ice lens in layer + REAL, DIMENSION(-NSNOW+1:0) :: EPORE !effective porosity = porosity - VOL_ICE + REAL :: PROPOR, TEMP + REAL :: PONDING1, PONDING2 + REAL, PARAMETER :: max_liq_mass_fraction = 0.4 +! ---------------------------------------------------------------------- + +!for the case when SNEQV becomes '0' after 'COMBINE' + + IF(SNEQV == 0.) THEN + SICE(1) = SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.) ! Barlage: SH2O->SICE v3.6 + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + END IF + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. To conserve water, +! excessive sublimation is used to reduce soil water. Smaller time steps would tend +! to aviod this problem. + + IF(ISNOW == 0 .and. SNEQV > 0.) THEN + TEMP = SNEQV + SNEQV = SNEQV - QSNSUB*DT + QSNFRO*DT + PROPOR = SNEQV/TEMP + SNOWH = MAX(0.,PROPOR * SNOWH) + SNOWH = MIN(MAX(SNOWH,SNEQV/500.0),SNEQV/50.0) ! limit adjustment to a reasonable density + + IF(SNEQV < 0.) THEN + SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.) + SNEQV = 0. + SNOWH = 0. + END IF + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + END IF + + IF(SNOWH <= 1.E-8 .OR. SNEQV <= 1.E-6) THEN + SNOWH = 0.0 + SNEQV = 0.0 + END IF + +! for deep snow + + IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references + + WGDIF = SNICE(ISNOW+1) - QSNSUB*DT + QSNFRO*DT + SNICE(ISNOW+1) = WGDIF + IF (WGDIF < 1.e-6 .and. ISNOW <0) THEN + CALL COMBINE (parameters,NSNOW ,NSOIL ,ILOC, JLOC , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1, PONDING2 ) !out + ENDIF + !KWM: Subroutine COMBINE can change ISNOW to make it 0 again? + IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references + SNLIQ(ISNOW+1) = SNLIQ(ISNOW+1) + QRAIN * DT + SNLIQ(ISNOW+1) = MAX(0., SNLIQ(ISNOW+1)) + ENDIF + + ENDIF !KWM -- Can the ENDIF be moved toward the end of the subroutine (Just set QSNBOT=0)? + +! Porosity and partial volume + + DO J = ISNOW+1, 0 + VOL_ICE(J) = MIN(1., SNICE(J)/(DZSNSO(J)*DENICE)) + EPORE(J) = 1. - VOL_ICE(J) + END DO + + QIN = 0. + QOUT = 0. + + DO J = ISNOW+1, 0 + SNLIQ(J) = SNLIQ(J) + QIN + VOL_LIQ(J) = SNLIQ(J)/(DZSNSO(J)*DENH2O) + QOUT = MAX(0.,(VOL_LIQ(J)-parameters%SSI*EPORE(J))*DZSNSO(J)) + IF(J == 0) THEN + QOUT = MAX((VOL_LIQ(J)- EPORE(J))*DZSNSO(J) , parameters%SNOW_RET_FAC*DT*QOUT) + END IF + QOUT = QOUT*DENH2O + SNLIQ(J) = SNLIQ(J) - QOUT + IF((SNLIQ(J)/(SNICE(J)+SNLIQ(J))) > max_liq_mass_fraction) THEN + QOUT = QOUT + (SNLIQ(J) - max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*SNICE(J)) + SNLIQ(J) = max_liq_mass_fraction/(1.0 - max_liq_mass_fraction)*SNICE(J) + ENDIF + QIN = QOUT + END DO + + DO J = ISNOW+1, 0 + DZSNSO(J) = MAX(DZSNSO(J),SNLIQ(J)/DENH2O + SNICE(J)/DENICE) + END DO + +! Liquid water from snow bottom to soil + + QSNBOT = QOUT / DT ! mm/s + + END SUBROUTINE SNOWH2O + +!== begin soilwater ================================================================================ + + SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in + QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC, & !in + SH2O ,SMC ,ZWT ,VEGTYP ,& !inout + SMCWTD, DEEPRECH ,& !inout + RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out + +! ---------------------------------------------------------------------- +! calculate surface runoff and soil moisture. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + REAL, INTENT(IN) :: DT !time step (sec) + REAL, INTENT(IN) :: QINSUR !water input on soil surface [mm/s] + REAL, INTENT(IN) :: QSEVA !evap from soil surface [mm/s] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI !evapotranspiration from soil layers [mm/s] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] + + INTEGER, INTENT(IN) :: VEGTYP + +! input & output + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] + REAL, INTENT(INOUT) :: ZWT !water table depth [m] + REAL, INTENT(INOUT) :: SMCWTD !soil moisture between bottom of the soil and the water table [m3/m3] + REAL , INTENT(INOUT) :: DEEPRECH + +! output + REAL, INTENT(OUT) :: QDRAIN !soil-bottom free drainage [mm/s] + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: RUNSUB !subsurface runoff [mm/s] + REAL, INTENT(OUT) :: FCRMAX !maximum of FCR (-) + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND !hydraulic conductivity (m/s) + +! local + INTEGER :: K,IZ !do-loop index + INTEGER :: ITER !iteration index + REAl :: DTFINE !fine time step (s) + REAL, DIMENSION(1:NSOIL) :: RHSTT !right-hand side term of the matrix + REAL, DIMENSION(1:NSOIL) :: AI !left-hand side term + REAL, DIMENSION(1:NSOIL) :: BI !left-hand side term + REAL, DIMENSION(1:NSOIL) :: CI !left-hand side term + + REAL :: FFF !runoff decay factor (m-1) + REAL :: RSBMX !baseflow coefficient [mm/s] + REAL :: PDDUM !infiltration rate at surface (m/s) + REAL :: FICE !ice fraction in frozen soil + REAL :: WPLUS !saturation excess of the total soil [m] + REAL :: RSAT !accumulation of WPLUS (saturation excess) [m] + REAL :: SICEMAX!maximum soil ice content (m3/m3) + REAL :: SH2OMIN!minimum soil liquid water content (m3/m3) + REAL :: WTSUB !sum of WCND(K)*DZSNSO(K) + REAL :: MH2O !water mass removal (mm) + REAL :: FSAT !fractional saturated area (-) + REAL, DIMENSION(1:NSOIL) :: MLIQ ! + REAL :: XS ! + REAL :: WATMIN ! + REAL :: QDRAIN_SAVE ! + REAL :: RUNSRF_SAVE ! + REAL :: EPORE !effective porosity [m3/m3] + REAL, DIMENSION(1:NSOIL) :: FCR !impermeable fraction due to frozen soil + INTEGER :: NITER !iteration times soil moisture (-) + REAL :: SMCTOT !2-m averaged soil moisture (m3/m3) + REAL :: DZTOT !2-m soil depth (m) + REAL, PARAMETER :: A = 4.0 +! ---------------------------------------------------------------------- + RUNSRF = 0.0 + PDDUM = 0.0 + RSAT = 0.0 + +! for the case when snowmelt water is too large + + DO K = 1,NSOIL + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) ) + RSAT = RSAT + MAX(0.,SH2O(K)-EPORE)*DZSNSO(K) + SH2O(K) = MIN(EPORE,SH2O(K)) + END DO + +!impermeable fraction due to frozen soil + + DO K = 1,NSOIL + FICE = MIN(1.0,SICE(K)/parameters%SMCMAX(K)) + FCR(K) = MAX(0.0,EXP(-A*(1.-FICE))- EXP(-A)) / & + (1.0 - EXP(-A)) + END DO + +! maximum soil ice content and minimum liquid water of all layers + + SICEMAX = 0.0 + FCRMAX = 0.0 + SH2OMIN = parameters%SMCMAX(1) + DO K = 1,NSOIL + IF (SICE(K) > SICEMAX) SICEMAX = SICE(K) + IF (FCR(K) > FCRMAX) FCRMAX = FCR(K) + IF (SH2O(K) < SH2OMIN) SH2OMIN = SH2O(K) + END DO + +!subsurface runoff for runoff scheme option 2 + + IF(OPT_RUN == 2) THEN + FFF = 2.0 + RSBMX = 4.0 + CALL ZWTEQ (parameters,NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) + RUNSUB = (1.0-FCRMAX) * RSBMX * EXP(-parameters%TIMEAN) * EXP(-FFF*ZWT) ! mm/s + END IF + +!surface runoff and infiltration rate using different schemes + +!jref impermable surface at urban + IF ( parameters%urban_flag ) FCR(1)= 0.95 + + IF(OPT_RUN == 1) THEN + FFF = 6.0 + FSAT = parameters%FSATMX*EXP(-0.5*FFF*(ZWT-2.0)) + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) + PDDUM = QINSUR - RUNSRF ! m/s + END IF + END IF + + IF(OPT_RUN == 5) THEN + FFF = 6.0 + FSAT = parameters%FSATMX*EXP(-0.5*FFF*MAX(-2.0-ZWT,0.)) + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) + PDDUM = QINSUR - RUNSRF ! m/s + END IF + END IF + + IF(OPT_RUN == 2) THEN + FFF = 2.0 + FSAT = parameters%FSATMX*EXP(-0.5*FFF*ZWT) + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) + PDDUM = QINSUR - RUNSRF ! m/s + END IF + END IF + + IF(OPT_RUN == 3) THEN + CALL INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in + SICEMAX,QINSUR , & !in + PDDUM ,RUNSRF ) !out + END IF + + IF(OPT_RUN == 4) THEN + SMCTOT = 0. + DZTOT = 0. + DO K = 1,NSOIL + DZTOT = DZTOT + DZSNSO(K) + SMCTOT = SMCTOT + SMC(K)/parameters%SMCMAX(K)*DZSNSO(K) + IF(DZTOT >= 2.0) EXIT + END DO + SMCTOT = SMCTOT/DZTOT + FSAT = MAX(0.01,SMCTOT) ** 4. !BATS + + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ((1.0-FCR(1))*FSAT+FCR(1)) + PDDUM = QINSUR - RUNSRF ! m/s + END IF + END IF + +! determine iteration times and finer time step + + NITER = 1 + +! IF(OPT_INF == 1) THEN !OPT_INF =2 may cause water imbalance + NITER = 3 + IF (PDDUM*DT>DZSNSO(1)*parameters%SMCMAX(1) ) THEN + NITER = NITER*2 + END IF +! END IF + + DTFINE = DT / NITER + +! solve soil moisture + + QDRAIN_SAVE = 0.0 + RUNSRF_SAVE = 0.0 + DO ITER = 1, NITER + IF(QINSUR > 0. .and. OPT_RUN == 3) THEN + CALL INFIL (parameters,NSOIL ,DTFINE ,ZSOIL ,SH2O ,SICE , & !in + SICEMAX,QINSUR , & !in + PDDUM ,RUNSRF ) !out + END IF + + CALL SRT (parameters,NSOIL ,ZSOIL ,DTFINE ,PDDUM ,ETRANI , & !in + QSEVA ,SH2O ,SMC ,ZWT ,FCR , & !in + SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , & !in + RHSTT ,AI ,BI ,CI ,QDRAIN , & !out + WCND ) !out + + CALL SSTEP (parameters,NSOIL ,NSNOW ,DTFINE ,ZSOIL ,DZSNSO , & !in + SICE ,ILOC ,JLOC ,ZWT , & !in + SH2O ,SMC ,AI ,BI ,CI , & !inout + RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout + WPLUS) !out + RSAT = RSAT + WPLUS + QDRAIN_SAVE = QDRAIN_SAVE + QDRAIN + RUNSRF_SAVE = RUNSRF_SAVE + RUNSRF + END DO + + QDRAIN = QDRAIN_SAVE/NITER + RUNSRF = RUNSRF_SAVE/NITER + + RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT ! m/s -> mm/s + QDRAIN = QDRAIN * 1000. + +!WRF_HYDRO_DJG... +!yw INFXSRT = RUNSRF * DT !mm/s -> mm + +! removal of soil water due to groundwater flow (option 2) + + IF(OPT_RUN == 2) THEN + WTSUB = 0. + DO K = 1, NSOIL + WTSUB = WTSUB + WCND(K)*DZSNSO(K) + END DO + + DO K = 1, NSOIL + MH2O = RUNSUB*DT*(WCND(K)*DZSNSO(K))/WTSUB ! mm + SH2O(K) = SH2O(K) - MH2O/(DZSNSO(K)*1000.) + END DO + END IF + +! Limit MLIQ to be greater than or equal to watmin. +! Get water needed to bring MLIQ equal WATMIN from lower layer. + + IF(OPT_RUN /= 1) THEN + DO IZ = 1, NSOIL + MLIQ(IZ) = SH2O(IZ)*DZSNSO(IZ)*1000. + END DO + + WATMIN = 0.01 ! mm + DO IZ = 1, NSOIL-1 + IF (MLIQ(IZ) .LT. 0.) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ ) = MLIQ(IZ ) + XS + MLIQ(IZ+1) = MLIQ(IZ+1) - XS + END DO + + IZ = NSOIL + IF (MLIQ(IZ) .LT. WATMIN) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ) = MLIQ(IZ) + XS + RUNSUB = RUNSUB - XS/DT + IF(OPT_RUN == 5)DEEPRECH = DEEPRECH - XS*1.E-3 + + DO IZ = 1, NSOIL + SH2O(IZ) = MLIQ(IZ) / (DZSNSO(IZ)*1000.) + END DO + END IF + + END SUBROUTINE SOILWATER + +!== begin zwteq ==================================================================================== + + SUBROUTINE ZWTEQ (parameters,NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) +! ---------------------------------------------------------------------- +! calculate equilibrium water table depth (Niu et al., 2005) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil liquid water content [m3/m3] + +! output + + REAL, INTENT(OUT) :: ZWT !water table depth [m] + +! locals + + INTEGER :: K !do-loop index + INTEGER, PARAMETER :: NFINE = 100 !no. of fine soil layers of 6m soil + REAL :: WD1 !water deficit from coarse (4-L) soil moisture profile + REAL :: WD2 !water deficit from fine (100-L) soil moisture profile + REAL :: DZFINE !layer thickness of the 100-L soil layers to 6.0 m + REAL :: TEMP !temporary variable + REAL, DIMENSION(1:NFINE) :: ZFINE !layer-bottom depth of the 100-L soil layers to 6.0 m +! ---------------------------------------------------------------------- + + WD1 = 0. + DO K = 1,NSOIL + WD1 = WD1 + (parameters%SMCMAX(1)-SH2O(K)) * DZSNSO(K) ! [m] + ENDDO + + DZFINE = 3.0 * (-ZSOIL(NSOIL)) / NFINE + do K =1,NFINE + ZFINE(K) = FLOAT(K) * DZFINE + ENDDO + + ZWT = -3.*ZSOIL(NSOIL) - 0.001 ! initial value [m] + + WD2 = 0. + DO K = 1,NFINE + TEMP = 1. + (ZWT-ZFINE(K))/parameters%PSISAT(1) + WD2 = WD2 + parameters%SMCMAX(1)*(1.-TEMP**(-1./parameters%BEXP(1)))*DZFINE + IF(ABS(WD2-WD1).LE.0.01) THEN + ZWT = ZFINE(K) + EXIT + ENDIF + ENDDO + + END SUBROUTINE ZWTEQ + +!== begin infil ==================================================================================== + + SUBROUTINE INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in + SICEMAX,QINSUR , & !in + PDDUM ,RUNSRF ) !out +! -------------------------------------------------------------------------------- +! compute inflitration rate at soil surface and surface runoff +! -------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + REAL, INTENT(IN) :: DT !time step (sec) + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil liquid water content [m3/m3] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] + REAL, INTENT(IN) :: QINSUR !water input on soil surface [mm/s] + REAL, INTENT(IN) :: SICEMAX!maximum soil ice content (m3/m3) + +! outputs + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: PDDUM !infiltration rate at surface + +! locals + INTEGER :: IALP1, J, JJ, K + REAL :: VAL + REAL :: DDT + REAL :: PX + REAL :: DT1, DD, DICE + REAL :: FCR + REAL :: SUM + REAL :: ACRT + REAL :: WDF + REAL :: WCND + REAL :: SMCAV + REAL :: INFMAX + REAL, DIMENSION(1:NSOIL) :: DMAX + INTEGER, PARAMETER :: CVFRZ = 3 +! -------------------------------------------------------------------------------- + + IF (QINSUR > 0.0) THEN + DT1 = DT /86400. + SMCAV = parameters%SMCMAX(1) - parameters%SMCWLT(1) + +! maximum infiltration rate + + DMAX(1)= -ZSOIL(1) * SMCAV + DICE = -ZSOIL(1) * SICE(1) + DMAX(1)= DMAX(1)* (1.0-(SH2O(1) + SICE(1) - parameters%SMCWLT(1))/SMCAV) + + DD = DMAX(1) + + DO K = 2,NSOIL + DICE = DICE + (ZSOIL(K-1) - ZSOIL(K) ) * SICE(K) + DMAX(K) = (ZSOIL(K-1) - ZSOIL(K)) * SMCAV + DMAX(K) = DMAX(K) * (1.0-(SH2O(K) + SICE(K) - parameters%SMCWLT(K))/SMCAV) + DD = DD + DMAX(K) + END DO + + VAL = (1. - EXP ( - parameters%KDT * DT1)) + DDT = DD * VAL + PX = MAX(0.,QINSUR * DT) + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + +! impermeable fraction due to frozen soil + + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * parameters%FRZX / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** (CVFRZ - J)) / FLOAT(K) + END DO + FCR = 1. - EXP (-ACRT) * SUM + END IF + +! correction of infiltration limitation + + INFMAX = INFMAX * FCR + +! jref for urban areas +! IF ( parameters%urban_flag ) INFMAX == INFMAX * 0.05 + + CALL WDFCND2 (parameters,WDF,WCND,SH2O(1),SICEMAX,1) + INFMAX = MAX (INFMAX,WCND) + INFMAX = MIN (INFMAX,PX) + + RUNSRF= MAX(0., QINSUR - INFMAX) + PDDUM = QINSUR - RUNSRF + + END IF + + END SUBROUTINE INFIL + +!== begin srt ====================================================================================== + + SUBROUTINE SRT (parameters,NSOIL ,ZSOIL ,DT ,PDDUM ,ETRANI , & !in + QSEVA ,SH2O ,SMC ,ZWT ,FCR , & !in + SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , & !in + RHSTT ,AI ,BI ,CI ,QDRAIN , & !out + WCND ) !out +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! water diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL, INTENT(IN) :: DT + REAL, INTENT(IN) :: PDDUM + REAL, INTENT(IN) :: QSEVA + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC + REAL, INTENT(IN) :: ZWT ! water table depth [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: FCR + REAL, INTENT(IN) :: FCRMAX !maximum of FCR (-) + REAL, INTENT(IN) :: SICEMAX!maximum soil ice content (m3/m3) + REAL, INTENT(IN) :: SMCWTD !soil moisture between bottom of the soil and the water table + +! output + + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: BI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: CI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND !hydraulic conductivity (m/s) + REAL, INTENT(OUT) :: QDRAIN !bottom drainage (m/s) + +! local + INTEGER :: K + REAL, DIMENSION(1:NSOIL) :: DDZ + REAL, DIMENSION(1:NSOIL) :: DENOM + REAL, DIMENSION(1:NSOIL) :: DSMDZ + REAL, DIMENSION(1:NSOIL) :: WFLUX + REAL, DIMENSION(1:NSOIL) :: WDF + REAL, DIMENSION(1:NSOIL) :: SMX + REAL :: TEMP1 + REAL :: SMXWTD !soil moisture between bottom of the soil and water table + REAL :: SMXBOT !soil moisture below bottom to calculate flux + +! Niu and Yang (2006), J. of Hydrometeorology +! ---------------------------------------------------------------------- + + IF(OPT_INF == 1) THEN + DO K = 1, NSOIL + CALL WDFCND1 (parameters,WDF(K),WCND(K),SMC(K),FCR(K),K) + SMX(K) = SMC(K) + END DO + IF(OPT_RUN == 5)SMXWTD=SMCWTD + END IF + + IF(OPT_INF == 2) THEN + DO K = 1, NSOIL + CALL WDFCND2 (parameters,WDF(K),WCND(K),SH2O(K),SICEMAX,K) + SMX(K) = SH2O(K) + END DO + IF(OPT_RUN == 5)SMXWTD=SMCWTD*SH2O(NSOIL)/SMC(NSOIL) !same liquid fraction as in the bottom layer + END IF + + DO K = 1, NSOIL + IF(K == 1) THEN + DENOM(K) = - ZSOIL (K) + TEMP1 = - ZSOIL (K+1) + DDZ(K) = 2.0 / TEMP1 + DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1 + WFLUX(K) = WDF(K) * DSMDZ(K) + WCND(K) - PDDUM + ETRANI(K) + QSEVA + ELSE IF (K < NSOIL) THEN + DENOM(k) = (ZSOIL(K-1) - ZSOIL(K)) + TEMP1 = (ZSOIL(K-1) - ZSOIL(K+1)) + DDZ(K) = 2.0 / TEMP1 + DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1 + WFLUX(K) = WDF(K ) * DSMDZ(K ) + WCND(K ) & + - WDF(K-1) * DSMDZ(K-1) - WCND(K-1) + ETRANI(K) + ELSE + DENOM(K) = (ZSOIL(K-1) - ZSOIL(K)) + IF(OPT_RUN == 1 .or. OPT_RUN == 2) THEN + QDRAIN = 0. + END IF + IF(OPT_RUN == 3) THEN + QDRAIN = parameters%SLOPE*WCND(K) + END IF + IF(OPT_RUN == 4) THEN + QDRAIN = (1.0-FCRMAX)*WCND(K) + END IF + IF(OPT_RUN == 5) THEN !gmm new m-m&f water table dynamics formulation + TEMP1 = 2.0 * DENOM(K) + IF(ZWT < ZSOIL(NSOIL)-DENOM(NSOIL))THEN +!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom + SMXBOT = SMX(K) - (SMX(K)-SMXWTD) * DENOM(K) * 2./ (DENOM(K) + ZSOIL(K) - ZWT) + ELSE + SMXBOT = SMXWTD + ENDIF + DSMDZ(K) = 2.0 * (SMX(K) - SMXBOT) / TEMP1 + QDRAIN = WDF(K ) * DSMDZ(K ) + WCND(K ) + END IF + WFLUX(K) = -(WDF(K-1)*DSMDZ(K-1))-WCND(K-1)+ETRANI(K) + QDRAIN + END IF + END DO + + DO K = 1, NSOIL + IF(K == 1) THEN + AI(K) = 0.0 + BI(K) = WDF(K ) * DDZ(K ) / DENOM(K) + CI(K) = - BI (K) + ELSE IF (K < NSOIL) THEN + AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = - WDF(K ) * DDZ(K ) / DENOM(K) + BI(K) = - ( AI (K) + CI (K) ) + ELSE + AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = 0.0 + BI(K) = - ( AI (K) + CI (K) ) + END IF + RHSTT(K) = WFLUX(K) / (-DENOM(K)) + END DO + +! ---------------------------------------------------------------------- + END SUBROUTINE SRT + +!== begin sstep ==================================================================================== + + SUBROUTINE SSTEP (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in + SICE ,ILOC ,JLOC ,ZWT , & !in + SH2O ,SMC ,AI ,BI ,CI , & !inout + RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout + WPLUS ) !out + +! ---------------------------------------------------------------------- +! calculate/update soil moisture content values +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL ! + INTEGER, INTENT(IN) :: NSNOW ! + REAL, INTENT(IN) :: DT + REAL, INTENT(IN) :: ZWT + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m] + +!input and output + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: BI + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: CI + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT + REAL , INTENT(INOUT) :: SMCWTD + REAL , INTENT(INOUT) :: QDRAIN + REAL , INTENT(INOUT) :: DEEPRECH + +!output + REAL, INTENT(OUT) :: WPLUS !saturation excess water (m) + +!local + INTEGER :: K + REAL, DIMENSION(1:NSOIL) :: RHSTTIN + REAL, DIMENSION(1:NSOIL) :: CIIN + REAL :: STOT + REAL :: EPORE + REAL :: WMINUS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + + DO K = 1,NSOIL + RHSTT (K) = RHSTT(K) * DT + AI (K) = AI(K) * DT + BI (K) = 1. + BI(K) * DT + CI (K) = CI(K) * DT + END DO + +! copy values for input variables before calling rosr12 + + DO K = 1,NSOIL + RHSTTIN(k) = RHSTT(K) + CIIN(k) = CI(K) + END DO + +! call ROSR12 to solve the tri-diagonal matrix + + CALL ROSR12 (CI,AI,BI,CIIN,RHSTTIN,RHSTT,1,NSOIL,0) + + DO K = 1,NSOIL + SH2O(K) = SH2O(K) + CI(K) + ENDDO + +! excessive water above saturation in a layer is moved to +! its unsaturated layer like in a bucket + +!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table + IF(OPT_RUN == 5) THEN + +!update smcwtd + + IF(ZWT < ZSOIL(NSOIL)-DZSNSO(NSOIL))THEN +!accumulate qdrain to update deep water table and soil moisture later + DEEPRECH = DEEPRECH + DT * QDRAIN + ELSE + SMCWTD = SMCWTD + DT * QDRAIN / DZSNSO(NSOIL) + WPLUS = MAX((SMCWTD-parameters%SMCMAX(NSOIL)), 0.0) * DZSNSO(NSOIL) + WMINUS = MAX((1.E-4-SMCWTD), 0.0) * DZSNSO(NSOIL) + + SMCWTD = MAX( MIN(SMCWTD,parameters%SMCMAX(NSOIL)) , 1.E-4) + SH2O(NSOIL) = SH2O(NSOIL) + WPLUS/DZSNSO(NSOIL) + +!reduce fluxes at the bottom boundaries accordingly + QDRAIN = QDRAIN - WPLUS/DT + DEEPRECH = DEEPRECH - WMINUS + ENDIF + + ENDIF + + DO K = NSOIL,2,-1 + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) ) + WPLUS = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K) + SH2O(K) = MIN(EPORE,SH2O(K)) + SH2O(K-1) = SH2O(K-1) + WPLUS/DZSNSO(K-1) + END DO + + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(1) - SICE(1) ) ) + WPLUS = MAX((SH2O(1)-EPORE), 0.0) * DZSNSO(1) + SH2O(1) = MIN(EPORE,SH2O(1)) + + IF(WPLUS > 0.0) THEN + SH2O(2) = SH2O(2) + WPLUS/DZSNSO(2) + DO K = 2,NSOIL-1 + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) ) + WPLUS = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K) + SH2O(K) = MIN(EPORE,SH2O(K)) + SH2O(K+1) = SH2O(K+1) + WPLUS/DZSNSO(K+1) + END DO + + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(NSOIL) - SICE(NSOIL) ) ) + WPLUS = MAX((SH2O(NSOIL)-EPORE), 0.0) * DZSNSO(NSOIL) + SH2O(NSOIL) = MIN(EPORE,SH2O(NSOIL)) + END IF + + SMC = SH2O + SICE + + END SUBROUTINE SSTEP + +!== begin wdfcnd1 ================================================================================== + + SUBROUTINE WDFCND1 (parameters,WDF,WCND,SMC,FCR,ISOIL) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + REAL,INTENT(IN) :: SMC + REAL,INTENT(IN) :: FCR + INTEGER,INTENT(IN) :: ISOIL + +! output + REAL,INTENT(OUT) :: WCND + REAL,INTENT(OUT) :: WDF + +! local + REAL :: EXPON + REAL :: FACTR + REAL :: VKWGT +! ---------------------------------------------------------------------- + +! soil water diffusivity + + FACTR = MAX(0.01, SMC/parameters%SMCMAX(ISOIL)) + EXPON = parameters%BEXP(ISOIL) + 2.0 + WDF = parameters%DWSAT(ISOIL) * FACTR ** EXPON + WDF = WDF * (1.0 - FCR) + +! hydraulic conductivity + + EXPON = 2.0*parameters%BEXP(ISOIL) + 3.0 + WCND = parameters%DKSAT(ISOIL) * FACTR ** EXPON + WCND = WCND * (1.0 - FCR) + + END SUBROUTINE WDFCND1 + +!== begin wdfcnd2 ================================================================================== + + SUBROUTINE WDFCND2 (parameters,WDF,WCND,SMC,SICE,ISOIL) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + REAL,INTENT(IN) :: SMC + REAL,INTENT(IN) :: SICE + INTEGER,INTENT(IN) :: ISOIL + +! output + REAL,INTENT(OUT) :: WCND + REAL,INTENT(OUT) :: WDF + +! local + REAL :: EXPON + REAL :: FACTR1,FACTR2 + REAL :: VKWGT +! ---------------------------------------------------------------------- + +! soil water diffusivity + + FACTR1 = 0.05/parameters%SMCMAX(ISOIL) + FACTR2 = MAX(0.01, SMC/parameters%SMCMAX(ISOIL)) + FACTR1 = MIN(FACTR1,FACTR2) + EXPON = parameters%BEXP(ISOIL) + 2.0 + WDF = parameters%DWSAT(ISOIL) * FACTR2 ** EXPON + + IF (SICE > 0.0) THEN + VKWGT = 1./ (1. + (500.* SICE)**3.) + WDF = VKWGT * WDF + (1.-VKWGT)*parameters%DWSAT(ISOIL)*(FACTR1)**EXPON + END IF + +! hydraulic conductivity + + EXPON = 2.0*parameters%BEXP(ISOIL) + 3.0 + WCND = parameters%DKSAT(ISOIL) * FACTR2 ** EXPON + + END SUBROUTINE WDFCND2 + +!==========begin irrigation subroutines============================================================ + SUBROUTINE TRIGGER_IRRIGATION(parameters,NSOIL,ZSOIL,SH2O,FVEG, & !in + JULIAN,IRRFRA,LAI, & !in + SIFAC,MIFAC,FIFAC, & !in + IRCNTSI,IRCNTMI,IRCNTFI, & !inout + IRAMTSI,IRAMTMI,IRAMTFI) !inout + !----------------------------------------------------------------------------------------------- + ! This subroutine trigger irrigation if soil moisture less than the management allowable deficit + ! (MAD) and estimate irrigation water depth (m) using current rootzone soil moisture and field + ! capacity. There are two options here to trigger the irrigation scheme based on MAD + ! OPT_IRR = 1 -> if irrigated fraction > threshold fraction + ! OPT_IRR = 2 -> if irrigated fraction > threshold fraction and within crop season + ! OPT_IRR = 3 -> if irrigated fraction > threshold fraction and LAI > threshold LAI + ! Author: Prasanth Valayamkunnath (NCAR) + ! Date : 08/06/2020 + !----------------------------------------------------------------------------------------------- + IMPLICIT NONE + ! ---------------------------------------------------------------------------------------------- + ! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL ! number of soil layers + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL ! depth of layers from surface, [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O ! volumteric liquid water content [%] + REAL, INTENT(IN) :: FVEG ! green vegetation fraction [-] + REAL, INTENT(IN) :: IRRFRA ! irrigated area fraction [-] + REAL, INTENT(IN) :: LAI ! leaf area index [m^2/m^2] + REAL, INTENT(IN) :: JULIAN ! julian day + REAL, INTENT(IN) :: SIFAC ! sprinkler irrigation fraction [-] + REAL, INTENT(IN) :: MIFAC ! micro irrigation fraction [-] + REAL, INTENT(IN) :: FIFAC ! flood irrigation fraction [-] + ! inouts + INTEGER, INTENT(INOUT):: IRCNTSI ! irrigation event number, Sprinkler + INTEGER, INTENT(INOUT):: IRCNTMI ! irrigation event number, Micro + INTEGER, INTENT(INOUT):: IRCNTFI ! irrigation event number, Flood + REAL, INTENT(INOUT):: IRAMTSI ! irrigation water amount [m] to be applied, Sprinkler + REAL, INTENT(INOUT):: IRAMTMI ! irrigation water amount [m] to be applied, Micro + REAL, INTENT(INOUT):: IRAMTFI ! irrigation water amount [m] to be applied, Flood + ! local + REAL :: SMCAVL ! available soil moisture [m] at timestep + REAL :: SMCLIM ! maximum available moisture [m] (FC-PWD) + REAL :: SMCSAT ! maximum saturation moisture [m] (POROSITY-FC) + REAL :: IRRWATAMT ! irrigation water amount [m] + LOGICAL :: IRR_ACTIVE ! irrigation check + INTEGER :: K + !--------------------------------------------------------------------------------------------- + IRR_ACTIVE = .TRUE. + + ! check if irrigation is can be activated or not + IF(OPT_IRR .EQ. 2)THEN + ! activate irrigation if within crop season + IF ((JULIAN .LT. parameters%PLTDAY).OR.& + (JULIAN .GT. (parameters%HSDAY - parameters%IRR_HAR))) IRR_ACTIVE = .FALSE. + ELSE IF (OPT_IRR .EQ. 3) THEN + + ! activate if LAI > threshold LAI + IF(LAI .LT. parameters%IRR_LAI) IRR_ACTIVE = .FALSE. + + ELSE IF ( (OPT_IRR .GT. 3) .OR. (OPT_IRR .LT. 1)) THEN + IRR_ACTIVE = .FALSE. + END IF + + IF(IRR_ACTIVE)THEN + SMCAVL = 0.0 + SMCLIM = 0.0 + ! estimate available water and field capacity for the root zone + SMCAVL = (SH2O(1)-parameters%SMCWLT(1))*(-1)*ZSOIL(1) ! current soil water (m) + SMCLIM = (parameters%SMCREF(1)-parameters%SMCWLT(1))*(-1)*ZSOIL(1) ! available water (m) + DO K = 2, parameters%NROOT + SMCAVL = SMCAVL + (SH2O(K)-parameters%SMCWLT(K))*(ZSOIL(K-1) - ZSOIL(K)) + SMCLIM = SMCLIM + (parameters%SMCREF(K)-parameters%SMCWLT(K))*(ZSOIL(K-1) - ZSOIL(K)) + END DO + + ! check if root zone soil moisture < MAD + IF((SMCAVL/SMCLIM) .LE. parameters%IRR_MAD) THEN + ! parameters%IRR_MAD- calibratable + ! amount of water need to be added to bring soil moisture back to + ! field capacity, i.e., irrigation water amount (m) + IRRWATAMT = (SMCLIM - SMCAVL)*IRRFRA*FVEG + ! sprinkler irrigation amount (m) based on 2D SIFAC + IF((IRAMTSI .EQ. 0.0) .AND. (SIFAC .GT. 0.0) .AND. (OPT_IRRM .EQ. 0)) THEN + IRAMTSI = SIFAC*IRRWATAMT + IRCNTSI = IRCNTSI + 1 + ! sprinkler irrigation amount (m) based on namelist choice + ELSE IF ((IRAMTSI .EQ. 0.0) .AND. (OPT_IRRM .EQ. 1)) THEN + IRAMTSI = IRRWATAMT + IRCNTSI = IRCNTSI + 1 + END IF + ! micro irrigation amount (m) based on 2D MIFAC + IF((IRAMTMI .EQ. 0.0) .AND. (MIFAC .GT. 0.0) .AND. (OPT_IRRM .EQ. 0)) THEN + IRAMTMI = MIFAC*IRRWATAMT + IRCNTMI = IRCNTMI + 1 + ! micro irrigation amount (m) based on namelist choice + ELSE IF ((IRAMTMI .EQ. 0.0) .AND. (OPT_IRRM .EQ. 2)) THEN + IRAMTMI = IRRWATAMT + IRCNTMI = IRCNTMI + 1 + END IF + ! flood irrigation amount (m): Assumed to saturate top two layers and + ! third layer to FC. As water moves from one end of the field to + ! another, surface layers will be saturated. + ! flood irrigation amount (m) based on 2D FIFAC + IF((IRAMTFI .EQ. 0.0) .AND. (FIFAC .GT. 0.0) .AND. (OPT_IRRM .EQ. 0)) THEN + IRAMTFI = FIFAC*(IRRWATAMT)*(parameters%FILOSS+1) + IRCNTFI = IRCNTFI + 1 + !flood irrigation amount (m) based on namelist choice + ELSE IF((IRAMTFI .EQ. 0.0) .AND. (OPT_IRRM .EQ. 3)) THEN + IRAMTFI = (IRRWATAMT)*(parameters%FILOSS+1) + IRCNTFI = IRCNTFI + 1 + END IF + ELSE + IRRWATAMT = 0.0 + IRAMTSI = 0.0 + IRAMTMI = 0.0 + IRAMTFI = 0.0 + END IF + END IF + END SUBROUTINE TRIGGER_IRRIGATION + + !============================================================================================================ + + SUBROUTINE SPRINKLER_IRRIGATION(parameters,NSOIL,DT,SH2O,SMC,SICE,& !in + T2,WINDU,WINDV,EAIR,SIFAC, & !in + IRAMTSI,IREVPLOS,IRSIRATE) !inout + !--------------------------------------------------------------------------------------------- + ! This subroutine estimate irrigation water depth (m) based on sprinkler method defined in + ! chapter 11 of NRCS, Part 623 National Engineering Handbook. Irrigation water will be applied + ! over the canopy considering, present soil moisture, infiltration rate of the soil, and + ! evaporative loss. This subroutine will be called before CANWAT subroutine to estimate them + ! canopy water storage loss. + ! Author: Prasanth Valayamkunnath (NCAR) + ! Date : 08/06/2020 + !--------------------------------------------------------------------------------------------- + IMPLICIT NONE + ! -------------------------------------------------------------------------------------------- + ! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DT + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE + REAL, INTENT(IN) :: T2 + REAL, INTENT(IN) :: WINDU + REAL, INTENT(IN) :: WINDV + REAL, INTENT(IN) :: EAIR + REAL, INTENT(IN) :: SIFAC ! sprinkler irrigation fraction + !inouts + REAL, INTENT(INOUT) :: IRAMTSI !total irrigation water amount [m] during this schedule + REAL, INTENT(INOUT) :: IREVPLOS !loss of irrigation water to evaporation,sprinkler [m/timestep] + REAL, INTENT(INOUT) :: IRSIRATE !rate of irrigation by sprinkler [m/timestep] + ! local + REAL :: FSUR !infiltration rate [m/s] + REAL :: TEMP_RATE + REAL :: WINDSPEED + REAL :: IRRLOSS !temporary var for irr loss [%] + REAL :: ESAT1 + !------------------------------------------------------------------------------------------- + ! estimate infiltration rate based on Philips Eq. + CALL IRR_PHILIP_INFIL(parameters,SMC,SH2O,SICE,DT,NSOIL,FSUR) + ! irrigation rate of sprinkler + TEMP_RATE = parameters%SPRIR_RATE*(1/1000.)*DT/3600. !NRCS rate/time step - calibratable + IRSIRATE = MIN(FSUR*DT,IRAMTSI,TEMP_RATE) !Limit the application rate to minimum of infiltration rate + !and to the NRCS recommended rate, (m) + + ! evaporative loss from droplets: Based on Bavi et al., (2009). Evaporation + ! losses from sprinkler irrigation systems under various operating + ! conditions. Journal of Applied Sciences, 9(3), 597-600. + WINDSPEED = SQRT((WINDU**2.0)+(WINDV**2.0)) ! [m/s] + ESAT1 = 610.8*EXP((17.27*(T2-273.15))/(237.3+(T2-273.15))) ! [Pa] + IF(T2 .GT. 273.15)THEN ! Equation (3) + IRRLOSS = 4.375*(EXP(0.106*WINDSPEED))*(((ESAT1-EAIR)*0.01)**(-0.092))*((T2-273.15)**(-0.102)) ! [%] + ELSE ! Equation (4) + IRRLOSS = 4.337*(EXP(0.077*WINDSPEED))*(((ESAT1-EAIR)*0.01)**(-0.098)) ! [%] + END IF + + ! PGI Fortran compiler does not support ISNAN + IF ( isnan_lsm(IRRLOSS)) IRRLOSS=4.0 ! In case if IRRLOSS is NaN + IF ( (IRRLOSS .GT. 100.0) .OR. (IRRLOSS .LT. 0.0) ) IRRLOSS=4.0 ! In case if IRRLOSS is out of range + + ! Sprinkler water (m) for sprinkler fraction + IRSIRATE = IRSIRATE * SIFAC + IF(IRSIRATE .GE. IRAMTSI)THEN + IRSIRATE = IRAMTSI + IRAMTSI = 0.0 + ELSE + IRAMTSI = IRAMTSI - IRSIRATE + END IF + IREVPLOS = IRSIRATE*IRRLOSS*(1./100.) + IRSIRATE = IRSIRATE-IREVPLOS + END SUBROUTINE SPRINKLER_IRRIGATION + + logical function isnan_lsm(arg1) + real,intent(in) :: arg1 + isnan_lsm = (arg1 .ne. arg1) + return + end function isnan_lsm + + !============================================================================================================ + SUBROUTINE MICRO_IRRIGATION(parameters,NSOIL,DT,SH2O,SMC,SICE,MIFAC, & !in + IRAMTMI,IRMIRATE) !inout + !--------------------------------------------------------------------------------------------- + ! This subroutine estimate irrigation water depth (m) based on Micro irrigation method defined + ! in chapter 7 of NRCS, Part 623 National Engineering Handbook. Irrigation water will be applied + ! under the canopy, within first layer (at ~5 cm depth) considering current soil moisture. + ! This subroutine will be called after CANWAT. + ! Author: Prasanth Valayamkunnath (NCAR) + ! Date : 08/06/2020 + !--------------------------------------------------------------------------------------------- + IMPLICIT NONE + ! -------------------------------------------------------------------------------------------- + ! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DT + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE + REAL, INTENT(IN) :: MIFAC ! micro irrigation fraction + ! inout + REAL, INTENT(INOUT) :: IRAMTMI !irrigation water amount [m] + REAL, INTENT(INOUT) :: IRMIRATE !rate of irrigation by micro [m/time step] + ! local + REAL :: FSUR !infiltration rate [m/s] + REAL :: TEMP_RATE + !----------------------------------------------------------------------------------------------------- + ! estimate infiltration rate based on Philips Eq. + CALL IRR_PHILIP_INFIL(parameters,SMC,SH2O,SICE,DT,NSOIL,FSUR) + ! irrigation rate of micro irrigation + TEMP_RATE = parameters%MICIR_RATE*(1./1000.)*DT/3600. !NRCS rate/time step - calibratable + IRMIRATE = MIN(0.5*FSUR*DT,IRAMTMI,TEMP_RATE) !Limit the application rate to minimum + !of 0.5*infiltration rate + !and to the NRCS recommended rate, (m) + IRMIRATE = IRMIRATE * MIFAC + IF(IRMIRATE .GE. IRAMTMI)THEN + IRMIRATE = IRAMTMI + IRAMTMI = 0.0 + ELSE + IRAMTMI = IRAMTMI - IRMIRATE + END IF + END SUBROUTINE MICRO_IRRIGATION + !============================================================================================================ + + SUBROUTINE FLOOD_IRRIGATION(parameters,NSOIL,DT,SH2O,SMC,SICE,FIFAC,& !in + IRAMTFI,IRFIRATE) !inout + !--------------------------------------------------------------------------------------------- + ! This subroutine estimate irrigation water depth (m) based on surface flooding irrigation method + ! defined in chapter 4 of NRCS, Part 623 National Engineering Handbook. Irrigation water will + ! be applied on the surface based on present soil moisture and infiltration rate of the soil. + ! This subroutine will be called after CANWAT subroutine to estimate them. Flooding or overland + ! flow is based on infiltration excess! + ! Author: Prasanth Valayamkunnath (NCAR) + ! Date : 08/06/2020 + !--------------------------------------------------------------------------------------------- + IMPLICIT NONE + ! -------------------------------------------------------------------------------------------- + ! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DT + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE + REAL, INTENT(IN) :: FIFAC !fraction of grid under micro irrigation(0 to 1) + ! inout + REAL, INTENT(INOUT) :: IRAMTFI !irrigation water amount [m] + REAL, INTENT(INOUT) :: IRFIRATE !irrigation water rate by micro [m/timestep] + ! local + REAL :: FSUR !infiltration rate [m/s] + REAL :: TEMP_RATE + !----------------------------------------------------------------------------------------------------- + ! estimate infiltration rate based on Philips Eq. + CALL IRR_PHILIP_INFIL(parameters,SMC,SH2O,SICE,DT,NSOIL,FSUR) + ! irrigation rate of flood irrigation. It should be + ! greater than infiltration rate to get infiltration + ! excess runoff at the time of application + IRFIRATE = FSUR*DT*parameters%FIRTFAC !Limit the application rate to + !fac*infiltration rate + IRFIRATE = IRFIRATE * FIFAC + IF(IRFIRATE .GE. IRAMTFI)THEN + IRFIRATE = IRAMTFI + IRAMTFI = 0.0 + ELSE + IRAMTFI = IRAMTFI - IRFIRATE + END IF + + END SUBROUTINE FLOOD_IRRIGATION + + !============================================================================================================ + SUBROUTINE IRR_PHILIP_INFIL(parameters,SMC,SH2O,SICE,DT,NSOIL, & ! in + FSUR) ! out + !--------------------------------------------------------------------------------------------- + ! This function estimate infiltration rate based on Philip's two parameter equation (Eq. 2) + ! presented in Valiantzas (2010). New linearized two-parameter infiltration equation for direct + ! determination of conductivity and sorptivity, J. Hydrology. + ! Author: Prasanth Valayamkunnath (NCAR) + ! Date : 08/06/2020 + !--------------------------------------------------------------------------------------------- + IMPLICIT NONE + ! -------------------------------------------------------------------------------------------- + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !soil moisture content [m3/m3] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil water content [m3/m3] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] + REAL, INTENT(IN) :: DT !time-step (sec) + + ! outputs + REAL, INTENT(OUT):: FSUR !surface infiltration rate (m/s) + ! local variables + REAL :: WDF !soil water diffusivity (m2/s) + REAL :: WCND !soil water conductivity[m/s] + REAL :: SP !sorptivity (LT^-1/2) + REAL :: AP !intial hydraulic conductivity (m/s,L/T) + REAL :: SICEMAX + INTEGER :: ISOIL,K + !--------------------------------------------------------------------------------- + ! maximum ice fraction + SICEMAX = 0.0 + DO K = 1,NSOIL + IF (SICE(K) > SICEMAX) SICEMAX = SICE(K) + END DO + + ! estimate initial soil hydraulic conductivty and diffusivity (Ki, D(theta) in the equation) + ISOIL = 1 + CALL WDFCND2 (parameters,WDF,WCND,SH2O(ISOIL),SICEMAX,ISOIL) + + ! sorptivity based on Eq. 10b from Kutilek, Miroslav, and Jana Valentova (1986) + ! sorptivity approximations. Transport in Porous Media 1.1, 57-62. + SP = SQRT(2.0 * (parameters%SMCMAX(ISOIL) - SMC(ISOIL)) * (parameters%DWSAT(ISOIL) - WDF)) + + ! parameter A in Eq. 9 of Valiantzas (2010) is given by + AP = MIN(WCND,(2.0/3.0)*parameters%DKSAT(ISOIL)) + AP = MAX(AP,(1.0/3.0)*parameters%DKSAT(ISOIL)) + + ! maximun infiltration rate, m + FSUR = 0.5*SP*((DT)**(-0.5))+AP ! m/s + !PRINT*,'SP=',SP + !PRINT*,'AP=',AP + !PRINT*,'FSUR=',FSUR + !PRINT*,'WCND=',WCND + FSUR = MAX(0.0,FSUR) + !FSUR = MIN(WCND,FSUR) + + END SUBROUTINE IRR_PHILIP_INFIL + +!=========end irrigation subroutines================================================================ + +!== begin groundwater ============================================================================== + + SUBROUTINE GROUNDWATER(parameters,NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in + STC ,WCND ,FCRMAX ,ILOC ,JLOC , & !in + SH2O ,ZWT ,WA ,WT , & !inout + QIN ,QDIS ) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + REAL, INTENT(IN) :: DT !timestep [sec] + REAL, INTENT(IN) :: FCRMAX!maximum FCR (-) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: WCND !hydraulic conductivity (m/s) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature (k) + +! input and output + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil water [m3/m3] + REAL, INTENT(INOUT) :: ZWT !the depth to water table [m] + REAL, INTENT(INOUT) :: WA !water storage in aquifer [mm] + REAL, INTENT(INOUT) :: WT !water storage in aquifer + !+ saturated soil [mm] +! output + REAL, INTENT(OUT) :: QIN !groundwater recharge [mm/s] + REAL, INTENT(OUT) :: QDIS !groundwater discharge [mm/s] + +! local + REAL :: FFF !runoff decay factor (m-1) + REAL :: RSBMX !baseflow coefficient [mm/s] + INTEGER :: IZ !do-loop index + INTEGER :: IWT !layer index above water table layer + REAL, DIMENSION( 1:NSOIL) :: DZMM !layer thickness [mm] + REAL, DIMENSION( 1:NSOIL) :: ZNODE !node depth [m] + REAL, DIMENSION( 1:NSOIL) :: MLIQ !liquid water mass [kg/m2 or mm] + REAL, DIMENSION( 1:NSOIL) :: EPORE !effective porosity [-] + REAL, DIMENSION( 1:NSOIL) :: HK !hydraulic conductivity [mm/s] + REAL, DIMENSION( 1:NSOIL) :: SMC !total soil water content [m3/m3] + REAL(KIND=8) :: S_NODE!degree of saturation of IWT layer + REAL :: DZSUM !cumulative depth above water table [m] + REAL :: SMPFZ !matric potential (frozen effects) [mm] + REAL :: KA !aquifer hydraulic conductivity [mm/s] + REAL :: WH_ZWT!water head at water table [mm] + REAL :: WH !water head at layer above ZWT [mm] + REAL :: WS !water used to fill air pore [mm] + REAL :: WTSUB !sum of HK*DZMM + REAL :: WATMIN!minimum soil vol soil moisture [m3/m3] + REAL :: XS !excessive water above saturation [mm] + REAL, PARAMETER :: ROUS = 0.2 !specific yield [-] + REAL, PARAMETER :: CMIC = 0.20 !microprore content (0.0-1.0) + !0.0-close to free drainage +! ------------------------------------------------------------- + QDIS = 0.0 + QIN = 0.0 + +! Derive layer-bottom depth in [mm] +!KWM: Derive layer thickness in mm + + DZMM(1) = -ZSOIL(1)*1.E3 + DO IZ = 2, NSOIL + DZMM(IZ) = 1.E3 * (ZSOIL(IZ - 1) - ZSOIL(IZ)) + ENDDO + +! Derive node (middle) depth in [m] +!KWM: Positive number, depth below ground surface in m + ZNODE(1) = -ZSOIL(1) / 2. + DO IZ = 2, NSOIL + ZNODE(IZ) = -ZSOIL(IZ-1) + 0.5 * (ZSOIL(IZ-1) - ZSOIL(IZ)) + ENDDO + +! Convert volumetric soil moisture "sh2o" to mass + + DO IZ = 1, NSOIL + SMC(IZ) = SH2O(IZ) + SICE(IZ) + MLIQ(IZ) = SH2O(IZ) * DZMM(IZ) + EPORE(IZ) = MAX(0.01,parameters%SMCMAX(IZ) - SICE(IZ)) + HK(IZ) = 1.E3*WCND(IZ) + ENDDO + +! The layer index of the first unsaturated layer, +! i.e., the layer right above the water table + + IWT = NSOIL + DO IZ = 2,NSOIL + IF(ZWT .LE. -ZSOIL(IZ) ) THEN + IWT = IZ-1 + EXIT + END IF + ENDDO + +! Groundwater discharge [mm/s] + + FFF = 6.0 + RSBMX = 5.0 + + QDIS = (1.0-FCRMAX)*RSBMX*EXP(-parameters%TIMEAN)*EXP(-FFF*(ZWT-2.0)) + +! Matric potential at the layer above the water table + + S_NODE = MIN(1.0,SMC(IWT)/parameters%SMCMAX(IWT) ) + S_NODE = MAX(S_NODE,REAL(0.01,KIND=8)) + SMPFZ = -parameters%PSISAT(IWT)*1000.*S_NODE**(-parameters%BEXP(IWT)) ! m --> mm + SMPFZ = MAX(-120000.0,CMIC*SMPFZ) + +! Recharge rate qin to groundwater + + KA = HK(IWT) + + WH_ZWT = - ZWT * 1.E3 !(mm) + WH = SMPFZ - ZNODE(IWT)*1.E3 !(mm) + QIN = - KA * (WH_ZWT-WH) /((ZWT-ZNODE(IWT))*1.E3) + QIN = MAX(-10.0/DT,MIN(10./DT,QIN)) + +! Water storage in the aquifer + saturated soil + + WT = WT + (QIN - QDIS) * DT !(mm) + + IF(IWT.EQ.NSOIL) THEN + WA = WA + (QIN - QDIS) * DT !(mm) + WT = WA + ZWT = (-ZSOIL(NSOIL) + 25.) - WA/1000./ROUS !(m) + MLIQ(NSOIL) = MLIQ(NSOIL) - QIN * DT ! [mm] + + MLIQ(NSOIL) = MLIQ(NSOIL) + MAX(0.,(WA - 5000.)) + WA = MIN(WA, 5000.) + ELSE + + IF (IWT.EQ.NSOIL-1) THEN + ZWT = -ZSOIL(NSOIL) & + - (WT-ROUS*1000*25.) / (EPORE(NSOIL))/1000. + ELSE + WS = 0. ! water used to fill soil air pores + DO IZ = IWT+2,NSOIL + WS = WS + EPORE(IZ) * DZMM(IZ) + ENDDO + ZWT = -ZSOIL(IWT+1) & + - (WT-ROUS*1000.*25.-WS) /(EPORE(IWT+1))/1000. + ENDIF + + WTSUB = 0. + DO IZ = 1, NSOIL + WTSUB = WTSUB + HK(IZ)*DZMM(IZ) + END DO + + DO IZ = 1, NSOIL ! Removing subsurface runoff + MLIQ(IZ) = MLIQ(IZ) - QDIS*DT*HK(IZ)*DZMM(IZ)/WTSUB + END DO + END IF + + ZWT = MAX(1.5,ZWT) + +! +! Limit MLIQ to be greater than or equal to watmin. +! Get water needed to bring MLIQ equal WATMIN from lower layer. +! + WATMIN = 0.01 + DO IZ = 1, NSOIL-1 + IF (MLIQ(IZ) .LT. 0.) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ ) = MLIQ(IZ ) + XS + MLIQ(IZ+1) = MLIQ(IZ+1) - XS + END DO + + IZ = NSOIL + IF (MLIQ(IZ) .LT. WATMIN) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ) = MLIQ(IZ) + XS + WA = WA - XS + WT = WT - XS + + DO IZ = 1, NSOIL + SH2O(IZ) = MLIQ(IZ) / DZMM(IZ) + END DO + + END SUBROUTINE GROUNDWATER + +!== begin shallowwatertable ======================================================================== + + SUBROUTINE SHALLOWWATERTABLE (parameters,NSNOW ,NSOIL ,ZSOIL, DT , & !in + DZSNSO ,SMCEQ ,ILOC ,JLOC , & !in + SMC ,WTD ,SMCWTD ,RECH, QDRAIN ) !inout +! ---------------------------------------------------------------------- +!Diagnoses water table depth and computes recharge when the water table is within the resolved soil layers, +!according to the Miguez-Macho&Fan scheme +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: ILOC,JLOC + REAL, INTENT(IN) :: DT + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] + +! input and output + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] + REAL, INTENT(INOUT) :: WTD !the depth to water table [m] + REAL, INTENT(INOUT) :: SMCWTD !soil moisture between bottom of the soil and the water table [m3/m3] + REAL, INTENT(OUT) :: RECH ! groundwater recharge (net vertical flux across the water table), positive up + REAL, INTENT(INOUT) :: QDRAIN + +! local + INTEGER :: IZ !do-loop index + INTEGER :: IWTD !layer index above water table layer + INTEGER :: KWTD !layer index where the water table layer is + REAL :: WTDOLD + REAL :: DZUP + REAL :: SMCEQDEEP + REAL, DIMENSION( 0:NSOIL) :: ZSOIL0 +! ------------------------------------------------------------- + + +ZSOIL0(1:NSOIL) = ZSOIL(1:NSOIL) +ZSOIL0(0) = 0. + +!find the layer where the water table is + DO IZ=NSOIL,1,-1 + IF(WTD + 1.E-6 < ZSOIL0(IZ)) EXIT + ENDDO + IWTD=IZ + + + KWTD=IWTD+1 !layer where the water table is + IF(KWTD.LE.NSOIL)THEN !wtd in the resolved layers + WTDOLD=WTD + IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN + + IF(SMC(KWTD).EQ.parameters%SMCMAX(KWTD))THEN !wtd went to the layer above + WTD=ZSOIL0(IWTD) + RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + IWTD=IWTD-1 + KWTD=KWTD-1 + IF(KWTD.GE.1)THEN + IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN + WTDOLD=WTD + WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & + - SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / & + ( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ), ZSOIL0(IWTD)) + RECH=RECH-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + ENDIF + ENDIF + ELSE !wtd stays in the layer + WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & + - SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / & + ( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ), ZSOIL0(IWTD)) + RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + ENDIF + + ELSE !wtd has gone down to the layer below + WTD=ZSOIL0(KWTD) + RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + KWTD=KWTD+1 + IWTD=IWTD+1 +!wtd crossed to the layer below. Now adjust it there + IF(KWTD.LE.NSOIL)THEN + WTDOLD=WTD + IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN + WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & + - SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / & + ( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ) , ZSOIL0(IWTD) ) + ELSE + WTD=ZSOIL0(KWTD) + ENDIF + RECH = RECH - (WTDOLD-WTD) * & + (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + + ELSE + WTDOLD=WTD +!restore smoi to equilibrium value with water from the ficticious layer below +! SMCWTD=SMCWTD-(SMCEQ(NSOIL)-SMC(NSOIL)) +! QDRAIN = QDRAIN - 1000 * (SMCEQ(NSOIL)-SMC(NSOIL)) * DZSNSO(NSOIL) / DT +! SMC(NSOIL)=SMCEQ(NSOIL) +!adjust wtd in the ficticious layer below + SMCEQDEEP = parameters%SMCMAX(NSOIL) * ( -parameters%PSISAT(NSOIL) / ( -parameters%PSISAT(NSOIL) - DZSNSO(NSOIL) ) ) ** (1./parameters%BEXP(NSOIL)) + WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) & + - SMCEQDEEP*ZSOIL0(NSOIL) + parameters%SMCMAX(NSOIL)*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / & + ( parameters%SMCMAX(NSOIL)-SMCEQDEEP ) , ZSOIL0(NSOIL) ) + RECH = RECH - (WTDOLD-WTD) * & + (parameters%SMCMAX(NSOIL)-SMCEQDEEP) + ENDIF + + ENDIF + ELSEIF(WTD.GE.ZSOIL0(NSOIL)-DZSNSO(NSOIL))THEN +!if wtd was already below the bottom of the resolved soil crust + WTDOLD=WTD + SMCEQDEEP = parameters%SMCMAX(NSOIL) * ( -parameters%PSISAT(NSOIL) / ( -parameters%PSISAT(NSOIL) - DZSNSO(NSOIL) ) ) ** (1./parameters%BEXP(NSOIL)) + IF(SMCWTD.GT.SMCEQDEEP)THEN + WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) & + - SMCEQDEEP*ZSOIL0(NSOIL) + parameters%SMCMAX(NSOIL)*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / & + ( parameters%SMCMAX(NSOIL)-SMCEQDEEP ) , ZSOIL0(NSOIL) ) + RECH = -(WTDOLD-WTD) * (parameters%SMCMAX(NSOIL)-SMCEQDEEP) + ELSE + RECH = -(WTDOLD-(ZSOIL0(NSOIL)-DZSNSO(NSOIL))) * (parameters%SMCMAX(NSOIL)-SMCEQDEEP) + WTDOLD=ZSOIL0(NSOIL)-DZSNSO(NSOIL) +!and now even further down + DZUP=(SMCEQDEEP-SMCWTD)*DZSNSO(NSOIL)/(parameters%SMCMAX(NSOIL)-SMCEQDEEP) + WTD=WTDOLD-DZUP + RECH = RECH - (parameters%SMCMAX(NSOIL)-SMCEQDEEP)*DZUP + SMCWTD=SMCEQDEEP + ENDIF + + + ENDIF + +IF(IWTD.LT.NSOIL .AND. IWTD.GT.0) THEN + SMCWTD=parameters%SMCMAX(IWTD) +ELSEIF(IWTD.LT.NSOIL .AND. IWTD.LE.0) THEN + SMCWTD=parameters%SMCMAX(1) +END IF + +END SUBROUTINE SHALLOWWATERTABLE + +! ================================================================================================== +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + +!== begin carbon =================================================================================== + + SUBROUTINE CARBON (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in + DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in + FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in + TROOT ,IST ,LAT ,ILOC ,JLOC , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out + TOTLB ,XLAI ,XSAI ) !out +! ------------------------------------------------------------------------------------------ + IMPLICIT NONE +! ------------------------------------------------------------------------------------------ +! inputs (carbon) + + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + INTEGER , INTENT(IN) :: VEGTYP !vegetation type + INTEGER , INTENT(IN) :: NSNOW !number of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL , INTENT(IN) :: DT !time step (s) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature [k] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL , INTENT(IN) :: TV !vegetation temperature (k) + REAL , INTENT(IN) :: TG !ground temperature (k) + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL , INTENT(IN) :: PSN !total leaf photosyn (umolco2/m2/s) [+] + REAL , INTENT(IN) :: APAR !PAR by canopy (w/m2) + REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL , INTENT(IN) :: FVEG !vegetation greenness fraction + REAL , INTENT(IN) :: TROOT !root-zone averaged temperature (k) + INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake + +! input & output (carbon) + + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon in deep soil [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short-lived carbon in shallow soil [g/m2] + +! outputs: (carbon) + + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange [g/m2/s CO2] + REAL , INTENT(OUT) :: AUTORS !net ecosystem respiration [g/m2/s C] + REAL , INTENT(OUT) :: HETERS !organic respiration [g/m2/s C] + REAL , INTENT(OUT) :: TOTSC !total soil carbon [g/m2 C] + REAL , INTENT(OUT) :: TOTLB !total living carbon ([g/m2 C] + REAL , INTENT(OUT) :: XLAI !leaf area index [-] + REAL , INTENT(OUT) :: XSAI !stem area index [-] +! REAL , INTENT(OUT) :: VOCFLX(5) ! voc fluxes [ug C m-2 h-1] + +! local variables + + INTEGER :: J !do-loop index + REAL :: WROOT !root zone soil water [-] + REAL :: WSTRES !water stress coeficient [-] (1. for wilting ) + REAL :: LAPM !leaf area per unit mass [m2/g] +! ------------------------------------------------------------------------------------------ + + IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. & + ( VEGTYP == parameters%ISICE ) .or. (parameters%urban_flag) ) THEN + XLAI = 0. + XSAI = 0. + GPP = 0. + NPP = 0. + NEE = 0. + AUTORS = 0. + HETERS = 0. + TOTSC = 0. + TOTLB = 0. + LFMASS = 0. + RTMASS = 0. + STMASS = 0. + WOOD = 0. + STBLCP = 0. + FASTCP = 0. + + RETURN + END IF + + LAPM = parameters%SLA / 1000. ! m2/kg -> m2/g + +! water stress + + WSTRES = 1.- BTRAN + + WROOT = 0. + DO J=1,parameters%NROOT + WROOT = WROOT + SMC(J)/parameters%SMCMAX(J) * DZSNSO(J) / (-ZSOIL(parameters%NROOT)) + ENDDO + + CALL CO2FLUX (parameters,NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in + DZSNSO ,STC ,PSN ,TROOT ,TV , & !in + WROOT ,WSTRES ,FOLN ,LAPM , & !in + LAT ,ILOC ,JLOC ,FVEG , & !in + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out + +! CALL BVOC (parameters,VOCFLX, VEGTYP, VEGFAC, APAR, TV) +! CALL CH4 + + END SUBROUTINE CARBON + +!== begin co2flux ================================================================================== + + SUBROUTINE CO2FLUX (parameters,NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in + DZSNSO ,STC ,PSN ,TROOT ,TV , & !in + WROOT ,WSTRES ,FOLN ,LAPM , & !in + LAT ,ILOC ,JLOC ,FVEG , & !in + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out +! ----------------------------------------------------------------------------------------- +! The original code is from RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 +! ----------------------------------------------------------------------------------------- + IMPLICIT NONE +! ----------------------------------------------------------------------------------------- + +! input + + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + INTEGER , INTENT(IN) :: VEGTYP !vegetation physiology type + INTEGER , INTENT(IN) :: NSNOW !number of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + REAL , INTENT(IN) :: DT !time step (s) + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature [k] + REAL , INTENT(IN) :: PSN !total leaf photosynthesis (umolco2/m2/s) + REAL , INTENT(IN) :: TROOT !root-zone averaged temperature (k) + REAL , INTENT(IN) :: TV !leaf temperature (k) + REAL , INTENT(IN) :: WROOT !root zone soil water + REAL , INTENT(IN) :: WSTRES !soil water stress + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: LAPM !leaf area per unit mass [m2/g] + REAL , INTENT(IN) :: FVEG !vegetation greenness fraction + +! input and output + + REAL , INTENT(INOUT) :: XLAI !leaf area index from leaf carbon [-] + REAL , INTENT(INOUT) :: XSAI !stem area index from leaf carbon [-] + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short lived carbon [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon pool [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + +! output + + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange (autors+heters-gpp) + REAL , INTENT(OUT) :: AUTORS !net ecosystem resp. (maintance and growth) + REAL , INTENT(OUT) :: HETERS !organic respiration + REAL , INTENT(OUT) :: TOTSC !total soil carbon (g/m2) + REAL , INTENT(OUT) :: TOTLB !total living carbon (g/m2) + +! local + + REAL :: CFLUX !carbon flux to atmosphere [g/m2/s] + REAL :: LFMSMN !minimum leaf mass [g/m2] + REAL :: RSWOOD !wood respiration [g/m2] + REAL :: RSLEAF !leaf maintenance respiration per timestep [g/m2] + REAL :: RSROOT !fine root respiration per time step [g/m2] + REAL :: NPPL !leaf net primary productivity [g/m2/s] + REAL :: NPPR !root net primary productivity [g/m2/s] + REAL :: NPPW !wood net primary productivity [g/m2/s] + REAL :: NPPS !wood net primary productivity [g/m2/s] + REAL :: DIELF !death of leaf mass per time step [g/m2] + + REAL :: ADDNPPLF !leaf assimil after resp. losses removed [g/m2] + REAL :: ADDNPPST !stem assimil after resp. losses removed [g/m2] + REAL :: CARBFX !carbon assimilated per model step [g/m2] + REAL :: GRLEAF !growth respiration rate for leaf [g/m2/s] + REAL :: GRROOT !growth respiration rate for root [g/m2/s] + REAL :: GRWOOD !growth respiration rate for wood [g/m2/s] + REAL :: GRSTEM !growth respiration rate for stem [g/m2/s] + REAL :: LEAFPT !fraction of carbon allocated to leaves [-] + REAL :: LFDEL !maximum leaf mass available to change [g/m2/s] + REAL :: LFTOVR !stem turnover per time step [g/m2] + REAL :: STTOVR !stem turnover per time step [g/m2] + REAL :: WDTOVR !wood turnover per time step [g/m2] + REAL :: RSSOIL !soil respiration per time step [g/m2] + REAL :: RTTOVR !root carbon loss per time step by turnover [g/m2] + REAL :: STABLC !decay rate of fast carbon to slow carbon [g/m2/s] + REAL :: WOODF !calculated wood to root ratio [-] + REAL :: NONLEF !fraction of carbon to root and wood [-] + REAL :: ROOTPT !fraction of carbon flux to roots [-] + REAL :: WOODPT !fraction of carbon flux to wood [-] + REAL :: STEMPT !fraction of carbon flux to stem [-] + REAL :: RESP !leaf respiration [umol/m2/s] + REAL :: RSSTEM !stem respiration [g/m2/s] + + REAL :: FSW !soil water factor for microbial respiration + REAL :: FST !soil temperature factor for microbial respiration + REAL :: FNF !foliage nitrogen adjustemt to respiration (<= 1) + REAL :: TF !temperature factor + REAL :: RF !respiration reduction factor (<= 1) + REAL :: STDEL + REAL :: STMSMN + REAL :: SAPM !stem area per unit mass (m2/g) + REAL :: DIEST +! -------------------------- constants ------------------------------- + REAL :: BF !parameter for present wood allocation [-] + REAL :: RSWOODC !wood respiration coeficient [1/s] + REAL :: STOVRC !stem turnover coefficient [1/s] + REAL :: RSDRYC !degree of drying that reduces soil respiration [-] + REAL :: RTOVRC !root turnover coefficient [1/s] + REAL :: WSTRC !water stress coeficient [-] + REAL :: LAIMIN !minimum leaf area index [m2/m2] + REAL :: XSAMIN !minimum leaf area index [m2/m2] + REAL :: SC + REAL :: SD + REAL :: VEGFRAC + +! Respiration as a function of temperature + + real :: r,x + r(x) = exp(0.08*(x-298.16)) +! --------------------------------------------------------------------------------- + +! constants + RTOVRC = 2.0E-8 !original was 2.0e-8 + RSDRYC = 40.0 !original was 40.0 + RSWOODC = 3.0E-10 ! + BF = 0.90 !original was 0.90 ! carbon to roots + WSTRC = 100.0 + LAIMIN = 0.05 + XSAMIN = 0.05 ! MB: change to prevent vegetation from not growing back in spring + + SAPM = 3.*0.001 ! m2/kg -->m2/g + LFMSMN = laimin/lapm + STMSMN = xsamin/sapm +! --------------------------------------------------------------------------------- + +! respiration + + IF(IGS .EQ. 0.) THEN + RF = 0.5 + ELSE + RF = 1.0 + ENDIF + + FNF = MIN( FOLN/MAX(1.E-06,parameters%FOLNMX), 1.0 ) + TF = parameters%ARM**( (TV-298.16)/10. ) + RESP = parameters%RMF25 * TF * FNF * XLAI * RF * (1.-WSTRES) ! umol/m2/s + RSLEAF = MIN((LFMASS-LFMSMN)/DT,RESP*12.e-6) ! g/m2/s + + RSROOT = parameters%RMR25*(RTMASS*1E-3)*TF *RF* 12.e-6 ! g/m2/s + RSSTEM = parameters%RMS25*((STMASS-STMSMN)*1E-3)*TF *RF* 12.e-6 ! g/m2/s + RSWOOD = RSWOODC * R(TV) * WOOD*parameters%WDPOOL + +! carbon assimilation +! 1 mole -> 12 g carbon or 44 g CO2; 1 umol -> 12.e-6 g carbon; + + CARBFX = PSN * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon + +! fraction of carbon into leaf versus nonleaf + + LEAFPT = EXP(0.01*(1.-EXP(0.75*XLAI))*XLAI) + IF(VEGTYP == parameters%EBLFOREST) LEAFPT = EXP(0.01*(1.-EXP(0.50*XLAI))*XLAI) + + NONLEF = 1.0 - LEAFPT + STEMPT = XLAI/10.0*LEAFPT + LEAFPT = LEAFPT - STEMPT + +! fraction of carbon into wood versus root + + IF(WOOD > 1.e-6) THEN + WOODF = (1.-EXP(-BF*(parameters%WRRAT*RTMASS/WOOD))/BF)*parameters%WDPOOL + ELSE + WOODF = parameters%WDPOOL + ENDIF + + ROOTPT = NONLEF*(1.-WOODF) + WOODPT = NONLEF*WOODF + +! leaf and root turnover per time step + + LFTOVR = parameters%LTOVRC*5.E-7*LFMASS + STTOVR = parameters%LTOVRC*5.E-7*STMASS + RTTOVR = RTOVRC*RTMASS + WDTOVR = 9.5E-10*WOOD + +! seasonal leaf die rate dependent on temp and water stress +! water stress is set to 1 at permanent wilting point + + SC = EXP(-0.3*MAX(0.,TV-parameters%TDLEF)) * (LFMASS/120.) + SD = EXP((WSTRES-1.)*WSTRC) + DIELF = LFMASS*1.E-6*(parameters%DILEFW * SD + parameters%DILEFC*SC) + DIEST = STMASS*1.E-6*(parameters%DILEFW * SD + parameters%DILEFC*SC) + +! calculate growth respiration for leaf, rtmass and wood + + GRLEAF = MAX(0.0,parameters%FRAGR*(LEAFPT*CARBFX - RSLEAF)) + GRSTEM = MAX(0.0,parameters%FRAGR*(STEMPT*CARBFX - RSSTEM)) + GRROOT = MAX(0.0,parameters%FRAGR*(ROOTPT*CARBFX - RSROOT)) + GRWOOD = MAX(0.0,parameters%FRAGR*(WOODPT*CARBFX - RSWOOD)) + +! Impose lower T limit for photosynthesis + + ADDNPPLF = MAX(0.,LEAFPT*CARBFX - GRLEAF-RSLEAF) + ADDNPPST = MAX(0.,STEMPT*CARBFX - GRSTEM-RSSTEM) +! ADDNPPLF = LEAFPT*CARBFX - GRLEAF-RSLEAF ! MB: test Kjetil +! ADDNPPST = STEMPT*CARBFX - GRSTEM-RSSTEM ! MB: test Kjetil + IF(TV.LT.parameters%TMIN) ADDNPPLF =0. + IF(TV.LT.parameters%TMIN) ADDNPPST =0. + +! update leaf, root, and wood carbon +! avoid reducing leaf mass below its minimum value but conserve mass + + LFDEL = (LFMASS - LFMSMN)/DT + STDEL = (STMASS - STMSMN)/DT + DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR) + DIEST = MIN(DIEST,STDEL+ADDNPPST-STTOVR) + +! net primary productivities + + NPPL = MAX(ADDNPPLF,-LFDEL) + NPPS = MAX(ADDNPPST,-STDEL) + NPPR = ROOTPT*CARBFX - RSROOT - GRROOT + NPPW = WOODPT*CARBFX - RSWOOD - GRWOOD + +! masses of plant components + + LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT + STMASS = STMASS + (NPPS-STTOVR-DIEST)*DT ! g/m2 + RTMASS = RTMASS + (NPPR-RTTOVR) *DT + + IF(RTMASS.LT.0.0) THEN + RTTOVR = NPPR + RTMASS = 0.0 + ENDIF + WOOD = (WOOD+(NPPW-WDTOVR)*DT)*parameters%WDPOOL + +! soil carbon budgets + + FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+WDTOVR+DIELF+DIEST)*DT ! MB: add DIEST v3.7 + + FST = 2.0**( (STC(1)-283.16)/10. ) + FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT) + RSSOIL = FSW * FST * parameters%MRP* MAX(0.,FASTCP*1.E-3)*12.E-6 + + STABLC = 0.1*RSSOIL + FASTCP = FASTCP - (RSSOIL + STABLC)*DT + STBLCP = STBLCP + STABLC*DT + +! total carbon flux + + CFLUX = - CARBFX + RSLEAF + RSROOT + RSWOOD + RSSTEM & ! MB: add RSSTEM,GRSTEM,0.9*RSSOIL v3.7 + + 0.9*RSSOIL + GRLEAF + GRROOT + GRWOOD + GRSTEM ! g/m2/s + +! for outputs + + GPP = CARBFX !g/m2/s C + NPP = NPPL + NPPW + NPPR +NPPS !g/m2/s C + AUTORS = RSROOT + RSWOOD + RSLEAF + RSSTEM + & !g/m2/s C MB: add RSSTEM, GRSTEM v3.7 + GRLEAF + GRROOT + GRWOOD + GRSTEM !g/m2/s C MB: add 0.9* v3.7 + HETERS = 0.9*RSSOIL !g/m2/s C + NEE = (AUTORS + HETERS - GPP)*44./12. !g/m2/s CO2 + TOTSC = FASTCP + STBLCP !g/m2 C + TOTLB = LFMASS + RTMASS +STMASS + WOOD !g/m2 C MB: add STMASS v3.7 + +! leaf area index and stem area index + + XLAI = MAX(LFMASS*LAPM,LAIMIN) + XSAI = MAX(STMASS*SAPM,XSAMIN) + + END SUBROUTINE CO2FLUX + +!== begin carbon_crop ============================================================================== + + SUBROUTINE CARBON_CROP (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL ,JULIAN , & !in + DZSNSO ,STC ,SMC ,TV ,PSN ,FOLN ,BTRAN , & !in + SOLDN ,T2M , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP ,GRAIN , & !inout + XLAI ,XSAI ,GDD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC ,TOTLB, PGS ) !out +! ------------------------------------------------------------------------------------------ +! Initial crop version created by Xing Liu +! Initial crop version added by Barlage v3.8 + +! ------------------------------------------------------------------------------------------ + IMPLICIT NONE +! ------------------------------------------------------------------------------------------ +! inputs (carbon) + + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: NSNOW !number of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: VEGTYP !vegetation type + REAL , INTENT(IN) :: DT !time step (s) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottomfrom soil surface + REAL , INTENT(IN) :: JULIAN !Julian day of year(fractional) ( 0 <= JULIAN < YEARLEN ) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layerthickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature[k] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice +liq.) [m3/m3] + REAL , INTENT(IN) :: TV !vegetation temperature(k) + REAL , INTENT(IN) :: PSN !total leaf photosyn(umolco2/m2/s) [+] + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: BTRAN !soil watertranspiration factor (0 to 1) + REAL , INTENT(IN) :: SOLDN !Downward solar radiation + REAL , INTENT(IN) :: T2M !air temperature + +! input & output (carbon) + + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots[g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl.woody roots) [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon in deepsoil [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short-lived carbon inshallow soil [g/m2] + REAL , INTENT(INOUT) :: GRAIN !mass of GRAIN [g/m2] + REAL , INTENT(INOUT) :: XLAI !leaf area index [-] + REAL , INTENT(INOUT) :: XSAI !stem area index [-] + REAL , INTENT(INOUT) :: GDD !growing degree days + +! outout + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange[g/m2/s CO2] + REAL , INTENT(OUT) :: AUTORS !net ecosystem respiration [g/m2/s C] + REAL , INTENT(OUT) :: HETERS !organic respiration[g/m2/s C] + REAL , INTENT(OUT) :: TOTSC !total soil carbon [g/m2C] + REAL , INTENT(OUT) :: TOTLB !total living carbon ([g/m2 C] + +! local variables + + INTEGER :: J !do-loop index + REAL :: WROOT !root zone soil water [-] + REAL :: WSTRES !water stress coeficient [-] (1. for wilting ) + INTEGER :: IPA !Planting index + INTEGER :: IHA !Havestindex(0=on,1=off) + INTEGER, INTENT(OUT) :: PGS !Plant growth stage + + REAL :: PSNCROP + +! ------------------------------------------------------------------------------------------ + IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. & + ( VEGTYP == parameters%ISICE ) .or. (parameters%urban_flag) ) THEN + XLAI = 0. + XSAI = 0. + GPP = 0. + NPP = 0. + NEE = 0. + AUTORS = 0. + HETERS = 0. + TOTSC = 0. + TOTLB = 0. + LFMASS = 0. + RTMASS = 0. + STMASS = 0. + WOOD = 0. + STBLCP = 0. + FASTCP = 0. + GRAIN = 0. + RETURN + END IF + +! water stress + + + WSTRES = 1.- BTRAN + + WROOT = 0. + DO J=1,parameters%NROOT + WROOT = WROOT + SMC(J)/parameters%SMCMAX(J) * DZSNSO(J) / (-ZSOIL(parameters%NROOT)) + ENDDO + + CALL PSN_CROP ( parameters, & !in + SOLDN, XLAI, T2M, & !in + PSNCROP ) !out + + CALL GROWING_GDD (parameters, & !in + T2M , DT, JULIAN, & !in + GDD , & !inout + IPA , IHA, PGS) !out + + CALL CO2FLUX_CROP (parameters, & !in + DT ,STC(1) ,PSN ,TV ,WROOT ,WSTRES ,FOLN , & !in + IPA ,IHA ,PGS , & !in XING + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD ,GRAIN ,GDD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out + + END SUBROUTINE CARBON_CROP + +!== begin co2flux_crop ============================================================================= + + SUBROUTINE CO2FLUX_CROP (parameters, & !in + DT ,STC ,PSN ,TV ,WROOT ,WSTRES ,FOLN , & !in + IPA ,IHA ,PGS , & !in XING + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD ,GRAIN ,GDD, & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out +! ----------------------------------------------------------------------------------------- +! The original code from RE Dickinson et al.(1998) and Guo-Yue Niu(2004), +! modified by Xing Liu, 2014. +! +! ----------------------------------------------------------------------------------------- + IMPLICIT NONE +! ----------------------------------------------------------------------------------------- + +! input + + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: DT !time step (s) + REAL , INTENT(IN) :: STC !soil temperature[k] + REAL , INTENT(IN) :: PSN !total leaf photosynthesis (umolco2/m2/s) + REAL , INTENT(IN) :: TV !leaf temperature (k) + REAL , INTENT(IN) :: WROOT !root zone soil water + REAL , INTENT(IN) :: WSTRES !soil water stress + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + INTEGER , INTENT(IN) :: IPA + INTEGER , INTENT(IN) :: IHA + INTEGER , INTENT(IN) :: PGS + +! input and output + + REAL , INTENT(INOUT) :: XLAI !leaf area index from leaf carbon [-] + REAL , INTENT(INOUT) :: XSAI !stem area index from leaf carbon [-] + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short lived carbon [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon pool [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + REAL , INTENT(INOUT) :: GRAIN !mass of grain (XING) [g/m2] + REAL , INTENT(INOUT) :: GDD !growing degree days (XING) + +! output + + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange (autors+heters-gpp) + REAL , INTENT(OUT) :: AUTORS !net ecosystem resp. (maintance and growth) + REAL , INTENT(OUT) :: HETERS !organic respiration + REAL , INTENT(OUT) :: TOTSC !total soil carbon (g/m2) + REAL , INTENT(OUT) :: TOTLB !total living carbon (g/m2) + +! local + + REAL :: CFLUX !carbon flux to atmosphere [g/m2/s] + REAL :: LFMSMN !minimum leaf mass [g/m2] + REAL :: RSWOOD !wood respiration [g/m2] + REAL :: RSLEAF !leaf maintenance respiration per timestep[g/m2] + REAL :: RSROOT !fine root respiration per time step [g/m2] + REAL :: RSGRAIN !grain respiration [g/m2] + REAL :: NPPL !leaf net primary productivity [g/m2/s] + REAL :: NPPR !root net primary productivity [g/m2/s] + REAL :: NPPW !wood net primary productivity [g/m2/s] + REAL :: NPPS !wood net primary productivity [g/m2/s] + REAL :: NPPG !grain net primary productivity [g/m2/s] + REAL :: DIELF !death of leaf mass per time step [g/m2] + + REAL :: ADDNPPLF !leaf assimil after resp. losses removed[g/m2] + REAL :: ADDNPPST !stem assimil after resp. losses removed[g/m2] + REAL :: CARBFX !carbon assimilated per model step [g/m2] + REAL :: CBHYDRAFX!carbonhydrate assimilated per model step [g/m2] + REAL :: GRLEAF !growth respiration rate for leaf [g/m2/s] + REAL :: GRROOT !growth respiration rate for root [g/m2/s] + REAL :: GRWOOD !growth respiration rate for wood [g/m2/s] + REAL :: GRSTEM !growth respiration rate for stem [g/m2/s] + REAL :: GRGRAIN !growth respiration rate for stem [g/m2/s] + REAL :: LEAFPT !fraction of carbon allocated to leaves [-] + REAL :: LFDEL !maximum leaf mass available to change[g/m2/s] + REAL :: LFTOVR !stem turnover per time step [g/m2] + REAL :: STTOVR !stem turnover per time step [g/m2] + REAL :: WDTOVR !wood turnover per time step [g/m2] + REAL :: GRTOVR !grainturnover per time step [g/m2] + REAL :: RSSOIL !soil respiration per time step [g/m2] + REAL :: RTTOVR !root carbon loss per time step by turnover[g/m2] + REAL :: STABLC !decay rate of fast carbon to slow carbon[g/m2/s] + REAL :: WOODF !calculated wood to root ratio [-] + REAL :: NONLEF !fraction of carbon to root and wood [-] + REAL :: RESP !leaf respiration [umol/m2/s] + REAL :: RSSTEM !stem respiration [g/m2/s] + + REAL :: FSW !soil water factor for microbial respiration + REAL :: FST !soil temperature factor for microbialrespiration + REAL :: FNF !foliage nitrogen adjustemt to respiration(<= 1) + REAL :: TF !temperature factor + REAL :: STDEL + REAL :: STMSMN + REAL :: SAPM !stem area per unit mass (m2/g) + REAL :: DIEST + REAL :: LFCONVERT !leaf to grain conversion ! Zhe Zhang 2020-07-13 + REAL :: STCONVERT !stem to grain conversion [g/m2/s] + REAL :: RTCONVERT !root to grain conversion [g/m2/s] +! -------------------------- constants ------------------------------- + REAL :: BF !parameter for present wood allocation [-] + REAL :: RSWOODC !wood respiration coeficient [1/s] + REAL :: STOVRC !stem turnover coefficient [1/s] + REAL :: RSDRYC !degree of drying that reduces soilrespiration [-] + REAL :: RTOVRC !root turnover coefficient [1/s] + REAL :: WSTRC !water stress coeficient [-] + REAL :: LAIMIN !minimum leaf area index [m2/m2] + REAL :: XSAMIN !minimum leaf area index [m2/m2] + REAL :: SC + REAL :: SD + REAL :: VEGFRAC + REAL :: TEMP + +! Respiration as a function of temperature + + real :: r,x + r(x) = exp(0.08*(x-298.16)) +! --------------------------------------------------------------------------------- + +! constants + RSDRYC = 40.0 !original was 40.0 + RSWOODC = 3.0E-10 ! + BF = 0.90 !original was 0.90 ! carbon to roots + WSTRC = 100.0 + LAIMIN = 0.05 + XSAMIN = 0.05 + + SAPM = 3.*0.001 ! m2/kg -->m2/g + LFMSMN = laimin/0.035 + STMSMN = xsamin/sapm +! --------------------------------------------------------------------------------- + +! carbon assimilation +! 1 mole -> 12 g carbon or 44 g CO2 or 30 g CH20 + + CARBFX = PSN*12.e-6!*IPA !umol co2 /m2/ s -> g/m2/s C + CBHYDRAFX = PSN*30.e-6!*IPA + +! mainteinance respiration + FNF = MIN( FOLN/MAX(1.E-06,parameters%FOLN_MX), 1.0 ) + TF = parameters%Q10MR**( (TV-298.16)/10. ) + RESP = parameters%LFMR25 * TF * FNF * XLAI * (1.-WSTRES) ! umol/m2/s + RSLEAF = MIN((LFMASS-LFMSMN)/DT,RESP*30.e-6) ! g/m2/s + RSROOT = parameters%RTMR25*(RTMASS*1E-3)*TF * 30.e-6 ! g/m2/s + RSSTEM = parameters%STMR25*(STMASS*1E-3)*TF * 30.e-6 ! g/m2/s + RSGRAIN = parameters%GRAINMR25*(GRAIN*1E-3)*TF * 30.e-6 ! g/m2/s + +! calculate growth respiration for leaf, rtmass and grain + + GRLEAF = MAX(0.0,parameters%FRA_GR*(parameters%LFPT(PGS)*CBHYDRAFX - RSLEAF)) + GRSTEM = MAX(0.0,parameters%FRA_GR*(parameters%STPT(PGS)*CBHYDRAFX - RSSTEM)) + GRROOT = MAX(0.0,parameters%FRA_GR*(parameters%RTPT(PGS)*CBHYDRAFX - RSROOT)) + GRGRAIN = MAX(0.0,parameters%FRA_GR*(parameters%GRAINPT(PGS)*CBHYDRAFX - RSGRAIN)) + +! leaf turnover, stem turnover, root turnover and leaf death caused by soil +! water and soil temperature stress + + LFTOVR = parameters%LF_OVRC(PGS)*1.E-6*LFMASS + RTTOVR = parameters%RT_OVRC(PGS)*1.E-6*RTMASS + STTOVR = parameters%ST_OVRC(PGS)*1.E-6*STMASS + SC = EXP(-0.3*MAX(0.,TV-parameters%LEFREEZ)) * (LFMASS/120.) + SD = EXP((WSTRES-1.)*WSTRC) + DIELF = LFMASS*1.E-6*(parameters%DILE_FW(PGS) * SD + parameters%DILE_FC(PGS)*SC) + +! Allocation of CBHYDRAFX to leaf, stem, root and grain at each growth stage + + + ADDNPPLF = MAX(0.,parameters%LFPT(PGS)*CBHYDRAFX - GRLEAF-RSLEAF) + ADDNPPLF = parameters%LFPT(PGS)*CBHYDRAFX - GRLEAF-RSLEAF + ADDNPPST = MAX(0.,parameters%STPT(PGS)*CBHYDRAFX - GRSTEM-RSSTEM) + ADDNPPST = parameters%STPT(PGS)*CBHYDRAFX - GRSTEM-RSSTEM + + +! avoid reducing leaf mass below its minimum value but conserve mass + + LFDEL = (LFMASS - LFMSMN)/DT + STDEL = (STMASS - STMSMN)/DT + LFTOVR = MIN(LFTOVR,LFDEL+ADDNPPLF) + STTOVR = MIN(STTOVR,STDEL+ADDNPPST) + DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR) + +! net primary productivities + + NPPL = MAX(ADDNPPLF,-LFDEL) + NPPL = ADDNPPLF + NPPS = MAX(ADDNPPST,-STDEL) + NPPS = ADDNPPST + NPPR = parameters%RTPT(PGS)*CBHYDRAFX - RSROOT - GRROOT + NPPG = parameters%GRAINPT(PGS)*CBHYDRAFX - RSGRAIN - GRGRAIN + +! masses of plant components + + LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT + STMASS = STMASS + (NPPS-STTOVR)*DT ! g/m2 + RTMASS = RTMASS + (NPPR-RTTOVR)*DT + GRAIN = GRAIN + NPPG*DT + + GPP = CBHYDRAFX* 0.4 !!g/m2/s C 0.4=12/30, CH20 to C + + LFCONVERT = 0.0 ! Zhe Zhang 2020-07-13 + STCONVERT = 0.0 + RTCONVERT = 0.0 + LFCONVERT = LFMASS*(parameters%LFCT(PGS)*DT/3600.0) + STCONVERT = STMASS*(parameters%STCT(PGS)*DT/3600.0) + RTCONVERT = RTMASS*(parameters%RTCT(PGS)*DT/3600.0) + LFMASS = LFMASS - LFCONVERT + STMASS = STMASS - STCONVERT + RTMASS = RTMASS - RTCONVERT + GRAIN = GRAIN + STCONVERT + RTCONVERT + LFCONVERT + !IF(PGS==6) THEN + ! STCONVERT = STMASS*(0.00005*DT/3600.0) + ! STMASS = STMASS - STCONVERT + ! RTCONVERT = RTMASS*(0.0005*DT/3600.0) + ! RTMASS = RTMASS - RTCONVERT + ! GRAIN = GRAIN + STCONVERT + RTCONVERT + !END IF + + IF(RTMASS.LT.0.0) THEN + RTTOVR = NPPR + RTMASS = 0.0 + ENDIF + + IF(GRAIN.LT.0.0) THEN + GRAIN = 0.0 + ENDIF + + ! soil carbon budgets + +! IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN +! FASTCP=1000 +! ELSE + FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+DIELF)*DT +! END IF + FST = 2.0**( (STC-283.16)/10. ) + FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT) + RSSOIL = FSW * FST * parameters%MRP* MAX(0.,FASTCP*1.E-3)*12.E-6 + + STABLC = 0.1*RSSOIL + FASTCP = FASTCP - (RSSOIL + STABLC)*DT + STBLCP = STBLCP + STABLC*DT + +! total carbon flux + + CFLUX = - CARBFX + RSLEAF + RSROOT + RSSTEM & + + RSSOIL + GRLEAF + GRROOT ! g/m2/s 0.4=12/30, CH20 to C + +! for outputs + !g/m2/s C + + NPP = (NPPL + NPPS+ NPPR +NPPG)*0.4 !!g/m2/s C 0.4=12/30, CH20 to C + + + AUTORS = RSROOT + RSGRAIN + RSLEAF + & !g/m2/s C + GRLEAF + GRROOT + GRGRAIN !g/m2/s C + + HETERS = RSSOIL !g/m2/s C + NEE = (AUTORS + HETERS - GPP)*44./30. !g/m2/s CO2 + TOTSC = FASTCP + STBLCP !g/m2 C + + TOTLB = LFMASS + RTMASS + GRAIN + +! leaf area index and stem area index + + XLAI = MAX(LFMASS*parameters%BIO2LAI,LAIMIN) + XSAI = MAX(STMASS*SAPM,XSAMIN) + + +!After harversting +! IF(PGS == 8 ) THEN +! LFMASS = 0.62 +! STMASS = 0 +! GRAIN = 0 +! END IF + +! IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN + IF(PGS == 8 .and. (GRAIN > 0. .or. LFMASS > 0 .or. STMASS > 0 .or. RTMASS > 0)) THEN + XLAI = 0.05 + XSAI = 0.05 + LFMASS = LFMSMN + STMASS = STMSMN + RTMASS = 0 + GRAIN = 0 + END IF + +END SUBROUTINE CO2FLUX_CROP + +!== begin growing_gdd ============================================================================== + + SUBROUTINE GROWING_GDD (parameters, & !in + T2M , DT, JULIAN, & !in + GDD , & !inout + IPA, IHA, PGS) !out +!=================================================================================================== + +! input + + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: T2M !Air temperature + REAL , INTENT(IN) :: DT !time step (s) + REAL , INTENT(IN) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) + +! input and output + + REAL , INTENT(INOUT) :: GDD !growing degress days + +! output + + INTEGER , INTENT(OUT) :: IPA !Planting index index(0=off, 1=on) + INTEGER , INTENT(OUT) :: IHA !Havestindex(0=on,1=off) + INTEGER , INTENT(OUT) :: PGS !Plant growth stage(1=S1,2=S2,3=S3) + +!local + + REAL :: GDDDAY !gap bewtween GDD and GDD8 + REAL :: DAYOFS2 !DAYS in stage2 + REAL :: TDIFF !temperature difference for growing degree days calculation + REAL :: TC + + TC = T2M - 273.15 + +!Havestindex(0=on,1=off) + + IPA = 1 + IHA = 1 + +!turn on/off the planting + + IF(JULIAN < parameters%PLTDAY) IPA = 0 + +!turn on/off the harvesting + IF(JULIAN >= parameters%HSDAY) IHA = 0 + +!Calculate the growing degree days + + IF(TC < parameters%GDDTBASE) THEN + TDIFF = 0.0 + ELSEIF(TC >= parameters%GDDTCUT) THEN + TDIFF = parameters%GDDTCUT - parameters%GDDTBASE + ELSE + TDIFF = TC - parameters%GDDTBASE + END IF + + GDD = (GDD + TDIFF * DT / 86400.0) * IPA * IHA + + GDDDAY = GDD + + ! Decide corn growth stage, based on Hybrid-Maize + ! PGS = 1 : Before planting + ! PGS = 2 : from tassel initiation to silking + ! PGS = 3 : from silking to effective grain filling + ! PGS = 4 : from effective grain filling to pysiological maturity + ! PGS = 5 : GDDM=1389 + ! PGS = 6 : + ! PGS = 7 : + ! PGS = 8 : + ! GDDM = 1389 + ! GDDM = 1555 + ! GDDSK = 0.41*GDDM +145.4+150 !from hybrid-maize + ! GDDS1 = ((GDDSK-96)/38.9-4)*21 + ! GDDS1 = 0.77*GDDSK + ! GDDS3 = GDDSK+170 + ! GDDS3 = 170 + + PGS = 1 ! MB: set PGS = 1 (for initialization during growing season when no GDD) + + IF(GDDDAY > 0.0) PGS = 2 + + IF(GDDDAY >= parameters%GDDS1) PGS = 3 + + IF(GDDDAY >= parameters%GDDS2) PGS = 4 + + IF(GDDDAY >= parameters%GDDS3) PGS = 5 + + IF(GDDDAY >= parameters%GDDS4) PGS = 6 + + IF(GDDDAY >= parameters%GDDS5) PGS = 7 + + IF(JULIAN >= parameters%HSDAY) PGS = 8 + + IF(JULIAN < parameters%PLTDAY) PGS = 1 + +END SUBROUTINE GROWING_GDD + +!== begin psn_crop ================================================================================= + +SUBROUTINE PSN_CROP ( parameters, & !in + SOLDN, XLAI,T2M, & !in + PSNCROP ) !out +!=================================================================================================== + +! input + + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: SOLDN ! downward solar radiation + REAL , INTENT(IN) :: XLAI ! LAI + REAL , INTENT(IN) :: T2M ! air temp + REAL , INTENT(OUT) :: PSNCROP ! + +!local + + REAL :: PAR ! photosynthetically active radiation (w/m2) 1 W m-2 = 0.0864 MJ m-2 day-1 + REAL :: Amax ! Maximum CO2 assimulation rate g/co2/s + REAL :: L1 ! Three Gaussian method + REAL :: L2 ! Three Gaussian method + REAL :: L3 ! Three Gaussian method + REAL :: I1 ! Three Gaussian method + REAL :: I2 ! Three Gaussian method + REAL :: I3 ! Three Gaussian method + REAL :: A1 ! Three Gaussian method + REAL :: A2 ! Three Gaussian method + REAL :: A3 ! Three Gaussian method + REAL :: A ! CO2 Assimulation + REAL :: TC + + TC = T2M - 273.15 + + PAR = parameters%I2PAR * SOLDN * 0.0036 !w to MJ m-2 + + IF(TC < parameters%TASSIM0) THEN + Amax = 1E-10 + ELSEIF(TC >= parameters%TASSIM0 .and. TC < parameters%TASSIM1) THEN + Amax = (TC - parameters%TASSIM0) * parameters%Aref / (parameters%TASSIM1 - parameters%TASSIM0) + ELSEIF(TC >= parameters%TASSIM1 .and. TC < parameters%TASSIM2) THEN + Amax = parameters%Aref + ELSE + Amax= parameters%Aref - 0.2 * (T2M - parameters%TASSIM2) + ENDIF + + Amax = max(amax,0.01) + + IF(XLAI <= 0.05) THEN + L1 = 0.1127 * 0.05 !use initial LAI(0.05), avoid error + L2 = 0.5 * 0.05 + L3 = 0.8873 * 0.05 + ELSE + L1 = 0.1127 * XLAI + L2 = 0.5 * XLAI + L3 = 0.8873 * XLAI + END IF + + I1 = parameters%k * PAR * exp(-parameters%k * L1) + I2 = parameters%k * PAR * exp(-parameters%k * L2) + I3 = parameters%k * PAR * exp(-parameters%k * L3) + + I1 = max(I1,1E-10) + I2 = max(I2,1E-10) + I3 = max(I3,1E-10) + + A1 = Amax * (1 - exp(-parameters%epsi * I1 / Amax)) + A2 = Amax * (1 - exp(-parameters%epsi * I2 / Amax)) * 1.6 + A3 = Amax * (1 - exp(-parameters%epsi * I3 / Amax)) + + IF (XLAI <= 0.05) THEN + A = (A1+A2+A3) / 3.6 * 0.05 + ELSEIF (XLAI > 0.05 .and. XLAI <= 4.0) THEN + A = (A1+A2+A3) / 3.6 * XLAI + ELSE + A = (A1+A2+A3) / 3.6 * 4 + END IF + + A = A * parameters%PSNRF ! Attainable + + PSNCROP = 6.313 * A ! (1/44) * 1000000)/3600 = 6.313 + +END SUBROUTINE PSN_CROP + +!== begin bvocflux ================================================================================= + +! SUBROUTINE BVOCFLUX(parameters,VOCFLX, VEGTYP, VEGFRAC, APAR, TV ) +! +! ------------------------------------------------------------------------------------------ +! implicit none +! ------------------------------------------------------------------------------------------ +! +! ------------------------ code history --------------------------- +! source file: BVOC +! purpose: BVOC emissions +! DESCRIPTION: +! Volatile organic compound emission +! This code simulates volatile organic compound emissions +! following the algorithm presented in Guenther, A., 1999: Modeling +! Biogenic Volatile Organic Compound Emissions to the Atmosphere. In +! Reactive Hydrocarbons in the Atmosphere, Ch. 3 +! This model relies on the assumption that 90% of isoprene and monoterpene +! emissions originate from canopy foliage: +! E = epsilon * gamma * density * delta +! The factor delta (longterm activity factor) applies to isoprene emission +! from deciduous plants only. We neglect this factor at the present time. +! This factor is discussed in Guenther (1997). +! Subroutine written to operate at the patch level. +! IN FINAL IMPLEMENTATION, REMEMBER: +! 1. may wish to call this routine only as freq. as rad. calculations +! 2. may wish to place epsilon values directly in pft-physiology file +! ------------------------ input/output variables ----------------- +! input +! integer ,INTENT(IN) :: vegtyp !vegetation type +! real ,INTENT(IN) :: vegfrac !green vegetation fraction [0.0-1.0] +! real ,INTENT(IN) :: apar !photosynthesis active energy by canopy (w/m2) +! real ,INTENT(IN) :: tv !vegetation canopy temperature (k) +! +! output +! real ,INTENT(OUT) :: vocflx(5) ! voc fluxes [ug C m-2 h-1] +! +! Local Variables +! +! real, parameter :: R = 8.314 ! univ. gas constant [J K-1 mol-1] +! real, parameter :: alpha = 0.0027 ! empirical coefficient +! real, parameter :: cl1 = 1.066 ! empirical coefficient +! real, parameter :: ct1 = 95000.0 ! empirical coefficient [J mol-1] +! real, parameter :: ct2 = 230000.0 ! empirical coefficient [J mol-1] +! real, parameter :: ct3 = 0.961 ! empirical coefficient +! real, parameter :: tm = 314.0 ! empirical coefficient [K] +! real, parameter :: tstd = 303.0 ! std temperature [K] +! real, parameter :: bet = 0.09 ! beta empirical coefficient [K-1] +! +! integer ivoc ! do-loop index +! integer ityp ! do-loop index +! real epsilon(5) +! real gamma(5) +! real density +! real elai +! real par,cl,reciprod,ct +! +! epsilon : +! +! do ivoc = 1, 5 +! epsilon(ivoc) = parameters%eps(VEGTYP,ivoc) +! end do +! +! gamma : Activity factor. Units [dimensionless] +! +! reciprod = 1. / (R * tv * tstd) +! ct = exp(ct1 * (tv - tstd) * reciprod) / & +! (ct3 + exp(ct2 * (tv - tm) * reciprod)) +! +! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) +! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) +! +! gamma(1) = cl * ct ! for isoprenes +! +! do ivoc = 2, 5 +! gamma(ivoc) = exp(bet * (tv - tstd)) +! end do +! +! Foliage density +! +! transform vegfrac to lai +! +! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) +! density = elai / (parameters%slarea(VEGTYP) * 0.5) +! +! calculate the voc flux +! +! do ivoc = 1, 5 +! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density +! end do +! +! end subroutine bvocflux +! ================================================================================================== + +!***************** SUBROUTINES FOR GECROS CROP SIMULATION *************** +!*----------------------------------------------------------------------* +!* SUBROUTINE EMERG * +!* Purpose: This subroutine calculates germination and emergence of * +!* the crop * +!* * +!* FORMAL PARAMETERS: (I=input,O=output,C=control,IN=init,T=time) * +!* * +!* name type meaning units class * +!* ---- ---- ------- ----- ----- * +!* nowdate C12 Actual date dd.mm.yy I * +!* DT R4 Time step of integration s I * +!* DD R4 Drilling depth cm I * +!* TSOIL R4 Soil temperature in first layer K I * +!* TBEM R4 Temperature threshold oC I * +!* EMA R4 Intercept of function for emergence oC I * +!* EMB R4 Slope of function for emergence oC I * +!* TTEM R4 Cumulative temperature sum for emergence oC I/O * +!* EMERGENCE LOG Flag for emergence - I/O * +!* STATE_GECROS(41) = emerged yes/no * +!* STATE_GECROS(43) = TTEM * +!*----------------------------------------------------------------------* + +SUBROUTINE EMERG(DT, TSOIL, DD, TBEM, EMA, EMB, STATE_GECROS) + IMPLICIT NONE + REAL, INTENT(IN) :: DT, TSOIL, DD, TBEM, EMA, EMB + REAL, DIMENSION(1:60), INTENT(INOUT) :: STATE_GECROS + REAL :: EMTH, TINT + SAVE + + IF ((TSOIL-273.15).LT.TBEM) THEN + ELSE + STATE_GECROS(43) = STATE_GECROS(43) + (TSOIL-273.15-TBEM)/(86400./DT) + ENDIF + + EMTH = EMA + EMB*DD + + IF (STATE_GECROS(43).GT.EMTH) THEN + STATE_GECROS(41)=1. +! write(*,*) 'Crop emerged on ', nowdate +! read(*,*) + ELSE + STATE_GECROS(41)=-1. + ENDIF + + RETURN +END SUBROUTINE EMERG + +! ********************************* end of carbon subroutines ***************************** +! ================================================================================================== + +!== begin noahmp_options =========================================================================== + + subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & + iopt_rsf , iopt_soil, iopt_pedo, iopt_crop, iopt_irr, iopt_irrm) + + implicit none + + INTEGER, INTENT(IN) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + INTEGER, INTENT(IN) :: iopt_crs !canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) + INTEGER, INTENT(IN) :: iopt_btr !soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) + INTEGER, INTENT(IN) :: iopt_run !runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) + INTEGER, INTENT(IN) :: iopt_sfc !surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97) + INTEGER, INTENT(IN) :: iopt_frz !supercooled liquid water (1-> NY06; 2->Koren99) + INTEGER, INTENT(IN) :: iopt_inf !frozen soil permeability (1-> NY06; 2->Koren99) + INTEGER, INTENT(IN) :: iopt_rad !radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg) + INTEGER, INTENT(IN) :: iopt_alb !snow surface albedo (1->BATS; 2->CLASS) + INTEGER, INTENT(IN) :: iopt_snf !rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) + INTEGER, INTENT(IN) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->Noah) + + INTEGER, INTENT(IN) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original Noah) + INTEGER, INTENT(IN) :: iopt_rsf !surface resistance (1->Sakaguchi/Zeng; 2->Seller; 3->mod Sellers; 4->1+snow) + INTEGER, INTENT(IN) :: iopt_soil !soil parameters set-up option + INTEGER, INTENT(IN) :: iopt_pedo !pedo-transfer function (1->Saxton and Rawls) + INTEGER, INTENT(IN) :: iopt_crop !crop model option (0->none; 1->Liu et al.; 2->Gecros) + INTEGER, INTENT(IN) :: iopt_irr ! 0 -> No irrigation; + ! 1 -> Irrigation ON; + ! 2 -> irrigation trigger based on crop season Planting and harvesting dates; + ! 3 -> irrigation trigger based on LAI threshold + INTEGER, INTENT(IN) :: iopt_irrm ! 0 -> all methods ON based on geo_em inputs + ! 1 -> sprinkler ON + ! 2 -> micro/drip ON + ! 3 -> flood irrigation ON +! ------------------------------------------------------------------------------------------------- + + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + opt_rsf = iopt_rsf + opt_soil = iopt_soil + opt_pedo = iopt_pedo + opt_crop = iopt_crop + opt_irr = iopt_irr + opt_irrm = iopt_irrm + + end subroutine noahmp_options + +END MODULE MODULE_SF_NOAHMPLSM + +MODULE NOAHMP_TABLES + + IMPLICIT NONE + + INTEGER, PRIVATE, PARAMETER :: MVT = 27 + INTEGER, PRIVATE, PARAMETER :: MBAND = 2 + INTEGER, PRIVATE, PARAMETER :: MSC = 8 + INTEGER, PRIVATE, PARAMETER :: MAX_SOILTYP = 30 + INTEGER, PRIVATE, PARAMETER :: NCROP = 5 + INTEGER, PRIVATE, PARAMETER :: NSTAGE = 8 + +! MPTABLE.TBL vegetation parameters + + INTEGER :: ISURBAN_TABLE + INTEGER :: ISWATER_TABLE + INTEGER :: ISBARREN_TABLE + INTEGER :: ISICE_TABLE + INTEGER :: ISCROP_TABLE + INTEGER :: EBLFOREST_TABLE + INTEGER :: NATURAL_TABLE + INTEGER :: LCZ_1_TABLE + INTEGER :: LCZ_2_TABLE + INTEGER :: LCZ_3_TABLE + INTEGER :: LCZ_4_TABLE + INTEGER :: LCZ_5_TABLE + INTEGER :: LCZ_6_TABLE + INTEGER :: LCZ_7_TABLE + INTEGER :: LCZ_8_TABLE + INTEGER :: LCZ_9_TABLE + INTEGER :: LCZ_10_TABLE + INTEGER :: LCZ_11_TABLE + + REAL :: CH2OP_TABLE(MVT) !maximum intercepted h2o per unit lai+sai (mm) + REAL :: DLEAF_TABLE(MVT) !characteristic leaf dimension (m) + REAL :: Z0MVT_TABLE(MVT) !momentum roughness length (m) + REAL :: HVT_TABLE(MVT) !top of canopy (m) + REAL :: HVB_TABLE(MVT) !bottom of canopy (m) + REAL :: DEN_TABLE(MVT) !tree density (no. of trunks per m2) + REAL :: RC_TABLE(MVT) !tree crown radius (m) + REAL :: MFSNO_TABLE(MVT) !snowmelt curve parameter () + REAL :: SCFFAC_TABLE(MVT) !snow cover factor (m) (replace original hard-coded 2.5*z0 in SCF formulation) + REAL :: SAIM_TABLE(MVT,12) !monthly stem area index, one-sided + REAL :: LAIM_TABLE(MVT,12) !monthly leaf area index, one-sided + REAL :: SLA_TABLE(MVT) !single-side leaf area per Kg [m2/kg] + REAL :: DILEFC_TABLE(MVT) !coeficient for leaf stress death [1/s] + REAL :: DILEFW_TABLE(MVT) !coeficient for leaf stress death [1/s] + REAL :: FRAGR_TABLE(MVT) !fraction of growth respiration !original was 0.3 + REAL :: LTOVRC_TABLE(MVT) !leaf turnover [1/s] + + REAL :: C3PSN_TABLE(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 + REAL :: KC25_TABLE(MVT) !co2 michaelis-menten constant at 25c (pa) + REAL :: AKC_TABLE(MVT) !q10 for kc25 + REAL :: KO25_TABLE(MVT) !o2 michaelis-menten constant at 25c (pa) + REAL :: AKO_TABLE(MVT) !q10 for ko25 + REAL :: VCMX25_TABLE(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMX_TABLE(MVT) !q10 for vcmx25 + REAL :: BP_TABLE(MVT) !minimum leaf conductance (umol/m**2/s) + REAL :: MP_TABLE(MVT) !slope of conductance-to-photosynthesis relationship + REAL :: QE25_TABLE(MVT) !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: AQE_TABLE(MVT) !q10 for qe25 + REAL :: RMF25_TABLE(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL :: RMS25_TABLE(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: RMR25_TABLE(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: ARM_TABLE(MVT) !q10 for maintenance respiration + REAL :: FOLNMX_TABLE(MVT) !foliage nitrogen concentration when f(n)=1 (%) + REAL :: TMIN_TABLE(MVT) !minimum temperature for photosynthesis (k) + + REAL :: XL_TABLE(MVT) !leaf/stem orientation index + REAL :: RHOL_TABLE(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir + REAL :: RHOS_TABLE(MVT,MBAND) !stem reflectance: 1=vis, 2=nir + REAL :: TAUL_TABLE(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir + REAL :: TAUS_TABLE(MVT,MBAND) !stem transmittance: 1=vis, 2=nir + + REAL :: MRP_TABLE(MVT) !microbial respiration parameter (umol co2 /kg c/ s) + REAL :: CWPVT_TABLE(MVT) !empirical canopy wind parameter + + REAL :: WRRAT_TABLE(MVT) !wood to non-wood ratio + REAL :: WDPOOL_TABLE(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] + REAL :: TDLEF_TABLE(MVT) !characteristic T for leaf freezing [K] + + REAL :: NROOT_TABLE(MVT) !number of soil layers with root present + REAL :: RGL_TABLE(MVT) !Parameter used in radiation stress function + REAL :: RS_TABLE(MVT) !Minimum stomatal resistance [s m-1] + REAL :: HS_TABLE(MVT) !Parameter used in vapor pressure deficit function + REAL :: TOPT_TABLE(MVT) !Optimum transpiration air temperature [K] + REAL :: RSMAX_TABLE(MVT) !Maximal stomatal resistance [s m-1] + +! SOILPARM.TBL parameters + + INTEGER :: SLCATS + + REAL :: BEXP_TABLE(MAX_SOILTYP) !maximum intercepted h2o per unit lai+sai (mm) + REAL :: SMCDRY_TABLE(MAX_SOILTYP) !characteristic leaf dimension (m) + REAL :: F1_TABLE(MAX_SOILTYP) !momentum roughness length (m) + REAL :: SMCMAX_TABLE(MAX_SOILTYP) !top of canopy (m) + REAL :: SMCREF_TABLE(MAX_SOILTYP) !bottom of canopy (m) + REAL :: PSISAT_TABLE(MAX_SOILTYP) !tree density (no. of trunks per m2) + REAL :: DKSAT_TABLE(MAX_SOILTYP) !tree crown radius (m) + REAL :: DWSAT_TABLE(MAX_SOILTYP) !monthly stem area index, one-sided + REAL :: SMCWLT_TABLE(MAX_SOILTYP) !monthly leaf area index, one-sided + REAL :: QUARTZ_TABLE(MAX_SOILTYP) !single-side leaf area per Kg [m2/kg] + +! GENPARM.TBL parameters + + REAL :: SLOPE_TABLE(9) !slope factor for soil drainage + + REAL :: CSOIL_TABLE !Soil heat capacity [J m-3 K-1] + REAL :: REFDK_TABLE !Parameter in the surface runoff parameterization + REAL :: REFKDT_TABLE !Parameter in the surface runoff parameterization + REAL :: FRZK_TABLE !Frozen ground parameter + REAL :: ZBOT_TABLE !Depth [m] of lower boundary soil temperature + REAL :: CZIL_TABLE !Parameter used in the calculation of the roughness length for heat + +! MPTABLE.TBL radiation parameters + + REAL :: ALBSAT_TABLE(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL :: ALBDRY_TABLE(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir + REAL :: ALBICE_TABLE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL :: ALBLAK_TABLE(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL :: OMEGAS_TABLE(MBAND) !two-stream parameter omega for snow + REAL :: BETADS_TABLE !two-stream parameter betad for snow + REAL :: BETAIS_TABLE !two-stream parameter betad for snow + REAL :: EG_TABLE(2) !emissivity + +! MPTABLE.TBL global parameters + + REAL :: CO2_TABLE !co2 partial pressure + REAL :: O2_TABLE !o2 partial pressure + REAL :: TIMEAN_TABLE !gridcell mean topgraphic index (global mean) + REAL :: FSATMX_TABLE !maximum surface saturated fraction (global mean) + REAL :: Z0SNO_TABLE !snow surface roughness length (m) (0.002) + REAL :: SSI_TABLE !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL :: SNOW_RET_FAC_TABLE !snowpack water release timescale factor (1/s) + REAL :: SNOW_EMIS_TABLE!snow emissivity + REAL :: SWEMX_TABLE !new snow mass to fully cover old snow (mm) + REAL :: TAU0_TABLE !tau0 from Yang97 eqn. 10a + REAL :: GRAIN_GROWTH_TABLE !growth from vapor diffusion Yang97 eqn. 10b + REAL :: EXTRA_GROWTH_TABLE !extra growth near freezing Yang97 eqn. 10c + REAL :: DIRT_SOOT_TABLE !dirt and soot term Yang97 eqn. 10d + REAL :: BATS_COSZ_TABLE !zenith angle snow albedo adjustment; b in Yang97 eqn. 15 + REAL :: BATS_VIS_NEW_TABLE !new snow visible albedo + REAL :: BATS_NIR_NEW_TABLE !new snow NIR albedo + REAL :: BATS_VIS_AGE_TABLE !age factor for diffuse visible snow albedo Yang97 eqn. 17 + REAL :: BATS_NIR_AGE_TABLE !age factor for diffuse NIR snow albedo Yang97 eqn. 18 + REAL :: BATS_VIS_DIR_TABLE !cosz factor for direct visible snow albedo Yang97 eqn. 15 + REAL :: BATS_NIR_DIR_TABLE !cosz factor for direct NIR snow albedo Yang97 eqn. 16 + REAL :: RSURF_SNOW_TABLE !surface resistance for snow(s/m) + REAL :: RSURF_EXP_TABLE !exponent in the shape parameter for soil resistance option 1 + +! MPTABLE.TBL irrigation parameters + + REAL :: IRR_FRAC_TABLE ! irrigation Fraction + INTEGER :: IRR_HAR_TABLE ! number of days before harvest date to stop irrigation + REAL :: IRR_LAI_TABLE ! Minimum lai to trigger irrigation + REAL :: IRR_MAD_TABLE ! management allowable deficit (0-1) + REAL :: FILOSS_TABLE ! fraction of flood irrigation loss (0-1) + REAL :: SPRIR_RATE_TABLE ! mm/h, sprinkler irrigation rate + REAL :: MICIR_RATE_TABLE ! mm/h, micro irrigation rate + REAL :: FIRTFAC_TABLE ! flood application rate factor + REAL :: IR_RAIN_TABLE ! maximum precipitation to stop irrigation trigger + +! MPTABLE.TBL crop parameters + + INTEGER :: DEFAULT_CROP_TABLE ! Default crop index + INTEGER :: PLTDAY_TABLE(NCROP) ! Planting date + INTEGER :: HSDAY_TABLE(NCROP) ! Harvest date + REAL :: PLANTPOP_TABLE(NCROP) ! Plant density [per ha] - used? + REAL :: IRRI_TABLE(NCROP) ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + + REAL :: GDDTBASE_TABLE(NCROP) ! Base temperature for GDD accumulation [C] + REAL :: GDDTCUT_TABLE(NCROP) ! Upper temperature for GDD accumulation [C] + REAL :: GDDS1_TABLE(NCROP) ! GDD from seeding to emergence + REAL :: GDDS2_TABLE(NCROP) ! GDD from seeding to initial vegetative + REAL :: GDDS3_TABLE(NCROP) ! GDD from seeding to post vegetative + REAL :: GDDS4_TABLE(NCROP) ! GDD from seeding to intial reproductive + REAL :: GDDS5_TABLE(NCROP) ! GDD from seeding to pysical maturity + + REAL :: C3PSNI_TABLE(NCROP) !photosynthetic pathway: 0. = c4, 1. = c3 ! Zhe Zhang 2020-07-03 + REAL :: KC25I_TABLE(NCROP) !co2 michaelis-menten constant at 25c (pa) + REAL :: AKCI_TABLE(NCROP) !q10 for kc25 + REAL :: KO25I_TABLE(NCROP) !o2 michaelis-menten constant at 25c (pa) + REAL :: AKOI_TABLE(NCROP) !q10 for ko25 + REAL :: VCMX25I_TABLE(NCROP) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMXI_TABLE(NCROP) !q10 for vcmx25 + REAL :: BPI_TABLE(NCROP) !minimum leaf conductance (umol/m**2/s) + REAL :: MPI_TABLE(NCROP) !slope of conductance-to-photosynthesis relationship + REAL :: QE25I_TABLE(NCROP) !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: FOLNMXI_TABLE(NCROP) !foliage nitrogen concentration when + + INTEGER :: C3C4_TABLE(NCROP) ! photosynthetic pathway: 1. = c3 2. = c4 + REAL :: AREF_TABLE(NCROP) ! reference maximum CO2 assimulation rate + REAL :: PSNRF_TABLE(NCROP) ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + REAL :: I2PAR_TABLE(NCROP) ! Fraction of incoming solar radiation to photosynthetically active radiation + REAL :: TASSIM0_TABLE(NCROP) ! Minimum temperature for CO2 assimulation [C] + REAL :: TASSIM1_TABLE(NCROP) ! CO2 assimulation linearly increasing until temperature reaches T1 [C] + REAL :: TASSIM2_TABLE(NCROP) ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + REAL :: K_TABLE(NCROP) ! light extinction coefficient + REAL :: EPSI_TABLE(NCROP) ! initial light use efficiency + + REAL :: Q10MR_TABLE(NCROP) ! q10 for maintainance respiration + REAL :: FOLN_MX_TABLE(NCROP) ! foliage nitrogen concentration when f(n)=1 (%) + REAL :: LEFREEZ_TABLE(NCROP) ! characteristic T for leaf freezing [K] + + REAL :: DILE_FC_TABLE(NCROP,NSTAGE) ! coeficient for temperature leaf stress death [1/s] + REAL :: DILE_FW_TABLE(NCROP,NSTAGE) ! coeficient for water leaf stress death [1/s] + REAL :: FRA_GR_TABLE(NCROP) ! fraction of growth respiration + + REAL :: LF_OVRC_TABLE(NCROP,NSTAGE) ! fraction of leaf turnover [1/s] + REAL :: ST_OVRC_TABLE(NCROP,NSTAGE) ! fraction of stem turnover [1/s] + REAL :: RT_OVRC_TABLE(NCROP,NSTAGE) ! fraction of root tunrover [1/s] + REAL :: LFMR25_TABLE(NCROP) ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] + REAL :: STMR25_TABLE(NCROP) ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: RTMR25_TABLE(NCROP) ! root maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: GRAINMR25_TABLE(NCROP) ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + + REAL :: LFPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to leaf + REAL :: STPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to stem + REAL :: RTPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to root + REAL :: GRAINPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to grain + REAL :: LFCT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate translocation from leaf to grain ! Zhe Zhang 2020-07-13 + REAL :: STCT_TABLE(NCROP,NSTAGE) ! stem to grain + REAL :: RTCT_TABLE(NCROP,NSTAGE) ! root to grain + REAL :: BIO2LAI_TABLE(NCROP) ! leaf are per living leaf biomass [m^2/kg] + +! MPTABLE.TBL optional parameters + + REAL :: sr2006_theta_1500t_a ! sand coefficient + REAL :: sr2006_theta_1500t_b ! clay coefficient + REAL :: sr2006_theta_1500t_c ! orgm coefficient + REAL :: sr2006_theta_1500t_d ! sand*orgm coefficient + REAL :: sr2006_theta_1500t_e ! clay*orgm coefficient + REAL :: sr2006_theta_1500t_f ! sand*clay coefficient + REAL :: sr2006_theta_1500t_g ! constant adjustment + + REAL :: sr2006_theta_1500_a ! theta_1500t coefficient + REAL :: sr2006_theta_1500_b ! constant adjustment + + REAL :: sr2006_theta_33t_a ! sand coefficient + REAL :: sr2006_theta_33t_b ! clay coefficient + REAL :: sr2006_theta_33t_c ! orgm coefficient + REAL :: sr2006_theta_33t_d ! sand*orgm coefficient + REAL :: sr2006_theta_33t_e ! clay*orgm coefficient + REAL :: sr2006_theta_33t_f ! sand*clay coefficient + REAL :: sr2006_theta_33t_g ! constant adjustment + + REAL :: sr2006_theta_33_a ! theta_33t*theta_33t coefficient + REAL :: sr2006_theta_33_b ! theta_33t coefficient + REAL :: sr2006_theta_33_c ! constant adjustment + + REAL :: sr2006_theta_s33t_a ! sand coefficient + REAL :: sr2006_theta_s33t_b ! clay coefficient + REAL :: sr2006_theta_s33t_c ! orgm coefficient + REAL :: sr2006_theta_s33t_d ! sand*orgm coefficient + REAL :: sr2006_theta_s33t_e ! clay*orgm coefficient + REAL :: sr2006_theta_s33t_f ! sand*clay coefficient + REAL :: sr2006_theta_s33t_g ! constant adjustment + + REAL :: sr2006_theta_s33_a ! theta_s33t coefficient + REAL :: sr2006_theta_s33_b ! constant adjustment + + REAL :: sr2006_psi_et_a ! sand coefficient + REAL :: sr2006_psi_et_b ! clay coefficient + REAL :: sr2006_psi_et_c ! theta_s33 coefficient + REAL :: sr2006_psi_et_d ! sand*theta_s33 coefficient + REAL :: sr2006_psi_et_e ! clay*theta_s33 coefficient + REAL :: sr2006_psi_et_f ! sand*clay coefficient + REAL :: sr2006_psi_et_g ! constant adjustment + + REAL :: sr2006_psi_e_a ! psi_et*psi_et coefficient + REAL :: sr2006_psi_e_b ! psi_et coefficient + REAL :: sr2006_psi_e_c ! constant adjustment + + REAL :: sr2006_smcmax_a ! sand adjustment + REAL :: sr2006_smcmax_b ! constant adjustment + +CONTAINS + + subroutine read_mp_veg_parameters(DATASET_IDENTIFIER) + implicit none + character(len=*), intent(in) :: DATASET_IDENTIFIER + integer :: ierr + INTEGER :: IK,IM + logical :: file_named + + integer :: NVEG + character(len=256) :: VEG_DATASET_DESCRIPTION + + INTEGER :: ISURBAN + INTEGER :: ISWATER + INTEGER :: ISBARREN + INTEGER :: ISICE + INTEGER :: ISCROP + INTEGER :: EBLFOREST + INTEGER :: NATURAL + INTEGER :: LCZ_1 + INTEGER :: LCZ_2 + INTEGER :: LCZ_3 + INTEGER :: LCZ_4 + INTEGER :: LCZ_5 + INTEGER :: LCZ_6 + INTEGER :: LCZ_7 + INTEGER :: LCZ_8 + INTEGER :: LCZ_9 + INTEGER :: LCZ_10 + INTEGER :: LCZ_11 + + REAL, DIMENSION(MVT) :: SAI_JAN,SAI_FEB,SAI_MAR,SAI_APR,SAI_MAY,SAI_JUN, & + SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC + REAL, DIMENSION(MVT) :: LAI_JAN,LAI_FEB,LAI_MAR,LAI_APR,LAI_MAY,LAI_JUN, & + LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC + REAL, DIMENSION(MVT) :: RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, & + TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR + REAL, DIMENSION(MVT) :: CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, & + AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , & + BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 + + NAMELIST / noahmp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + NAMELIST / noahmp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, & + LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11,& + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & + FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & + LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 + + NAMELIST / noahmp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + NAMELIST / noahmp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, & + LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & + FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & + LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 + + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + CH2OP_TABLE = -1.E36 + DLEAF_TABLE = -1.E36 + Z0MVT_TABLE = -1.E36 + HVT_TABLE = -1.E36 + HVB_TABLE = -1.E36 + DEN_TABLE = -1.E36 + RC_TABLE = -1.E36 + MFSNO_TABLE = -1.E36 + SCFFAC_TABLE = -1.E36 + RHOL_TABLE = -1.E36 + RHOS_TABLE = -1.E36 + TAUL_TABLE = -1.E36 + TAUS_TABLE = -1.E36 + XL_TABLE = -1.E36 + CWPVT_TABLE = -1.E36 + C3PSN_TABLE = -1.E36 + KC25_TABLE = -1.E36 + AKC_TABLE = -1.E36 + KO25_TABLE = -1.E36 + AKO_TABLE = -1.E36 + AVCMX_TABLE = -1.E36 + AQE_TABLE = -1.E36 + LTOVRC_TABLE = -1.E36 + DILEFC_TABLE = -1.E36 + DILEFW_TABLE = -1.E36 + RMF25_TABLE = -1.E36 + SLA_TABLE = -1.E36 + FRAGR_TABLE = -1.E36 + TMIN_TABLE = -1.E36 + VCMX25_TABLE = -1.E36 + TDLEF_TABLE = -1.E36 + BP_TABLE = -1.E36 + MP_TABLE = -1.E36 + QE25_TABLE = -1.E36 + RMS25_TABLE = -1.E36 + RMR25_TABLE = -1.E36 + ARM_TABLE = -1.E36 + FOLNMX_TABLE = -1.E36 + WDPOOL_TABLE = -1.E36 + WRRAT_TABLE = -1.E36 + MRP_TABLE = -1.E36 + SAIM_TABLE = -1.E36 + LAIM_TABLE = -1.E36 + NROOT_TABLE = -1.E36 + RGL_TABLE = -1.E36 + RS_TABLE = -1.E36 + HS_TABLE = -1.E36 + TOPT_TABLE = -1.E36 + RSMAX_TABLE = -1.E36 + ISURBAN_TABLE = -99999 + ISWATER_TABLE = -99999 + ISBARREN_TABLE = -99999 + ISICE_TABLE = -99999 + ISCROP_TABLE = -99999 + EBLFOREST_TABLE = -99999 + NATURAL_TABLE = -99999 + LCZ_1_TABLE = -99999 + LCZ_2_TABLE = -99999 + LCZ_3_TABLE = -99999 + LCZ_4_TABLE = -99999 + LCZ_5_TABLE = -99999 + LCZ_6_TABLE = -99999 + LCZ_7_TABLE = -99999 + LCZ_8_TABLE = -99999 + LCZ_9_TABLE = -99999 + LCZ_10_TABLE = -99999 + LCZ_11_TABLE = -99999 + + inquire( file='MPTABLE.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file MPTABLE.TBL")') + WRITE(*,*) "STOP in Noah-MP read_mp_veg_parameters" + STOP + ! call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters") + endif + + if ( trim(DATASET_IDENTIFIER) == "USGS" ) then + read(15,noahmp_usgs_veg_categories) + read(15,noahmp_usgs_parameters) + else if ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then + read(15,noahmp_modis_veg_categories) + read(15,noahmp_modis_parameters) + else + write(*,'("WARNING: Unrecognized DATASET_IDENTIFIER in subroutine READ_MP_VEG_PARAMETERS")') + write(*,'("WARNING: DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER) + WRITE(*,*) "STOP in Noah-MP read_mp_veg_parameters" + STOP + ! call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters") + endif + close(15) + + ISURBAN_TABLE = ISURBAN + ISWATER_TABLE = ISWATER + ISBARREN_TABLE = ISBARREN + ISICE_TABLE = ISICE + ISCROP_TABLE = ISCROP + EBLFOREST_TABLE = EBLFOREST + NATURAL_TABLE = NATURAL + LCZ_1_TABLE = LCZ_1 + LCZ_2_TABLE = LCZ_2 + LCZ_3_TABLE = LCZ_3 + LCZ_4_TABLE = LCZ_4 + LCZ_5_TABLE = LCZ_5 + LCZ_6_TABLE = LCZ_6 + LCZ_7_TABLE = LCZ_7 + LCZ_8_TABLE = LCZ_8 + LCZ_9_TABLE = LCZ_9 + LCZ_10_TABLE = LCZ_10 + LCZ_11_TABLE = LCZ_11 + + CH2OP_TABLE(1:NVEG) = CH2OP(1:NVEG) + DLEAF_TABLE(1:NVEG) = DLEAF(1:NVEG) + Z0MVT_TABLE(1:NVEG) = Z0MVT(1:NVEG) + HVT_TABLE(1:NVEG) = HVT(1:NVEG) + HVB_TABLE(1:NVEG) = HVB(1:NVEG) + DEN_TABLE(1:NVEG) = DEN(1:NVEG) + RC_TABLE(1:NVEG) = RC(1:NVEG) + MFSNO_TABLE(1:NVEG) = MFSNO(1:NVEG) + SCFFAC_TABLE(1:NVEG) = SCFFAC(1:NVEG) + XL_TABLE(1:NVEG) = XL(1:NVEG) + CWPVT_TABLE(1:NVEG) = CWPVT(1:NVEG) + C3PSN_TABLE(1:NVEG) = C3PSN(1:NVEG) + KC25_TABLE(1:NVEG) = KC25(1:NVEG) + AKC_TABLE(1:NVEG) = AKC(1:NVEG) + KO25_TABLE(1:NVEG) = KO25(1:NVEG) + AKO_TABLE(1:NVEG) = AKO(1:NVEG) + AVCMX_TABLE(1:NVEG) = AVCMX(1:NVEG) + AQE_TABLE(1:NVEG) = AQE(1:NVEG) + LTOVRC_TABLE(1:NVEG) = LTOVRC(1:NVEG) + DILEFC_TABLE(1:NVEG) = DILEFC(1:NVEG) + DILEFW_TABLE(1:NVEG) = DILEFW(1:NVEG) + RMF25_TABLE(1:NVEG) = RMF25(1:NVEG) + SLA_TABLE(1:NVEG) = SLA(1:NVEG) + FRAGR_TABLE(1:NVEG) = FRAGR(1:NVEG) + TMIN_TABLE(1:NVEG) = TMIN(1:NVEG) + VCMX25_TABLE(1:NVEG) = VCMX25(1:NVEG) + TDLEF_TABLE(1:NVEG) = TDLEF(1:NVEG) + BP_TABLE(1:NVEG) = BP(1:NVEG) + MP_TABLE(1:NVEG) = MP(1:NVEG) + QE25_TABLE(1:NVEG) = QE25(1:NVEG) + RMS25_TABLE(1:NVEG) = RMS25(1:NVEG) + RMR25_TABLE(1:NVEG) = RMR25(1:NVEG) + ARM_TABLE(1:NVEG) = ARM(1:NVEG) + FOLNMX_TABLE(1:NVEG) = FOLNMX(1:NVEG) + WDPOOL_TABLE(1:NVEG) = WDPOOL(1:NVEG) + WRRAT_TABLE(1:NVEG) = WRRAT(1:NVEG) + MRP_TABLE(1:NVEG) = MRP(1:NVEG) + NROOT_TABLE(1:NVEG) = NROOT(1:NVEG) + RGL_TABLE(1:NVEG) = RGL(1:NVEG) + RS_TABLE(1:NVEG) = RS(1:NVEG) + HS_TABLE(1:NVEG) = HS(1:NVEG) + TOPT_TABLE(1:NVEG) = TOPT(1:NVEG) + RSMAX_TABLE(1:NVEG) = RSMAX(1:NVEG) + + ! Put LAI and SAI into 2d array from monthly lines in table; same for canopy radiation properties + + SAIM_TABLE(1:NVEG, 1) = SAI_JAN(1:NVEG) + SAIM_TABLE(1:NVEG, 2) = SAI_FEB(1:NVEG) + SAIM_TABLE(1:NVEG, 3) = SAI_MAR(1:NVEG) + SAIM_TABLE(1:NVEG, 4) = SAI_APR(1:NVEG) + SAIM_TABLE(1:NVEG, 5) = SAI_MAY(1:NVEG) + SAIM_TABLE(1:NVEG, 6) = SAI_JUN(1:NVEG) + SAIM_TABLE(1:NVEG, 7) = SAI_JUL(1:NVEG) + SAIM_TABLE(1:NVEG, 8) = SAI_AUG(1:NVEG) + SAIM_TABLE(1:NVEG, 9) = SAI_SEP(1:NVEG) + SAIM_TABLE(1:NVEG,10) = SAI_OCT(1:NVEG) + SAIM_TABLE(1:NVEG,11) = SAI_NOV(1:NVEG) + SAIM_TABLE(1:NVEG,12) = SAI_DEC(1:NVEG) + + LAIM_TABLE(1:NVEG, 1) = LAI_JAN(1:NVEG) + LAIM_TABLE(1:NVEG, 2) = LAI_FEB(1:NVEG) + LAIM_TABLE(1:NVEG, 3) = LAI_MAR(1:NVEG) + LAIM_TABLE(1:NVEG, 4) = LAI_APR(1:NVEG) + LAIM_TABLE(1:NVEG, 5) = LAI_MAY(1:NVEG) + LAIM_TABLE(1:NVEG, 6) = LAI_JUN(1:NVEG) + LAIM_TABLE(1:NVEG, 7) = LAI_JUL(1:NVEG) + LAIM_TABLE(1:NVEG, 8) = LAI_AUG(1:NVEG) + LAIM_TABLE(1:NVEG, 9) = LAI_SEP(1:NVEG) + LAIM_TABLE(1:NVEG,10) = LAI_OCT(1:NVEG) + LAIM_TABLE(1:NVEG,11) = LAI_NOV(1:NVEG) + LAIM_TABLE(1:NVEG,12) = LAI_DEC(1:NVEG) + + RHOL_TABLE(1:NVEG,1) = RHOL_VIS(1:NVEG) !leaf reflectance: 1=vis, 2=nir + RHOL_TABLE(1:NVEG,2) = RHOL_NIR(1:NVEG) !leaf reflectance: 1=vis, 2=nir + RHOS_TABLE(1:NVEG,1) = RHOS_VIS(1:NVEG) !stem reflectance: 1=vis, 2=nir + RHOS_TABLE(1:NVEG,2) = RHOS_NIR(1:NVEG) !stem reflectance: 1=vis, 2=nir + TAUL_TABLE(1:NVEG,1) = TAUL_VIS(1:NVEG) !leaf transmittance: 1=vis, 2=nir + TAUL_TABLE(1:NVEG,2) = TAUL_NIR(1:NVEG) !leaf transmittance: 1=vis, 2=nir + TAUS_TABLE(1:NVEG,1) = TAUS_VIS(1:NVEG) !stem transmittance: 1=vis, 2=nir + TAUS_TABLE(1:NVEG,2) = TAUS_NIR(1:NVEG) !stem transmittance: 1=vis, 2=nir + + end subroutine read_mp_veg_parameters + + subroutine read_mp_soil_parameters() + IMPLICIT NONE + INTEGER :: IERR + CHARACTER*4 :: SLTYPE + INTEGER :: ITMP, NUM_SLOPE, LC + CHARACTER(len=256) :: message + logical :: file_named + + + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + BEXP_TABLE = -1.E36 + SMCDRY_TABLE = -1.E36 + F1_TABLE = -1.E36 + SMCMAX_TABLE = -1.E36 + SMCREF_TABLE = -1.E36 + PSISAT_TABLE = -1.E36 + DKSAT_TABLE = -1.E36 + DWSAT_TABLE = -1.E36 + SMCWLT_TABLE = -1.E36 + QUARTZ_TABLE = -1.E36 + SLOPE_TABLE = -1.E36 + CSOIL_TABLE = -1.E36 + REFDK_TABLE = -1.E36 + REFKDT_TABLE = -1.E36 + FRZK_TABLE = -1.E36 + ZBOT_TABLE = -1.E36 + CZIL_TABLE = -1.E36 + +! +!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL +! + inquire( file='SOILPARM.TBL', exist=file_named ) + if ( file_named ) then + open(21, file='SOILPARM.TBL',form='formatted',status='old',iostat=ierr) + else + open(21, form='formatted',status='old',iostat=ierr) + end if + + IF(ierr .NE. 0 ) THEN + WRITE(message,FMT='(A)') 'module_sf_noahmpdrv.F: read_mp_soil_parameters: failure opening SOILPARM.TBL' + STOP +! CALL wrf_error_fatal ( message ) + END IF + + READ (21,*) + READ (21,*) SLTYPE + READ (21,*) SLCATS + IF (this_image()==1) THEN + WRITE( message , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', & + SLCATS,' CATEGORIES' + ENDIF +! CALL wrf_message ( message ) + + DO LC=1,SLCATS + READ (21,*) ITMP,BEXP_TABLE(LC),SMCDRY_TABLE(LC),F1_TABLE(LC),SMCMAX_TABLE(LC), & + SMCREF_TABLE(LC),PSISAT_TABLE(LC),DKSAT_TABLE(LC), DWSAT_TABLE(LC), & + SMCWLT_TABLE(LC), QUARTZ_TABLE(LC) + ENDDO + + CLOSE (21) + +! +!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL +! + inquire( file='GENPARM.TBL', exist=file_named ) + if ( file_named ) then + open(22, file='GENPARM.TBL',form='formatted',status='old',iostat=ierr) + else + open(22, form='formatted',status='old',iostat=ierr) + end if + + IF(ierr .NE. 0 ) THEN + WRITE(message,FMT='(A)') 'module_sf_noahlsm.F: read_mp_soil_parameters: failure opening GENPARM.TBL' + STOP +! CALL wrf_error_fatal ( message ) + END IF + + READ (22,*) + READ (22,*) + READ (22,*) NUM_SLOPE + + DO LC=1,NUM_SLOPE + READ (22,*) SLOPE_TABLE(LC) + ENDDO + + READ (22,*) + READ (22,*) + READ (22,*) + READ (22,*) + READ (22,*) + READ (22,*) CSOIL_TABLE + READ (22,*) + READ (22,*) + READ (22,*) + READ (22,*) REFDK_TABLE + READ (22,*) + READ (22,*) REFKDT_TABLE + READ (22,*) + READ (22,*) FRZK_TABLE + READ (22,*) + READ (22,*) ZBOT_TABLE + READ (22,*) + READ (22,*) CZIL_TABLE + READ (22,*) + READ (22,*) + READ (22,*) + READ (22,*) + + CLOSE (22) + + end subroutine read_mp_soil_parameters + + subroutine read_mp_rad_parameters() + implicit none + integer :: ierr + logical :: file_named + + REAL :: ALBICE(MBAND),ALBLAK(MBAND),OMEGAS(MBAND),BETADS,BETAIS,EG(2) + REAL :: ALBSAT_VIS(MSC) + REAL :: ALBSAT_NIR(MSC) + REAL :: ALBDRY_VIS(MSC) + REAL :: ALBDRY_NIR(MSC) + + NAMELIST / noahmp_rad_parameters / ALBSAT_VIS,ALBSAT_NIR,ALBDRY_VIS,ALBDRY_NIR,ALBICE,ALBLAK,OMEGAS,BETADS,BETAIS,EG + + + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + ALBSAT_TABLE = -1.E36 + ALBDRY_TABLE = -1.E36 + ALBICE_TABLE = -1.E36 + ALBLAK_TABLE = -1.E36 + OMEGAS_TABLE = -1.E36 + BETADS_TABLE = -1.E36 + BETAIS_TABLE = -1.E36 + EG_TABLE = -1.E36 + + inquire( file='MPTABLE.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file MPTABLE.TBL")') + write(*,*) "STOP in Noah-MP read_mp_rad_parameters" + STOP + ! call wrf_error_fatal("STOP in Noah-MP read_mp_rad_parameters") + endif + + read(15,noahmp_rad_parameters) + close(15) + + ALBSAT_TABLE(:,1) = ALBSAT_VIS ! saturated soil albedos: 1=vis, 2=nir + ALBSAT_TABLE(:,2) = ALBSAT_NIR ! saturated soil albedos: 1=vis, 2=nir + ALBDRY_TABLE(:,1) = ALBDRY_VIS ! dry soil albedos: 1=vis, 2=nir + ALBDRY_TABLE(:,2) = ALBDRY_NIR ! dry soil albedos: 1=vis, 2=nir + ALBICE_TABLE = ALBICE + ALBLAK_TABLE = ALBLAK + OMEGAS_TABLE = OMEGAS + BETADS_TABLE = BETADS + BETAIS_TABLE = BETAIS + EG_TABLE = EG + + end subroutine read_mp_rad_parameters + + subroutine read_mp_global_parameters() + implicit none + integer :: ierr + logical :: file_named + + REAL :: CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC,SNOW_EMIS,& + SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& + BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& + RSURF_SNOW,RSURF_EXP + + NAMELIST / noahmp_global_parameters / CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC,SNOW_EMIS,& + SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& + BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& + RSURF_SNOW,RSURF_EXP + + + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + CO2_TABLE = -1.E36 + O2_TABLE = -1.E36 + TIMEAN_TABLE = -1.E36 + FSATMX_TABLE = -1.E36 + Z0SNO_TABLE = -1.E36 + SSI_TABLE = -1.E36 +SNOW_RET_FAC_TABLE = -1.E36 + SNOW_EMIS_TABLE = -1.E36 + SWEMX_TABLE = -1.E36 + TAU0_TABLE = -1.E36 +GRAIN_GROWTH_TABLE = -1.E36 +EXTRA_GROWTH_TABLE = -1.E36 + DIRT_SOOT_TABLE = -1.E36 + BATS_COSZ_TABLE = -1.E36 +BATS_VIS_NEW_TABLE = -1.E36 +BATS_NIR_NEW_TABLE = -1.E36 +BATS_VIS_AGE_TABLE = -1.E36 +BATS_NIR_AGE_TABLE = -1.E36 +BATS_VIS_DIR_TABLE = -1.E36 +BATS_NIR_DIR_TABLE = -1.E36 +RSURF_SNOW_TABLE = -1.E36 + RSURF_EXP_TABLE = -1.E36 + + inquire( file='MPTABLE.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file MPTABLE.TBL")') + WRITE(*,*) "STOP in Noah-MP read_mp_global_parameters" + STOP +! call wrf_error_fatal("STOP in Noah-MP read_mp_global_parameters") + endif + + read(15,noahmp_global_parameters) + close(15) + + CO2_TABLE = CO2 + O2_TABLE = O2 + TIMEAN_TABLE = TIMEAN + FSATMX_TABLE = FSATMX + Z0SNO_TABLE = Z0SNO + SSI_TABLE = SSI +SNOW_RET_FAC_TABLE = SNOW_RET_FAC + SNOW_EMIS_TABLE = SNOW_EMIS + SWEMX_TABLE = SWEMX + TAU0_TABLE = TAU0 +GRAIN_GROWTH_TABLE = GRAIN_GROWTH +EXTRA_GROWTH_TABLE = EXTRA_GROWTH + DIRT_SOOT_TABLE = DIRT_SOOT + BATS_COSZ_TABLE = BATS_COSZ +BATS_VIS_NEW_TABLE = BATS_VIS_NEW +BATS_NIR_NEW_TABLE = BATS_NIR_NEW +BATS_VIS_AGE_TABLE = BATS_VIS_AGE +BATS_NIR_AGE_TABLE = BATS_NIR_AGE +BATS_VIS_DIR_TABLE = BATS_VIS_DIR +BATS_NIR_DIR_TABLE = BATS_NIR_DIR +RSURF_SNOW_TABLE = RSURF_SNOW + RSURF_EXP_TABLE = RSURF_EXP + + end subroutine read_mp_global_parameters + + subroutine read_mp_crop_parameters() + implicit none + integer :: ierr + logical :: file_named + + INTEGER :: DEFAULT_CROP + INTEGER, DIMENSION(NCROP) :: PLTDAY + INTEGER, DIMENSION(NCROP) :: HSDAY + REAL, DIMENSION(NCROP) :: PLANTPOP + REAL, DIMENSION(NCROP) :: IRRI + REAL, DIMENSION(NCROP) :: GDDTBASE + REAL, DIMENSION(NCROP) :: GDDTCUT + REAL, DIMENSION(NCROP) :: GDDS1 + REAL, DIMENSION(NCROP) :: GDDS2 + REAL, DIMENSION(NCROP) :: GDDS3 + REAL, DIMENSION(NCROP) :: GDDS4 + REAL, DIMENSION(NCROP) :: GDDS5 + REAL, DIMENSION(NCROP) :: C3PSN ! this session copied from stomata parameters Zhe Zhang 2020-07-13 + REAL, DIMENSION(NCROP) :: KC25 + REAL, DIMENSION(NCROP) :: AKC + REAL, DIMENSION(NCROP) :: KO25 + REAL, DIMENSION(NCROP) :: AKO + REAL, DIMENSION(NCROP) :: AVCMX + REAL, DIMENSION(NCROP) :: VCMX25 + REAL, DIMENSION(NCROP) :: BP + REAL, DIMENSION(NCROP) :: MP + REAL, DIMENSION(NCROP) :: FOLNMX + REAL, DIMENSION(NCROP) :: QE25 ! until here + INTEGER, DIMENSION(NCROP) :: C3C4 + REAL, DIMENSION(NCROP) :: AREF + REAL, DIMENSION(NCROP) :: PSNRF + REAL, DIMENSION(NCROP) :: I2PAR + REAL, DIMENSION(NCROP) :: TASSIM0 + REAL, DIMENSION(NCROP) :: TASSIM1 + REAL, DIMENSION(NCROP) :: TASSIM2 + REAL, DIMENSION(NCROP) :: K + REAL, DIMENSION(NCROP) :: EPSI + REAL, DIMENSION(NCROP) :: Q10MR + REAL, DIMENSION(NCROP) :: FOLN_MX + REAL, DIMENSION(NCROP) :: LEFREEZ + REAL, DIMENSION(NCROP) :: DILE_FC_S1,DILE_FC_S2,DILE_FC_S3,DILE_FC_S4,DILE_FC_S5,DILE_FC_S6,DILE_FC_S7,DILE_FC_S8 + REAL, DIMENSION(NCROP) :: DILE_FW_S1,DILE_FW_S2,DILE_FW_S3,DILE_FW_S4,DILE_FW_S5,DILE_FW_S6,DILE_FW_S7,DILE_FW_S8 + REAL, DIMENSION(NCROP) :: FRA_GR + REAL, DIMENSION(NCROP) :: LF_OVRC_S1,LF_OVRC_S2,LF_OVRC_S3,LF_OVRC_S4,LF_OVRC_S5,LF_OVRC_S6,LF_OVRC_S7,LF_OVRC_S8 + REAL, DIMENSION(NCROP) :: ST_OVRC_S1,ST_OVRC_S2,ST_OVRC_S3,ST_OVRC_S4,ST_OVRC_S5,ST_OVRC_S6,ST_OVRC_S7,ST_OVRC_S8 + REAL, DIMENSION(NCROP) :: RT_OVRC_S1,RT_OVRC_S2,RT_OVRC_S3,RT_OVRC_S4,RT_OVRC_S5,RT_OVRC_S6,RT_OVRC_S7,RT_OVRC_S8 + REAL, DIMENSION(NCROP) :: LFMR25 + REAL, DIMENSION(NCROP) :: STMR25 + REAL, DIMENSION(NCROP) :: RTMR25 + REAL, DIMENSION(NCROP) :: GRAINMR25 + REAL, DIMENSION(NCROP) :: LFPT_S1,LFPT_S2,LFPT_S3,LFPT_S4,LFPT_S5,LFPT_S6,LFPT_S7,LFPT_S8 + REAL, DIMENSION(NCROP) :: STPT_S1,STPT_S2,STPT_S3,STPT_S4,STPT_S5,STPT_S6,STPT_S7,STPT_S8 + REAL, DIMENSION(NCROP) :: RTPT_S1,RTPT_S2,RTPT_S3,RTPT_S4,RTPT_S5,RTPT_S6,RTPT_S7,RTPT_S8 + REAL, DIMENSION(NCROP) :: GRAINPT_S1,GRAINPT_S2,GRAINPT_S3,GRAINPT_S4,GRAINPT_S5,GRAINPT_S6,GRAINPT_S7,GRAINPT_S8 + REAL, DIMENSION(NCROP) :: LFCT_S1,LFCT_S2,LFCT_S3,LFCT_S4,LFCT_S5,LFCT_S6,LFCT_S7,LFCT_S8 + REAL, DIMENSION(NCROP) :: STCT_S1,STCT_S2,STCT_S3,STCT_S4,STCT_S5,STCT_S6,STCT_S7,STCT_S8 + REAL, DIMENSION(NCROP) :: RTCT_S1,RTCT_S2,RTCT_S3,RTCT_S4,RTCT_S5,RTCT_S6,RTCT_S7,RTCT_S8 + REAL, DIMENSION(NCROP) :: BIO2LAI + + +! NAMELIST / noahmp_crop_parameters /DEFAULT_CROP, PLTDAY, HSDAY, PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2, & +! GDDS3, GDDS4, GDDS5, C3C4, AREF, PSNRF, I2PAR, TASSIM0, & +! TASSIM1, TASSIM2, K, EPSI, Q10MR, FOLN_MX, LEFREEZ, & +! Zhe Zhang 2020-07-13 + NAMELIST / noahmp_crop_parameters /DEFAULT_CROP, PLTDAY, HSDAY, PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2, GDDS3, GDDS4, GDDS5, & ! + C3PSN, KC25, AKC, KO25, AKO, AVCMX, VCMX25, BP, MP, FOLNMX, QE25, & ! parameters added from stomata + C3C4, AREF, PSNRF, I2PAR, TASSIM0, & + TASSIM1, TASSIM2, K, EPSI, Q10MR, FOLN_MX, LEFREEZ, & + DILE_FC_S1,DILE_FC_S2,DILE_FC_S3,DILE_FC_S4,DILE_FC_S5,DILE_FC_S6,DILE_FC_S7,DILE_FC_S8, & + DILE_FW_S1,DILE_FW_S2,DILE_FW_S3,DILE_FW_S4,DILE_FW_S5,DILE_FW_S6,DILE_FW_S7,DILE_FW_S8, & + FRA_GR, & + LF_OVRC_S1,LF_OVRC_S2,LF_OVRC_S3,LF_OVRC_S4,LF_OVRC_S5,LF_OVRC_S6,LF_OVRC_S7,LF_OVRC_S8, & + ST_OVRC_S1,ST_OVRC_S2,ST_OVRC_S3,ST_OVRC_S4,ST_OVRC_S5,ST_OVRC_S6,ST_OVRC_S7,ST_OVRC_S8, & + RT_OVRC_S1,RT_OVRC_S2,RT_OVRC_S3,RT_OVRC_S4,RT_OVRC_S5,RT_OVRC_S6,RT_OVRC_S7,RT_OVRC_S8, & + LFMR25, STMR25, RTMR25, GRAINMR25, & + LFPT_S1, LFPT_S2, LFPT_S3, LFPT_S4, LFPT_S5, LFPT_S6, LFPT_S7, LFPT_S8, & + STPT_S1, STPT_S2, STPT_S3, STPT_S4, STPT_S5, STPT_S6, STPT_S7, STPT_S8, & + RTPT_S1, RTPT_S2, RTPT_S3, RTPT_S4, RTPT_S5, RTPT_S6, RTPT_S7, RTPT_S8, & + GRAINPT_S1,GRAINPT_S2,GRAINPT_S3,GRAINPT_S4,GRAINPT_S5,GRAINPT_S6,GRAINPT_S7,GRAINPT_S8, & + LFCT_S1,LFCT_S2,LFCT_S3,LFCT_S4,LFCT_S5,LFCT_S6,LFCT_S7,LFCT_S8, & + STCT_S1,STCT_S2,STCT_S3,STCT_S4,STCT_S5,STCT_S6,STCT_S7,STCT_S8, & + RTCT_S1,RTCT_S2,RTCT_S3,RTCT_S4,RTCT_S5,RTCT_S6,RTCT_S7,RTCT_S8, & + BIO2LAI + + + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + DEFAULT_CROP_TABLE = -99999 + PLTDAY_TABLE = -99999 + HSDAY_TABLE = -99999 + PLANTPOP_TABLE = -1.E36 + IRRI_TABLE = -1.E36 + GDDTBASE_TABLE = -1.E36 + GDDTCUT_TABLE = -1.E36 + GDDS1_TABLE = -1.E36 + GDDS2_TABLE = -1.E36 + GDDS3_TABLE = -1.E36 + GDDS4_TABLE = -1.E36 + GDDS5_TABLE = -1.E36 + C3PSNI_TABLE = -1.E36 ! parameter from PSN copied from stomata ! Zhe Zhang 2020-07-13 + KC25I_TABLE = -1.E36 + AKCI_TABLE = -1.E36 + KO25I_TABLE = -1.E36 + AKOI_TABLE = -1.E36 + AVCMXI_TABLE = -1.E36 + VCMX25I_TABLE = -1.E36 + BPI_TABLE = -1.E36 + MPI_TABLE = -1.E36 + FOLNMXI_TABLE = -1.E36 + QE25I_TABLE = -1.E36 ! ends here + C3C4_TABLE = -99999 + AREF_TABLE = -1.E36 + PSNRF_TABLE = -1.E36 + I2PAR_TABLE = -1.E36 + TASSIM0_TABLE = -1.E36 + TASSIM1_TABLE = -1.E36 + TASSIM2_TABLE = -1.E36 + K_TABLE = -1.E36 + EPSI_TABLE = -1.E36 + Q10MR_TABLE = -1.E36 + FOLN_MX_TABLE = -1.E36 + LEFREEZ_TABLE = -1.E36 + DILE_FC_TABLE = -1.E36 + DILE_FW_TABLE = -1.E36 + FRA_GR_TABLE = -1.E36 + LF_OVRC_TABLE = -1.E36 + ST_OVRC_TABLE = -1.E36 + RT_OVRC_TABLE = -1.E36 + LFMR25_TABLE = -1.E36 + STMR25_TABLE = -1.E36 + RTMR25_TABLE = -1.E36 + GRAINMR25_TABLE = -1.E36 + LFPT_TABLE = -1.E36 + STPT_TABLE = -1.E36 + RTPT_TABLE = -1.E36 + GRAINPT_TABLE = -1.E36 + LFCT_TABLE = -1.E36 ! convert start + STCT_TABLE = -1.E36 + RTCT_TABLE = -1.E36 ! convert end + BIO2LAI_TABLE = -1.E36 + + + inquire( file='MPTABLE.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file MPTABLE.TBL")') + write(*,*) "STOP in Noah-MP read_mp_crop_parameters" + STOP + !call wrf_error_fatal("STOP in Noah-MP read_mp_crop_parameters") + endif + + read(15,noahmp_crop_parameters) + close(15) + + DEFAULT_CROP_TABLE = DEFAULT_CROP + PLTDAY_TABLE = PLTDAY + HSDAY_TABLE = HSDAY + PLANTPOP_TABLE = PLANTPOP + IRRI_TABLE = IRRI + GDDTBASE_TABLE = GDDTBASE + GDDTCUT_TABLE = GDDTCUT + GDDS1_TABLE = GDDS1 + GDDS2_TABLE = GDDS2 + GDDS3_TABLE = GDDS3 + GDDS4_TABLE = GDDS4 + GDDS5_TABLE = GDDS5 + C3PSNI_TABLE(1:5) = C3PSN(1:5) ! parameters from stomata ! Zhe Zhang 2020-07-13 + KC25I_TABLE(1:5) = KC25(1:5) + AKCI_TABLE(1:5) = AKC(1:5) + KO25I_TABLE(1:5) = KO25(1:5) + AKOI_TABLE(1:5) = AKO(1:5) + AVCMXI_TABLE(1:5) = AVCMX(1:5) + VCMX25I_TABLE(1:5) = VCMX25(1:5) + BPI_TABLE(1:5) = BP(1:5) + MPI_TABLE(1:5) = MP(1:5) + FOLNMXI_TABLE(1:5) = FOLNMX(1:5) + QE25I_TABLE(1:5) = QE25(1:5) ! ends here + C3C4_TABLE = C3C4 + AREF_TABLE = AREF + PSNRF_TABLE = PSNRF + I2PAR_TABLE = I2PAR + TASSIM0_TABLE = TASSIM0 + TASSIM1_TABLE = TASSIM1 + TASSIM2_TABLE = TASSIM2 + K_TABLE = K + EPSI_TABLE = EPSI + Q10MR_TABLE = Q10MR + FOLN_MX_TABLE = FOLN_MX + LEFREEZ_TABLE = LEFREEZ + DILE_FC_TABLE(:,1) = DILE_FC_S1 + DILE_FC_TABLE(:,2) = DILE_FC_S2 + DILE_FC_TABLE(:,3) = DILE_FC_S3 + DILE_FC_TABLE(:,4) = DILE_FC_S4 + DILE_FC_TABLE(:,5) = DILE_FC_S5 + DILE_FC_TABLE(:,6) = DILE_FC_S6 + DILE_FC_TABLE(:,7) = DILE_FC_S7 + DILE_FC_TABLE(:,8) = DILE_FC_S8 + DILE_FW_TABLE(:,1) = DILE_FW_S1 + DILE_FW_TABLE(:,2) = DILE_FW_S2 + DILE_FW_TABLE(:,3) = DILE_FW_S3 + DILE_FW_TABLE(:,4) = DILE_FW_S4 + DILE_FW_TABLE(:,5) = DILE_FW_S5 + DILE_FW_TABLE(:,6) = DILE_FW_S6 + DILE_FW_TABLE(:,7) = DILE_FW_S7 + DILE_FW_TABLE(:,8) = DILE_FW_S8 + FRA_GR_TABLE = FRA_GR + LF_OVRC_TABLE(:,1) = LF_OVRC_S1 + LF_OVRC_TABLE(:,2) = LF_OVRC_S2 + LF_OVRC_TABLE(:,3) = LF_OVRC_S3 + LF_OVRC_TABLE(:,4) = LF_OVRC_S4 + LF_OVRC_TABLE(:,5) = LF_OVRC_S5 + LF_OVRC_TABLE(:,6) = LF_OVRC_S6 + LF_OVRC_TABLE(:,7) = LF_OVRC_S7 + LF_OVRC_TABLE(:,8) = LF_OVRC_S8 + ST_OVRC_TABLE(:,1) = ST_OVRC_S1 + ST_OVRC_TABLE(:,2) = ST_OVRC_S2 + ST_OVRC_TABLE(:,3) = ST_OVRC_S3 + ST_OVRC_TABLE(:,4) = ST_OVRC_S4 + ST_OVRC_TABLE(:,5) = ST_OVRC_S5 + ST_OVRC_TABLE(:,6) = ST_OVRC_S6 + ST_OVRC_TABLE(:,7) = ST_OVRC_S7 + ST_OVRC_TABLE(:,8) = ST_OVRC_S8 + RT_OVRC_TABLE(:,1) = RT_OVRC_S1 + RT_OVRC_TABLE(:,2) = RT_OVRC_S2 + RT_OVRC_TABLE(:,3) = RT_OVRC_S3 + RT_OVRC_TABLE(:,4) = RT_OVRC_S4 + RT_OVRC_TABLE(:,5) = RT_OVRC_S5 + RT_OVRC_TABLE(:,6) = RT_OVRC_S6 + RT_OVRC_TABLE(:,7) = RT_OVRC_S7 + RT_OVRC_TABLE(:,8) = RT_OVRC_S8 + LFMR25_TABLE = LFMR25 + STMR25_TABLE = STMR25 + RTMR25_TABLE = RTMR25 + GRAINMR25_TABLE = GRAINMR25 + LFPT_TABLE(:,1) = LFPT_S1 + LFPT_TABLE(:,2) = LFPT_S2 + LFPT_TABLE(:,3) = LFPT_S3 + LFPT_TABLE(:,4) = LFPT_S4 + LFPT_TABLE(:,5) = LFPT_S5 + LFPT_TABLE(:,6) = LFPT_S6 + LFPT_TABLE(:,7) = LFPT_S7 + LFPT_TABLE(:,8) = LFPT_S8 + STPT_TABLE(:,1) = STPT_S1 + STPT_TABLE(:,2) = STPT_S2 + STPT_TABLE(:,3) = STPT_S3 + STPT_TABLE(:,4) = STPT_S4 + STPT_TABLE(:,5) = STPT_S5 + STPT_TABLE(:,6) = STPT_S6 + STPT_TABLE(:,7) = STPT_S7 + STPT_TABLE(:,8) = STPT_S8 + RTPT_TABLE(:,1) = RTPT_S1 + RTPT_TABLE(:,2) = RTPT_S2 + RTPT_TABLE(:,3) = RTPT_S3 + RTPT_TABLE(:,4) = RTPT_S4 + RTPT_TABLE(:,5) = RTPT_S5 + RTPT_TABLE(:,6) = RTPT_S6 + RTPT_TABLE(:,7) = RTPT_S7 + RTPT_TABLE(:,8) = RTPT_S8 + GRAINPT_TABLE(:,1) = GRAINPT_S1 + GRAINPT_TABLE(:,2) = GRAINPT_S2 + GRAINPT_TABLE(:,3) = GRAINPT_S3 + GRAINPT_TABLE(:,4) = GRAINPT_S4 + GRAINPT_TABLE(:,5) = GRAINPT_S5 + GRAINPT_TABLE(:,6) = GRAINPT_S6 + GRAINPT_TABLE(:,7) = GRAINPT_S7 + GRAINPT_TABLE(:,8) = GRAINPT_S8 + LFCT_TABLE(:,1) = LFCT_S1 + LFCT_TABLE(:,2) = LFCT_S2 + LFCT_TABLE(:,3) = LFCT_S3 + LFCT_TABLE(:,4) = LFCT_S4 + LFCT_TABLE(:,5) = LFCT_S5 + LFCT_TABLE(:,6) = LFCT_S6 + LFCT_TABLE(:,7) = LFCT_S7 + LFCT_TABLE(:,8) = LFCT_S8 + STCT_TABLE(:,1) = STCT_S1 + STCT_TABLE(:,2) = STCT_S2 + STCT_TABLE(:,3) = STCT_S3 + STCT_TABLE(:,4) = STCT_S4 + STCT_TABLE(:,5) = STCT_S5 + STCT_TABLE(:,6) = STCT_S6 + STCT_TABLE(:,7) = STCT_S7 + STCT_TABLE(:,8) = STCT_S8 + RTCT_TABLE(:,1) = RTCT_S1 + RTCT_TABLE(:,2) = RTCT_S2 + RTCT_TABLE(:,3) = RTCT_S3 + RTCT_TABLE(:,4) = RTCT_S4 + RTCT_TABLE(:,5) = RTCT_S5 + RTCT_TABLE(:,6) = RTCT_S6 + RTCT_TABLE(:,7) = RTCT_S7 + RTCT_TABLE(:,8) = RTCT_S8 + BIO2LAI_TABLE = BIO2LAI + + end subroutine read_mp_crop_parameters + + subroutine read_mp_irrigation_parameters() + implicit none + integer :: ierr + logical :: file_named + + REAL :: IRR_FRAC ! irrigation Fraction + INTEGER :: IRR_HAR ! number of days before harvest date to stop irrigation + REAL :: IRR_LAI ! Minimum lai to trigger irrigation + REAL :: IRR_MAD ! management allowable deficit (0-1) + REAL :: FILOSS ! fraction of flood irrigation loss (0-1) + REAL :: SPRIR_RATE ! mm/h, sprinkler irrigation rate + REAL :: MICIR_RATE ! mm/h, micro irrigation rate + REAL :: FIRTFAC ! flood application rate factor + REAL :: IR_RAIN ! maximum precipitation to stop irrigation trigger + + NAMELIST / noahmp_irrigation_parameters / IRR_FRAC, IRR_HAR, IRR_LAI, IRR_MAD, FILOSS, & + SPRIR_RATE, MICIR_RATE, FIRTFAC, IR_RAIN + + IRR_FRAC_TABLE = -1.E36 ! irrigation Fraction + IRR_HAR_TABLE = 0 ! number of days before harvest date to stop irrigation + IRR_LAI_TABLE = -1.E36 ! Minimum lai to trigger irrigation + IRR_MAD_TABLE = -1.E36 ! management allowable deficit (0-1) + FILOSS_TABLE = -1.E36 ! fraction of flood irrigation loss (0-1) + SPRIR_RATE_TABLE = -1.E36 ! mm/h, sprinkler irrigation rate + MICIR_RATE_TABLE = -1.E36 ! mm/h, micro irrigation rate + FIRTFAC_TABLE = -1.E36 ! flood application rate factor + IR_RAIN_TABLE = -1.E36 ! maximum precipitation to stop irrigation trigger + + inquire( file='MPTABLE.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file MPTABLE.TBL")') + write(*,*) "STOP in Noah-MP read_mp_crop_parameters" + STOP +! call wrf_error_fatal("STOP in Noah-MP read_mp_crop_parameters") + endif + + read(15,noahmp_irrigation_parameters) + close(15) + + IRR_FRAC_TABLE = IRR_FRAC ! irrigation Fraction + IRR_HAR_TABLE = IRR_HAR ! number of days before harvest date to stop irrigation + IRR_LAI_TABLE = IRR_LAI ! Minimum lai to trigger irrigation + IRR_MAD_TABLE = IRR_MAD ! management allowable deficit (0-1) + FILOSS_TABLE = FILOSS ! fraction of flood irrigation loss (0-1) + SPRIR_RATE_TABLE = SPRIR_RATE ! mm/h, sprinkler irrigation rate + MICIR_RATE_TABLE = MICIR_RATE ! mm/h, micro irrigation rate + FIRTFAC_TABLE = FIRTFAC ! flood application rate factor + IR_RAIN_TABLE = IR_RAIN ! maximum precipitation to stop irrigation trigger + + end subroutine read_mp_irrigation_parameters + + subroutine read_mp_optional_parameters() + implicit none + integer :: ierr + logical :: file_named + + NAMELIST / noahmp_optional_parameters / & + sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & + sr2006_theta_1500t_g , & + sr2006_theta_1500_a , sr2006_theta_1500_b , & + sr2006_theta_33t_a , sr2006_theta_33t_b , sr2006_theta_33t_c , & + sr2006_theta_33t_d , sr2006_theta_33t_e , sr2006_theta_33t_f , & + sr2006_theta_33t_g , & + sr2006_theta_33_a , sr2006_theta_33_b , sr2006_theta_33_c , & + sr2006_theta_s33t_a , sr2006_theta_s33t_b , sr2006_theta_s33t_c , & + sr2006_theta_s33t_d , sr2006_theta_s33t_e , sr2006_theta_s33t_f , & + sr2006_theta_s33t_g , & + sr2006_theta_s33_a , sr2006_theta_s33_b , & + sr2006_psi_et_a , sr2006_psi_et_b , sr2006_psi_et_c , & + sr2006_psi_et_d , sr2006_psi_et_e , sr2006_psi_et_f , & + sr2006_psi_et_g , & + sr2006_psi_e_a , sr2006_psi_e_b , sr2006_psi_e_c , & + sr2006_smcmax_a , sr2006_smcmax_b + + inquire( file='MPTABLE.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file MPTABLE.TBL")') + WRITE(*,*) "STOP in Noah-MP read_mp_optional_parameters" + STOP +! call wrf_error_fatal("STOP in Noah-MP read_mp_optional_parameters") + endif + + read(15,noahmp_optional_parameters) + close(15) + + + end subroutine read_mp_optional_parameters + +END MODULE NOAHMP_TABLES diff --git a/src/physics/mp_driver.f90 b/src/physics/mp_driver.f90 index 54223d63..26737c7e 100644 --- a/src/physics/mp_driver.f90 +++ b/src/physics/mp_driver.f90 @@ -32,7 +32,8 @@ module microphysics use module_mp_thompson_aer, only: mp_gt_driver_aer, thompson_aer_init use module_mp_thompson, only: mp_gt_driver, thompson_init ! use module_mp_morr_two_moment, only: MORR_TWO_MOMENT_INIT, MP_MORR_TWO_MOMENT - use module_mp_wsm6, only: wsm6, wsm6init + use module_mp_wsm6, only: wsm6, wsm6init + use module_mp_wsm3, only: wsm3, wsm3init use module_mp_simple, only: mp_simple_driver, mp_simple_var_request use time_object, only: Time_type use options_interface, only: options_t @@ -44,7 +45,7 @@ module microphysics integer :: update_interval real*8 :: last_model_time ! temporary variables - real,allocatable,dimension(:,:) :: SR, last_rain, last_snow, this_precip,refl_10cm + real,allocatable,dimension(:,:) :: SR, last_rain, last_snow, this_precip, this_snow,refl_10cm ! microphysics specific flag. If it returns the current hourly precip (e.g. Morrison), then set this to false. @@ -93,9 +94,16 @@ subroutine mp_init(options) ! write(*,*) " Morrison Microphysics" ! call MORR_TWO_MOMENT_INIT(hail_opt=0) ! precip_delta=.False. + elseif (options%physics%microphysics==kMP_WSM6) then if (this_image()==1) write(*,*) " WSM6 Microphysics" call wsm6init(rhoair0,rhowater,rhosnow,cliq,cpv) + precip_delta=.True. + + elseif (options%physics%microphysics==kMP_WSM3) then + if (this_image()==1) write(*,*) " WSM3 Microphysics" + call wsm3init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read=.True.) + precip_delta=.True. endif update_interval = options%mp_options%update_interval @@ -114,7 +122,7 @@ subroutine mp_thompson_aer_var_request(options) kVARS%water_vapor, kVARS%cloud_water, kVARS%rain_in_air, kVARS%rain_number_concentration, & kVARS%snow_in_air, kVARS%cloud_ice, kVARS%w, kVARS%ice_number_concentration, & kVARS%snowfall, kVARS%precipitation, kVARS%graupel, kVARS%graupel_in_air, & - kVARS%dz ]) + kVARS%dz, kVARS%re_cloud, kVARS%re_ice, kVARS%re_snow ]) ! List the variables that are required to be advected for the simple microphysics call options%advect_vars( & @@ -128,8 +136,9 @@ subroutine mp_thompson_aer_var_request(options) kVARS%cloud_water, kVARS%rain_in_air, kVARS%snow_in_air, & kVARS%precipitation,kVARS%snowfall, kVARS%graupel, & kVARS%dz, kVARS%snow_in_air, kVARS%cloud_ice, & - kVARS%rain_number_concentration, kVARS%rain_in_air, & - kVARS%ice_number_concentration, kVARS%graupel_in_air ] ) + kVARS%rain_number_concentration, kVARS%rain_in_air, & + kVARS%ice_number_concentration, kVARS%graupel_in_air, & + kVARS%re_cloud, kVARS%re_ice, kVARS%re_snow ] ) end subroutine @@ -141,10 +150,9 @@ subroutine mp_wsm6_var_request(options) ! List the variables that are required to be allocated for the simple microphysics call options%alloc_vars( & [kVARS%pressure, kVARS%potential_temperature, kVARS%exner, kVARS%density, & - kVARS%water_vapor, kVARS%cloud_water, kVARS%rain_in_air, & - kVARS%snow_in_air, kVARS%cloud_ice, kVARS%w, & - kVARS%snowfall, kVARS%precipitation, kVARS%graupel, kVARS%graupel_in_air, & - kVARS%dz ]) + kVARS%water_vapor, kVARS%cloud_water, kVARS%rain_in_air, & + kVARS%snow_in_air, kVARS%cloud_ice, kVARS%dz, & + kVARS%snowfall, kVARS%precipitation, kVARS%graupel, kVARS%graupel_in_air ]) ! List the variables that are required to be advected for the simple microphysics call options%advect_vars( & @@ -161,6 +169,31 @@ subroutine mp_wsm6_var_request(options) kVARS%rain_in_air, kVARS%graupel_in_air ] ) + end subroutine + + subroutine mp_wsm3_var_request(options) + implicit none + type(options_t), intent(inout) :: options + + ! List the variables that are required to be allocated for the simple microphysics + call options%alloc_vars( & + [kVARS%pressure, kVARS%potential_temperature, kVARS%exner, kVARS%density, & + kVARS%water_vapor, kVARS%cloud_water, kVARS%rain_in_air, & + kVARS%dz, kVARS%snowfall, kVARS%precipitation ]) + + ! List the variables that are required to be advected for the simple microphysics + call options%advect_vars( & + [kVARS%potential_temperature, kVARS%water_vapor, kVARS%cloud_water, & + kVARS%rain_in_air ] ) + + ! List the variables that are required to be allocated for the simple microphysics + call options%restart_vars( & + [kVARS%pressure, kVARS%potential_temperature, kVARS%water_vapor, & + kVARS%cloud_water, kVARS%rain_in_air, kVARS%snow_in_air, & + kVARS%precipitation,kVARS%snowfall, kVARS%graupel, & + kVARS%dz, kVARS%rain_in_air ] ) + + end subroutine @@ -179,8 +212,18 @@ subroutine mp_var_request(options) elseif (options%physics%microphysics==kMP_MORRISON) then stop "Morrison physics not re-implemented yet" + elseif (options%physics%microphysics==kMP_WSM6) then call mp_wsm6_var_request(options) + + elseif (options%physics%microphysics==kMP_WSM3) then + call mp_wsm3_var_request(options) + + ! For the ideal test case(s), we need to be able to advect qv, without initializing microphysics: + elseif (options%parameters%ideal) then + if (this_image()==1) write(*,*) " allocating water vapor for ideal test case." + call options%alloc_vars( [kVARS%water_vapor] ) + call options%advect_vars( [kVARS%water_vapor] ) endif end subroutine mp_var_request @@ -210,6 +253,11 @@ subroutine allocate_module_variables(ims,ime,jms,jme,kms,kme) allocate(this_precip(ims:ime,jms:jme)) this_precip=0 endif + if (.not.allocated(this_snow)) then + allocate(this_snow(ims:ime,jms:jme)) + this_snow=0 + endif + if (.not.allocated(refl_10cm)) then allocate(refl_10cm(ims:ime,jms:jme)) refl_10cm=0 @@ -358,8 +406,11 @@ subroutine process_subdomain(domain, options, dt, & integer, intent(in) :: its,ite, jts,jte, kts,kte integer, intent(in) :: ims,ime, jms,jme, kms,kme integer, intent(in) :: ids,ide, jds,jde, kds,kde + real :: precipitation(ims:ime, jms:jme), graupel(ims:ime, jms:jme), snowfall(ims:ime, jms:jme) - + precipitation = 0 + graupel = 0 + snowfall = 0 ! run the thompson microphysics if (options%physics%microphysics==kMP_THOMPSON) then ! call the thompson microphysics @@ -377,11 +428,11 @@ subroutine process_subdomain(domain, options, dt, & dz = domain%dz_mass%data_3d, & dt_in = dt, & itimestep = 1, & ! not used in thompson - RAINNC = domain%accumulated_precipitation%data_2d, & + RAINNC = precipitation, & RAINNCV = this_precip, & ! not used outside thompson (yet) SR = SR, & ! not used outside thompson (yet) - SNOWNC = domain%accumulated_snowfall%data_2d, & - GRAUPELNC = domain%graupel%data_2d, & + SNOWNC = snowfall, & + GRAUPELNC = graupel, & ids = ids, ide = ide, & ! domain dims jds = jds, jde = jde, & kds = kds, kde = kde, & @@ -408,10 +459,13 @@ subroutine process_subdomain(domain, options, dt, & w = domain%w%data_3d, & dz = domain%dz_mass%data_3d, & dt_in = dt, & - RAINNC = domain%accumulated_precipitation%data_2d, & - SNOWNC = domain%accumulated_snowfall%data_2d, & - GRAUPELNC = domain%graupel%data_2d, & - has_reqc=0, has_reqi=0, has_reqs=0, & + RAINNC = precipitation, & + SNOWNC = snowfall, & + GRAUPELNC = graupel, & + re_cloud = domain%re_cloud%data_3d, & + re_ice = domain%re_ice%data_3d, & + re_snow = domain%re_snow%data_3d, & + has_reqc=1, has_reqi=1, has_reqs=1, & ids = ids, ide = ide, & ! domain dims jds = jds, jde = jde, & kds = kds, kde = kde, & @@ -432,8 +486,8 @@ subroutine process_subdomain(domain, options, dt, & domain%cloud_water_mass%data_3d, & domain%rain_mass%data_3d, & domain%snow_mass%data_3d, & - domain%accumulated_precipitation%data_2d, & - domain%accumulated_snowfall%data_2d, & + precipitation, & + snowfall, & dt, & domain%dz_mass%data_3d, & ims = ims, ime = ime, & ! memory dims @@ -480,11 +534,11 @@ subroutine process_subdomain(domain, options, dt, & XLS = XLS, XLV0 = XLV, XLF0 = XLF, & den0 = rhoair0, denr = rhowater, & cliq = cliq, cice = cice, psat = psat, & - rain = domain%accumulated_precipitation%data_2d, & + rain = precipitation, & rainncv = this_precip, & ! not used outside thompson (yet) sr = SR, & ! not used outside thompson (yet) - snow = domain%accumulated_snowfall%data_2d, & - graupel = domain%graupel%data_2d, & + snow = snowfall, & + graupel = graupel, & ids = ids, ide = ide, & ! domain dims jds = jds, jde = jde, & kds = kds, kde = kde, & @@ -495,8 +549,50 @@ subroutine process_subdomain(domain, options, dt, & jts = jts, jte = jte, & kts = kts, kte = kte) + elseif (options%physics%microphysics==kMP_WSM3) then + + call wsm3( q = domain%water_vapor%data_3d, & + th = domain%potential_temperature%data_3d, & + qci = domain%cloud_water_mass%data_3d, & + qrs = domain%rain_mass%data_3d, & + w = domain%w_real%data_3d, & + pii= domain%exner%data_3d, & + p = domain%pressure%data_3d, & + delz = domain%dz_mass%data_3d, & + den = domain%density%data_3d, & + delt = dt, & + g = gravity, & + cpd = cp, cpv = cpv, rd = Rd, rv = Rw, t0c = 273.15, & + ep1 = EP1, ep2 = EP2, qmin = epsilon, & + XLS = XLS, XLV0 = XLV, XLF0 = XLF, & + den0 = rhoair0, denr = rhowater, & + cliq = cliq, cice = cice, psat = psat, & + rain = precipitation, & + rainncv = this_precip, & ! not used outside thompson (yet) + sr = SR, & ! not used outside thompson (yet) + snow = snowfall, & + snowncv = this_snow, & + has_reqc=0, has_reqi=0, has_reqs=0, & + ids = ids, ide = ide, & ! domain dims + jds = jds, jde = jde, & + kds = kds, kde = kde, & + ims = ims, ime = ime, & ! memory dims + jms = jms, jme = jme, & + kms = kms, kme = kme, & + its = its, ite = ite, & ! tile dims + jts = jts, jte = jte, & + kts = kts, kte = kte) endif + if (associated(domain%accumulated_precipitation%data_2dd)) then + domain%accumulated_precipitation%data_2dd = domain%accumulated_precipitation%data_2dd + precipitation + endif + if (associated(domain%graupel%data_2dd)) then + domain%graupel%data_2dd = domain%graupel%data_2dd + graupel + endif + if (associated(domain%accumulated_snowfall%data_2dd)) then + domain%accumulated_snowfall%data_2dd = domain%accumulated_snowfall%data_2dd + snowfall + endif ! needs to be converted to work on specified tile or better, maybe moved out of microphysics driver entirely... ! if (options%use_bias_correction) then ! call apply_rain_fraction(domain%model_time, domain%rain_fraction, domain%rain, last_rain, precip_delta) @@ -618,10 +714,10 @@ subroutine mp(domain, options, dt_in, halo, subset) ! If we are going to distribute the current precip over a few grid cells, we need to keep track of ! the last_precip so we know how much fell - if ((options%mp_options%local_precip_fraction<1).or.(options%parameters%use_bias_correction)) then - last_rain = domain%accumulated_precipitation%data_2d - last_snow = domain%accumulated_snowfall%data_2d - endif + ! if (options%mp_options%local_precip_fraction<1) then + ! last_rain = domain%accumulated_precipitation%data_2dd + ! last_snow = domain%accumulated_snowfall%data_2d + ! endif ! set the current tile to the top layer to process microphysics for if (options%mp_options%top_mp_level>0) then @@ -700,5 +796,8 @@ subroutine mp_finish(options) if (allocated(this_precip)) then deallocate(this_precip) endif + if (allocated(this_snow)) then + deallocate(this_snow) + endif end subroutine mp_finish end module microphysics diff --git a/src/physics/mp_thompson_aer.f90 b/src/physics/mp_thompson_aer.f90 index 80e0248a..c2f12603 100644 --- a/src/physics/mp_thompson_aer.f90 +++ b/src/physics/mp_thompson_aer.f90 @@ -352,16 +352,16 @@ MODULE module_mp_thompson_aer INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tcg_racg[:], tmr_racg[:], tcr_gacr[:], tmg_gacr[:], & - tnr_racg[:], tnr_gacr[:] + tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & + tnr_racg, tnr_gacr REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tcs_racs1[:], tmr_racs1[:], tcs_racs2[:], tmr_racs2[:], & - tcr_sacr1[:], tms_sacr1[:], tcr_sacr2[:], tms_sacr2[:], & - tnr_racs1[:], tnr_racs2[:], tnr_sacr1[:], tnr_sacr2[:] + tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & + tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & + tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tpi_qcfz[:], tni_qcfz[:] + tpi_qcfz, tni_qcfz REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tpi_qrfz[:], tpg_qrfz[:], tni_qrfz[:], tnr_qrfz[:] + tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: & tps_iaus, tni_iaus, tpi_ide REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw @@ -558,36 +558,36 @@ SUBROUTINE thompson_aer_init(hgt, nwfa2d, nwfa, nifa, dx, dy, & !..Allocate space for lookup tables (J. Michalakes 2009Jun08). if (.NOT. ALLOCATED(tcg_racg) ) then - ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)[*]) + ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) micro_init = .TRUE. endif - if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)[*]) - - if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)[*]) - - if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,nbc,45,ntb_IN)[*]) - if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,nbc,45,ntb_IN)[*]) - - if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45,ntb_IN)[*]) - if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45,ntb_IN)[*]) - if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45,ntb_IN)[*]) - if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45,ntb_IN)[*]) + if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,nbc,45,ntb_IN)) + if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,nbc,45,ntb_IN)) + + if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45,ntb_IN)) if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1)) if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1)) @@ -1091,6 +1091,7 @@ SUBROUTINE mp_gt_driver_aer(qv, qc, qr, qi, qs, qg, ni, nr, nc, & !$omp shared(tcg_racg,tmr_racg,tcr_gacr,tmg_gacr,tnr_racg,tnr_gacr) & !$OMP SHARED(RAINNC,SNOWNC,RAINNCV,SNOWNCV,GRAUPELNCV,GRAUPELNC,SR) & !$OMP SHARED(w,th,pii,p,dz,qv,qc) & + !$OMP SHARED(has_reqi,has_reqs,has_reqc) & !$OMP SHARED(qi,qr,qs,qg,ni,nr,nc,nwfa,nifa,nwfa2d,refl_10cm,re_cloud,re_ice,re_snow, is_aerosol_aware) ! parameter list : Nt_c,TNO,rho_g,av_s,bv_s,fv_s,av_g,bv_g,EF_si,Ef_ri diff --git a/src/physics/mp_wsm3.f90 b/src/physics/mp_wsm3.f90 new file mode 100644 index 00000000..d2eb98ed --- /dev/null +++ b/src/physics/mp_wsm3.f90 @@ -0,0 +1,1603 @@ +#ifdef _ACCEL +# include "module_mp_wsm3_accel.F" +#else +! #if ( RWORDSIZE == 4 ) +! # define VREC vsrec +! # define VSQRT vssqrt +! #else +! # define VREC vrec +! # define VSQRT vsqrt +! #endif + +! subroutine vssqrt(y,x,n) +! real, intent(inout) :: y(n) +! real, intent(in) :: x(n) +! integer, intent(in) :: n +! integer :: j +! do j=1,n +! y(j)=sqrt(x(j)) +! enddo +! end +! +! subroutine vsrec(y,x,n) +! real, intent(inout) :: y(n) +! real, intent(in) :: x(n) +! integer, intent(in) :: n +! integer :: j +! do j=1,n +! y(j)=1.0/(x(j)) +! enddo +! end + + +MODULE module_mp_wsm3 +! + USE mod_wrf_constants, only : RE_QC_BG, RE_QI_BG, RE_QS_BG +! + REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops + REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain + REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain + REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain + REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency + REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow + REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow + REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) + REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain + REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow + REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel + REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter + REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow + REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s + REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg + REAL, SAVE :: & + qc0, qck1, pidnc, & + bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + precr1,precr2,xmmax,roqimax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & + pidn0s,xlv1,pi, & + rslopermax,rslopesmax,rslopegmax, & + rsloperbmax,rslopesbmax,rslopegbmax, & + rsloper2max,rslopes2max,rslopeg2max, & + rsloper3max,rslopes3max,rslopeg3max +! +! Specifies code-inlining of fpvs function in WSM32D below. JM 20040507 +! +CONTAINS +!=================================================================== +! + SUBROUTINE wsm3(th, q, qci, qrs & + , w, den, pii, p, delz & + , delt,g, cpd, cpv, rd, rv, t0c & + , ep1, ep2, qmin & + , XLS, XLV0, XLF0, den0, denr & + , cliq,cice,psat & + , rain, rainncv & + , snow, snowncv & + , sr & + , has_reqc, has_reqi, has_reqs & ! for radiation + , re_cloud, re_ice, re_snow & ! for radiation + , ids,ide, jds,jde, kds,kde & + , ims,ime, jms,jme, kms,kme & + , its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + th, & + q, & + qci, & + qrs + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: w, & + den, & + pii, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + rd, & + rv, & + t0c, & + den0, & + cpd, & + cpv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: rain, & + rainncv + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: snow, & + snowncv, & + sr +! for radiation connecting + INTEGER, INTENT(IN):: & + has_reqc, & + has_reqi, & + has_reqs + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, & + INTENT(INOUT):: & + re_cloud, & + re_ice, & + re_snow + +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte ) :: t + INTEGER :: i,j,k + +! to calculate effective radius for radiation + REAL, DIMENSION( kts:kte ) :: t1d + REAL, DIMENSION( kts:kte ) :: den1d + REAL, DIMENSION( kts:kte ) :: qc1d + REAL, DIMENSION( kts:kte ) :: qi1d + REAL, DIMENSION( kts:kte ) :: qs1d + REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs + +!------------------------------------------------------------------- + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + t(i,k)=th(i,k,j)*pii(i,k,j) + ENDDO + ENDDO + CALL wsm32D(t, q(ims,kms,j), qci(ims,kms,j) & + ,qrs(ims,kms,j),w(ims,kms,j), den(ims,kms,j) & + ,p(ims,kms,j), delz(ims,kms,j) & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,j & + ,rain(ims,j), rainncv(ims,j) & + ,snow(ims,j),snowncv(ims,j) & + ,sr(ims,j) & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) + DO K=kts,kte + DO I=its,ite + th(i,k,j)=t(i,k)/pii(i,k,j) + ENDDO + ENDDO + + if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then + do i=its,ite + do k=kts,kte + re_qc(k) = RE_QC_BG + re_qi(k) = RE_QI_BG + re_qs(k) = RE_QS_BG + + t1d(k) = th(i,k,j)*pii(i,k,j) + den1d(k)= den(i,k,j) + if(t(i,k).ge.t0c) then + qc1d(k) = qci(i,k,j) + qi1d(k) = 0.0 + qs1d(k) = 0.0 + else + qc1d(k) = 0.0 + qi1d(k) = qci(i,k,j) + qs1d(k) = qrs(i,k,j) + endif + enddo + call effectRad_wsm3(t1d, qc1d, qi1d, qs1d, den1d, & + qmin, t0c, re_qc, re_qi, re_qs, & + kts, kte, i, j) + do k=kts,kte + re_cloud(i,k,j) = MAX(RE_QC_BG, MIN(re_qc(k), 50.E-6)) + re_ice(i,k,j) = MAX(RE_QI_BG, MIN(re_qi(k), 125.E-6)) + re_snow(i,k,j) = MAX(RE_QS_BG, MIN(re_qs(k), 999.E-6)) + enddo + enddo + endif ! has_reqc, etc... + + ENDDO + END SUBROUTINE wsm3 +!=================================================================== +! + SUBROUTINE wsm32D(t, q & + ,qci, qrs,w, den, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,lat & + ,rain, rainncv & + ,snow,snowncv & + ,sr & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +! This code is a 3-class simple ice microphyiscs scheme (WSM3) of the +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! Production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM3 cloud scheme +! +! Developed by Song-You Hong (Yonsei Univ.), Jimy Dudhia (NCAR) +! and Shu-Hua Chen (UC Davis) +! Summer 2002 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2003 +! +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Dudhia (D89, 1989) J. Atmos. Sci. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! Juang and Hong (JH, 2010) Mon. Wea. Rev. +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + lat + REAL, DIMENSION( its:ite , kts:kte ), & + INTENT(INOUT) :: & + t + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(INOUT) :: & + q, & + qci, & + qrs + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(IN ) :: w, & + den, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime ), & + INTENT(INOUT) :: rain, & + rainncv + REAL, DIMENSION( ims:ime ), OPTIONAL, & + INTENT(INOUT) :: snow, & + snowncv, & + sr +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte ) :: & + rh, & + qs, & + denfac, & + rslope, & + rslope2, & + rslope3, & + qrs_tmp, & + den_tmp, & + delz_tmp, & + rslopeb + REAL, DIMENSION( its:ite , kts:kte ) :: & + pgen, & + pisd, & + paut, & + pacr, & + pres, & + pcon + REAL, DIMENSION( its:ite , kts:kte ) :: & + fall, & + falk, & + xl, & + cpm, & + work1, & + work2, & + xni, & + qs0, & + denqci, & + denqrs, & + n0sfac, & + falkc, & + work1c, & + work2c, & + fallc + REAL, DIMENSION( its:ite ) :: delqrs,& + delqi + REAL, DIMENSION(its:ite) :: tstepsnow + INTEGER, DIMENSION( its:ite ) :: kwork1,& + kwork2 + INTEGER, DIMENSION( its:ite ) :: mstep, & + numdt + LOGICAL, DIMENSION( its:ite ) :: flgcld + REAL :: & + cpmcal, xlcal, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + fallsum, fallsum_qsi, vt2i,vt2s,acrfac, & + qdt, pvt, qik, delq, facq, qrsci, frzmlt, & + snomlt, hold, holdrs, facqci, supcol, coeres, & + supsat, dtcld, xmi, qciik, delqci, eacrs, satdt, & + qimax, diameter, xni0, roqi0, supice,holdc, holdci + INTEGER :: i, j, k, mstepmax, & + iprt, latd, lond, loop, loops, ifsat, kk, n, idim, kdim +! Temporaries used for inlining fpvs function + REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp +! variables for optimization + REAL, DIMENSION( its:ite ) :: tvec1 +! +!================================================================= +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! Optimizatin : A**B => exp(log(A)*(B)) +! + diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y + viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y + xka(x,y) = 1.414e3*viscos(x,y)*y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) + venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & + /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) + conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! + idim = ite-its+1 + kdim = kte-kts+1 +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qci(i,k) = max(qci(i,k),0.0) + qrs(i,k) = max(qrs(i,k),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation +! emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo + do k = kts, kte + do i = its, ite + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the surface rain, snow +! + do i = its, ite + rainncv(i) = 0. + if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i) = 0. + sr(i) = 0. +! new local array to catch step snow + tstepsnow(i) = 0. + enddo +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! +!---------------------------------------------------------------- +! initialize the large scale variables +! + do i = its, ite + flgcld(i) = .true. + enddo +! + do k = kts, kte + ! CALL VREC( tvec1(its), den(its,k), ite-its+1) + ! tvec1(its:ite) = 1/(den(its:ite,k)) + do i = its, ite + tvec1(i) = 1.0/(den(i,k)) + tvec1(i) = tvec1(i)*den0 + denfac(i,k) = sqrt(tvec1(i)) + enddo + ! CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) + ! denfac(its:ite,k) = sqrt(tvec1(its:ite)) + enddo +! +! Inline expansion for fpvs +! qs(i,k) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qs0(i,k) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + cvap = cpv + hvap=xlv0 + hsub=xls + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qs(i,k) =psat*(exp(log(tr)*(xai)))*exp(xbi*(1.-tr)) + else + qs(i,k) =psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) + endif + qs0(i,k) =psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) + qs0(i,k) = (qs0(i,k)-qs(i,k))/qs(i,k) + qs(i,k) = min(qs(i,k),0.99*p(i,k)) + qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) + qs(i,k) = max(qs(i,k),qmin) + rh(i,k) = max(q(i,k) / qs(i,k),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! + do k = kts, kte + do i = its, ite + pres(i,k) = 0. + paut(i,k) = 0. + pacr(i,k) = 0. + pgen(i,k) = 0. + pisd(i,k) = 0. + pcon(i,k) = 0. + fall(i,k) = 0. + falk(i,k) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + xni(i,k) = 1.e3 + enddo + enddo +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- + do k = kts, kte + do i = its, ite + xni(i,k) = min(max(5.38e7 & + *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) + enddo + enddo +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!--------------------------------------------------------------- + do k = kts, kte + do i = its, ite + qrs_tmp(i,k) = qrs(i,k) + enddo + enddo + call slope_wsm3(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! +! +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 + do i = its, ite + denqrs(i,k) = den(i,k)*qrs(i,k) + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1,denqrs, & + delqrs,dtcld,1,1) + do k = kts, kte + do i = its, ite + qrs(i,k) = max(denqrs(i,k)/den(i,k),0.) + fall(i,k) = denqrs(i,k)*work1(i,k)/delz(i,k) + enddo + enddo + do i = its, ite + fall(i,1) = delqrs(i)/delz(i,1)/dtcld + enddo +!--------------------------------------------------------------- +! Vice [ms-1] : fallout of ice crystal [HDC 5a] +!--------------------------------------------------------------- + do k = kte, kts, -1 + do i = its, ite + if(t(i,k).lt.t0c.and.qci(i,k).gt.0.) then + xmi = den(i,k)*qci(i,k)/xni(i,k) + diameter = max(dicon * sqrt(xmi), 1.e-25) + work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) + else + work1c(i,k) = 0. + endif + enddo + enddo +! +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 + do i = its, ite + denqci(i,k) = den(i,k)*qci(i,k) + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & + delqi,dtcld,1,0) + do k = kts, kte + do i = its, ite + qci(i,k) = max(denqci(i,k)/den(i,k),0.) + enddo + enddo + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo +! +!---------------------------------------------------------------- +! compute the freezing/melting term. [D89 B16-B17] +! freezing occurs one layer above the melting level +! + do i = its, ite + mstep(i) = 0 + enddo + do k = kts, kte +! + do i = its, ite + if(t(i,k).ge.t0c) then + mstep(i) = k + endif + enddo + enddo +! + do i = its, ite + kwork2(i) = mstep(i) + kwork1(i) = mstep(i) + if(mstep(i).ne.0) then + if (w(i,mstep(i)).gt.0.) then + kwork1(i) = mstep(i) + 1 + endif + endif + enddo +! + do i = its, ite + k = kwork1(i) + kk = kwork2(i) + if(k*kk.ge.1) then + qrsci = qrs(i,k) + qci(i,k) + if(qrsci.gt.0..or.fall(i,kk).gt.0.) then + frzmlt = min(max(-w(i,k)*qrsci/delz(i,k),-qrsci/dtcld), & + qrsci/dtcld) + snomlt = min(max(fall(i,kk)/den(i,kk),-qrs(i,k)/dtcld), & + qrs(i,k)/dtcld) + if(k.eq.kk) then + t(i,k) = t(i,k) - xlf0/cpm(i,k)*(frzmlt+snomlt)*dtcld + else + t(i,k) = t(i,k) - xlf0/cpm(i,k)*frzmlt*dtcld + t(i,kk) = t(i,kk) - xlf0/cpm(i,kk)*snomlt*dtcld + endif + endif + endif + enddo +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + fallsum = fall(i,1) + fallsum_qsi = 0. + if((t0c-t(i,1)).gt.0) then + fallsum = fallsum+fallc(i,1) + fallsum_qsi = fall(i,1)+fallc(i,1) + endif + if(fallsum.gt.0.) then + rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rainncv(i) + rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i) + endif + if(fallsum_qsi.gt.0.) then + tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & + +tstepsnow(i) + IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN + snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snowncv(i) + snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) + ENDIF + endif + IF ( PRESENT (snowncv) ) THEN + if(fallsum.gt.0.) sr(i) = snowncv(i)/(rainncv(i)+1.e-12) + ELSE + if(fallsum.gt.0.) sr(i) = tstepsnow(i)/(rainncv(i)+1.e-12) + ENDIF + enddo +! +!---------------------------------------------------------------- +! update the slope parameters for microphysics computation +! + do k = kts, kte + do i = its, ite + qrs_tmp(i,k) = qrs(i,k) + enddo + enddo + call slope_wsm3(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + if(t(i,k).ge.t0c) then + work1(i,k) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k)) + else + work1(i,k) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k)) + endif + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qs(i,k) + satdt = supsat/dtcld + if(t(i,k).ge.t0c) then +! +!=============================================================== +! +! warm rain processes +! +! - follows the processes in RH83 and LFO except for autoconcersion +! +!=============================================================== +!--------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [HDC 16] +! (C->R) +!--------------------------------------------------------------- + if(qci(i,k).gt.qc0) then +! paut(i,k) = qck1*qci(i,k)**(7./3.) + paut(i,k) = qck1*exp(log(qci(i,k))*((7./3.))) + paut(i,k) = min(paut(i,k),qci(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! pracw: accretion of cloud water by rain [HL A40] [D89 B15] +! (C->R) +!--------------------------------------------------------------- + if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qmin) then + pacr(i,k) = min(pacrr*rslope3(i,k)*rslopeb(i,k) & + *qci(i,k)*denfac(i,k),qci(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! prevp: evaporation/condensation rate of rain [HDC 14] +! (V->R or R->V) +!--------------------------------------------------------------- + if(qrs(i,k).gt.0.) then + coeres = rslope2(i,k)*sqrt(rslope(i,k)*rslopeb(i,k)) + pres(i,k) = (rh(i,k)-1.)*(precr1*rslope2(i,k) & + +precr2*work2(i,k)*coeres)/work1(i,k) + if(pres(i,k).lt.0.) then + pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) + pres(i,k) = max(pres(i,k),satdt/2) + else + pres(i,k) = min(pres(i,k),satdt/2) + endif + endif + else +! +!=============================================================== +! +! cold rain processes +! +! - follows the revised ice microphysics processes in HDC +! - the processes same as in RH83 and LFO behave +! following ice crystal hapits defined in HDC, inclduing +! intercept parameter for snow (n0s), ice crystal number +! concentration (ni), ice nuclei number concentration +! (n0i), ice diameter (d) +! +!=============================================================== +! + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + ifsat = 0 +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- + xni(i,k) = min(max(5.38e7 & + *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) + eacrs = exp(0.07*(-supcol)) + if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qmin) then + xmi = den(i,k)*qci(i,k)/xni(i,k) + diameter = min(dicon * sqrt(xmi),dimax) + vt2i = 1.49e4*diameter**1.31 + vt2s = pvts*rslopeb(i,k)*denfac(i,k) +!------------------------------------------------------------- +! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] +! (TR) +!------------------------------------------------------------- + acrfac = 2.*rslope3(i,k)+2.*diameter*rslope2(i,k) & + +diameter**2*rslope(i,k) + pacr(i,k) = min(pi*qci(i,k)*eacrs*n0s*n0sfac(i,k) & + *abs(vt2s-vt2i)*acrfac/4.,qci(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pidep: Deposition/Sublimation rate of ice [HDC 9] +! (TI or I->V) +!------------------------------------------------------------- + if(qci(i,k).gt.0.) then + xmi = den(i,k)*qci(i,k)/xni(i,k) + diameter = dicon * sqrt(xmi) + pisd(i,k) = 4.*diameter*xni(i,k)*(rh(i,k)-1.)/work1(i,k) + if(pisd(i,k).lt.0.) then + pisd(i,k) = max(pisd(i,k),satdt/2) + pisd(i,k) = max(pisd(i,k),-qci(i,k)/dtcld) + else + pisd(i,k) = min(pisd(i,k),satdt/2) + endif + if(abs(pisd(i,k)).ge.abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! psdep: deposition/sublimation rate of snow [HDC 14] +! (V->S or S->V) +!------------------------------------------------------------- + if(qrs(i,k).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k)*sqrt(rslope(i,k)*rslopeb(i,k)) + pres(i,k) = (rh(i,k)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k) & + +precs2*work2(i,k)*coeres)/work1(i,k) + supice = satdt-pisd(i,k) + if(pres(i,k).lt.0.) then + pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) + pres(i,k) = max(max(pres(i,k),satdt/2),supice) + else + pres(i,k) = min(min(pres(i,k),satdt/2),supice) + endif + if(abs(pisd(i,k)+pres(i,k)).ge.abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! pigen: generation(nucleation) of ice from vapor [HDC 7-8] +! (TI) +!------------------------------------------------------------- + if(supsat.gt.0.and.ifsat.ne.1) then + supice = satdt-pisd(i,k)-pres(i,k) + xni0 = 1.e3*exp(0.1*supcol) + roqi0 = 4.92e-11*exp(log(xni0)*(1.33)) + pgen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k),0.))/dtcld) + pgen(i,k) = min(min(pgen(i,k),satdt),supice) + endif +!------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [HDC 12] +! (TS) +!------------------------------------------------------------- + if(qci(i,k).gt.0.) then + qimax = roqimax/den(i,k) + paut(i,k) = max(0.,(qci(i,k)-qimax)/dtcld) + endif + endif + enddo + enddo +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite + qciik = max(qmin,qci(i,k)) + delqci = (paut(i,k)+pacr(i,k)-pgen(i,k)-pisd(i,k))*dtcld + if(delqci.ge.qciik) then + facqci = qciik/delqci + paut(i,k) = paut(i,k)*facqci + pacr(i,k) = pacr(i,k)*facqci + pgen(i,k) = pgen(i,k)*facqci + pisd(i,k) = pisd(i,k)*facqci + endif + qik = max(qmin,q(i,k)) + delq = (pres(i,k)+pgen(i,k)+pisd(i,k))*dtcld + if(delq.ge.qik) then + facq = qik/delq + pres(i,k) = pres(i,k)*facq + pgen(i,k) = pgen(i,k)*facq + pisd(i,k) = pisd(i,k)*facq + endif + work2(i,k) = -pres(i,k)-pgen(i,k)-pisd(i,k) + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k) = max(qci(i,k)-(paut(i,k)+pacr(i,k)-pgen(i,k)-pisd(i,k)) & + *dtcld,0.) + qrs(i,k) = max(qrs(i,k)+(paut(i,k)+pacr(i,k)+pres(i,k))*dtcld,0.) + if(t(i,k).lt.t0c) then + t(i,k) = t(i,k)-xls*work2(i,k)/cpm(i,k)*dtcld + else + t(i,k) = t(i,k)-xl(i,k)*work2(i,k)/cpm(i,k)*dtcld + endif + enddo + enddo +! + cvap = cpv + hvap = xlv0 + hsub = xls + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qs(i,k)=psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) + qs(i,k) = min(qs(i,k),0.99*p(i,k)) + qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) + qs(i,k) = max(qs(i,k),qmin) + denfac(i,k) = sqrt(den0/den(i,k)) + enddo + enddo +! +!---------------------------------------------------------------- +! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +! if there exists additional water vapor condensated/if +! evaporation of cloud water is not enough to remove subsaturation +! + do k = kts, kte + do i = its, ite + work1(i,k) = conden(t(i,k),q(i,k),qs(i,k),xl(i,k),cpm(i,k)) + work2(i,k) = qci(i,k)+work1(i,k) + pcon(i,k) = min(max(work1(i,k),0.),max(q(i,k),0.))/dtcld + if(qci(i,k).gt.0..and.work1(i,k).lt.0.and.t(i,k).gt.t0c) & + pcon(i,k) = max(work1(i,k),-qci(i,k))/dtcld + q(i,k) = q(i,k)-pcon(i,k)*dtcld + qci(i,k) = max(qci(i,k)+pcon(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcon(i,k)*xl(i,k)/cpm(i,k)*dtcld + enddo + enddo +! +!---------------------------------------------------------------- +! padding for small values +! + do k = kts, kte + do i = its, ite + if(qci(i,k).le.qmin) qci(i,k) = 0.0 + if(qrs(i,k).le.qcrmin) qrs(i,k) = 0.0 + enddo + enddo +! + enddo ! big loops + END SUBROUTINE wsm32D +! ................................................................... + REAL FUNCTION rgmma(x) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! rgmma function: use infinite product form + REAL :: euler + PARAMETER (euler=0.577215664901532) + REAL :: x, y + INTEGER :: i + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i=1,10000 + y=float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + END FUNCTION rgmma +! +!-------------------------------------------------------------------------- + REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!-------------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------------- + REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & + xai,xbi,ttp,tr + INTEGER ice +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) + else + fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END FUNCTION fpvs +!------------------------------------------------------------------- + SUBROUTINE wsm3init(den0,denr,dens,cl,cpv,allowed_to_read) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!.... constants which may not be tunable + REAL, INTENT(IN) :: den0,denr,dens,cl,cpv + LOGICAL, INTENT(IN) :: allowed_to_read +! + pi = 4.*atan(1.) + xlv1 = cl-cpv +! + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + pidnc = pi*denr/6. ! syb +! + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + xmmax = (dimax/dicon)**2 + roqimax = 2.08e22*dimax**8 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s +! + rslopermax = 1./lamdarmax + rslopesmax = 1./lamdasmax + rsloperbmax = rslopermax ** bvtr + rslopesbmax = rslopesmax ** bvts + rsloper2max = rslopermax * rslopermax + rslopes2max = rslopesmax * rslopesmax + rsloper3max = rsloper2max * rslopermax + rslopes3max = rslopes2max * rslopesmax +! + END SUBROUTINE wsm3init +! + subroutine slope_wsm3(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte ) :: & + qrs, & + den, & + denfac, & + t, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar,lamdas,x, y, z, supcol, pvt + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. +! + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + if(t(i,k).ge.t0c) then + pvt = pvtr + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) + rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + else + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + pvt = pvts + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + endif + vt(i,k) = pvt*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_wsm3 +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_pcm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real zsumt,qsumt,zsumb,qsumb + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! pcm is 1st order, we should use 2nd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_wsm3(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + if( n.eq.2 ) wa(1:km) = 0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt +! compute q with piecewise constant method + if( kt-kb.eq.1 ) then + qn(k) = qa(kb) + else if( kt-kb.ge.2 ) then + zsumb = za(kb+1)-zi(k) + qsumb = qa(kb) * zsumb + zsumt = zi(k+1)-za(kt-1) + qsumt = qa(kt-1) * zsumt + qsum = 0.0 + zsum = 0.0 + if( kt-kb.ge.3 ) then + do m=kb+1,kt-2 + qsum = qsum + qa(m) * dza(m) + zsum = zsum + dza(m) + enddo + endif + qn(k) = (qsumb+qsum+qsumt)/(zsumb+zsum+zsumt) + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_pcm +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_wsm3(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plm +! +!----------------------------------------------------------------------- + subroutine effectRad_wsm3 (t, qc, qi, qs, rho, qmin, t0c, & + re_qc, re_qi, re_qs, kts, kte, ii, jj) + +!----------------------------------------------------------------------- +! Compute radiation effective radii of cloud water, ice, and snow for +! single-moment microphysics. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------- + + implicit none + +!..Sub arguments + integer, intent(in) :: kts, kte, ii, jj + real, intent(in) :: qmin + real, intent(in) :: t0c + real, dimension( kts:kte ), intent(in):: t + real, dimension( kts:kte ), intent(in):: qc + real, dimension( kts:kte ), intent(in):: qi + real, dimension( kts:kte ), intent(in):: qs + real, dimension( kts:kte ), intent(in):: rho + real, dimension( kts:kte ), intent(inout):: re_qc + real, dimension( kts:kte ), intent(inout):: re_qi + real, dimension( kts:kte ), intent(inout):: re_qs +!..Local variables + integer:: i,k + integer :: inu_c + real, dimension( kts:kte ):: ni + real, dimension( kts:kte ):: rqc + real, dimension( kts:kte ):: rqi + real, dimension( kts:kte ):: rni + real, dimension( kts:kte ):: rqs + real :: temp + real :: lamdac + real :: supcol, n0sfac, lamdas + real :: diai ! diameter of ice in m + logical :: has_qc, has_qi, has_qs +!..Minimum microphys values + real, parameter :: R1 = 1.E-12 + real, parameter :: R2 = 1.E-6 +!..Mass power law relations: mass = am*D**bm + real, parameter :: bm_r = 3.0 + real, parameter :: obmr = 1.0/bm_r + real, parameter :: nc0 = 3.E8 +!----------------------------------------------------------------------- + has_qc = .false. + has_qi = .false. + has_qs = .false. + + do k = kts, kte + ! for cloud + rqc(k) = max(R1, qc(k)*rho(k)) + if (rqc(k).gt.R1) has_qc = .true. + ! for ice + rqi(k) = max(R1, qi(k)*rho(k)) + temp = (rho(k)*max(qi(k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(k)= max(R2, ni(k)*rho(k)) + if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. + ! for snow + rqs(k) = max(R1, qs(k)*rho(k)) + if (rqs(k).gt.R1) has_qs = .true. + enddo + + if (has_qc) then + do k=kts,kte + if (rqc(k).le.R1) CYCLE + lamdac = (pidnc*nc0/rqc(k))**obmr + re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) + enddo + endif + + if (has_qi) then + do k=kts,kte + if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(k)/ni(k)) + re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) + enddo + endif + + if (has_qs) then + do k=kts,kte + if (rqs(k).le.R1) CYCLE + supcol = t0c-t(k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) + re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) + enddo + endif + + end subroutine effectRad_wsm3 +!----------------------------------------------------------------------- +END MODULE module_mp_wsm3 +#endif diff --git a/src/physics/pbl_driver.f90 b/src/physics/pbl_driver.f90 index ef31228a..485cfc26 100644 --- a/src/physics/pbl_driver.f90 +++ b/src/physics/pbl_driver.f90 @@ -29,19 +29,80 @@ module planetary_boundary_layer use domain_interface, only : domain_t use options_interface, only : options_t use pbl_simple, only : simple_pbl, finalize_simple_pbl, init_simple_pbl - !use module_bl_ysu, only : ysuinit, ysu + use module_bl_ysu, only : ysuinit, ysu + use mod_atm_utilities, only : calc_Richardson_nr + use mod_wrf_constants, only : EOMEG + use icar_constants !, only : karman,stefan_boltzmann + use mod_pbl_utilities, only : da_sfc_wtq + use ieee_arithmetic ! for debugging + use array_utilities, only : array_offset_x_3d, array_offset_y_3d + + implicit none + real,allocatable, dimension(:,:) :: windspd, Ri, z_atm, zol, hol, hpbl, psim, & + psih, u10d, v10d, t2d, q2d, gz1oz0, CHS, xland_real,regime + ! integer, allocatable, dimension(:,:) :: kpbl2d + real, allocatable, dimension(:,:,:) :: tend_u_ugrid, tend_v_vgrid private - public :: pbl_init, pbl, pbl_finalize + public :: pbl_var_request, pbl_init, pbl, pbl_finalize integer :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte + its, ite, jts, jte, kts, kte, j, k, i logical :: allowed_to_read, restart, flag_qi contains + + subroutine pbl_var_request(options) + implicit none + type(options_t),intent(inout) :: options + + if (options%physics%landsurface == kPBL_SIMPLE) then + call options%alloc_vars( & + [kVARS%water_vapor, kVARS%potential_temperature, & + kVARS%cloud_water, kVARS%cloud_ice, & + kVARS%rain_in_air, kVARS%snow_in_air, & + kVARS%exner, kVARS%dz_interface, kVARS%density, & + kVARS%u, kVARS%v, kVARS%land_mask]) + + call options%advect_vars([kVARS%potential_temperature, kVARS%water_vapor]) + + call options%restart_vars( & + [kVARS%water_vapor, kVARS%potential_temperature, & + kVARS%exner, kVARS%dz_interface, kVARS%density, & + kVARS%u, kVARS%v, kVARS%land_mask]) + endif + if (options%physics%boundarylayer==kPBL_YSU) then + + call options%alloc_vars( & + [kVARS%water_vapor, kVARS%potential_temperature, kVARS%temperature, & + kVARS%exner, kVARS%dz_interface, kVARS%density, kVARS%pressure_interface, & + kVARS%skin_temperature, kVARS%terrain, kVARS%ground_surf_temperature, & + kVARS%sensible_heat, kVARS%latent_heat, kVARS%u_10m, kVARS%v_10m, & + kVARS%humidity_2m, kVARS%surface_pressure, kVARS%ground_heat_flux, & + kVARS%znu, kVARS%znw, kVARS%roughness_z0, kVARS%ustar, kVARS%cloud_ice, & + kVARS%tend_th_pbl, kVARS%tend_qc_pbl, kVARS%tend_qi_pbl, kVARS%temperature_2m, & + kVARS%tend_u, kVARS%tend_v, kVARS%tend_qv_pbl, kVARS%pressure, kVARS%kpbl, & + kVARS%land_mask, kVARS%cloud_water, kVARS%coeff_heat_exchange_3d, kVARS%hpbl ]) !kVARS%tend_qv_adv,kVARS%tend_qv, kVARS%tend_qs, kVARS%tend_qr,, kVARS%u_mass, kVARS%v_mass, +! kVARS%coeff_momentum_drag, ?? + call options%advect_vars([kVARS%potential_temperature, kVARS%water_vapor, kVARS%cloud_ice, kVARS%cloud_water]) !?? + + call options%restart_vars( & + [kVARS%water_vapor, kVARS%potential_temperature, kVARS%temperature, & + kVARS%exner, kVARS%dz_interface, kVARS%density, kVARS%pressure_interface, & + kVARS%skin_temperature, kVARS%terrain, kVARS%ground_surf_temperature, & + kVARS%sensible_heat, kVARS%latent_heat, kVARS%u_10m, kVARS%v_10m, & + kVARS%humidity_2m, kVARS%surface_pressure, kVARS%ground_heat_flux, & + kVARS%znu, kVARS%znw, kVARS%roughness_z0, kVARS%ustar, kVARS%cloud_ice, & + kVARS%tend_th_pbl, kVARS%tend_qc_pbl, kVARS%tend_qi_pbl, kVARS%temperature_2m, & + kVARS%tend_u, kVARS%tend_v, kVARS%tend_qv_pbl, kVARS%pressure, kVARS%kpbl, & + kVARS%land_mask, kVARS%cloud_water,kVARS%coeff_heat_exchange_3d, kVARS%hpbl ]) !kVARS%u_mass, kVARS%v_mass, + endif + end subroutine pbl_var_request + + subroutine pbl_init(domain,options) implicit none type(domain_t), intent(inout) :: domain @@ -54,28 +115,82 @@ subroutine pbl_init(domain,options) allowed_to_read = .True. restart = .False. flag_qi = .true. - ! if (.not.allocated(domain%tend%qv_pbl)) allocate(domain%tend%qv_pbl(ims:ime,kms:kme,jms:jme)) - ! domain%tend%qv_pbl=0 + if (.not.allocated(domain%tend%qv_pbl)) allocate(domain%tend%qv_pbl(ims:ime,kms:kme,jms:jme)) + domain%tend%qv_pbl=0 if (this_image()==1) write(*,*) "Initializing PBL Scheme" + if (options%physics%boundarylayer==kPBL_SIMPLE) then if (this_image()==1) write(*,*) " Simple PBL" call init_simple_pbl(domain, options) + else if (options%physics%boundarylayer==kPBL_YSU) then - ! if (this_image()==1) write(*,*) " YSU PBL" - ! if (.not.allocated(domain%tend%th)) allocate(domain%tend%th(ims:ime,kms:kme,jms:jme)) - ! if (.not.allocated(domain%tend%qc)) allocate(domain%tend%qc(ims:ime,kms:kme,jms:jme)) - ! if (.not.allocated(domain%tend%qr)) allocate(domain%tend%qr(ims:ime,kms:kme,jms:jme)) - ! if (.not.allocated(domain%tend%qi)) allocate(domain%tend%qi(ims:ime,kms:kme,jms:jme)) - ! if (.not.allocated(domain%tend%u)) allocate(domain%tend%u(ims:ime,kms:kme,jms:jme)) - ! if (.not.allocated(domain%tend%v)) allocate(domain%tend%v(ims:ime,kms:kme,jms:jme)) - ! call ysuinit(domain%tend%u,domain%tend%v, & - ! domain%tend%th,domain%tend%qv_pbl, & - ! domain%tend%qc,domain%tend%qi,1,1, & - ! restart, allowed_to_read, & - ! ids, ide, jds, jde, kds, kde, & - ! ims, ime, jms, jme, kms, kme, & - ! its, ite, jts, jte, kts, kte) + + if (this_image()==1) write(*,*) " YSU PBL" + + ! allocate local vars YSU: + allocate(windspd(ims:ime, jms:jme)) + allocate(Ri(ims:ime,jms:jme)) + ! Ri = 0 + allocate(z_atm(ims:ime,jms:jme)) + z_atm = domain%z%data_3d(:,kts,:) - domain%terrain%data_2d ! defines the height of the middle of the first model level + allocate(zol(ims:ime, jms:jme)) ! zol z/l height over monin-obukhov length - intent(inout) - but appears to not be used really? + zol = 10 + allocate(hol(ims:ime, jms:jme)) ! hol pbl height over monin-obukhov length - intent(inout) + hol = 1000.0 + ! allocate(hpbl(ims:ime, jms:jme)) ! this should go to domain object for convective modules!! + allocate(psim(ims:ime, jms:jme)) + ! psim= 0.5 + allocate(psih(ims:ime, jms:jme)) + ! psih=0.5 + allocate(u10d(ims:ime, jms:jme)) + allocate(v10d(ims:ime, jms:jme)) + allocate(t2d(ims:ime, jms:jme)) + allocate(q2d(ims:ime, jms:jme)) + allocate(gz1oz0(ims:ime, jms:jme)) !-- gz1oz0 log(z/z0) where z0 is roughness length + gz1oz0 = log(z_atm / domain%roughness_z0%data_2d) + ! allocate(kpbl2d(ims:ime, jms:jme)) ! domain%kpbl now + ! allocate(CHS(ims:ime,jms:jme)) + ! CHS = 0.01 + allocate(xland_real(ims:ime,jms:jme)) + xland_real=real(domain%land_mask) + allocate(regime(ims:ime,jms:jme)) + allocate(tend_u_ugrid(ims:ime+1, kms:kme, jms:jme)) ! to add the calculated u/v tendencies to the u/v grid + allocate(tend_v_vgrid(ims:ime, kms:kme, jms:jme+1)) + + ! initialize tendencies (this is done in ysu init but only for tiles, not mem (ie its vs ims)) + ! BK: check if this actually matters ??? + if(.not.restart)then + do j = jms,jme + do k = kms,kme + do i = ims,ime + domain%tend%u(i,k,j) = 0. + domain%tend%v(i,k,j) = 0. + domain%tend%th_pbl(i,k,j) = 0. + domain%tend%qv_pbl(i,k,j) = 0. + domain%tend%qc_pbl(i,k,j) = 0. + domain%tend%qi_pbl(i,k,j) = 0. + enddo + enddo + enddo + endif + + + call ysuinit(rublten=domain%tend%u & + ,rvblten=domain%tend%v & + ,rthblten=domain%tend%th_pbl & + ,rqvblten=domain%tend%qv_pbl & + ,rqcblten=domain%tend%qc_pbl & + ,rqiblten=domain%tend%qi_pbl & + ,p_qi=1 & + ,p_first_scalar=1 & + ,restart=restart & + ,allowed_to_read= allowed_to_read & + ,ids=ids, ide=ide, jds=jds, jde=jde & + ,kds=kds, kde=kde, ims=ims, ime=ime & + ,jms=jms, jme=jme, kms=kms, kme=kme & + ,its=its, ite=ite, jts=jts, jte=jte & + ,kts=kts, kte=kte-1) endif end subroutine pbl_init @@ -83,7 +198,7 @@ subroutine pbl(domain, options, dt_in) implicit none type(domain_t), intent(inout) :: domain type(options_t), intent(in) :: options - real, intent(in) :: dt_in + real, intent(in) :: dt_in ! =real(dt%seconds()) if (options%physics%boundarylayer==kPBL_SIMPLE) then call simple_pbl(domain% potential_temperature %data_3d, & @@ -99,32 +214,172 @@ subroutine pbl(domain, options, dt_in) domain% z %data_3d, & domain% dz_mass %data_3d, & domain% terrain %data_2d, & + domain% land_mask, & its, ite, jts, jte, kts, kte, & dt_in) ! domain% qv_pbl_tendency %data_3d) endif if (options%physics%boundarylayer==kPBL_YSU) then - stop "YSU PBL not implemented yet" - ! call ysu(domain%Um, domain%Vm, domain%th, domain%t, & - ! domain%qv, domain%cloud,domain%ice, & - ! domain%p,domain%p_inter,domain%pii, & - ! domain%tend%u,domain%tend%v,domain%tend%th, & - ! domain%tend%qv_pbl,domain%tend%qc,domain%tend%qi,flag_qi, & - ! cp,gravity,rovcp,rd,rovg, & - ! domain%dz_i, domain%z, LH_vaporization,rv,domain%psfc, & - ! domain%znu, domain%znw, domain%mut,domain%p_top, & - ! domain%znt, domain%ustar,zol, hol, hpbl, psim, psih, & - ! domain%xland,domain%sensible_heat,domain%latent_heat, & - ! domain%tskin,gz1oz0, wspd, br, & - ! dt,dtmin,kpbl2d, & - ! svp1,svp2,svp3,svpt0,ep1,ep2,karman,eomeg,stbolt, & - ! exch_h, & - ! domain%u10,domain%v10, & - ! ids,ide, jds,jde, kds,kde, & - ! ims,ime, jms,jme, kms,kme, & - ! its,ite, jts,jte, kts,kte) - endif + + ! windspd=sqrt( domain%u_mass%data_3d(ims:ime, 1, jms:jme)**2 + & + ! domain%v_mass%data_3d(ims:ime, 1, jms:jme)**2 ) + windspd = sqrt(domain%u_10m%data_2d**2 + domain%v_10m%data_2d**2) ! as it is done in lsm_driver. + where(windspd==0) windspd=1e-5 + + ! Richardson number + call calc_Richardson_nr(Ri,domain%temperature%data_3d, domain%skin_temperature%data_2d, z_atm, windspd) + + ! Copied from WRF, to calc psim and psih. ( Not 100% sure this is the way to go) + call da_sfc_wtq ( psfc=domain%surface_pressure%data_2d & + , tg=domain%ground_surf_temperature%data_2d & !? + , ps=domain%pressure%data_3d(:,1,:) & + , ts=domain%temperature%data_3d(:,1,:) & + , qs=domain%cloud_water_mass%data_3d(:,1,:) & + , us=domain%u_mass%data_3d(:,1,:) & + , vs=domain%v_mass%data_3d(:,1,:) & + , hs=z_atm & !: height at the lowest half sigma level + , roughness=domain%roughness_z0%data_2d & !s(ims:ime, jms:jme) & + , xland=xland_real & ! real(domain%land_mask) + , dx=domain%dx & + , u10=u10d, v10=v10d, t2=t2d, q2=q2d & ! output only so can be dummies for now + , regime=regime & + , psim=psim & ! these we want + , psih=psih & + , has_lsm=.true. & !if(options%physics%landsurface>1) + , ust_wrf=domain%ustar & + ! , regime_wrf, qsfc_wrf, znt_wrf, , mol_wrf, hfx, qfx, pblh & ! optional + ,hfx=domain%sensible_heat%data_2d & + ,qfx=domain%latent_heat%data_2d/LH_vaporization & + ,ims=ims, ime=ime, jms=jms, jme=jme) + + + call ysu(u3d=domain%u_mass%data_3d & !-- u3d 3d u-velocity interpolated to theta points (m/s) + ,v3d=domain%v_mass%data_3d & !-- v3d 3d v-velocity interpolated to theta points (m/s) + ,th3d=domain%potential_temperature%data_3d & + ,t3d=domain%temperature%data_3d & + ,qv3d=domain%water_vapor%data_3d & + ,qc3d=domain%cloud_water_mass%data_3d & !-- qc3d cloud water mixing ratio (kg/kg) + ,qi3d=domain%cloud_ice_mass%data_3d & !-- qi3d cloud ice mixing ratio (kg/kg) + ,p3d=domain%pressure%data_3d & !-- p3d 3d pressure (pa) + ,p3di=domain%pressure_interface%data_3d & !-- p3di 3d pressure (pa) at interface level + ,pi3d=domain%exner%data_3d & !-- pi3d 3d exner function (dimensionless) + ,rublten=domain%tend%u & ! i/o + ,rvblten=domain%tend%v & ! i/o + ,rthblten=domain%tend%th_pbl & ! i/o + ,rqvblten=domain%tend%qv_pbl & ! i/o + ,rqcblten=domain%tend%qc_pbl & ! i/o + ,rqiblten=domain%tend%qi_pbl & ! i/o + ,flag_qi=.false. & ! not used in ysu code, so can be whatever? + ,cp=cp & + ,g=gravity & + ,rovcp=rovcp & ! rovcp = Rd/cp + ,rd=Rd & ! J/(kg K) specific gas constant for dry air + ,rovg=rovg & + ,dz8w=domain%dz_interface%data_3d & !-- dz8w dz between full levels (m) + ,z=domain%z%data_3d & !-- z height above sea level (m) + ,xlv=LH_vaporization & !-- xlv latent heat of vaporization (j/kg) + ,rv=Rw & ! J/(kg K) specific gas constant for wet/moist air + ,psfc=domain%surface_pressure%data_2d & + ,znu=domain%znu & ! znu and znw are only used if mut is provided. + ,znw=domain%znw & + ! ,mut="" & ! optional - mass in a cell? + ! ,p_top="" & !, && optional - only if mut is supplied + ,znt=domain%roughness_z0%data_2d & ! i/o -- znt roughness length (m) (input only) + ,ust=domain%ustar & ! i/o -- ust u* in similarity theory (m/s) + ,zol=zol & ! i/o -- zol z/l height over monin-obukhov length - intent(inout) - but appears to not be used really? + ,hol=hol & ! i/o -- hol pbl height over monin-obukhov length - intent(inout) + ,hpbl=domain%hpbl%data_2d & ! i/o -- hpbl pbl height (m) - intent(inout) + ,psim=psim & !-- psim similarity stability function for momentum - intent(in) + ,psih=psih & !-- psih similarity stability function for heat- intent(in) + ,xland=real(domain%land_mask) & + ,hfx=domain%sensible_heat%data_2d & ! HFX - net upward heat flux at the surface (W/m^2) + ,qfx=domain%latent_heat%data_2d/LH_vaporization & ! QFX - net upward moisture flux at the surface (kg/m^2/s) + ,tsk=domain%skin_temperature%data_2d & + ,gz1oz0=gz1oz0 & !-- gz1oz0 log(z/z0) where z0 is roughness length + ,wspd=windspd & ! i/o -- wspd wind speed at lowest model level (m/s) + ,br=Ri & !-- br bulk richardson number in surface layer + ,dt=dt_in & !-- dt time step (s) + ,dtmin=dt_in/60. & !-- dtmin time step (minute) + ,kpbl2d=domain%kpbl & ! o -- ?? k layer of pbl top?? + ,svp1=SVP1 & !-- svp1 constant for saturation vapor pressure (kpa) + ,svp2=SVP2 & !-- svp2 constant for saturation vapor pressure (dimensionless) + ,svp3=SVP3 & !-- svp3 constant for saturation vapor pressure (k) + ,svpt0=SVPT0 & !-- svpt0 constant for saturation vapor pressure (k) + ,ep1=EP1 & !-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless) + ,ep2=EP2 & !-- ep2 constant for specific humidity calculation + ,karman=karman & !-- karman von karman constant + ,eomeg=EOMEG & !-- eomeg angular velocity of earths rotation (rad/s) + ,stbolt=stefan_boltzmann & !-- stbolt stefan-boltzmann constant (w/m^2/k^4) + ,exch_h=domain%coeff_heat_exchange_3d%data_3d & ! i/o -- exch_h ! exchange coefficient for heat, K m/s , but 3d?? + ,u10=domain%u_10m%data_2d & + ,v10=domain%v_10m%data_2d & + ,ids=ids, ide=ide, jds=jds, jde=jde & + ,kds=kds, kde=kde, ims=ims, ime=ime & + ,jms=jms, jme=jme, kms=kms, kme=kme & + ,its=its, ite=ite, jts=jts, jte=jte & + ,kts=kts, kte=kte-1 & + !optional + ,regime=regime )! i/o -- regime flag indicating pbl regime (stable, unstable, etc.) - not used? + + ! if(this_image()==1 .and. options%parameters%debug) write(*,*) " pbl height/lev is:", maxval(domain%hpbl%data_2d ),"m/", maxval(domain%kpbl) ! uncomment if you want to see the pbl height. + + !> ------------ add tendency terms ------------ + ! + ! Here the tendency terms that were calculated by the ysu routine are added to the domain-wide fields. + ! For u and v, we need to re-balance the uvw fields and re-compute dt after we change them. This is done in the + ! step routine in time_step.f90, after the pbl call. + ! + !> ----------------------------------------------- + + ! Offset u/v tendencies to u and v grid, then add + ! call array_offset_x_3d(domain%tend%u , tend_u_ugrid) + ! call array_offset_y_3d(domain%tend%v , tend_v_vgrid) + + ! domain%u%data_3d = domain%u%data_3d + tend_u_ugrid * dt_in + ! domain%v%data_3d = domain%v%data_3d + tend_v_vgrid * dt_in + + ! add mass grid tendencies + domain%water_vapor%data_3d = domain%water_vapor%data_3d + domain%tend%qv_pbl * dt_in + domain%cloud_water_mass%data_3d = domain%cloud_water_mass%data_3d + domain%tend%qc_pbl * dt_in + domain%potential_temperature%data_3d = domain%potential_temperature%data_3d + domain%tend%th_pbl * dt_in + domain%cloud_ice_mass%data_3d = domain%cloud_ice_mass%data_3d + domain%tend%qi_pbl * dt_in + + ! Reset tendencies before the next pbl call. (not sure if necessary) + domain%tend%qv_pbl = 0 + domain%tend%th_pbl = 0 + domain%tend%qc_pbl = 0 + domain%tend%qi_pbl = 0 + domain%tend%u = 0 + domain%tend%v = 0 + + + + ! -------------------- omp loop - how to deal with offset (v) grid?? --------------- + ! ! $omp parallel private(j) & + ! ! $omp default(shared) + ! ! $omp do schedule(static) + ! do j=jts,jte ! OMP loop + + ! domain%u%data_3d(:,:,j) = domain%u%data_3d(:,:,j) + tend_u_ugrid(:,:,j) * dt_in + ! ! domain%v%data_3d(:,:,j) = domain%v%data_3d(:,:,j) + domain%tend%v(:,:,j) * dt_in + + ! domain%water_vapor%data_3d(:,:,j) = domain%water_vapor%data_3d(:,:,j) + domain%tend%qv_pbl(:,:,j) * dt_in + ! domain%cloud_water_mass%data_3d(:,:,j) = domain%cloud_water_mass%data_3d(:,:,j) + domain%tend%qc_pbl(:,:,j) * dt_in + ! domain%potential_temperature%data_3d(:,:,j) = domain%potential_temperature%data_3d(:,:,j) + domain%tend%th_pbl(:,:,j) * dt_in + ! domain%cloud_ice_mass%data_3d(:,:,j) = domain%cloud_ice_mass%data_3d(:,:,j) + domain%tend%qi_pbl(:,:,j) * dt_in + + ! ! Reset tendencies before the next pbl call. (necessary?) + ! domain%tend%qv_pbl(:,:,j) = 0 + ! domain%tend%th_pbl(:,:,j) = 0 + ! domain%tend%qc_pbl(:,:,j) = 0 + ! domain%tend%qi_pbl(:,:,j) = 0 + + ! enddo + ! ! $omp end do + ! ! $omp end parallel + + endif ! End YSU call end subroutine pbl diff --git a/src/physics/pbl_simple.f90 b/src/physics/pbl_simple.f90 index 7e92acd8..8aa75db2 100644 --- a/src/physics/pbl_simple.f90 +++ b/src/physics/pbl_simple.f90 @@ -21,6 +21,7 @@ !!---------------------------------------------------------- module pbl_simple use data_structures + use icar_constants, only : kLC_LAND, kLC_WATER use domain_interface, only : domain_t use options_interface, only : options_t @@ -61,11 +62,11 @@ module pbl_simple ! note, they actually use 30m because they only use this for free-atmosphere mixing ! but they note that 250m is used in the operational model for the full PBL mixing real, parameter :: N_substeps=10. ! number of substeps to allow (puts a cap on K to match CFL) - real, parameter :: diffusion_reduction=10.0 ! used to reduce diffusion rates + real, parameter :: diffusion_reduction=2.0 ! used to reduce diffusion rates contains - subroutine simple_pbl(th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, terrain, its, ite, jts, jte, kts, kte_in, dt, tend_qv_pbl) + subroutine simple_pbl(th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, terrain, land_mask, its, ite, jts, jte, kts, kte_in, dt, tend_qv_pbl) real, intent(inout), dimension(ims:ime, kms:kme, jms:jme) :: th ! potential temperature [K] real, intent(inout), dimension(ims:ime, kms:kme, jms:jme) :: qv ! water vapor mixing ratio [kg/kg] real, intent(inout), dimension(ims:ime, kms:kme, jms:jme) :: cloud ! cloud water mixing ratio [kg/kg] @@ -79,6 +80,7 @@ subroutine simple_pbl(th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, real, intent(in), dimension(ims:ime, kms:kme, jms:jme) :: z ! model level heights [m] real, intent(in), dimension(ims:ime, kms:kme, jms:jme) :: dz ! model level thickness [m] real, intent(in), dimension(ims:ime, jms:jme) :: terrain ! terrain height above sea level [m] + integer,intent(in), dimension(ims:ime, jms:jme) :: land_mask ! water = 2 (kLC_WATER) land = 1 (kLC_LAND) integer,intent(in) :: its, ite, jts, jte, kts, kte_in real, intent(in) :: dt ! time step [s] real, intent(inout), dimension(ims:ime,kms:kme,jms:jme), optional :: tend_qv_pbl ! output water vapor tendency [kg/kg/s] (for use in other physics) @@ -89,7 +91,7 @@ subroutine simple_pbl(th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, ! don't process the top model level regardless, there shouldn't be any real pbl diffusion occuring there kte = min(kme-1, kte_in) ! OpenMP parallelization small static chunk size because we typically get a small area that takes most of the time (because of substepping) - !$omp parallel shared(th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, terrain) & !, tend_qv_pbl) & + !$omp parallel shared(land_mask, th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, terrain) & !, tend_qv_pbl) & !$omp shared(l_m, K_m, Kq_m, stability_m, prandtl_m, virt_pot_temp_zgradient_m, rig_m, shear_m, lastqv_m, ims, ime, jms, jme, kms, kme) & !$omp firstprivate(its, ite, jts, jte, kts, kte, dt) private(i, k, j) @@ -113,8 +115,6 @@ subroutine simple_pbl(th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, ! diffusion for scalars Kq_m(its:ite,k,j) = K_m(its:ite,k,j) / prandtl_m(its:ite,k,j) - ! rescale diffusion to cut down on excessive mixing - Kq_m(its:ite,k,j) = Kq_m(its:ite, k,j) / diffusion_reduction Kq_m(its:ite,k,j) = Kq_m(its:ite, k,j) * dt / ((dz(its:ite,k,j) + dz(its:ite,k+1,j))/2) ! enforce limits specified in HP96 @@ -124,7 +124,11 @@ subroutine simple_pbl(th, qv, cloud, ice, qrain, qsnow, um, vm, pii, rho, z, dz, elseif (Kq_m(i,k,j)<1) then Kq_m(i,k,j)=1 endif + if (land_mask(i,j) == kLC_WATER) Kq_m(i,k,j) = Kq_m(i,k,j) / 1000.0 enddo + + ! rescale diffusion to cut down on excessive mixing + Kq_m(its:ite,k,j) = Kq_m(its:ite, k,j) / diffusion_reduction enddo call pbl_diffusion(qv, th, cloud, ice, qrain, qsnow, rho, dz, its, ite, kts, kte, j) diff --git a/src/physics/pbl_ysu.f90 b/src/physics/pbl_ysu.f90 index ac2cd9ca..806f3b58 100644 --- a/src/physics/pbl_ysu.f90 +++ b/src/physics/pbl_ysu.f90 @@ -153,7 +153,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & ! real, dimension( ims:ime, jms:jme ) , & intent(in ) :: xland, & - hfx, & + hfx, & qfx, & psim, & psih, & @@ -203,6 +203,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & real, dimension( its:ite, kts:kte ) :: rqibl2dt, & pdh real, dimension( its:ite, kts:kte+1 ) :: pdhi + ! do j = jts,jte if(present(mut))then @@ -214,13 +215,14 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & enddo enddo else - do k = kts,kte+1 + do k = kts,kte+1 do i = its,ite if(k.le.kte)pdh(i,k) = p3d(i,k,j) pdhi(i,k) = p3di(i,k,j) enddo enddo endif + call ysu2d(J=j,ux=u3d(ims,kms,j),vx=v3d(ims,kms,j) & ,tx=t3d(ims,kms,j) & ,qx=qv3d(ims,kms,j),qcx=qc3d(ims,kms,j) & @@ -965,7 +967,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,qcx,qix,p2d,p2di,pi2d, & enddo endif ! - do k = kts,kte-1 + do k = kts,kte -1 do i = its,ite dtodsd = dt2/del(i,k) dtodsu = dt2/del(i,k+1) @@ -998,6 +1000,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,qcx,qix,p2d,p2di,pi2d, & exch_hx(i,k) = xkzh(i,k) enddo enddo + ! if(ncloud.ge.2) then do ic = 2,ncloud @@ -1044,6 +1047,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,qcx,qix,p2d,p2di,pi2d, & qtnp(i,k) = qtnp(i,k)+qtend enddo enddo + ! if(ncloud.ge.2) then do ic = 2,ncloud diff --git a/src/physics/ra_clWRF_support.f90 b/src/physics/ra_clWRF_support.f90 new file mode 100755 index 00000000..5804abd8 --- /dev/null +++ b/src/physics/ra_clWRF_support.f90 @@ -0,0 +1,597 @@ +!----------------------------------------------------------------------- +! +! Contains all subroutines to get time-varying mixing ratios of CO2, +! N2O, CH4, CFC11 and CFC12 into radiation schemes. +! These subroutines enable the user to specify the mixing ratios +! in the file CAMtr_volume_mixing_ratio, giving the user an easy way +! to specify trace gases concentrations. +! +! The subroutines were first developed by and put together in this module +! by C. Carouge. +!----------------------------------------------------------------------- +MODULE module_ra_clWRF_support + + !USE module_wrf_error + + IMPLICIT NONE + PRIVATE + INTEGER, PARAMETER :: r8 = 8 + integer, parameter :: cyr = 1800 ! maximum num. of lines in 'CAMtr_volume_mixing_ratio' file + integer, DIMENSION(1:cyr), SAVE :: yrdata + real, DIMENSION(1:cyr), SAVE :: juldata + real(r8), DIMENSION(1:cyr), SAVE :: co2r, n2or, ch4r, cfc11r, cfc12r + + + ! Same values as in module_ra_cam_support.F + integer, parameter :: VARCAM_in_years = 233 + integer :: yr_CAM(1:VARCAM_in_years) = & + (/ 1869, 1870, 1871, 1872, 1873, 1874, 1875, & + 1876, 1877, 1878, 1879, 1880, 1881, 1882, & + 1883, 1884, 1885, 1886, 1887, 1888, 1889, & + 1890, 1891, 1892, 1893, 1894, 1895, 1896, & + 1897, 1898, 1899, 1900, 1901, 1902, 1903, & + 1904, 1905, 1906, 1907, 1908, 1909, 1910, & + 1911, 1912, 1913, 1914, 1915, 1916, 1917, & + 1918, 1919, 1920, 1921, 1922, 1923, 1924, & + 1925, 1926, 1927, 1928, 1929, 1930, 1931, & + 1932, 1933, 1934, 1935, 1936, 1937, 1938, & + 1939, 1940, 1941, 1942, 1943, 1944, 1945, & + 1946, 1947, 1948, 1949, 1950, 1951, 1952, & + 1953, 1954, 1955, 1956, 1957, 1958, 1959, & + 1960, 1961, 1962, 1963, 1964, 1965, 1966, & + 1967, 1968, 1969, 1970, 1971, 1972, 1973, & + 1974, 1975, 1976, 1977, 1978, 1979, 1980, & + 1981, 1982, 1983, 1984, 1985, 1986, 1987, & + 1988, 1989, 1990, 1991, 1992, 1993, 1994, & + 1995, 1996, 1997, 1998, 1999, 2000, 2001, & + 2002, 2003, 2004, 2005, 2006, 2007, 2008, & + 2009, 2010, 2011, 2012, 2013, 2014, 2015, & + 2016, 2017, 2018, 2019, 2020, 2021, 2022, & + 2023, 2024, 2025, 2026, 2027, 2028, 2029, & + 2030, 2031, 2032, 2033, 2034, 2035, 2036, & + 2037, 2038, 2039, 2040, 2041, 2042, 2043, & + 2044, 2045, 2046, 2047, 2048, 2049, 2050, & + 2051, 2052, 2053, 2054, 2055, 2056, 2057, & + 2058, 2059, 2060, 2061, 2062, 2063, 2064, & + 2065, 2066, 2067, 2068, 2069, 2070, 2071, & + 2072, 2073, 2074, 2075, 2076, 2077, 2078, & + 2079, 2080, 2081, 2082, 2083, 2084, 2085, & + 2086, 2087, 2088, 2089, 2090, 2091, 2092, & + 2093, 2094, 2095, 2096, 2097, 2098, 2099, & + 2100, 2101 /) + real :: co2r_CAM(1:VARCAM_in_years) = & + (/ 289.263, 289.263, 289.416, 289.577, 289.745, 289.919, 290.102, & + 290.293, 290.491, 290.696, 290.909, 291.129, 291.355, 291.587, 291.824, & + 292.066, 292.313, 292.563, 292.815, 293.071, 293.328, 293.586, 293.843, & + 294.098, 294.35, 294.598, 294.842, 295.082, 295.32, 295.558, 295.797, & + 296.038, 296.284, 296.535, 296.794, 297.062, 297.338, 297.62, 297.91, & + 298.204, 298.504, 298.806, 299.111, 299.419, 299.729, 300.04, 300.352, & + 300.666, 300.98, 301.294, 301.608, 301.923, 302.237, 302.551, 302.863, & + 303.172, 303.478, 303.779, 304.075, 304.366, 304.651, 304.93, 305.206, & + 305.478, 305.746, 306.013, 306.28, 306.546, 306.815, 307.087, 307.365, & + 307.65, 307.943, 308.246, 308.56, 308.887, 309.228, 309.584, 309.956, & + 310.344, 310.749, 311.172, 311.614, 312.077, 312.561, 313.068, 313.599, & + 314.154, 314.737, 315.347, 315.984, 316.646, 317.328, 318.026, 318.742, & + 319.489, 320.282, 321.133, 322.045, 323.021, 324.06, 325.155, 326.299, & + 327.484, 328.698, 329.933, 331.194, 332.499, 333.854, 335.254, 336.69, & + 338.15, 339.628, 341.125, 342.65, 344.206, 345.797, 347.397, 348.98, & + 350.551, 352.1, 354.3637, 355.7772, 357.1601, 358.5306, 359.9046, & + 361.4157, 363.0445, 364.7761, 366.6064, 368.5322, 370.534, 372.5798, & + 374.6564, 376.7656, 378.9087, 381.0864, 383.2994, 385.548, 387.8326, & + 390.1536, 392.523, 394.9625, 397.4806, 400.075, 402.7444, 405.4875, & + 408.3035, 411.1918, 414.1518, 417.1831, 420.2806, 423.4355, 426.6442, & + 429.9076, 433.2261, 436.6002, 440.0303, 443.5168, 447.06, 450.6603, & + 454.3059, 457.9756, 461.6612, 465.3649, 469.0886, 472.8335, 476.6008, & + 480.3916, 484.2069, 488.0473, 491.9184, 495.8295, 499.7849, 503.7843, & + 507.8278, 511.9155, 516.0476, 520.2243, 524.4459, 528.7127, 533.0213, & + 537.3655, 541.7429, 546.1544, 550.6005, 555.0819, 559.5991, 564.1525, & + 568.7429, 573.3701, 578.0399, 582.7611, 587.5379, 592.3701, 597.2572, & + 602.1997, 607.1975, 612.2507, 617.3596, 622.524, 627.7528, 633.0616, & + 638.457, 643.9384, 649.505, 655.1568, 660.8936, 666.7153, 672.6219, & + 678.6133, 684.6945, 690.8745, 697.1569, 703.5416, 710.0284, 716.6172, & + 723.308, 730.1008, 736.9958, 743.993, 751.0975, 758.3183, 765.6594, & + 773.1207, 780.702, 788.4033, 796.2249, 804.1667, 812.2289, 820.4118, & + 828.6444, 828.6444 /) + + PUBLIC :: read_CAMgases + +CONTAINS + + SUBROUTINE read_CAMgases(yr, julian, model, co2vmr, n2ovmr, ch4vmr, cfc11vmr, cfc12vmr) + USE io_routines , ONLY: io_newunit + INTEGER, INTENT(IN) :: yr + REAL, INTENT(IN) :: julian + CHARACTER(LEN=*), INTENT(IN) :: model ! Radiation scheme name + REAL(r8), OPTIONAL, INTENT(OUT) :: co2vmr, n2ovmr, ch4vmr, cfc11vmr, cfc12vmr + +!Local + + INTEGER :: yearIN, found_yearIN, iyear & + ,yr1,yr2 + INTEGER :: mondata(1:cyr) + !LOGICAL, EXTERNAL :: wrf_dm_on_monitor + !INTEGER, EXTERNAL :: get_unused_unit + + INTEGER :: istatus, iunit, idata +!ccc VARCAM_in_years is a module variable, needs something else here! + INTEGER, SAVE :: max_years + integer :: nyrm, nyrp, njulm, njulp + LOGICAL :: exists + LOGICAL, SAVE :: READtrFILE=.FALSE. + CHARACTER(LEN=256) :: message + INTEGER :: monday(13)=(/0,31,28,31,30,31,30,31,31,30,31,30,31/) + INTEGER :: mondayi(13) + INTEGER :: my1,my2,my3, tot_valid + +! CLWRF-UC June.09 (Copy from share/wrf_tsin.F) + IF ( .NOT. READtrFILE ) THEN + READtrFILE= .TRUE. + + INQUIRE(FILE='CAMtr_volume_mixing_ratio', EXIST=exists) + + IF (exists) THEN + !iunit = get_unused_unit() + iunit = io_newunit() + IF ( iunit <= 0 ) THEN + !F ( wrf_dm_on_monitor() ) THEN + !CALL wrf_error_fatal('Error in module_ra_rrtm: could not find a free Fortran unit.') + error stop 'Error in module_ra_rrtm: could not find a free Fortran unit.' + !END IF + END IF + + ! Read volume mixing ratio + OPEN(UNIT=iunit, FILE='CAMtr_volume_mixing_ratio', FORM='formatted', & + STATUS='old', IOSTAT=istatus) + + IF (istatus == 0) THEN + ! Ignore first two lines which constitute a header + READ(UNIT=iunit, FMT='(1X)') + READ(UNIT=iunit, FMT='(1X)') + + istatus = 0 + idata = 1 + DO WHILE (istatus == 0) + READ(UNIT=iunit, FMT='(I4, 1x, F8.3,1x, 4(F10.3,1x))', IOSTAT=istatus) & + yrdata(idata), co2r(idata), n2or(idata), ch4r(idata), cfc11r(idata), & + cfc12r(idata) + if (istatus==0) then + !IF ( wrf_dm_on_monitor() ) THEN + if (idata==1) then + WRITE(message,*)'CLWRF reading...: istatus:',istatus,' idata:',idata, & + ' year:', yrdata(idata), ' co2: ',co2r(idata), ' n2o: ',& + n2or(idata),' ch4:',ch4r(idata) + !call wrf_debug( 0, message) + if (this_image()==1) write(*,*) trim(message) + endif + ! ENDIF + mondata(idata) = 6 + + idata=idata+1 + endif + END DO + if (this_image()==1) print*,"CLWRF read:",idata-1, " lines" + + IF (istatus /= -1) THEN + PRINT *,'CLWRF -- clwrf -- CLWRF ALERT!' + PRINT *," Not normal ending of 'CAMtr_volume_mixing_ratio' file" + PRINT *," Lecture ends with 'IOSTAT'=",istatus + END IF + max_years = idata - 1 + CLOSE(iunit) + + ! Calculate the julian day for each month. + DO idata=1,max_years + mondayi = monday + MY1=MOD(yrdata(idata),4) + MY2=MOD(yrdata(idata),100) + MY3=MOD(yrdata(idata),400) + IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0) mondayi(3)=29 + juldata(idata) = sum(mondayi(1:mondata(idata)))+real(mondayi(mondata(idata)+1))/2.-0.5 ! 1st Jan 00:00 = 0 julian day + ENDDO + ENDIF + ELSE + max_years = VARCAM_in_years ! Set max number of years to the table size + ! used for CAM. + ! For CAM model, recovers original data sets. + IF (model .eq. "CAM") THEN + yrdata(1:max_years) = yr_CAM + co2r(1:max_years) = co2r_CAM + ELSE + !CALL wrf_error_fatal("CLWRF: 'CAMtr_volume_mixing_ratio' does not exist") + error stop "CLWRF: 'CAMtr_volume_mixing_ratio' does not exist" + ENDIF + + ENDIF ! CAMtr_volume_mixing_ratio exists + + ENDIF ! File already opened and read + + found_yearIN=0 + iyear=1 + !ccc Crash if iyear get > cyr (max. # of years in the mixing ratio file) ? + !DO WHILE (found_yearIN == 0) + DO WHILE (found_yearIN == 0 .and. iyear <= cyr) + IF (yrdata(iyear) .GT. yr ) THEN + yearIN=iyear + found_yearIN=1 + ELSE IF ((yrdata(iyear) .EQ. yr) .AND. (juldata(iyear) .GT. julian)) THEN + yearIN=iyear + found_yearIN = 1 + ENDIF + iyear=iyear+1 + ENDDO + + ! Prevent yr > last year in data +! IF (yearIN .ge. VARCAM_in_years) yearIN=VARCAM_in_years-1 + IF (iyear .ge. max_years) then + yearIN=max_years-1 + found_yearIN = 1 + ENDIF + + IF (found_yearIN .NE. 0 ) THEN + if (yearIN .eq. 1) yearIN = yearIN + 1 ! To take 2 first lines of the file + nyrm = yrdata(yearIN-1) + njulm = juldata(yearIN-1) + nyrp = yrdata(yearIN) + njulp = juldata(yearIN) + ENDIF + + IF (PRESENT(co2vmr)) THEN + co2vmr=-9999.999 + if (found_yearIN /= 0) then + ! Interpolate data only if we have at least 2 valid concentrations. + tot_valid = count(co2r(1:max_years) > 0) + IF (tot_valid >= 2 ) THEN + CALL valid_years(yearIN, co2r, max_years,yr1, yr2) + + ! Set nyrm, njulm, nyrp, njulp + nyrm = yrdata(yr1) + njulm = juldata(yr1) + nyrp = yrdata(yr2) + njulp = juldata(yr2) + + CALL interpolate_CAMgases(yr, julian, nyrm, njulm, yr1, yr2, nyrp, njulp, co2r, co2vmr) + ENDIF + endif + ! Verification of interpolated values. In case of no value + ! original values extracted from ghg_surfvals.F90 module + + IF (co2vmr < 0. .or. found_yearIN == 0) THEN + CALL orig_val("CO2",model,co2vmr) + ELSE + ! If extrapolation, need to bound the data to pre-industrial concentrations + if (co2vmr < 270.) co2vmr = 270. + co2vmr=co2vmr*1.e-06 + END IF + ENDIF + + IF (PRESENT(n2ovmr)) THEN + n2ovmr=-9999.999 + if (found_yearIN /= 0) then + tot_valid = count(n2or(1:max_years) > 0) + IF (tot_valid >= 2 ) THEN + CALL valid_years(yearIN, n2or, max_years,yr1, yr2) + + ! Set nyrm, njulm, nyrp, njulp + nyrm = yrdata(yr1) + njulm = juldata(yr1) + nyrp = yrdata(yr2) + njulp = juldata(yr2) + + CALL interpolate_CAMgases(yr, julian, nyrm, njulm, yr1, yr2, nyrp, njulp, n2or, n2ovmr) + ENDIF + endif + + IF (n2ovmr < 0. .or. found_yearIN == 0) THEN + CALL orig_val("N2O",model,n2ovmr) + ELSE + ! If extrapolation, need to bound the data to pre-industrial concentrations + if (n2ovmr < 270.) n2ovmr = 270. + n2ovmr=n2ovmr*1.e-09 + ENDIF + + ENDIF + + IF (PRESENT(ch4vmr)) THEN + ch4vmr=-9999.999 + if (found_yearIN /= 0) then + tot_valid = count(ch4r(1:max_years) > 0) + IF (tot_valid >= 2 ) THEN + CALL valid_years(yearIN, ch4r, max_years,yr1, yr2) + + ! Set nyrm, njulm, nyrp, njulp + nyrm = yrdata(yr1) + njulm = juldata(yr1) + nyrp = yrdata(yr2) + njulp = juldata(yr2) + + CALL interpolate_CAMgases(yr, julian, nyrm, njulm, yr1, yr2, nyrp, njulp, ch4r, ch4vmr) + endif + endif + + IF (ch4vmr < 0. .or. found_yearIN == 0) THEN + CALL orig_val("CH4",model,ch4vmr) + ELSE + ! If extrapolation, need to bound the data to pre-industrial concentrations + if (ch4vmr < 700. ) ch4vmr = 700. + ch4vmr=ch4vmr*1.e-09 + ENDIF + ENDIF + + IF (PRESENT(cfc11vmr)) THEN + cfc11vmr = -9999.999 + if (found_yearIN /= 0) then + tot_valid = count(cfc11r(1:max_years) > 0) + IF (tot_valid >= 2 ) THEN + CALL valid_years(yearIN, cfc11r, max_years,yr1, yr2) + + ! Set nyrm, njulm, nyrp, njulp + nyrm = yrdata(yr1) + njulm = juldata(yr1) + nyrp = yrdata(yr2) + njulp = juldata(yr2) + + CALL interpolate_CAMgases(yr, julian, nyrm, njulm, yr1, yr2, nyrp, njulp, cfc11r, cfc11vmr) + endif + endif + + IF (cfc11vmr < 0. .or. found_yearIN == 0) THEN + CALL orig_val("CFC11",model,cfc11vmr) + ELSE + cfc11vmr=cfc11vmr*1.e-12 + ENDIF + ENDIF + + IF (PRESENT(cfc12vmr)) THEN + cfc12vmr = -9999.999 + if (found_yearIN /= 0) then + tot_valid = count(cfc12r(1:max_years) > 0) + IF (tot_valid >= 2 ) THEN + CALL valid_years(yearIN, cfc12r, max_years,yr1, yr2) + + ! Set nyrm, njulm, nyrp, njulp + nyrm = yrdata(yr1) + njulm = juldata(yr1) + nyrp = yrdata(yr2) + njulp = juldata(yr2) + + CALL interpolate_CAMgases(yr, julian, nyrm, njulm, yr1, yr2, nyrp, njulp, cfc12r, cfc12vmr) + endif + endif + + IF (cfc12vmr < 0. .or. found_yearIN == 0) THEN + CALL orig_val("CFC12",model,cfc12vmr) + ELSE + cfc12vmr=cfc12vmr*1.e-12 + ENDIF + ENDIF + + END SUBROUTINE read_CAMgases + + SUBROUTINE valid_years(yearIN, gas, tot_years, yr1, yr2) + +! Find + INTEGER, INTENT(IN) :: yearIN, tot_years + INTEGER, INTENT(OUT) :: yr2, yr1 + REAL(r8), INTENT(IN) :: gas(:) + + ! Local variables + INTEGER :: yr_loc, idata + + + yr_loc = yearIN + yr2 = yr_loc + yr1 = yr_loc-1 + + ! If all valid dates are > yearIN then find the 2 lowest dates with + ! valid data. + IF (count(gas(1:yr_loc-1) > 0.) == 0) THEN +!ccc DO idata = yr_loc-1, tot_years-1 + DO idata = yr_loc, tot_years-1 + IF (gas(idata) > 0.) THEN + yr1 = idata + EXIT + ENDIF + ENDDO +!ccc DO idata = yr1, tot_years + DO idata = yr1+1, tot_years + IF (gas(idata) > 0.) THEN + yr2 = idata + EXIT + ENDIF + ENDDO + ELSE ! There is at least 1 valid year below yearIN + IF (gas(yr_loc) < 0.) THEN + + ! Find the closest valid year, look for higher year first + IF (any(gas(yr_loc:tot_years) > 0)) THEN + DO idata=yr_loc+1, tot_years + IF (gas(idata) > 0) THEN + yr2 = idata + exit + ENDIF + ENDDO + ELSE ! Need to take lower years and extrapolate data. + DO idata=yr_loc-1,2,-1 + IF (gas(idata) > 0) THEN + yr2 = idata + exit + ENDIF + ENDDO + ENDIF + ENDIF + + yr_loc = min(yr_loc-1, yr2-1) + IF (gas(yr_loc) < 0.) THEN + + ! Find the closest valid year, lower than yr1 + IF (any(gas(1:yr_loc-1) > 0)) THEN + DO idata=yr_loc-1,1,-1 + IF (gas(idata) > 0) THEN + yr1 = idata + exit + ENDIF + ENDDO + ELSE ! Need to take higher years and extrapolate data. + print*, 'Problem: this case should never happen' + ENDIF + ELSE ! Then yr1 is yr_loc (first valid date < yr2) + yr1 = yr_loc + ENDIF + ENDIF + END SUBROUTINE valid_years + + SUBROUTINE interpolate_CAMgases(yr, julian, yeari, juli, yr1, yr2, yearf, julf, gas, interp_gas) + IMPLICIT NONE +! These subroutine interpolates a trace gas concentration from a non-homogeneously +! distributed gas concentration evolution + INTEGER, INTENT (IN) :: yr, yeari, yr1, yr2, yearf, juli, julf + REAL, INTENT (IN) :: julian + REAL(r8), DIMENSION(500), INTENT (IN) :: gas + REAL(r8), INTENT (OUT) :: interp_gas +!Local + REAL(r8) :: yearini, yearend, gas1, gas2 + REAL :: doymodel, doydatam, doydatap, & + deltat, fact1, fact2, x + INTEGER :: ny, my1,my2,my3,nday, maxyear, minyear + + + ! Add support for leap-years + + ! Find smallest and largest year: yearf >= yeari since the file is ordered with increasing dates. + minyear = MIN(yr,yeari) + maxyear = MAX(yr,yearf) + + ! Initialise with the day in the year for each date. + fact2 = juli + fact1 = julf + x = julian + + ! Calculate the julian day (day 0 = 1 Jan minyear at 00:00) + DO ny=minyear, maxyear-1 + nday = 365 + ! Leap-year? + MY1=MOD(ny,4) + MY2=MOD(ny,100) + MY3=MOD(ny,400) + IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0) nday=366 + + if (ny < yeari) then + fact2 = fact2+nday + endif + if (ny < yr) then + x = x+nday + endif + if (ny < yearf) then + fact1 = fact1+nday + endif + enddo + + deltat = fact1-fact2 + fact1 = (fact1 - x)/deltat + fact2 = (x - fact2)/deltat + + interp_gas = gas(yr1)*fact1+gas(yr2)*fact2 + + IF (interp_gas .LT. 0. ) THEN + interp_gas=-99999. + ENDIF + + END SUBROUTINE interpolate_CAMgases + + SUBROUTINE interpolate_lin(x1,y1,x2,y2,x0,y) + IMPLICIT NONE +! Program to interpolate values y=a+b*x with: +! a=y1 +! b=(y2-y1)/(x2-x1) +! x=abs(x1-x0) + + REAL, INTENT (IN) :: x1,x2,x0 + REAL(r8), INTENT (IN) :: y1,y2 + REAL(r8), INTENT (OUT) :: y + REAL(r8) :: a,b,x + + a=y1 + b=(y2-y1)/(x2-x1) + + IF (x0 .GE. x1) THEN + x=x0-x1 + ELSE + x=x1-x0 + b=-b + ENDIF + + y=a+b*x + + END SUBROUTINE interpolate_lin + + + SUBROUTINE orig_val(tracer,model,out) + + CHARACTER(LEN=*), INTENT(IN) :: tracer ! The trace gas name + CHARACTER(LEN=*), INTENT(IN) :: model ! The radiation scheme name + REAL(r8), INTENT(INOUT) :: out ! The output value +!Local + !LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER(LEN=256) :: message + + + IF (model .eq. "CAM") THEN + IF (tracer .eq. "CO2") THEN + out = 3.55e-4 + + ELSE IF (tracer .eq. "N2O") THEN + out = 0.311e-6 + + ELSE IF (tracer .eq. "CH4") THEN + out = 1.714e-6 + + ELSE IF (tracer .eq. "CFC11") THEN + out = 0.280e-9 + + ELSE IF (tracer .eq. "CFC12") THEN + out = 0.503e-9 + + ELSE + !IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*) 'CLWRF : Trace gas ',tracer,' not valid for scheme ',model + !CALL wrf_error_fatal(message) + error stop message + !ENDIF + ENDIF + + ELSE IF ((model .eq. "RRTM") .or. & + (model .eq. "RRTMG")) THEN + IF (tracer .eq. "CO2") THEN + out = 379.e-6 + + ELSE IF (tracer .eq. "N2O") THEN + out = 319e-9 + + ELSE IF (tracer .eq. "CH4") THEN + out = 1774.e-9 + + ELSE IF (tracer .eq. "CFC11") THEN + out = 0.251e-9 + + ELSE IF (tracer .eq. "CFC12") THEN + out = 0.538e-9 + + ELSE + !IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*) 'CLWRF : Trace gas ',tracer,' not valid for scheme ',model + !CALL wrf_error_fatal(message) + error stop message + !ENDIF + ENDIF + + ELSE + !IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*) 'CLWRF not implemented for the ',model,' radiative scheme.' + !CALL wrf_error_fatal(message) + error stop message + !ENDIF + ENDIF + + END SUBROUTINE orig_val + +END MODULE module_ra_clWRF_support diff --git a/src/physics/ra_driver.f90 b/src/physics/ra_driver.f90 index 68e6b915..b088cfff 100644 --- a/src/physics/ra_driver.f90 +++ b/src/physics/ra_driver.f90 @@ -23,17 +23,21 @@ !! !!---------------------------------------------------------- module radiation - use module_ra_simple, only: ra_simple, ra_simple_init + use module_ra_simple, only: ra_simple, ra_simple_init, calc_solar_elevation + use module_ra_rrtmg_lw, only: rrtmg_lwinit, rrtmg_lwrad + use module_ra_rrtmg_sw, only: rrtmg_swinit, rrtmg_swrad use options_interface, only : options_t use domain_interface, only : domain_t use data_structures - use icar_constants, only : kVARS - + use icar_constants, only : kVARS, cp, Rd, gravity, solar_constant + use mod_atm_utilities, only : cal_cldfra3 implicit none - + integer :: update_interval + real*8 :: last_model_time contains + subroutine radiation_init(domain,options) - type(domain_t), intent(in) :: domain + type(domain_t), intent(inout) :: domain type(options_t),intent(in) :: options if (this_image()==1) write(*,*) "Initializing Radiation" @@ -46,6 +50,41 @@ subroutine radiation_init(domain,options) call ra_simple_init(domain, options) endif + if (options%physics%radiation==kRA_RRTMG) then + if (this_image()==1) write(*,*) " RRTMG" + if(.not.allocated(domain%tend%th_lwrad)) & + allocate(domain%tend%th_lwrad(domain%ims:domain%ime,domain%kms:domain%kme,domain%jms:domain%jme)) + if(.not.allocated(domain%tend%th_swrad)) & + allocate(domain%tend%th_swrad(domain%ims:domain%ime,domain%kms:domain%kme,domain%jms:domain%jme)) + + if (options%physics%microphysics .ne. kMP_THOMP_AER) then + if (this_image()==1)write(*,*) ' NOTE: When running RRTMG, microphysics option 5 works best.' + endif + + ! needed to allocate module variables so ra_driver can use calc_solar_elevation + call ra_simple_init(domain, options) + + call rrtmg_lwinit( & + !p_top=minval(domain%pressure_interface%data_3d(:,domain%kme,:)), allowed_to_read=.TRUE. , & + ! Added 0.8 factor to make sure p_top is low enough. This value can be changed if code crashes. + ! Code will crash because of negative log value in this expression in ra_rrtmg_lw and ra_rrtmg_sw: + ! plog = log(pavel(lay)) + p_top=(minval(domain%pressure_interface%data_3d(:,domain%kme,:)))*0.8, allowed_to_read=.TRUE. , & + ids=domain%ids, ide=domain%ide, jds=domain%jds, jde=domain%jde, kds=domain%kds, kde=domain%kde, & + ims=domain%ims, ime=domain%ime, jms=domain%jms, jme=domain%jme, kms=domain%kms, kme=domain%kme, & + its=domain%its, ite=domain%ite, jts=domain%jts, jte=domain%jte, kts=domain%kts, kte=domain%kte ) + + call rrtmg_swinit( & + allowed_to_read=.TRUE., & + ids=domain%ids, ide=domain%ide, jds=domain%jds, jde=domain%jde, kds=domain%kds, kde=domain%kde, & + ims=domain%ims, ime=domain%ime, jms=domain%jms, jme=domain%jme, kms=domain%kms, kme=domain%kme, & + its=domain%its, ite=domain%ite, jts=domain%jts, jte=domain%jte, kts=domain%kts, kte=domain%kte ) + domain%tend%th_swrad = 0 + domain%tend%th_lwrad = 0 + endif + update_interval=options%rad_options%update_interval_rrtmg ! 30 min, 1800 s 600 ! 10 min (600 s) + last_model_time=-999 + end subroutine radiation_init @@ -57,6 +96,10 @@ subroutine ra_var_request(options) call ra_simple_var_request(options) endif + if (options%physics%radiation == kRA_RRTMG) then + call ra_rrtmg_var_request(options) + endif + end subroutine ra_var_request @@ -86,6 +129,42 @@ subroutine ra_simple_var_request(options) end subroutine ra_simple_var_request + !> ---------------------------------------------- + !! Communicate to the master process requesting the variables requred to be allocated, used for restart files, and advected + !! + !! ---------------------------------------------- + subroutine ra_rrtmg_var_request(options) + implicit none + type(options_t), intent(inout) :: options + + ! List the variables that are required to be allocated for the simple radiation code + call options%alloc_vars( & + [kVARS%pressure, kVARS%pressure_interface, kVARS%potential_temperature, kVARS%exner, & + kVARS%water_vapor, kVARS%cloud_water, kVARS%rain_in_air, kVARS%snow_in_air, & + kVARS%shortwave, kVARS%longwave, kVARS%cloud_ice, kVARS%graupel_in_air, & + kVARS%re_cloud, kVARS%re_ice, kVARS%re_snow, kVARS%out_longwave_rad, & + kVARS%land_mask, kVARS%snow_water_equivalent, & + kVARS%dz_interface, kVARS%skin_temperature, kVARS%temperature, kVARS%density, & + kVARS%longwave_cloud_forcing, kVARS%land_emissivity, kVARS%temperature_interface, & + kVARS%cosine_zenith_angle, kVARS%shortwave_cloud_forcing, kVARS%tend_swrad, & + kVARS%cloud_fraction, kVARS%albedo]) + + + ! List the variables that are required when restarting for the simple radiation code + call options%restart_vars( & + [kVARS%pressure, kVARS%pressure_interface, kVARS%potential_temperature, kVARS%exner, & + kVARS%water_vapor, kVARS%cloud_water, kVARS%rain_in_air, kVARS%snow_in_air, & + kVARS%shortwave, kVARS%longwave, kVARS%cloud_ice, kVARS%graupel_in_air, & + kVARS%re_cloud, kVARS%re_ice, kVARS%re_snow, kVARS%out_longwave_rad, & + kVARS%snow_water_equivalent, & + kVARS%dz_interface, kVARS%skin_temperature, kVARS%temperature, kVARS%density, & + kVARS%longwave_cloud_forcing, kVARS%land_emissivity, kVARS%temperature_interface, & + kVARS%cosine_zenith_angle, kVARS%shortwave_cloud_forcing, kVars%tend_swrad & + ] ) + + end subroutine ra_rrtmg_var_request + + subroutine rad(domain, options, dt, halo, subset) implicit none @@ -96,6 +175,22 @@ subroutine rad(domain, options, dt, halo, subset) integer :: ims, ime, jms, jme, kms, kme integer :: its, ite, jts, jte, kts, kte + integer :: ids, ide, jds, jde, kds, kde + + real, dimension(:,:,:,:), pointer :: tauaer_sw=>null(), ssaaer_sw=>null(), asyaer_sw=>null() + real, allocatable :: day_frac(:), solar_elevation(:) + real, allocatable:: albedo(:,:),gsw(:,:) + integer :: j + real ::ra_dt + + real :: gridkm + integer :: i, k + real, allocatable:: t_1d(:), p_1d(:), Dz_1d(:), qv_1d(:), qc_1d(:), qi_1d(:), qs_1d(:), cf_1d(:) + real, allocatable :: qc(:,:,:),qi(:,:,:), qs(:,:,:), cldfra(:,:,:) + real, allocatable :: xland(:,:) + + logical :: f_qr, f_qc, f_qi, f_qs, f_qg, f_qv, f_qndrop + integer :: mp_options ims = domain%grid%ims ime = domain%grid%ime @@ -110,6 +205,63 @@ subroutine rad(domain, options, dt, halo, subset) kts = domain%grid%kts kte = domain%grid%kte + ids = domain%grid%ids + ide = domain%grid%ide + jds = domain%grid%jds + jde = domain%grid%jde + kds = domain%grid%kds + kde = domain%grid%kde + + allocate(t_1d(kms:kme)) + allocate(p_1d(kms:kme)) + allocate(Dz_1d(kms:kme)) + allocate(qv_1d(kms:kme)) + allocate(qc_1d(kms:kme)) + allocate(qi_1d(kms:kme)) + allocate(qs_1d(kms:kme)) + allocate(cf_1d(kms:kme)) + + allocate(qc(ims:ime,kms:kme,jms:jme)) + allocate(qi(ims:ime,kms:kme,jms:jme)) + allocate(qs(ims:ime,kms:kme,jms:jme)) + allocate(cldfra(ims:ime,kms:kme,jms:jme)) + allocate(xland(ims:ime,jms:jme)) + + allocate(day_frac(ims:ime)) + allocate(solar_elevation(ims:ime)) + allocate(albedo(ims:ime,jms:jme)) + allocate(gsw(ims:ime,jms:jme)) + + ! Note, need to link NoahMP to update albedo + + qc = 0 + qi = 0 + qs = 0 + + cldfra=0 + + F_QI=.false. + F_QC=.false. + F_QR=.false. + F_QS=.false. + F_QG=.false. + f_qndrop=.false. + F_QV=.false. + + F_QI=associated(domain%cloud_ice_mass%data_3d ) + F_QC=associated(domain%cloud_water_mass%data_3d ) + F_QR=associated(domain%rain_mass%data_3d ) + F_QS=associated(domain%snow_mass%data_3d ) + F_QV=associated(domain%water_vapor%data_3d ) + !F_QG=associated(domain%graupel_mass%data_3d ) + F_QNDROP=associated(domain%cloud_number%data_3d) + + if (F_QC) qc(:,:,:) = domain%cloud_water_mass%data_3d + if (F_QI) qi(:,:,:) = domain%cloud_ice_mass%data_3d + if (F_QS) qs(:,:,:) = domain%snow_mass%data_3d + + mp_options=0 + if (options%physics%radiation==kRA_SIMPLE) then call ra_simple(theta = domain%potential_temperature%data_3d, & pii= domain%exner%data_3d, & @@ -129,7 +281,240 @@ subroutine rad(domain, options, dt, halo, subset) options = options, & dt = dt, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & - its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte) + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, F_runlw=.True.) + endif + + if (options%physics%radiation==kRA_RRTMG) then + + if (options%lsm_options%monthly_albedo) then + ALBEDO = domain%albedo%data_3d(:, domain%model_time%month, :) + else + ALBEDO = domain%albedo%data_3d(:, 1, :) + endif + + do j = jms,jme + solar_elevation = calc_solar_elevation(date=domain%model_time, lon=domain%longitude%data_2d, & + j=j, ims=ims,ime=ime,jms=jms,jme=jme,its=its,ite=ite,day_frac=day_frac) + domain%cosine_zenith_angle%data_2d(its:ite,j)=sin(solar_elevation(its:ite)) + enddo + + if (last_model_time==-999) then + last_model_time = domain%model_time%seconds()-update_interval + endif + if ((domain%model_time%seconds() - last_model_time) >= update_interval) then + ra_dt = domain%model_time%seconds() - last_model_time + last_model_time = domain%model_time%seconds() + domain%tend%th_swrad = 0 + domain%shortwave%data_2d = 0 + ! Calculate cloud fraction + If (options%rad_options%icloud == 3) THEN + IF ( F_QC .AND. F_QI ) THEN + gridkm = domain%dx/1000 + XLAND = domain%land_mask + domain%cloud_fraction%data_2d = 0 + DO j = jts,jte + DO i = its,ite + DO k = kts,kte + p_1d(k) = domain%pressure%data_3d(i,k,j) !p(i,k,j) + t_1d(k) = domain%temperature%data_3d(i,k,j) + qv_1d(k) = domain%water_vapor%data_3d(i,k,j) + qc_1d(k) = domain%cloud_water_mass%data_3d(i,k,j) + qi_1d(k) = domain%cloud_ice_mass%data_3d(i,k,j) + qs_1d(k) = domain%snow_mass%data_3d(i,k,j) + Dz_1d(k) = domain%dz_interface%data_3d(i,k,j) + cf_1d(k) = cldfra(i,k,j) + ENDDO + CALL cal_cldfra3(cf_1d, qv_1d, qc_1d, qi_1d, qs_1d, Dz_1d, & + & p_1d, t_1d, XLAND(i,j), gridkm, & + & .false., 1.5, kms, kme) + + DO k = kts,kte + ! qc, qi and qs are locally recalculated in cal_cldfra3 base on RH to account for subgrid clouds qc(i,k,j) = qc_1d(k) + qc(i,k,j) = qc_1d(k) + qi(i,k,j) = qi_1d(k) + qs(i,k,j) = qs_1d(k) + cldfra(i,k,j) = cf_1d(k) + domain%cloud_fraction%data_2d(i,j) = max(domain%cloud_fraction%data_2d(i,j), cf_1d(k)) + ENDDO + ENDDO + ENDDO + END IF + END IF + + if (.not.options%rad_options%use_simple_sw) then + call RRTMG_SWRAD(rthratensw=domain%tend%th_swrad, & + ! swupt, swuptc, swuptcln, swdnt, swdntc, swdntcln, & + ! swupb, swupbc, swupbcln, swdnb, swdnbc, swdnbcln, & + ! swupflx, swupflxc, swdnflx, swdnflxc, & + swdnb = domain%shortwave%data_2d, & + swcf = domain%shortwave_cloud_forcing%data_2d, & + gsw = gsw, & + xtime = 0., gmt = 0., & ! not used + xlat = domain%latitude%data_2d, & ! not used + xlong = domain%longitude%data_2d, & ! not used + radt = 0., degrad = 0., declin = 0., & ! not used + coszr = domain%cosine_zenith_angle%data_2d, & + julday = 0, & ! not used + solcon = solar_constant, & + albedo = albedo, & + t3d = domain%temperature%data_3d, & + t8w = domain%temperature_interface%data_3d, & + tsk = domain%skin_temperature%data_2d, & + p3d = domain%pressure%data_3d, & + p8w = domain%pressure_interface%data_3d, & + pi3d = domain%exner%data_3d, & + rho3d = domain%density%data_3d, & + dz8w = domain%dz_interface%data_3d, & + cldfra3d=cldfra, & + !, lradius, iradius, & + is_cammgmp_used = .False., & + r = Rd, & + g = gravity, & + re_cloud = domain%re_cloud%data_3d, & + re_ice = domain%re_ice%data_3d, & + re_snow = domain%re_snow%data_3d, & + has_reqc=1, & ! use with icloud > 0 + has_reqi=1, & ! use with icloud > 0 + has_reqs=1, & ! use with icloud > 0 ! G. Thompson + icloud = options%rad_options%icloud, & ! set to nonzero if effective radius is available from microphysics + warm_rain = .False., & ! when a dding WSM3scheme, add option for .True. + cldovrlp=1, & ! J. Henderson AER: cldovrlp namelist value + !f_ice_phy, f_rain_phy, & + xland=real(domain%land_mask), & + xice=real(domain%land_mask)*0, & ! should add a variable for sea ice fraction + snow=domain%snow_water_equivalent%data_2d, & + qv3d=domain%water_vapor%data_3d, & + qc3d=qc, & + qr3d=domain%rain_mass%data_3d, & + qi3d=qi, & + qs3d=qs, & + qg3d=domain%graupel_mass%data_3d, & + !o3input, o33d, & + aer_opt=0, & + !aerod, & + no_src = 1, & + ! alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011) + ! alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011) + ! swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011) + ! swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011) + sf_surface_physics=1, & !Zhenxin + f_qv=f_qv, f_qc=f_qc, f_qr=f_qr, & + f_qi=f_qi, f_qs=f_qs, f_qg=f_qg, & + !tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao + !gaer300,gaer400,gaer600,gaer999, & ! czhao + !waer300,waer400,waer600,waer999, & ! czhao + ! aer_ra_feedback, & + !jdfcz progn,prescribe, & + calc_clean_atm_diag=0, & + ! qndrop3d=domain%cloud_number%data_3d, & + f_qndrop=f_qndrop, & !czhao + mp_physics=0, & !wang 2014/12 + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte-1, & + !swupflx, swupflxc, & + !swdnflx, swdnflxc, & + tauaer3d_sw=tauaer_sw, & ! jararias 2013/11 + ssaaer3d_sw=ssaaer_sw, & ! jararias 2013/11 + asyaer3d_sw=asyaer_sw, & + ! swddir = domain%skin_temperature%data_2d, & + ! swddni = domain%skin_temperature%data_2d, & + ! swddif = domain%skin_temperature%data_2d, & ! jararias 2013/08 + ! swdownc = domain%skin_temperature%data_2d, & + ! swddnic = domain%skin_temperature%data_2d, & + ! swddirc = domain%skin_temperature%data_2d, & ! PAJ + xcoszen = domain%cosine_zenith_angle%data_2d, & ! NEED TO CALCULATE THIS. + yr=domain%model_time%year, & + julian=domain%model_time%day_of_year(), & + mp_options=mp_options ) + else + call ra_simple(theta = domain%potential_temperature%data_3d, & + pii= domain%exner%data_3d, & + qv = domain%water_vapor%data_3d, & + qc = domain%cloud_water_mass%data_3d, & + qs = domain%snow_mass%data_3d & + + domain%cloud_ice_mass%data_3d & + + domain%graupel_mass%data_3d, & + qr = domain%rain_mass%data_3d, & + p = domain%pressure%data_3d, & + swdown = domain%shortwave%data_2d, & + lwdown = domain%longwave%data_2d, & + cloud_cover = domain%cloud_fraction%data_2d, & + lat = domain%latitude%data_2d, & + lon = domain%longitude%data_2d, & + date = domain%model_time, & + options = options, & + dt = dt, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, F_runlw=.False.) + endif ! simple SW only + + call RRTMG_LWRAD(rthratenlw=domain%tend%th_lwrad, & +! lwupt, lwuptc, lwuptcln, lwdnt, lwdntc, lwdntcln, & !if lwupt defined, all MUST be defined +! lwupb, lwupbc, lwupbcln, lwdnb, lwdnbc, lwdnbcln, & + glw = domain%longwave%data_2d, & + olr = domain%out_longwave_rad%data_2d, & + lwcf = domain%longwave_cloud_forcing%data_2d, & + emiss = domain%land_emissivity%data_2d, & + p8w = domain%pressure_interface%data_3d, & + p3d = domain%pressure%data_3d, & + pi3d = domain%exner%data_3d, & + dz8w = domain%dz_interface%data_3d, & + tsk = domain%skin_temperature%data_2d, & + t3d = domain%temperature%data_3d, & + t8w = domain%temperature_interface%data_3d, & ! temperature interface + rho3d = domain%density%data_3d, & + r = Rd, & + g = gravity, & + icloud = options%rad_options%icloud, & ! set to nonzero if effective radius is available from microphysics + warm_rain = .False., & ! when a dding WSM3scheme, add option for .True. + cldfra3d = cldfra, & + cldovrlp=1, & ! set to 1 for now. Could make this ICAR namelist option +! lradius,iradius, & !goes with CAMMGMP (Morrison Gettelman CAM mp) + is_cammgmp_used = .False., & !goes with CAMMGMP (Morrison Gettelman CAM mp) +! f_ice_phy, f_rain_phy, & !goes with MP option 5 (Ferrier) + xland=real(domain%land_mask), & + xice=real(domain%land_mask)*0, & ! should add a variable for sea ice fraction + snow=domain%snow_water_equivalent%data_2d, & + qv3d=domain%water_vapor%data_3d, & + qc3d=qc, & + qr3d=domain%rain_mass%data_3d, & + qi3d=qi, & + qs3d=qs, & + qg3d=domain%graupel_mass%data_3d, & +! o3input, o33d, & + f_qv=f_qv, f_qc=f_qc, f_qr=f_qr, & + f_qi=f_qi, f_qs=f_qs, f_qg=f_qg, & + re_cloud = domain%re_cloud%data_3d, & + re_ice = domain%re_ice%data_3d, & + re_snow = domain%re_snow%data_3d, & + has_reqc=1, & ! use with icloud > 0 + has_reqi=1, & ! use with icloud > 0 + has_reqs=1, & ! use with icloud > 0 ! G. Thompson +! tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao +! tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao +! tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao +! tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & ! czhao +! aer_ra_feedback, & !czhao +! !jdfcz progn,prescribe, & !czhao + calc_clean_atm_diag=0, & ! used with wrf_chem !czhao +! qndrop3d=domain%cloud_number%data_3d, & ! used with icould > 0 + f_qndrop=f_qndrop, & ! if icloud > 0, use this + !ccc added for time varying gases. + yr=domain%model_time%year, & + julian=domain%model_time%day_of_year(), & + !ccc + mp_physics=0, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte-1,& +! lwupflx, lwupflxc, lwdnflx, lwdnflxc, & + read_ghg=options%rad_options%read_ghg & + ) + domain%tend_swrad%data_3d = domain%tend%th_swrad + endif + domain%potential_temperature%data_3d = domain%potential_temperature%data_3d + domain%tend%th_lwrad*dt + domain%tend%th_swrad*dt + domain%temperature%data_3d = domain%potential_temperature%data_3d * domain%exner%data_3d endif end subroutine rad diff --git a/src/physics/ra_rrtmg_lw.f90 b/src/physics/ra_rrtmg_lw.f90 new file mode 100644 index 00000000..d1e2c4f9 --- /dev/null +++ b/src/physics/ra_rrtmg_lw.f90 @@ -0,0 +1,14488 @@ +!MODULE module_ra_rrtmg_lw + + module parkind +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg kinds +! Define integer and real kinds for various types. +! +! Initial version: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! +! integer kinds +! ------------- +! +! integer, parameter :: kind_ib = selected_int_kind(13) ! 8 byte integer +! integer, parameter :: kind_im = selected_int_kind(6) ! 4 byte integer + integer, parameter :: kind_ib = kind(1) + integer, parameter :: kind_im = kind(1) + integer, parameter :: kind_in = kind(1) ! native integer + +! +! real kinds +! ---------- +! +! integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real +! integer, parameter :: kind_rm = selected_real_kind(6) ! 4 byte real +! integer, parameter :: kind_rn = kind(1.0) ! native real + +#if 0 +! Modified for WRF: +#if (RWORDSIZE == 8) + integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real +#endif +#if (RWORDSIZE == 4) + integer, parameter :: kind_rb = selected_real_kind(6) ! 4 byte real +#endif +#else + integer, parameter :: kind_rb = kind(1.0) ! native real +#endif + + end module parkind + + module parrrtm + + use parkind ,only : im => kind_im + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw main parameters +! +! Initial version: JJMorcrette, ECMWF, Jul 1998 +! Revised: MJIacono, AER, Jun 2006 +! Revised: MJIacono, AER, Aug 2007 +! Revised: MJIacono, AER, Aug 2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! mxlay : integer: maximum number of layers +! mg : integer: number of original g-intervals per spectral band +! nbndlw : integer: number of spectral bands +! maxxsec: integer: maximum number of cross-section molecules +! (e.g. cfcs) +! maxinpx: integer: +! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw +! ngNN : integer: number of reduced g-intervals per spectral band +! ngsNN : integer: cumulative number of g-intervals per band +!------------------------------------------------------------------ + + integer(kind=im), parameter :: mxlay = 203 + integer(kind=im), parameter :: mg = 16 + integer(kind=im), parameter :: nbndlw = 16 + integer(kind=im), parameter :: maxxsec= 4 + integer(kind=im), parameter :: mxmol = 38 + integer(kind=im), parameter :: maxinpx= 38 + integer(kind=im), parameter :: nmol = 7 +! Use for 140 g-point model + integer(kind=im), parameter :: ngptlw = 140 +! Use for 256 g-point model +! integer(kind=im), parameter :: ngptlw = 256 + +! Use for 140 g-point model + integer(kind=im), parameter :: ng1 = 10 + integer(kind=im), parameter :: ng2 = 12 + integer(kind=im), parameter :: ng3 = 16 + integer(kind=im), parameter :: ng4 = 14 + integer(kind=im), parameter :: ng5 = 16 + integer(kind=im), parameter :: ng6 = 8 + integer(kind=im), parameter :: ng7 = 12 + integer(kind=im), parameter :: ng8 = 8 + integer(kind=im), parameter :: ng9 = 12 + integer(kind=im), parameter :: ng10 = 6 + integer(kind=im), parameter :: ng11 = 8 + integer(kind=im), parameter :: ng12 = 8 + integer(kind=im), parameter :: ng13 = 4 + integer(kind=im), parameter :: ng14 = 2 + integer(kind=im), parameter :: ng15 = 2 + integer(kind=im), parameter :: ng16 = 2 + + integer(kind=im), parameter :: ngs1 = 10 + integer(kind=im), parameter :: ngs2 = 22 + integer(kind=im), parameter :: ngs3 = 38 + integer(kind=im), parameter :: ngs4 = 52 + integer(kind=im), parameter :: ngs5 = 68 + integer(kind=im), parameter :: ngs6 = 76 + integer(kind=im), parameter :: ngs7 = 88 + integer(kind=im), parameter :: ngs8 = 96 + integer(kind=im), parameter :: ngs9 = 108 + integer(kind=im), parameter :: ngs10 = 114 + integer(kind=im), parameter :: ngs11 = 122 + integer(kind=im), parameter :: ngs12 = 130 + integer(kind=im), parameter :: ngs13 = 134 + integer(kind=im), parameter :: ngs14 = 136 + integer(kind=im), parameter :: ngs15 = 138 + +! Use for 256 g-point model +! integer(kind=im), parameter :: ng1 = 16 +! integer(kind=im), parameter :: ng2 = 16 +! integer(kind=im), parameter :: ng3 = 16 +! integer(kind=im), parameter :: ng4 = 16 +! integer(kind=im), parameter :: ng5 = 16 +! integer(kind=im), parameter :: ng6 = 16 +! integer(kind=im), parameter :: ng7 = 16 +! integer(kind=im), parameter :: ng8 = 16 +! integer(kind=im), parameter :: ng9 = 16 +! integer(kind=im), parameter :: ng10 = 16 +! integer(kind=im), parameter :: ng11 = 16 +! integer(kind=im), parameter :: ng12 = 16 +! integer(kind=im), parameter :: ng13 = 16 +! integer(kind=im), parameter :: ng14 = 16 +! integer(kind=im), parameter :: ng15 = 16 +! integer(kind=im), parameter :: ng16 = 16 + +! integer(kind=im), parameter :: ngs1 = 16 +! integer(kind=im), parameter :: ngs2 = 32 +! integer(kind=im), parameter :: ngs3 = 48 +! integer(kind=im), parameter :: ngs4 = 64 +! integer(kind=im), parameter :: ngs5 = 80 +! integer(kind=im), parameter :: ngs6 = 96 +! integer(kind=im), parameter :: ngs7 = 112 +! integer(kind=im), parameter :: ngs8 = 128 +! integer(kind=im), parameter :: ngs9 = 144 +! integer(kind=im), parameter :: ngs10 = 160 +! integer(kind=im), parameter :: ngs11 = 176 +! integer(kind=im), parameter :: ngs12 = 192 +! integer(kind=im), parameter :: ngs13 = 208 +! integer(kind=im), parameter :: ngs14 = 224 +! integer(kind=im), parameter :: ngs15 = 240 +! integer(kind=im), parameter :: ngs16 = 256 + + end module parrrtm + + module rrlw_cld + + use parkind, only : rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw cloud property coefficients + +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! abscld1: real : +! absice0: real : +! absice1: real : +! absice2: real : +! absice3: real : +! absliq0: real : +! absliq1: real : +!------------------------------------------------------------------ + + real(kind=rb) :: abscld1 + real(kind=rb) , dimension(2) :: absice0 + real(kind=rb) , dimension(2,5) :: absice1 + real(kind=rb) , dimension(43,16) :: absice2 + real(kind=rb) , dimension(46,16) :: absice3 + real(kind=rb) :: absliq0 + real(kind=rb) , dimension(58,16) :: absliq1 + + end module rrlw_cld + + module rrlw_con + + use parkind, only : rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw constants + +! Initial version: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! fluxfac: real : radiance to flux conversion factor +! heatfac: real : flux to heating rate conversion factor +!oneminus: real : 1.-1.e-6 +! pi : real : pi +! grav : real : acceleration of gravity +! planck : real : planck constant +! boltz : real : boltzmann constant +! clight : real : speed of light +! avogad : real : avogadro constant +! alosmt : real : loschmidt constant +! gascon : real : molar gas constant +! radcn1 : real : first radiation constant +! radcn2 : real : second radiation constant +! sbcnst : real : stefan-boltzmann constant +! secdy : real : seconds per day +!------------------------------------------------------------------ + + real(kind=rb) :: fluxfac, heatfac + real(kind=rb) :: oneminus, pi, grav + real(kind=rb) :: planck, boltz, clight + real(kind=rb) :: avogad, alosmt, gascon + real(kind=rb) :: radcn1, radcn2 + real(kind=rb) :: sbcnst, secdy + + end module rrlw_con + + module rrlw_kg01 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 1 +! band 1: 10-250 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mn2 : real +! kbo_mn2 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no1 = 16 + + !real,allocatable, dimension(:) :: fracrefao(no1) , fracrefbo(no1) + !real :: kao(5,13,no1) + !real :: kbo(5,13:59,no1) + !real :: kao_mn2(19,no1) , kbo_mn2(19,no1) + !real :: selfrefo(10,no1), forrefo(4,no1) + + real,allocatable, dimension(:) :: fracrefao(:) , fracrefbo(:) + real,allocatable, dimension(:,:,:) :: kao(:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: kao_mn2(:,:) , kbo_mn2(:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 1 +! band 1: 10-250 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! absa : real +! absb : real +! ka_mn2 : real +! kb_mn2 : real +! selfref : real +! forref : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng1 = 10 + + real*8 :: fracrefa(ng1) , fracrefb(ng1) + real*8 :: ka(5,13,ng1) , absa(65,ng1) + real*8 :: kb(5,13:59,ng1), absb(235,ng1) + real*8 :: ka_mn2(19,ng1) , kb_mn2(19,ng1) + real*8 :: selfref(10,ng1), forref(4,ng1) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrlw_kg01 + + module rrlw_kg02 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 2 +! band 2: 250-500 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no2 = 16 + + real,allocatable, dimension(:) :: fracrefao , fracrefbo + real,allocatable, dimension(:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:) :: selfrefo, forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 2 +! band 2: 250-500 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! +! refparam: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng2 = 12 + + real*8 :: fracrefa(ng2) , fracrefb(ng2) + real*8 :: ka(5,13,ng2) , absa(65,ng2) + real*8 :: kb(5,13:59,ng2), absb(235,ng2) + real*8 :: selfref(10,ng2), forref(4,ng2) + + real*8 :: refparam(13) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + end module rrlw_kg02 + + module rrlw_kg03 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 3 +! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mn2o: real +! kbo_mn2o: real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no3 = 16 + + real,allocatable, dimension(:,:) :: fracrefao ,fracrefbo + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:,:) :: kbo + real,allocatable, dimension(:,:,:) :: kao_mn2o, kbo_mn2o + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 3 +! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mn2o : real +! kb_mn2o : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng3 = 16 + + real*8 :: fracrefa(ng3,9) ,fracrefb(ng3,5) + real*8 :: ka(9,5,13,ng3) ,absa(585,ng3) + real*8 :: kb(5,5,13:59,ng3),absb(1175,ng3) + real*8 :: ka_mn2o(9,19,ng3), kb_mn2o(5,19,ng3) + real*8 :: selfref(10,ng3) + real*8 :: forref(4,ng3) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1)) + + end module rrlw_kg03 + + module rrlw_kg04 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 4 +! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no4 = 16 + + real,allocatable, dimension(:,:) :: fracrefao ,fracrefbo + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:,:) :: kbo + real,allocatable, dimension(:,:) :: selfrefo ,forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 4 +! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! absa : real +! absb : real +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! selfref : real +! forref : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng4 = 14 + + real*8 :: fracrefa(ng4,9) ,fracrefb(ng4,5) + real*8 :: ka(9,5,13,ng4) ,absa(585,ng4) + real*8 :: kb(5,5,13:59,ng4),absb(1175,ng4) + real*8 :: selfref(10,ng4) ,forref(4,ng4) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1)) + + end module rrlw_kg04 + + module rrlw_kg05 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 5 +! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mo3 : real +! selfrefo: real +! forrefo : real +! ccl4o : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no5 = 16 + + real,allocatable, dimension(:,:) :: fracrefao ,fracrefbo + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:,:) :: kbo + real,allocatable, dimension(:,:,:) :: kao_mo3 + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + real,allocatable, dimension(:) :: ccl4o + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 5 +! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mo3 : real +! selfref : real +! forref : real +! ccl4 : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng5 = 16 + + real*8 :: fracrefa(ng5,9) ,fracrefb(ng5,5) + real*8 :: ka(9,5,13,ng5) ,absa(585,ng5) + real*8 :: kb(5,5,13:59,ng5),absb(1175,ng5) + real*8 :: ka_mo3(9,19,ng5) + real*8 :: selfref(10,ng5) + real*8 :: forref(4,ng5) + real*8 :: ccl4(ng5) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1)) + + end module rrlw_kg05 + + module rrlw_kg06 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 6 +! band 6: 820-980 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kao_mco2: real +! selfrefo: real +! forrefo : real +!cfc11adjo: real +! cfc12o : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no6 = 16 + + real,allocatable, dimension(:) :: fracrefao + real,allocatable, dimension(:,:,:) :: kao + real,allocatable, dimension(:,:) :: kao_mco2 + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + + real,allocatable, dimension(:) :: cfc11adjo + real,allocatable, dimension(:) :: cfc12o + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 6 +! band 6: 820-980 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! ka_mco2 : real +! selfref : real +! forref : real +!cfc11adj : real +! cfc12 : real +! +! absa : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng6 = 8 + + real*8 , dimension(ng6) :: fracrefa + real*8 :: ka(5,13,ng6),absa(65,ng6) + real*8 :: ka_mco2(19,ng6) + real*8 :: selfref(10,ng6) + real*8 :: forref(4,ng6) + + real*8 , dimension(ng6) :: cfc11adj + real*8 , dimension(ng6) :: cfc12 + + equivalence (ka(1,1,1),absa(1,1)) + + end module rrlw_kg06 + + module rrlw_kg07 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 7 +! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mco2: real +! kbo_mco2: real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no7 = 16 + + real,allocatable, dimension(:) :: fracrefbo + real,allocatable, dimension(:,:) :: fracrefao + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:,:) :: kao_mco2 + real,allocatable, dimension(:,:) :: kbo_mco2 + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 7 +! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mco2 : real +! kb_mco2 : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng7 = 12 + + real*8 , dimension(ng7) :: fracrefb + real*8 :: fracrefa(ng7,9) + real*8 :: ka(9,5,13,ng7) ,absa(585,ng7) + real*8 :: kb(5,13:59,ng7),absb(235,ng7) + real*8 :: ka_mco2(9,19,ng7) + real*8 :: kb_mco2(19,ng7) + real*8 :: selfref(10,ng7) + real*8 :: forref(4,ng7) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + end module rrlw_kg07 + + module rrlw_kg08 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 8 +! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mco2: real +! kbo_mco2: real +! kao_mn2o: real +! kbo_mn2o: real +! kao_mo3 : real +! selfrefo: real +! forrefo : real +! cfc12o : real +!cfc22adjo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no8 = 16 + + real,allocatable, dimension(:) :: fracrefao + real,allocatable, dimension(:) :: fracrefbo + real,allocatable, dimension(:) :: cfc12o + real,allocatable, dimension(:) :: cfc22adjo + + real,allocatable, dimension(:,:,:) :: kao + real,allocatable, dimension(:,:) :: kao_mco2 + real,allocatable, dimension(:,:) :: kao_mn2o + real,allocatable, dimension(:,:) :: kao_mo3 + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:) :: kbo_mco2 + real,allocatable, dimension(:,:) :: kbo_mn2o + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 8 +! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mco2 : real +! kb_mco2 : real +! ka_mn2o : real +! kb_mn2o : real +! ka_mo3 : real +! selfref : real +! forref : real +! cfc12 : real +! cfc22adj: real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng8 = 8 + + real*8 , dimension(ng8) :: fracrefa + real*8 , dimension(ng8) :: fracrefb + real*8 , dimension(ng8) :: cfc12 + real*8 , dimension(ng8) :: cfc22adj + + real*8 :: ka(5,13,ng8) ,absa(65,ng8) + real*8 :: kb(5,13:59,ng8) ,absb(235,ng8) + real*8 :: ka_mco2(19,ng8) + real*8 :: ka_mn2o(19,ng8) + real*8 :: ka_mo3(19,ng8) + real*8 :: kb_mco2(19,ng8) + real*8 :: kb_mn2o(19,ng8) + real*8 :: selfref(10,ng8) + real*8 :: forref(4,ng8) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + end module rrlw_kg08 + + module rrlw_kg09 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 9 +! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mn2o: real +! kbo_mn2o: real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no9 = 16 + + real,allocatable, dimension(:) :: fracrefbo + + real,allocatable, dimension(:,:) :: fracrefao + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:,:) :: kao_mn2o + real,allocatable, dimension(:,:) :: kbo_mn2o + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 9 +! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mn2o : real +! kb_mn2o : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng9 = 12 + + real*8 , dimension(ng9) :: fracrefb + real*8 :: fracrefa(ng9,9) + real*8 :: ka(9,5,13,ng9) ,absa(585,ng9) + real*8 :: kb(5,13:59,ng9) ,absb(235,ng9) + real*8 :: ka_mn2o(9,19,ng9) + real*8 :: kb_mn2o(19,ng9) + real*8 :: selfref(10,ng9) + real*8 :: forref(4,ng9) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + end module rrlw_kg09 + + module rrlw_kg10 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 10 +! band 10: 1390-1480 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no10 = 16 + + real,allocatable, dimension(:) :: fracrefao + real,allocatable, dimension(:) :: fracrefbo + + real,allocatable, dimension(:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 10 +! band 10: 1390-1480 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng10 = 6 + + real*8 , dimension(ng10) :: fracrefa + real*8 , dimension(ng10) :: fracrefb + + real*8 :: ka(5,13,ng10) , absa(65,ng10) + real*8 :: kb(5,13:59,ng10), absb(235,ng10) + real*8 :: selfref(10,ng10) + real*8 :: forref(4,ng10) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + end module rrlw_kg10 + + module rrlw_kg11 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 11 +! band 11: 1480-1800 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mo2 : real +! kbo_mo2 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no11 = 16 + + real,allocatable, dimension(:) :: fracrefao + real,allocatable, dimension(:) :: fracrefbo + + real,allocatable, dimension(:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:) :: kao_mo2 + real,allocatable, dimension(:,:) :: kbo_mo2 + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 11 +! band 11: 1480-1800 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mo2 : real +! kb_mo2 : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng11 = 8 + + real*8 , dimension(ng11) :: fracrefa + real*8 , dimension(ng11) :: fracrefb + + real*8 :: ka(5,13,ng11) , absa(65,ng11) + real*8 :: kb(5,13:59,ng11), absb(235,ng11) + real*8 :: ka_mo2(19,ng11) + real*8 :: kb_mo2(19,ng11) + real*8 :: selfref(10,ng11) + real*8 :: forref(4,ng11) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + end module rrlw_kg11 + + module rrlw_kg12 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 12 +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no12 = 16 + + real,allocatable, dimension(:,:) :: fracrefao + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 12 +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng12 = 8 + + real*8 :: fracrefa(ng12,9) + real*8 :: ka(9,5,13,ng12) ,absa(585,ng12) + real*8 :: selfref(10,ng12) + real*8 :: forref(4,ng12) + + equivalence (ka(1,1,1,1),absa(1,1)) + + end module rrlw_kg12 + + module rrlw_kg13 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 13 +! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kao_mco2: real +! kao_mco : real +! kbo_mo3 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no13 = 16 + + real,allocatable, dimension(:) :: fracrefbo + + real,allocatable, dimension(:,:) :: fracrefao + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kao_mco2 + real,allocatable, dimension(:,:,:) :: kao_mco + real,allocatable, dimension(:,:) :: kbo_mo3 + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 13 +! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! ka_mco2 : real +! ka_mco : real +! kb_mo3 : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng13 = 4 + + real*8 , dimension(ng13) :: fracrefb + + real*8 :: fracrefa(ng13,9) + real*8 :: ka(9,5,13,ng13) ,absa(585,ng13) + real*8 :: ka_mco2(9,19,ng13) + real*8 :: ka_mco(9,19,ng13) + real*8 :: kb_mo3(19,ng13) + real*8 :: selfref(10,ng13) + real*8 :: forref(4,ng13) + + equivalence (ka(1,1,1,1),absa(1,1)) + + end module rrlw_kg13 + + module rrlw_kg14 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 14 +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no14 = 16 + + real,allocatable, dimension(:) :: fracrefao + real,allocatable, dimension(:) :: fracrefbo + + real,allocatable, dimension(:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 14 +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng14 = 2 + + real*8 , dimension(ng14) :: fracrefa + real*8 , dimension(ng14) :: fracrefb + + real*8 :: ka(5,13,ng14) ,absa(65,ng14) + real*8 :: kb(5,13:59,ng14),absb(235,ng14) + real*8 :: selfref(10,ng14) + real*8 :: forref(4,ng14) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrlw_kg14 + + module rrlw_kg15 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 15 +! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kao_mn2 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no15 = 16 + + real,allocatable, dimension(:,:) :: fracrefao + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kao_mn2 + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 15 +! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! ka_mn2 : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng15 = 2 + + real*8 :: fracrefa(ng15,9) + real*8 :: ka(9,5,13,ng15) ,absa(585,ng15) + real*8 :: ka_mn2(9,19,ng15) + real*8 :: selfref(10,ng15) + real*8 :: forref(4,ng15) + + equivalence (ka(1,1,1,1),absa(1,1)) + + end module rrlw_kg15 + + module rrlw_kg16 + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 16 +! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no16 = 16 + + real,allocatable, dimension(:) :: fracrefbo + + real,allocatable, dimension(:,:) :: fracrefao + real,allocatable, dimension(:,:,:,:) :: kao + real,allocatable, dimension(:,:,:) :: kbo + real,allocatable, dimension(:,:) :: selfrefo + real,allocatable, dimension(:,:) :: forrefo + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 16 +! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! kb : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: ng16 = 2 + + real*8 , dimension(ng16) :: fracrefb + + real*8 :: fracrefa(ng16,9) + real*8 :: ka(9,5,13,ng16) ,absa(585,ng16) + real*8 :: kb(5,13:59,ng16), absb(235,ng16) + real*8 :: selfref(10,ng16) + real*8 :: forref(4,ng16) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrlw_kg16 + + + module rrlw_ref + + use parkind, only : im => kind_im, rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw reference atmosphere +! Based on standard mid-latitude summer profile +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! pref : real : Reference pressure levels +! preflog: real : Reference pressure levels, ln(pref) +! tref : real : Reference temperature levels for MLS profile +! chi_mls: real : +!------------------------------------------------------------------ + + real(kind=rb) , dimension(59) :: pref + real(kind=rb) , dimension(59) :: preflog + real(kind=rb) , dimension(59) :: tref + real(kind=rb) :: chi_mls(7,59) + + end module rrlw_ref + + module rrlw_tbl + + use parkind, only : im => kind_im, rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw exponential lookup table arrays + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, Jun 2006 +! Revised: MJIacono, AER, Aug 2007 +! Revised: MJIacono, AER, Aug 2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ntbl : integer: Lookup table dimension +! tblint : real : Lookup table conversion factor +! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative +! transfer) +! exp_tbl: real : Transmittance lookup table +! tfn_tbl: real : Tau transition function; i.e. the transition of +! the Planck function from that for the mean layer +! temperature to that for the layer boundary +! temperature as a function of optical depth. +! The "linear in tau" method is used to make +! the table. +! pade : real : Pade constant +! bpade : real : Inverse of Pade constant +!------------------------------------------------------------------ + + integer(kind=im), parameter :: ntbl = 10000 + + real(kind=rb), parameter :: tblint = 10000.0_rb + + real(kind=rb) , dimension(0:ntbl) :: tau_tbl + real(kind=rb) , dimension(0:ntbl) :: exp_tbl + real(kind=rb) , dimension(0:ntbl) :: tfn_tbl + + real(kind=rb), parameter :: pade = 0.278_rb + real(kind=rb) :: bpade + + end module rrlw_tbl + + module rrlw_vsn + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw version information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +!hnamrtm :character: +!hnamini :character: +!hnamcld :character: +!hnamclc :character: +!hnamrtr :character: +!hnamrtx :character: +!hnamrtc :character: +!hnamset :character: +!hnamtau :character: +!hnamatm :character: +!hnamutl :character: +!hnamext :character: +!hnamkg :character: +! +! hvrrtm :character: +! hvrini :character: +! hvrcld :character: +! hvrclc :character: +! hvrrtr :character: +! hvrrtx :character: +! hvrrtc :character: +! hvrset :character: +! hvrtau :character: +! hvratm :character: +! hvrutl :character: +! hvrext :character: +! hvrkg :character: +!------------------------------------------------------------------ + + character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx, & + hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext + character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx, & + hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext + + character*18 hvrkg + character*20 hnamkg + + end module rrlw_vsn + + module rrlw_wvn + + use parkind, only : im => kind_im, rb => kind_rb + use parrrtm, only : nbndlw, mg, ngptlw, maxinpx + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw spectral information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ng : integer: Number of original g-intervals in each spectral band +! nspa : integer: For the lower atmosphere, the number of reference +! atmospheres that are stored for each spectral band +! per pressure level and temperature. Each of these +! atmospheres has different relative amounts of the +! key species for the band (i.e. different binary +! species parameters). +! nspb : integer: Same as nspa for the upper atmosphere +!wavenum1: real : Spectral band lower boundary in wavenumbers +!wavenum2: real : Spectral band upper boundary in wavenumbers +! delwave: real : Spectral band width in wavenumbers +! totplnk: real : Integrated Planck value for each band; (band 16 +! includes total from 2600 cm-1 to infinity) +! Used for calculation across total spectrum +!totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1) +! Used for calculation in band 16 only if +! individual band output requested +! +! ngc : integer: The number of new g-intervals in each band +! ngs : integer: The cumulative sum of new g-intervals for each band +! ngm : integer: The index of each new g-interval relative to the +! original 16 g-intervals in each band +! ngn : integer: The number of original g-intervals that are +! combined to make each new g-intervals in each band +! ngb : integer: The band index for each new g-interval +! wt : real : RRTM weights for the original 16 g-intervals +! rwgt : real : Weights for combining original 16 g-intervals +! (256 total) into reduced set of g-intervals +! (140 total) +! nxmol : integer: Number of cross-section molecules +! ixindx : integer: Flag for active cross-sections in calculation +!------------------------------------------------------------------ + + integer(kind=im) :: ng(nbndlw) + integer(kind=im) :: nspa(nbndlw) + integer(kind=im) :: nspb(nbndlw) + + real(kind=rb) :: wavenum1(nbndlw) + real(kind=rb) :: wavenum2(nbndlw) + real(kind=rb) :: delwave(nbndlw) + + real(kind=rb) :: totplnk(181,nbndlw) + real(kind=rb) :: totplk16(181) + + integer(kind=im) :: ngc(nbndlw) + integer(kind=im) :: ngs(nbndlw) + integer(kind=im) :: ngn(ngptlw) + integer(kind=im) :: ngb(ngptlw) + integer(kind=im) :: ngm(nbndlw*mg) + + real(kind=rb) :: wt(mg) + real(kind=rb) :: rwgt(nbndlw*mg) + + integer(kind=im) :: nxmol + integer(kind=im) :: ixindx(maxinpx) + + end module rrlw_wvn + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + +! Fortran-95 implementation of the Mersenne Twister 19937, following +! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), +! adapted cosmetically by making the names more general. +! Users must declare one or more variables of type randomNumberSequence in the calling +! procedure which are then initialized using a required seed. If the +! variable is not initialized the random numbers will all be 0. +! For example: +! program testRandoms +! use RandomNumbers +! type(randomNumberSequence) :: randomNumbers +! integer :: i +! +! randomNumbers = new_RandomNumberSequence(seed = 100) +! do i = 1, 10 +! print ('(f12.10, 2x)'), getRandomReal(randomNumbers) +! end do +! end program testRandoms +! +! Fortran-95 implementation by +! Robert Pincus +! NOAA-CIRES Climate Diagnostics Center +! Boulder, CO 80305 +! email: Robert.Pincus@colorado.edu +! +! This documentation in the original C program reads: +! ------------------------------------------------------------- +! A C-program for MT19937, with initialization improved 2002/2/10. +! Coded by Takuji Nishimura and Makoto Matsumoto. +! This is a faster version by taking Shawn Cokus's optimization, +! Matthe Bellew's simplification, Isaku Wada's real version. +! +! Before using, initialize the state by using init_genrand(seed) +! or init_by_array(init_key, key_length). +! +! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! +! 3. The names of its contributors may not be used to endorse or promote +! products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! +! Any feedback is very welcome. +! http://www.math.keio.ac.jp/matumoto/emt.html +! email: matumoto@math.keio.ac.jp +! ------------------------------------------------------------- + + module MersenneTwister +! ------------------------------------------------------------- + + use parkind, only : im => kind_im, rb => kind_rb + + implicit none + private + + ! Algorithm parameters + ! ------- + ! Period parameters + integer(kind=im), parameter :: blockSize = 624, & + M = 397, & + MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL) + UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL) + LMASK = 2147483647 ! least significant r bits (0x7fffffffUL) + ! Tempering parameters + integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL) + TMASKC= -272236544 ! (0xefc60000UL) + ! ------- + + ! The type containing the state variable + type randomNumberSequence + integer(kind=im) :: currentElement ! = blockSize + integer(kind=im), dimension(0:blockSize -1) :: state ! = 0 + end type randomNumberSequence + + interface new_RandomNumberSequence + module procedure initialize_scalar, initialize_vector + end interface new_RandomNumberSequence + + public :: randomNumberSequence + public :: new_RandomNumberSequence, finalize_RandomNumberSequence, & + getRandomInt, getRandomPositiveInt, getRandomReal +! ------------------------------------------------------------- +contains + ! ------------------------------------------------------------- + ! Private functions + ! --------------------------- + function mixbits(u, v) + integer(kind=im), intent( in) :: u, v + integer(kind=im) :: mixbits + + mixbits = ior(iand(u, UMASK), iand(v, LMASK)) + end function mixbits + ! --------------------------- + function twist(u, v) + integer(kind=im), intent( in) :: u, v + integer(kind=im) :: twist + + ! Local variable + integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /) + + twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) + twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) + end function twist + ! --------------------------- + subroutine nextState(twister) + type(randomNumberSequence), intent(inout) :: twister + + ! Local variables + integer(kind=im) :: k + + do k = 0, blockSize - M - 1 + twister%state(k) = ieor(twister%state(k + M), & + twist(twister%state(k), twister%state(k + 1_im))) + end do + do k = blockSize - M, blockSize - 2 + twister%state(k) = ieor(twister%state(k + M - blockSize), & + twist(twister%state(k), twister%state(k + 1_im))) + end do + twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), & + twist(twister%state(blockSize - 1_im), twister%state(0_im))) + twister%currentElement = 0_im + + end subroutine nextState + ! --------------------------- + elemental function temper(y) + integer(kind=im), intent(in) :: y + integer(kind=im) :: temper + + integer(kind=im) :: x + + ! Tempering + x = ieor(y, ishft(y, -11)) + x = ieor(x, iand(ishft(x, 7), TMASKB)) + x = ieor(x, iand(ishft(x, 15), TMASKC)) + temper = ieor(x, ishft(x, -18)) + end function temper + ! ------------------------------------------------------------- + ! Public (but hidden) functions + ! -------------------- + function initialize_scalar(seed) result(twister) + integer(kind=im), intent(in ) :: seed + type(randomNumberSequence) :: twister + + integer(kind=im) :: i + ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, + ! MSBs of the seed affect only MSBs of the array state[]. + ! 2002/01/09 modified by Makoto Matsumoto + + twister%state(0) = iand(seed, -1_im) + do i = 1, blockSize - 1 ! ubound(twister%state) + twister%state(i) = 1812433253_im * ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) + i + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + twister%currentElement = blockSize + end function initialize_scalar + ! ------------------------------------------------------------- + function initialize_vector(seed) result(twister) + integer(kind=im), dimension(0:), intent(in) :: seed + type(randomNumberSequence) :: twister + + integer(kind=im) :: i, j, k, nFirstLoop, nWraps + + nWraps = 0 + twister = initialize_scalar(19650218_im) + + nFirstLoop = max(blockSize, size(seed)) + do k = 1, nFirstLoop + i = mod(k + nWraps, blockSize) + j = mod(k - 1, size(seed)) + if(i == 0) then + twister%state(i) = twister%state(blockSize - 1) + twister%state(1) = ieor(twister%state(1), & + ieor(twister%state(1-1), & + ishft(twister%state(1-1), -30_im)) * 1664525_im) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + nWraps = nWraps + 1 + else + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) * 1664525_im) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end if + end do + + ! + ! Walk through the state array, beginning where we left off in the block above + ! + do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1 + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + + twister%state(0) = twister%state(blockSize - 1) + + do i = 1, mod(nFirstLoop, blockSize) + nWraps + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear + twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines + end do + + twister%state(0) = UMASK + twister%currentElement = blockSize + + end function initialize_vector + ! ------------------------------------------------------------- + ! Public functions + ! -------------------- + function getRandomInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer(kind=im) :: getRandomInt + ! Generate a random integer on the interval [0,0xffffffff] + ! Equivalent to genrand_int32 in the C code. + ! Fortran doesn't have a type that's unsigned like C does, + ! so this is integers in the range -2**31 - 2**31 + ! All functions for getting random numbers call this one, + ! then manipulate the result + + if(twister%currentElement >= blockSize) call nextState(twister) + + getRandomInt = temper(twister%state(twister%currentElement)) + twister%currentElement = twister%currentElement + 1 + + end function getRandomInt + ! -------------------- + function getRandomPositiveInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer(kind=im) :: getRandomPositiveInt + ! Generate a random integer on the interval [0,0x7fffffff] + ! or [0,2**31] + ! Equivalent to genrand_int31 in the C code. + + ! Local integers + integer(kind=im) :: localInt + + localInt = getRandomInt(twister) + getRandomPositiveInt = ishft(localInt, -1) + + end function getRandomPositiveInt + ! -------------------- +!! mji - modified Jan 2007, double converted to rrtmg real kind type + function getRandomReal(twister) + type(randomNumberSequence), intent(inout) :: twister +! double precision :: getRandomReal + real(kind=rb) :: getRandomReal + ! Generate a random number on [0,1] + ! Equivalent to genrand_real1 in the C code + ! The result is stored as double precision but has 32 bit resolution + + integer(kind=im) :: localInt + + localInt = getRandomInt(twister) + if(localInt < 0) then +! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb) + else +! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb) + end if + + end function getRandomReal + ! -------------------- + subroutine finalize_RandomNumberSequence(twister) + type(randomNumberSequence), intent(inout) :: twister + + twister%currentElement = blockSize + twister%state(:) = 0_im + end subroutine finalize_RandomNumberSequence + + ! -------------------- + + end module MersenneTwister + + + module mcica_random_numbers + + ! Generic module to wrap random number generators. + ! The module defines a type that identifies the particular stream of random + ! numbers, and has procedures for initializing it and getting real numbers + ! in the range 0 to 1. + ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. + ! + use MersenneTwister, only: randomNumberSequence, & ! The random number engine. + new_RandomNumberSequence, getRandomReal +!! mji +!! use time_manager_mod, only: time_type, get_date + + use parkind, only : im => kind_im, rb => kind_rb + + implicit none + private + + type randomNumberStream + type(randomNumberSequence) :: theNumbers + end type randomNumberStream + + interface getRandomNumbers + module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D + end interface getRandomNumbers + + interface initializeRandomNumberStream + module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V + end interface initializeRandomNumberStream + + public :: randomNumberStream, & + initializeRandomNumberStream, getRandomNumbers +!! mji +!! initializeRandomNumberStream, getRandomNumbers, & +!! constructSeed +contains + ! --------------------------------------------------------- + ! Initialization + ! --------------------------------------------------------- + function initializeRandomNumberStream_S(seed) result(new) + integer(kind=im), intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_S + ! --------------------------------------------------------- + function initializeRandomNumberStream_V(seed) result(new) + integer(kind=im), dimension(:), intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_V + ! --------------------------------------------------------- + ! Procedures for drawing random numbers + ! --------------------------------------------------------- + subroutine getRandomNumber_Scalar(stream, number) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), intent( out) :: number + + number = getRandomReal(stream%theNumbers) + end subroutine getRandomNumber_Scalar + ! --------------------------------------------------------- + subroutine getRandomNumber_1D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), dimension(:), intent( out) :: numbers + + ! Local variables + integer(kind=im) :: i + + do i = 1, size(numbers) + numbers(i) = getRandomReal(stream%theNumbers) + end do + end subroutine getRandomNumber_1D + ! --------------------------------------------------------- + subroutine getRandomNumber_2D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real(kind=rb), dimension(:, :), intent( out) :: numbers + + ! Local variables + integer(kind=im) :: i + + do i = 1, size(numbers, 2) + call getRandomNumber_1D(stream, numbers(:, i)) + end do + end subroutine getRandomNumber_2D +! mji +! ! --------------------------------------------------------- +! ! Constructing a unique seed from grid cell index and model date/time +! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute +! ! --------------------------------------------------------- +! function constructSeed(i, j, time) result(seed) +! integer(kind=im), intent( in) :: i, j +! type(time_type), intent( in) :: time +! integer(kind=im), dimension(8) :: seed +! +! ! Local variables +! integer(kind=im) :: year, month, day, hour, minute, second +! +! +! call get_date(time, year, month, day, hour, minute, second) +! seed = (/ i, j, year, month, day, hour, minute, second /) +! end function constructSeed + + end module mcica_random_numbers + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module mcica_subcol_gen_lw + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! Purpose: Create McICA stochastic arrays for cloud physical or optical properties. +! Two options are possible: +! 1) Input cloud physical properties: cloud fraction, ice and liquid water +! paths, ice fraction, and particle sizes. Output will be stochastic +! arrays of these variables. (inflag = 1) +! 2) Input cloud optical properties directly: cloud optical depth, single +! scattering albedo and asymmetry parameter. Output will be stochastic +! arrays of these variables. (inflag = 0; longwave scattering is not +! yet available, ssac and asmc are for future expansion) + +! --------- Modules ---------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrtm, only : nbndlw, ngptlw + use rrlw_con, only: grav + use rrlw_wvn, only: ngb + use rrlw_vsn + + implicit none + +! public interfaces/functions/subroutines + public :: mcica_subcol_lw, generate_stochastic_clouds + + contains + +!------------------------------------------------------------------ +! Public subroutines +!------------------------------------------------------------------ + + subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, hgt, & + cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, cldfmcl, & + ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl) + +! ----- Input ----- +! Control + integer(kind=im), intent(in) :: iplon ! column/longitude index + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, + ! permute the seed between each call. + ! between calls for LW and SW, recommended + ! permuteseed differes by 'ngpt' + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + +! Atmosphere + real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlay) + + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + +! Atmosphere/clouds - cldprop + real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo + ! Dimensions: (nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter + ! Dimensions: (nbndlw,ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: res(:,:) ! snow particle size + ! Dimensions: (ncol,nlay) + +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + +! ----- Local ----- + +! Stochastic cloud generator variables [mcica] + integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals) + integer(kind=im) :: ilev ! loop index + + real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa) +! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa) +! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity) +! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity) + + +! Return if clear sky; or stop if icld out of range + if (icld.eq.0) return + if (icld.lt.0.or.icld.gt.5) then + stop 'MCICA_SUBCOL: INVALID ICLD' + endif + +! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns + + +! Pass particle sizes to new arrays, no subcolumns for these properties yet +! Convert pressures from mb to Pa + + reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) + relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) + resnmcl(:ncol,:nlay) = res(:ncol,:nlay) + pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb + +! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components + +! cwp = (q * pdel * 1000.) / gravit) +! = (kg/kg * kg m-1 s-2 *1000.) / m s-2 +! = (g m-2) +! +! q = (cwp * gravit) / (pdel *1000.) +! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.) +! = kg/kg + +! do ilev = 1, nlay +! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! enddo + +! Generate the stochastic subcolumns of cloud optical properties for the longwave; + call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, pmid, hgt, cldfrac, clwp, ciwp, cswp, tauc, & + cldfmcl, clwpmcl, ciwpmcl, cswpmcl, taucmcl, permuteseed) + + end subroutine mcica_subcol_lw + + +!------------------------------------------------------------------------------------------------- + subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, hgt, cld, clwp, ciwp, cswp, tauc, & + cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, tauc_stoch, changeSeed) +!------------------------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------------------------------------------- + ! --------------------- + ! Contact: Cecile Hannay (hannay@ucar.edu) + ! + ! Original code: Based on Raisanen et al., QJRMS, 2004. + ! + ! Modifications: + ! 1) Generalized for use with RRTMG and added Mersenne Twister as the default + ! random number generator, which can be changed to the optional kissvec random number generator + ! with flag 'irng'. Some extra functionality has been commented or removed. + ! Michael J. Iacono, AER, Inc., February 2007 + ! 2) Activated exponential and exponential/random cloud overlap method + ! Michael J. Iacono, AER, November 2017 + ! + ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. + ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one + ! and uniform cloud liquid and cloud ice concentration. + ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer + ! and obeys an overlap assumption in the vertical. + ! + ! Overlap assumption: + ! The cloud are consistent with 5 overlap assumptions: random, maximum, maximum-random, exponential and exponential random. + ! The default option is maximum-random (option 2) + ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random + ! This is set with the variable "overlap" + ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) + ! + ! Seed: + ! If the stochastic cloud generator is called several times during the same timestep, + ! one should change the seed between the call to insure that the subcolumns are different. + ! This is done by changing the argument 'changeSeed' + ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , + ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call + ! + ! PDF assumption: + ! We can use arbitrary complicated PDFS. + ! In the present version, we produce homogeneuous clouds (the simplest case). + ! Future developments include using the PDF scheme of Ben Johnson. + ! + ! History file: + ! Option to add diagnostics variables in the history file. (using FINCL in the namelist) + ! nsubcol = number of subcolumns + ! overlap = overlap type (1-3) + ! Zo = length scale + ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) + ! CLDLIQ_S = mean of the subcolumn cloud water + ! CLDICE_S = mean of the subcolumn cloud ice + ! + ! Note: + ! Here: we force that the cloud condensate to be consistent with the cloud fraction + ! i.e we only have cloud condensate when the cell is cloudy. + ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations + ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction + ! without cloud condensate or the opposite). + !--------------------------------------------------------------------------------------------------------------- + + use mcica_random_numbers +! The Mersenne Twister random number engine + use MersenneTwister, only: randomNumberSequence, & + new_RandomNumberSequence, getRandomReal + + type(randomNumberSequence) :: randomNumbers + +! -- Arguments + + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) + integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed + +! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state + real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (nbndlw,ncol,nlay) +! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion +! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion + + real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow path + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion +! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion + +! -- Local variables + real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction + +! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive +! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction +! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water +! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice +! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth +! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo +! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter + +! Set overlap + integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, + ! 3 = maximum overlap, 4 = exponential, + ! 5 = exponential-random + real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) + real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter + +! Constants (min value for cloud fraction and cloud water and ice) + real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction +! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) + +! Variables related to random number and seed + real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers + integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec) + real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) + integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister) + real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) + +! Flag to identify cloud fraction in subcolumns + logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy + +! Indices + integer(kind=im) :: ilev, isubcol, i, n ! indices + +!------------------------------------------------------------------------------------------ + +! Check that irng is in bounds; if not, set to default + if (irng .ne. 0) irng = 1 + +! Pass input cloud overlap setting to local variable + overlap = icld + +! Ensure that cloud fractions are in bounds + do ilev = 1, nlay + do i = 1, ncol + cldf(i,ilev) = cld(i,ilev) + if (cldf(i,ilev) < cldmin) then + cldf(i,ilev) = 0._rb + endif + enddo + enddo + +! ----- Create seed -------- + +! Advance randum number generator by changeseed values + if (irng.eq.0) then +! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. +! Must use pmid from bottom four layers. + do i=1,ncol + if (pmid(i,1).lt.pmid(i,2)) then + stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.' + endif + seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im + seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im + seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im + seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im + enddo + do i=1,changeSeed + call kissvec(seed1, seed2, seed3, seed4, rand_num) + enddo + elseif (irng.eq.1) then + randomNumbers = new_RandomNumberSequence(seed = changeSeed) + endif + + +! ------ Apply overlap assumption -------- + +! generate the random numbers + + select case (overlap) + + case(1) +! Random overlap +! i) pick a random value at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + case(2) +! Maximum-Random overlap +! i) pick a random number for top layer. +! ii) walk down the column: +! - if the layer above is cloudy, we use the same random number than in the layer above +! - if the layer above is clear, we use a new random number + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) + else + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) + endif + enddo + enddo + enddo + + case(3) +! Maximum overlap +! i) pick the same random numebr at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + call kissvec(seed1, seed2, seed3, seed4, rand_num) + do ilev = 1,nlay + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + rand_num_mt = getRandomReal(randomNumbers) + do ilev = 1, nlay + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + case(4) + ! Exponential overlap: weighting between maximum and random overlap increases with the distance. + ! The random numbers for exponential overlap verify: + ! j=1 RAN(j)=RND1 + ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) + ! RAN(j) = RND2 + ! alpha is obtained from the equation + ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale + + ! compute alpha + do i = 1, ncol + alpha(i, 1) = 0._rb + do ilev = 2,nlay + alpha(i, ilev) = exp( -( hgt (i, ilev) - hgt (i, ilev-1)) / Zo) + enddo + enddo + + ! generate 2 streams of random numbers + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol, :, ilev) = rand_num + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF2(isubcol, :, ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + rand_num_mt = getRandomReal(randomNumbers) + CDF2(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + ! generate random numbers + do ilev = 2,nlay + where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) ) + CDF(:,:,ilev) = CDF(:,:,ilev-1) + end where + end do + + case(5) + ! Exponential-random overlap: +! call wrf_error_fatal("Cloud Overlap case 5: ER has not yet been implemented. Stopping...") + error stop "Cloud Overlap case 5: ER has not yet been implemented. Stopping..." + end select + + +! -- generate subcolumns for homogeneous clouds ----- + do ilev = 1,nlay + iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) + enddo + +! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; +! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; +! where there is a cloud, define the subcolumn cloud properties, +! otherwise set these to zero + + do ilev = 1,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (iscloudy(isubcol,i,ilev) ) then + cld_stoch(isubcol,i,ilev) = 1._rb + clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) + ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) + cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) + n = ngb(isubcol) + tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) +! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) +! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) + else + cld_stoch(isubcol,i,ilev) = 0._rb + clwp_stoch(isubcol,i,ilev) = 0._rb + ciwp_stoch(isubcol,i,ilev) = 0._rb + cswp_stoch(isubcol,i,ilev) = 0._rb + tauc_stoch(isubcol,i,ilev) = 0._rb +! ssac_stoch(isubcol,i,ilev) = 1._rb +! asmc_stoch(isubcol,i,ilev) = 1._rb + endif + enddo + enddo + enddo + +! -- compute the means of the subcolumns --- +! mean_cld_stoch(:,:) = 0._rb +! mean_clwp_stoch(:,:) = 0._rb +! mean_ciwp_stoch(:,:) = 0._rb +! mean_tauc_stoch(:,:) = 0._rb +! mean_ssac_stoch(:,:) = 0._rb +! mean_asmc_stoch(:,:) = 0._rb +! do i = 1, nsubcol +! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) +! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) +! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) +! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) +! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) +! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) +! end do +! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol +! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol +! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol +! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol +! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol +! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol + + end subroutine generate_stochastic_clouds + + +!------------------------------------------------------------------ +! Private subroutines +!------------------------------------------------------------------ + +!-------------------------------------------------------------------------------------------------- + subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!-------------------------------------------------------------------------------------------------- + +! public domain code +! made available from http://www.fortran.com/ +! downloaded by pjr on 03/16/04 for NCAR CAM +! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 + +! The KISS (Keep It Simple Stupid) random number generator. Combines: +! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. +! (2) A 3-shift shift-register generator, period 2^32-1, +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; +! + real(kind=rb), dimension(:), intent(inout) :: ran_arr + integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4 + integer(kind=im) :: i,sz,kiss + integer(kind=im) :: m, k, n + +! inline function + m(k, n) = ieor (k, ishft (k, n) ) + + sz = size(ran_arr) + do i = 1, sz + seed1(i) = 69069_im * seed1(i) + 1327217885_im + seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) + seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im) + seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) + ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb + end do + + end subroutine kissvec + + end module mcica_subcol_gen_lw + +! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_cldprmc.f90,v $ +! author: $Author: mike $ +! revision: $Revision: 1.8 $ +! created: $Date: 2009/05/22 21:04:30 $ +! + module rrtmg_lw_cldprmc + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! --------- Modules ---------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrtm, only : ngptlw, nbndlw + use rrlw_cld, only: abscld1, absliq0, absliq1, & + absice0, absice1, absice2, absice3 + use rrlw_wvn, only: ngb + use rrlw_vsn, only: hvrclc, hnamclc + + implicit none + + contains + +! ------------------------------------------------------------------------------ + subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & + ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc) +! ------------------------------------------------------------------------------ + +! Purpose: Compute the cloud optical depth(s) for each cloudy layer. + +! ------- Input ------- + + integer(kind=im), intent(in) :: nlayers ! total number of layers + integer(kind=im), intent(in) :: inflag ! see definitions + integer(kind=im), intent(in) :: iceflag ! see definitions + integer(kind=im), intent(in) :: liqflag ! see definitions + + real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: cswpmc(:,:) ! cloud snow path [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: relqmc(:) ! liquid particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: reicmc(:) ! ice particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: resnmc(:) ! snow particle effective radius (microns) + ! Dimensions: (nlayers) + ! specific definition of reicmc depends on setting of iceflag: + ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + +! ------- Output ------- + + integer(kind=im), intent(out) :: ncbands ! number of cloud spectral bands + real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlayers) + +! ------- Local ------- + + integer(kind=im) :: lay ! Layer index + integer(kind=im) :: ib ! spectral band index + integer(kind=im) :: ig ! g-point interval index + integer(kind=im) :: index + integer(kind=im) :: icb(nbndlw) + + real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients + real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients + real(kind=rb) :: abscosno(ngptlw) ! snow absorption coefficients + real(kind=rb) :: cwp ! cloud water path + real(kind=rb) :: radice ! cloud ice effective size (microns) + real(kind=rb) :: factor ! + real(kind=rb) :: fint ! + real(kind=rb) :: radliq ! cloud liquid droplet radius (microns) + real(kind=rb) :: radsno ! cloud snow effective size (microns) + real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon + real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities + character*80 errmess + +! ------- Definitions ------- + +! Explanation of the method for each value of INFLAG. Values of +! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. +! INFLAG = 2 does distinguish between liquid and ice clouds, and +! requires further user input to specify the method to be used to +! compute the aborption due to each. +! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) +! optical depth are input. +! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud +! water path (g/m2) are input. The (gray) cloud optical +! depth is computed as in CCM2. +! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud +! water path (g/m2), and cloud ice fraction are input. +! ICEFLAG = 0: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in CCM3. +! ICEFLAG = 1: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in +! Ebert and Curry, JGR, 97, 3831-3836 (1992). The +! spectral regions in this work have been matched with +! the spectral bands in RRTM to as great an extent +! as possible: +! E&C 1 IB = 5 RRTM bands 9-16 +! E&C 2 IB = 4 RRTM bands 6-8 +! E&C 3 IB = 3 RRTM bands 3-5 +! E&C 4 IB = 2 RRTM band 2 +! E&C 5 IB = 1 RRTM band 1 +! ICEFLAG = 2: The ice effective radius (microns) is input and the +! optical properties due to ice clouds are computed from +! the optical properties stored in the RT code, +! STREAMER v3.0 (Reference: Key. J., Streamer +! User's Guide, Cooperative Institute for +! Meteorological Satellite Studies, 2001, 96 pp.). +! Valid range of values for re are between 5.0 and +! 131.0 micron. +! ICEFLAG = 3: The ice generalized effective size (dge) is input +! and the optical properties, are calculated as in +! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution +! tables which were appropriately averaged for the +! bands in RRTM_LW. Linear interpolation is used to +! get the coefficients from the stored tables. +! Valid range of values for dge are between 5.0 and +! 140.0 micron. +! LIQFLAG = 0: The optical depths due to water clouds are computed as +! in CCM3. +! LIQFLAG = 1: The water droplet effective radius (microns) is input +! and the optical depths due to water clouds are computed +! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). +! The values for absorption coefficients appropriate for +! the spectral bands in RRTM have been obtained for a +! range of effective radii by an averaging procedure +! based on the work of J. Pinto (private communication). +! Linear interpolation is used to get the absorption +! coefficients for the input effective radius. + + data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/ + +!jm not thread safe hvrclc = '$Revision: 1.8 $' + + ncbands = 1 + +! This initialization is done in rrtmg_lw_subcol.F90. +! do lay = 1, nlayers +! do ig = 1, ngptlw +! taucmc(ig,lay) = 0.0_rb +! enddo +! enddo + +! Main layer loop + do lay = 1, nlayers + + do ig = 1, ngptlw + cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay) + if (cldfmc(ig,lay) .ge. cldmin .and. & + (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then + +! Ice clouds and water clouds combined. + if (inflag .eq. 0) then +! Cloud optical depth already defined in taucmc, return to main program + return + + elseif(inflag .eq. 1) then + stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' +! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) +! taucmc(ig,lay) = abscld1 * cwp + +! Separate treatement of ice clouds and water clouds. + elseif(inflag .ge. 2) then + radice = reicmc(lay) + +! Calculation of absorption coefficients due to ice clouds. + if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then + abscoice(ig) = 0.0_rb + abscosno(ig) = 0.0_rb + + elseif (iceflag .eq. 0) then + if (radice .lt. 10.0_rb) stop 'ICE RADIUS TOO SMALL' + abscoice(ig) = absice0(1) + absice0(2)/radice + abscosno(ig) = 0.0_rb + + elseif (iceflag .eq. 1) then + if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop & + 'ICE RADIUS OUT OF BOUNDS' + ncbands = 5 + ib = icb(ngb(ig)) + abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice + abscosno(ig) = 0.0_rb + +! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns + + elseif (iceflag .eq. 2) then + if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS' + ncbands = 16 + factor = (radice - 2._rb)/3._rb + index = int(factor) + if (index .eq. 43) index = 42 + fint = factor - float(index) + ib = ngb(ig) + abscoice(ig) = & + absice2(index,ib) + fint * & + (absice2(index+1,ib) - (absice2(index,ib))) + abscosno(ig) = 0.0_rb + +! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns + + elseif (iceflag .ge. 3) then + if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then + write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & + 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + ,ig, lay, ciwpmc(ig,lay), radice +! call wrf_error_fatal(errmess) + error stop errmess + end if + ncbands = 16 + factor = (radice - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + abscoice(ig) = & + absice3(index,ib) + fint * & + (absice3(index+1,ib) - (absice3(index,ib))) + abscosno(ig) = 0.0_rb + + endif + +!..Incorporate additional effects due to snow. + if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then + radsno = resnmc(lay) + if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then + write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & + 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + ,ig, lay, cswpmc(ig,lay), radsno +! call wrf_error_fatal(errmess) + error stop errmess + end if + ncbands = 16 + factor = (radsno - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + abscosno(ig) = & + absice3(index,ib) + fint * & + (absice3(index+1,ib) - (absice3(index,ib))) + endif + + +! Calculation of absorption coefficients due to water clouds. + if (clwpmc(ig,lay) .eq. 0.0_rb) then + abscoliq(ig) = 0.0_rb + + elseif (liqflag .eq. 0) then + abscoliq(ig) = absliq0 + + elseif (liqflag .eq. 1) then + radliq = relqmc(lay) + if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) stop & + 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS' + index = int(radliq - 1.5_rb) + if (index .eq. 0) index = 1 + if (index .eq. 58) index = 57 + fint = radliq - 1.5_rb - float(index) + ib = ngb(ig) + abscoliq(ig) = & + absliq1(index,ib) + fint * & + (absliq1(index+1,ib) - (absliq1(index,ib))) + endif + + taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + & + clwpmc(ig,lay) * abscoliq(ig) + & + cswpmc(ig,lay) * abscosno(ig) + + endif + endif + enddo + enddo + + end subroutine cldprmc + + end module rrtmg_lw_cldprmc + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module rrtmg_lw_rtrnmc + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! --------- Modules ---------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrtm, only : mg, nbndlw, ngptlw + use rrlw_con, only: fluxfac, heatfac + use rrlw_wvn, only: delwave, ngb, ngs + use rrlw_tbl, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl + use rrlw_vsn, only: hvrrtc, hnamrtc + + implicit none + + real(kind=rb) :: wtdiff, rec_6 + real(kind=rb) :: a0(nbndlw),a1(nbndlw),a2(nbndlw)! diffusivity angle adjustment coefficients + +! This secant and weight corresponds to the standard diffusivity +! angle. This initial value is redefined below for some bands. + data wtdiff /0.5_rb/ + data rec_6 /0.166667_rb/ + +! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 +! and 1.80) as a function of total column water vapor. The function +! has been defined to minimize flux and cooling rate errors in these bands +! over a wide range of precipitable water values. + data a0 / 1.66_rb, 1.55_rb, 1.58_rb, 1.66_rb, & + 1.54_rb, 1.454_rb, 1.89_rb, 1.33_rb, & + 1.668_rb, 1.66_rb, 1.66_rb, 1.66_rb, & + 1.66_rb, 1.66_rb, 1.66_rb, 1.66_rb / + data a1 / 0.00_rb, 0.25_rb, 0.22_rb, 0.00_rb, & + 0.13_rb, 0.446_rb, -0.10_rb, 0.40_rb, & + -0.006_rb, 0.00_rb, 0.00_rb, 0.00_rb, & + 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb / + data a2 / 0.00_rb, -12.0_rb, -11.7_rb, 0.00_rb, & + -0.72_rb,-0.243_rb, 0.19_rb,-0.062_rb, & + 0.414_rb, 0.00_rb, 0.00_rb, 0.00_rb, & + 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb / + + contains + +!----------------------------------------------------------------------------- + subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, & + cldfmc, taucmc, planklay, planklev, plankbnd, & + pwvcm, fracs, taut, & + totuflux, totdflux, fnet, htr, & + totuclfl, totdclfl, fnetc, htrc ) +!----------------------------------------------------------------------------- +! +! Original version: E. J. Mlawer, et al. RRTM_V3.0 +! Revision for GCMs: Michael J. Iacono; October, 2002 +! Revision for F90: Michael J. Iacono; June, 2006 +! +! This program calculates the upward fluxes, downward fluxes, and +! heating rates for an arbitrary clear or cloudy atmosphere. The input +! to this program is the atmospheric profile, all Planck function +! information, and the cloud fraction by layer. A variable diffusivity +! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 +! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of +! the column water vapor, and other bands use a value of 1.66. The Gaussian +! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that +! use of the emissivity angle for the flux integration can cause errors of +! 1 to 4 W/m2 within cloudy layers. +! Clouds are treated with the McICA stochastic approach and maximum-random +! cloud overlap. +!*************************************************************************** + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: nlayers ! total number of layers + integer(kind=im), intent(in) :: istart ! beginning band of calculation + integer(kind=im), intent(in) :: iend ! ending band of calculation + integer(kind=im), intent(in) :: iout ! output option flag + +! Atmosphere + real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm) + real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity + ! Dimensions: (nbndlw) + real(kind=rb), intent(in) :: planklay(:,:) ! + ! Dimensions: (nlayers,nbndlw) + real(kind=rb), intent(in) :: planklev(0:,:) ! + ! Dimensions: (0:nlayers,nbndlw) + real(kind=rb), intent(in) :: plankbnd(:) ! + ! Dimensions: (nbndlw) + real(kind=rb), intent(in) :: fracs(:,:) ! + ! Dimensions: (nlayers,ngptw) + real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths + ! Dimensions: (nlayers,ngptlw) + +! Clouds + integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands + real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica] + ! Dimensions: (ngptlw,nlayers) + real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlayers) + +! ----- Output ----- + real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day) + ! Dimensions: (0:nlayers) + +! ----- Local ----- +! Declarations for radiative transfer + real(kind=rb) :: abscld(nlayers,ngptlw) + real(kind=rb) :: atot(nlayers) + real(kind=rb) :: atrans(nlayers) + real(kind=rb) :: bbugas(nlayers) + real(kind=rb) :: bbutot(nlayers) + real(kind=rb) :: clrurad(0:nlayers) + real(kind=rb) :: clrdrad(0:nlayers) + real(kind=rb) :: efclfrac(nlayers,ngptlw) + real(kind=rb) :: uflux(0:nlayers) + real(kind=rb) :: dflux(0:nlayers) + real(kind=rb) :: urad(0:nlayers) + real(kind=rb) :: drad(0:nlayers) + real(kind=rb) :: uclfl(0:nlayers) + real(kind=rb) :: dclfl(0:nlayers) + real(kind=rb) :: odcld(nlayers,ngptlw) + + + real(kind=rb) :: secdiff(nbndlw) ! secant of diffusivity angle + real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn + real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc + real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac + real(kind=rb) :: rad0, reflect, radlu, radclru + + integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer + integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices + integer(kind=im) :: igc ! g-point interval counter + integer(kind=im) :: iclddn ! flag for cloud in down path + integer(kind=im) :: ittot, itgas, itr ! lookup table indices + +! ------- Definitions ------- +! input +! nlayers ! number of model layers +! ngptlw ! total number of g-point subintervals +! nbndlw ! number of longwave spectral bands +! ncbands ! number of spectral bands for clouds +! secdiff ! diffusivity angle +! wtdiff ! weight for radiance to flux conversion +! pavel ! layer pressures (mb) +! pz ! level (interface) pressures (mb) +! tavel ! layer temperatures (k) +! tz ! level (interface) temperatures(mb) +! tbound ! surface temperature (k) +! cldfrac ! layer cloud fraction +! taucloud ! layer cloud optical depth +! itr ! integer look-up table index +! icldlyr ! flag for cloudy layers +! iclddn ! flag for cloud in column at any layer +! semiss ! surface emissivities for each band +! reflect ! surface reflectance +! bpade ! 1/(pade constant) +! tau_tbl ! clear sky optical depth look-up table +! exp_tbl ! exponential look-up table for transmittance +! tfn_tbl ! tau transition function look-up table + +! local +! atrans ! gaseous absorptivity +! abscld ! cloud absorptivity +! atot ! combined gaseous and cloud absorptivity +! odclr ! clear sky (gaseous) optical depth +! odcld ! cloud optical depth +! odtot ! optical depth of gas and cloud +! tfacgas ! gas-only pade factor, used for planck fn +! tfactot ! gas and cloud pade factor, used for planck fn +! bbdgas ! gas-only planck function for downward rt +! bbugas ! gas-only planck function for upward rt +! bbdtot ! gas and cloud planck function for downward rt +! bbutot ! gas and cloud planck function for upward calc. +! gassrc ! source radiance due to gas only +! efclfrac ! effective cloud fraction +! radlu ! spectrally summed upward radiance +! radclru ! spectrally summed clear sky upward radiance +! urad ! upward radiance by layer +! clrurad ! clear sky upward radiance by layer +! radld ! spectrally summed downward radiance +! radclrd ! spectrally summed clear sky downward radiance +! drad ! downward radiance by layer +! clrdrad ! clear sky downward radiance by layer + +! output +! totuflux ! upward longwave flux (w/m2) +! totdflux ! downward longwave flux (w/m2) +! fnet ! net longwave flux (w/m2) +! htr ! longwave heating rate (k/day) +! totuclfl ! clear sky upward longwave flux (w/m2) +! totdclfl ! clear sky downward longwave flux (w/m2) +! fnetc ! clear sky net longwave flux (w/m2) +! htrc ! clear sky longwave heating rate (k/day) + + +!jm not thread safe hvrrtc = '$Revision: 1.3 $' + + do ibnd = 1,nbndlw + if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then + secdiff(ibnd) = 1.66_rb + else + secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm) + if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb + if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb + endif + enddo + + urad(0) = 0.0_rb + drad(0) = 0.0_rb + totuflux(0) = 0.0_rb + totdflux(0) = 0.0_rb + clrurad(0) = 0.0_rb + clrdrad(0) = 0.0_rb + totuclfl(0) = 0.0_rb + totdclfl(0) = 0.0_rb + + do lay = 1, nlayers + urad(lay) = 0.0_rb + drad(lay) = 0.0_rb + totuflux(lay) = 0.0_rb + totdflux(lay) = 0.0_rb + clrurad(lay) = 0.0_rb + clrdrad(lay) = 0.0_rb + totuclfl(lay) = 0.0_rb + totdclfl(lay) = 0.0_rb + icldlyr(lay) = 0 + +! Change to band loop? + do ig = 1, ngptlw + if (cldfmc(ig,lay) .eq. 1._rb) then + ib = ngb(ig) + odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay) + transcld = exp(-odcld(lay,ig)) + abscld(lay,ig) = 1._rb - transcld + efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay) + icldlyr(lay) = 1 + else + odcld(lay,ig) = 0.0_rb + abscld(lay,ig) = 0.0_rb + efclfrac(lay,ig) = 0.0_rb + endif + enddo + + enddo + + igc = 1 +! Loop over frequency bands. + do iband = istart, iend + +! Reinitialize g-point counter for each band if output for each band is requested. + if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 + +! Loop over g-channels. + 1000 continue + +! Radiative transfer starts here. + radld = 0._rb + radclrd = 0._rb + iclddn = 0 + +! Downward radiative transfer loop. + + do lev = nlayers, 1, -1 + plfrac = fracs(lev,igc) + blay = planklay(lev,iband) + dplankup = planklev(lev,iband) - blay + dplankdn = planklev(lev-1,iband) - blay + odepth = secdiff(iband) * taut(lev,igc) + if (odepth .lt. 0.0_rb) odepth = 0.0_rb +! Cloudy layer + if (icldlyr(lev).eq.1) then + iclddn = 1 + odtot = odepth + odcld(lev,igc) + if (odtot .lt. 0.06_rb) then + atrans(lev) = odepth - 0.5_rb*odepth*odepth + odepth_rec = rec_6*odepth + gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) + + atot(lev) = odtot - 0.5_rb*odtot*odtot + odtot_rec = rec_6*odtot + bbdtot = plfrac * (blay+dplankdn*odtot_rec) + bbd = plfrac*(blay+dplankdn*odepth_rec) + radld = radld - radld * (atrans(lev) + & + efclfrac(lev,igc) * (1. - atrans(lev))) + & + gassrc + cldfmc(igc,lev) * & + (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + + bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) + bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) + + elseif (odepth .le. 0.06_rb) then + atrans(lev) = odepth - 0.5_rb*odepth*odepth + odepth_rec = rec_6*odepth + gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) + + odtot = odepth + odcld(lev,igc) + tblind = odtot/(bpade+odtot) + ittot = tblint*tblind + 0.5_rb + tfactot = tfn_tbl(ittot) + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+dplankdn*odepth_rec) + atot(lev) = 1. - exp_tbl(ittot) + + radld = radld - radld * (atrans(lev) + & + efclfrac(lev,igc) * (1._rb - atrans(lev))) + & + gassrc + cldfmc(igc,lev) * & + (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + + bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) + bbutot(lev) = plfrac * (blay + tfactot * dplankup) + + else + + tblind = odepth/(bpade+odepth) + itgas = tblint*tblind+0.5_rb + odepth = tau_tbl(itgas) + atrans(lev) = 1._rb - exp_tbl(itgas) + tfacgas = tfn_tbl(itgas) + gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) + + odtot = odepth + odcld(lev,igc) + tblind = odtot/(bpade+odtot) + ittot = tblint*tblind + 0.5_rb + tfactot = tfn_tbl(ittot) + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+tfacgas*dplankdn) + atot(lev) = 1._rb - exp_tbl(ittot) + + radld = radld - radld * (atrans(lev) + & + efclfrac(lev,igc) * (1._rb - atrans(lev))) + & + gassrc + cldfmc(igc,lev) * & + (bbdtot * atot(lev) - gassrc) + drad(lev-1) = drad(lev-1) + radld + bbugas(lev) = plfrac * (blay + tfacgas * dplankup) + bbutot(lev) = plfrac * (blay + tfactot * dplankup) + endif +! Clear layer + else + if (odepth .le. 0.06_rb) then + atrans(lev) = odepth-0.5_rb*odepth*odepth + odepth = rec_6*odepth + bbd = plfrac*(blay+dplankdn*odepth) + bbugas(lev) = plfrac*(blay+dplankup*odepth) + else + tblind = odepth/(bpade+odepth) + itr = tblint*tblind+0.5_rb + transc = exp_tbl(itr) + atrans(lev) = 1._rb-transc + tausfac = tfn_tbl(itr) + bbd = plfrac*(blay+tausfac*dplankdn) + bbugas(lev) = plfrac * (blay + tausfac * dplankup) + endif + radld = radld + (bbd-radld)*atrans(lev) + drad(lev-1) = drad(lev-1) + radld + endif +! Set clear sky stream to total sky stream as long as layers +! remain clear. Streams diverge when a cloud is reached (iclddn=1), +! and clear sky stream must be computed separately from that point. + if (iclddn.eq.1) then + radclrd = radclrd + (bbd-radclrd) * atrans(lev) + clrdrad(lev-1) = clrdrad(lev-1) + radclrd + else + radclrd = radld + clrdrad(lev-1) = drad(lev-1) + endif + enddo + +! Spectral emissivity & reflectance +! Include the contribution of spectrally varying longwave emissivity +! and reflection from the surface to the upward radiative transfer. +! Note: Spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + + rad0 = fracs(1,igc) * plankbnd(iband) +! Add in specular reflection of surface downward radiance. + reflect = 1._rb - semiss(iband) + radlu = rad0 + reflect * radld + radclru = rad0 + reflect * radclrd + + +! Upward radiative transfer loop. + urad(0) = urad(0) + radlu + clrurad(0) = clrurad(0) + radclru + + do lev = 1, nlayers +! Cloudy layer + if (icldlyr(lev) .eq. 1) then + gassrc = bbugas(lev) * atrans(lev) + radlu = radlu - radlu * (atrans(lev) + & + efclfrac(lev,igc) * (1._rb - atrans(lev))) + & + gassrc + cldfmc(igc,lev) * & + (bbutot(lev) * atot(lev) - gassrc) + urad(lev) = urad(lev) + radlu +! Clear layer + else + radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) + urad(lev) = urad(lev) + radlu + endif +! Set clear sky stream to total sky stream as long as all layers +! are clear (iclddn=0). Streams must be calculated separately at +! all layers when a cloud is present (ICLDDN=1), because surface +! reflectance is different for each stream. + if (iclddn.eq.1) then + radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) + clrurad(lev) = clrurad(lev) + radclru + else + radclru = radlu + clrurad(lev) = urad(lev) + endif + enddo + +! Increment g-point counter + igc = igc + 1 +! Return to continue radiative transfer for all g-channels in present band + if (igc .le. ngs(iband)) go to 1000 + +! Process longwave output from band for total and clear streams. +! Calculate upward, downward, and net flux. + do lev = nlayers, 0, -1 + uflux(lev) = urad(lev)*wtdiff + dflux(lev) = drad(lev)*wtdiff + urad(lev) = 0.0_rb + drad(lev) = 0.0_rb + totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband) + totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband) + uclfl(lev) = clrurad(lev)*wtdiff + dclfl(lev) = clrdrad(lev)*wtdiff + clrurad(lev) = 0.0_rb + clrdrad(lev) = 0.0_rb + totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband) + totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband) + enddo + +! End spectral band loop + enddo + +! Calculate fluxes at surface + totuflux(0) = totuflux(0) * fluxfac + totdflux(0) = totdflux(0) * fluxfac + fnet(0) = totuflux(0) - totdflux(0) + totuclfl(0) = totuclfl(0) * fluxfac + totdclfl(0) = totdclfl(0) * fluxfac + fnetc(0) = totuclfl(0) - totdclfl(0) + +! Calculate fluxes at model levels + do lev = 1, nlayers + totuflux(lev) = totuflux(lev) * fluxfac + totdflux(lev) = totdflux(lev) * fluxfac + fnet(lev) = totuflux(lev) - totdflux(lev) + totuclfl(lev) = totuclfl(lev) * fluxfac + totdclfl(lev) = totdclfl(lev) * fluxfac + fnetc(lev) = totuclfl(lev) - totdclfl(lev) + l = lev - 1 + +! Calculate heating rates at model layers + htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) + htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) + enddo + +! Set heating rate to zero in top layer + htr(nlayers) = 0.0_rb + htrc(nlayers) = 0.0_rb + + end subroutine rtrnmc + + end module rrtmg_lw_rtrnmc + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module rrtmg_lw_setcoef + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrtm, only : nbndlw, mg, maxxsec, mxmol + use rrlw_wvn, only: totplnk, totplk16 + use rrlw_ref + use rrlw_vsn, only: hvrset, hnamset + + implicit none + + contains + +!---------------------------------------------------------------------------- + subroutine setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, & + coldry, wkl, wbroad, & + laytrop, jp, jt, jt1, planklay, planklev, plankbnd, & + colh2o, colco2, colo3, coln2o, colco, colch4, colo2, & + colbrd, fac00, fac01, fac10, fac11, & + rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & + rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, & + rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + minorfrac, scaleminor, scaleminorn2, indminor) +!---------------------------------------------------------------------------- +! +! Purpose: For a given atmosphere, calculate the indices and +! fractions related to the pressure and temperature interpolations. +! Also calculate the values of the integrated Planck functions +! for each band at the level and layer temperatures. + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: nlayers ! total number of layers + integer(kind=im), intent(in) :: istart ! beginning band of calculation + + real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: tavel(:) ! layer temperatures (K) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: tz(0:) ! level (interface) temperatures (K) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: tbound ! surface temperature (K) + real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: wbroad(:) ! broadening gas column density (mol/cm2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2) + ! Dimensions: (mxmol,nlayers) + real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity + ! Dimensions: (nbndlw) + +! ----- Output ----- + integer(kind=im), intent(out) :: laytrop ! tropopause layer index + integer(kind=im), intent(out) :: jp(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(out) :: jt(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(out) :: jt1(:) ! + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: planklay(:,:) ! + ! Dimensions: (nlayers,nbndlw) + real(kind=rb), intent(out) :: planklev(0:,:) ! + ! Dimensions: (0:nlayers,nbndlw) + real(kind=rb), intent(out) :: plankbnd(:) ! + ! Dimensions: (nbndlw) + + real(kind=rb), intent(out) :: colh2o(:) ! column amount (h2o) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colco2(:) ! column amount (co2) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colo3(:) ! column amount (o3) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: coln2o(:) ! column amount (n2o) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colco(:) ! column amount (co) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colch4(:) ! column amount (ch4) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colo2(:) ! column amount (o2) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colbrd(:) ! column amount (broadening gases) + ! Dimensions: (nlayers) + + integer(kind=im), intent(out) :: indself(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(out) :: indfor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: selffac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: selffrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: forfac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: forfrac(:) + ! Dimensions: (nlayers) + + integer(kind=im), intent(out) :: indminor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: minorfrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: scaleminor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: scaleminorn2(:) + ! Dimensions: (nlayers) + + real(kind=rb), intent(out) :: & ! + fac00(:), fac01(:), & ! Dimensions: (nlayers) + fac10(:), fac11(:) + + real(kind=rb), intent(out) :: & ! + rat_h2oco2(:),rat_h2oco2_1(:), & + rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers) + rat_h2on2o(:),rat_h2on2o_1(:), & + rat_h2och4(:),rat_h2och4_1(:), & + rat_n2oco2(:),rat_n2oco2_1(:), & + rat_o3co2(:),rat_o3co2_1(:) + + +! ----- Local ----- + integer(kind=im) :: indbound, indlev0 + integer(kind=im) :: lay, indlay, indlev, iband + integer(kind=im) :: jp1 + real(kind=rb) :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac + real(kind=rb) :: dbdtlev, dbdtlay + real(kind=rb) :: plog, fp, ft, ft1, water, scalefac, factor, compfp + + +!jm not thread safe hvrset = '$Revision: 1.3 $' + + stpfac = 296._rb/1013._rb + + indbound = tbound - 159._rb + if (indbound .lt. 1) then + indbound = 1 + elseif (indbound .gt. 180) then + indbound = 180 + endif + tbndfrac = tbound - 159._rb - float(indbound) + indlev0 = tz(0) - 159._rb + if (indlev0 .lt. 1) then + indlev0 = 1 + elseif (indlev0 .gt. 180) then + indlev0 = 180 + endif + t0frac = tz(0) - 159._rb - float(indlev0) + laytrop = 0 + +! Begin layer loop +! Calculate the integrated Planck functions for each band at the +! surface, level, and layer temperatures. + do lay = 1, nlayers + indlay = tavel(lay) - 159._rb + if (indlay .lt. 1) then + indlay = 1 + elseif (indlay .gt. 180) then + indlay = 180 + endif + tlayfrac = tavel(lay) - 159._rb - float(indlay) + indlev = tz(lay) - 159._rb + if (indlev .lt. 1) then + indlev = 1 + elseif (indlev .gt. 180) then + indlev = 180 + endif + tlevfrac = tz(lay) - 159._rb - float(indlev) + +! Begin spectral band loop + do iband = 1, 15 + if (lay.eq.1) then + dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband) + plankbnd(iband) = semiss(iband) * & + (totplnk(indbound,iband) + tbndfrac * dbdtlev) + dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband) + planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev + endif + dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband) + dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband) + planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay + planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev + enddo + +! For band 16, if radiative transfer will be performed on just +! this band, use integrated Planck values up to 3250 cm-1. +! If radiative transfer will be performed across all 16 bands, +! then include in the integrated Planck values for this band +! contributions from 2600 cm-1 to infinity. + iband = 16 + if (istart .eq. 16) then + if (lay.eq.1) then + dbdtlev = totplk16(indbound+1) - totplk16(indbound) + plankbnd(iband) = semiss(iband) * & + (totplk16(indbound) + tbndfrac * dbdtlev) + dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband) + planklev(0,iband) = totplk16(indlev0) + & + t0frac * dbdtlev + endif + dbdtlev = totplk16(indlev+1) - totplk16(indlev) + dbdtlay = totplk16(indlay+1) - totplk16(indlay) + planklay(lay,iband) = totplk16(indlay) + tlayfrac * dbdtlay + planklev(lay,iband) = totplk16(indlev) + tlevfrac * dbdtlev + else + if (lay.eq.1) then + dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband) + plankbnd(iband) = semiss(iband) * & + (totplnk(indbound,iband) + tbndfrac * dbdtlev) + dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband) + planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev + endif + dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband) + dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband) + planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay + planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev + endif + +! Find the two reference pressures on either side of the +! layer pressure. Store them in JP and JP1. Store in FP the +! fraction of the difference (in ln(pressure)) between these +! two values that the layer pressure lies. + + plog = log(pavel(lay)) +! plog = dlog(pavel(lay)) + jp(lay) = int(36._rb - 5*(plog+0.04_rb)) + if (jp(lay) .lt. 1) then + jp(lay) = 1 + elseif (jp(lay) .gt. 58) then + jp(lay) = 58 + endif + jp1 = jp(lay) + 1 + fp = 5._rb *(preflog(jp(lay)) - plog) + +! Determine, for each reference pressure (JP and JP1), which +! reference temperature (these are different for each +! reference pressure) is nearest the layer temperature but does +! not exceed it. Store these indices in JT and JT1, resp. +! Store in FT (resp. FT1) the fraction of the way between JT +! (JT1) and the next highest reference temperature that the +! layer temperature falls. + jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb) + if (jt(lay) .lt. 1) then + jt(lay) = 1 + elseif (jt(lay) .gt. 4) then + jt(lay) = 4 + endif + ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - float(jt(lay)-3) + jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb) + if (jt1(lay) .lt. 1) then + jt1(lay) = 1 + elseif (jt1(lay) .gt. 4) then + jt1(lay) = 4 + endif + ft1 = ((tavel(lay)-tref(jp1))/15._rb) - float(jt1(lay)-3) + water = wkl(1,lay)/coldry(lay) + scalefac = pavel(lay) * stpfac / tavel(lay) + +! If the pressure is less than ~100mb, perform a different +! set of species interpolations. + if (plog .le. 4.56_rb) go to 5300 + laytrop = laytrop + 1 + + forfac(lay) = scalefac / (1.+water) + factor = (332.0_rb-tavel(lay))/36.0_rb + indfor(lay) = min(2, max(1, int(factor))) + forfrac(lay) = factor - float(indfor(lay)) + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + selffac(lay) = water * forfac(lay) + factor = (tavel(lay)-188.0_rb)/7.2_rb + indself(lay) = min(9, max(1, int(factor)-7)) + selffrac(lay) = factor - float(indself(lay) + 7) + +! Set up factors needed to separately include the minor gases +! in the calculation of absorption coefficient + scaleminor(lay) = pavel(lay)/tavel(lay) + scaleminorn2(lay) = (pavel(lay)/tavel(lay)) & + *(wbroad(lay)/(coldry(lay)+wkl(1,lay))) + factor = (tavel(lay)-180.8_rb)/7.2_rb + indminor(lay) = min(18, max(1, int(factor))) + minorfrac(lay) = factor - float(indminor(lay)) + +! Setup reference ratio to be used in calculation of binary +! species parameter in lower atmosphere. + rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay)) + rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1) + + rat_h2oo3(lay)=chi_mls(1,jp(lay))/chi_mls(3,jp(lay)) + rat_h2oo3_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(3,jp(lay)+1) + + rat_h2on2o(lay)=chi_mls(1,jp(lay))/chi_mls(4,jp(lay)) + rat_h2on2o_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(4,jp(lay)+1) + + rat_h2och4(lay)=chi_mls(1,jp(lay))/chi_mls(6,jp(lay)) + rat_h2och4_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(6,jp(lay)+1) + + rat_n2oco2(lay)=chi_mls(4,jp(lay))/chi_mls(2,jp(lay)) + rat_n2oco2_1(lay)=chi_mls(4,jp(lay)+1)/chi_mls(2,jp(lay)+1) + +! Calculate needed column amounts. + colh2o(lay) = 1.e-20_rb * wkl(1,lay) + colco2(lay) = 1.e-20_rb * wkl(2,lay) + colo3(lay) = 1.e-20_rb * wkl(3,lay) + coln2o(lay) = 1.e-20_rb * wkl(4,lay) + colco(lay) = 1.e-20_rb * wkl(5,lay) + colch4(lay) = 1.e-20_rb * wkl(6,lay) + colo2(lay) = 1.e-20_rb * wkl(7,lay) + if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay) + if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay) + if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay) + if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay) + if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay) + colbrd(lay) = 1.e-20_rb * wbroad(lay) + go to 5400 + +! Above laytrop. + 5300 continue + + forfac(lay) = scalefac / (1.+water) + factor = (tavel(lay)-188.0_rb)/36.0_rb + indfor(lay) = 3 + forfrac(lay) = factor - 1.0_rb + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + selffac(lay) = water * forfac(lay) + +! Set up factors needed to separately include the minor gases +! in the calculation of absorption coefficient + scaleminor(lay) = pavel(lay)/tavel(lay) + scaleminorn2(lay) = (pavel(lay)/tavel(lay)) & + * (wbroad(lay)/(coldry(lay)+wkl(1,lay))) + factor = (tavel(lay)-180.8_rb)/7.2_rb + indminor(lay) = min(18, max(1, int(factor))) + minorfrac(lay) = factor - float(indminor(lay)) + +! Setup reference ratio to be used in calculation of binary +! species parameter in upper atmosphere. + rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay)) + rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1) + + rat_o3co2(lay)=chi_mls(3,jp(lay))/chi_mls(2,jp(lay)) + rat_o3co2_1(lay)=chi_mls(3,jp(lay)+1)/chi_mls(2,jp(lay)+1) + +! Calculate needed column amounts. + colh2o(lay) = 1.e-20_rb * wkl(1,lay) + colco2(lay) = 1.e-20_rb * wkl(2,lay) + colo3(lay) = 1.e-20_rb * wkl(3,lay) + coln2o(lay) = 1.e-20_rb * wkl(4,lay) + colco(lay) = 1.e-20_rb * wkl(5,lay) + colch4(lay) = 1.e-20_rb * wkl(6,lay) + colo2(lay) = 1.e-20_rb * wkl(7,lay) + if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay) + if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay) + if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay) + if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay) + if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay) + colbrd(lay) = 1.e-20_rb * wbroad(lay) + 5400 continue + +! We have now isolated the layer ln pressure and temperature, +! between two reference pressures and two reference temperatures +! (for each reference pressure). We multiply the pressure +! fraction FP with the appropriate temperature fractions to get +! the factors that will be needed for the interpolation that yields +! the optical depths (performed in routines TAUGBn for band n).` + + compfp = 1. - fp + fac10(lay) = compfp * ft + fac00(lay) = compfp * (1._rb - ft) + fac11(lay) = fp * ft1 + fac01(lay) = fp * (1._rb - ft1) + +! Rescale selffac and forfac for use in taumol + selffac(lay) = colh2o(lay)*selffac(lay) + forfac(lay) = colh2o(lay)*forfac(lay) + +! End layer loop + enddo + + end subroutine setcoef + +!*************************************************************************** + subroutine lwatmref +!*************************************************************************** + + save + +! These pressures are chosen such that the ln of the first pressure +! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and +! each subsequent ln(pressure) differs from the previous one by 0.2. + + pref(:) = (/ & + 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, & + 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, & + 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, & + 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, & + 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, & + 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, & + 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, & + 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, & + 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, & + 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, & + 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, & + 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb/) + + preflog(:) = (/ & + 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, & + 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, & + 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, & + 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, & + 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, & + 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, & + 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, & + -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, & + -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, & + -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, & + -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, & + -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb/) + +! These are the temperatures associated with the respective +! pressures for the mls standard atmosphere. + + tref(:) = (/ & + 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, & + 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, & + 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, & + 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, & + 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, & + 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, & + 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, & + 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, & + 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, & + 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, & + 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, & + 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb/) + + chi_mls(1,1:12) = (/ & + 1.8760e-02_rb, 1.2223e-02_rb, 5.8909e-03_rb, 2.7675e-03_rb, 1.4065e-03_rb, & + 7.5970e-04_rb, 3.8876e-04_rb, 1.6542e-04_rb, 3.7190e-05_rb, 7.4765e-06_rb, & + 4.3082e-06_rb, 3.3319e-06_rb/) + chi_mls(1,13:59) = (/ & + 3.2039e-06_rb, 3.1619e-06_rb, 3.2524e-06_rb, 3.4226e-06_rb, 3.6288e-06_rb, & + 3.9148e-06_rb, 4.1488e-06_rb, 4.3081e-06_rb, 4.4420e-06_rb, 4.5778e-06_rb, & + 4.7087e-06_rb, 4.7943e-06_rb, 4.8697e-06_rb, 4.9260e-06_rb, 4.9669e-06_rb, & + 4.9963e-06_rb, 5.0527e-06_rb, 5.1266e-06_rb, 5.2503e-06_rb, 5.3571e-06_rb, & + 5.4509e-06_rb, 5.4830e-06_rb, 5.5000e-06_rb, 5.5000e-06_rb, 5.4536e-06_rb, & + 5.4047e-06_rb, 5.3558e-06_rb, 5.2533e-06_rb, 5.1436e-06_rb, 5.0340e-06_rb, & + 4.8766e-06_rb, 4.6979e-06_rb, 4.5191e-06_rb, 4.3360e-06_rb, 4.1442e-06_rb, & + 3.9523e-06_rb, 3.7605e-06_rb, 3.5722e-06_rb, 3.3855e-06_rb, 3.1988e-06_rb, & + 3.0121e-06_rb, 2.8262e-06_rb, 2.6407e-06_rb, 2.4552e-06_rb, 2.2696e-06_rb, & + 4.3360e-06_rb, 4.1442e-06_rb/) + chi_mls(2,1:12) = (/ & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb/) + chi_mls(2,13:59) = (/ & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, & + 3.5500e-04_rb, 3.5471e-04_rb, 3.5427e-04_rb, 3.5384e-04_rb, 3.5340e-04_rb, & + 3.5500e-04_rb, 3.5500e-04_rb/) + chi_mls(3,1:12) = (/ & + 3.0170e-08_rb, 3.4725e-08_rb, 4.2477e-08_rb, 5.2759e-08_rb, 6.6944e-08_rb, & + 8.7130e-08_rb, 1.1391e-07_rb, 1.5677e-07_rb, 2.1788e-07_rb, 3.2443e-07_rb, & + 4.6594e-07_rb, 5.6806e-07_rb/) + chi_mls(3,13:59) = (/ & + 6.9607e-07_rb, 1.1186e-06_rb, 1.7618e-06_rb, 2.3269e-06_rb, 2.9577e-06_rb, & + 3.6593e-06_rb, 4.5950e-06_rb, 5.3189e-06_rb, 5.9618e-06_rb, 6.5113e-06_rb, & + 7.0635e-06_rb, 7.6917e-06_rb, 8.2577e-06_rb, 8.7082e-06_rb, 8.8325e-06_rb, & + 8.7149e-06_rb, 8.0943e-06_rb, 7.3307e-06_rb, 6.3101e-06_rb, 5.3672e-06_rb, & + 4.4829e-06_rb, 3.8391e-06_rb, 3.2827e-06_rb, 2.8235e-06_rb, 2.4906e-06_rb, & + 2.1645e-06_rb, 1.8385e-06_rb, 1.6618e-06_rb, 1.5052e-06_rb, 1.3485e-06_rb, & + 1.1972e-06_rb, 1.0482e-06_rb, 8.9926e-07_rb, 7.6343e-07_rb, 6.5381e-07_rb, & + 5.4419e-07_rb, 4.3456e-07_rb, 3.6421e-07_rb, 3.1194e-07_rb, 2.5967e-07_rb, & + 2.0740e-07_rb, 1.9146e-07_rb, 1.9364e-07_rb, 1.9582e-07_rb, 1.9800e-07_rb, & + 7.6343e-07_rb, 6.5381e-07_rb/) + chi_mls(4,1:12) = (/ & + 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, & + 3.1965e-07_rb, 3.1532e-07_rb, 3.0383e-07_rb, 2.9422e-07_rb, 2.8495e-07_rb, & + 2.7671e-07_rb, 2.6471e-07_rb/) + chi_mls(4,13:59) = (/ & + 2.4285e-07_rb, 2.0955e-07_rb, 1.7195e-07_rb, 1.3749e-07_rb, 1.1332e-07_rb, & + 1.0035e-07_rb, 9.1281e-08_rb, 8.5463e-08_rb, 8.0363e-08_rb, 7.3372e-08_rb, & + 6.5975e-08_rb, 5.6039e-08_rb, 4.7090e-08_rb, 3.9977e-08_rb, 3.2979e-08_rb, & + 2.6064e-08_rb, 2.1066e-08_rb, 1.6592e-08_rb, 1.3017e-08_rb, 1.0090e-08_rb, & + 7.6249e-09_rb, 6.1159e-09_rb, 4.6672e-09_rb, 3.2857e-09_rb, 2.8484e-09_rb, & + 2.4620e-09_rb, 2.0756e-09_rb, 1.8551e-09_rb, 1.6568e-09_rb, 1.4584e-09_rb, & + 1.3195e-09_rb, 1.2072e-09_rb, 1.0948e-09_rb, 9.9780e-10_rb, 9.3126e-10_rb, & + 8.6472e-10_rb, 7.9818e-10_rb, 7.5138e-10_rb, 7.1367e-10_rb, 6.7596e-10_rb, & + 6.3825e-10_rb, 6.0981e-10_rb, 5.8600e-10_rb, 5.6218e-10_rb, 5.3837e-10_rb, & + 9.9780e-10_rb, 9.3126e-10_rb/) + chi_mls(5,1:12) = (/ & + 1.5000e-07_rb, 1.4306e-07_rb, 1.3474e-07_rb, 1.3061e-07_rb, 1.2793e-07_rb, & + 1.2038e-07_rb, 1.0798e-07_rb, 9.4238e-08_rb, 7.9488e-08_rb, 6.1386e-08_rb, & + 4.5563e-08_rb, 3.3475e-08_rb/) + chi_mls(5,13:59) = (/ & + 2.5118e-08_rb, 1.8671e-08_rb, 1.4349e-08_rb, 1.2501e-08_rb, 1.2407e-08_rb, & + 1.3472e-08_rb, 1.4900e-08_rb, 1.6079e-08_rb, 1.7156e-08_rb, 1.8616e-08_rb, & + 2.0106e-08_rb, 2.1654e-08_rb, 2.3096e-08_rb, 2.4340e-08_rb, 2.5643e-08_rb, & + 2.6990e-08_rb, 2.8456e-08_rb, 2.9854e-08_rb, 3.0943e-08_rb, 3.2023e-08_rb, & + 3.3101e-08_rb, 3.4260e-08_rb, 3.5360e-08_rb, 3.6397e-08_rb, 3.7310e-08_rb, & + 3.8217e-08_rb, 3.9123e-08_rb, 4.1303e-08_rb, 4.3652e-08_rb, 4.6002e-08_rb, & + 5.0289e-08_rb, 5.5446e-08_rb, 6.0603e-08_rb, 6.8946e-08_rb, 8.3652e-08_rb, & + 9.8357e-08_rb, 1.1306e-07_rb, 1.4766e-07_rb, 1.9142e-07_rb, 2.3518e-07_rb, & + 2.7894e-07_rb, 3.5001e-07_rb, 4.3469e-07_rb, 5.1938e-07_rb, 6.0407e-07_rb, & + 6.8946e-08_rb, 8.3652e-08_rb/) + chi_mls(6,1:12) = (/ & + 1.7000e-06_rb, 1.7000e-06_rb, 1.6999e-06_rb, 1.6904e-06_rb, 1.6671e-06_rb, & + 1.6351e-06_rb, 1.6098e-06_rb, 1.5590e-06_rb, 1.5120e-06_rb, 1.4741e-06_rb, & + 1.4385e-06_rb, 1.4002e-06_rb/) + chi_mls(6,13:59) = (/ & + 1.3573e-06_rb, 1.3130e-06_rb, 1.2512e-06_rb, 1.1668e-06_rb, 1.0553e-06_rb, & + 9.3281e-07_rb, 8.1217e-07_rb, 7.5239e-07_rb, 7.0728e-07_rb, 6.6722e-07_rb, & + 6.2733e-07_rb, 5.8604e-07_rb, 5.4769e-07_rb, 5.1480e-07_rb, 4.8206e-07_rb, & + 4.4943e-07_rb, 4.1702e-07_rb, 3.8460e-07_rb, 3.5200e-07_rb, 3.1926e-07_rb, & + 2.8646e-07_rb, 2.5498e-07_rb, 2.2474e-07_rb, 1.9588e-07_rb, 1.8295e-07_rb, & + 1.7089e-07_rb, 1.5882e-07_rb, 1.5536e-07_rb, 1.5304e-07_rb, 1.5072e-07_rb, & + 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, & + 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, & + 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, & + 1.5000e-07_rb, 1.5000e-07_rb/) + chi_mls(7,1:12) = (/ & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb/) + chi_mls(7,13:59) = (/ & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, & + 0.2090_rb, 0.2090_rb/) + + end subroutine lwatmref + +!*************************************************************************** + subroutine lwavplank +!*************************************************************************** + + save + + totplnk(1:50, 1) = (/ & + 0.14783e-05_rb,0.15006e-05_rb,0.15230e-05_rb,0.15455e-05_rb,0.15681e-05_rb, & + 0.15908e-05_rb,0.16136e-05_rb,0.16365e-05_rb,0.16595e-05_rb,0.16826e-05_rb, & + 0.17059e-05_rb,0.17292e-05_rb,0.17526e-05_rb,0.17762e-05_rb,0.17998e-05_rb, & + 0.18235e-05_rb,0.18473e-05_rb,0.18712e-05_rb,0.18953e-05_rb,0.19194e-05_rb, & + 0.19435e-05_rb,0.19678e-05_rb,0.19922e-05_rb,0.20166e-05_rb,0.20412e-05_rb, & + 0.20658e-05_rb,0.20905e-05_rb,0.21153e-05_rb,0.21402e-05_rb,0.21652e-05_rb, & + 0.21902e-05_rb,0.22154e-05_rb,0.22406e-05_rb,0.22659e-05_rb,0.22912e-05_rb, & + 0.23167e-05_rb,0.23422e-05_rb,0.23678e-05_rb,0.23934e-05_rb,0.24192e-05_rb, & + 0.24450e-05_rb,0.24709e-05_rb,0.24968e-05_rb,0.25229e-05_rb,0.25490e-05_rb, & + 0.25751e-05_rb,0.26014e-05_rb,0.26277e-05_rb,0.26540e-05_rb,0.26805e-05_rb/) + totplnk(51:100, 1) = (/ & + 0.27070e-05_rb,0.27335e-05_rb,0.27602e-05_rb,0.27869e-05_rb,0.28136e-05_rb, & + 0.28404e-05_rb,0.28673e-05_rb,0.28943e-05_rb,0.29213e-05_rb,0.29483e-05_rb, & + 0.29754e-05_rb,0.30026e-05_rb,0.30298e-05_rb,0.30571e-05_rb,0.30845e-05_rb, & + 0.31119e-05_rb,0.31393e-05_rb,0.31669e-05_rb,0.31944e-05_rb,0.32220e-05_rb, & + 0.32497e-05_rb,0.32774e-05_rb,0.33052e-05_rb,0.33330e-05_rb,0.33609e-05_rb, & + 0.33888e-05_rb,0.34168e-05_rb,0.34448e-05_rb,0.34729e-05_rb,0.35010e-05_rb, & + 0.35292e-05_rb,0.35574e-05_rb,0.35857e-05_rb,0.36140e-05_rb,0.36424e-05_rb, & + 0.36708e-05_rb,0.36992e-05_rb,0.37277e-05_rb,0.37563e-05_rb,0.37848e-05_rb, & + 0.38135e-05_rb,0.38421e-05_rb,0.38708e-05_rb,0.38996e-05_rb,0.39284e-05_rb, & + 0.39572e-05_rb,0.39861e-05_rb,0.40150e-05_rb,0.40440e-05_rb,0.40730e-05_rb/) + totplnk(101:150, 1) = (/ & + 0.41020e-05_rb,0.41311e-05_rb,0.41602e-05_rb,0.41893e-05_rb,0.42185e-05_rb, & + 0.42477e-05_rb,0.42770e-05_rb,0.43063e-05_rb,0.43356e-05_rb,0.43650e-05_rb, & + 0.43944e-05_rb,0.44238e-05_rb,0.44533e-05_rb,0.44828e-05_rb,0.45124e-05_rb, & + 0.45419e-05_rb,0.45715e-05_rb,0.46012e-05_rb,0.46309e-05_rb,0.46606e-05_rb, & + 0.46903e-05_rb,0.47201e-05_rb,0.47499e-05_rb,0.47797e-05_rb,0.48096e-05_rb, & + 0.48395e-05_rb,0.48695e-05_rb,0.48994e-05_rb,0.49294e-05_rb,0.49594e-05_rb, & + 0.49895e-05_rb,0.50196e-05_rb,0.50497e-05_rb,0.50798e-05_rb,0.51100e-05_rb, & + 0.51402e-05_rb,0.51704e-05_rb,0.52007e-05_rb,0.52309e-05_rb,0.52612e-05_rb, & + 0.52916e-05_rb,0.53219e-05_rb,0.53523e-05_rb,0.53827e-05_rb,0.54132e-05_rb, & + 0.54436e-05_rb,0.54741e-05_rb,0.55047e-05_rb,0.55352e-05_rb,0.55658e-05_rb/) + totplnk(151:181, 1) = (/ & + 0.55964e-05_rb,0.56270e-05_rb,0.56576e-05_rb,0.56883e-05_rb,0.57190e-05_rb, & + 0.57497e-05_rb,0.57804e-05_rb,0.58112e-05_rb,0.58420e-05_rb,0.58728e-05_rb, & + 0.59036e-05_rb,0.59345e-05_rb,0.59653e-05_rb,0.59962e-05_rb,0.60272e-05_rb, & + 0.60581e-05_rb,0.60891e-05_rb,0.61201e-05_rb,0.61511e-05_rb,0.61821e-05_rb, & + 0.62131e-05_rb,0.62442e-05_rb,0.62753e-05_rb,0.63064e-05_rb,0.63376e-05_rb, & + 0.63687e-05_rb,0.63998e-05_rb,0.64310e-05_rb,0.64622e-05_rb,0.64935e-05_rb, & + 0.65247e-05_rb/) + totplnk(1:50, 2) = (/ & + 0.20262e-05_rb,0.20757e-05_rb,0.21257e-05_rb,0.21763e-05_rb,0.22276e-05_rb, & + 0.22794e-05_rb,0.23319e-05_rb,0.23849e-05_rb,0.24386e-05_rb,0.24928e-05_rb, & + 0.25477e-05_rb,0.26031e-05_rb,0.26591e-05_rb,0.27157e-05_rb,0.27728e-05_rb, & + 0.28306e-05_rb,0.28889e-05_rb,0.29478e-05_rb,0.30073e-05_rb,0.30673e-05_rb, & + 0.31279e-05_rb,0.31890e-05_rb,0.32507e-05_rb,0.33129e-05_rb,0.33757e-05_rb, & + 0.34391e-05_rb,0.35029e-05_rb,0.35674e-05_rb,0.36323e-05_rb,0.36978e-05_rb, & + 0.37638e-05_rb,0.38304e-05_rb,0.38974e-05_rb,0.39650e-05_rb,0.40331e-05_rb, & + 0.41017e-05_rb,0.41708e-05_rb,0.42405e-05_rb,0.43106e-05_rb,0.43812e-05_rb, & + 0.44524e-05_rb,0.45240e-05_rb,0.45961e-05_rb,0.46687e-05_rb,0.47418e-05_rb, & + 0.48153e-05_rb,0.48894e-05_rb,0.49639e-05_rb,0.50389e-05_rb,0.51143e-05_rb/) + totplnk(51:100, 2) = (/ & + 0.51902e-05_rb,0.52666e-05_rb,0.53434e-05_rb,0.54207e-05_rb,0.54985e-05_rb, & + 0.55767e-05_rb,0.56553e-05_rb,0.57343e-05_rb,0.58139e-05_rb,0.58938e-05_rb, & + 0.59742e-05_rb,0.60550e-05_rb,0.61362e-05_rb,0.62179e-05_rb,0.63000e-05_rb, & + 0.63825e-05_rb,0.64654e-05_rb,0.65487e-05_rb,0.66324e-05_rb,0.67166e-05_rb, & + 0.68011e-05_rb,0.68860e-05_rb,0.69714e-05_rb,0.70571e-05_rb,0.71432e-05_rb, & + 0.72297e-05_rb,0.73166e-05_rb,0.74039e-05_rb,0.74915e-05_rb,0.75796e-05_rb, & + 0.76680e-05_rb,0.77567e-05_rb,0.78459e-05_rb,0.79354e-05_rb,0.80252e-05_rb, & + 0.81155e-05_rb,0.82061e-05_rb,0.82970e-05_rb,0.83883e-05_rb,0.84799e-05_rb, & + 0.85719e-05_rb,0.86643e-05_rb,0.87569e-05_rb,0.88499e-05_rb,0.89433e-05_rb, & + 0.90370e-05_rb,0.91310e-05_rb,0.92254e-05_rb,0.93200e-05_rb,0.94150e-05_rb/) + totplnk(101:150, 2) = (/ & + 0.95104e-05_rb,0.96060e-05_rb,0.97020e-05_rb,0.97982e-05_rb,0.98948e-05_rb, & + 0.99917e-05_rb,0.10089e-04_rb,0.10186e-04_rb,0.10284e-04_rb,0.10382e-04_rb, & + 0.10481e-04_rb,0.10580e-04_rb,0.10679e-04_rb,0.10778e-04_rb,0.10877e-04_rb, & + 0.10977e-04_rb,0.11077e-04_rb,0.11178e-04_rb,0.11279e-04_rb,0.11380e-04_rb, & + 0.11481e-04_rb,0.11583e-04_rb,0.11684e-04_rb,0.11786e-04_rb,0.11889e-04_rb, & + 0.11992e-04_rb,0.12094e-04_rb,0.12198e-04_rb,0.12301e-04_rb,0.12405e-04_rb, & + 0.12509e-04_rb,0.12613e-04_rb,0.12717e-04_rb,0.12822e-04_rb,0.12927e-04_rb, & + 0.13032e-04_rb,0.13138e-04_rb,0.13244e-04_rb,0.13349e-04_rb,0.13456e-04_rb, & + 0.13562e-04_rb,0.13669e-04_rb,0.13776e-04_rb,0.13883e-04_rb,0.13990e-04_rb, & + 0.14098e-04_rb,0.14206e-04_rb,0.14314e-04_rb,0.14422e-04_rb,0.14531e-04_rb/) + totplnk(151:181, 2) = (/ & + 0.14639e-04_rb,0.14748e-04_rb,0.14857e-04_rb,0.14967e-04_rb,0.15076e-04_rb, & + 0.15186e-04_rb,0.15296e-04_rb,0.15407e-04_rb,0.15517e-04_rb,0.15628e-04_rb, & + 0.15739e-04_rb,0.15850e-04_rb,0.15961e-04_rb,0.16072e-04_rb,0.16184e-04_rb, & + 0.16296e-04_rb,0.16408e-04_rb,0.16521e-04_rb,0.16633e-04_rb,0.16746e-04_rb, & + 0.16859e-04_rb,0.16972e-04_rb,0.17085e-04_rb,0.17198e-04_rb,0.17312e-04_rb, & + 0.17426e-04_rb,0.17540e-04_rb,0.17654e-04_rb,0.17769e-04_rb,0.17883e-04_rb, & + 0.17998e-04_rb/) + totplnk(1:50, 3) = (/ & + 1.34822e-06_rb,1.39134e-06_rb,1.43530e-06_rb,1.48010e-06_rb,1.52574e-06_rb, & + 1.57222e-06_rb,1.61956e-06_rb,1.66774e-06_rb,1.71678e-06_rb,1.76666e-06_rb, & + 1.81741e-06_rb,1.86901e-06_rb,1.92147e-06_rb,1.97479e-06_rb,2.02898e-06_rb, & + 2.08402e-06_rb,2.13993e-06_rb,2.19671e-06_rb,2.25435e-06_rb,2.31285e-06_rb, & + 2.37222e-06_rb,2.43246e-06_rb,2.49356e-06_rb,2.55553e-06_rb,2.61837e-06_rb, & + 2.68207e-06_rb,2.74664e-06_rb,2.81207e-06_rb,2.87837e-06_rb,2.94554e-06_rb, & + 3.01356e-06_rb,3.08245e-06_rb,3.15221e-06_rb,3.22282e-06_rb,3.29429e-06_rb, & + 3.36662e-06_rb,3.43982e-06_rb,3.51386e-06_rb,3.58876e-06_rb,3.66451e-06_rb, & + 3.74112e-06_rb,3.81857e-06_rb,3.89688e-06_rb,3.97602e-06_rb,4.05601e-06_rb, & + 4.13685e-06_rb,4.21852e-06_rb,4.30104e-06_rb,4.38438e-06_rb,4.46857e-06_rb/) + totplnk(51:100, 3) = (/ & + 4.55358e-06_rb,4.63943e-06_rb,4.72610e-06_rb,4.81359e-06_rb,4.90191e-06_rb, & + 4.99105e-06_rb,5.08100e-06_rb,5.17176e-06_rb,5.26335e-06_rb,5.35573e-06_rb, & + 5.44892e-06_rb,5.54292e-06_rb,5.63772e-06_rb,5.73331e-06_rb,5.82970e-06_rb, & + 5.92688e-06_rb,6.02485e-06_rb,6.12360e-06_rb,6.22314e-06_rb,6.32346e-06_rb, & + 6.42455e-06_rb,6.52641e-06_rb,6.62906e-06_rb,6.73247e-06_rb,6.83664e-06_rb, & + 6.94156e-06_rb,7.04725e-06_rb,7.15370e-06_rb,7.26089e-06_rb,7.36883e-06_rb, & + 7.47752e-06_rb,7.58695e-06_rb,7.69712e-06_rb,7.80801e-06_rb,7.91965e-06_rb, & + 8.03201e-06_rb,8.14510e-06_rb,8.25891e-06_rb,8.37343e-06_rb,8.48867e-06_rb, & + 8.60463e-06_rb,8.72128e-06_rb,8.83865e-06_rb,8.95672e-06_rb,9.07548e-06_rb, & + 9.19495e-06_rb,9.31510e-06_rb,9.43594e-06_rb,9.55745e-06_rb,9.67966e-06_rb/) + totplnk(101:150, 3) = (/ & + 9.80254e-06_rb,9.92609e-06_rb,1.00503e-05_rb,1.01752e-05_rb,1.03008e-05_rb, & + 1.04270e-05_rb,1.05539e-05_rb,1.06814e-05_rb,1.08096e-05_rb,1.09384e-05_rb, & + 1.10679e-05_rb,1.11980e-05_rb,1.13288e-05_rb,1.14601e-05_rb,1.15922e-05_rb, & + 1.17248e-05_rb,1.18581e-05_rb,1.19920e-05_rb,1.21265e-05_rb,1.22616e-05_rb, & + 1.23973e-05_rb,1.25337e-05_rb,1.26706e-05_rb,1.28081e-05_rb,1.29463e-05_rb, & + 1.30850e-05_rb,1.32243e-05_rb,1.33642e-05_rb,1.35047e-05_rb,1.36458e-05_rb, & + 1.37875e-05_rb,1.39297e-05_rb,1.40725e-05_rb,1.42159e-05_rb,1.43598e-05_rb, & + 1.45044e-05_rb,1.46494e-05_rb,1.47950e-05_rb,1.49412e-05_rb,1.50879e-05_rb, & + 1.52352e-05_rb,1.53830e-05_rb,1.55314e-05_rb,1.56803e-05_rb,1.58297e-05_rb, & + 1.59797e-05_rb,1.61302e-05_rb,1.62812e-05_rb,1.64327e-05_rb,1.65848e-05_rb/) + totplnk(151:181, 3) = (/ & + 1.67374e-05_rb,1.68904e-05_rb,1.70441e-05_rb,1.71982e-05_rb,1.73528e-05_rb, & + 1.75079e-05_rb,1.76635e-05_rb,1.78197e-05_rb,1.79763e-05_rb,1.81334e-05_rb, & + 1.82910e-05_rb,1.84491e-05_rb,1.86076e-05_rb,1.87667e-05_rb,1.89262e-05_rb, & + 1.90862e-05_rb,1.92467e-05_rb,1.94076e-05_rb,1.95690e-05_rb,1.97309e-05_rb, & + 1.98932e-05_rb,2.00560e-05_rb,2.02193e-05_rb,2.03830e-05_rb,2.05472e-05_rb, & + 2.07118e-05_rb,2.08768e-05_rb,2.10423e-05_rb,2.12083e-05_rb,2.13747e-05_rb, & + 2.15414e-05_rb/) + totplnk(1:50, 4) = (/ & + 8.90528e-07_rb,9.24222e-07_rb,9.58757e-07_rb,9.94141e-07_rb,1.03038e-06_rb, & + 1.06748e-06_rb,1.10545e-06_rb,1.14430e-06_rb,1.18403e-06_rb,1.22465e-06_rb, & + 1.26618e-06_rb,1.30860e-06_rb,1.35193e-06_rb,1.39619e-06_rb,1.44136e-06_rb, & + 1.48746e-06_rb,1.53449e-06_rb,1.58246e-06_rb,1.63138e-06_rb,1.68124e-06_rb, & + 1.73206e-06_rb,1.78383e-06_rb,1.83657e-06_rb,1.89028e-06_rb,1.94495e-06_rb, & + 2.00060e-06_rb,2.05724e-06_rb,2.11485e-06_rb,2.17344e-06_rb,2.23303e-06_rb, & + 2.29361e-06_rb,2.35519e-06_rb,2.41777e-06_rb,2.48134e-06_rb,2.54592e-06_rb, & + 2.61151e-06_rb,2.67810e-06_rb,2.74571e-06_rb,2.81433e-06_rb,2.88396e-06_rb, & + 2.95461e-06_rb,3.02628e-06_rb,3.09896e-06_rb,3.17267e-06_rb,3.24741e-06_rb, & + 3.32316e-06_rb,3.39994e-06_rb,3.47774e-06_rb,3.55657e-06_rb,3.63642e-06_rb/) + totplnk(51:100, 4) = (/ & + 3.71731e-06_rb,3.79922e-06_rb,3.88216e-06_rb,3.96612e-06_rb,4.05112e-06_rb, & + 4.13714e-06_rb,4.22419e-06_rb,4.31227e-06_rb,4.40137e-06_rb,4.49151e-06_rb, & + 4.58266e-06_rb,4.67485e-06_rb,4.76806e-06_rb,4.86229e-06_rb,4.95754e-06_rb, & + 5.05383e-06_rb,5.15113e-06_rb,5.24946e-06_rb,5.34879e-06_rb,5.44916e-06_rb, & + 5.55053e-06_rb,5.65292e-06_rb,5.75632e-06_rb,5.86073e-06_rb,5.96616e-06_rb, & + 6.07260e-06_rb,6.18003e-06_rb,6.28848e-06_rb,6.39794e-06_rb,6.50838e-06_rb, & + 6.61983e-06_rb,6.73229e-06_rb,6.84573e-06_rb,6.96016e-06_rb,7.07559e-06_rb, & + 7.19200e-06_rb,7.30940e-06_rb,7.42779e-06_rb,7.54715e-06_rb,7.66749e-06_rb, & + 7.78882e-06_rb,7.91110e-06_rb,8.03436e-06_rb,8.15859e-06_rb,8.28379e-06_rb, & + 8.40994e-06_rb,8.53706e-06_rb,8.66515e-06_rb,8.79418e-06_rb,8.92416e-06_rb/) + totplnk(101:150, 4) = (/ & + 9.05510e-06_rb,9.18697e-06_rb,9.31979e-06_rb,9.45356e-06_rb,9.58826e-06_rb, & + 9.72389e-06_rb,9.86046e-06_rb,9.99793e-06_rb,1.01364e-05_rb,1.02757e-05_rb, & + 1.04159e-05_rb,1.05571e-05_rb,1.06992e-05_rb,1.08422e-05_rb,1.09861e-05_rb, & + 1.11309e-05_rb,1.12766e-05_rb,1.14232e-05_rb,1.15707e-05_rb,1.17190e-05_rb, & + 1.18683e-05_rb,1.20184e-05_rb,1.21695e-05_rb,1.23214e-05_rb,1.24741e-05_rb, & + 1.26277e-05_rb,1.27822e-05_rb,1.29376e-05_rb,1.30939e-05_rb,1.32509e-05_rb, & + 1.34088e-05_rb,1.35676e-05_rb,1.37273e-05_rb,1.38877e-05_rb,1.40490e-05_rb, & + 1.42112e-05_rb,1.43742e-05_rb,1.45380e-05_rb,1.47026e-05_rb,1.48680e-05_rb, & + 1.50343e-05_rb,1.52014e-05_rb,1.53692e-05_rb,1.55379e-05_rb,1.57074e-05_rb, & + 1.58778e-05_rb,1.60488e-05_rb,1.62207e-05_rb,1.63934e-05_rb,1.65669e-05_rb/) + totplnk(151:181, 4) = (/ & + 1.67411e-05_rb,1.69162e-05_rb,1.70920e-05_rb,1.72685e-05_rb,1.74459e-05_rb, & + 1.76240e-05_rb,1.78029e-05_rb,1.79825e-05_rb,1.81629e-05_rb,1.83440e-05_rb, & + 1.85259e-05_rb,1.87086e-05_rb,1.88919e-05_rb,1.90760e-05_rb,1.92609e-05_rb, & + 1.94465e-05_rb,1.96327e-05_rb,1.98199e-05_rb,2.00076e-05_rb,2.01961e-05_rb, & + 2.03853e-05_rb,2.05752e-05_rb,2.07658e-05_rb,2.09571e-05_rb,2.11491e-05_rb, & + 2.13418e-05_rb,2.15352e-05_rb,2.17294e-05_rb,2.19241e-05_rb,2.21196e-05_rb, & + 2.23158e-05_rb/) + totplnk(1:50, 5) = (/ & + 5.70230e-07_rb,5.94788e-07_rb,6.20085e-07_rb,6.46130e-07_rb,6.72936e-07_rb, & + 7.00512e-07_rb,7.28869e-07_rb,7.58019e-07_rb,7.87971e-07_rb,8.18734e-07_rb, & + 8.50320e-07_rb,8.82738e-07_rb,9.15999e-07_rb,9.50110e-07_rb,9.85084e-07_rb, & + 1.02093e-06_rb,1.05765e-06_rb,1.09527e-06_rb,1.13378e-06_rb,1.17320e-06_rb, & + 1.21353e-06_rb,1.25479e-06_rb,1.29698e-06_rb,1.34011e-06_rb,1.38419e-06_rb, & + 1.42923e-06_rb,1.47523e-06_rb,1.52221e-06_rb,1.57016e-06_rb,1.61910e-06_rb, & + 1.66904e-06_rb,1.71997e-06_rb,1.77192e-06_rb,1.82488e-06_rb,1.87886e-06_rb, & + 1.93387e-06_rb,1.98991e-06_rb,2.04699e-06_rb,2.10512e-06_rb,2.16430e-06_rb, & + 2.22454e-06_rb,2.28584e-06_rb,2.34821e-06_rb,2.41166e-06_rb,2.47618e-06_rb, & + 2.54178e-06_rb,2.60847e-06_rb,2.67626e-06_rb,2.74514e-06_rb,2.81512e-06_rb/) + totplnk(51:100, 5) = (/ & + 2.88621e-06_rb,2.95841e-06_rb,3.03172e-06_rb,3.10615e-06_rb,3.18170e-06_rb, & + 3.25838e-06_rb,3.33618e-06_rb,3.41511e-06_rb,3.49518e-06_rb,3.57639e-06_rb, & + 3.65873e-06_rb,3.74221e-06_rb,3.82684e-06_rb,3.91262e-06_rb,3.99955e-06_rb, & + 4.08763e-06_rb,4.17686e-06_rb,4.26725e-06_rb,4.35880e-06_rb,4.45150e-06_rb, & + 4.54537e-06_rb,4.64039e-06_rb,4.73659e-06_rb,4.83394e-06_rb,4.93246e-06_rb, & + 5.03215e-06_rb,5.13301e-06_rb,5.23504e-06_rb,5.33823e-06_rb,5.44260e-06_rb, & + 5.54814e-06_rb,5.65484e-06_rb,5.76272e-06_rb,5.87177e-06_rb,5.98199e-06_rb, & + 6.09339e-06_rb,6.20596e-06_rb,6.31969e-06_rb,6.43460e-06_rb,6.55068e-06_rb, & + 6.66793e-06_rb,6.78636e-06_rb,6.90595e-06_rb,7.02670e-06_rb,7.14863e-06_rb, & + 7.27173e-06_rb,7.39599e-06_rb,7.52142e-06_rb,7.64802e-06_rb,7.77577e-06_rb/) + totplnk(101:150, 5) = (/ & + 7.90469e-06_rb,8.03477e-06_rb,8.16601e-06_rb,8.29841e-06_rb,8.43198e-06_rb, & + 8.56669e-06_rb,8.70256e-06_rb,8.83957e-06_rb,8.97775e-06_rb,9.11706e-06_rb, & + 9.25753e-06_rb,9.39915e-06_rb,9.54190e-06_rb,9.68580e-06_rb,9.83085e-06_rb, & + 9.97704e-06_rb,1.01243e-05_rb,1.02728e-05_rb,1.04224e-05_rb,1.05731e-05_rb, & + 1.07249e-05_rb,1.08779e-05_rb,1.10320e-05_rb,1.11872e-05_rb,1.13435e-05_rb, & + 1.15009e-05_rb,1.16595e-05_rb,1.18191e-05_rb,1.19799e-05_rb,1.21418e-05_rb, & + 1.23048e-05_rb,1.24688e-05_rb,1.26340e-05_rb,1.28003e-05_rb,1.29676e-05_rb, & + 1.31361e-05_rb,1.33056e-05_rb,1.34762e-05_rb,1.36479e-05_rb,1.38207e-05_rb, & + 1.39945e-05_rb,1.41694e-05_rb,1.43454e-05_rb,1.45225e-05_rb,1.47006e-05_rb, & + 1.48797e-05_rb,1.50600e-05_rb,1.52413e-05_rb,1.54236e-05_rb,1.56070e-05_rb/) + totplnk(151:181, 5) = (/ & + 1.57914e-05_rb,1.59768e-05_rb,1.61633e-05_rb,1.63509e-05_rb,1.65394e-05_rb, & + 1.67290e-05_rb,1.69197e-05_rb,1.71113e-05_rb,1.73040e-05_rb,1.74976e-05_rb, & + 1.76923e-05_rb,1.78880e-05_rb,1.80847e-05_rb,1.82824e-05_rb,1.84811e-05_rb, & + 1.86808e-05_rb,1.88814e-05_rb,1.90831e-05_rb,1.92857e-05_rb,1.94894e-05_rb, & + 1.96940e-05_rb,1.98996e-05_rb,2.01061e-05_rb,2.03136e-05_rb,2.05221e-05_rb, & + 2.07316e-05_rb,2.09420e-05_rb,2.11533e-05_rb,2.13657e-05_rb,2.15789e-05_rb, & + 2.17931e-05_rb/) + totplnk(1:50, 6) = (/ & + 2.73493e-07_rb,2.87408e-07_rb,3.01848e-07_rb,3.16825e-07_rb,3.32352e-07_rb, & + 3.48439e-07_rb,3.65100e-07_rb,3.82346e-07_rb,4.00189e-07_rb,4.18641e-07_rb, & + 4.37715e-07_rb,4.57422e-07_rb,4.77774e-07_rb,4.98784e-07_rb,5.20464e-07_rb, & + 5.42824e-07_rb,5.65879e-07_rb,5.89638e-07_rb,6.14115e-07_rb,6.39320e-07_rb, & + 6.65266e-07_rb,6.91965e-07_rb,7.19427e-07_rb,7.47666e-07_rb,7.76691e-07_rb, & + 8.06516e-07_rb,8.37151e-07_rb,8.68607e-07_rb,9.00896e-07_rb,9.34029e-07_rb, & + 9.68018e-07_rb,1.00287e-06_rb,1.03860e-06_rb,1.07522e-06_rb,1.11274e-06_rb, & + 1.15117e-06_rb,1.19052e-06_rb,1.23079e-06_rb,1.27201e-06_rb,1.31418e-06_rb, & + 1.35731e-06_rb,1.40141e-06_rb,1.44650e-06_rb,1.49257e-06_rb,1.53965e-06_rb, & + 1.58773e-06_rb,1.63684e-06_rb,1.68697e-06_rb,1.73815e-06_rb,1.79037e-06_rb/) + totplnk(51:100, 6) = (/ & + 1.84365e-06_rb,1.89799e-06_rb,1.95341e-06_rb,2.00991e-06_rb,2.06750e-06_rb, & + 2.12619e-06_rb,2.18599e-06_rb,2.24691e-06_rb,2.30895e-06_rb,2.37212e-06_rb, & + 2.43643e-06_rb,2.50189e-06_rb,2.56851e-06_rb,2.63628e-06_rb,2.70523e-06_rb, & + 2.77536e-06_rb,2.84666e-06_rb,2.91916e-06_rb,2.99286e-06_rb,3.06776e-06_rb, & + 3.14387e-06_rb,3.22120e-06_rb,3.29975e-06_rb,3.37953e-06_rb,3.46054e-06_rb, & + 3.54280e-06_rb,3.62630e-06_rb,3.71105e-06_rb,3.79707e-06_rb,3.88434e-06_rb, & + 3.97288e-06_rb,4.06270e-06_rb,4.15380e-06_rb,4.24617e-06_rb,4.33984e-06_rb, & + 4.43479e-06_rb,4.53104e-06_rb,4.62860e-06_rb,4.72746e-06_rb,4.82763e-06_rb, & + 4.92911e-06_rb,5.03191e-06_rb,5.13603e-06_rb,5.24147e-06_rb,5.34824e-06_rb, & + 5.45634e-06_rb,5.56578e-06_rb,5.67656e-06_rb,5.78867e-06_rb,5.90213e-06_rb/) + totplnk(101:150, 6) = (/ & + 6.01694e-06_rb,6.13309e-06_rb,6.25060e-06_rb,6.36947e-06_rb,6.48968e-06_rb, & + 6.61126e-06_rb,6.73420e-06_rb,6.85850e-06_rb,6.98417e-06_rb,7.11120e-06_rb, & + 7.23961e-06_rb,7.36938e-06_rb,7.50053e-06_rb,7.63305e-06_rb,7.76694e-06_rb, & + 7.90221e-06_rb,8.03887e-06_rb,8.17690e-06_rb,8.31632e-06_rb,8.45710e-06_rb, & + 8.59928e-06_rb,8.74282e-06_rb,8.88776e-06_rb,9.03409e-06_rb,9.18179e-06_rb, & + 9.33088e-06_rb,9.48136e-06_rb,9.63323e-06_rb,9.78648e-06_rb,9.94111e-06_rb, & + 1.00971e-05_rb,1.02545e-05_rb,1.04133e-05_rb,1.05735e-05_rb,1.07351e-05_rb, & + 1.08980e-05_rb,1.10624e-05_rb,1.12281e-05_rb,1.13952e-05_rb,1.15637e-05_rb, & + 1.17335e-05_rb,1.19048e-05_rb,1.20774e-05_rb,1.22514e-05_rb,1.24268e-05_rb, & + 1.26036e-05_rb,1.27817e-05_rb,1.29612e-05_rb,1.31421e-05_rb,1.33244e-05_rb/) + totplnk(151:181, 6) = (/ & + 1.35080e-05_rb,1.36930e-05_rb,1.38794e-05_rb,1.40672e-05_rb,1.42563e-05_rb, & + 1.44468e-05_rb,1.46386e-05_rb,1.48318e-05_rb,1.50264e-05_rb,1.52223e-05_rb, & + 1.54196e-05_rb,1.56182e-05_rb,1.58182e-05_rb,1.60196e-05_rb,1.62223e-05_rb, & + 1.64263e-05_rb,1.66317e-05_rb,1.68384e-05_rb,1.70465e-05_rb,1.72559e-05_rb, & + 1.74666e-05_rb,1.76787e-05_rb,1.78921e-05_rb,1.81069e-05_rb,1.83230e-05_rb, & + 1.85404e-05_rb,1.87591e-05_rb,1.89791e-05_rb,1.92005e-05_rb,1.94232e-05_rb, & + 1.96471e-05_rb/) + totplnk(1:50, 7) = (/ & + 1.25349e-07_rb,1.32735e-07_rb,1.40458e-07_rb,1.48527e-07_rb,1.56954e-07_rb, & + 1.65748e-07_rb,1.74920e-07_rb,1.84481e-07_rb,1.94443e-07_rb,2.04814e-07_rb, & + 2.15608e-07_rb,2.26835e-07_rb,2.38507e-07_rb,2.50634e-07_rb,2.63229e-07_rb, & + 2.76301e-07_rb,2.89864e-07_rb,3.03930e-07_rb,3.18508e-07_rb,3.33612e-07_rb, & + 3.49253e-07_rb,3.65443e-07_rb,3.82195e-07_rb,3.99519e-07_rb,4.17428e-07_rb, & + 4.35934e-07_rb,4.55050e-07_rb,4.74785e-07_rb,4.95155e-07_rb,5.16170e-07_rb, & + 5.37844e-07_rb,5.60186e-07_rb,5.83211e-07_rb,6.06929e-07_rb,6.31355e-07_rb, & + 6.56498e-07_rb,6.82373e-07_rb,7.08990e-07_rb,7.36362e-07_rb,7.64501e-07_rb, & + 7.93420e-07_rb,8.23130e-07_rb,8.53643e-07_rb,8.84971e-07_rb,9.17128e-07_rb, & + 9.50123e-07_rb,9.83969e-07_rb,1.01868e-06_rb,1.05426e-06_rb,1.09073e-06_rb/) + totplnk(51:100, 7) = (/ & + 1.12810e-06_rb,1.16638e-06_rb,1.20558e-06_rb,1.24572e-06_rb,1.28680e-06_rb, & + 1.32883e-06_rb,1.37183e-06_rb,1.41581e-06_rb,1.46078e-06_rb,1.50675e-06_rb, & + 1.55374e-06_rb,1.60174e-06_rb,1.65078e-06_rb,1.70087e-06_rb,1.75200e-06_rb, & + 1.80421e-06_rb,1.85749e-06_rb,1.91186e-06_rb,1.96732e-06_rb,2.02389e-06_rb, & + 2.08159e-06_rb,2.14040e-06_rb,2.20035e-06_rb,2.26146e-06_rb,2.32372e-06_rb, & + 2.38714e-06_rb,2.45174e-06_rb,2.51753e-06_rb,2.58451e-06_rb,2.65270e-06_rb, & + 2.72210e-06_rb,2.79272e-06_rb,2.86457e-06_rb,2.93767e-06_rb,3.01201e-06_rb, & + 3.08761e-06_rb,3.16448e-06_rb,3.24261e-06_rb,3.32204e-06_rb,3.40275e-06_rb, & + 3.48476e-06_rb,3.56808e-06_rb,3.65271e-06_rb,3.73866e-06_rb,3.82595e-06_rb, & + 3.91456e-06_rb,4.00453e-06_rb,4.09584e-06_rb,4.18851e-06_rb,4.28254e-06_rb/) + totplnk(101:150, 7) = (/ & + 4.37796e-06_rb,4.47475e-06_rb,4.57293e-06_rb,4.67249e-06_rb,4.77346e-06_rb, & + 4.87583e-06_rb,4.97961e-06_rb,5.08481e-06_rb,5.19143e-06_rb,5.29948e-06_rb, & + 5.40896e-06_rb,5.51989e-06_rb,5.63226e-06_rb,5.74608e-06_rb,5.86136e-06_rb, & + 5.97810e-06_rb,6.09631e-06_rb,6.21597e-06_rb,6.33713e-06_rb,6.45976e-06_rb, & + 6.58388e-06_rb,6.70950e-06_rb,6.83661e-06_rb,6.96521e-06_rb,7.09531e-06_rb, & + 7.22692e-06_rb,7.36005e-06_rb,7.49468e-06_rb,7.63084e-06_rb,7.76851e-06_rb, & + 7.90773e-06_rb,8.04846e-06_rb,8.19072e-06_rb,8.33452e-06_rb,8.47985e-06_rb, & + 8.62674e-06_rb,8.77517e-06_rb,8.92514e-06_rb,9.07666e-06_rb,9.22975e-06_rb, & + 9.38437e-06_rb,9.54057e-06_rb,9.69832e-06_rb,9.85762e-06_rb,1.00185e-05_rb, & + 1.01810e-05_rb,1.03450e-05_rb,1.05106e-05_rb,1.06777e-05_rb,1.08465e-05_rb/) + totplnk(151:181, 7) = (/ & + 1.10168e-05_rb,1.11887e-05_rb,1.13621e-05_rb,1.15372e-05_rb,1.17138e-05_rb, & + 1.18920e-05_rb,1.20718e-05_rb,1.22532e-05_rb,1.24362e-05_rb,1.26207e-05_rb, & + 1.28069e-05_rb,1.29946e-05_rb,1.31839e-05_rb,1.33749e-05_rb,1.35674e-05_rb, & + 1.37615e-05_rb,1.39572e-05_rb,1.41544e-05_rb,1.43533e-05_rb,1.45538e-05_rb, & + 1.47558e-05_rb,1.49595e-05_rb,1.51647e-05_rb,1.53716e-05_rb,1.55800e-05_rb, & + 1.57900e-05_rb,1.60017e-05_rb,1.62149e-05_rb,1.64296e-05_rb,1.66460e-05_rb, & + 1.68640e-05_rb/) + totplnk(1:50, 8) = (/ & + 6.74445e-08_rb,7.18176e-08_rb,7.64153e-08_rb,8.12456e-08_rb,8.63170e-08_rb, & + 9.16378e-08_rb,9.72168e-08_rb,1.03063e-07_rb,1.09184e-07_rb,1.15591e-07_rb, & + 1.22292e-07_rb,1.29296e-07_rb,1.36613e-07_rb,1.44253e-07_rb,1.52226e-07_rb, & + 1.60540e-07_rb,1.69207e-07_rb,1.78236e-07_rb,1.87637e-07_rb,1.97421e-07_rb, & + 2.07599e-07_rb,2.18181e-07_rb,2.29177e-07_rb,2.40598e-07_rb,2.52456e-07_rb, & + 2.64761e-07_rb,2.77523e-07_rb,2.90755e-07_rb,3.04468e-07_rb,3.18673e-07_rb, & + 3.33381e-07_rb,3.48603e-07_rb,3.64352e-07_rb,3.80638e-07_rb,3.97474e-07_rb, & + 4.14871e-07_rb,4.32841e-07_rb,4.51395e-07_rb,4.70547e-07_rb,4.90306e-07_rb, & + 5.10687e-07_rb,5.31699e-07_rb,5.53357e-07_rb,5.75670e-07_rb,5.98652e-07_rb, & + 6.22315e-07_rb,6.46672e-07_rb,6.71731e-07_rb,6.97511e-07_rb,7.24018e-07_rb/) + totplnk(51:100, 8) = (/ & + 7.51266e-07_rb,7.79269e-07_rb,8.08038e-07_rb,8.37584e-07_rb,8.67922e-07_rb, & + 8.99061e-07_rb,9.31016e-07_rb,9.63797e-07_rb,9.97417e-07_rb,1.03189e-06_rb, & + 1.06722e-06_rb,1.10343e-06_rb,1.14053e-06_rb,1.17853e-06_rb,1.21743e-06_rb, & + 1.25726e-06_rb,1.29803e-06_rb,1.33974e-06_rb,1.38241e-06_rb,1.42606e-06_rb, & + 1.47068e-06_rb,1.51630e-06_rb,1.56293e-06_rb,1.61056e-06_rb,1.65924e-06_rb, & + 1.70894e-06_rb,1.75971e-06_rb,1.81153e-06_rb,1.86443e-06_rb,1.91841e-06_rb, & + 1.97350e-06_rb,2.02968e-06_rb,2.08699e-06_rb,2.14543e-06_rb,2.20500e-06_rb, & + 2.26573e-06_rb,2.32762e-06_rb,2.39068e-06_rb,2.45492e-06_rb,2.52036e-06_rb, & + 2.58700e-06_rb,2.65485e-06_rb,2.72393e-06_rb,2.79424e-06_rb,2.86580e-06_rb, & + 2.93861e-06_rb,3.01269e-06_rb,3.08803e-06_rb,3.16467e-06_rb,3.24259e-06_rb/) + totplnk(101:150, 8) = (/ & + 3.32181e-06_rb,3.40235e-06_rb,3.48420e-06_rb,3.56739e-06_rb,3.65192e-06_rb, & + 3.73779e-06_rb,3.82502e-06_rb,3.91362e-06_rb,4.00359e-06_rb,4.09494e-06_rb, & + 4.18768e-06_rb,4.28182e-06_rb,4.37737e-06_rb,4.47434e-06_rb,4.57273e-06_rb, & + 4.67254e-06_rb,4.77380e-06_rb,4.87651e-06_rb,4.98067e-06_rb,5.08630e-06_rb, & + 5.19339e-06_rb,5.30196e-06_rb,5.41201e-06_rb,5.52356e-06_rb,5.63660e-06_rb, & + 5.75116e-06_rb,5.86722e-06_rb,5.98479e-06_rb,6.10390e-06_rb,6.22453e-06_rb, & + 6.34669e-06_rb,6.47042e-06_rb,6.59569e-06_rb,6.72252e-06_rb,6.85090e-06_rb, & + 6.98085e-06_rb,7.11238e-06_rb,7.24549e-06_rb,7.38019e-06_rb,7.51646e-06_rb, & + 7.65434e-06_rb,7.79382e-06_rb,7.93490e-06_rb,8.07760e-06_rb,8.22192e-06_rb, & + 8.36784e-06_rb,8.51540e-06_rb,8.66459e-06_rb,8.81542e-06_rb,8.96786e-06_rb/) + totplnk(151:181, 8) = (/ & + 9.12197e-06_rb,9.27772e-06_rb,9.43513e-06_rb,9.59419e-06_rb,9.75490e-06_rb, & + 9.91728e-06_rb,1.00813e-05_rb,1.02471e-05_rb,1.04144e-05_rb,1.05835e-05_rb, & + 1.07543e-05_rb,1.09267e-05_rb,1.11008e-05_rb,1.12766e-05_rb,1.14541e-05_rb, & + 1.16333e-05_rb,1.18142e-05_rb,1.19969e-05_rb,1.21812e-05_rb,1.23672e-05_rb, & + 1.25549e-05_rb,1.27443e-05_rb,1.29355e-05_rb,1.31284e-05_rb,1.33229e-05_rb, & + 1.35193e-05_rb,1.37173e-05_rb,1.39170e-05_rb,1.41185e-05_rb,1.43217e-05_rb, & + 1.45267e-05_rb/) + totplnk(1:50, 9) = (/ & + 2.61522e-08_rb,2.80613e-08_rb,3.00838e-08_rb,3.22250e-08_rb,3.44899e-08_rb, & + 3.68841e-08_rb,3.94129e-08_rb,4.20820e-08_rb,4.48973e-08_rb,4.78646e-08_rb, & + 5.09901e-08_rb,5.42799e-08_rb,5.77405e-08_rb,6.13784e-08_rb,6.52001e-08_rb, & + 6.92126e-08_rb,7.34227e-08_rb,7.78375e-08_rb,8.24643e-08_rb,8.73103e-08_rb, & + 9.23832e-08_rb,9.76905e-08_rb,1.03240e-07_rb,1.09039e-07_rb,1.15097e-07_rb, & + 1.21421e-07_rb,1.28020e-07_rb,1.34902e-07_rb,1.42075e-07_rb,1.49548e-07_rb, & + 1.57331e-07_rb,1.65432e-07_rb,1.73860e-07_rb,1.82624e-07_rb,1.91734e-07_rb, & + 2.01198e-07_rb,2.11028e-07_rb,2.21231e-07_rb,2.31818e-07_rb,2.42799e-07_rb, & + 2.54184e-07_rb,2.65983e-07_rb,2.78205e-07_rb,2.90862e-07_rb,3.03963e-07_rb, & + 3.17519e-07_rb,3.31541e-07_rb,3.46039e-07_rb,3.61024e-07_rb,3.76507e-07_rb/) + totplnk(51:100, 9) = (/ & + 3.92498e-07_rb,4.09008e-07_rb,4.26050e-07_rb,4.43633e-07_rb,4.61769e-07_rb, & + 4.80469e-07_rb,4.99744e-07_rb,5.19606e-07_rb,5.40067e-07_rb,5.61136e-07_rb, & + 5.82828e-07_rb,6.05152e-07_rb,6.28120e-07_rb,6.51745e-07_rb,6.76038e-07_rb, & + 7.01010e-07_rb,7.26674e-07_rb,7.53041e-07_rb,7.80124e-07_rb,8.07933e-07_rb, & + 8.36482e-07_rb,8.65781e-07_rb,8.95845e-07_rb,9.26683e-07_rb,9.58308e-07_rb, & + 9.90732e-07_rb,1.02397e-06_rb,1.05803e-06_rb,1.09292e-06_rb,1.12866e-06_rb, & + 1.16526e-06_rb,1.20274e-06_rb,1.24109e-06_rb,1.28034e-06_rb,1.32050e-06_rb, & + 1.36158e-06_rb,1.40359e-06_rb,1.44655e-06_rb,1.49046e-06_rb,1.53534e-06_rb, & + 1.58120e-06_rb,1.62805e-06_rb,1.67591e-06_rb,1.72478e-06_rb,1.77468e-06_rb, & + 1.82561e-06_rb,1.87760e-06_rb,1.93066e-06_rb,1.98479e-06_rb,2.04000e-06_rb/) + totplnk(101:150, 9) = (/ & + 2.09631e-06_rb,2.15373e-06_rb,2.21228e-06_rb,2.27196e-06_rb,2.33278e-06_rb, & + 2.39475e-06_rb,2.45790e-06_rb,2.52222e-06_rb,2.58773e-06_rb,2.65445e-06_rb, & + 2.72238e-06_rb,2.79152e-06_rb,2.86191e-06_rb,2.93354e-06_rb,3.00643e-06_rb, & + 3.08058e-06_rb,3.15601e-06_rb,3.23273e-06_rb,3.31075e-06_rb,3.39009e-06_rb, & + 3.47074e-06_rb,3.55272e-06_rb,3.63605e-06_rb,3.72072e-06_rb,3.80676e-06_rb, & + 3.89417e-06_rb,3.98297e-06_rb,4.07315e-06_rb,4.16474e-06_rb,4.25774e-06_rb, & + 4.35217e-06_rb,4.44802e-06_rb,4.54532e-06_rb,4.64406e-06_rb,4.74428e-06_rb, & + 4.84595e-06_rb,4.94911e-06_rb,5.05376e-06_rb,5.15990e-06_rb,5.26755e-06_rb, & + 5.37671e-06_rb,5.48741e-06_rb,5.59963e-06_rb,5.71340e-06_rb,5.82871e-06_rb, & + 5.94559e-06_rb,6.06403e-06_rb,6.18404e-06_rb,6.30565e-06_rb,6.42885e-06_rb/) + totplnk(151:181, 9) = (/ & + 6.55364e-06_rb,6.68004e-06_rb,6.80806e-06_rb,6.93771e-06_rb,7.06898e-06_rb, & + 7.20190e-06_rb,7.33646e-06_rb,7.47267e-06_rb,7.61056e-06_rb,7.75010e-06_rb, & + 7.89133e-06_rb,8.03423e-06_rb,8.17884e-06_rb,8.32514e-06_rb,8.47314e-06_rb, & + 8.62284e-06_rb,8.77427e-06_rb,8.92743e-06_rb,9.08231e-06_rb,9.23893e-06_rb, & + 9.39729e-06_rb,9.55741e-06_rb,9.71927e-06_rb,9.88291e-06_rb,1.00483e-05_rb, & + 1.02155e-05_rb,1.03844e-05_rb,1.05552e-05_rb,1.07277e-05_rb,1.09020e-05_rb, & + 1.10781e-05_rb/) + totplnk(1:50,10) = (/ & + 8.89300e-09_rb,9.63263e-09_rb,1.04235e-08_rb,1.12685e-08_rb,1.21703e-08_rb, & + 1.31321e-08_rb,1.41570e-08_rb,1.52482e-08_rb,1.64090e-08_rb,1.76428e-08_rb, & + 1.89533e-08_rb,2.03441e-08_rb,2.18190e-08_rb,2.33820e-08_rb,2.50370e-08_rb, & + 2.67884e-08_rb,2.86402e-08_rb,3.05969e-08_rb,3.26632e-08_rb,3.48436e-08_rb, & + 3.71429e-08_rb,3.95660e-08_rb,4.21179e-08_rb,4.48040e-08_rb,4.76294e-08_rb, & + 5.05996e-08_rb,5.37201e-08_rb,5.69966e-08_rb,6.04349e-08_rb,6.40411e-08_rb, & + 6.78211e-08_rb,7.17812e-08_rb,7.59276e-08_rb,8.02670e-08_rb,8.48059e-08_rb, & + 8.95508e-08_rb,9.45090e-08_rb,9.96873e-08_rb,1.05093e-07_rb,1.10733e-07_rb, & + 1.16614e-07_rb,1.22745e-07_rb,1.29133e-07_rb,1.35786e-07_rb,1.42711e-07_rb, & + 1.49916e-07_rb,1.57410e-07_rb,1.65202e-07_rb,1.73298e-07_rb,1.81709e-07_rb/) + totplnk(51:100,10) = (/ & + 1.90441e-07_rb,1.99505e-07_rb,2.08908e-07_rb,2.18660e-07_rb,2.28770e-07_rb, & + 2.39247e-07_rb,2.50101e-07_rb,2.61340e-07_rb,2.72974e-07_rb,2.85013e-07_rb, & + 2.97467e-07_rb,3.10345e-07_rb,3.23657e-07_rb,3.37413e-07_rb,3.51623e-07_rb, & + 3.66298e-07_rb,3.81448e-07_rb,3.97082e-07_rb,4.13212e-07_rb,4.29848e-07_rb, & + 4.47000e-07_rb,4.64680e-07_rb,4.82898e-07_rb,5.01664e-07_rb,5.20991e-07_rb, & + 5.40888e-07_rb,5.61369e-07_rb,5.82440e-07_rb,6.04118e-07_rb,6.26410e-07_rb, & + 6.49329e-07_rb,6.72887e-07_rb,6.97095e-07_rb,7.21964e-07_rb,7.47506e-07_rb, & + 7.73732e-07_rb,8.00655e-07_rb,8.28287e-07_rb,8.56635e-07_rb,8.85717e-07_rb, & + 9.15542e-07_rb,9.46122e-07_rb,9.77469e-07_rb,1.00960e-06_rb,1.04251e-06_rb, & + 1.07623e-06_rb,1.11077e-06_rb,1.14613e-06_rb,1.18233e-06_rb,1.21939e-06_rb/) + totplnk(101:150,10) = (/ & + 1.25730e-06_rb,1.29610e-06_rb,1.33578e-06_rb,1.37636e-06_rb,1.41785e-06_rb, & + 1.46027e-06_rb,1.50362e-06_rb,1.54792e-06_rb,1.59319e-06_rb,1.63942e-06_rb, & + 1.68665e-06_rb,1.73487e-06_rb,1.78410e-06_rb,1.83435e-06_rb,1.88564e-06_rb, & + 1.93797e-06_rb,1.99136e-06_rb,2.04582e-06_rb,2.10137e-06_rb,2.15801e-06_rb, & + 2.21576e-06_rb,2.27463e-06_rb,2.33462e-06_rb,2.39577e-06_rb,2.45806e-06_rb, & + 2.52153e-06_rb,2.58617e-06_rb,2.65201e-06_rb,2.71905e-06_rb,2.78730e-06_rb, & + 2.85678e-06_rb,2.92749e-06_rb,2.99946e-06_rb,3.07269e-06_rb,3.14720e-06_rb, & + 3.22299e-06_rb,3.30007e-06_rb,3.37847e-06_rb,3.45818e-06_rb,3.53923e-06_rb, & + 3.62161e-06_rb,3.70535e-06_rb,3.79046e-06_rb,3.87695e-06_rb,3.96481e-06_rb, & + 4.05409e-06_rb,4.14477e-06_rb,4.23687e-06_rb,4.33040e-06_rb,4.42538e-06_rb/) + totplnk(151:181,10) = (/ & + 4.52180e-06_rb,4.61969e-06_rb,4.71905e-06_rb,4.81991e-06_rb,4.92226e-06_rb, & + 5.02611e-06_rb,5.13148e-06_rb,5.23839e-06_rb,5.34681e-06_rb,5.45681e-06_rb, & + 5.56835e-06_rb,5.68146e-06_rb,5.79614e-06_rb,5.91242e-06_rb,6.03030e-06_rb, & + 6.14978e-06_rb,6.27088e-06_rb,6.39360e-06_rb,6.51798e-06_rb,6.64398e-06_rb, & + 6.77165e-06_rb,6.90099e-06_rb,7.03198e-06_rb,7.16468e-06_rb,7.29906e-06_rb, & + 7.43514e-06_rb,7.57294e-06_rb,7.71244e-06_rb,7.85369e-06_rb,7.99666e-06_rb, & + 8.14138e-06_rb/) + totplnk(1:50,11) = (/ & + 2.53767e-09_rb,2.77242e-09_rb,3.02564e-09_rb,3.29851e-09_rb,3.59228e-09_rb, & + 3.90825e-09_rb,4.24777e-09_rb,4.61227e-09_rb,5.00322e-09_rb,5.42219e-09_rb, & + 5.87080e-09_rb,6.35072e-09_rb,6.86370e-09_rb,7.41159e-09_rb,7.99628e-09_rb, & + 8.61974e-09_rb,9.28404e-09_rb,9.99130e-09_rb,1.07437e-08_rb,1.15436e-08_rb, & + 1.23933e-08_rb,1.32953e-08_rb,1.42522e-08_rb,1.52665e-08_rb,1.63410e-08_rb, & + 1.74786e-08_rb,1.86820e-08_rb,1.99542e-08_rb,2.12985e-08_rb,2.27179e-08_rb, & + 2.42158e-08_rb,2.57954e-08_rb,2.74604e-08_rb,2.92141e-08_rb,3.10604e-08_rb, & + 3.30029e-08_rb,3.50457e-08_rb,3.71925e-08_rb,3.94476e-08_rb,4.18149e-08_rb, & + 4.42991e-08_rb,4.69043e-08_rb,4.96352e-08_rb,5.24961e-08_rb,5.54921e-08_rb, & + 5.86277e-08_rb,6.19081e-08_rb,6.53381e-08_rb,6.89231e-08_rb,7.26681e-08_rb/) + totplnk(51:100,11) = (/ & + 7.65788e-08_rb,8.06604e-08_rb,8.49187e-08_rb,8.93591e-08_rb,9.39879e-08_rb, & + 9.88106e-08_rb,1.03834e-07_rb,1.09063e-07_rb,1.14504e-07_rb,1.20165e-07_rb, & + 1.26051e-07_rb,1.32169e-07_rb,1.38525e-07_rb,1.45128e-07_rb,1.51982e-07_rb, & + 1.59096e-07_rb,1.66477e-07_rb,1.74132e-07_rb,1.82068e-07_rb,1.90292e-07_rb, & + 1.98813e-07_rb,2.07638e-07_rb,2.16775e-07_rb,2.26231e-07_rb,2.36015e-07_rb, & + 2.46135e-07_rb,2.56599e-07_rb,2.67415e-07_rb,2.78592e-07_rb,2.90137e-07_rb, & + 3.02061e-07_rb,3.14371e-07_rb,3.27077e-07_rb,3.40186e-07_rb,3.53710e-07_rb, & + 3.67655e-07_rb,3.82031e-07_rb,3.96848e-07_rb,4.12116e-07_rb,4.27842e-07_rb, & + 4.44039e-07_rb,4.60713e-07_rb,4.77876e-07_rb,4.95537e-07_rb,5.13706e-07_rb, & + 5.32392e-07_rb,5.51608e-07_rb,5.71360e-07_rb,5.91662e-07_rb,6.12521e-07_rb/) + totplnk(101:150,11) = (/ & + 6.33950e-07_rb,6.55958e-07_rb,6.78556e-07_rb,7.01753e-07_rb,7.25562e-07_rb, & + 7.49992e-07_rb,7.75055e-07_rb,8.00760e-07_rb,8.27120e-07_rb,8.54145e-07_rb, & + 8.81845e-07_rb,9.10233e-07_rb,9.39318e-07_rb,9.69113e-07_rb,9.99627e-07_rb, & + 1.03087e-06_rb,1.06286e-06_rb,1.09561e-06_rb,1.12912e-06_rb,1.16340e-06_rb, & + 1.19848e-06_rb,1.23435e-06_rb,1.27104e-06_rb,1.30855e-06_rb,1.34690e-06_rb, & + 1.38609e-06_rb,1.42614e-06_rb,1.46706e-06_rb,1.50886e-06_rb,1.55155e-06_rb, & + 1.59515e-06_rb,1.63967e-06_rb,1.68512e-06_rb,1.73150e-06_rb,1.77884e-06_rb, & + 1.82715e-06_rb,1.87643e-06_rb,1.92670e-06_rb,1.97797e-06_rb,2.03026e-06_rb, & + 2.08356e-06_rb,2.13791e-06_rb,2.19330e-06_rb,2.24975e-06_rb,2.30728e-06_rb, & + 2.36589e-06_rb,2.42560e-06_rb,2.48641e-06_rb,2.54835e-06_rb,2.61142e-06_rb/) + totplnk(151:181,11) = (/ & + 2.67563e-06_rb,2.74100e-06_rb,2.80754e-06_rb,2.87526e-06_rb,2.94417e-06_rb, & + 3.01429e-06_rb,3.08562e-06_rb,3.15819e-06_rb,3.23199e-06_rb,3.30704e-06_rb, & + 3.38336e-06_rb,3.46096e-06_rb,3.53984e-06_rb,3.62002e-06_rb,3.70151e-06_rb, & + 3.78433e-06_rb,3.86848e-06_rb,3.95399e-06_rb,4.04084e-06_rb,4.12907e-06_rb, & + 4.21868e-06_rb,4.30968e-06_rb,4.40209e-06_rb,4.49592e-06_rb,4.59117e-06_rb, & + 4.68786e-06_rb,4.78600e-06_rb,4.88561e-06_rb,4.98669e-06_rb,5.08926e-06_rb, & + 5.19332e-06_rb/) + totplnk(1:50,12) = (/ & + 2.73921e-10_rb,3.04500e-10_rb,3.38056e-10_rb,3.74835e-10_rb,4.15099e-10_rb, & + 4.59126e-10_rb,5.07214e-10_rb,5.59679e-10_rb,6.16857e-10_rb,6.79103e-10_rb, & + 7.46796e-10_rb,8.20335e-10_rb,9.00144e-10_rb,9.86671e-10_rb,1.08039e-09_rb, & + 1.18180e-09_rb,1.29142e-09_rb,1.40982e-09_rb,1.53757e-09_rb,1.67529e-09_rb, & + 1.82363e-09_rb,1.98327e-09_rb,2.15492e-09_rb,2.33932e-09_rb,2.53726e-09_rb, & + 2.74957e-09_rb,2.97710e-09_rb,3.22075e-09_rb,3.48145e-09_rb,3.76020e-09_rb, & + 4.05801e-09_rb,4.37595e-09_rb,4.71513e-09_rb,5.07672e-09_rb,5.46193e-09_rb, & + 5.87201e-09_rb,6.30827e-09_rb,6.77205e-09_rb,7.26480e-09_rb,7.78794e-09_rb, & + 8.34304e-09_rb,8.93163e-09_rb,9.55537e-09_rb,1.02159e-08_rb,1.09151e-08_rb, & + 1.16547e-08_rb,1.24365e-08_rb,1.32625e-08_rb,1.41348e-08_rb,1.50554e-08_rb/) + totplnk(51:100,12) = (/ & + 1.60264e-08_rb,1.70500e-08_rb,1.81285e-08_rb,1.92642e-08_rb,2.04596e-08_rb, & + 2.17171e-08_rb,2.30394e-08_rb,2.44289e-08_rb,2.58885e-08_rb,2.74209e-08_rb, & + 2.90290e-08_rb,3.07157e-08_rb,3.24841e-08_rb,3.43371e-08_rb,3.62782e-08_rb, & + 3.83103e-08_rb,4.04371e-08_rb,4.26617e-08_rb,4.49878e-08_rb,4.74190e-08_rb, & + 4.99589e-08_rb,5.26113e-08_rb,5.53801e-08_rb,5.82692e-08_rb,6.12826e-08_rb, & + 6.44245e-08_rb,6.76991e-08_rb,7.11105e-08_rb,7.46634e-08_rb,7.83621e-08_rb, & + 8.22112e-08_rb,8.62154e-08_rb,9.03795e-08_rb,9.47081e-08_rb,9.92066e-08_rb, & + 1.03879e-07_rb,1.08732e-07_rb,1.13770e-07_rb,1.18998e-07_rb,1.24422e-07_rb, & + 1.30048e-07_rb,1.35880e-07_rb,1.41924e-07_rb,1.48187e-07_rb,1.54675e-07_rb, & + 1.61392e-07_rb,1.68346e-07_rb,1.75543e-07_rb,1.82988e-07_rb,1.90688e-07_rb/) + totplnk(101:150,12) = (/ & + 1.98650e-07_rb,2.06880e-07_rb,2.15385e-07_rb,2.24172e-07_rb,2.33247e-07_rb, & + 2.42617e-07_rb,2.52289e-07_rb,2.62272e-07_rb,2.72571e-07_rb,2.83193e-07_rb, & + 2.94147e-07_rb,3.05440e-07_rb,3.17080e-07_rb,3.29074e-07_rb,3.41430e-07_rb, & + 3.54155e-07_rb,3.67259e-07_rb,3.80747e-07_rb,3.94631e-07_rb,4.08916e-07_rb, & + 4.23611e-07_rb,4.38725e-07_rb,4.54267e-07_rb,4.70245e-07_rb,4.86666e-07_rb, & + 5.03541e-07_rb,5.20879e-07_rb,5.38687e-07_rb,5.56975e-07_rb,5.75751e-07_rb, & + 5.95026e-07_rb,6.14808e-07_rb,6.35107e-07_rb,6.55932e-07_rb,6.77293e-07_rb, & + 6.99197e-07_rb,7.21656e-07_rb,7.44681e-07_rb,7.68278e-07_rb,7.92460e-07_rb, & + 8.17235e-07_rb,8.42614e-07_rb,8.68606e-07_rb,8.95223e-07_rb,9.22473e-07_rb, & + 9.50366e-07_rb,9.78915e-07_rb,1.00813e-06_rb,1.03802e-06_rb,1.06859e-06_rb/) + totplnk(151:181,12) = (/ & + 1.09986e-06_rb,1.13184e-06_rb,1.16453e-06_rb,1.19796e-06_rb,1.23212e-06_rb, & + 1.26703e-06_rb,1.30270e-06_rb,1.33915e-06_rb,1.37637e-06_rb,1.41440e-06_rb, & + 1.45322e-06_rb,1.49286e-06_rb,1.53333e-06_rb,1.57464e-06_rb,1.61679e-06_rb, & + 1.65981e-06_rb,1.70370e-06_rb,1.74847e-06_rb,1.79414e-06_rb,1.84071e-06_rb, & + 1.88821e-06_rb,1.93663e-06_rb,1.98599e-06_rb,2.03631e-06_rb,2.08759e-06_rb, & + 2.13985e-06_rb,2.19310e-06_rb,2.24734e-06_rb,2.30260e-06_rb,2.35888e-06_rb, & + 2.41619e-06_rb/) + totplnk(1:50,13) = (/ & + 4.53634e-11_rb,5.11435e-11_rb,5.75754e-11_rb,6.47222e-11_rb,7.26531e-11_rb, & + 8.14420e-11_rb,9.11690e-11_rb,1.01921e-10_rb,1.13790e-10_rb,1.26877e-10_rb, & + 1.41288e-10_rb,1.57140e-10_rb,1.74555e-10_rb,1.93665e-10_rb,2.14613e-10_rb, & + 2.37548e-10_rb,2.62633e-10_rb,2.90039e-10_rb,3.19948e-10_rb,3.52558e-10_rb, & + 3.88073e-10_rb,4.26716e-10_rb,4.68719e-10_rb,5.14331e-10_rb,5.63815e-10_rb, & + 6.17448e-10_rb,6.75526e-10_rb,7.38358e-10_rb,8.06277e-10_rb,8.79625e-10_rb, & + 9.58770e-10_rb,1.04410e-09_rb,1.13602e-09_rb,1.23495e-09_rb,1.34135e-09_rb, & + 1.45568e-09_rb,1.57845e-09_rb,1.71017e-09_rb,1.85139e-09_rb,2.00268e-09_rb, & + 2.16464e-09_rb,2.33789e-09_rb,2.52309e-09_rb,2.72093e-09_rb,2.93212e-09_rb, & + 3.15740e-09_rb,3.39757e-09_rb,3.65341e-09_rb,3.92579e-09_rb,4.21559e-09_rb/) + totplnk(51:100,13) = (/ & + 4.52372e-09_rb,4.85115e-09_rb,5.19886e-09_rb,5.56788e-09_rb,5.95928e-09_rb, & + 6.37419e-09_rb,6.81375e-09_rb,7.27917e-09_rb,7.77168e-09_rb,8.29256e-09_rb, & + 8.84317e-09_rb,9.42487e-09_rb,1.00391e-08_rb,1.06873e-08_rb,1.13710e-08_rb, & + 1.20919e-08_rb,1.28515e-08_rb,1.36514e-08_rb,1.44935e-08_rb,1.53796e-08_rb, & + 1.63114e-08_rb,1.72909e-08_rb,1.83201e-08_rb,1.94008e-08_rb,2.05354e-08_rb, & + 2.17258e-08_rb,2.29742e-08_rb,2.42830e-08_rb,2.56545e-08_rb,2.70910e-08_rb, & + 2.85950e-08_rb,3.01689e-08_rb,3.18155e-08_rb,3.35373e-08_rb,3.53372e-08_rb, & + 3.72177e-08_rb,3.91818e-08_rb,4.12325e-08_rb,4.33727e-08_rb,4.56056e-08_rb, & + 4.79342e-08_rb,5.03617e-08_rb,5.28915e-08_rb,5.55270e-08_rb,5.82715e-08_rb, & + 6.11286e-08_rb,6.41019e-08_rb,6.71951e-08_rb,7.04119e-08_rb,7.37560e-08_rb/) + totplnk(101:150,13) = (/ & + 7.72315e-08_rb,8.08424e-08_rb,8.45927e-08_rb,8.84866e-08_rb,9.25281e-08_rb, & + 9.67218e-08_rb,1.01072e-07_rb,1.05583e-07_rb,1.10260e-07_rb,1.15107e-07_rb, & + 1.20128e-07_rb,1.25330e-07_rb,1.30716e-07_rb,1.36291e-07_rb,1.42061e-07_rb, & + 1.48031e-07_rb,1.54206e-07_rb,1.60592e-07_rb,1.67192e-07_rb,1.74015e-07_rb, & + 1.81064e-07_rb,1.88345e-07_rb,1.95865e-07_rb,2.03628e-07_rb,2.11643e-07_rb, & + 2.19912e-07_rb,2.28443e-07_rb,2.37244e-07_rb,2.46318e-07_rb,2.55673e-07_rb, & + 2.65316e-07_rb,2.75252e-07_rb,2.85489e-07_rb,2.96033e-07_rb,3.06891e-07_rb, & + 3.18070e-07_rb,3.29576e-07_rb,3.41417e-07_rb,3.53600e-07_rb,3.66133e-07_rb, & + 3.79021e-07_rb,3.92274e-07_rb,4.05897e-07_rb,4.19899e-07_rb,4.34288e-07_rb, & + 4.49071e-07_rb,4.64255e-07_rb,4.79850e-07_rb,4.95863e-07_rb,5.12300e-07_rb/) + totplnk(151:181,13) = (/ & + 5.29172e-07_rb,5.46486e-07_rb,5.64250e-07_rb,5.82473e-07_rb,6.01164e-07_rb, & + 6.20329e-07_rb,6.39979e-07_rb,6.60122e-07_rb,6.80767e-07_rb,7.01922e-07_rb, & + 7.23596e-07_rb,7.45800e-07_rb,7.68539e-07_rb,7.91826e-07_rb,8.15669e-07_rb, & + 8.40076e-07_rb,8.65058e-07_rb,8.90623e-07_rb,9.16783e-07_rb,9.43544e-07_rb, & + 9.70917e-07_rb,9.98912e-07_rb,1.02754e-06_rb,1.05681e-06_rb,1.08673e-06_rb, & + 1.11731e-06_rb,1.14856e-06_rb,1.18050e-06_rb,1.21312e-06_rb,1.24645e-06_rb, & + 1.28049e-06_rb/) + totplnk(1:50,14) = (/ & + 1.40113e-11_rb,1.59358e-11_rb,1.80960e-11_rb,2.05171e-11_rb,2.32266e-11_rb, & + 2.62546e-11_rb,2.96335e-11_rb,3.33990e-11_rb,3.75896e-11_rb,4.22469e-11_rb, & + 4.74164e-11_rb,5.31466e-11_rb,5.94905e-11_rb,6.65054e-11_rb,7.42522e-11_rb, & + 8.27975e-11_rb,9.22122e-11_rb,1.02573e-10_rb,1.13961e-10_rb,1.26466e-10_rb, & + 1.40181e-10_rb,1.55206e-10_rb,1.71651e-10_rb,1.89630e-10_rb,2.09265e-10_rb, & + 2.30689e-10_rb,2.54040e-10_rb,2.79467e-10_rb,3.07128e-10_rb,3.37190e-10_rb, & + 3.69833e-10_rb,4.05243e-10_rb,4.43623e-10_rb,4.85183e-10_rb,5.30149e-10_rb, & + 5.78755e-10_rb,6.31255e-10_rb,6.87910e-10_rb,7.49002e-10_rb,8.14824e-10_rb, & + 8.85687e-10_rb,9.61914e-10_rb,1.04385e-09_rb,1.13186e-09_rb,1.22631e-09_rb, & + 1.32761e-09_rb,1.43617e-09_rb,1.55243e-09_rb,1.67686e-09_rb,1.80992e-09_rb/) + totplnk(51:100,14) = (/ & + 1.95212e-09_rb,2.10399e-09_rb,2.26607e-09_rb,2.43895e-09_rb,2.62321e-09_rb, & + 2.81949e-09_rb,3.02844e-09_rb,3.25073e-09_rb,3.48707e-09_rb,3.73820e-09_rb, & + 4.00490e-09_rb,4.28794e-09_rb,4.58819e-09_rb,4.90647e-09_rb,5.24371e-09_rb, & + 5.60081e-09_rb,5.97875e-09_rb,6.37854e-09_rb,6.80120e-09_rb,7.24782e-09_rb, & + 7.71950e-09_rb,8.21740e-09_rb,8.74271e-09_rb,9.29666e-09_rb,9.88054e-09_rb, & + 1.04956e-08_rb,1.11434e-08_rb,1.18251e-08_rb,1.25422e-08_rb,1.32964e-08_rb, & + 1.40890e-08_rb,1.49217e-08_rb,1.57961e-08_rb,1.67140e-08_rb,1.76771e-08_rb, & + 1.86870e-08_rb,1.97458e-08_rb,2.08553e-08_rb,2.20175e-08_rb,2.32342e-08_rb, & + 2.45077e-08_rb,2.58401e-08_rb,2.72334e-08_rb,2.86900e-08_rb,3.02122e-08_rb, & + 3.18021e-08_rb,3.34624e-08_rb,3.51954e-08_rb,3.70037e-08_rb,3.88899e-08_rb/) + totplnk(101:150,14) = (/ & + 4.08568e-08_rb,4.29068e-08_rb,4.50429e-08_rb,4.72678e-08_rb,4.95847e-08_rb, & + 5.19963e-08_rb,5.45058e-08_rb,5.71161e-08_rb,5.98309e-08_rb,6.26529e-08_rb, & + 6.55857e-08_rb,6.86327e-08_rb,7.17971e-08_rb,7.50829e-08_rb,7.84933e-08_rb, & + 8.20323e-08_rb,8.57035e-08_rb,8.95105e-08_rb,9.34579e-08_rb,9.75488e-08_rb, & + 1.01788e-07_rb,1.06179e-07_rb,1.10727e-07_rb,1.15434e-07_rb,1.20307e-07_rb, & + 1.25350e-07_rb,1.30566e-07_rb,1.35961e-07_rb,1.41539e-07_rb,1.47304e-07_rb, & + 1.53263e-07_rb,1.59419e-07_rb,1.65778e-07_rb,1.72345e-07_rb,1.79124e-07_rb, & + 1.86122e-07_rb,1.93343e-07_rb,2.00792e-07_rb,2.08476e-07_rb,2.16400e-07_rb, & + 2.24568e-07_rb,2.32988e-07_rb,2.41666e-07_rb,2.50605e-07_rb,2.59813e-07_rb, & + 2.69297e-07_rb,2.79060e-07_rb,2.89111e-07_rb,2.99455e-07_rb,3.10099e-07_rb/) + totplnk(151:181,14) = (/ & + 3.21049e-07_rb,3.32311e-07_rb,3.43893e-07_rb,3.55801e-07_rb,3.68041e-07_rb, & + 3.80621e-07_rb,3.93547e-07_rb,4.06826e-07_rb,4.20465e-07_rb,4.34473e-07_rb, & + 4.48856e-07_rb,4.63620e-07_rb,4.78774e-07_rb,4.94325e-07_rb,5.10280e-07_rb, & + 5.26648e-07_rb,5.43436e-07_rb,5.60652e-07_rb,5.78302e-07_rb,5.96397e-07_rb, & + 6.14943e-07_rb,6.33949e-07_rb,6.53421e-07_rb,6.73370e-07_rb,6.93803e-07_rb, & + 7.14731e-07_rb,7.36157e-07_rb,7.58095e-07_rb,7.80549e-07_rb,8.03533e-07_rb, & + 8.27050e-07_rb/) + totplnk(1:50,15) = (/ & + 3.90483e-12_rb,4.47999e-12_rb,5.13122e-12_rb,5.86739e-12_rb,6.69829e-12_rb, & + 7.63467e-12_rb,8.68833e-12_rb,9.87221e-12_rb,1.12005e-11_rb,1.26885e-11_rb, & + 1.43534e-11_rb,1.62134e-11_rb,1.82888e-11_rb,2.06012e-11_rb,2.31745e-11_rb, & + 2.60343e-11_rb,2.92087e-11_rb,3.27277e-11_rb,3.66242e-11_rb,4.09334e-11_rb, & + 4.56935e-11_rb,5.09455e-11_rb,5.67338e-11_rb,6.31057e-11_rb,7.01127e-11_rb, & + 7.78096e-11_rb,8.62554e-11_rb,9.55130e-11_rb,1.05651e-10_rb,1.16740e-10_rb, & + 1.28858e-10_rb,1.42089e-10_rb,1.56519e-10_rb,1.72243e-10_rb,1.89361e-10_rb, & + 2.07978e-10_rb,2.28209e-10_rb,2.50173e-10_rb,2.73999e-10_rb,2.99820e-10_rb, & + 3.27782e-10_rb,3.58034e-10_rb,3.90739e-10_rb,4.26067e-10_rb,4.64196e-10_rb, & + 5.05317e-10_rb,5.49631e-10_rb,5.97347e-10_rb,6.48689e-10_rb,7.03891e-10_rb/) + totplnk(51:100,15) = (/ & + 7.63201e-10_rb,8.26876e-10_rb,8.95192e-10_rb,9.68430e-10_rb,1.04690e-09_rb, & + 1.13091e-09_rb,1.22079e-09_rb,1.31689e-09_rb,1.41957e-09_rb,1.52922e-09_rb, & + 1.64623e-09_rb,1.77101e-09_rb,1.90401e-09_rb,2.04567e-09_rb,2.19647e-09_rb, & + 2.35690e-09_rb,2.52749e-09_rb,2.70875e-09_rb,2.90127e-09_rb,3.10560e-09_rb, & + 3.32238e-09_rb,3.55222e-09_rb,3.79578e-09_rb,4.05375e-09_rb,4.32682e-09_rb, & + 4.61574e-09_rb,4.92128e-09_rb,5.24420e-09_rb,5.58536e-09_rb,5.94558e-09_rb, & + 6.32575e-09_rb,6.72678e-09_rb,7.14964e-09_rb,7.59526e-09_rb,8.06470e-09_rb, & + 8.55897e-09_rb,9.07916e-09_rb,9.62638e-09_rb,1.02018e-08_rb,1.08066e-08_rb, & + 1.14420e-08_rb,1.21092e-08_rb,1.28097e-08_rb,1.35446e-08_rb,1.43155e-08_rb, & + 1.51237e-08_rb,1.59708e-08_rb,1.68581e-08_rb,1.77873e-08_rb,1.87599e-08_rb/) + totplnk(101:150,15) = (/ & + 1.97777e-08_rb,2.08423e-08_rb,2.19555e-08_rb,2.31190e-08_rb,2.43348e-08_rb, & + 2.56045e-08_rb,2.69302e-08_rb,2.83140e-08_rb,2.97578e-08_rb,3.12636e-08_rb, & + 3.28337e-08_rb,3.44702e-08_rb,3.61755e-08_rb,3.79516e-08_rb,3.98012e-08_rb, & + 4.17265e-08_rb,4.37300e-08_rb,4.58143e-08_rb,4.79819e-08_rb,5.02355e-08_rb, & + 5.25777e-08_rb,5.50114e-08_rb,5.75393e-08_rb,6.01644e-08_rb,6.28896e-08_rb, & + 6.57177e-08_rb,6.86521e-08_rb,7.16959e-08_rb,7.48520e-08_rb,7.81239e-08_rb, & + 8.15148e-08_rb,8.50282e-08_rb,8.86675e-08_rb,9.24362e-08_rb,9.63380e-08_rb, & + 1.00376e-07_rb,1.04555e-07_rb,1.08878e-07_rb,1.13349e-07_rb,1.17972e-07_rb, & + 1.22751e-07_rb,1.27690e-07_rb,1.32793e-07_rb,1.38064e-07_rb,1.43508e-07_rb, & + 1.49129e-07_rb,1.54931e-07_rb,1.60920e-07_rb,1.67099e-07_rb,1.73473e-07_rb/) + totplnk(151:181,15) = (/ & + 1.80046e-07_rb,1.86825e-07_rb,1.93812e-07_rb,2.01014e-07_rb,2.08436e-07_rb, & + 2.16082e-07_rb,2.23957e-07_rb,2.32067e-07_rb,2.40418e-07_rb,2.49013e-07_rb, & + 2.57860e-07_rb,2.66963e-07_rb,2.76328e-07_rb,2.85961e-07_rb,2.95868e-07_rb, & + 3.06053e-07_rb,3.16524e-07_rb,3.27286e-07_rb,3.38345e-07_rb,3.49707e-07_rb, & + 3.61379e-07_rb,3.73367e-07_rb,3.85676e-07_rb,3.98315e-07_rb,4.11287e-07_rb, & + 4.24602e-07_rb,4.38265e-07_rb,4.52283e-07_rb,4.66662e-07_rb,4.81410e-07_rb, & + 4.96535e-07_rb/) + totplnk(1:50,16) = (/ & + 0.28639e-12_rb,0.33349e-12_rb,0.38764e-12_rb,0.44977e-12_rb,0.52093e-12_rb, & + 0.60231e-12_rb,0.69522e-12_rb,0.80111e-12_rb,0.92163e-12_rb,0.10586e-11_rb, & + 0.12139e-11_rb,0.13899e-11_rb,0.15890e-11_rb,0.18138e-11_rb,0.20674e-11_rb, & + 0.23531e-11_rb,0.26744e-11_rb,0.30352e-11_rb,0.34401e-11_rb,0.38936e-11_rb, & + 0.44011e-11_rb,0.49681e-11_rb,0.56010e-11_rb,0.63065e-11_rb,0.70919e-11_rb, & + 0.79654e-11_rb,0.89357e-11_rb,0.10012e-10_rb,0.11205e-10_rb,0.12526e-10_rb, & + 0.13986e-10_rb,0.15600e-10_rb,0.17380e-10_rb,0.19342e-10_rb,0.21503e-10_rb, & + 0.23881e-10_rb,0.26494e-10_rb,0.29362e-10_rb,0.32509e-10_rb,0.35958e-10_rb, & + 0.39733e-10_rb,0.43863e-10_rb,0.48376e-10_rb,0.53303e-10_rb,0.58679e-10_rb, & + 0.64539e-10_rb,0.70920e-10_rb,0.77864e-10_rb,0.85413e-10_rb,0.93615e-10_rb/) + totplnk(51:100,16) = (/ & + 0.10252e-09_rb,0.11217e-09_rb,0.12264e-09_rb,0.13397e-09_rb,0.14624e-09_rb, & + 0.15950e-09_rb,0.17383e-09_rb,0.18930e-09_rb,0.20599e-09_rb,0.22399e-09_rb, & + 0.24339e-09_rb,0.26427e-09_rb,0.28674e-09_rb,0.31090e-09_rb,0.33686e-09_rb, & + 0.36474e-09_rb,0.39466e-09_rb,0.42676e-09_rb,0.46115e-09_rb,0.49800e-09_rb, & + 0.53744e-09_rb,0.57964e-09_rb,0.62476e-09_rb,0.67298e-09_rb,0.72448e-09_rb, & + 0.77945e-09_rb,0.83809e-09_rb,0.90062e-09_rb,0.96725e-09_rb,0.10382e-08_rb, & + 0.11138e-08_rb,0.11941e-08_rb,0.12796e-08_rb,0.13704e-08_rb,0.14669e-08_rb, & + 0.15694e-08_rb,0.16781e-08_rb,0.17934e-08_rb,0.19157e-08_rb,0.20453e-08_rb, & + 0.21825e-08_rb,0.23278e-08_rb,0.24815e-08_rb,0.26442e-08_rb,0.28161e-08_rb, & + 0.29978e-08_rb,0.31898e-08_rb,0.33925e-08_rb,0.36064e-08_rb,0.38321e-08_rb/) + totplnk(101:150,16) = (/ & + 0.40700e-08_rb,0.43209e-08_rb,0.45852e-08_rb,0.48636e-08_rb,0.51567e-08_rb, & + 0.54652e-08_rb,0.57897e-08_rb,0.61310e-08_rb,0.64897e-08_rb,0.68667e-08_rb, & + 0.72626e-08_rb,0.76784e-08_rb,0.81148e-08_rb,0.85727e-08_rb,0.90530e-08_rb, & + 0.95566e-08_rb,0.10084e-07_rb,0.10638e-07_rb,0.11217e-07_rb,0.11824e-07_rb, & + 0.12458e-07_rb,0.13123e-07_rb,0.13818e-07_rb,0.14545e-07_rb,0.15305e-07_rb, & + 0.16099e-07_rb,0.16928e-07_rb,0.17795e-07_rb,0.18699e-07_rb,0.19643e-07_rb, & + 0.20629e-07_rb,0.21656e-07_rb,0.22728e-07_rb,0.23845e-07_rb,0.25010e-07_rb, & + 0.26223e-07_rb,0.27487e-07_rb,0.28804e-07_rb,0.30174e-07_rb,0.31600e-07_rb, & + 0.33084e-07_rb,0.34628e-07_rb,0.36233e-07_rb,0.37902e-07_rb,0.39637e-07_rb, & + 0.41440e-07_rb,0.43313e-07_rb,0.45259e-07_rb,0.47279e-07_rb,0.49376e-07_rb/) + totplnk(151:181,16) = (/ & + 0.51552e-07_rb,0.53810e-07_rb,0.56153e-07_rb,0.58583e-07_rb,0.61102e-07_rb, & + 0.63713e-07_rb,0.66420e-07_rb,0.69224e-07_rb,0.72129e-07_rb,0.75138e-07_rb, & + 0.78254e-07_rb,0.81479e-07_rb,0.84818e-07_rb,0.88272e-07_rb,0.91846e-07_rb, & + 0.95543e-07_rb,0.99366e-07_rb,0.10332e-06_rb,0.10740e-06_rb,0.11163e-06_rb, & + 0.11599e-06_rb,0.12050e-06_rb,0.12515e-06_rb,0.12996e-06_rb,0.13493e-06_rb, & + 0.14005e-06_rb,0.14534e-06_rb,0.15080e-06_rb,0.15643e-06_rb,0.16224e-06_rb, & + 0.16823e-06_rb/) + totplk16(1:50) = (/ & + 0.28481e-12_rb,0.33159e-12_rb,0.38535e-12_rb,0.44701e-12_rb,0.51763e-12_rb, & + 0.59836e-12_rb,0.69049e-12_rb,0.79549e-12_rb,0.91493e-12_rb,0.10506e-11_rb, & + 0.12045e-11_rb,0.13788e-11_rb,0.15758e-11_rb,0.17984e-11_rb,0.20493e-11_rb, & + 0.23317e-11_rb,0.26494e-11_rb,0.30060e-11_rb,0.34060e-11_rb,0.38539e-11_rb, & + 0.43548e-11_rb,0.49144e-11_rb,0.55387e-11_rb,0.62344e-11_rb,0.70086e-11_rb, & + 0.78692e-11_rb,0.88248e-11_rb,0.98846e-11_rb,0.11059e-10_rb,0.12358e-10_rb, & + 0.13794e-10_rb,0.15379e-10_rb,0.17128e-10_rb,0.19055e-10_rb,0.21176e-10_rb, & + 0.23508e-10_rb,0.26070e-10_rb,0.28881e-10_rb,0.31963e-10_rb,0.35339e-10_rb, & + 0.39034e-10_rb,0.43073e-10_rb,0.47484e-10_rb,0.52299e-10_rb,0.57548e-10_rb, & + 0.63267e-10_rb,0.69491e-10_rb,0.76261e-10_rb,0.83616e-10_rb,0.91603e-10_rb/) + totplk16(51:100) = (/ & + 0.10027e-09_rb,0.10966e-09_rb,0.11983e-09_rb,0.13084e-09_rb,0.14275e-09_rb, & + 0.15562e-09_rb,0.16951e-09_rb,0.18451e-09_rb,0.20068e-09_rb,0.21810e-09_rb, & + 0.23686e-09_rb,0.25704e-09_rb,0.27875e-09_rb,0.30207e-09_rb,0.32712e-09_rb, & + 0.35400e-09_rb,0.38282e-09_rb,0.41372e-09_rb,0.44681e-09_rb,0.48223e-09_rb, & + 0.52013e-09_rb,0.56064e-09_rb,0.60392e-09_rb,0.65015e-09_rb,0.69948e-09_rb, & + 0.75209e-09_rb,0.80818e-09_rb,0.86794e-09_rb,0.93157e-09_rb,0.99929e-09_rb, & + 0.10713e-08_rb,0.11479e-08_rb,0.12293e-08_rb,0.13157e-08_rb,0.14074e-08_rb, & + 0.15047e-08_rb,0.16079e-08_rb,0.17172e-08_rb,0.18330e-08_rb,0.19557e-08_rb, & + 0.20855e-08_rb,0.22228e-08_rb,0.23680e-08_rb,0.25214e-08_rb,0.26835e-08_rb, & + 0.28546e-08_rb,0.30352e-08_rb,0.32257e-08_rb,0.34266e-08_rb,0.36384e-08_rb/) + totplk16(101:150) = (/ & + 0.38615e-08_rb,0.40965e-08_rb,0.43438e-08_rb,0.46041e-08_rb,0.48779e-08_rb, & + 0.51658e-08_rb,0.54683e-08_rb,0.57862e-08_rb,0.61200e-08_rb,0.64705e-08_rb, & + 0.68382e-08_rb,0.72240e-08_rb,0.76285e-08_rb,0.80526e-08_rb,0.84969e-08_rb, & + 0.89624e-08_rb,0.94498e-08_rb,0.99599e-08_rb,0.10494e-07_rb,0.11052e-07_rb, & + 0.11636e-07_rb,0.12246e-07_rb,0.12884e-07_rb,0.13551e-07_rb,0.14246e-07_rb, & + 0.14973e-07_rb,0.15731e-07_rb,0.16522e-07_rb,0.17347e-07_rb,0.18207e-07_rb, & + 0.19103e-07_rb,0.20037e-07_rb,0.21011e-07_rb,0.22024e-07_rb,0.23079e-07_rb, & + 0.24177e-07_rb,0.25320e-07_rb,0.26508e-07_rb,0.27744e-07_rb,0.29029e-07_rb, & + 0.30365e-07_rb,0.31753e-07_rb,0.33194e-07_rb,0.34691e-07_rb,0.36246e-07_rb, & + 0.37859e-07_rb,0.39533e-07_rb,0.41270e-07_rb,0.43071e-07_rb,0.44939e-07_rb/) + totplk16(151:181) = (/ & + 0.46875e-07_rb,0.48882e-07_rb,0.50961e-07_rb,0.53115e-07_rb,0.55345e-07_rb, & + 0.57655e-07_rb,0.60046e-07_rb,0.62520e-07_rb,0.65080e-07_rb,0.67728e-07_rb, & + 0.70466e-07_rb,0.73298e-07_rb,0.76225e-07_rb,0.79251e-07_rb,0.82377e-07_rb, & + 0.85606e-07_rb,0.88942e-07_rb,0.92386e-07_rb,0.95942e-07_rb,0.99612e-07_rb, & + 0.10340e-06_rb,0.10731e-06_rb,0.11134e-06_rb,0.11550e-06_rb,0.11979e-06_rb, & + 0.12421e-06_rb,0.12876e-06_rb,0.13346e-06_rb,0.13830e-06_rb,0.14328e-06_rb, & + 0.14841e-06_rb/) + + end subroutine lwavplank + + end module rrtmg_lw_setcoef + +! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_taumol.f90,v $ +! author: $Author: mike $ +! revision: $Revision: 1.7 $ +! created: $Date: 2009/10/20 15:08:37 $ +! + module rrtmg_lw_taumol + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrtm, only : mg, nbndlw, maxxsec, ngptlw + use rrlw_con, only: oneminus + use rrlw_wvn, only: nspa, nspb + use rrlw_vsn, only: hvrtau, hnamtau + + implicit none + + contains + +!---------------------------------------------------------------------------- + subroutine taumol(nlayers, pavel, wx, coldry, & + laytrop, jp, jt, jt1, planklay, planklev, plankbnd, & + colh2o, colco2, colo3, coln2o, colco, colch4, colo2, & + colbrd, fac00, fac01, fac10, fac11, & + rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & + rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, & + rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + minorfrac, scaleminor, scaleminorn2, indminor, & + fracs, taug) +!---------------------------------------------------------------------------- + +! ******************************************************************************* +! * * +! * Optical depths developed for the * +! * * +! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * +! * * +! * * +! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * +! * 131 HARTWELL AVENUE * +! * LEXINGTON, MA 02421 * +! * * +! * * +! * ELI J. MLAWER * +! * JENNIFER DELAMERE * +! * STEVEN J. TAUBMAN * +! * SHEPARD A. CLOUGH * +! * * +! * * +! * * +! * * +! * email: mlawer@aer.com * +! * email: jdelamer@aer.com * +! * * +! * The authors wish to acknowledge the contributions of the * +! * following people: Karen Cady-Pereira, Patrick D. Brown, * +! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. * +! * * +! ******************************************************************************* +! * * +! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. * +! * * +! ******************************************************************************* +! * TAUMOL * +! * * +! * This file contains the subroutines TAUGBn (where n goes from * +! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions * +! * per g-value and layer for band n. * +! * * +! * Output: optical depths (unitless) * +! * fractions needed to compute Planck functions at every layer * +! * and g-value * +! * * +! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * +! * COMMON /PLANKG/ FRACS(MXLAY,MG) * +! * * +! * Input * +! * * +! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * +! * COMMON /PRECISE/ ONEMINUS * +! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * +! * & PZ(0:MXLAY),TZ(0:MXLAY) * +! * COMMON /PROFDATA/ LAYTROP, * +! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), * +! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), * +! * & COLO2(MXLAY) +! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * +! * & FAC10(MXLAY),FAC11(MXLAY) * +! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * +! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * +! * * +! * Description: * +! * NG(IBAND) - number of g-values in band IBAND * +! * NSPA(IBAND) - for the lower atmosphere, the number of reference * +! * atmospheres that are stored for band IBAND per * +! * pressure level and temperature. Each of these * +! * atmospheres has different relative amounts of the * +! * key species for the band (i.e. different binary * +! * species parameters). * +! * NSPB(IBAND) - same for upper atmosphere * +! * ONEMINUS - since problems are caused in some cases by interpolation * +! * parameters equal to or greater than 1, for these cases * +! * these parameters are set to this value, slightly < 1. * +! * PAVEL - layer pressures (mb) * +! * TAVEL - layer temperatures (degrees K) * +! * PZ - level pressures (mb) * +! * TZ - level temperatures (degrees K) * +! * LAYTROP - layer at which switch is made from one combination of * +! * key species to another * +! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * +! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * +! * respectively (molecules/cm**2) * +! * FACij(LAY) - for layer LAY, these are factors that are needed to * +! * compute the interpolation factors that multiply the * +! * appropriate reference k-values. A value of 0 (1) for * +! * i,j indicates that the corresponding factor multiplies * +! * reference k-value for the lower (higher) of the two * +! * appropriate temperatures, and altitudes, respectively. * +! * JP - the index of the lower (in altitude) of the two appropriate * +! * reference pressure levels needed for interpolation * +! * JT, JT1 - the indices of the lower of the two appropriate reference * +! * temperatures needed for interpolation (for pressure * +! * levels JP and JP+1, respectively) * +! * SELFFAC - scale factor needed for water vapor self-continuum, equals * +! * (water vapor density)/(atmospheric density at 296K and * +! * 1013 mb) * +! * SELFFRAC - factor needed for temperature interpolation of reference * +! * water vapor self-continuum data * +! * INDSELF - index of the lower of the two appropriate reference * +! * temperatures needed for the self-continuum interpolation * +! * FORFAC - scale factor needed for water vapor foreign-continuum. * +! * FORFRAC - factor needed for temperature interpolation of reference * +! * water vapor foreign-continuum data * +! * INDFOR - index of the lower of the two appropriate reference * +! * temperatures needed for the foreign-continuum interpolation * +! * * +! * Data input * +! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),* +! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' * +! * (note: n is the band number,'MGAS' is the species name of the minor * +! * gas) * +! * * +! * Description: * +! * KA - k-values for low reference atmospheres (key-species only) * +! * (units: cm**2/molecule) * +! * KB - k-values for high reference atmospheres (key-species only) * +! * (units: cm**2/molecule) * +! * KA_M'MGAS' - k-values for low reference atmosphere minor species * +! * (units: cm**2/molecule) * +! * KB_M'MGAS' - k-values for high reference atmosphere minor species * +! * (units: cm**2/molecule) * +! * SELFREF - k-values for water vapor self-continuum for reference * +! * atmospheres (used below LAYTROP) * +! * (units: cm**2/molecule) * +! * FORREF - k-values for water vapor foreign-continuum for reference * +! * atmospheres (used below/above LAYTROP) * +! * (units: cm**2/molecule) * +! * * +! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * +! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * +! * * +!******************************************************************************* + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: nlayers ! total number of layers + real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2) + ! Dimensions: (maxxsec,nlayers) + real(kind=rb), intent(in) :: coldry(:) ! column amount (dry air) + ! Dimensions: (nlayers) + + integer(kind=im), intent(in) :: laytrop ! tropopause layer index + integer(kind=im), intent(in) :: jp(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: jt(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: jt1(:) ! + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: planklay(:,:) ! + ! Dimensions: (nlayers,nbndlw) + real(kind=rb), intent(in) :: planklev(0:,:) ! + ! Dimensions: (nlayers,nbndlw) + real(kind=rb), intent(in) :: plankbnd(:) ! + ! Dimensions: (nbndlw) + + real(kind=rb), intent(in) :: colh2o(:) ! column amount (h2o) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colco2(:) ! column amount (co2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colo3(:) ! column amount (o3) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: coln2o(:) ! column amount (n2o) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colco(:) ! column amount (co) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colch4(:) ! column amount (ch4) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colo2(:) ! column amount (o2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colbrd(:) ! column amount (broadening gases) + ! Dimensions: (nlayers) + + integer(kind=im), intent(in) :: indself(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: indfor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: selffac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: selffrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: forfac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: forfrac(:) + ! Dimensions: (nlayers) + + integer(kind=im), intent(in) :: indminor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: minorfrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: scaleminor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: scaleminorn2(:) + ! Dimensions: (nlayers) + + real(kind=rb), intent(in) :: & ! + fac00(:), fac01(:), & ! Dimensions: (nlayers) + fac10(:), fac11(:) + real(kind=rb), intent(in) :: & ! + rat_h2oco2(:),rat_h2oco2_1(:), & + rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers) + rat_h2on2o(:),rat_h2on2o_1(:), & + rat_h2och4(:),rat_h2och4_1(:), & + rat_n2oco2(:),rat_n2oco2_1(:), & + rat_o3co2(:),rat_o3co2_1(:) + +! ----- Output ----- + real(kind=rb), intent(out) :: fracs(:,:) ! planck fractions + ! Dimensions: (nlayers,ngptlw) + real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth + ! Dimensions: (nlayers,ngptlw) + +!jm not thread safe hvrtau = '$Revision: 1.7 $' + +! Calculate gaseous optical depth and planck fractions for each spectral band. + + call taugb1 + call taugb2 + call taugb3 + call taugb4 + call taugb5 + call taugb6 + call taugb7 + call taugb8 + call taugb9 + call taugb10 + call taugb11 + call taugb12 + call taugb13 + call taugb14 + call taugb15 + call taugb16 + + contains + +!---------------------------------------------------------------------------- + subroutine taugb1 +!---------------------------------------------------------------------------- + +! ------- Modifications ------- +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. +! Revised by Michael J. Iacono, Atmospheric & Environmental Research. +! +! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) +! (high key - h2o; high minor - n2) +! +! note: previous versions of rrtm band 1: +! 10-250 cm-1 (low - h2o; high - h2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng1 + use rrlw_kg01, only : fracrefa, fracrefb, absa, ka, absb, kb, & + ka_mn2, kb_mn2, selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + real(kind=rb) :: pp, corradj, scalen2, tauself, taufor, taun2 + + +! Minor gas mapping levels: +! lower - n2, p = 142.5490 mbar, t = 215.70 k +! upper - n2, p = 142.5490 mbar, t = 215.70 k + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + pp = pavel(lay) + corradj = 1. + if (pp .lt. 250._rb) then + corradj = 1._rb - 0.15_rb * (250._rb-pp) / 154.4_rb + endif + + scalen2 = colbrd(lay) * scaleminorn2(lay) + do ig = 1, ng1 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taun2 = scalen2*(ka_mn2(indm,ig) + & + minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig))) + taug(lay,ig) = corradj * (colh2o(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) & + + tauself + taufor + taun2) + fracs(lay,ig) = fracrefa(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1 + indf = indfor(lay) + indm = indminor(lay) + pp = pavel(lay) + corradj = 1._rb - 0.15_rb * (pp / 95.6_rb) + + scalen2 = colbrd(lay) * scaleminorn2(lay) + do ig = 1, ng1 + taufor = forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) + taun2 = scalen2*(kb_mn2(indm,ig) + & + minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig))) + taug(lay,ig) = corradj * (colh2o(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + taufor + taun2) + fracs(lay,ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb1 + +!---------------------------------------------------------------------------- + subroutine taugb2 +!---------------------------------------------------------------------------- +! +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! +! note: previous version of rrtm band 2: +! 250 - 500 cm-1 (low - h2o; high - h2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng2, ngs1 + use rrlw_kg02, only : fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, ig + real(kind=rb) :: pp, corradj, tauself, taufor + + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1 + inds = indself(lay) + indf = indfor(lay) + pp = pavel(lay) + corradj = 1._rb - .05_rb * (pp - 100._rb) / 900._rb + do ig = 1, ng2 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(lay,ngs1+ig) = corradj * (colh2o(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) & + + tauself + taufor) + fracs(lay,ngs1+ig) = fracrefa(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1 + indf = indfor(lay) + do ig = 1, ng2 + taufor = forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) + taug(lay,ngs1+ig) = colh2o(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + taufor + fracs(lay,ngs1+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb2 + +!---------------------------------------------------------------------------- + subroutine taugb3 +!---------------------------------------------------------------------------- +! +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng3, ngs2 + use rrlw_ref, only : chi_mls + use rrlw_kg03, only : fracrefa, fracrefb, absa, ka, absb, kb, & + ka_mn2o, kb_mn2o, selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + integer(kind=im) :: js, js1, jmn2o, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, & + fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o + real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b + real(kind=rb) :: tau_major, tau_major1 + + +! Minor gas mapping levels: +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + +! P = 212.725 mb + refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) + +! P = 95.58 mb + refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) + +! P = 706.270mb + refrat_m_a = chi_mls(1,3)/chi_mls(2,3) + +! P = 95.58 mb + refrat_m_b = chi_mls(1,13)/chi_mls(2,13) + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the water vapor +! self-continuum and foreign continuum is interpolated (in temperature) +! separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay) + specparm_mn2o = colh2o(lay)/speccomb_mn2o + if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus + specmult_mn2o = 8._rb*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o,1.0_rb) + fmn2omf = minorfrac(lay)*fmn2o +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(lay)/coldry(lay) + ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1) + if (ratn2o .gt. 1.5_rb) then + adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb + adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcoln2o = coln2o(lay) + endif + + speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng3 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * & + (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig)) + n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * & + (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig)) + absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs2+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcoln2o*absn2o + fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + + speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 4._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + + speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay) + specparm_mn2o = colh2o(lay)/speccomb_mn2o + if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus + specmult_mn2o = 4._rb*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o,1.0_rb) + fmn2omf = minorfrac(lay)*fmn2o +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(lay)/coldry(lay) + ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1) + if (ratn2o .gt. 1.5_rb) then + adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb + adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcoln2o = coln2o(lay) + endif + + speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 4._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1 + indf = indfor(lay) + indm = indminor(lay) + + do ig = 1, ng3 + taufor = forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) + n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * & + (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,indm,ig)) + n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * & + (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,indm+1,ig)) + absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) + taug(lay,ngs2+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig)) & + + speccomb1 * & + (fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) & + + taufor & + + adjcoln2o*absn2o + fracs(lay,ngs2+ig) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo + enddo + + end subroutine taugb3 + +!---------------------------------------------------------------------------- + subroutine taugb4 +!---------------------------------------------------------------------------- +! +! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng4, ngs3 + use rrlw_ref, only : chi_mls + use rrlw_kg04, only : fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, ig + integer(kind=im) :: js, js1, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor + real(kind=rb) :: refrat_planck_a, refrat_planck_b + real(kind=rb) :: tau_major, tau_major1 + + +! P = 142.5940 mb + refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) + +! P = 95.58350 mb + refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated (in temperature) +! separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1 + inds = indself(lay) + indf = indfor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng4 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs3+ig) = tau_major + tau_major1 & + + tauself + taufor + fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + + speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) + specparm = colo3(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) + specparm1 = colo3(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 4._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + + speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) + specparm_planck = colo3(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 4._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1 + + do ig = 1, ng4 + taug(lay,ngs3+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig)) & + + speccomb1 * & + (fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) + fracs(lay,ngs3+ig) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo + +! Empirical modification to code to improve stratospheric cooling rates +! for co2. Revised to apply weighting for g-point reduction in this band. + + taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92 + taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88 + taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07 + taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1 + taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99 + taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88 + taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943 + + enddo + + end subroutine taugb4 + +!---------------------------------------------------------------------------- + subroutine taugb5 +!---------------------------------------------------------------------------- +! +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +! (high key - o3,co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng5, ngs4 + use rrlw_ref, only : chi_mls + use rrlw_kg05, only : fracrefa, fracrefb, absa, ka, absb, kb, & + ka_mo3, selfref, forref, ccl4 + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + integer(kind=im) :: js, js1, jmo3, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3 + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor, o3m1, o3m2, abso3 + real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a + real(kind=rb) :: tau_major, tau_major1 + + +! Minor gas mapping level : +! lower - o3, p = 317.34 mbar, t = 240.77 k +! lower - ccl4 + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 473.420 mb + refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) + +! P = 0.2369 mb + refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) + +! P = 317.3480 + refrat_m_a = chi_mls(1,7)/chi_mls(2,7) + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the +! water vapor self-continuum and foreign continuum is +! interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay) + specparm_mo3 = colh2o(lay)/speccomb_mo3 + if (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus + specmult_mo3 = 8._rb*specparm_mo3 + jmo3 = 1 + int(specmult_mo3) + fmo3 = mod(specmult_mo3,1.0_rb) + + speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng5 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * & + (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig)) + o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * & + (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig)) + abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs4+ig) = tau_major + tau_major1 & + + tauself + taufor & + + abso3*colo3(lay) & + + wx(1,lay) * ccl4(ig) + fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + + speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) + specparm = colo3(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) + specparm1 = colo3(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 4._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + + speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) + specparm_planck = colo3(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 4._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1 + + do ig = 1, ng5 + taug(lay,ngs4+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig)) & + + speccomb1 * & + (fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) & + + wx(1,lay) * ccl4(ig) + fracs(lay,ngs4+ig) = fracrefb(ig,jpl) + fpl * & + (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) + enddo + enddo + + end subroutine taugb5 + +!---------------------------------------------------------------------------- + subroutine taugb6 +!---------------------------------------------------------------------------- +! +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +! (high key - nothing; high minor - cfc11, cfc12) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ngs5 +! use parrrtm, only : ng6, ngs5 + use rrlw_ref, only : chi_mls + use rrlw_kg06 +! use rrlw_kg06, only : fracrefa, absa, ka, ka_mco2, & +! selfref, forref, cfc11adj, cfc12 + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2 + real(kind=rb) :: tauself, taufor, absco2 + + +! Minor gas mapping level: +! lower - co2, p = 706.2720 mb, t = 294.2 k +! upper - cfc11, cfc12 + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. The water vapor self-continuum and foreign continuum +! is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(lay)/(coldry(lay)) + ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1) + if (ratco2 .gt. 3.0_rb) then + adjfac = 2.0_rb+(ratco2-2.0_rb)**0.77_rb + adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcolco2 = colco2(lay) + endif + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + do ig = 1, ng6 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * & + (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) + taug(lay,ngs5+ig) = colh2o(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2 * absco2 & + + wx(2,lay) * cfc11adj(ig) & + + wx(3,lay) * cfc12(ig) + fracs(lay,ngs5+ig) = fracrefa(ig) + enddo + enddo + +! Upper atmosphere loop +! Nothing important goes on above laytrop in this band. + do lay = laytrop+1, nlayers + + do ig = 1, ng6 + taug(lay,ngs5+ig) = 0.0_rb & + + wx(2,lay) * cfc11adj(ig) & + + wx(3,lay) * cfc12(ig) + fracs(lay,ngs5+ig) = fracrefa(ig) + enddo + enddo + + end subroutine taugb6 + +!---------------------------------------------------------------------------- + subroutine taugb7 +!---------------------------------------------------------------------------- +! +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +! (high key - o3; high minor - co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng7, ngs6 + use rrlw_ref, only : chi_mls + use rrlw_kg07, only : fracrefa, fracrefb, absa, ka, absb, kb, & + ka_mco2, kb_mco2, selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + integer(kind=im) :: js, js1, jmco2, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2 + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2 + real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2 + real(kind=rb) :: refrat_planck_a, refrat_m_a + real(kind=rb) :: tau_major, tau_major1 + + +! Minor gas mapping level : +! lower - co2, p = 706.2620 mbar, t= 278.94 k +! upper - co2, p = 12.9350 mbar, t = 234.01 k + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + +! P = 706.2620 mb + refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) + +! P = 706.2720 mb + refrat_m_a = chi_mls(1,3)/chi_mls(3,3) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay) + specparm_mco2 = colh2o(lay)/speccomb_mco2 + if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus + specmult_mco2 = 8._rb*specparm_mco2 + + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2,1.0_rb) + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(lay)/(coldry(lay)) + ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) + if (ratco2 .gt. 3.0_rb) then + adjfac = 3.0_rb+(ratco2-3.0_rb)**0.79_rb + adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcolco2 = colco2(lay) + endif + + speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng7 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * & + (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig)) + co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * & + (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig)) + absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs6+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcolco2*absco2 + fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(lay)/(coldry(lay)) + ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) + if (ratco2 .gt. 3.0_rb) then + adjfac = 2.0_rb+(ratco2-2.0_rb)**0.79_rb + adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcolco2 = colco2(lay) + endif + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1 + indm = indminor(lay) + + do ig = 1, ng7 + absco2 = kb_mco2(indm,ig) + minorfrac(lay) * & + (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) + taug(lay,ngs6+ig) = colo3(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + adjcolco2 * absco2 + fracs(lay,ngs6+ig) = fracrefb(ig) + enddo + +! Empirical modification to code to improve stratospheric cooling rates +! for o3. Revised to apply weighting for g-point reduction in this band. + + taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_rb + taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_rb + taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_rb + taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_rb + taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_rb + taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_rb + + enddo + + end subroutine taugb7 + +!---------------------------------------------------------------------------- + subroutine taugb8 +!---------------------------------------------------------------------------- +! +! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) +! (high key - o3; high minor - co2, n2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng8, ngs7 + use rrlw_ref, only : chi_mls + use rrlw_kg08, only : fracrefa, fracrefb, absa, ka, absb, kb, & + ka_mco2, ka_mn2o, ka_mo3, kb_mco2, kb_mn2o, & + selfref, forref, cfc12, cfc22adj + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + real(kind=rb) :: tauself, taufor, absco2, abso3, absn2o + real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2 + + +! Minor gas mapping level: +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - o3, p = 317.348 mb, t = 240.77 k +! lower - n2o, p = 706.2720 mb, t= 278.94 k +! lower - cfc12,cfc11 +! upper - co2, p = 35.1632 mb, t = 223.28 k +! upper - n2o, p = 8.716e-2 mb, t = 226.03 k + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the water vapor +! self-continuum and foreign continuum is interpolated (in temperature) +! separately. + +! Lower atmosphere loop + do lay = 1, laytrop + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(lay)/(coldry(lay)) + ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1) + if (ratco2 .gt. 3.0_rb) then + adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb + adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcolco2 = colco2(lay) + endif + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + do ig = 1, ng8 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * & + (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))) + abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * & + (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) + absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * & + (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))) + taug(lay,ngs7+ig) = colh2o(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2*absco2 & + + colo3(lay) * abso3 & + + coln2o(lay) * absn2o & + + wx(3,lay) * cfc12(ig) & + + wx(4,lay) * cfc22adj(ig) + fracs(lay,ngs7+ig) = fracrefa(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(lay)/coldry(lay) + ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1) + if (ratco2 .gt. 3.0_rb) then + adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb + adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_rb + else + adjcolco2 = colco2(lay) + endif + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1 + indm = indminor(lay) + + do ig = 1, ng8 + absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * & + (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))) + absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * & + (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))) + taug(lay,ngs7+ig) = colo3(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + adjcolco2*absco2 & + + coln2o(lay)*absn2o & + + wx(3,lay) * cfc12(ig) & + + wx(4,lay) * cfc22adj(ig) + fracs(lay,ngs7+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb8 + +!---------------------------------------------------------------------------- + subroutine taugb9 +!---------------------------------------------------------------------------- +! +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +! (high key - ch4; high minor - n2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng9, ngs8 + use rrlw_ref, only : chi_mls + use rrlw_kg09, only : fracrefa, fracrefb, absa, ka, absb, kb, & + ka_mn2o, kb_mn2o, selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + integer(kind=im) :: js, js1, jmn2o, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o + real(kind=rb) :: chi_n2o, ratn2o, adjfac, adjcoln2o + real(kind=rb) :: refrat_planck_a, refrat_m_a + real(kind=rb) :: tau_major, tau_major1 + + +! Minor gas mapping level : +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 212 mb + refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) + +! P = 706.272 mb + refrat_m_a = chi_mls(1,3)/chi_mls(6,3) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay) + specparm_mn2o = colh2o(lay)/speccomb_mn2o + if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus + specmult_mn2o = 8._rb*specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o,1.0_rb) + +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(lay)/(coldry(lay)) + ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1) + if (ratn2o .gt. 1.5_rb) then + adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb + adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcoln2o = coln2o(lay) + endif + + speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng9 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * & + (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig)) + n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * & + (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig)) + absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs8+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcoln2o*absn2o + fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(lay)/(coldry(lay)) + ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1) + if (ratn2o .gt. 1.5_rb) then + adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb + adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb + else + adjcoln2o = coln2o(lay) + endif + + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1 + indm = indminor(lay) + + do ig = 1, ng9 + absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * & + (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) + taug(lay,ngs8+ig) = colch4(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + adjcoln2o*absn2o + fracs(lay,ngs8+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb9 + +!---------------------------------------------------------------------------- + subroutine taugb10 +!---------------------------------------------------------------------------- +! +! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng10, ngs9 + use rrlw_kg10, only : fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, ig + real(kind=rb) :: tauself, taufor + + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1 + inds = indself(lay) + indf = indfor(lay) + + do ig = 1, ng10 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(lay,ngs9+ig) = colh2o(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) & + + tauself + taufor + fracs(lay,ngs9+ig) = fracrefa(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1 + indf = indfor(lay) + + do ig = 1, ng10 + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(lay,ngs9+ig) = colh2o(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + taufor + fracs(lay,ngs9+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb10 + +!---------------------------------------------------------------------------- + subroutine taugb11 +!---------------------------------------------------------------------------- +! +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng11, ngs10 + use rrlw_kg11, only : fracrefa, fracrefb, absa, ka, absb, kb, & + ka_mo2, kb_mo2, selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + real(kind=rb) :: scaleo2, tauself, taufor, tauo2 + + +! Minor gas mapping level : +! lower - o2, p = 706.2720 mbar, t = 278.94 k +! upper - o2, p = 4.758820 mbarm t = 250.85 k + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + scaleo2 = colo2(lay)*scaleminor(lay) + do ig = 1, ng11 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * & + (ka_mo2(indm+1,ig) - ka_mo2(indm,ig))) + taug(lay,ngs10+ig) = colh2o(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) & + + tauself + taufor & + + tauo2 + fracs(lay,ngs10+ig) = fracrefa(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1 + indf = indfor(lay) + indm = indminor(lay) + scaleo2 = colo2(lay)*scaleminor(lay) + do ig = 1, ng11 + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * & + (kb_mo2(indm+1,ig) - kb_mo2(indm,ig))) + taug(lay,ngs10+ig) = colh2o(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + taufor & + + tauo2 + fracs(lay,ngs10+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb11 + +!---------------------------------------------------------------------------- + subroutine taugb12 +!---------------------------------------------------------------------------- +! +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng12, ngs11 + use rrlw_ref, only : chi_mls + use rrlw_kg12, only : fracrefa, absa, ka, & + selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, ig + integer(kind=im) :: js, js1, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor + real(kind=rb) :: refrat_planck_a + real(kind=rb) :: tau_major, tau_major1 + + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 174.164 mb + refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum adn foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1 + inds = indself(lay) + indf = indfor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng12 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs11+ig) = tau_major + tau_major1 & + + tauself + taufor + fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + + do ig = 1, ng12 + taug(lay,ngs11+ig) = 0.0_rb + fracs(lay,ngs11+ig) = 0.0_rb + enddo + enddo + + end subroutine taugb12 + +!---------------------------------------------------------------------------- + subroutine taugb13 +!---------------------------------------------------------------------------- +! +! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng13, ngs12 + use rrlw_ref, only : chi_mls + use rrlw_kg13, only : fracrefa, fracrefb, absa, ka, & + ka_mco2, ka_mco, kb_mo3, selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + integer(kind=im) :: js, js1, jmco2, jmco, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2 + real(kind=rb) :: speccomb_mco, specparm_mco, specmult_mco, fmco + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2 + real(kind=rb) :: com1, com2, absco, abso3 + real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2 + real(kind=rb) :: refrat_planck_a, refrat_m_a, refrat_m_a3 + real(kind=rb) :: tau_major, tau_major1 + +! Minor gas mapping levels : +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - co, p = 706 mb, t = 278.94 k +! upper - o3, p = 95.5835 mb, t = 215.7 k + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 473.420 mb (Level 5) + refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) + +! P = 1053. (Level 1) + refrat_m_a = chi_mls(1,1)/chi_mls(4,1) + +! P = 706. (Level 3) + refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay) + specparm_mco2 = colh2o(lay)/speccomb_mco2 + if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus + specmult_mco2 = 8._rb*specparm_mco2 + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2,1.0_rb) + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(lay)/(coldry(lay)) + ratco2 = 1.e20_rb*chi_co2/3.55e-4_rb + if (ratco2 .gt. 3.0_rb) then + adjfac = 2.0_rb+(ratco2-2.0_rb)**0.68_rb + adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_rb + else + adjcolco2 = colco2(lay) + endif + + speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay) + specparm_mco = colh2o(lay)/speccomb_mco + if (specparm_mco .ge. oneminus) specparm_mco = oneminus + specmult_mco = 8._rb*specparm_mco + jmco = 1 + int(specmult_mco) + fmco = mod(specmult_mco,1.0_rb) + + speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng13 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * & + (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig)) + co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * & + (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig)) + absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) + com1 = ka_mco(jmco,indm,ig) + fmco * & + (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig)) + com2 = ka_mco(jmco,indm+1,ig) + fmco * & + (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig)) + absco = com1 + minorfrac(lay) * (com2 - com1) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs12+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcolco2*absco2 & + + colco(lay)*absco + fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + indm = indminor(lay) + do ig = 1, ng13 + abso3 = kb_mo3(indm,ig) + minorfrac(lay) * & + (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) + taug(lay,ngs12+ig) = colo3(lay)*abso3 + fracs(lay,ngs12+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb13 + +!---------------------------------------------------------------------------- + subroutine taugb14 +!---------------------------------------------------------------------------- +! +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng14, ngs13 + use rrlw_kg14, only : fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, ig + real(kind=rb) :: tauself, taufor + + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum +! and foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1 + inds = indself(lay) + indf = indfor(lay) + do ig = 1, ng14 + tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + taug(lay,ngs13+ig) = colco2(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) & + + tauself + taufor + fracs(lay,ngs13+ig) = fracrefa(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1 + do ig = 1, ng14 + taug(lay,ngs13+ig) = colco2(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) + fracs(lay,ngs13+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb14 + +!---------------------------------------------------------------------------- + subroutine taugb15 +!---------------------------------------------------------------------------- +! +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng15, ngs14 + use rrlw_ref, only : chi_mls + use rrlw_kg15, only : fracrefa, absa, ka, & + ka_mn2, selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig + integer(kind=im) :: js, js1, jmn2, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2 + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: scalen2, tauself, taufor, n2m1, n2m2, taun2 + real(kind=rb) :: refrat_planck_a, refrat_m_a + real(kind=rb) :: tau_major, tau_major1 + + +! Minor gas mapping level : +! Lower - Nitrogen Continuum, P = 1053., T = 294. + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. +! P = 1053. mb (Level 1) + refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) + +! P = 1053. + refrat_m_a = chi_mls(4,1)/chi_mls(2,1) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay) + specparm = coln2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay) + specparm1 = coln2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay) + specparm_mn2 = coln2o(lay)/speccomb_mn2 + if (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus + specmult_mn2 = 8._rb*specparm_mn2 + jmn2 = 1 + int(specmult_mn2) + fmn2 = mod(specmult_mn2,1.0_rb) + + speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay) + specparm_planck = coln2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1 + inds = indself(lay) + indf = indfor(lay) + indm = indminor(lay) + + scalen2 = colbrd(lay)*scaleminor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng15 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * & + (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig)) + n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * & + (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig)) + taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1)) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs14+ig) = tau_major + tau_major1 & + + tauself + taufor & + + taun2 + fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + do ig = 1, ng15 + taug(lay,ngs14+ig) = 0.0_rb + fracs(lay,ngs14+ig) = 0.0_rb + enddo + enddo + + end subroutine taugb15 + +!---------------------------------------------------------------------------- + subroutine taugb16 +!---------------------------------------------------------------------------- +! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrtm, only : ng16, ngs15 + use rrlw_ref, only : chi_mls + use rrlw_kg16, only : fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Declarations ------- + +! Local + integer(kind=im) :: lay, ind0, ind1, inds, indf, ig + integer(kind=im) :: js, js1, jpl + real(kind=rb) :: speccomb, specparm, specmult, fs + real(kind=rb) :: speccomb1, specparm1, specmult1, fs1 + real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl + real(kind=rb) :: p, p4, fk0, fk1, fk2 + real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210 + real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211 + real(kind=rb) :: tauself, taufor + real(kind=rb) :: refrat_planck_a + real(kind=rb) :: tau_major, tau_major1 + + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + +! P = 387. mb (Level 6) + refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature,and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + + speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0_rb) + + speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) + specparm1 = colh2o(lay)/speccomb1 + if (specparm1 .ge. oneminus) specparm1 = oneminus + specmult1 = 8._rb*(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0_rb) + + speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) + specparm_planck = colh2o(lay)/speccomb_planck + if (specparm_planck .ge. oneminus) specparm_planck=oneminus + specmult_planck = 8._rb*specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0_rb) + + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1 + inds = indself(lay) + indf = indfor(lay) + + if (specparm .lt. 0.125_rb) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else if (specparm .gt. 0.875_rb) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac000 = fk0*fac00(lay) + fac100 = fk1*fac00(lay) + fac200 = fk2*fac00(lay) + fac010 = fk0*fac10(lay) + fac110 = fk1*fac10(lay) + fac210 = fk2*fac10(lay) + else + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + endif + + if (specparm1 .lt. 0.125_rb) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else if (specparm1 .gt. 0.875_rb) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0_rb*p4 + fk2 = p + p4 + fac001 = fk0*fac01(lay) + fac101 = fk1*fac01(lay) + fac201 = fk2*fac01(lay) + fac011 = fk0*fac11(lay) + fac111 = fk1*fac11(lay) + fac211 = fk2*fac11(lay) + else + fac001 = (1._rb - fs1) * fac01(lay) + fac011 = (1._rb - fs1) * fac11(lay) + fac101 = fs1 * fac01(lay) + fac111 = fs1 * fac11(lay) + endif + + do ig = 1, ng16 + tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) + + if (specparm .lt. 0.125_rb) then + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac200 * absa(ind0+2,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac210 * absa(ind0+11,ig)) + else if (specparm .gt. 0.875_rb) then + tau_major = speccomb * & + (fac200 * absa(ind0-1,ig) + & + fac100 * absa(ind0,ig) + & + fac000 * absa(ind0+1,ig) + & + fac210 * absa(ind0+8,ig) + & + fac110 * absa(ind0+9,ig) + & + fac010 * absa(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125_rb) then + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac201 * absa(ind1+2,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig) + & + fac211 * absa(ind1+11,ig)) + else if (specparm1 .gt. 0.875_rb) then + tau_major1 = speccomb1 * & + (fac201 * absa(ind1-1,ig) + & + fac101 * absa(ind1,ig) + & + fac001 * absa(ind1+1,ig) + & + fac211 * absa(ind1+8,ig) + & + fac111 * absa(ind1+9,ig) + & + fac011 * absa(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + endif + + taug(lay,ngs15+ig) = tau_major + tau_major1 & + + tauself + taufor + fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * & + (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1 + do ig = 1, ng16 + taug(lay,ngs15+ig) = colch4(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) + fracs(lay,ngs15+ig) = fracrefb(ig) + enddo + enddo + + end subroutine taugb16 + + end subroutine taumol + + end module rrtmg_lw_taumol + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module rrtmg_lw_init + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + use parkind, only : im => kind_im, rb => kind_rb + use rrlw_wvn + use rrtmg_lw_setcoef, only: lwatmref, lwavplank + +! Steven Cavallo: added for buffer layer adjustment + implicit none + + integer , save :: nlayers + + contains + +! ************************************************************************** + subroutine rrtmg_lw_ini(cpdair) +! ************************************************************************** +! +! Original version: Michael J. Iacono; July, 1998 +! First revision for GCMs: September, 1998 +! Second revision for RRTM_V3.0: September, 2002 +! +! This subroutine performs calculations necessary for the initialization +! of the longwave model. Lookup tables are computed for use in the LW +! radiative transfer, and input absorption coefficient data for each +! spectral band are reduced from 256 g-point intervals to 140. +! ************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw + use rrlw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl + use rrlw_vsn, only: hvrini, hnamini + + real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! ------- Local ------- + + integer(kind=im) :: itr, ibnd, igc, ig, ind, ipr + integer(kind=im) :: igcsm, iprsm + + real(kind=rb) :: wtsum, wtsm(mg) ! + real(kind=rb) :: tfn ! + + real(kind=rb), parameter :: expeps = 1.e-20 ! Smallest value for exponential table + +! ------- Definitions ------- +! Arrays for 10000-point look-up tables: +! TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer) +! EXP_TBL Exponential lookup table for ransmittance +! TFN_TBL Tau transition function; i.e. the transition of the Planck +! function from that for the mean layer temperature to that for +! the layer boundary temperature as a function of optical depth. +! The "linear in tau" method is used to make the table. +! PADE Pade approximation constant (= 0.278) +! BPADE Inverse of the Pade approximation constant +! + +!jm not thread safe hvrini = '$Revision: 1.3 $' + +! Initialize model data + call lwdatinit(cpdair) + call lwcmbdat ! g-point interval reduction data + call lwcldpr ! cloud optical properties + call lwatmref ! reference MLS profile + call lwavplank ! Planck function +! Moved to module_ra_rrtmg_lw for WRF +! call lw_kgb01 ! molecular absorption coefficients +! call lw_kgb02 +! call lw_kgb03 +! call lw_kgb04 +! call lw_kgb05 +! call lw_kgb06 +! call lw_kgb07 +! call lw_kgb08 +! call lw_kgb09 +! call lw_kgb10 +! call lw_kgb11 +! call lw_kgb12 +! call lw_kgb13 +! call lw_kgb14 +! call lw_kgb15 +! call lw_kgb16 + +! Compute lookup tables for transmittance, tau transition function, +! and clear sky tau (for the cloudy sky radiative transfer). Tau is +! computed as a function of the tau transition function, transmittance +! is calculated as a function of tau, and the tau transition function +! is calculated using the linear in tau formulation at values of tau +! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables +! are computed at intervals of 0.001. The inverse of the constant used +! in the Pade approximation to the tau transition function is set to b. + + tau_tbl(0) = 0.0_rb + tau_tbl(ntbl) = 1.e10_rb + exp_tbl(0) = 1.0_rb + exp_tbl(ntbl) = expeps + tfn_tbl(0) = 0.0_rb + tfn_tbl(ntbl) = 1.0_rb + bpade = 1.0_rb / pade + do itr = 1, ntbl-1 + tfn = float(itr) / float(ntbl) + tau_tbl(itr) = bpade * tfn / (1._rb - tfn) + exp_tbl(itr) = exp(-tau_tbl(itr)) + if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps + if (tau_tbl(itr) .lt. 0.06_rb) then + tfn_tbl(itr) = tau_tbl(itr)/6._rb + else + tfn_tbl(itr) = 1._rb-2._rb*((1._rb/tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr)))) + endif + enddo + +! Perform g-point reduction from 16 per band (256 total points) to +! a band dependant number (140 total points) for all absorption +! coefficient input data and Planck fraction input data. +! Compute relative weighting for new g-point combinations. + + igcsm = 0 + do ibnd = 1,nbndlw + iprsm = 0 + if (ngc(ibnd).lt.mg) then + do igc = 1,ngc(ibnd) + igcsm = igcsm + 1 + wtsum = 0._rb + do ipr = 1, ngn(igcsm) + iprsm = iprsm + 1 + wtsum = wtsum + wt(iprsm) + enddo + wtsm(igc) = wtsum + enddo + do ig = 1, ng(ibnd) + ind = (ibnd-1)*mg + ig + rwgt(ind) = wt(ig)/wtsm(ngm(ind)) + enddo + else + do ig = 1, ng(ibnd) + igcsm = igcsm + 1 + ind = (ibnd-1)*mg + ig + rwgt(ind) = 1.0_rb + enddo + endif + enddo + +! Reduce g-points for absorption coefficient data in each LW spectral band. + + call cmbgb1 + call cmbgb2 + call cmbgb3 + call cmbgb4 + call cmbgb5 + call cmbgb6 + call cmbgb7 + call cmbgb8 + call cmbgb9 + call cmbgb10 + call cmbgb11 + call cmbgb12 + call cmbgb13 + call cmbgb14 + call cmbgb15 + call cmbgb16 + + end subroutine rrtmg_lw_ini + +!*************************************************************************** + subroutine lwdatinit(cpdair) +!*************************************************************************** + +! --------- Modules ---------- + + use parrrtm, only : maxxsec, maxinpx + use rrlw_con, only: heatfac, grav, planck, boltz, & + clight, avogad, alosmt, gascon, radcn1, radcn2, & + sbcnst, secdy, fluxfac, oneminus, pi + use rrlw_vsn + + save + + real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! Longwave spectral band limits (wavenumbers) + wavenum1(:) = (/ 10._rb, 350._rb, 500._rb, 630._rb, 700._rb, 820._rb, & + 980._rb,1080._rb,1180._rb,1390._rb,1480._rb,1800._rb, & + 2080._rb,2250._rb,2380._rb,2600._rb/) + wavenum2(:) = (/350._rb, 500._rb, 630._rb, 700._rb, 820._rb, 980._rb, & + 1080._rb,1180._rb,1390._rb,1480._rb,1800._rb,2080._rb, & + 2250._rb,2380._rb,2600._rb,3250._rb/) + delwave(:) = (/340._rb, 150._rb, 130._rb, 70._rb, 120._rb, 160._rb, & + 100._rb, 100._rb, 210._rb, 90._rb, 320._rb, 280._rb, & + 170._rb, 130._rb, 220._rb, 650._rb/) + +! Spectral band information + ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/) + nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/) + nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/) + +! nxmol - number of cross-sections input by user +! ixindx(i) - index of cross-section molecule corresponding to Ith +! cross-section specified by user +! = 0 -- not allowed in rrtm +! = 1 -- ccl4 +! = 2 -- cfc11 +! = 3 -- cfc12 +! = 4 -- cfc22 + nxmol = 4 + ixindx(1) = 1 + ixindx(2) = 2 + ixindx(3) = 3 + ixindx(4) = 4 + ixindx(5:maxinpx) = 0 + +! Fundamental physical constants from NIST 2002 + + grav = 9.8066_rb ! Acceleration of gravity + ! (m s-2) + planck = 6.62606876e-27_rb ! Planck constant + ! (ergs s; g cm2 s-1) + boltz = 1.3806503e-16_rb ! Boltzmann constant + ! (ergs K-1; g cm2 s-2 K-1) + clight = 2.99792458e+10_rb ! Speed of light in a vacuum + ! (cm s-1) + avogad = 6.02214199e+23_rb ! Avogadro constant + ! (mol-1) + alosmt = 2.6867775e+19_rb ! Loschmidt constant + ! (cm-3) + gascon = 8.31447200e+07_rb ! Molar gas constant + ! (ergs mol-1 K-1) + radcn1 = 1.191042722e-12_rb ! First radiation constant + ! (W cm2 sr-1) + radcn2 = 1.4387752_rb ! Second radiation constant + ! (cm K) + sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant + ! (W cm-2 K-4) + secdy = 8.6400e4_rb ! Number of seconds per day + ! (s d-1) + +!jm moved here for thread safety, 20141107 + oneminus = 1._rb - 1.e-6_rb + pi = 2._rb * asin(1._rb) + fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4 + +! +! units are generally cgs +! +! The first and second radiation constants are taken from NIST. +! They were previously obtained from the relations: +! radcn1 = 2.*planck*clight*clight*1.e-07 +! radcn2 = planck*clight/boltz + +! Heatfac is the factor by which delta-flux / delta-pressure is +! multiplied, with flux in W/m-2 and pressure in mbar, to get +! the heating rate in units of degrees/day. It is equal to: +! Original value: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.004) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.8066)(86400)(1e-5)/(1.004) +! heatfac = 8.4391_rb +! +! Modified value for consistency with CAM3: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.00464) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.80616)(86400)(1e-5)/(1.00464) +! heatfac = 8.43339130434_rb +! +! Calculated value: +! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2) +! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2) +! converts mb to Pa when heatfac is multiplied by W m-2 mb-1. + heatfac = grav * secdy / (cpdair * 1.e2_rb) + + end subroutine lwdatinit + +!*************************************************************************** + subroutine lwcmbdat +!*************************************************************************** + + save + +! ------- Definitions ------- +! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands: +! This mapping from 256 to 140 points has been carefully selected to +! minimize the effect on the resulting fluxes and cooling rates, and +! caution should be used if the mapping is modified. The full 256 +! g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc. +! ngptlw The total number of new g-points +! ngc The number of new g-points in each band +! ngs The cumulative sum of new g-points for each band +! ngm The index of each new g-point relative to the original +! 16 g-points for each band. +! ngn The number of original g-points that are combined to make +! each new g-point in each band. +! ngb The band index for each new g-point. +! wt RRTM weights for 16 g-points. + +! ------- Data statements ------- + ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/) + ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/) + ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, & ! band 1 + 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 2 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 3 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! band 4 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 5 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 6 + 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! band 7 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 8 + 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 9 + 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 10 + 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! band 11 + 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 12 + 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! band 13 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 14 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 15 + 1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/) ! band 16 + ngn(:) = (/1,1,2,2,2,2,2,2,1,1, & ! band 1 + 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 2 + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 3 + 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! band 4 + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 5 + 2,2,2,2,2,2,2,2, & ! band 6 + 2,2,1,1,1,1,1,1,1,1,2,2, & ! band 7 + 2,2,2,2,2,2,2,2, & ! band 8 + 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 9 + 2,2,2,2,4,4, & ! band 10 + 1,1,2,2,2,2,3,3, & ! band 11 + 1,1,1,1,2,2,4,4, & ! band 12 + 3,3,4,6, & ! band 13 + 8,8, & ! band 14 + 8,8, & ! band 15 + 4,12/) ! band 16 + ngb(:) = (/1,1,1,1,1,1,1,1,1,1, & ! band 1 + 2,2,2,2,2,2,2,2,2,2,2,2, & ! band 2 + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, & ! band 3 + 4,4,4,4,4,4,4,4,4,4,4,4,4,4, & ! band 4 + 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, & ! band 5 + 6,6,6,6,6,6,6,6, & ! band 6 + 7,7,7,7,7,7,7,7,7,7,7,7, & ! band 7 + 8,8,8,8,8,8,8,8, & ! band 8 + 9,9,9,9,9,9,9,9,9,9,9,9, & ! band 9 + 10,10,10,10,10,10, & ! band 10 + 11,11,11,11,11,11,11,11, & ! band 11 + 12,12,12,12,12,12,12,12, & ! band 12 + 13,13,13,13, & ! band 13 + 14,14, & ! band 14 + 15,15, & ! band 15 + 16,16/) ! band 16 + wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, & + 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, & + 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, & + 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, & + 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, & + 0.0000750000_rb/) + + end subroutine lwcmbdat + +!*************************************************************************** + subroutine cmbgb1 +!*************************************************************************** +! +! Original version: MJIacono; July 1998 +! Revision for GCMs: MJIacono; September 1998 +! Revision for RRTMG: MJIacono, September 2002 +! Revision for F90 reformatting: MJIacono, June 2006 +! +! The subroutines CMBGB1->CMBGB16 input the absorption coefficient +! data for each band, which are defined for 16 g-points and 16 spectral +! bands. The data are combined with appropriate weighting following the +! g-point mapping arrays specified in RRTMINIT. Plank fraction data +! in arrays FRACREFA and FRACREFB are combined without weighting. All +! g-point reduced data are put into new arrays for use in RRTM. +! +! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) +! (high key - h2o; high minor - n2) +! note: previous versions of rrtm band 1: +! 10-250 cm-1 (low - h2o; high - h2o) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng1 + use rrlw_kg01, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2, kb_mn2, & + selfref, forref + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(1) + sumk1 = 0. + sumk2 = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm) + sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm) + enddo + ka_mn2(jt,igc) = sumk1 + kb_mn2(jt,igc) = sumk2 + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(1) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb1 + +!*************************************************************************** + subroutine cmbgb2 +!*************************************************************************** +! +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! +! note: previous version of rrtm band 2: +! 250 - 500 cm-1 (low - h2o; high - h2o) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng2 + use rrlw_kg02, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+16) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(2) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb2 + +!*************************************************************************** + subroutine cmbgb3 +!*************************************************************************** +! +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +! +! old band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng3 + use rrlw_kg03, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2o, kb_mn2o, & + selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp-12,iprsm)*rwgt(iprsm+32) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32) + enddo + ka_mn2o(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32) + enddo + kb_mn2o(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(3) + sumf = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(3) + sumf = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm,jp) + enddo + fracrefb(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb3 + +!*************************************************************************** + subroutine cmbgb4 +!*************************************************************************** +! +! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) +! +! old band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng4 + use rrlw_kg04, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp-12,iprsm)*rwgt(iprsm+48) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(4) + sumf = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(4) + sumf = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm,jp) + enddo + fracrefb(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb4 + +!*************************************************************************** + subroutine cmbgb5 +!*************************************************************************** +! +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +! (high key - o3,co2) +! +! old band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng5 + use rrlw_kg05, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, & + selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp-12,iprsm)*rwgt(iprsm+64) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64) + enddo + ka_mo3(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(5) + sumf = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(5) + sumf = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm,jp) + enddo + fracrefb(igc,jp) = sumf + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64) + enddo + ccl4(igc) = sumk + enddo + + end subroutine cmbgb5 + +!*************************************************************************** + subroutine cmbgb6 +!*************************************************************************** +! +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +! (high key - nothing; high minor - cfc11, cfc12) +! +! old band 6: 820-980 cm-1 (low - h2o; high - nothing) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw +! use parrrtm, only : mg, nbndlw, ngptlw, ng6 + use rrlw_kg06 +! use rrlw_kg06, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, & +! selfrefo, forrefo, & +! fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12, & +! selfref, forref + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf, sumk1, sumk2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80) + enddo + ka_mco2(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(6) + sumf = 0. + sumk1= 0. + sumk2= 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm) + sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80) + sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80) + enddo + fracrefa(igc) = sumf + cfc11adj(igc) = sumk1 + cfc12(igc) = sumk2 + enddo + + end subroutine cmbgb6 + +!*************************************************************************** + subroutine cmbgb7 +!*************************************************************************** +! +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +! (high key - o3; high minor - co2) +! +! old band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng7 + use rrlw_kg07, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mco2, kb_mco2, & + selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+96) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96) + enddo + ka_mco2(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96) + enddo + kb_mco2(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(7) + sumf = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(7) + sumf = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + end subroutine cmbgb7 + +!*************************************************************************** + subroutine cmbgb8 +!*************************************************************************** +! +! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) +! (high key - o3; high minor - co2, n2o) +! +! old band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng8 + use rrlw_kg08, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, & + kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, & + cfc12o, cfc22adjo, & + fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o, & + ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref, & + cfc12, cfc22adj + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+112) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(8) + sumk1 = 0. + sumk2 = 0. + sumk3 = 0. + sumk4 = 0. + sumk5 = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112) + sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112) + sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112) + sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112) + sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112) + enddo + ka_mco2(jt,igc) = sumk1 + kb_mco2(jt,igc) = sumk2 + ka_mo3(jt,igc) = sumk3 + ka_mn2o(jt,igc) = sumk4 + kb_mn2o(jt,igc) = sumk5 + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(8) + sumf1= 0. + sumf2= 0. + sumk1= 0. + sumk2= 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112) + sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + cfc12(igc) = sumk1 + cfc22adj(igc) = sumk2 + enddo + + end subroutine cmbgb8 + +!*************************************************************************** + subroutine cmbgb9 +!*************************************************************************** +! +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +! (high key - ch4; high minor - n2o)! + +! old band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng9 + use rrlw_kg09, only: fracrefao, fracrefbo, kao, kao_mn2o, & + kbo, kbo_mn2o, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, ka_mn2o, & + absb, kb, kb_mn2o, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+128) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128) + enddo + ka_mn2o(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128) + enddo + kb_mn2o(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(9) + sumf = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(9) + sumf = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + end subroutine cmbgb9 + +!*************************************************************************** + subroutine cmbgb10 +!*************************************************************************** +! +! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) +! +! old band 10: 1390-1480 cm-1 (low - h2o; high - h2o) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng10 + use rrlw_kg10, only: fracrefao, fracrefbo, kao, kbo, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+144) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(10) + sumf1= 0. + sumf2= 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb10 + +!*************************************************************************** + subroutine cmbgb11 +!*************************************************************************** +! +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +! +! old band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng11 + use rrlw_kg11, only: fracrefao, fracrefbo, kao, kao_mo2, & + kbo, kbo_mo2, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, ka_mo2, & + absb, kb, kb_mo2, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+160) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(11) + sumk1 = 0. + sumk2 = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160) + sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160) + enddo + ka_mo2(jt,igc) = sumk1 + kb_mo2(jt,igc) = sumk2 + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(11) + sumf1= 0. + sumf2= 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb11 + +!*************************************************************************** + subroutine cmbgb12 +!*************************************************************************** +! +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! +! old band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng12 + use rrlw_kg12, only: fracrefao, kao, selfrefo, forrefo, & + fracrefa, absa, ka, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(12) + sumf = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb12 + +!*************************************************************************** + subroutine cmbgb13 +!*************************************************************************** +! +! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) +! +! old band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng13 + use rrlw_kg13, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, & + kbo_mo3, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco, & + kb_mo3, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumk1, sumk2, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(13) + sumk1 = 0. + sumk2 = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192) + sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192) + enddo + ka_mco2(jn,jt,igc) = sumk1 + ka_mco(jn,jt,igc) = sumk2 + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192) + enddo + kb_mo3(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(13) + sumf = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(13) + sumf = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb13 + +!*************************************************************************** + subroutine cmbgb14 +!*************************************************************************** +! +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +! +! old band 14: 2250-2380 cm-1 (low - co2; high - co2) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng14 + use rrlw_kg14, only: fracrefao, fracrefbo, kao, kbo, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+208) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(14) + sumf1= 0. + sumf2= 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb14 + +!*************************************************************************** + subroutine cmbgb15 +!*************************************************************************** +! +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +! +! old band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng15 + use rrlw_kg15, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, & + fracrefa, absa, ka, ka_mn2, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224) + enddo + ka_mn2(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(15) + sumf = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb15 + +!*************************************************************************** + subroutine cmbgb16 +!*************************************************************************** +! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! +! old band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) +!*************************************************************************** + + use parrrtm, only : mg, nbndlw, ngptlw, ng16 + use rrlw_kg16, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+240) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(16) + sumf = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(16) + sumf = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb16 + +!*************************************************************************** + subroutine lwcldpr +!*************************************************************************** + +! --------- Modules ---------- + + use rrlw_cld, only: abscld1, absliq0, absliq1, & + absice0, absice1, absice2, absice3 + + save + +! ABSCLDn is the liquid water absorption coefficient (m2/g). +! For INFLAG = 1. + abscld1 = 0.0602410_rb +! +! Everything below is for INFLAG = 2. + +! ABSICEn(J,IB) are the parameters needed to compute the liquid water +! absorption coefficient in spectral region IB for ICEFLAG=n. The units +! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)). +! For ICEFLAG = 0. + + absice0(:)= (/0.005_rb, 1.0_rb/) + +! For ICEFLAG = 1. + absice1(1,:) = (/0.0036_rb, 0.0068_rb, 0.0003_rb, 0.0016_rb, 0.0020_rb/) + absice1(2,:) = (/1.136_rb , 0.600_rb , 1.338_rb , 1.166_rb , 1.118_rb /) + +! For ICEFLAG = 2. In each band, the absorption +! coefficients are listed for a range of effective radii from 5.0 +! to 131.0 microns in increments of 3.0 microns. +! Spherical Ice Particle Parameterization +! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)] + absice2(:,1) = (/ & +! band 1 + 7.798999e-02_rb,6.340479e-02_rb,5.417973e-02_rb,4.766245e-02_rb,4.272663e-02_rb, & + 3.880939e-02_rb,3.559544e-02_rb,3.289241e-02_rb,3.057511e-02_rb,2.855800e-02_rb, & + 2.678022e-02_rb,2.519712e-02_rb,2.377505e-02_rb,2.248806e-02_rb,2.131578e-02_rb, & + 2.024194e-02_rb,1.925337e-02_rb,1.833926e-02_rb,1.749067e-02_rb,1.670007e-02_rb, & + 1.596113e-02_rb,1.526845e-02_rb,1.461739e-02_rb,1.400394e-02_rb,1.342462e-02_rb, & + 1.287639e-02_rb,1.235656e-02_rb,1.186279e-02_rb,1.139297e-02_rb,1.094524e-02_rb, & + 1.051794e-02_rb,1.010956e-02_rb,9.718755e-03_rb,9.344316e-03_rb,8.985139e-03_rb, & + 8.640223e-03_rb,8.308656e-03_rb,7.989606e-03_rb,7.682312e-03_rb,7.386076e-03_rb, & + 7.100255e-03_rb,6.824258e-03_rb,6.557540e-03_rb/) + absice2(:,2) = (/ & +! band 2 + 2.784879e-02_rb,2.709863e-02_rb,2.619165e-02_rb,2.529230e-02_rb,2.443225e-02_rb, & + 2.361575e-02_rb,2.284021e-02_rb,2.210150e-02_rb,2.139548e-02_rb,2.071840e-02_rb, & + 2.006702e-02_rb,1.943856e-02_rb,1.883064e-02_rb,1.824120e-02_rb,1.766849e-02_rb, & + 1.711099e-02_rb,1.656737e-02_rb,1.603647e-02_rb,1.551727e-02_rb,1.500886e-02_rb, & + 1.451045e-02_rb,1.402132e-02_rb,1.354084e-02_rb,1.306842e-02_rb,1.260355e-02_rb, & + 1.214575e-02_rb,1.169460e-02_rb,1.124971e-02_rb,1.081072e-02_rb,1.037731e-02_rb, & + 9.949167e-03_rb,9.526021e-03_rb,9.107615e-03_rb,8.693714e-03_rb,8.284096e-03_rb, & + 7.878558e-03_rb,7.476910e-03_rb,7.078974e-03_rb,6.684586e-03_rb,6.293589e-03_rb, & + 5.905839e-03_rb,5.521200e-03_rb,5.139543e-03_rb/) + absice2(:,3) = (/ & +! band 3 + 1.065397e-01_rb,8.005726e-02_rb,6.546428e-02_rb,5.589131e-02_rb,4.898681e-02_rb, & + 4.369932e-02_rb,3.947901e-02_rb,3.600676e-02_rb,3.308299e-02_rb,3.057561e-02_rb, & + 2.839325e-02_rb,2.647040e-02_rb,2.475872e-02_rb,2.322164e-02_rb,2.183091e-02_rb, & + 2.056430e-02_rb,1.940407e-02_rb,1.833586e-02_rb,1.734787e-02_rb,1.643034e-02_rb, & + 1.557512e-02_rb,1.477530e-02_rb,1.402501e-02_rb,1.331924e-02_rb,1.265364e-02_rb, & + 1.202445e-02_rb,1.142838e-02_rb,1.086257e-02_rb,1.032445e-02_rb,9.811791e-03_rb, & + 9.322587e-03_rb,8.855053e-03_rb,8.407591e-03_rb,7.978763e-03_rb,7.567273e-03_rb, & + 7.171949e-03_rb,6.791728e-03_rb,6.425642e-03_rb,6.072809e-03_rb,5.732424e-03_rb, & + 5.403748e-03_rb,5.086103e-03_rb,4.778865e-03_rb/) + absice2(:,4) = (/ & +! band 4 + 1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, & + 4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, & + 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, & + 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, & + 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, & + 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, & + 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, & + 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, & + 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/) + absice2(:,5) = (/ & +! band 5 + 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, & + 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, & + 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, & + 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, & + 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, & + 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, & + 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, & + 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, & + 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/) + absice2(:,6) = (/ & +! band 6 + 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, & + 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, & + 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, & + 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, & + 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, & + 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, & + 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, & + 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, & + 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/) + absice2(:,7) = (/ & +! band 7 + 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, & + 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, & + 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, & + 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, & + 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, & + 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, & + 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, & + 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, & + 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/) + absice2(:,8) = (/ & +! band 8 + 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, & + 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, & + 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, & + 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, & + 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, & + 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, & + 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, & + 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, & + 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/) + absice2(:,9) = (/ & +! band 9 + 1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, & + 4.022253e-02_rb,3.555576e-02_rb,3.187259e-02_rb,2.888498e-02_rb,2.640843e-02_rb, & + 2.431904e-02_rb,2.253038e-02_rb,2.098024e-02_rb,1.962267e-02_rb,1.842293e-02_rb, & + 1.735426e-02_rb,1.639571e-02_rb,1.553060e-02_rb,1.474552e-02_rb,1.402953e-02_rb, & + 1.337363e-02_rb,1.277033e-02_rb,1.221336e-02_rb,1.169741e-02_rb,1.121797e-02_rb, & + 1.077117e-02_rb,1.035369e-02_rb,9.962643e-03_rb,9.595509e-03_rb,9.250088e-03_rb, & + 8.924447e-03_rb,8.616876e-03_rb,8.325862e-03_rb,8.050057e-03_rb,7.788258e-03_rb, & + 7.539388e-03_rb,7.302478e-03_rb,7.076656e-03_rb,6.861134e-03_rb,6.655197e-03_rb, & + 6.458197e-03_rb,6.269543e-03_rb,6.088697e-03_rb/) + absice2(:,10) = (/ & +! band 10 + 1.593628e-01_rb,1.014552e-01_rb,7.458955e-02_rb,5.903571e-02_rb,4.887582e-02_rb, & + 4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, & + 2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, & + 1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, & + 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, & + 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, & + 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, & + 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, & + 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/) + absice2(:,11) = (/ & +! band 11 + 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, & + 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, & + 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, & + 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, & + 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, & + 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, & + 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, & + 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, & + 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/) + absice2(:,12) = (/ & +! band 12 + 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, & + 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, & + 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, & + 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, & + 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, & + 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, & + 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, & + 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, & + 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/) + absice2(:,13) = (/ & +! band 13 + 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, & + 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, & + 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, & + 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, & + 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, & + 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, & + 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, & + 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, & + 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/) + absice2(:,14) = (/ & +! band 14 + 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, & + 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, & + 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, & + 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, & + 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, & + 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, & + 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, & + 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, & + 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/) + absice2(:,15) = (/ & +! band 15 + 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, & + 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, & + 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, & + 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, & + 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, & + 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, & + 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, & + 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, & + 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/) + absice2(:,16) = (/ & +! band 16 + 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, & + 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, & + 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, & + 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, & + 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, & + 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, & + 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, & + 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, & + 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/) + +! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in +! increments of 3 microns. +! units = m2/g +! Hexagonal Ice Particle Parameterization +! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)] + absice3(:,1) = (/ & +! band 1 + 3.110649e-03_rb,4.666352e-02_rb,6.606447e-02_rb,6.531678e-02_rb,6.012598e-02_rb, & + 5.437494e-02_rb,4.906411e-02_rb,4.441146e-02_rb,4.040585e-02_rb,3.697334e-02_rb, & + 3.403027e-02_rb,3.149979e-02_rb,2.931596e-02_rb,2.742365e-02_rb,2.577721e-02_rb, & + 2.433888e-02_rb,2.307732e-02_rb,2.196644e-02_rb,2.098437e-02_rb,2.011264e-02_rb, & + 1.933561e-02_rb,1.863992e-02_rb,1.801407e-02_rb,1.744812e-02_rb,1.693346e-02_rb, & + 1.646252e-02_rb,1.602866e-02_rb,1.562600e-02_rb,1.524933e-02_rb,1.489399e-02_rb, & + 1.455580e-02_rb,1.423098e-02_rb,1.391612e-02_rb,1.360812e-02_rb,1.330413e-02_rb, & + 1.300156e-02_rb,1.269801e-02_rb,1.239127e-02_rb,1.207928e-02_rb,1.176014e-02_rb, & + 1.143204e-02_rb,1.109334e-02_rb,1.074243e-02_rb,1.037786e-02_rb,9.998198e-03_rb, & + 9.602126e-03_rb/) + absice3(:,2) = (/ & +! band 2 + 3.984966e-04_rb,1.681097e-02_rb,2.627680e-02_rb,2.767465e-02_rb,2.700722e-02_rb, & + 2.579180e-02_rb,2.448677e-02_rb,2.323890e-02_rb,2.209096e-02_rb,2.104882e-02_rb, & + 2.010547e-02_rb,1.925003e-02_rb,1.847128e-02_rb,1.775883e-02_rb,1.710358e-02_rb, & + 1.649769e-02_rb,1.593449e-02_rb,1.540829e-02_rb,1.491429e-02_rb,1.444837e-02_rb, & + 1.400704e-02_rb,1.358729e-02_rb,1.318654e-02_rb,1.280258e-02_rb,1.243346e-02_rb, & + 1.207750e-02_rb,1.173325e-02_rb,1.139941e-02_rb,1.107487e-02_rb,1.075861e-02_rb, & + 1.044975e-02_rb,1.014753e-02_rb,9.851229e-03_rb,9.560240e-03_rb,9.274003e-03_rb, & + 8.992020e-03_rb,8.713845e-03_rb,8.439074e-03_rb,8.167346e-03_rb,7.898331e-03_rb, & + 7.631734e-03_rb,7.367286e-03_rb,7.104742e-03_rb,6.843882e-03_rb,6.584504e-03_rb, & + 6.326424e-03_rb/) + absice3(:,3) = (/ & +! band 3 + 6.933163e-02_rb,8.540475e-02_rb,7.701816e-02_rb,6.771158e-02_rb,5.986953e-02_rb, & + 5.348120e-02_rb,4.824962e-02_rb,4.390563e-02_rb,4.024411e-02_rb,3.711404e-02_rb, & + 3.440426e-02_rb,3.203200e-02_rb,2.993478e-02_rb,2.806474e-02_rb,2.638464e-02_rb, & + 2.486516e-02_rb,2.348288e-02_rb,2.221890e-02_rb,2.105780e-02_rb,1.998687e-02_rb, & + 1.899552e-02_rb,1.807490e-02_rb,1.721750e-02_rb,1.641693e-02_rb,1.566773e-02_rb, & + 1.496515e-02_rb,1.430509e-02_rb,1.368398e-02_rb,1.309865e-02_rb,1.254634e-02_rb, & + 1.202456e-02_rb,1.153114e-02_rb,1.106409e-02_rb,1.062166e-02_rb,1.020224e-02_rb, & + 9.804381e-03_rb,9.426771e-03_rb,9.068205e-03_rb,8.727578e-03_rb,8.403876e-03_rb, & + 8.096160e-03_rb,7.803564e-03_rb,7.525281e-03_rb,7.260560e-03_rb,7.008697e-03_rb, & + 6.769036e-03_rb/) + absice3(:,4) = (/ & +! band 4 + 1.765735e-01_rb,1.382700e-01_rb,1.095129e-01_rb,8.987475e-02_rb,7.591185e-02_rb, & + 6.554169e-02_rb,5.755500e-02_rb,5.122083e-02_rb,4.607610e-02_rb,4.181475e-02_rb, & + 3.822697e-02_rb,3.516432e-02_rb,3.251897e-02_rb,3.021073e-02_rb,2.817876e-02_rb, & + 2.637607e-02_rb,2.476582e-02_rb,2.331871e-02_rb,2.201113e-02_rb,2.082388e-02_rb, & + 1.974115e-02_rb,1.874983e-02_rb,1.783894e-02_rb,1.699922e-02_rb,1.622280e-02_rb, & + 1.550296e-02_rb,1.483390e-02_rb,1.421064e-02_rb,1.362880e-02_rb,1.308460e-02_rb, & + 1.257468e-02_rb,1.209611e-02_rb,1.164628e-02_rb,1.122287e-02_rb,1.082381e-02_rb, & + 1.044725e-02_rb,1.009154e-02_rb,9.755166e-03_rb,9.436783e-03_rb,9.135163e-03_rb, & + 8.849193e-03_rb,8.577856e-03_rb,8.320225e-03_rb,8.075451e-03_rb,7.842755e-03_rb, & + 7.621418e-03_rb/) + absice3(:,5) = (/ & +! band 5 + 2.339673e-01_rb,1.692124e-01_rb,1.291656e-01_rb,1.033837e-01_rb,8.562949e-02_rb, & + 7.273526e-02_rb,6.298262e-02_rb,5.537015e-02_rb,4.927787e-02_rb,4.430246e-02_rb, & + 4.017061e-02_rb,3.669072e-02_rb,3.372455e-02_rb,3.116995e-02_rb,2.894977e-02_rb, & + 2.700471e-02_rb,2.528842e-02_rb,2.376420e-02_rb,2.240256e-02_rb,2.117959e-02_rb, & + 2.007567e-02_rb,1.907456e-02_rb,1.816271e-02_rb,1.732874e-02_rb,1.656300e-02_rb, & + 1.585725e-02_rb,1.520445e-02_rb,1.459852e-02_rb,1.403419e-02_rb,1.350689e-02_rb, & + 1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, & + 1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, & + 9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, & + 7.890412e-03_rb/) + absice3(:,6) = (/ & +! band 6 + 1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, & + 6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, & + 3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, & + 2.479206e-02_rb,2.335051e-02_rb,2.206851e-02_rb,2.092195e-02_rb,1.989108e-02_rb, & + 1.895958e-02_rb,1.811385e-02_rb,1.734245e-02_rb,1.663573e-02_rb,1.598545e-02_rb, & + 1.538456e-02_rb,1.482700e-02_rb,1.430750e-02_rb,1.382150e-02_rb,1.336499e-02_rb, & + 1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, & + 1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, & + 9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, & + 8.114723e-03_rb/) + absice3(:,7) = (/ & +! band 7 + 1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, & + 4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, & + 2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, & + 2.201687e-02_rb,2.096619e-02_rb,2.000112e-02_rb,1.911044e-02_rb,1.828481e-02_rb, & + 1.751641e-02_rb,1.679866e-02_rb,1.612598e-02_rb,1.549360e-02_rb,1.489742e-02_rb, & + 1.433392e-02_rb,1.380002e-02_rb,1.329305e-02_rb,1.281068e-02_rb,1.235084e-02_rb, & + 1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, & + 9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, & + 8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, & + 7.026186e-03_rb/) + absice3(:,8) = (/ & +! band 8 + 6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, & + 4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, & + 2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, & + 2.250808e-02_rb,2.140532e-02_rb,2.038609e-02_rb,1.944018e-02_rb,1.855918e-02_rb, & + 1.773609e-02_rb,1.696504e-02_rb,1.624106e-02_rb,1.555990e-02_rb,1.491793e-02_rb, & + 1.431197e-02_rb,1.373928e-02_rb,1.319743e-02_rb,1.268430e-02_rb,1.219799e-02_rb, & + 1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, & + 9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, & + 8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, & + 7.060305e-03_rb/) + absice3(:,9) = (/ & +! band 9 + 1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, & + 4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, & + 3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, & + 2.305852e-02_rb,2.188966e-02_rb,2.081757e-02_rb,1.982974e-02_rb,1.891599e-02_rb, & + 1.806794e-02_rb,1.727865e-02_rb,1.654227e-02_rb,1.585387e-02_rb,1.520924e-02_rb, & + 1.460476e-02_rb,1.403730e-02_rb,1.350416e-02_rb,1.300293e-02_rb,1.253153e-02_rb, & + 1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, & + 1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, & + 8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, & + 7.964013e-03_rb/) + absice3(:,10) = (/ & +! band 10 + 1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, & + 5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, & + 3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, & + 2.391150e-02_rb,2.263582e-02_rb,2.147549e-02_rb,2.041476e-02_rb,1.944089e-02_rb, & + 1.854342e-02_rb,1.771371e-02_rb,1.694456e-02_rb,1.622989e-02_rb,1.556456e-02_rb, & + 1.494415e-02_rb,1.436491e-02_rb,1.382354e-02_rb,1.331719e-02_rb,1.284339e-02_rb, & + 1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, & + 1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, & + 9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, & + 8.442725e-03_rb/) + absice3(:,11) = (/ & +! band 11 + 1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, & + 5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, & + 3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, & + 2.348414e-02_rb,2.222705e-02_rb,2.108762e-02_rb,2.004936e-02_rb,1.909892e-02_rb, & + 1.822539e-02_rb,1.741975e-02_rb,1.667449e-02_rb,1.598330e-02_rb,1.534084e-02_rb, & + 1.474253e-02_rb,1.418446e-02_rb,1.366325e-02_rb,1.317597e-02_rb,1.272004e-02_rb, & + 1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, & + 1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, & + 9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, & + 8.422115e-03_rb/) + absice3(:,12) = (/ & +! band 12 + 9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, & + 3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, & + 2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, & + 1.852546e-02_rb,1.777763e-02_rb,1.708528e-02_rb,1.644134e-02_rb,1.584009e-02_rb, & + 1.527684e-02_rb,1.474774e-02_rb,1.424955e-02_rb,1.377957e-02_rb,1.333549e-02_rb, & + 1.291534e-02_rb,1.251743e-02_rb,1.214029e-02_rb,1.178265e-02_rb,1.144337e-02_rb, & + 1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, & + 9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, & + 8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, & + 7.947730e-03_rb/) + absice3(:,13) = (/ & +! band 13 + 1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, & + 4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, & + 2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, & + 2.203516e-02_rb,2.096002e-02_rb,1.997579e-02_rb,1.907036e-02_rb,1.823401e-02_rb, & + 1.745879e-02_rb,1.673819e-02_rb,1.606678e-02_rb,1.544003e-02_rb,1.485411e-02_rb, & + 1.430574e-02_rb,1.379215e-02_rb,1.331092e-02_rb,1.285996e-02_rb,1.243746e-02_rb, & + 1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, & + 1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, & + 9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, & + 8.652951e-03_rb/) + absice3(:,14) = (/ & +! band 14 + 1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, & + 4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, & + 2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, & + 2.188910e-02_rb,2.082842e-02_rb,1.985789e-02_rb,1.896553e-02_rb,1.814165e-02_rb, & + 1.737839e-02_rb,1.666927e-02_rb,1.600891e-02_rb,1.539279e-02_rb,1.481712e-02_rb, & + 1.427865e-02_rb,1.377463e-02_rb,1.330266e-02_rb,1.286068e-02_rb,1.244689e-02_rb, & + 1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, & + 1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, & + 9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, & + 8.785184e-03_rb/) + absice3(:,15) = (/ & +! band 15 + 1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, & + 3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, & + 2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, & + 1.925493e-02_rb,1.845331e-02_rb,1.771269e-02_rb,1.702531e-02_rb,1.638493e-02_rb, & + 1.578648e-02_rb,1.522579e-02_rb,1.469940e-02_rb,1.420442e-02_rb,1.373841e-02_rb, & + 1.329931e-02_rb,1.288535e-02_rb,1.249502e-02_rb,1.212700e-02_rb,1.178015e-02_rb, & + 1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, & + 1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, & + 9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, & + 8.560232e-03_rb/) + absice3(:,16) = (/ & +! band 16 + 1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, & + 4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, & + 2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, & + 2.071701e-02_rb,1.967121e-02_rb,1.872692e-02_rb,1.786931e-02_rb,1.708641e-02_rb, & + 1.636846e-02_rb,1.570743e-02_rb,1.509665e-02_rb,1.453052e-02_rb,1.400433e-02_rb, & + 1.351407e-02_rb,1.305631e-02_rb,1.262810e-02_rb,1.222688e-02_rb,1.185044e-02_rb, & + 1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, & + 1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, & + 8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, & + 8.123136e-03_rb/) + +! For LIQFLAG = 0. + absliq0 = 0.0903614_rb + +! For LIQFLAG = 1. In each band, the absorption +! coefficients are listed for a range of effective radii from 2.5 +! to 59.5 microns in increments of 1.0 micron. + absliq1(:, 1) = (/ & +! band 1 + 1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, & + 7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, & + 6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, & + 5.61743e-02_rb, 5.40571e-02_rb, 5.20812e-02_rb, 5.02245e-02_rb, 4.84680e-02_rb, & + 4.67959e-02_rb, 4.51944e-02_rb, 4.36516e-02_rb, 4.21570e-02_rb, 4.07015e-02_rb, & + 3.92766e-02_rb, 3.78747e-02_rb, 3.64886e-02_rb, 3.53632e-02_rb, 3.41992e-02_rb, & + 3.31016e-02_rb, 3.20643e-02_rb, 3.10817e-02_rb, 3.01490e-02_rb, 2.92620e-02_rb, & + 2.84171e-02_rb, 2.76108e-02_rb, 2.68404e-02_rb, 2.61031e-02_rb, 2.53966e-02_rb, & + 2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, & + 2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, & + 1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, & + 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/) + absliq1(:, 2) = (/ & +! band 2 + 2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, & + 1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, & + 8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, & + 5.85359e-02_rb, 5.51020e-02_rb, 5.20032e-02_rb, 4.91916e-02_rb, 4.66283e-02_rb, & + 4.42813e-02_rb, 4.21236e-02_rb, 4.01330e-02_rb, 3.82905e-02_rb, 3.65797e-02_rb, & + 3.49869e-02_rb, 3.35002e-02_rb, 3.21090e-02_rb, 3.08957e-02_rb, 2.97601e-02_rb, & + 2.86966e-02_rb, 2.76984e-02_rb, 2.67599e-02_rb, 2.58758e-02_rb, 2.50416e-02_rb, & + 2.42532e-02_rb, 2.35070e-02_rb, 2.27997e-02_rb, 2.21284e-02_rb, 2.14904e-02_rb, & + 2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, & + 1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, & + 1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, & + 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/) + absliq1(:, 3) = (/ & +! band 3 + 2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, & + 1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, & + 8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, & + 5.53402e-02_rb, 5.19087e-02_rb, 4.88455e-02_rb, 4.60951e-02_rb, 4.36124e-02_rb, & + 4.13607e-02_rb, 3.93096e-02_rb, 3.74338e-02_rb, 3.57119e-02_rb, 3.41261e-02_rb, & + 3.26610e-02_rb, 3.13036e-02_rb, 3.00425e-02_rb, 2.88497e-02_rb, 2.78077e-02_rb, & + 2.68317e-02_rb, 2.59158e-02_rb, 2.50545e-02_rb, 2.42430e-02_rb, 2.34772e-02_rb, & + 2.27533e-02_rb, 2.20679e-02_rb, 2.14181e-02_rb, 2.08011e-02_rb, 2.02145e-02_rb, & + 1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, & + 1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, & + 1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, & + 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/) + absliq1(:, 4) = (/ & +! band 4 + 3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, & + 1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, & + 7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, & + 5.27534e-02_rb, 4.95384e-02_rb, 4.66690e-02_rb, 4.40925e-02_rb, 4.17664e-02_rb, & + 3.96559e-02_rb, 3.77326e-02_rb, 3.59727e-02_rb, 3.43561e-02_rb, 3.28662e-02_rb, & + 3.14885e-02_rb, 3.02110e-02_rb, 2.90231e-02_rb, 2.78948e-02_rb, 2.69109e-02_rb, & + 2.59884e-02_rb, 2.51217e-02_rb, 2.43058e-02_rb, 2.35364e-02_rb, 2.28096e-02_rb, & + 2.21218e-02_rb, 2.14700e-02_rb, 2.08515e-02_rb, 2.02636e-02_rb, 1.97041e-02_rb, & + 1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, & + 1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, & + 1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, & + 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/) + absliq1(:, 5) = (/ & +! band 5 + 2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, & + 1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, & + 7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, & + 5.06538e-02_rb, 4.76866e-02_rb, 4.50301e-02_rb, 4.26374e-02_rb, 4.04704e-02_rb, & + 3.84981e-02_rb, 3.66948e-02_rb, 3.50394e-02_rb, 3.35141e-02_rb, 3.21038e-02_rb, & + 3.07957e-02_rb, 2.95788e-02_rb, 2.84438e-02_rb, 2.73790e-02_rb, 2.64390e-02_rb, & + 2.55565e-02_rb, 2.47263e-02_rb, 2.39437e-02_rb, 2.32047e-02_rb, 2.25056e-02_rb, & + 2.18433e-02_rb, 2.12149e-02_rb, 2.06177e-02_rb, 2.00495e-02_rb, 1.95081e-02_rb, & + 1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, & + 1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, & + 1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, & + 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/) + absliq1(:, 6) = (/ & +! band 6 + 8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, & + 7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, & + 5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, & + 4.48148e-02_rb, 4.28431e-02_rb, 4.10231e-02_rb, 3.93332e-02_rb, 3.77563e-02_rb, & + 3.62785e-02_rb, 3.48882e-02_rb, 3.35758e-02_rb, 3.23333e-02_rb, 3.11536e-02_rb, & + 3.00310e-02_rb, 2.89601e-02_rb, 2.79365e-02_rb, 2.70502e-02_rb, 2.62618e-02_rb, & + 2.55025e-02_rb, 2.47728e-02_rb, 2.40726e-02_rb, 2.34013e-02_rb, 2.27583e-02_rb, & + 2.21422e-02_rb, 2.15522e-02_rb, 2.09869e-02_rb, 2.04453e-02_rb, 1.99260e-02_rb, & + 1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, & + 1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, & + 1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, & + 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/) + absliq1(:, 7) = (/ & +! band 7 + 4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, & + 6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, & + 4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, & + 4.18480e-02_rb, 4.02169e-02_rb, 3.86658e-02_rb, 3.71992e-02_rb, 3.58168e-02_rb, & + 3.45155e-02_rb, 3.32912e-02_rb, 3.21390e-02_rb, 3.10538e-02_rb, 3.00307e-02_rb, & + 2.90651e-02_rb, 2.81524e-02_rb, 2.72885e-02_rb, 2.62821e-02_rb, 2.55744e-02_rb, & + 2.48799e-02_rb, 2.42029e-02_rb, 2.35460e-02_rb, 2.29108e-02_rb, 2.22981e-02_rb, & + 2.17079e-02_rb, 2.11402e-02_rb, 2.05945e-02_rb, 2.00701e-02_rb, 1.95663e-02_rb, & + 1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, & + 1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, & + 1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, & + 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/) + absliq1(:, 8) = (/ & +! band 8 + 1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, & + 5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, & + 4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, & + 4.01850e-02_rb, 3.86892e-02_rb, 3.72461e-02_rb, 3.58722e-02_rb, 3.45749e-02_rb, & + 3.33564e-02_rb, 3.22155e-02_rb, 3.11494e-02_rb, 3.01541e-02_rb, 2.92253e-02_rb, & + 2.83584e-02_rb, 2.75488e-02_rb, 2.67925e-02_rb, 2.57692e-02_rb, 2.50704e-02_rb, & + 2.43918e-02_rb, 2.37350e-02_rb, 2.31005e-02_rb, 2.24888e-02_rb, 2.18996e-02_rb, & + 2.13325e-02_rb, 2.07870e-02_rb, 2.02623e-02_rb, 1.97577e-02_rb, 1.92724e-02_rb, & + 1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, & + 1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, & + 1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, & + 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/) + absliq1(:, 9) = (/ & +! band 9 + 6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, & + 6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, & + 4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, & + 4.01261e-02_rb, 3.85171e-02_rb, 3.69860e-02_rb, 3.55442e-02_rb, 3.41954e-02_rb, & + 3.29384e-02_rb, 3.17693e-02_rb, 3.06832e-02_rb, 2.96745e-02_rb, 2.87374e-02_rb, & + 2.78662e-02_rb, 2.70557e-02_rb, 2.63008e-02_rb, 2.52450e-02_rb, 2.45424e-02_rb, & + 2.38656e-02_rb, 2.32144e-02_rb, 2.25885e-02_rb, 2.19873e-02_rb, 2.14099e-02_rb, & + 2.08554e-02_rb, 2.03230e-02_rb, 1.98116e-02_rb, 1.93203e-02_rb, 1.88482e-02_rb, & + 1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, & + 1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, & + 1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, & + 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/) + absliq1(:,10) = (/ & +! band 10 + 7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, & + 6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, & + 5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, & + 4.17569e-02_rb, 3.99328e-02_rb, 3.82224e-02_rb, 3.66265e-02_rb, 3.51416e-02_rb, & + 3.37617e-02_rb, 3.24798e-02_rb, 3.12887e-02_rb, 3.01812e-02_rb, 2.91505e-02_rb, & + 2.81900e-02_rb, 2.72939e-02_rb, 2.64568e-02_rb, 2.54165e-02_rb, 2.46832e-02_rb, & + 2.39783e-02_rb, 2.33017e-02_rb, 2.26531e-02_rb, 2.20314e-02_rb, 2.14359e-02_rb, & + 2.08653e-02_rb, 2.03187e-02_rb, 1.97947e-02_rb, 1.92924e-02_rb, 1.88106e-02_rb, & + 1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, & + 1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, & + 1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, & + 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/) + absliq1(:,11) = (/ & +! band 11 + 1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, & + 9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, & + 6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, & + 4.66014e-02_rb, 4.40644e-02_rb, 4.17706e-02_rb, 3.96910e-02_rb, 3.77998e-02_rb, & + 3.60742e-02_rb, 3.44947e-02_rb, 3.30442e-02_rb, 3.17079e-02_rb, 3.04730e-02_rb, & + 2.93283e-02_rb, 2.82642e-02_rb, 2.72720e-02_rb, 2.61789e-02_rb, 2.53277e-02_rb, & + 2.45237e-02_rb, 2.37635e-02_rb, 2.30438e-02_rb, 2.23615e-02_rb, 2.17140e-02_rb, & + 2.10987e-02_rb, 2.05133e-02_rb, 1.99557e-02_rb, 1.94241e-02_rb, 1.89166e-02_rb, & + 1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, & + 1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, & + 1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, & + 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/) + absliq1(:,12) = (/ & +! band 12 + 3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, & + 3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, & + 3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, & + 2.84120e-02_rb, 2.75525e-02_rb, 2.67361e-02_rb, 2.59618e-02_rb, 2.52280e-02_rb, & + 2.45327e-02_rb, 2.38736e-02_rb, 2.32487e-02_rb, 2.26558e-02_rb, 2.20929e-02_rb, & + 2.15579e-02_rb, 2.10491e-02_rb, 2.05648e-02_rb, 1.99749e-02_rb, 1.95704e-02_rb, & + 1.91731e-02_rb, 1.87839e-02_rb, 1.84032e-02_rb, 1.80315e-02_rb, 1.76689e-02_rb, & + 1.73155e-02_rb, 1.69712e-02_rb, 1.66362e-02_rb, 1.63101e-02_rb, 1.59928e-02_rb, & + 1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, & + 1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, & + 1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, & + 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/) + absliq1(:,13) = (/ & +! band 13 + 3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, & + 4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, & + 3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, & + 3.11264e-02_rb, 3.00704e-02_rb, 2.90784e-02_rb, 2.81463e-02_rb, 2.72702e-02_rb, & + 2.64460e-02_rb, 2.56698e-02_rb, 2.49381e-02_rb, 2.42475e-02_rb, 2.35948e-02_rb, & + 2.29774e-02_rb, 2.23925e-02_rb, 2.18379e-02_rb, 2.11793e-02_rb, 2.07076e-02_rb, & + 2.02470e-02_rb, 1.97981e-02_rb, 1.93613e-02_rb, 1.89367e-02_rb, 1.85243e-02_rb, & + 1.81240e-02_rb, 1.77356e-02_rb, 1.73588e-02_rb, 1.69935e-02_rb, 1.66392e-02_rb, & + 1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, & + 1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, & + 1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, & + 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/) + absliq1(:,14) = (/ & +! band 14 + 1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, & + 3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, & + 3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, & + 2.66604e-02_rb, 2.58654e-02_rb, 2.51161e-02_rb, 2.44100e-02_rb, 2.37440e-02_rb, & + 2.31154e-02_rb, 2.25215e-02_rb, 2.19599e-02_rb, 2.14282e-02_rb, 2.09242e-02_rb, & + 2.04459e-02_rb, 1.99915e-02_rb, 1.95594e-02_rb, 1.90254e-02_rb, 1.86598e-02_rb, & + 1.82996e-02_rb, 1.79455e-02_rb, 1.75983e-02_rb, 1.72584e-02_rb, 1.69260e-02_rb, & + 1.66013e-02_rb, 1.62843e-02_rb, 1.59752e-02_rb, 1.56737e-02_rb, 1.53799e-02_rb, & + 1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, & + 1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, & + 1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, & + 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/) + absliq1(:,15) = (/ & +! band 15 + 5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, & + 2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, & + 2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, & + 1.86028e-02_rb, 1.81742e-02_rb, 1.77693e-02_rb, 1.73866e-02_rb, 1.70244e-02_rb, & + 1.66815e-02_rb, 1.63563e-02_rb, 1.60477e-02_rb, 1.57544e-02_rb, 1.54755e-02_rb, & + 1.52097e-02_rb, 1.49564e-02_rb, 1.47146e-02_rb, 1.43684e-02_rb, 1.41728e-02_rb, & + 1.39762e-02_rb, 1.37797e-02_rb, 1.35838e-02_rb, 1.33891e-02_rb, 1.31961e-02_rb, & + 1.30051e-02_rb, 1.28164e-02_rb, 1.26302e-02_rb, 1.24466e-02_rb, 1.22659e-02_rb, & + 1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, & + 1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, & + 1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, & + 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/) + absliq1(:,16) = (/ & +! band 16 + 5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, & + 5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, & + 3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, & + 2.87856e-02_rb, 2.75474e-02_rb, 2.64223e-02_rb, 2.53953e-02_rb, 2.44542e-02_rb, & + 2.35885e-02_rb, 2.27894e-02_rb, 2.20494e-02_rb, 2.13622e-02_rb, 2.07222e-02_rb, & + 2.01246e-02_rb, 1.95654e-02_rb, 1.90408e-02_rb, 1.84398e-02_rb, 1.80021e-02_rb, & + 1.75816e-02_rb, 1.71775e-02_rb, 1.67889e-02_rb, 1.64152e-02_rb, 1.60554e-02_rb, & + 1.57089e-02_rb, 1.53751e-02_rb, 1.50531e-02_rb, 1.47426e-02_rb, 1.44428e-02_rb, & + 1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, & + 1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, & + 1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, & + 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/) + + end subroutine lwcldpr + + end module rrtmg_lw_init + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module rrtmg_lw_rad + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- +! +! **************************************************************************** +! * * +! * RRTMG_LW * +! * * +! * * +! * * +! * a rapid radiative transfer model * +! * for the longwave region * +! * for application to general circulation models * +! * * +! * * +! * Atmospheric and Environmental Research, Inc. * +! * 131 Hartwell Avenue * +! * Lexington, MA 02421 * +! * * +! * * +! * Eli J. Mlawer * +! * Jennifer S. Delamere * +! * Michael J. Iacono * +! * Shepard A. Clough * +! * * +! * * +! * * +! * * +! * * +! * * +! * email: miacono@aer.com * +! * email: emlawer@aer.com * +! * email: jdelamer@aer.com * +! * * +! * The authors wish to acknowledge the contributions of the * +! * following people: Steven J. Taubman, Karen Cady-Pereira, * +! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. * +! * * +! **************************************************************************** + +! -------- Modules -------- + use parkind, only : im => kind_im, rb => kind_rb + use rrlw_vsn + use mcica_subcol_gen_lw, only: mcica_subcol_lw + use rrtmg_lw_cldprmc, only: cldprmc +! *** Move the required call to rrtmg_lw_ini below and the following +! use association to the GCM initialization area *** +! use rrtmg_lw_init, only: rrtmg_lw_ini + use rrtmg_lw_rtrnmc, only: rtrnmc + use rrtmg_lw_setcoef, only: setcoef + use rrtmg_lw_taumol, only: taumol + + implicit none + +! public interfaces/functions/subroutines + public :: rrtmg_lw, inatm + +!------------------------------------------------------------------ + contains +!------------------------------------------------------------------ + +!------------------------------------------------------------------ +! Public subroutines +!------------------------------------------------------------------ + + subroutine rrtmg_lw & + (ncol ,nlay ,icld , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , & + inflglw ,iceflglw,liqflglw,cldfmcl , & + taucmcl ,ciwpmcl ,clwpmcl , cswpmcl ,reicmcl ,relqmcl , resnmcl , & + tauaer , & + uflx ,dflx ,hr ,uflxc ,dflxc, hrc, & + uflxcln ,dflxcln, calc_clean_atm_diag ) + +! -------- Description -------- + +! This program is the driver subroutine for RRTMG_LW, the AER LW radiation +! model for application to GCMs, that has been adapted from RRTM_LW for +! improved efficiency. +! +! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization +! area, since this has to be called only once. +! +! This routine: +! a) calls INATM to read in the atmospheric profile from GCM; +! all layering in RRTMG is ordered from surface to toa. +! b) calls CLDPRMC to set cloud optical depth for McICA based +! on input cloud properties +! c) calls SETCOEF to calculate various quantities needed for +! the radiative transfer algorithm +! d) calls TAUMOL to calculate gaseous optical depths for each +! of the 16 spectral bands +! e) calls RTRNMC (for both clear and cloudy profiles) to perform the +! radiative transfer calculation using McICA, the Monte-Carlo +! Independent Column Approximation, to represent sub-grid scale +! cloud variability +! f) passes the necessary fluxes and cooling rates back to GCM +! +! Two modes of operation are possible: +! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use +! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. +! +! 1) Standard, single forward model calculation (imca = 0) +! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., +! JC, 2003) method is applied to the forward model calculation (imca = 1) +! +! This call to RRTMG_LW must be preceeded by a call to the module +! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator, +! which will provide the cloud physical or cloud optical properties +! on the RRTMG quadrature point (ngpt) dimension. +! Two random number generators are available for use when imca = 1. +! This is chosen by setting flag irnd on input to mcica_subcol_gen_lw. +! 1) KISSVEC (irnd = 0) +! 2) Mersenne-Twister (irnd = 1) +! +! Two methods of cloud property input are possible: +! Cloud properties can be input in one of two ways (controlled by input +! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions +! and subroutine rrtmg_lw_cldprop.f90 for further details): +! +! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0) +! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2); +! cloud optical properties are calculated by cldprop or cldprmc based +! on input settings of iceflglw and liqflglw. Ice particle size provided +! must be appropriately defined for the ice parameterization selected. +! +! One method of aerosol property input is possible: +! Aerosol properties can be input in only one way (controlled by input +! flag iaer; see text file rrtmg_lw_instructions for further details): +! +! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10); +! band average optical depth at the mid-point of each spectral band. +! RRTMG_LW currently treats only aerosol absorption; +! scattering capability is not presently available. +! +! +! ------- Modifications ------- +! +! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced +! set of g-points for application to GCMs. +! +!-- Original version (derived from RRTM_LW), reduction of g-points, other +! revisions for use with GCMs. +! 1999: M. J. Iacono, AER, Inc. +!-- Adapted for use with NCAR/CAM. +! May 2004: M. J. Iacono, AER, Inc. +!-- Revised to add McICA capability. +! Nov 2005: M. J. Iacono, AER, Inc. +!-- Conversion to F90 formatting for consistency with rrtmg_sw. +! Feb 2007: M. J. Iacono, AER, Inc. +!-- Modifications to formatting to use assumed-shape arrays. +! Aug 2007: M. J. Iacono, AER, Inc. +!-- Modified to add longwave aerosol absorption. +! Apr 2008: M. J. Iacono, AER, Inc. + +! --------- Modules ---------- + + use parrrtm, only : nbndlw, ngptlw, maxxsec, mxmol + use rrlw_con, only: fluxfac, heatfac, oneminus, pi + use rrlw_wvn, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: ncol ! Number of horizontal columns + integer(kind=im), intent(in) :: nlay ! Number of model layers + integer(kind=im), intent(inout) :: icld ! Cloud overlap method + ! 0: Clear only + ! 1: Random + ! 2: Maximum/random + ! 3: Maximum + ! 4: Exponential + ! 5: Exponential/random + real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K) + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity + ! Dimensions: (ncol,nbndlw) + + integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties + integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification + integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification + + real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice particle effective size (microns) + ! Dimensions: (ncol,nlay) + ! specific definition of reicmcl depends on setting of iceflglw: + ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflglw = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: resnmcl(:,:) ! Snow effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth + ! Dimensions: (ngptlw,ncol,nlay) +! real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo + ! Dimensions: (ngptlw,ncol,nlay) + ! for future expansion + ! lw scattering not yet available +! real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter + ! Dimensions: (ngptlw,ncol,nlay) + ! for future expansion + ! lw scattering not yet available + real(kind=rb), intent(in) :: tauaer(:,:,:) ! aerosol optical depth + ! at mid-point of LW spectral bands + ! Dimensions: (ncol,nlay,nbndlw) +! real(kind=rb), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo + ! Dimensions: (ncol,nlay,nbndlw) + ! for future expansion + ! (lw aerosols/scattering not yet available) +! real(kind=rb), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter + ! Dimensions: (ncol,nlay,nbndlw) + ! for future expansion + ! (lw aerosols/scattering not yet available) + integer, intent(in) :: calc_clean_atm_diag ! Control for clean air diagnositic calls for WRF-Chem + +! ----- Output ----- + + real(kind=rb), intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: uflxcln(:,:) ! Clean sky longwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: dflxcln(:,:) ! Clean sky longwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + +! ----- Local ----- + +! Control + integer(kind=im) :: nlayers ! total number of layers + integer(kind=im) :: istart ! beginning band of calculation + integer(kind=im) :: iend ! ending band of calculation + integer(kind=im) :: iout ! output option flag (inactive) + integer(kind=im) :: iaer ! aerosol option flag + integer(kind=im) :: iplon ! column loop index + integer(kind=im) :: imca ! flag for mcica [0=off, 1=on] + integer(kind=im) :: ims ! value for changing mcica permute seed + integer(kind=im) :: k ! layer loop index + integer(kind=im) :: ig ! g-point loop index + +! Atmosphere + real(kind=rb) :: pavel(nlay+1) ! layer pressures (mb) + real(kind=rb) :: tavel(nlay+1) ! layer temperatures (K) + real(kind=rb) :: pz(0:nlay+1) ! level (interface) pressures (hPa, mb) + real(kind=rb) :: tz(0:nlay+1) ! level (interface) temperatures (K) + real(kind=rb) :: tbound ! surface temperature (K) + real(kind=rb) :: coldry(nlay+1) ! dry air column density (mol/cm2) + real(kind=rb) :: wbrodl(nlay+1) ! broadening gas column density (mol/cm2) + real(kind=rb) :: wkl(mxmol,nlay+1) ! molecular amounts (mol/cm-2) + real(kind=rb) :: wx(maxxsec,nlay+1) ! cross-section amounts (mol/cm-2) + real(kind=rb) :: pwvcm ! precipitable water vapor (cm) + real(kind=rb) :: semiss(nbndlw) ! lw surface emissivity + real(kind=rb) :: fracs(nlay+1,ngptlw) ! + real(kind=rb) :: taug(nlay+1,ngptlw) ! gaseous optical depths + real(kind=rb) :: taut(nlay+1,ngptlw) ! gaseous + aerosol optical depths + + real(kind=rb) :: taua(nlay+1,nbndlw) ! aerosol optical depth +! real(kind=rb) :: ssaa(nlay+1,nbndlw) ! aerosol single scattering albedo + ! for future expansion + ! (lw aerosols/scattering not yet available) +! real(kind=rb) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter + ! for future expansion + ! (lw aerosols/scattering not yet available) + +! Atmosphere - setcoef + integer(kind=im) :: laytrop ! tropopause layer index + integer(kind=im) :: jp(nlay+1) ! lookup table index + integer(kind=im) :: jt(nlay+1) ! lookup table index + integer(kind=im) :: jt1(nlay+1) ! lookup table index + real(kind=rb) :: planklay(nlay+1,nbndlw)! + real(kind=rb) :: planklev(0:nlay+1,nbndlw)! + real(kind=rb) :: plankbnd(nbndlw) ! + + real(kind=rb) :: colh2o(nlay+1) ! column amount (h2o) + real(kind=rb) :: colco2(nlay+1) ! column amount (co2) + real(kind=rb) :: colo3(nlay+1) ! column amount (o3) + real(kind=rb) :: coln2o(nlay+1) ! column amount (n2o) + real(kind=rb) :: colco(nlay+1) ! column amount (co) + real(kind=rb) :: colch4(nlay+1) ! column amount (ch4) + real(kind=rb) :: colo2(nlay+1) ! column amount (o2) + real(kind=rb) :: colbrd(nlay+1) ! column amount (broadening gases) + + integer(kind=im) :: indself(nlay+1) + integer(kind=im) :: indfor(nlay+1) + real(kind=rb) :: selffac(nlay+1) + real(kind=rb) :: selffrac(nlay+1) + real(kind=rb) :: forfac(nlay+1) + real(kind=rb) :: forfrac(nlay+1) + + integer(kind=im) :: indminor(nlay+1) + real(kind=rb) :: minorfrac(nlay+1) + real(kind=rb) :: scaleminor(nlay+1) + real(kind=rb) :: scaleminorn2(nlay+1) + + real(kind=rb) :: & ! + fac00(nlay+1), fac01(nlay+1), & + fac10(nlay+1), fac11(nlay+1) + real(kind=rb) :: & ! + rat_h2oco2(nlay+1),rat_h2oco2_1(nlay+1), & + rat_h2oo3(nlay+1),rat_h2oo3_1(nlay+1), & + rat_h2on2o(nlay+1),rat_h2on2o_1(nlay+1), & + rat_h2och4(nlay+1),rat_h2och4_1(nlay+1), & + rat_n2oco2(nlay+1),rat_n2oco2_1(nlay+1), & + rat_o3co2(nlay+1),rat_o3co2_1(nlay+1) + +! Atmosphere/clouds - cldprop + integer(kind=im) :: ncbands ! number of cloud spectral bands + integer(kind=im) :: inflag ! flag for cloud property method + integer(kind=im) :: iceflag ! flag for ice cloud properties + integer(kind=im) :: liqflag ! flag for liquid cloud properties + +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb) :: cldfmc(ngptlw,nlay+1) ! cloud fraction [mcica] + real(kind=rb) :: ciwpmc(ngptlw,nlay+1) ! in-cloud ice water path [mcica] + real(kind=rb) :: clwpmc(ngptlw,nlay+1) ! in-cloud liquid water path [mcica] + real(kind=rb) :: cswpmc(ngptlw,nlay+1) ! in-cloud snow path [mcica] + real(kind=rb) :: relqmc(nlay+1) ! liquid particle effective radius (microns) + real(kind=rb) :: reicmc(nlay+1) ! ice particle effective size (microns) + real(kind=rb) :: resnmc(nlay+1) ! snow particle effective size (microns) + real(kind=rb) :: taucmc(ngptlw,nlay+1) ! in-cloud optical depth [mcica] +! real(kind=rb) :: ssacmc(ngptlw,nlay+1) ! in-cloud single scattering albedo [mcica] + ! for future expansion + ! (lw scattering not yet available) +! real(kind=rb) :: asmcmc(ngptlw,nlay+1) ! in-cloud asymmetry parameter [mcica] + ! for future expansion + ! (lw scattering not yet available) + +! Output + real(kind=rb) :: totuflux(0:nlay+1) ! upward longwave flux (w/m2) + real(kind=rb) :: totdflux(0:nlay+1) ! downward longwave flux (w/m2) + real(kind=rb) :: fnet(0:nlay+1) ! net longwave flux (w/m2) + real(kind=rb) :: htr(0:nlay+1) ! longwave heating rate (k/day) + real(kind=rb) :: totuclfl(0:nlay+1) ! clear sky upward longwave flux (w/m2) + real(kind=rb) :: totdclfl(0:nlay+1) ! clear sky downward longwave flux (w/m2) + real(kind=rb) :: fnetc(0:nlay+1) ! clear sky net longwave flux (w/m2) + real(kind=rb) :: htrc(0:nlay+1) ! clear sky longwave heating rate (k/day) + real(kind=rb) :: totuclnlfl(0:nlay+1) ! clean sky upward longwave flux (w/m2) + real(kind=rb) :: totdclnlfl(0:nlay+1) ! clean sky downward longwave flux (w/m2) + real(kind=rb) :: fnetcln(0:nlay+1) ! clean sky net longwave flux (w/m2) + real(kind=rb) :: htrcln(0:nlay+1) ! clean sky longwave heating rate (k/day) + +! +! Initializations + +!jm not thread safe oneminus = 1._rb - 1.e-6_rb +!jm not thread safe pi = 2._rb * asin(1._rb) +!jm not thread safe fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4 + istart = 1 + iend = 16 + iout = 0 + ims = 1 + +! Set imca to select calculation type: +! imca = 0, use standard forward model calculation +! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability + +! *** This version uses McICA (imca = 1) *** + +! Set icld to select of clear or cloud calculation and cloud overlap method +! icld = 0, clear only +! icld = 1, with clouds using random cloud overlap +! icld = 2, with clouds using maximum/random cloud overlap +! icld = 3, with clouds using maximum cloud overlap (McICA only) +! icld = 4, with clouds using exponential cloud overlap (McICA only) +! icld = 5, with clouds using exponential/random cloud overlap (McICA only) + +! Set iaer to select aerosol option +! iaer = 0, no aerosols +! icld = 10, input total aerosol optical depth (tauaer) directly + iaer = 10 + +! Call model and data initialization, compute lookup tables, perform +! reduction of g-points from 256 to 140 for input absorption coefficient +! data and other arrays. +! +! In a GCM this call should be placed in the model initialization +! area, since this has to be called only once. +! call rrtmg_lw_ini(cpdair) + +! This is the main longitude/column loop within RRTMG. + do iplon = 1, ncol + +! Prepare atmospheric profile from GCM for use in RRTMG, and define +! other input parameters. + + call inatm (iplon, nlay, icld, iaer, & + play, plev, tlay, tlev, tsfc, h2ovmr, & + o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, & + cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, & + cldfmcl, taucmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, tauaer, & + nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, & + wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, & + cldfmc, taucmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, taua) + +! For cloudy atmosphere, use cldprop to set cloud optical properties based on +! input cloud physical properties. Select method based on choices described +! in cldprop. Cloud fraction, water path, liquid droplet and ice particle +! effective radius must be passed into cldprop. Cloud fraction and cloud +! optical depth are transferred to rrtmg_lw arrays in cldprop. + + call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, & + clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc) + +! Calculate information needed by the radiative transfer routine +! that is specific to this atmosphere, especially some of the +! coefficients and indices needed to compute the optical depths +! by interpolating data from stored reference atmospheres. + + call setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, & + coldry, wkl, wbrodl, & + laytrop, jp, jt, jt1, planklay, planklev, plankbnd, & + colh2o, colco2, colo3, coln2o, colco, colch4, colo2, & + colbrd, fac00, fac01, fac10, fac11, & + rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & + rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, & + rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + minorfrac, scaleminor, scaleminorn2, indminor) + +! Calculate the gaseous optical depths and Planck fractions for +! each longwave spectral band. + + call taumol(nlayers, pavel, wx, coldry, & + laytrop, jp, jt, jt1, planklay, planklev, plankbnd, & + colh2o, colco2, colo3, coln2o, colco, colch4, colo2, & + colbrd, fac00, fac01, fac10, fac11, & + rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, & + rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, & + rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + minorfrac, scaleminor, scaleminorn2, indminor, & + fracs, taug) + + +! Combine gaseous and aerosol optical depths, if aerosol active + if (iaer .eq. 0) then + do k = 1, nlayers + do ig = 1, ngptlw + taut(k,ig) = taug(k,ig) + enddo + enddo + elseif (iaer .eq. 10) then + do k = 1, nlayers + do ig = 1, ngptlw + taut(k,ig) = taug(k,ig) + taua(k,ngb(ig)) + enddo + enddo + endif + +! Call the radiative transfer routine. +! Either routine can be called to do clear sky calculation. If clouds +! are present, then select routine based on cloud overlap assumption +! to be used. Clear sky calculation is done simultaneously. +! For McICA, RTRNMC is called for clear and cloudy calculations. + +#if (WRF_CHEM == 1) + ! Call the radiative transfer routine for "clean" sky first, + ! passing taug rather than taut so we have no aerosol influence. + ! We will keep totuclnlfl, totdclnlfl, fnetcln, and htrcln, + ! and then overwrite the rest with the second call to rtrnmc. + if(calc_clean_atm_diag .gt. 0)then + call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, & + cldfmc, taucmc, planklay, planklev, plankbnd, & + pwvcm, fracs, taug, & + totuclnlfl, totdclnlfl, fnetcln, htrcln, & + totuclfl, totdclfl, fnetc, htrc ) + else + do k = 0, nlayers + totuclnlfl(k) = 0.0 + totdclnlfl(k) = 0.0 + end do + end if +#else + do k = 0, nlayers + totuclnlfl(k) = 0.0 + totdclnlfl(k) = 0.0 + end do +#endif + call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, & + cldfmc, taucmc, planklay, planklev, plankbnd, & + pwvcm, fracs, taut, & + totuflux, totdflux, fnet, htr, & + totuclfl, totdclfl, fnetc, htrc ) + +! Transfer up and down fluxes and heating rate to output arrays. +! Vertical indexing goes from bottom to top; reverse here for GCM if necessary. + + do k = 0, nlayers + uflx(iplon,k+1) = totuflux(k) + dflx(iplon,k+1) = totdflux(k) + uflxc(iplon,k+1) = totuclfl(k) + dflxc(iplon,k+1) = totdclfl(k) + uflxcln(iplon,k+1) = totuclnlfl(k) + dflxcln(iplon,k+1) = totdclnlfl(k) + enddo + do k = 0, nlayers-1 + hr(iplon,k+1) = htr(k) + hrc(iplon,k+1) = htrc(k) + enddo + + enddo + + end subroutine rrtmg_lw + +!*************************************************************************** + subroutine inatm (iplon, nlay, icld, iaer, & + play, plev, tlay, tlev, tsfc, h2ovmr, & + o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, & + cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, & + cldfmcl, taucmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, tauaer, & + nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, & + wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, & + cldfmc, taucmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, taua) +!*************************************************************************** +! +! Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW. +! Set other RRTMG_LW input parameters. +! +!*************************************************************************** + +! --------- Modules ---------- + + use parrrtm, only : nbndlw, ngptlw, nmol, maxxsec, mxmol + use rrlw_con, only: fluxfac, heatfac, oneminus, pi, grav, avogad + use rrlw_wvn, only: ng, nspa, nspb, wavenum1, wavenum2, delwave, ixindx + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: iplon ! column loop index + integer(kind=im), intent(in) :: nlay ! Number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud and cloud overlap flag + integer(kind=im), intent(in) :: iaer ! aerosol option flag + + real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K) + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity + ! Dimensions: (ncol,nbndlw) + + integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties + integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification + integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification + + real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: resnmcl(:,:) ! Snow effective size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth + ! Dimensions: (ngptlw,ncol,nlay) + real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth + ! Dimensions: (ncol,nlay,nbndlw) + +! ----- Output ----- +! Atmosphere + integer(kind=im), intent(out) :: nlayers ! number of layers + + real(kind=rb), intent(out) :: pavel(:) ! layer pressures (mb) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: tavel(:) ! layer temperatures (K) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb) + ! Dimensions: (0:nlay) + real(kind=rb), intent(out) :: tz(0:) ! level (interface) temperatures (K) + ! Dimensions: (0:nlay) + real(kind=rb), intent(out) :: tbound ! surface temperature (K) + real(kind=rb), intent(out) :: coldry(:) ! dry air column density (mol/cm2) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: wbrodl(:) ! broadening gas column density (mol/cm2) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2) + ! Dimensions: (mxmol,nlay) + real(kind=rb), intent(out) :: wx(:,:) ! cross-section amounts (mol/cm-2) + ! Dimensions: (maxxsec,nlay) + real(kind=rb), intent(out) :: pwvcm ! precipitable water vapor (cm) + real(kind=rb), intent(out) :: semiss(:) ! lw surface emissivity + ! Dimensions: (nbndlw) + +! Atmosphere/clouds - cldprop + integer(kind=im), intent(out) :: inflag ! flag for cloud property method + integer(kind=im), intent(out) :: iceflag ! flag for ice cloud properties + integer(kind=im), intent(out) :: liqflag ! flag for liquid cloud properties + + real(kind=rb), intent(out) :: cldfmc(:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=rb), intent(out) :: ciwpmc(:,:) ! in-cloud ice water path [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=rb), intent(out) :: clwpmc(:,:) ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=rb), intent(out) :: cswpmc(:,:) ! in-cloud snow path [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=rb), intent(out) :: relqmc(:) ! liquid particle effective radius (microns) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: reicmc(:) ! ice particle effective size (microns) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: resnmc(:) ! snow effective size (microns) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: taucmc(:,:) ! in-cloud optical depth [mcica] + ! Dimensions: (ngptlw,nlay) + real(kind=rb), intent(out) :: taua(:,:) ! aerosol optical depth + ! Dimensions: (nlay,nbndlw) + + +! ----- Local ----- + real(kind=rb), parameter :: amd = 28.9660_rb ! Effective molecular weight of dry air (g/mol) + real(kind=rb), parameter :: amw = 18.0160_rb ! Molecular weight of water vapor (g/mol) +! real(kind=rb), parameter :: amc = 44.0098_rb ! Molecular weight of carbon dioxide (g/mol) +! real(kind=rb), parameter :: amo = 47.9998_rb ! Molecular weight of ozone (g/mol) +! real(kind=rb), parameter :: amo2 = 31.9999_rb ! Molecular weight of oxygen (g/mol) +! real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol) +! real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol) +! real(kind=rb), parameter :: amc11 = 137.3684_rb ! Molecular weight of CFC11 (g/mol) - CCL3F +! real(kind=rb), parameter :: amc12 = 120.9138_rb ! Molecular weight of CFC12 (g/mol) - CCL2F2 +! real(kind=rb), parameter :: amc22 = 86.4688_rb ! Molecular weight of CFC22 (g/mol) - CHCLF2 +! real(kind=rb), parameter :: amcl4 = 153.823_rb ! Molecular weight of CCL4 (g/mol) - CCL4 + +! Set molecular weight ratios (for converting mmr to vmr) +! e.g. h2ovmr = h2ommr * amdw) + real(kind=rb), parameter :: amdw = 1.607793_rb ! Molecular weight of dry air / water vapor + real(kind=rb), parameter :: amdc = 0.658114_rb ! Molecular weight of dry air / carbon dioxide + real(kind=rb), parameter :: amdo = 0.603428_rb ! Molecular weight of dry air / ozone + real(kind=rb), parameter :: amdm = 1.805423_rb ! Molecular weight of dry air / methane + real(kind=rb), parameter :: amdn = 0.658090_rb ! Molecular weight of dry air / nitrous oxide + real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen + real(kind=rb), parameter :: amdc1 = 0.210852_rb ! Molecular weight of dry air / CFC11 + real(kind=rb), parameter :: amdc2 = 0.239546_rb ! Molecular weight of dry air / CFC12 + + integer(kind=im) :: isp, l, ix, n, imol, ib, ig ! Loop indices + real(kind=rb) :: amm, amttl, wvttl, wvsh, summol + +! Add one to nlayers here to include extra model layer at top of atmosphere + nlayers = nlay + +! Initialize all molecular amounts and cloud properties to zero here, then pass input amounts +! into RRTM arrays below. + + wkl(:,:) = 0.0_rb + wx(:,:) = 0.0_rb + cldfmc(:,:) = 0.0_rb + taucmc(:,:) = 0.0_rb + ciwpmc(:,:) = 0.0_rb + clwpmc(:,:) = 0.0_rb + cswpmc(:,:) = 0.0_rb + reicmc(:) = 0.0_rb + relqmc(:) = 0.0_rb + resnmc(:) = 0.0_rb + taua(:,:) = 0.0_rb + amttl = 0.0_rb + wvttl = 0.0_rb + +! Set surface temperature. + tbound = tsfc(iplon) + +! Install input GCM arrays into RRTMG_LW arrays for pressure, temperature, +! and molecular amounts. +! Pressures are input in mb, or are converted to mb here. +! Molecular amounts are input in volume mixing ratio, or are converted from +! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio +! here. These are then converted to molecular amount (molec/cm2) below. +! The dry air column COLDRY (in molec/cm2) is calculated from the level +! pressures, pz (in mb), based on the hydrostatic equation and includes a +! correction to account for h2o in the layer. The molecular weight of moist +! air (amm) is calculated for each layer. +! Note: In RRTMG, layer indexing goes from bottom to top, and coding below +! assumes GCM input fields are also bottom to top. Input layer indexing +! from GCM fields should be reversed here if necessary. + + pz(0) = plev(iplon,1) + tz(0) = tlev(iplon,1) + do l = 1, nlayers + pavel(l) = play(iplon,l) + tavel(l) = tlay(iplon,l) + pz(l) = plev(iplon,l+1) + tz(l) = tlev(iplon,l+1) +! For h2o input in vmr: + wkl(1,l) = h2ovmr(iplon,l) +! For h2o input in mmr: +! wkl(1,l) = h2o(iplon,l)*amdw +! For h2o input in specific humidity; +! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw + wkl(2,l) = co2vmr(iplon,l) + wkl(3,l) = o3vmr(iplon,l) + wkl(4,l) = n2ovmr(iplon,l) + wkl(6,l) = ch4vmr(iplon,l) + wkl(7,l) = o2vmr(iplon,l) + amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw + coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / & + (1.e2_rb * grav * amm * (1._rb + wkl(1,l))) + enddo + +! Set cross section molecule amounts from input; convert to vmr if necessary + do l=1, nlayers + wx(1,l) = ccl4vmr(iplon,l) + wx(2,l) = cfc11vmr(iplon,l) + wx(3,l) = cfc12vmr(iplon,l) + wx(4,l) = cfc22vmr(iplon,l) + enddo + +! The following section can be used to set values for an additional layer (from +! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes. +! Temperature and molecular amounts in the extra model layer are set to +! their values in the top GCM model layer, though these can be modified +! here if necessary. +! If this feature is utilized, increase nlayers by one above, limit the two +! loops above to (nlayers-1), and set the top most (extra) layer values here. + +! pavel(nlayers) = 0.5_rb * pz(nlayers-1) +! tavel(nlayers) = tavel(nlayers-1) +! pz(nlayers) = 1.e-4_rb +! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1)) +! tz(nlayers) = tz(nlayers-1) +! wkl(1,nlayers) = wkl(1,nlayers-1) +! wkl(2,nlayers) = wkl(2,nlayers-1) +! wkl(3,nlayers) = wkl(3,nlayers-1) +! wkl(4,nlayers) = wkl(4,nlayers-1) +! wkl(6,nlayers) = wkl(6,nlayers-1) +! wkl(7,nlayers) = wkl(7,nlayers-1) +! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw +! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / & +! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1))) +! wx(1,nlayers) = wx(1,nlayers-1) +! wx(2,nlayers) = wx(2,nlayers-1) +! wx(3,nlayers) = wx(3,nlayers-1) +! wx(4,nlayers) = wx(4,nlayers-1) + +! At this point all molecular amounts in wkl and wx are in volume mixing ratio; +! convert to molec/cm2 based on coldry for use in rrtm. also, compute precipitable +! water vapor for diffusivity angle adjustments in rtrn and rtrnmr. + + do l = 1, nlayers + summol = 0.0_rb + do imol = 2, nmol + summol = summol + wkl(imol,l) + enddo + wbrodl(l) = coldry(l) * (1._rb - summol) + do imol = 1, nmol + wkl(imol,l) = coldry(l) * wkl(imol,l) + enddo + amttl = amttl + coldry(l)+wkl(1,l) + wvttl = wvttl + wkl(1,l) + do ix = 1,maxxsec + if (ixindx(ix) .ne. 0) then + wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_rb + endif + enddo + enddo + + wvsh = (amw * wvttl) / (amd * amttl) + pwvcm = wvsh * (1.e3_rb * pz(0)) / (1.e2_rb * grav) + +! Set spectral surface emissivity for each longwave band. + + do n=1,nbndlw + semiss(n) = emis(iplon,n) +! semiss(n) = 1.0_rb + enddo + +! Transfer aerosol optical properties to RRTM variable; +! modify to reverse layer indexing here if necessary. + + if (iaer .ge. 1) then + do l = 1, nlayers + do ib = 1, nbndlw + taua(l,ib) = tauaer(iplon,l,ib) + enddo + enddo + endif + +! Transfer cloud fraction and cloud optical properties to RRTM variables, +! modify to reverse layer indexing here if necessary. + + if (icld .ge. 1) then + inflag = inflglw + iceflag = iceflglw + liqflag = liqflglw + +! Move incoming GCM cloud arrays to RRTMG cloud arrays. +! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw) + + do l = 1, nlayers + do ig = 1, ngptlw + cldfmc(ig,l) = cldfmcl(ig,iplon,l) + taucmc(ig,l) = taucmcl(ig,iplon,l) + ciwpmc(ig,l) = ciwpmcl(ig,iplon,l) + clwpmc(ig,l) = clwpmcl(ig,iplon,l) + cswpmc(ig,l) = cswpmcl(ig,iplon,l) + enddo + reicmc(l) = reicmcl(iplon,l) + relqmc(l) = relqmcl(iplon,l) + resnmc(l) = resnmcl(iplon,l) + enddo + +! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer. + +! cldfmc(:,nlayers) = 0.0_rb +! taucmc(:,nlayers) = 0.0_rb +! ciwpmc(:,nlayers) = 0.0_rb +! clwpmc(:,nlayers) = 0.0_rb +! reicmc(nlayers) = 0.0_rb +! relqmc(nlayers) = 0.0_rb +! taua(nlayers,:) = 0.0_rb + + endif + + end subroutine inatm + + end module rrtmg_lw_rad + +!------------------------------------------------------------------ +MODULE module_ra_rrtmg_lw + +use icar_constants, only : cp +!use module_wrf_error +!#if (HWRF == 1) +! USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF +!#else +! USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT +!#endif +!use module_dm + +use parrrtm, only : nbndlw, ngptlw +use rrtmg_lw_init, only: rrtmg_lw_ini +use rrtmg_lw_rad, only: rrtmg_lw +use mcica_subcol_gen_lw, only: mcica_subcol_lw + + real retab(95) + data retab / & + 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/ + ! + save retab + ! For buffer layer adjustment. Steven Cavallo, Dec 2010. + integer , save :: nlayers + real, PARAMETER :: deltap = 4. ! Pressure interval for buffer layer in mb + +CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE RRTMG_LWRAD( & + rthratenlw, & + lwupt, lwuptc, lwuptcln, lwdnt, lwdntc, lwdntcln, & + lwupb, lwupbc, lwupbcln, lwdnb, lwdnbc, lwdnbcln, & +! lwupflx, lwupflxc, lwdnflx, lwdnflxc, & + glw, olr, lwcf, emiss, & + p8w, p3d, pi3d, & + dz8w, tsk, t3d, t8w, rho3d, r, g, & + icloud, warm_rain, cldfra3d, & + cldovrlp, & + lradius,iradius, & + is_cammgmp_used, & + f_ice_phy, f_rain_phy, & + xland, xice, snow, & + qv3d, qc3d, qr3d, & + qi3d, qs3d, qg3d, & + o3input, o33d, & + f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, & + re_cloud, re_ice, re_snow, & ! G. Thompson + has_reqc, has_reqi, has_reqs, & ! G. Thompson + tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao + tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao + tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao + tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & ! czhao + aer_ra_feedback, & !czhao +!jdfcz progn,prescribe, & !czhao + progn,calc_clean_atm_diag, & !czhao + qndrop3d,f_qndrop, & !czhao +!ccc added for time varying gases. + yr,julian, & +!ccc + mp_physics, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + lwupflx, lwupflxc, lwdnflx, lwdnflxc, & + read_ghg & + ) +!------------------------------------------------------------------ +!ccc To use clWRF time varying trace gases + USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases + + IMPLICIT NONE +!------------------------------------------------------------------ + LOGICAL, INTENT(IN ) :: warm_rain + LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: ICLOUD + INTEGER, INTENT(IN ) :: MP_PHYSICS +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: dz8w, & + t3d, & + t8w, & + p8w, & + p3d, & + pi3d, & + rho3d + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RTHRATENLW + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: GLW, & + OLR, & + LWCF + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: EMISS, & + TSK + + REAL, INTENT(IN ) :: R,G + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: XLAND, & + XICE, & + SNOW +!ccc Added for time-varying trace gases. + INTEGER, INTENT(IN ) :: yr + REAL, INTENT(IN ) :: julian +!ccc + +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + CLDFRA3D, & + LRADIUS, & + IRADIUS, & + + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D, & + QNDROP3D + +!..Added by G. Thompson to couple cloud physics effective radii. + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: & + re_cloud, & + re_ice, & + re_snow + INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs + + real pi,third,relconst,lwpmin,rhoh2o + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + F_ICE_PHY, & + F_RAIN_PHY + + LOGICAL, OPTIONAL, INTENT(IN) :: & + F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP +! Optional + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao + tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao + tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao + tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16 + + INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback +!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe + INTEGER, INTENT(IN ), OPTIONAL :: progn + INTEGER, INTENT(IN ) :: calc_clean_atm_diag + +! Ozone + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: O33D + INTEGER, OPTIONAL, INTENT(IN ) :: o3input + + real, parameter :: thresh=1.e-9 + real slope + character(len=200) :: msg + + +! Top of atmosphere and surface longwave fluxes (W m-2) + REAL, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + LWUPT,LWUPTC,LWUPTCLN,LWDNT,LWDNTC,LWDNTCLN,& + LWUPB,LWUPBC,LWUPBCLN,LWDNB,LWDNBC,LWDNBCLN + +! Layer longwave fluxes (including extra layer above model top) +! Vertical ordering is from bottom to top (W m-2) + REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), & + OPTIONAL, INTENT(OUT) :: & + LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC + + LOGICAL, INTENT(IN) :: read_ghg + + ! LOCAL VARS + + REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & + Tw1D + + REAL, DIMENSION( kts:kte ) :: TTEN1D, & + CLDFRA1D, & + DZ1D, & + P1D, & + T1D, & + QV1D, & + QC1D, & + QR1D, & + QI1D, & + RHO1D, & + QS1D, & + QG1D, & + O31D, & + qndrop1d +!BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996) + real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, & + re_30C=1250.0/9.208, re_20C=1250.0/9.387 + + +! Added local arrays for RRTMG + integer :: ncol, & + nlay, & + icld, & + cldovrlp, & + inflglw, & + iceflglw, & + liqflglw +! Dimension with extra layer from model top to TOA + real, dimension( 1, kts:nlayers+1 ) :: plev, & + tlev + real, dimension( 1, kts:nlayers ) :: play, & + tlay, & + h2ovmr, & + o3vmr, & + co2vmr, & + o2vmr, & + ch4vmr, & + n2ovmr, & + cfc11vmr, & + cfc12vmr, & + cfc22vmr, & + ccl4vmr + real, dimension( kts:nlayers ) :: o3mmr +! Add height of each layer for exponential-random cloud overlap +! This will be derived below from the dz in each layer + real, dimension( 1, kts:nlayers ) :: hgt + real :: dzsum +! For old cloud property specification for rrtm_lw + real, dimension( kts:kte ) :: clwp, & + ciwp, & + cswp, & + plwp, & + piwp +! Surface emissivity (for 16 LW spectral bands) + real, dimension( 1, nbndlw ) :: emis +! Dimension with extra layer from model top to TOA, +! though no clouds are allowed in extra layer + real, dimension( 1, kts:nlayers ) :: clwpth, & + ciwpth, & + cswpth, & + rel, & + rei, & + res, & + cldfrac, & + relqmcl, & + reicmcl, & + resnmcl + real, dimension( nbndlw, 1, kts:nlayers ) :: taucld + real, dimension( ngptlw, 1, kts:nlayers ) :: cldfmcl, & + clwpmcl, & + ciwpmcl, & + cswpmcl, & + taucmcl + real, dimension( 1, kts:nlayers, nbndlw ) :: tauaer + +! Output arrays contain extra layer from model top to TOA + real, dimension( 1, kts:nlayers+1 ) :: uflx, & + dflx, & + uflxc, & + dflxc, & + uflxcln, & + dflxcln + + real, dimension( 1, kts:nlayers ) :: hr, & + hrc + + real, dimension ( 1 ) :: tsfc, & + ps + real :: ro, & + dz + real:: snow_mass_factor + +!..We can use message interface regardless of what options are running, +!.. so let us ask for it here. + CHARACTER(LEN=256) :: message +! LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +!ccc To add time-varying trace gases (CO2, N2O and CH4). Read the conc. from file +! then interpolate to date of run. +#ifdef CLWRFGHG +! CLWRF-UC June.09 + REAL(8) :: co2, n2o, ch4, cfc11, cfc12 +#else + +! Set trace gas volume mixing ratios, 2005 values, IPCC (2007) +! carbon dioxide (379 ppmv) - this is being replaced by an annual function in v4.2 + real(8) :: co2 +! data co2 / 379.e-6 / +! methane (1774 ppbv) + real(8) :: ch4 + data ch4 / 1774.e-9 / +! nitrous oxide (319 ppbv) + real(8) :: n2o + data n2o / 319.e-9 / +! cfc-11 (251 ppt) + real(8) :: cfc11 + data cfc11 / 0.251e-9 / +! cfc-12 (538 ppt) + real(8) :: cfc12 + data cfc12 / 0.538e-9 / +#endif +! cfc-22 (169 ppt) + real :: cfc22 + data cfc22 / 0.169e-9 / +! ccl4 (93 ppt) + real :: ccl4 + data ccl4 / 0.093e-9 / +! Set oxygen volume mixing ratio (for o2mmr=0.23143) + real :: o2 + data o2 / 0.209488 / + + integer :: iplon, irng, permuteseed + integer :: nb + +! For old cloud property specification for rrtm_lw +! Cloud and precipitation absorption coefficients + real :: abcw,abice,abrn,absn + data abcw /0.144/ + data abice /0.0735/ + data abrn /0.330e-3/ + data absn /2.34e-3/ + +! Molecular weights and ratios for converting mmr to vmr units +! real :: amd ! Effective molecular weight of dry air (g/mol) +! real :: amw ! Molecular weight of water vapor (g/mol) +! real :: amo ! Molecular weight of ozone (g/mol) +! real :: amo2 ! Molecular weight of oxygen (g/mol) +! Atomic weights for conversion from mass to volume mixing ratios +! data amd / 28.9660 / +! data amw / 18.0160 / +! data amo / 47.9998 / +! data amo2 / 31.9999 / + + real :: amdw ! Molecular weight of dry air / water vapor + real :: amdo ! Molecular weight of dry air / ozone + real :: amdo2 ! Molecular weight of dry air / oxygen + data amdw / 1.607793 / + data amdo / 0.603461 / + data amdo2 / 0.905190 / + +!! + real, dimension( 1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb) + + real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path + cliqwp, & ! in-cloud cloud liquid water path + csnowp, & ! in-cloud snow water path + reliq, & ! effective drop radius (microns) + reice ! effective ice crystal size (microns) + real, dimension(1, 1:kte-kts+1):: recloud1d, & + reice1d, & + resnow1d + + real :: gliqwp, gicewp, gsnowp, gravmks + +! +! REAL :: TSFC,GLW0,OLR0,EMISS0,FP + + real, dimension (1) :: landfrac, landm, snowh, icefrac + + integer :: pcols, pver + +! + INTEGER :: i,j,K, idx_rei + REAL :: corr + LOGICAL :: predicate + +! Added for top of model adjustment. Steven Cavallo NCAR/MMM December 2010 + INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table + INTEGER :: L, LL, klev ! Loop indices + REAL, DIMENSION( kts:nlayers+1 ) :: varint + REAL :: wght,vark,vark1,tem1,tem2,tem3 + REAL :: PPROF(nproflevs), TPROF(nproflevs) + ! Weighted mean pressure and temperature profiles from midlatitude + ! summer (MLS),midlatitude winter (MLW), sub-Arctic + ! winter (SAW),sub-Arctic summer (SAS), and tropical (TROP) + ! standard atmospheres. + DATA PPROF /1000.00,855.47,731.82,626.05,535.57,458.16, & + 391.94,335.29,286.83,245.38,209.91,179.57, & + 153.62,131.41,112.42,96.17,82.27,70.38, & + 60.21,51.51,44.06,37.69,32.25,27.59, & + 23.60,20.19,17.27,14.77,12.64,10.81, & + 9.25,7.91,6.77,5.79,4.95,4.24, & + 3.63,3.10,2.65,2.27,1.94,1.66, & + 1.42,1.22,1.04,0.89,0.76,0.65, & + 0.56,0.48,0.41,0.35,0.30,0.26, & + 0.22,0.19,0.16,0.14,0.12,0.10/ + DATA TPROF /286.96,281.07,275.16,268.11,260.56,253.02, & + 245.62,238.41,231.57,225.91,221.72,217.79, & + 215.06,212.74,210.25,210.16,210.69,212.14, & + 213.74,215.37,216.82,217.94,219.03,220.18, & + 221.37,222.64,224.16,225.88,227.63,229.51, & + 231.50,233.73,236.18,238.78,241.60,244.44, & + 247.35,250.33,253.32,256.30,259.22,262.12, & + 264.80,266.50,267.59,268.44,268.69,267.76, & + 266.13,263.96,261.54,258.93,256.15,253.23, & + 249.89,246.67,243.48,240.25,236.66,233.86/ +!------------------------------------------------------------------ +#if ( WRF_CHEM == 1 ) + IF ( aer_ra_feedback == 1) then + IF ( .NOT. & + ( PRESENT(tauaerlw1) .AND. & + PRESENT(tauaerlw2) .AND. & + PRESENT(tauaerlw3) .AND. & + PRESENT(tauaerlw4) .AND. & + PRESENT(tauaerlw5) .AND. & + PRESENT(tauaerlw6) .AND. & + PRESENT(tauaerlw7) .AND. & + PRESENT(tauaerlw8) .AND. & + PRESENT(tauaerlw9) .AND. & + PRESENT(tauaerlw10) .AND. & + PRESENT(tauaerlw11) .AND. & + PRESENT(tauaerlw12) .AND. & + PRESENT(tauaerlw13) .AND. & + PRESENT(tauaerlw14) .AND. & + PRESENT(tauaerlw15) .AND. & + PRESENT(tauaerlw16) ) ) THEN + !CALL wrf_error_fatal & + !('Warning: missing fields required for aerosol radiation' ) + error stop 'Warning: missing fields required for aerosol radiation' + ENDIF + ENDIF +#endif + + +!-----CALCULATE LONG WAVE RADIATION +! +! All fields are ordered vertically from bottom to top +! Pressures are in mb +! +! Annual function for co2 in WRF v4.2 + co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6 + +!ccc Read time-varying trace gases concentrations and interpolate them to run date. +! +!#ifdef CLWRFGHG +if (read_ghg) then + CALL read_CAMgases(yr,julian,"RRTMG",co2,n2o,ch4,cfc11,cfc12) + +! IF ( wrf_dm_on_monitor() ) THEN + IF (this_image()==1) THEN + WRITE(message,*)'CAM-CLWRF interpolated values______ year:',yr,' julian day:',julian + !call wrf_debug( 100, message) + ! write(*,*) message + WRITE(message,*)' CAM-CLWRF co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12 + !call wrf_debug( 100, message) + ! write(*,*) message + ENDIF +endif +!#endif +!ccc + +! latitude loop + j_loop: do j = jts,jte + +! longitude loop + i_loop: do i = its,ite + + do k=kts,kte+1 + Pw1D(K) = p8w(I,K,J)/100. + Tw1D(K) = t8w(I,K,J) + enddo + + DO K=kts,kte + QV1D(K)=0. + QC1D(K)=0. + QR1D(K)=0. + QI1D(K)=0. + QS1D(K)=0. + CLDFRA1D(k)=0. + ENDDO + + DO K=kts,kte + QV1D(K)=QV3D(I,K,J) + QV1D(K)=max(0.,QV1D(K)) + ENDDO + + IF (PRESENT(O33D)) THEN + DO K=kts,kte + O31D(K)=O33D(I,K,J) + ENDDO + ELSE + DO K=kts,kte + O31D(K)=0.0 + ENDDO + ENDIF + + DO K=kts,kte + TTEN1D(K)=0. + T1D(K)=T3D(I,K,J) + P1D(K)=P3D(I,K,J)/100. + RHO1D(K)=RHO3D(I,K,J) + DZ1D(K)=dz8w(I,K,J) + ENDDO + +! moist variables + + IF (ICLOUD .ne. 0) THEN + IF ( PRESENT( CLDFRA3D ) ) THEN + DO K=kts,kte + CLDFRA1D(k)=CLDFRA3D(I,K,J) + ENDDO + ENDIF + + IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN + IF ( F_QC) THEN + DO K=kts,kte + QC1D(K)=QC3D(I,K,J) + QC1D(K)=max(0.,QC1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN + IF ( F_QR) THEN + DO K=kts,kte + QR1D(K)=QR3D(I,K,J) + QR1D(K)=max(0.,QR1D(K)) + ENDDO + ENDIF + ENDIF + + IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN + IF (F_QNDROP) THEN + DO K=kts,kte + qndrop1d(K)=qndrop3d(I,K,J) + ENDDO + ENDIF + ENDIF + +! This logic is tortured because cannot test F_QI unless +! it is present, and order of evaluation of expressions +! is not specified in Fortran + + IF ( PRESENT ( F_QI ) ) THEN + predicate = F_QI + ELSE + predicate = .FALSE. + ENDIF + +! For MP option 3 + IF (.NOT. predicate .and. .not. warm_rain) THEN + DO K=kts,kte + IF (T1D(K) .lt. 273.15) THEN + QI1D(K)=QC1D(K) + QS1D(K)=QR1D(K) + QC1D(K)=0. + QR1D(K)=0. + ENDIF + ENDDO + ENDIF + + IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN + IF (F_QI) THEN + DO K=kts,kte + QI1D(K)=QI3D(I,K,J) + QI1D(K)=max(0.,QI1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN + IF (F_QS) THEN + DO K=kts,kte + QS1D(K)=QS3D(I,K,J) + QS1D(K)=max(0.,QS1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN + IF (F_QG) THEN + DO K=kts,kte + QG1D(K)=QG3D(I,K,J) + QG1D(K)=max(0.,QG1D(K)) + ENDDO + ENDIF + ENDIF + +! mji - For MP option 5 + IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN + IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN + DO K=kts,kte + qi1d(k) = 0.1*qs3d(i,k,j) + qs1d(k) = 0.9*qs3d(i,k,j) + qc1d(k) = qc3d(i,k,j) + qi1d(k) = max(0.,qi1d(k)) + qc1d(k) = max(0.,qc1d(k)) + ENDDO + ENDIF + ENDIF + + ELSE + reice1d = 10 + recloud1d = 5 + resnow1d = 10 + ENDIF + +! For mp option=5 or 85 (new Ferrier- Aligo or fer_hires scheme), QI3D saves all +!#if (HWRF == 1) +! IF ( mp_physics == FER_MP_HIRES .OR. & +! mp_physics == FER_MP_HIRES_ADVECT .OR. & +! mp_physics == ETAMP_HWRF ) THEN +!#else +! IF ( mp_physics == FER_MP_HIRES .OR. & +! mp_physics == FER_MP_HIRES_ADVECT) THEN +!#endif + DO K=kts,kte + qi1d(k) = qi3d(i,k,j) + qs1d(k) = 0.0 + qc1d(k) = qc3d(i,k,j) + qi1d(k) = max(0.,qi1d(k)) + qc1d(k) = max(0.,qc1d(k)) + ENDDO +! ENDIF + +! EMISS0=EMISS(I,J) +! GLW0=0. +! OLR0=0. +! TSFC=TSK(I,J) + DO K=kts,kte + QV1D(K)=AMAX1(QV1D(K),1.E-12) + ENDDO + +! Set up input for longwave + ncol = 1 +! Add extra layer from top of model to top of atmosphere +! nlay = (kte - kts + 1) + 1 +! Edited for top of model adjustment (nlayers = kte + 1). +! Steven Cavallo, December 2010 + nlay = nlayers ! Keep these indices the same + +! Select cloud overlap assumption (1 = random, 2 = maximum-random, 3 = maximum, 4 = exponential, 5 = exponential-random + icld=cldovrlp ! J. Henderson AER assign namelist variable cldovrlp to existing icld + +! Select cloud liquid and ice optics parameterization options +! For passing in cloud optical properties directly: +! icld = 2 +! inflglw = 0 +! iceflglw = 0 +! liqflglw = 0 +! For passing in cloud physical properties; cloud optics parameterized in RRTMG: + inflglw = 2 + iceflglw = 3 + liqflglw = 1 + +!Mukul change the flags here with reference to the new effective cloud/ice/snow radius + + + IF (ICLOUD .ne. 0) THEN + IF ( has_reqc .ne. 0) THEN + inflglw = 3 + DO K=kts,kte + recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6) + if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean + recloud1D(ncol,K) = 10.5 + elseif(recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land + recloud1D(ncol,K) = 7.5 + endif + ENDDO + ELSE + DO K=kts,kte + recloud1D(ncol,K) = 5.0 + ENDDO + ENDIF + + IF ( has_reqi .ne. 0) THEN + inflglw = 4 + iceflglw = 4 + DO K=kts,kte + reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6) + if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then + idx_rei = int(t3d(i,k,j)-179.) + idx_rei = min(max(idx_rei,1),75) + corr = t3d(i,k,j) - int(t3d(i,k,j)) + reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + & + & retab(idx_rei+1)*corr + reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0) + endif + ENDDO + ELSE + DO K=kts,kte +#if (EM_CORE==1) + reice1D(ncol,K) = 10.0 +#else + tem2 = 25.0 !- was 10.0 + tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3) + if (tem3>thresh) then !- Only when IWC>1.e-9 gm^-3 + tem1=t1d(k)-273.15 + if (tem1 < -50.0) then + tem2 = re_50C*tem3**0.109 + elseif (tem1 < -40.0) then + tem2 = re_40C*tem3**0.08 + elseif (tem1 < -30.0) then + tem2 = re_30C*tem3**0.055 + else + tem2 = re_20C*tem3**0.031 + endif + tem2 = max(25.,tem2) + endif + reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice<= 140 microns +#endif + ENDDO + ENDIF + + IF ( has_reqs .ne. 0) THEN + inflglw = 5 + iceflglw = 5 + DO K=kts,kte + resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6) + ENDDO + ELSE + DO K=kts,kte + resnow1D(ncol,K) = 10.0 + ENDDO + ENDIF + +! special case for P3 microphysics +! put ice into snow category for optics, then set ice to zero + IF (has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN + inflglw = 5 + iceflglw = 5 + DO K=kts,kte + resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6) + QS1D(K)=QI3D(I,K,J) + QI1D(K)=0. + reice1D(ncol,K)=10. + END DO + END IF + + ENDIF + +! Layer indexing goes bottom to top here for all fields. +! Water vapor and ozone are converted from mmr to vmr. +! Pressures are in units of mb here. + plev(ncol,1) = pw1d(1) + tlev(ncol,1) = tw1d(1) + tsfc(ncol) = tsk(i,j) + do k = kts, kte + play(ncol,k) = p1d(k) + plev(ncol,k+1) = pw1d(k+1) + pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1) + tlay(ncol,k) = t1d(k) + tlev(ncol,k+1) = tw1d(k+1) + h2ovmr(ncol,k) = qv1d(k) * amdw + co2vmr(ncol,k) = co2 + o2vmr(ncol,k) = o2 + ch4vmr(ncol,k) = ch4 + n2ovmr(ncol,k) = n2o + cfc11vmr(ncol,k) = cfc11 + cfc12vmr(ncol,k) = cfc12 + cfc22vmr(ncol,k) = cfc22 + ccl4vmr(ncol,k) = ccl4 + enddo + +! Derive height of each layer mid-point from layer thickness. +! Needed for exponential (icld=4) and exponential-random overlap (icld=5) options only. + dzsum = 0.0 + do k = kts, kte + dz = dz1d(k) + hgt(ncol,k) = dzsum + 0.5*dz + dzsum = dzsum + dz + enddo + +! This section is replaced with a new method to deal with model top + if ( 1 == 0 ) then + +! Define profile values for extra layer from model top to top of atmosphere. +! The top layer temperature for all gridpoints is set to the top layer-1 +! temperature plus a constant (0 K) that represents an isothermal layer +! above ptop. Top layer interface temperatures are linearly interpolated +! from the layer temperatures. + + play(ncol,kte+1) = 0.5 * plev(ncol,kte+1) + tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0 + plev(ncol,kte+2) = 1.0e-5 + tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0 + h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte) + co2vmr(ncol,kte+1) = co2vmr(ncol,kte) + o2vmr(ncol,kte+1) = o2vmr(ncol,kte) + ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte) + n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte) + cfc11vmr(ncol,kte+1) = cfc11vmr(ncol,kte) + cfc12vmr(ncol,kte+1) = cfc12vmr(ncol,kte) + cfc22vmr(ncol,kte+1) = cfc22vmr(ncol,kte) + ccl4vmr(ncol,kte+1) = ccl4vmr(ncol,kte) + + endif + +! Set up values for extra layers to the top of the atmosphere. +! Temperature is calculated based on an average temperature profile given +! here in a table. The input table data is linearly interpolated to the +! column pressure. Mixing ratios are held constant except for ozone. +! Caution should be used if model top pressure is less than 5 hPa. +! Steven Cavallo, NCAR/MMM, December 2010 + ! Calculate the column pressure buffer levels above the + ! model top + + + do L=kte+1,nlayers,1 + plev(ncol,L+1) = plev(ncol,L) - deltap + play(ncol,L) = 0.5*(plev(ncol,L) + plev(ncol,L+1)) +! Fill in height array above model top to top of atmosphere using +! dz from model top layer for completeness, though this information is not +! likely to be used by the exponential-random cloud overlap method. + hgt(ncol,L) = dzsum + 0.5*dz + dzsum = dzsum + dz + enddo + ! Add zero as top level. This gets the temperature max at the + ! stratopause, reducing the downward flux errors in the top + ! levels. If zero happened to be the top level already, + ! this will add another level with zero, but will not affect + ! the radiative transfer calculation. + plev(ncol,nlayers+1) = 0.00 + play(ncol,nlayers) = 0.5*(plev(ncol,nlayers) + plev(ncol,nlayers+1)) + + ! Interpolate the table temperatures to column pressure levels + do L=1,nlayers+1,1 + if ( PPROF(nproflevs) .lt. plev(ncol,L) ) then + do LL=2,nproflevs,1 + if ( PPROF(LL) .lt. plev(ncol,L) ) then + klev = LL - 1 + exit + endif + enddo + + else + klev = nproflevs + endif + + if (klev .ne. nproflevs ) then + vark = TPROF(klev) + vark1 = TPROF(klev+1) + wght=(plev(ncol,L)-PPROF(klev) )/( PPROF(klev+1)-PPROF(klev)) + else + vark = TPROF(klev) + vark1 = TPROF(klev) + wght = 0.0 + endif + varint(L) = wght*(vark1-vark)+vark + + enddo + + ! Match the interpolated table temperature profile to WRF column + do L=kte+1,nlayers+1,1 + tlev(ncol,L) = varint(L) + (tlev(ncol,kte) - varint(kte)) + !if ( L .le. nlay ) then + tlay(ncol,L-1) = 0.5*(tlev(ncol,L) + tlev(ncol,L-1)) + !endif + enddo + + ! Now the chemical species (except for ozone) + do L=kte+1,nlayers,1 + h2ovmr(ncol,L) = h2ovmr(ncol,kte) + co2vmr(ncol,L) = co2vmr(ncol,kte) + o2vmr(ncol,L) = o2vmr(ncol,kte) + ch4vmr(ncol,L) = ch4vmr(ncol,kte) + n2ovmr(ncol,L) = n2ovmr(ncol,kte) + cfc11vmr(ncol,L) = cfc11vmr(ncol,kte) + cfc12vmr(ncol,L) = cfc12vmr(ncol,kte) + cfc22vmr(ncol,L) = cfc22vmr(ncol,kte) + ccl4vmr(ncol,L) = ccl4vmr(ncol,kte) + enddo +! End top of model buffer +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Get ozone profile including amount in extra layer above model top. +! Steven Cavallo: Must pass nlay-1 into subroutine to get nlayers +! dimension for o3mmr + call inirad (o3mmr,plev,kts,nlay-1) + +! Steven Cavallo: Changed to nlayers from kte+1 + if(present(o33d)) then + do k = kts, nlayers + o3vmr(ncol,k) = o3mmr(k) * amdo + IF ( PRESENT( O33D ) ) THEN + if(o3input .eq. 2)then + if(k.le.kte)then + o3vmr(ncol,k) = o31d(k) + else +! apply shifted climatology profile above model top + o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo + if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo + endif + endif + ENDIF + enddo + else + do k = kts, nlayers + o3vmr(ncol,k) = o3mmr(k) * amdo + enddo + endif + +! Set surface emissivity in each RRTMG longwave band + do nb = 1, nbndlw + emis(ncol, nb) = emiss(i,j) + enddo + +! Define cloud optical properties for radiation (inflglw = 0) +! This is approach used with older RRTM_LW; +! Cloud and precipitation paths in g/m2 +! qi=0 if no ice phase +! qs=0 if no ice phase + if (inflglw .eq. 0) then + do k = kts,kte + ro = p1d(k) / (r * t1d(k))*100. + dz = dz1d(k) + clwp(k) = ro*qc1d(k)*dz*1000. + ciwp(k) = ro*qi1d(k)*dz*1000. + plwp(k) = (ro*qr1d(k))**0.75*dz*1000. + piwp(k) = (ro*qs1d(k))**0.75*dz*1000. + enddo + +! Cloud fraction and cloud optical depth; old approach used with RRTM_LW + do k = kts, kte + cldfrac(ncol,k) = cldfra1d(k) + do nb = 1, nbndlw + taucld(nb,ncol,k) = abcw*clwp(k) + abice*ciwp(k) & + +abrn*plwp(k) + absn*piwp(k) + if (taucld(nb,ncol,k) .gt. 0.01) cldfrac(ncol,k) = 1. + enddo + enddo + +! Zero out cloud physical property arrays; not used when passing optical properties +! into radiation + do k = kts, kte + clwpth(ncol,k) = 0.0 + ciwpth(ncol,k) = 0.0 + rel(ncol,k) = 10.0 + rei(ncol,k) = 10.0 + enddo + endif + +! Define cloud physical properties for radiation (inflglw = 1 or 2) +! Cloud fraction +! Set cloud arrays if passing cloud physical properties into radiation + if (inflglw .gt. 0) then + do k = kts, kte + cldfrac(ncol,k) = cldfra1d(k) + enddo + +! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method) + pcols = ncol + pver = kte - kts + 1 + gravmks = g + landfrac(ncol) = 2.-XLAND(I,J) + landm(ncol) = landfrac(ncol) + snowh(ncol) = 0.001*SNOW(I,J) + icefrac(ncol) = XICE(I,J) + +! From module_ra_cam: Convert liquid and ice mixing ratios to water paths; +! pdel is in mb here; convert back to Pa (*100.) +! Water paths are in units of g/m2 +! snow added as ice cloud (JD 091022) + do k = kts, kte + gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path. + cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path. + cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path. + end do + + +! Mukul +!..The ice water path is already sum of cloud ice and snow, but when we have explicit +!.. ice effective radius, overwrite the ice path with only the cloud ice variable, +!.. leaving out the snow for its own effect. + if(iceflglw.ge.4)then + do k = kts, kte + gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path. + end do + end if + +!..Here the snow path is adjusted if (radiation) effective radius of snow is +!.. larger than what we currently have in the lookup tables. Since mass goes +!.. rather close to diameter squared, adjust the mixing ratio of snow used +!.. to compute its water path in combination with the max diameter. Not a +!.. perfect fix, but certainly better than using all snow mass when diameter is +!.. far larger than table currently contains and crystal sizes much larger than +!.. about 140 microns have lesser impact than those much smaller sizes. + + if(iceflglw.eq.5)then + do k = kts, kte + snow_mass_factor = 1.0 + if (resnow1d(ncol,k) .gt. 130.)then + snow_mass_factor = (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k)) + resnow1d(ncol,k) = 130.0 + !IF ( wrf_dm_on_monitor() ) THEN + IF (this_image()==1) then + WRITE(message,*)'RRTMG: reducing snow mass (cloud path) to ', & + nint(snow_mass_factor*100.), ' percent of full value' + !call wrf_debug(150, message) + ENDIF + endif + gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path. + csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k)) + end do + end if + + +!link the aerosol feedback to cloud -czhao + if( PRESENT( progn ) ) then + if (progn == 1) then +!jdfcz if(prescribe==0) then + + pi = 4.*atan(1.0) + third=1./3. + rhoh2o=1.e3 + relconst=3/(4.*pi*rhoh2o) +! minimun liquid water path to calculate rel +! corresponds to optical depth of 1.e-3 for radius 4 microns. + lwpmin=3.e-5 + do k = kts, kte + reliq(ncol,k) = 10. + if( PRESENT( F_QNDROP ) ) then + if( F_QNDROP ) then + if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. & + qndrop1d(k).gt.1000. ) then + reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m +! apply scaling from Martin et al., JAS 51, 1830. + reliq(ncol,k)=1.1*reliq(ncol,k) + reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns + reliq(ncol,k)=max(reliq(ncol,k),4.) + reliq(ncol,k)=min(reliq(ncol,k),20.) + end if + end if + end if + end do +!jdfcz else ! prescribe +! following Kiehl +! call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) +! write(0,*) 'lw prescribe aerosol',maxval(qndrop3d) +!jdfcz endif + else ! progn + call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + else !present(progn) + call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + +! following Kristjansson and Mitchell + call reicalc(ncol, pcols, pver, tlay, reice) + + +!..If we already have effective radius of cloud and ice, then just overwrite what +!.. was computed in the relcalc and reicalc subroutines above. + + if (inflglw .ge. 3) then + do k = kts, kte + reliq(ncol,k) = recloud1d(ncol,k) + end do + endif +#if (EM_CORE==1) + if (iceflglw .ge. 4) then +#else + if (iceflglw .ge. 3) then !BSF: was .ge. 4 +#endif + + do k = kts, kte + reice(ncol,k) = reice1d(ncol,k) + end do + endif + +! Limit upper bound of reice for Fu ice parameterization and convert +! from effective radius to generalized effective size (*1.0315; Fu, 1996) + if (iceflglw .eq. 3) then + do k = kts, kte + reice(ncol,k) = reice(ncol,k) * 1.0315 + reice(ncol,k) = min(140.0,reice(ncol,k)) + end do + endif +!if CAMMGMP is used, use output from CAMMGMP + if(is_CAMMGMP_used) then + do k = kts, kte + if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then + reice(ncol,k) = iradius(i,k,j) + else + reice(ncol,k) = 25. + end if + reice(ncol,k) = max(5., min(140.0,reice(ncol,k))) + if ( qc1d(k) .gt. 1.e-20) then + reliq(ncol,k) = lradius(i,k,j) + else + reliq(ncol,k) = 10. + end if + reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k))) + enddo + endif + + +! Set cloud physical property arrays + do k = kts, kte + clwpth(ncol,k) = cliqwp(ncol,k) + ciwpth(ncol,k) = cicewp(ncol,k) + rel(ncol,k) = reliq(ncol,k) + rei(ncol,k) = reice(ncol,k) + enddo + + +!Mukul + if (inflglw .eq. 5) then + do k = kts, kte + cswpth(ncol,k) = csnowp(ncol,k) + res(ncol,k) = resnow1d(ncol,k) + end do + else + do k = kts, kte + cswpth(ncol,k) = 0. + res(ncol,k) = 10. + end do + endif + +! Zero out cloud optical properties here; not used when passing physical properties +! to radiation and taucld is calculated in radiation + do k = kts, kte + do nb = 1, nbndlw + taucld(nb,ncol,k) = 0.0 + enddo + enddo + endif + +! No clouds are allowed in the extra layer from model top to TOA + ! Steven Cavallo: Edited out for buffer adjustment below + if ( 1 == 0 ) then + + + clwpth(ncol,kte+1) = 0. + ciwpth(ncol,kte+1) = 0. + cswpth(ncol,kte+1) = 0. + rel(ncol,kte+1) = 10. + rei(ncol,kte+1) = 10. + res(ncol,kte+1) = 10. + cldfrac(ncol,kte+1) = 0. + do nb = 1, nbndlw + taucld(nb,ncol,kte+1) = 0. + enddo + + endif + + ! Buffer adjustment. Steven Cavallo December 2010 + do k=kte+1,nlayers + clwpth(ncol,k) = 0. + ciwpth(ncol,k) = 0. + cswpth(ncol,k) = 0. + rel(ncol,k) = 10. + rei(ncol,k) = 10. + res(ncol,k) = 10. + cldfrac(ncol,k) = 0. + do nb = 1,nbndlw + taucld(nb,ncol,k) = 0. + enddo + enddo + + iplon = 1 + irng = 0 + permuteseed = 150 + +! Sub-column generator for McICA + call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, hgt, & + cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, cldfmcl, & + ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl) + +!-------------------------------------------------------------------------- +! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010 +!-------------------------------------------------------------------------- +! Aerosol optical depth by layer for each RRTMG longwave band +! No aerosols in layer above model top (kte+1) +! Steven Cavallo: Upper bound of loop changed to nlayers from kte+1 +! do nb = 1, nbndlw +! do k = kts, kte+1 +! tauaer(ncol,k,nb) = 0. +! enddo +! enddo + +! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao +! + do nb = 1, nbndlw + do k = kts,nlayers + tauaer(ncol,k,nb) = 0. + end do + end do + +#if ( WRF_CHEM == 1 ) + IF ( AER_RA_FEEDBACK == 1) then +! do nb = 1, nbndlw + do k = kts,kte !wig + if(tauaerlw1(i,k,j).gt.thresh .and. tauaerlw16(i,k,j).gt.thresh) then + tauaer(ncol,k,1)=tauaerlw1(i,k,j) + tauaer(ncol,k,2)=tauaerlw2(i,k,j) + tauaer(ncol,k,3)=tauaerlw3(i,k,j) + tauaer(ncol,k,4)=tauaerlw4(i,k,j) + tauaer(ncol,k,5)=tauaerlw5(i,k,j) + tauaer(ncol,k,6)=tauaerlw6(i,k,j) + tauaer(ncol,k,7)=tauaerlw7(i,k,j) + tauaer(ncol,k,8)=tauaerlw8(i,k,j) + tauaer(ncol,k,9)=tauaerlw9(i,k,j) + tauaer(ncol,k,10)=tauaerlw10(i,k,j) + tauaer(ncol,k,11)=tauaerlw11(i,k,j) + tauaer(ncol,k,12)=tauaerlw12(i,k,j) + tauaer(ncol,k,13)=tauaerlw13(i,k,j) + tauaer(ncol,k,14)=tauaerlw14(i,k,j) + tauaer(ncol,k,15)=tauaerlw15(i,k,j) + tauaer(ncol,k,16)=tauaerlw16(i,k,j) + endif + enddo ! k +! end do ! nb + +!wig beg + do nb = 1, nbndlw + slope = 0. !use slope as a sum holder + do k = kts,kte + slope = slope + tauaer(ncol,k,nb) + end do + if( slope < 0. ) then + write(msg,'("ERROR: Negative total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb + !call wrf_error_fatal(msg) + error stop msg + else if( slope > 5. ) then + !call wrf_message("-------------------------") + write(msg,'("WARNING: Large total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb + write(*,*) msg + !call wrf_message(msg) + + !call wrf_message("Diagnostics 1: k, tauaerlw1, tauaerlw16") + write(*,*) "Diagnostics 1: k, tauaerlw1, tauaerlw16" + do k=kts,kte + write(msg,'(i4,2f8.2)') k, tauaerlw1(i,k,j), tauaerlw16(i,k,j) + write(*,*) msg + !call wrf_message(msg) + end do + !call wrf_message("-------------------------") + endif + enddo ! nb + endif ! aer_ra_feedback +#endif + +! Call RRTMG longwave radiation model + call rrtmg_lw & + (ncol ,nlay ,icld , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , & + inflglw ,iceflglw,liqflglw,cldfmcl , & + taucmcl ,ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl , & + tauaer , & + uflx ,dflx ,hr ,uflxc ,dflxc, hrc, & + uflxcln ,dflxcln, calc_clean_atm_diag ) + +! Output downard surface flux, and outgoing longwave flux and cloud forcing +! at the top of atmosphere (W/m2) + glw(i,j) = dflx(1,1) +! olr(i,j) = uflx(1,kte+2) +! lwcf(i,j) = uflxc(1,kte+2) - uflx(1,kte+2) +! Steven Cavallo: Changed OLR to be valid at the top of atmosphere instead +! of top of model. Dec 2010. + olr(i,j) = uflx(1,nlayers+1) + lwcf(i,j) = uflxc(1,nlayers+1) - uflx(1,nlayers+1) + + if (present(lwupt)) then +! Output up and down toa fluxes for total and clear sky +! nlayers+1 represents value at 0 mb + lwupt(i,j) = uflx(1,nlayers+1) + lwuptc(i,j) = uflxc(1,nlayers+1) + lwdnt(i,j) = dflx(1,nlayers+1) + lwdntc(i,j) = dflxc(1,nlayers+1) +! Output up and down surface fluxes for total and clear sky + lwupb(i,j) = uflx(1,1) + lwupbc(i,j) = uflxc(1,1) + lwdnb(i,j) = dflx(1,1) + lwdnbc(i,j) = dflxc(1,1) + if(calc_clean_atm_diag .gt. 0)then +! Output up and down toa fluxes for clean sky + lwuptcln(i,j) = uflxcln(1,nlayers+1) + lwdntcln(i,j) = dflxcln(1,nlayers+1) +! Output up and down surface fluxes for clean sky + lwupbcln(i,j) = uflxcln(1,1) + lwdnbcln(i,j) = dflxcln(1,1) + end if + endif + +! Output up and down layer fluxes for total and clear sky. +! Vertical ordering is from bottom to top in units of W m-2. + if ( present (lwupflx) ) then + do k=kts,kte+2 + lwupflx(i,k,j) = uflx(1,k) + lwupflxc(i,k,j) = uflxc(1,k) + lwdnflx(i,k,j) = dflx(1,k) + lwdnflxc(i,k,j) = dflxc(1,k) + enddo + endif + +! Output heating rate tendency; convert heating rate from K/d to K/s +! Heating rate arrays are ordered vertically from bottom to top here. + do k=kts,kte + tten1d(k) = hr(ncol,k)/86400. + rthratenlw(i,k,j) = tten1d(k)/pi3d(i,k,j) + enddo + +! + end do i_loop + end do j_loop + +!------------------------------------------------------------------- + + END SUBROUTINE RRTMG_LWRAD + + +!------------------------------------------------------------------------- + SUBROUTINE INIRAD (O3PROF,Plev, kts, kte) +!------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: kts,kte + + REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF + + REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev + +! LOCAL VAR + + INTEGER :: k + +! +! COMPUTE OZONE MIXING RATIO DISTRIBUTION +! + DO K=kts,kte+1 + O3PROF(K)=0. + ENDDO + + CALL O3DATA(O3PROF, Plev, kts, kte) + + END SUBROUTINE INIRAD + +!------------------------------------------------------------------------- + SUBROUTINE O3DATA (O3PROF, Plev, kts, kte) +!------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------- +! + INTEGER, INTENT(IN ) :: kts, kte +! + REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF + + REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev + +! LOCAL VAR + INTEGER :: K, JJ + + REAL :: PRLEVH(kts:kte+2),PPWRKH(32), & + O3WRK(31),PPWRK(31),O3SUM(31),PPSUM(31), & + O3WIN(31),PPWIN(31),O3ANN(31),PPANN(31) + + REAL :: PB1, PB2, PT1, PT2 + + DATA O3SUM /5.297E-8,5.852E-8,6.579E-8,7.505E-8, & + 8.577E-8,9.895E-8,1.175E-7,1.399E-7,1.677E-7,2.003E-7, & + 2.571E-7,3.325E-7,4.438E-7,6.255E-7,8.168E-7,1.036E-6, & + 1.366E-6,1.855E-6,2.514E-6,3.240E-6,4.033E-6,4.854E-6, & + 5.517E-6,6.089E-6,6.689E-6,1.106E-5,1.462E-5,1.321E-5, & + 9.856E-6,5.960E-6,5.960E-6/ + + DATA PPSUM /955.890,850.532,754.599,667.742,589.841, & + 519.421,455.480,398.085,347.171,301.735,261.310,225.360, & + 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123, & + 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122, & + 9.277, 4.660, 2.421, 1.294, 0.647/ +! + DATA O3WIN /4.629E-8,4.686E-8,5.017E-8,5.613E-8, & + 6.871E-8,8.751E-8,1.138E-7,1.516E-7,2.161E-7,3.264E-7, & + 4.968E-7,7.338E-7,1.017E-6,1.308E-6,1.625E-6,2.011E-6, & + 2.516E-6,3.130E-6,3.840E-6,4.703E-6,5.486E-6,6.289E-6, & + 6.993E-6,7.494E-6,8.197E-6,9.632E-6,1.113E-5,1.146E-5, & + 9.389E-6,6.135E-6,6.135E-6/ + + DATA PPWIN /955.747,841.783,740.199,649.538,568.404, & + 495.815,431.069,373.464,322.354,277.190,237.635,203.433, & + 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940, & + 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423, & + 7.583, 3.620, 1.807, 0.938, 0.469/ +! + + DO K=1,31 + PPANN(K)=PPSUM(K) + ENDDO +! + O3ANN(1)=0.5*(O3SUM(1)+O3WIN(1)) +! + DO K=2,31 + O3ANN(K)=O3WIN(K-1)+(O3WIN(K)-O3WIN(K-1))/(PPWIN(K)-PPWIN(K-1))* & + (PPSUM(K)-PPWIN(K-1)) + ENDDO +! + DO K=2,31 + O3ANN(K)=0.5*(O3ANN(K)+O3SUM(K)) + ENDDO +! + DO K=1,31 + O3WRK(K)=O3ANN(K) + PPWRK(K)=PPANN(K) + ENDDO +! +! CALCULATE HALF PRESSURE LEVELS FOR MODEL AND DATA LEVELS +! + +! Plev is total P at model levels, from bottom to top +! Plev is in mb + + DO K=kts,kte+2 + PRLEVH(K)=Plev(K) + ENDDO +! + PPWRKH(1)=1100. + DO K=2,31 + PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2. + ENDDO + PPWRKH(32)=0. + DO K=kts,kte+1 + DO 25 JJ=1,31 + IF((-(PRLEVH(K)-PPWRKH(JJ))).GE.0.)THEN + PB1=0. + ELSE + PB1=PRLEVH(K)-PPWRKH(JJ) + ENDIF + IF((-(PRLEVH(K)-PPWRKH(JJ+1))).GE.0.)THEN + PB2=0. + ELSE + PB2=PRLEVH(K)-PPWRKH(JJ+1) + ENDIF + IF((-(PRLEVH(K+1)-PPWRKH(JJ))).GE.0.)THEN + PT1=0. + ELSE + PT1=PRLEVH(K+1)-PPWRKH(JJ) + ENDIF + IF((-(PRLEVH(K+1)-PPWRKH(JJ+1))).GE.0.)THEN + PT2=0. + ELSE + PT2=PRLEVH(K+1)-PPWRKH(JJ+1) + ENDIF + O3PROF(K)=O3PROF(K)+(PB2-PB1-PT2+PT1)*O3WRK(JJ) + 25 CONTINUE + O3PROF(K)=O3PROF(K)/(PRLEVH(K)-PRLEVH(K+1)) + + ENDDO +! + END SUBROUTINE O3DATA + +!------------------------------------------------------------------ + +!==================================================================== + SUBROUTINE rrtmg_lwinit( & + p_top, allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL, INTENT(IN) :: p_top + +! Steven Cavallo. Added for buffer layer adjustment. December 2010. + NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels. + ! nlayers will subsequently + ! replace kte+1 + + + + ! Read in absorption coefficients and other data + IF ( allowed_to_read ) THEN + CALL rrtmg_lwlookuptable + ENDIF + +! Perform g-point reduction and other initializations +! Specific heat of dry air (cp) used in flux to heating rate conversion factor. + call rrtmg_lw_ini(cp) + + END SUBROUTINE rrtmg_lwinit + + +! ************************************************************************** + SUBROUTINE rrtmg_lwlookuptable +! ************************************************************************** +USE io_routines, ONLY: io_newunit, io_read +IMPLICIT NONE + +! Local + INTEGER :: i + LOGICAL :: opened +! LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER*80 errmess + INTEGER rrtmg_unit + INTEGER FILESIZE , recl + REAL :: foo + + rrtmg_unit = io_newunit() + IF ( rrtmg_unit < 0 ) THEN + error stop 'module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// & + 'find unused fortran unit to read in lookup table.' + ENDIF + + call lw_kgb01(rrtmg_unit) + call lw_kgb02(rrtmg_unit) + call lw_kgb03(rrtmg_unit) + call lw_kgb04(rrtmg_unit) + call lw_kgb05(rrtmg_unit) + call lw_kgb06(rrtmg_unit) + call lw_kgb07(rrtmg_unit) + call lw_kgb08(rrtmg_unit) + call lw_kgb09(rrtmg_unit) + call lw_kgb10(rrtmg_unit) + call lw_kgb11(rrtmg_unit) + call lw_kgb12(rrtmg_unit) + call lw_kgb13(rrtmg_unit) + call lw_kgb14(rrtmg_unit) + call lw_kgb15(rrtmg_unit) + call lw_kgb16(rrtmg_unit) + + CLOSE (rrtmg_unit) + + RETURN +9009 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error opening RRTMG_LW_DATA on unit ',rrtmg_unit + !CALL wrf_error_fatal(errmess) + error stop errmess + END SUBROUTINE rrtmg_lwlookuptable + +! ************************************************************************** +! RRTMG Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original version: E. J. Mlawer, et al. +! Revision for GCMs: Michael J. Iacono; October, 2002 +! Revision for F90 formatting: Michael J. Iacono; June 2006 +! +! This file contains 16 READ statements that include the +! absorption coefficients and other data for each of the 16 longwave +! spectral bands used in RRTMG_LW. Here, the data are defined for 16 +! g-points, or sub-intervals, per band. These data are combined and +! weighted using a mapping procedure in module RRTMG_LW_INIT to reduce +! the total number of g-points from 256 to 140 for use in the GCM. +! ************************************************************************** + +! ************************************************************************** + subroutine lw_kgb01(rrtmg_unit) +! ************************************************************************** + USE io_routines!, ONLY: io_newunit, io_read + use rrlw_kg01, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, & + absa, absb, & + selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The arrays kao_mn2 and kbo_mn2 contain the coefficients of the +! nitrogen continuum for the upper and lower atmosphere. +! Minor gas mapping levels: +! Lower - n2: P = 142.5490 mbar, T = 215.70 K +! Upper - n2: P = 142.5490 mbar, T = 215.70 K + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + + call io_read1d("rrtmg_support/fracrefao_1.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_1.nc", "fracrefbo", fracrefbo) + call io_read3d("rrtmg_support/kao_1.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_1.nc", "kbo", kbo) + call io_read2d("rrtmg_support/kao_mn2_1.nc", "kao_mn2", kao_mn2) + call io_read2d("rrtmg_support/kbo_mn2_1.nc", "kbo_mn2", kbo_mn2) + call io_read2d("rrtmg_support/selfrefo_1.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_1.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine lw_kgb01 + +! ************************************************************************** + subroutine lw_kgb02(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg02, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 1053.630 mbar, T = 294.2 K +! Upper: P = 3.206e-2 mb, T = 197.92 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read1d("rrtmg_support/fracrefao_2.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_2.nc", "fracrefbo", fracrefbo) + call io_read3d("rrtmg_support/kao_2.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_2.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_2.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_2.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine lw_kgb02 + +! ************************************************************************** + subroutine lw_kgb03(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg03, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, & + kbo_mn2o, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 212.7250 mbar, T = 223.06 K +! Upper: P = 95.8 mbar, T = 215.7 k + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amounts ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 to +! that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_3.nc", "fracrefao", fracrefao) + call io_read2d("rrtmg_support/fracrefbo_3.nc", "fracrefbo", fracrefbo) + call io_read4d("rrtmg_support/kao_3.nc", "kao", kao) + call io_read4d("rrtmg_support/kbo_3.nc", "kbo", kbo) + call io_read3d("rrtmg_support/kao_mn2o_3.nc", "kao_mn2o", kao_mn2o) + call io_read3d("rrtmg_support/kbo_mn2o_3.nc", "kbo_mn2o", kbo_mn2o) + call io_read2d("rrtmg_support/selfrefo_3.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_3.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb03 + +! ************************************************************************** + subroutine lw_kgb04(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg04, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower : P = 142.5940 mbar, T = 215.70 K +! Upper : P = 95.58350 mb, T = 215.70 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of H2O to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_4.nc", "fracrefao", fracrefao) + call io_read2d("rrtmg_support/fracrefbo_4.nc", "fracrefbo", fracrefbo) + call io_read4d("rrtmg_support/kao_4.nc", "kao", kao) + call io_read4d("rrtmg_support/kbo_4.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_4.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_4.nc", "forrefo", forrefo) + + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb04 + +! ************************************************************************** + subroutine lw_kgb05(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg05, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, & + selfrefo, forrefo, ccl4o + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 473.42 mb, T = 259.83 +! Upper: P = 0.2369280 mbar, T = 253.60 K + +! The arrays kao_mo3 and ccl4o contain the coefficients for +! ozone and ccl4 in the lower atmosphere. +! Minor gas mapping level: +! Lower - o3: P = 317.34 mbar, T = 240.77 k +! Lower - ccl4: + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of H2O to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_5.nc", "fracrefao", fracrefao) + call io_read2d("rrtmg_support/fracrefbo_5.nc", "fracrefbo", fracrefbo) + call io_read4d("rrtmg_support/kao_5.nc", "kao", kao) + call io_read4d("rrtmg_support/kbo_5.nc", "kbo", kbo) + call io_read3d("rrtmg_support/kao_mo3_5.nc", "kao_mo3", kao_mo3) + call io_read1d("rrtmg_support/ccl4o_5.nc", "ccl4o", ccl4o) + call io_read2d("rrtmg_support/selfrefo_5.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_5.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb05 + +! ************************************************************************** + subroutine lw_kgb06(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg06 +! use rrlw_kg06, only : fracrefao, kao, kao_mco2, selfrefo, forrefo, & +! cfc11adjo, cfc12o + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: : P = 473.4280 mb, T = 259.83 K + +! The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for +! carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper +! atmosphere. +! Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band. +! Minor gas mapping level: +! Lower - co2: P = 706.2720 mb, T = 294.2 k +! Upper - cfc11, cfc12 + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read1d("rrtmg_support/fracrefao_6.nc", "fracrefao", fracrefao) + call io_read3d("rrtmg_support/kao_6.nc", "kao", kao) + call io_read2d("rrtmg_support/kao_mco2_6.nc", "kao_mco2", kao_mco2) + call io_read1d("rrtmg_support/cfc11adjo_6.nc", "cfc11adjo", cfc11adjo) + call io_read1d("rrtmg_support/cfc12o_6.nc", "cfc12o", cfc12o) + call io_read2d("rrtmg_support/selfrefo_6.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_6.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + + end subroutine lw_kgb06 + +! ************************************************************************** + subroutine lw_kgb07(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg07, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, & + kbo_mco2, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower : P = 706.27 mb, T = 278.94 K +! Upper : P = 95.58 mbar, T= 215.70 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296_rb,260_rb,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_7.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_7.nc", "fracrefbo", fracrefbo) + call io_read4d("rrtmg_support/kao_7.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_7.nc", "kbo", kbo) + call io_read3d("rrtmg_support/kao_mco2_7.nc", "kao_mco2", kao_mco2) + call io_read2d("rrtmg_support/kbo_mco2_7.nc", "kbo_mco2", kbo_mco2) + call io_read2d("rrtmg_support/selfrefo_7.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_7.nc", "forrefo", forrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb07 + +! ************************************************************************** + subroutine lw_kgb08(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg08, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, & + kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, & + cfc12o, cfc22adjo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=473.4280 mb, T = 259.83 K +! Upper: P=95.5835 mb, T= 215.7 K + +! The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients for +! carbon dioxide and n2o in the lower and upper atmosphere. +! The array kao_mo3 contains the coefficients for ozone in the lower atmosphere, +! and arrays cfc12o and cfc12adjo contain the coefficients for cfc12 and cfc22. +! Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1 +! and 1290-1335 cm-1 bands. +! Minor gas mapping level: +! Lower - co2: P = 1053.63 mb, T = 294.2 k +! Lower - o3: P = 317.348 mb, T = 240.77 k +! Lower - n2o: P = 706.2720 mb, T= 278.94 k +! Lower - cfc12, cfc22 +! Upper - co2: P = 35.1632 mb, T = 223.28 k +! Upper - n2o: P = 8.716e-2 mb, T = 226.03 k + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read1d("rrtmg_support/fracrefao_8.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_8.nc", "fracrefbo", fracrefbo) + call io_read3d("rrtmg_support/kao_8.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_8.nc", "kbo", kbo) + call io_read2d("rrtmg_support/kao_mco2_8.nc", "kao_mco2", kao_mco2) + call io_read2d("rrtmg_support/kbo_mco2_8.nc", "kbo_mco2", kbo_mco2) + call io_read2d("rrtmg_support/kao_mn2o_8.nc", "kao_mn2o", kao_mn2o) + call io_read2d("rrtmg_support/kbo_mn2o_8.nc", "kbo_mn2o", kbo_mn2o) + call io_read2d("rrtmg_support/kao_mo3_8.nc", "kao_mo3", kao_mo3) + call io_read2d("rrtmg_support/selfrefo_8.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_8.nc", "forrefo", forrefo) + call io_read1d("rrtmg_support/cfc12o_8.nc", "cfc12o", cfc12o) + call io_read1d("rrtmg_support/cfc22adjo_8.nc", "cfc22adjo", cfc22adjo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb08 + +! ************************************************************************** + subroutine lw_kgb09(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg09, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, & + kbo_mn2o, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=212.7250 mb, T = 223.06 K +! Upper: P=3.20e-2 mb, T = 197.92 k + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_9.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_9.nc", "fracrefbo", fracrefbo) + call io_read4d("rrtmg_support/kao_9.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_9.nc", "kbo", kbo) + call io_read3d("rrtmg_support/kao_mn2o_9.nc", "kao_mn2o", kao_mn2o) + call io_read2d("rrtmg_support/kbo_mn2o_9.nc", "kbo_mn2o", kbo_mn2o) + call io_read2d("rrtmg_support/selfrefo_9.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_9.nc", "forrefo", forrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb09 + +! ************************************************************************** + subroutine lw_kgb10(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg10, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 212.7250 mb, T = 223.06 K +! Upper: P = 95.58350 mb, T = 215.70 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read1d("rrtmg_support/fracrefao_10.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_10.nc", "fracrefbo", fracrefbo) + call io_read3d("rrtmg_support/kao_10.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_10.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_10.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_10.nc", "forrefo", forrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb10 + +! ************************************************************************** + subroutine lw_kgb11(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg11, only : fracrefao, fracrefbo, kao, kbo, kao_mo2, & + kbo_mo2, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=1053.63 mb, T= 294.2 K +! Upper: P=0.353 mb, T = 262.11 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read1d("rrtmg_support/fracrefao_11.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_11.nc", "fracrefbo", fracrefbo) + call io_read3d("rrtmg_support/kao_11.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_11.nc", "kbo", kbo) + call io_read2d("rrtmg_support/kao_mo2_11.nc", "kao_mo2", kao_mo2) + call io_read2d("rrtmg_support/kbo_mo2_11.nc", "kbo_mo2", kbo_mo2) + call io_read2d("rrtmg_support/selfrefo_11.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_11.nc", "forrefo", forrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb11 + +! ************************************************************************** + subroutine lw_kgb12(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg12, only : fracrefao, kao, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 174.1640 mbar, T= 215.78 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_12.nc", "fracrefao", fracrefao) + call io_read4d("rrtmg_support/kao_12.nc", "kao", kao) + call io_read2d("rrtmg_support/selfrefo_12.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_12.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb12 + +! ************************************************************************** + subroutine lw_kgb13(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg13, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco, & + kbo_mo3, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=473.4280 mb, T = 259.83 K +! Upper: P=4.758820 mb, T = 250.85 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_13.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_13.nc", "fracrefbo", fracrefbo) + call io_read4d("rrtmg_support/kao_13.nc", "kao", kao) + call io_read3d("rrtmg_support/kao_mco2_13.nc", "kao_mco2", kao_mco2) + call io_read3d("rrtmg_support/kao_mco_13.nc", "kao_mco", kao_mco) + call io_read2d("rrtmg_support/kbo_mo3_13.nc", "kbo_mo3", kbo_mo3) + call io_read2d("rrtmg_support/selfrefo_13.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_13.nc", "forrefo", forrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb13 + +! ************************************************************************** + subroutine lw_kgb14(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg14, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 142.5940 mb, T = 215.70 K +! Upper: P = 4.758820 mb, T = 250.85 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read1d("rrtmg_support/fracrefao_14.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_14.nc", "fracrefbo", fracrefbo) + call io_read3d("rrtmg_support/kao_14.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_14.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_14.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_14.nc", "forrefo", forrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb14 + +! ************************************************************************** + subroutine lw_kgb15(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg15, only : fracrefao, kao, kao_mn2, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 1053. mb, T = 294.2 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KA_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_15.nc", "fracrefao", fracrefao) + call io_read4d("rrtmg_support/kao_15.nc", "kao", kao) + call io_read3d("rrtmg_support/kao_mn2_15.nc", "kao_mn2", kao_mn2) + call io_read2d("rrtmg_support/selfrefo_15.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_15.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb15 + +! ************************************************************************** + subroutine lw_kgb16(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrlw_kg16, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + ! logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 387.6100 mbar, T = 250.17 K +! Upper: P=95.58350 mb, T = 215.70 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/fracrefao_16.nc", "fracrefao", fracrefao) + call io_read1d("rrtmg_support/fracrefbo_16.nc", "fracrefbo", fracrefbo) + call io_read4d("rrtmg_support/kao_16.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_16.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_16.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_16.nc", "forrefo", forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine lw_kgb16 + +!=============================================================================== + subroutine relcalc(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute cloud water size +! +! Method: +! analytic formula following the formulation originally developed by J. T. Kiehl +! +! Author: Phil Rasch +! +!----------------------------------------------------------------------- + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: ncol + integer, intent(in) :: pcols, pver + real, intent(in) :: landfrac(pcols) ! Land fraction + real, intent(in) :: icefrac(pcols) ! Ice fraction + real, intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m) + real, intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean + real, intent(in) :: t(pcols,pver) ! Temperature + +! +! Output arguments +! + real, intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns) +! +!---------------------------Local workspace----------------------------- +! + integer i,k ! Lon, lev indices + real tmelt ! freezing temperature of fresh water (K) + real rliqland ! liquid drop size if over land + real rliqocean ! liquid drop size if over ocean + real rliqice ! liquid drop size if over sea ice +! +!----------------------------------------------------------------------- +! + tmelt = 273.16 + rliqocean = 14.0 + rliqice = 14.0 + rliqland = 8.0 + do k=1,pver + do i=1,ncol +! jrm Reworked effective radius algorithm + ! Start with temperature-dependent value appropriate for continental air + ! Note: findmcnew has a pressure dependence here + rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0,max(0.0,(tmelt-t(i,k))*0.05)) + ! Modify for snow depth over land + rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,snowh(i)*10.)) + ! Ramp between polluted value over land to clean value over ocean. + rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,1.0-landm(i))) + ! Ramp between the resultant value and a sea ice value in the presence of ice. + rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0,max(0.0,icefrac(i))) +! end jrm + end do + end do + end subroutine relcalc +!=============================================================================== + subroutine reicalc(ncol, pcols, pver, t, re) + ! + + integer, intent(in) :: ncol, pcols, pver + real, intent(out) :: re(pcols,pver) + real, intent(in) :: t(pcols,pver) + real corr + integer i + integer k + integer index + ! + ! Tabulated values of re(T) in the temperature interval + ! 180 K -- 274 K; hexagonal columns assumed: + ! + ! + do k=1,pver + do i=1,ncol + index = int(t(i,k)-179.) + index = min(max(index,1),94) + corr = t(i,k) - int(t(i,k)) + re(i,k) = retab(index)*(1.-corr) & + +retab(index+1)*corr + ! re(i,k) = amax1(amin1(re(i,k),30.),10.) + end do + end do + ! + return + end subroutine reicalc +!------------------------------------------------------------------ + +END MODULE module_ra_rrtmg_lw diff --git a/src/physics/ra_rrtmg_sw.f90 b/src/physics/ra_rrtmg_sw.f90 new file mode 100644 index 00000000..4c60aeb4 --- /dev/null +++ b/src/physics/ra_rrtmg_sw.f90 @@ -0,0 +1,12367 @@ +!!MODULE module_ra_rrtmg_sw + + module parrrsw + + use parkind ,only : im => kind_im, rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw main parameters +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! mxlay : integer: maximum number of layers +! mg : integer: number of original g-intervals per spectral band +! nbndsw : integer: number of spectral bands +! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) +! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw +! ngNN : integer: number of reduced g-intervals per spectral band +! ngsNN : integer: cumulative number of g-intervals per band +!------------------------------------------------------------------ + + integer(kind=im), parameter :: mxlay = 203 !jplay, klev + integer(kind=im), parameter :: mg = 16 !jpg + integer(kind=im), parameter :: nbndsw = 14 !jpsw, ksw + integer(kind=im), parameter :: naerec = 6 !jpaer + integer(kind=im), parameter :: mxmol = 38 + integer(kind=im), parameter :: nstr = 2 + integer(kind=im), parameter :: nmol = 7 +! Use for 112 g-point model + integer(kind=im), parameter :: ngptsw = 112 !jpgpt +! Use for 224 g-point model +! integer(kind=im), parameter :: ngptsw = 224 !jpgpt + +! may need to rename these - from v2.6 + integer(kind=im), parameter :: jpband = 29 + integer(kind=im), parameter :: jpb1 = 16 !istart + integer(kind=im), parameter :: jpb2 = 29 !iend + + integer(kind=im), parameter :: jmcmu = 32 + integer(kind=im), parameter :: jmumu = 32 + integer(kind=im), parameter :: jmphi = 3 + integer(kind=im), parameter :: jmxang = 4 + integer(kind=im), parameter :: jmxstr = 16 + +! Use for 112 g-point model + integer(kind=im), parameter :: ng16 = 6 + integer(kind=im), parameter :: ng17 = 12 + integer(kind=im), parameter :: ng18 = 8 + integer(kind=im), parameter :: ng19 = 8 + integer(kind=im), parameter :: ng20 = 10 + integer(kind=im), parameter :: ng21 = 10 + integer(kind=im), parameter :: ng22 = 2 + integer(kind=im), parameter :: ng23 = 10 + integer(kind=im), parameter :: ng24 = 8 + integer(kind=im), parameter :: ng25 = 6 + integer(kind=im), parameter :: ng26 = 6 + integer(kind=im), parameter :: ng27 = 8 + integer(kind=im), parameter :: ng28 = 6 + integer(kind=im), parameter :: ng29 = 12 + + integer(kind=im), parameter :: ngs16 = 6 + integer(kind=im), parameter :: ngs17 = 18 + integer(kind=im), parameter :: ngs18 = 26 + integer(kind=im), parameter :: ngs19 = 34 + integer(kind=im), parameter :: ngs20 = 44 + integer(kind=im), parameter :: ngs21 = 54 + integer(kind=im), parameter :: ngs22 = 56 + integer(kind=im), parameter :: ngs23 = 66 + integer(kind=im), parameter :: ngs24 = 74 + integer(kind=im), parameter :: ngs25 = 80 + integer(kind=im), parameter :: ngs26 = 86 + integer(kind=im), parameter :: ngs27 = 94 + integer(kind=im), parameter :: ngs28 = 100 + integer(kind=im), parameter :: ngs29 = 112 + +! Use for 224 g-point model +! integer(kind=im), parameter :: ng16 = 16 +! integer(kind=im), parameter :: ng17 = 16 +! integer(kind=im), parameter :: ng18 = 16 +! integer(kind=im), parameter :: ng19 = 16 +! integer(kind=im), parameter :: ng20 = 16 +! integer(kind=im), parameter :: ng21 = 16 +! integer(kind=im), parameter :: ng22 = 16 +! integer(kind=im), parameter :: ng23 = 16 +! integer(kind=im), parameter :: ng24 = 16 +! integer(kind=im), parameter :: ng25 = 16 +! integer(kind=im), parameter :: ng26 = 16 +! integer(kind=im), parameter :: ng27 = 16 +! integer(kind=im), parameter :: ng28 = 16 +! integer(kind=im), parameter :: ng29 = 16 + +! integer(kind=im), parameter :: ngs16 = 16 +! integer(kind=im), parameter :: ngs17 = 32 +! integer(kind=im), parameter :: ngs18 = 48 +! integer(kind=im), parameter :: ngs19 = 64 +! integer(kind=im), parameter :: ngs20 = 80 +! integer(kind=im), parameter :: ngs21 = 96 +! integer(kind=im), parameter :: ngs22 = 112 +! integer(kind=im), parameter :: ngs23 = 128 +! integer(kind=im), parameter :: ngs24 = 144 +! integer(kind=im), parameter :: ngs25 = 160 +! integer(kind=im), parameter :: ngs26 = 176 +! integer(kind=im), parameter :: ngs27 = 192 +! integer(kind=im), parameter :: ngs28 = 208 +! integer(kind=im), parameter :: ngs29 = 224 + +! Source function solar constant + real(kind=rb), parameter :: rrsw_scon = 1.36822e+03 ! W/m2 + + end module parrrsw + + module rrsw_aer + + use parkind, only : im => kind_im, rb => kind_rb + use parrrsw, only : nbndsw, naerec + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw aerosol optical properties +! +! Data derived from six ECMWF aerosol types and defined for +! the rrtmg_sw spectral intervals +! +! Initial: J.-J. Morcrette, ECMWF, mar2003 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ +! +!-- The six ECMWF aerosol types are respectively: +! +! 1/ continental average 2/ maritime +! 3/ desert 4/ urban +! 5/ volcanic active 6/ stratospheric background +! +! computed from Hess and Koepke (con, mar, des, urb) +! from Bonnel et al. (vol, str) +! +! rrtmg_sw 14 spectral intervals (microns): +! 3.846 - 3.077 +! 3.077 - 2.500 +! 2.500 - 2.150 +! 2.150 - 1.942 +! 1.942 - 1.626 +! 1.626 - 1.299 +! 1.299 - 1.242 +! 1.242 - 0.7782 +! 0.7782- 0.6250 +! 0.6250- 0.4415 +! 0.4415- 0.3448 +! 0.3448- 0.2632 +! 0.2632- 0.2000 +! 12.195 - 3.846 +! +!------------------------------------------------------------------ +! +! name type purpose +! ----- : ---- : ---------------------------------------------- +! rsrtaua : real : ratio of average optical thickness in +! spectral band to that at 0.55 micron +! rsrpiza : real : average single scattering albedo (unitless) +! rsrasya : real : average asymmetry parameter (unitless) +!------------------------------------------------------------------ + + real(kind=rb) :: rsrtaua(nbndsw,naerec) + real(kind=rb) :: rsrpiza(nbndsw,naerec) + real(kind=rb) :: rsrasya(nbndsw,naerec) + + end module rrsw_aer + + module rrsw_cld + + use parkind, only : im => kind_im, rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw cloud property coefficients +! +! Initial: J.-J. Morcrette, ECMWF, oct1999 +! Revised: J. Delamere/MJIacono, AER, aug2005 +! Revised: MJIacono, AER, nov2005 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ +! +! name type purpose +! ----- : ---- : ---------------------------------------------- +! xxxliq1 : real : optical properties (extinction coefficient, single +! scattering albedo, assymetry factor) from +! Hu & Stamnes, j. clim., 6, 728-742, 1993. +! xxxice2 : real : optical properties (extinction coefficient, single +! scattering albedo, assymetry factor) from streamer v3.0, +! Key, streamer user's guide, cooperative institude +! for meteorological studies, 95 pp., 2001. +! xxxice3 : real : optical properties (extinction coefficient, single +! scattering albedo, assymetry factor) from +! Fu, j. clim., 9, 1996. +! xbari : real : optical property coefficients for five spectral +! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285, +! and 14285-40000 wavenumbers) following +! Ebert and Curry, jgr, 97, 3831-3836, 1992. +!------------------------------------------------------------------ + + real(kind=rb) :: extliq1(58,16:29), ssaliq1(58,16:29), asyliq1(58,16:29) + real(kind=rb) :: extice2(43,16:29), ssaice2(43,16:29), asyice2(43,16:29) + real(kind=rb) :: extice3(46,16:29), ssaice3(46,16:29), asyice3(46,16:29) + real(kind=rb) :: fdlice3(46,16:29) + real(kind=rb) :: abari(5),bbari(5),cbari(5),dbari(5),ebari(5),fbari(5) + + end module rrsw_cld + + module rrsw_con + + use parkind, only : im => kind_im, rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw constants + +! Initial version: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! fluxfac: real : radiance to flux conversion factor +! heatfac: real : flux to heating rate conversion factor +!oneminus: real : 1.-1.e-6 +! pi : real : pi +! grav : real : acceleration of gravity +! planck : real : planck constant +! boltz : real : boltzmann constant +! clight : real : speed of light +! avogad : real : avogadro constant +! alosmt : real : loschmidt constant +! gascon : real : molar gas constant +! radcn1 : real : first radiation constant +! radcn2 : real : second radiation constant +! sbcnst : real : stefan-boltzmann constant +! secdy : real : seconds per day +!------------------------------------------------------------------ + + real(kind=rb) :: fluxfac, heatfac + real(kind=rb) :: oneminus, pi, grav + real(kind=rb) :: planck, boltz, clight + real(kind=rb) :: avogad, alosmt, gascon + real(kind=rb) :: radcn1, radcn2 + real(kind=rb) :: sbcnst, secdy + + end module rrsw_con + + module rrsw_kg16 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng16 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 16 +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no16 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:) :: sfluxrefo(:) + + integer(kind=im) :: layreffr + real :: rayl, strrat1 + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 16 +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng16) , absa(585,ng16) + real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16) + real(kind=rb) :: selfref(10,ng16), forref(3,ng16) + real(kind=rb) :: sfluxref(ng16) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg16 + + module rrsw_kg17 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng17 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 17 +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no17 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:,:) :: kbo(:,:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:,:) :: sfluxrefo(:,:) + + integer(kind=im) :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 17 +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng17) , absa(585,ng17) + real(kind=rb) :: kb(5,5,13:59,ng17), absb(1175,ng17) + real(kind=rb) :: selfref(10,ng17), forref(4,ng17) + real(kind=rb) :: sfluxref(ng17,5) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1)) + + end module rrsw_kg17 + + module rrsw_kg18 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng18 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 18 +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no18 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:,:) :: sfluxrefo(:,:) + + integer(kind=im) :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 18 +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng18), absa(585,ng18) + real(kind=rb) :: kb(5,13:59,ng18), absb(235,ng18) + real(kind=rb) :: selfref(10,ng18), forref(3,ng18) + real(kind=rb) :: sfluxref(ng18,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg18 + + module rrsw_kg19 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng19 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 19 +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no19 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:,:) :: sfluxrefo(:,:) + + integer(kind=im) :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 19 +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng19), absa(585,ng19) + real(kind=rb) :: kb(5,13:59,ng19), absb(235,ng19) + real(kind=rb) :: selfref(10,ng19), forref(3,ng19) + real(kind=rb) :: sfluxref(ng19,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg19 + + module rrsw_kg20 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng20 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 20 +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +! absch4o : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no20 = 16 + + real,allocatable, dimension(:,:,:) :: kao(:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:) :: sfluxrefo(:) + real,allocatable, dimension(:) :: absch4o(:) + + integer(kind=im) :: layreffr + real :: rayl + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 20 +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +! absch4 : real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(5,13,ng20), absa(65,ng20) + real(kind=rb) :: kb(5,13:59,ng20), absb(235,ng20) + real(kind=rb) :: selfref(10,ng20), forref(4,ng20) + real(kind=rb) :: sfluxref(ng20) + real(kind=rb) :: absch4(ng20) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg20 + + module rrsw_kg21 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng21 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 21 +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no21 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:,:) :: kbo(:,:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:,:) :: sfluxrefo(:,:) + + integer(kind=im) :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 21 +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng21), absa(585,ng21) + real(kind=rb) :: kb(5,5,13:59,ng21), absb(1175,ng21) + real(kind=rb) :: selfref(10,ng21), forref(4,ng21) + real(kind=rb) :: sfluxref(ng21,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1)) + + end module rrsw_kg21 + + module rrsw_kg22 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng22 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 22 +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no22 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:,:) :: sfluxrefo(:,:) + + integer(kind=im) :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 22 +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng22), absa(585,ng22) + real(kind=rb) :: kb(5,13:59,ng22), absb(235,ng22) + real(kind=rb) :: selfref(10,ng22), forref(3,ng22) + real(kind=rb) :: sfluxref(ng22,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg22 + + module rrsw_kg23 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng23 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 23 +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no23 = 16 + + real,allocatable, dimension(:,:,:) :: kao(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:) :: sfluxrefo(:) + real,allocatable, dimension(:) :: raylo(:) + + integer(kind=im) :: layreffr + real :: givfac + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 23 +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(5,13,ng23), absa(65,ng23) + real(kind=rb) :: selfref(10,ng23), forref(3,ng23) + real(kind=rb) :: sfluxref(ng23), rayl(ng23) + + equivalence (ka(1,1,1),absa(1,1)) + + end module rrsw_kg23 + + module rrsw_kg24 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng24 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 24 +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +! abso3ao : real +! abso3bo : real +! raylao : real +! raylbo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no24 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:,:) :: sfluxrefo(:,:) + real,allocatable, dimension(:) :: abso3ao(:), abso3bo(:), raylbo(:) + real,allocatable, dimension(:,:) :: raylao(:,:) + + integer(kind=im) :: layreffr + real :: strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 24 +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +! abso3a : real +! abso3b : real +! rayla : real +! raylb : real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng24), absa(585,ng24) + real(kind=rb) :: kb(5,13:59,ng24), absb(235,ng24) + real(kind=rb) :: selfref(10,ng24), forref(3,ng24) + real(kind=rb) :: sfluxref(ng24,9) + real(kind=rb) :: abso3a(ng24), abso3b(ng24) + real(kind=rb) :: rayla(ng24,9), raylb(ng24) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg24 + + module rrsw_kg25 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng25 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 25 +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +!sfluxrefo: real +! abso3ao : real +! abso3bo : real +! raylo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no25 = 16 + + real,allocatable, dimension(:,:,:) :: kao(:,:,:) + real,allocatable, dimension(:) :: sfluxrefo(:) + real,allocatable, dimension(:) :: abso3ao(:), abso3bo(:) + real,allocatable, dimension(:) :: raylo(:) + + integer(kind=im) :: layreffr + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 25 +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! absa : real +! sfluxref: real +! abso3a : real +! abso3b : real +! rayl : real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(5,13,ng25), absa(65,ng25) + real(kind=rb) :: sfluxref(ng25) + real(kind=rb) :: abso3a(ng25), abso3b(ng25) + real(kind=rb) :: rayl(ng25) + + equivalence (ka(1,1,1),absa(1,1)) + + end module rrsw_kg25 + + module rrsw_kg26 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng26 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 26 +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!sfluxrefo: real +! raylo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no26 = 16 + + real,allocatable, dimension(:) :: sfluxrefo(:) + real,allocatable, dimension(:) :: raylo(:) + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 26 +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! sfluxref: real +! rayl : real +!----------------------------------------------------------------- + + real(kind=rb) :: sfluxref(ng26) + real(kind=rb) :: rayl(ng26) + + end module rrsw_kg26 + + module rrsw_kg27 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng27 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 27 +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +!sfluxrefo: real +! raylo : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no27 = 16 + + real,allocatable, dimension(:,:,:) :: kao(:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:) :: sfluxrefo(:) + real,allocatable, dimension(:) :: raylo(:) + + integer(kind=im) :: layreffr + real :: scalekur + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 27 +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! sfluxref: real +! rayl : real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(5,13,ng27), absa(65,ng27) + real(kind=rb) :: kb(5,13:59,ng27), absb(235,ng27) + real(kind=rb) :: sfluxref(ng27) + real(kind=rb) :: rayl(ng27) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg27 + + module rrsw_kg28 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng28 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 28 +! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no28 = 16 + + real,allocatable, dimension(:,:,:,:) :: kao(:,:,:,:) + real,allocatable, dimension(:,:,:,:) :: kbo(:,:,:,:) + real,allocatable, dimension(:,:) :: sfluxrefo(:,:) + + integer(kind=im) :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 28 +! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! sfluxref: real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(9,5,13,ng28), absa(585,ng28) + real(kind=rb) :: kb(5,5,13:59,ng28), absb(1175,ng28) + real(kind=rb) :: sfluxref(ng28,5) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1)) + + end module rrsw_kg28 + + module rrsw_kg29 + + use parkind ,only : im => kind_im, rb => kind_rb + use parrrsw, only : ng29 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 29 +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +! absh2oo : real +! absco2o : real +!----------------------------------------------------------------- + + integer(kind=im), parameter :: no29 = 16 + + real,allocatable, dimension(:,:,:):: kao(:,:,:) + real,allocatable, dimension(:,:,:) :: kbo(:,:,:) + real,allocatable, dimension(:,:) :: selfrefo(:,:), forrefo(:,:) + real,allocatable, dimension(:) :: sfluxrefo(:) + real,allocatable, dimension(:) :: absh2oo(:), absco2o(:) + + integer(kind=im) :: layreffr + real :: rayl + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 29 +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! selfref : real +! forref : real +! sfluxref: real +! absh2o : real +! absco2 : real +!----------------------------------------------------------------- + + real(kind=rb) :: ka(5,13,ng29), absa(65,ng29) + real(kind=rb) :: kb(5,13:59,ng29), absb(235,ng29) + real(kind=rb) :: selfref(10,ng29), forref(4,ng29) + real(kind=rb) :: sfluxref(ng29) + real(kind=rb) :: absh2o(ng29), absco2(ng29) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg29 + + module rrsw_ref + + use parkind, only : im => kind_im, rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw reference atmosphere +! Based on standard mid-latitude summer profile +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! pref : real : Reference pressure levels +! preflog: real : Reference pressure levels, ln(pref) +! tref : real : Reference temperature levels for MLS profile +!------------------------------------------------------------------ + + real(kind=rb) , dimension(59) :: pref + real(kind=rb) , dimension(59) :: preflog + real(kind=rb) , dimension(59) :: tref + + end module rrsw_ref + + module rrsw_tbl + + use parkind, only : im => kind_im, rb => kind_rb + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw lookup table arrays + +! Initial version: MJIacono, AER, may2007 +! Revised: MJIacono, AER, aug2007 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ntbl : integer: Lookup table dimension +! tblint : real : Lookup table conversion factor +! tau_tbl: real : Clear-sky optical depth +! exp_tbl: real : Exponential lookup table for transmittance +! od_lo : real : Value of tau below which expansion is used +! : in place of lookup table +! pade : real : Pade approximation constant +! bpade : real : Inverse of Pade constant +!------------------------------------------------------------------ + + integer(kind=im), parameter :: ntbl = 10000 + + real(kind=rb), parameter :: tblint = 10000.0_rb + + real(kind=rb), parameter :: od_lo = 0.06_rb + + real(kind=rb) :: tau_tbl + real(kind=rb) , dimension(0:ntbl) :: exp_tbl + + real(kind=rb), parameter :: pade = 0.278_rb + real(kind=rb) :: bpade + + end module rrsw_tbl + + module rrsw_vsn + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw version information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +!hnamrtm :character: +!hnamini :character: +!hnamcld :character: +!hnamclc :character: +!hnamrft :character: +!hnamspv :character: +!hnamspc :character: +!hnamset :character: +!hnamtau :character: +!hnamvqd :character: +!hnamatm :character: +!hnamutl :character: +!hnamext :character: +!hnamkg :character: +! +! hvrrtm :character: +! hvrini :character: +! hvrcld :character: +! hvrclc :character: +! hvrrft :character: +! hvrspv :character: +! hvrspc :character: +! hvrset :character: +! hvrtau :character: +! hvrvqd :character: +! hvratm :character: +! hvrutl :character: +! hvrext :character: +! hvrkg :character: +!------------------------------------------------------------------ + + character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, & + hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext + character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, & + hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext + + character*18 hvrkg + character*20 hnamkg + + end module rrsw_vsn + + module rrsw_wvn + + use parkind, only : im => kind_im, rb => kind_rb + use parrrsw, only : nbndsw, mg, ngptsw, jpb1, jpb2 + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw spectral information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ng : integer: Number of original g-intervals in each spectral band +! nspa : integer: +! nspb : integer: +!wavenum1: real : Spectral band lower boundary in wavenumbers +!wavenum2: real : Spectral band upper boundary in wavenumbers +! delwave: real : Spectral band width in wavenumbers +! +! ngc : integer: The number of new g-intervals in each band +! ngs : integer: The cumulative sum of new g-intervals for each band +! ngm : integer: The index of each new g-interval relative to the +! original 16 g-intervals in each band +! ngn : integer: The number of original g-intervals that are +! combined to make each new g-intervals in each band +! ngb : integer: The band index for each new g-interval +! wt : real : RRTM weights for the original 16 g-intervals +! rwgt : real : Weights for combining original 16 g-intervals +! (224 total) into reduced set of g-intervals +! (112 total) +!------------------------------------------------------------------ + + integer(kind=im) :: ng(jpb1:jpb2) + integer(kind=im) :: nspa(jpb1:jpb2) + integer(kind=im) :: nspb(jpb1:jpb2) + + real(kind=rb) :: wavenum1(jpb1:jpb2) + real(kind=rb) :: wavenum2(jpb1:jpb2) + real(kind=rb) :: delwave(jpb1:jpb2) + + integer(kind=im) :: ngc(nbndsw) + integer(kind=im) :: ngs(nbndsw) + integer(kind=im) :: ngn(ngptsw) + integer(kind=im) :: ngb(ngptsw) + integer(kind=im) :: ngm(nbndsw*mg) + + real(kind=rb) :: wt(mg) + real(kind=rb) :: rwgt(nbndsw*mg) + + end module rrsw_wvn + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module mcica_subcol_gen_sw + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! Purpose: Create McICA stochastic arrays for cloud physical or optical properties. +! Two options are possible: +! 1) Input cloud physical properties: cloud fraction, ice and liquid water +! paths, ice fraction, and particle sizes. Output will be stochastic +! arrays of these variables. (inflag = 1) +! 2) Input cloud optical properties directly: cloud optical depth, single +! scattering albedo and asymmetry parameter. Output will be stochastic +! arrays of these variables. (inflag = 0) + +! --------- Modules ---------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrsw, only : nbndsw, ngptsw + use rrsw_con, only: grav + use rrsw_wvn, only: ngb + use rrsw_vsn + + implicit none + +! public interfaces/functions/subroutines + public :: mcica_subcol_sw, generate_stochastic_clouds_sw + + contains + +!------------------------------------------------------------------ +! Public subroutines +!------------------------------------------------------------------ + +! mji - Add height needed for exponential-ranom cloud overlap method (icld=4) + subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, hgt, & + cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, ssac, asmc, fsfc, & + cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, & + taucmcl, ssacmcl, asmcmcl, fsfcmcl) + +! ----- Input ----- +! Control + integer(kind=im), intent(in) :: iplon ! column/longitude dimension + integer(kind=im), intent(in) :: ncol ! number of columns + integer(kind=im), intent(in) :: nlay ! number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, + ! permute the seed between each call; + ! between calls for LW and SW, recommended + ! permuteseed differs by 'ngpt' + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + +! Atmosphere + real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlay) +! mji - Add height + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) +! Atmosphere/clouds - cldprop + real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: res(:,:) ! cloud snow particle size + ! Dimensions: (ncol,nlay) + +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: fsfcmcl(:,:,:) ! in-cloud forward scattering fraction [mcica] + ! Dimensions: (ngptsw,ncol,nlay) + +! ----- Local ----- + +! Stochastic cloud generator variables [mcica] + integer(kind=im), parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals) + integer(kind=im) :: ilev ! loop index + + real(kind=rb) :: pmid(ncol,nlay) ! layer pressures (Pa) +! real(kind=rb) :: pdel(ncol,nlay) ! layer pressure thickness (Pa) +! real(kind=rb) :: qi(ncol,nlay) ! ice water (specific humidity) +! real(kind=rb) :: ql(ncol,nlay) ! liq water (specific humidity) + + +! Return if clear sky + if (icld.eq.0) return + +! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns + + +! Pass particle sizes to new arrays, no subcolumns for these properties yet +! Convert pressures from mb to Pa + + reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) + relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) + resnmcl(:ncol,:nlay) = res(:ncol,:nlay) + pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb + +! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components + +! cwp = (q * pdel * 1000.) / gravit) +! = (kg/kg * kg m-1 s-2 *1000.) / m s-2 +! = (g m-2) +! +! q = (cwp * gravit) / (pdel *1000.) +! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.) +! = kg/kg + +! do ilev = 1, nlay +! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb) +! enddo + +! Generate the stochastic subcolumns of cloud optical properties for the shortwave; + call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, irng, pmid, hgt, cldfrac, clwp, ciwp, cswp, & + tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, ciwpmcl, cswpmcl, & + taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed) + + end subroutine mcica_subcol_sw + + +!------------------------------------------------------------------------------------------------- + subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, hgt, cld, clwp, ciwp, cswp, & + tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, & + tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed) +!------------------------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------------------------------------------- + ! --------------------- + ! Contact: Cecile Hannay (hannay@ucar.edu) + ! + ! Original code: Based on Raisanen et al., QJRMS, 2004. + ! + ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default + ! random number generator, which can be changed to the optional kissvec random number generator + ! with flag 'irng'. Some extra functionality has been commented or removed. + ! Michael J. Iacono, AER, Inc., February 2007 + ! + ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. + ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one + ! and uniform cloud liquid and cloud ice concentration. + ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer + ! and obeys an overlap assumption in the vertical. + ! + ! Overlap assumption: + ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. + ! The default option is maximum-random (option 3) + ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap + ! This is set with the variable "overlap" + !mji - Exponential overlap option (overlap=4) has been deactivated in this version + ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) + ! + ! Seed: + ! If the stochastic cloud generator is called several times during the same timestep, + ! one should change the seed between the call to insure that the subcolumns are different. + ! This is done by changing the argument 'changeSeed' + ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , + ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call + ! + ! PDF assumption: + ! We can use arbitrary complicated PDFS. + ! In the present version, we produce homogeneuous clouds (the simplest case). + ! Future developments include using the PDF scheme of Ben Johnson. + ! + ! History file: + ! Option to add diagnostics variables in the history file. (using FINCL in the namelist) + ! nsubcol = number of subcolumns + ! overlap = overlap type (1-3) + ! Zo = length scale + ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) + ! CLDLIQ_S = mean of the subcolumn cloud water + ! CLDICE_S = mean of the subcolumn cloud ice + ! + ! Note: + ! Here: we force that the cloud condensate to be consistent with the cloud fraction + ! i.e we only have cloud condensate when the cell is cloudy. + ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations + ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction + ! without cloud condensate or the opposite). + !--------------------------------------------------------------------------------------------------------------- + + use mcica_random_numbers +! The Mersenne Twister random number engine + use MersenneTwister, only: randomNumberSequence, & + new_RandomNumberSequence, getRandomReal + + type(randomNumberSequence) :: randomNumbers + +! -- Arguments + + integer(kind=im), intent(in) :: ncol ! number of layers + integer(kind=im), intent(in) :: nlay ! number of layers + integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag + integer(kind=im), intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) + integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed + +! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state + real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) + ! Dimensions: (nbndsw,ncol,nlay) + + real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction + ! Dimensions: (ngptsw,ncol,nlay) + +! -- Local variables + real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction + ! Dimensions: (ncol,nlay) + +! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive +! real(kind=rb) :: mean_cld_stoch(ncol,nlay) ! cloud fraction +! real(kind=rb) :: mean_clwp_stoch(ncol,nlay) ! cloud water +! real(kind=rb) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice +! real(kind=rb) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth +! real(kind=rb) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo +! real(kind=rb) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter +! real(kind=rb) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction + +! Set overlap + integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, + ! 3 = maximum overlap, 4 = exponential, + ! 5 = exponential-random + real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) + real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter + +! Constants (min value for cloud fraction and cloud water and ice) + real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction +! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) + +! Variables related to random number and seed + real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers + integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number + real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) + integer(kind=im) :: iseed ! seed to create random number (Mersenne Twister) + real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) + +! Flag to identify cloud fraction in subcolumns + logical, dimension(nsubcol, ncol, nlay) :: isCloudy ! flag that says whether a gridbox is cloudy + +! Indices + integer(kind=im) :: ilev, isubcol, i, n, ngbm ! indices + +!------------------------------------------------------------------------------------------ + +! Check that irng is in bounds; if not, set to default + if (irng .ne. 0) irng = 1 + +! Pass input cloud overlap setting to local variable + overlap = icld + +! Ensure that cloud fractions are in bounds + do ilev = 1, nlay + do i = 1, ncol + cldf(i,ilev) = cld(i,ilev) + if (cldf(i,ilev) < cldmin) then + cldf(i,ilev) = 0._rb + endif + enddo + enddo + +! ----- Create seed -------- + +! Advance randum number generator by changeseed values + if (irng.eq.0) then +! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. +! Must use pmid from bottom four layers. + do i=1,ncol + if (pmid(i,1).lt.pmid(i,2)) then + stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.' + endif + seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im + seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im + seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im + seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im + enddo + do i=1,changeSeed + call kissvec(seed1, seed2, seed3, seed4, rand_num) + enddo + elseif (irng.eq.1) then + randomNumbers = new_RandomNumberSequence(seed = changeSeed) + endif + + +! ------ Apply overlap assumption -------- + +! generate the random numbers + + select case (overlap) + + case(1) +! Random overlap +! i) pick a random value at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + case(2) +! Maximum-Random overlap +! i) pick a random number for top layer. +! ii) walk down the column: +! - if the layer above is cloudy, we use the same random number than in the layer above +! - if the layer above is clear, we use a new random number + + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) + else + CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) + endif + enddo + enddo + enddo + + case(3) +! Maximum overlap +! i) pick same random numebr at every level + + if (irng.eq.0) then + do isubcol = 1,nsubcol + call kissvec(seed1, seed2, seed3, seed4, rand_num) + do ilev = 1,nlay + CDF(isubcol,:,ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + rand_num_mt = getRandomReal(randomNumbers) + do ilev = 1, nlay + CDF(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + +! mji - Activate exponential cloud overlap option + case(4) + ! Exponential overlap: weighting between maximum and random overlap increases with the distance. + ! The random numbers for exponential overlap verify: + ! j=1 RAN(j)=RND1 + ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) + ! RAN(j) = RND2 + ! alpha is obtained from the equation + ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale + + ! compute alpha + do i = 1, ncol + alpha(i, 1) = 0._rb + do ilev = 2,nlay + alpha(i, ilev) = exp( -( hgt (i, ilev) - hgt (i, ilev-1)) / Zo) + enddo + enddo + + ! generate 2 streams of random numbers + if (irng.eq.0) then + do isubcol = 1,nsubcol + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(isubcol, :, ilev) = rand_num + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF2(isubcol, :, ilev) = rand_num + enddo + enddo + elseif (irng.eq.1) then + do isubcol = 1, nsubcol + do i = 1, ncol + do ilev = 1, nlay + rand_num_mt = getRandomReal(randomNumbers) + CDF(isubcol,i,ilev) = rand_num_mt + rand_num_mt = getRandomReal(randomNumbers) + CDF2(isubcol,i,ilev) = rand_num_mt + enddo + enddo + enddo + endif + + ! generate random numbers + do ilev = 2,nlay + where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) ) + CDF(:,:,ilev) = CDF(:,:,ilev-1) + end where + end do + +! mji - Exponential-random cloud overlap option + case(5) + ! Exponential-random overlap: + ! call wrf_error_fatal("Cloud Overlap case 5: ER has not yet been implemented. Stopping...") + error stop "Cloud Overlap case 5: ER has not yet been implemented. Stopping..." + end select + + +! -- generate subcolumns for homogeneous clouds ----- + do ilev = 1, nlay + isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) + enddo + +! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; +! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; +! where there is a cloud, define the subcolumn cloud properties, +! otherwise set these to zero + + ngbm = ngb(1) - 1 + do ilev = 1,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + if ( iscloudy(isubcol,i,ilev) ) then + cld_stoch(isubcol,i,ilev) = 1._rb + clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) + ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) + cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) + n = ngb(isubcol) - ngbm + tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) + ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) + asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) + fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev) + else + cld_stoch(isubcol,i,ilev) = 0._rb + clwp_stoch(isubcol,i,ilev) = 0._rb + ciwp_stoch(isubcol,i,ilev) = 0._rb + cswp_stoch(isubcol,i,ilev) = 0._rb + tauc_stoch(isubcol,i,ilev) = 0._rb + ssac_stoch(isubcol,i,ilev) = 1._rb + asmc_stoch(isubcol,i,ilev) = 0._rb + fsfc_stoch(isubcol,i,ilev) = 0._rb + endif + enddo + enddo + enddo + +! -- compute the means of the subcolumns --- +! mean_cld_stoch(:,:) = 0._rb +! mean_clwp_stoch(:,:) = 0._rb +! mean_ciwp_stoch(:,:) = 0._rb +! mean_tauc_stoch(:,:) = 0._rb +! mean_ssac_stoch(:,:) = 0._rb +! mean_asmc_stoch(:,:) = 0._rb +! mean_fsfc_stoch(:,:) = 0._rb +! do i = 1, nsubcol +! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) +! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) +! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) +! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) +! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) +! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) +! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:) +! end do +! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol +! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol +! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol +! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol +! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol +! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol +! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol + + end subroutine generate_stochastic_clouds_sw + + +!-------------------------------------------------------------------------------------------------- + subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!-------------------------------------------------------------------------------------------------- + +! public domain code +! made available from http://www.fortran.com/ +! downloaded by pjr on 03/16/04 for NCAR CAM +! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 + +! The KISS (Keep It Simple Stupid) random number generator. Combines: +! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. +! (2) A 3-shift shift-register generator, period 2^32-1, +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; +! + real(kind=rb), dimension(:), intent(inout) :: ran_arr + integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4 + integer(kind=im) :: i,sz,kiss + integer(kind=im) :: m, k, n + +! inline function + m(k, n) = ieor (k, ishft (k, n) ) + + sz = size(ran_arr) + do i = 1, sz + seed1(i) = 69069_im * seed1(i) + 1327217885_im + seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) + seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im) + seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) + ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb + end do + + end subroutine kissvec + + end module mcica_subcol_gen_sw + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ + + module rrtmg_sw_cldprmc + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrsw, only : ngptsw, jpband, jpb1, jpb2 + use rrsw_cld, only : extliq1, ssaliq1, asyliq1, & + extice2, ssaice2, asyice2, & + extice3, ssaice3, asyice3, fdlice3, & + abari, bbari, cbari, dbari, ebari, fbari + use rrsw_wvn, only : wavenum1, wavenum2, ngb + use rrsw_vsn, only : hvrclc, hnamclc + + implicit none + + contains + +! ---------------------------------------------------------------------------- + subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & + ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, & + taormc, taucmc, ssacmc, asmcmc, fsfcmc) +! ---------------------------------------------------------------------------- + +! Purpose: Compute the cloud optical properties for each cloudy layer +! and g-point interval for use by the McICA method. +! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available; +! (Hu & Stamnes, Key, and Fu) are implemented. + +! ------- Input ------- + + integer(kind=im), intent(in) :: nlayers ! total number of layers + integer(kind=im), intent(in) :: inflag ! see definitions + integer(kind=im), intent(in) :: iceflag ! see definitions + integer(kind=im), intent(in) :: liqflag ! see definitions + + real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptsw,nlayers) + real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real(kind=rb), intent(in) :: cswpmc(:,:) ! cloud snow water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real(kind=rb), intent(in) :: resnmc(:) ! cloud snow particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: relqmc(:) ! cloud liquid particle effective radius (microns) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: reicmc(:) ! cloud ice particle effective radius (microns) + ! Dimensions: (nlayers) + ! specific definition of reicmc depends on setting of iceflag: + ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real(kind=rb), intent(in) :: fsfcmc(:,:) ! cloud forward scattering fraction + ! Dimensions: (ngptsw,nlayers) + +! ------- Output ------- + + real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=rb), intent(inout) :: ssacmc(:,:) ! single scattering albedo (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=rb), intent(inout) :: asmcmc(:,:) ! asymmetry parameter (delta scaled) + ! Dimensions: (ngptsw,nlayers) + real(kind=rb), intent(out) :: taormc(:,:) ! cloud optical depth (non-delta scaled) + ! Dimensions: (ngptsw,nlayers) + +! ------- Local ------- + +! integer(kind=im) :: ncbands + integer(kind=im) :: ib, lay, istr, index, icx, ig + + real(kind=rb), parameter :: eps = 1.e-06_rb ! epsilon + real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities + real(kind=rb) :: cwp ! total cloud water path + real(kind=rb) :: radliq ! cloud liquid droplet radius (microns) + real(kind=rb) :: radice ! cloud ice effective size (microns) + real(kind=rb) :: radsno ! cloud snow effective size (microns) + real(kind=rb) :: factor + real(kind=rb) :: fint + + real(kind=rb) :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa + real(kind=rb) :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq + real(kind=rb) :: tausnoorig, scatsno, ssasno, tausno + + real(kind=rb) :: fdelta(ngptsw) + real(kind=rb) :: extcoice(ngptsw), gice(ngptsw) + real(kind=rb) :: ssacoice(ngptsw), forwice(ngptsw) + real(kind=rb) :: extcoliq(ngptsw), gliq(ngptsw) + real(kind=rb) :: ssacoliq(ngptsw), forwliq(ngptsw) + real(kind=rb) :: extcosno(ngptsw), gsno(ngptsw) + real(kind=rb) :: ssacosno(ngptsw), forwsno(ngptsw) + + CHARACTER*80 errmess + +! Initialize + +!jm not thread safe hvrclc = '$Revision: 1.3 $' + +! Some of these initializations are done elsewhere + do lay = 1, nlayers + do ig = 1, ngptsw + taormc(ig,lay) = taucmc(ig,lay) +! taucmc(ig,lay) = 0.0_rb +! ssacmc(ig,lay) = 1.0_rb +! asmcmc(ig,lay) = 0.0_rb + enddo + enddo + +! Main layer loop + do lay = 1, nlayers + +! Main g-point interval loop + do ig = 1, ngptsw + cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay) + + if (cldfmc(ig,lay) .ge. cldmin .and. & + (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then + +! (inflag=0): Cloud optical properties input directly + if (inflag .eq. 0) then +! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled; +! Apply delta-M scaling here (using Henyey-Greenstein approximation) + taucldorig_a = taucmc(ig,lay) + ffp = fsfcmc(ig,lay) + ffp1 = 1.0_rb - ffp + ffpssa = 1.0_rb - ffp * ssacmc(ig,lay) + ssacloud_a = ffp1 * ssacmc(ig,lay) / ffpssa + taucloud_a = ffpssa * taucldorig_a + + taormc(ig,lay) = taucldorig_a + ssacmc(ig,lay) = ssacloud_a + taucmc(ig,lay) = taucloud_a + asmcmc(ig,lay) = (asmcmc(ig,lay) - ffp) / (ffp1) + + elseif (inflag .eq. 1) then + stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' + +! (inflag=2): Separate treatement of ice clouds and water clouds. + elseif (inflag .ge. 2) then + radice = reicmc(lay) + +! Calculation of absorption coefficients due to ice clouds. + if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then + extcoice(ig) = 0.0_rb + ssacoice(ig) = 0.0_rb + gice(ig) = 0.0_rb + forwice(ig) = 0.0_rb + + extcosno(ig) = 0.0_rb + ssacosno(ig) = 0.0_rb + gsno(ig) = 0.0_rb + forwsno(ig) = 0.0_rb + +! (iceflag = 1): +! Note: This option uses Ebert and Curry approach for all particle sizes similar to +! CAM3 implementation, though this is somewhat unjustified for large ice particles + elseif (iceflag .eq. 1) then + ib = ngb(ig) + if (wavenum2(ib) .gt. 1.43e04_rb) then + icx = 1 + elseif (wavenum2(ib) .gt. 7.7e03_rb) then + icx = 2 + elseif (wavenum2(ib) .gt. 5.3e03_rb) then + icx = 3 + elseif (wavenum2(ib) .gt. 4.0e03_rb) then + icx = 4 + elseif (wavenum2(ib) .ge. 2.5e03_rb) then + icx = 5 + endif + extcoice(ig) = (abari(icx) + bbari(icx)/radice) + ssacoice(ig) = 1._rb - cbari(icx) - dbari(icx) * radice + gice(ig) = ebari(icx) + fbari(icx) * radice +! Check to ensure upper limit of gice is within physical limits for large particles + if (gice(ig).ge.1._rb) gice(ig) = 1._rb - eps + forwice(ig) = gice(ig)*gice(ig) +! Check to ensure all calculated quantities are within physical limits. + if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0' + if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0' + if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0' + if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0' + if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0' + +! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns + + elseif (iceflag .eq. 2) then + if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS' + factor = (radice - 2._rb)/3._rb + index = int(factor) + if (index .eq. 43) index = 42 + fint = factor - float(index) + ib = ngb(ig) + extcoice(ig) = extice2(index,ib) + fint * & + (extice2(index+1,ib) - extice2(index,ib)) + ssacoice(ig) = ssaice2(index,ib) + fint * & + (ssaice2(index+1,ib) - ssaice2(index,ib)) + gice(ig) = asyice2(index,ib) + fint * & + (asyice2(index+1,ib) - asyice2(index,ib)) + forwice(ig) = gice(ig)*gice(ig) +! Check to ensure all calculated quantities are within physical limits. + if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0' + if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0' + if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0' + if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0' + if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0' + +! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns + + elseif (iceflag .ge. 3) then + if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then + write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & + 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + ,ig, lay, ciwpmc(ig,lay), radice +! call wrf_error_fatal(errmess) + error stop errmess + end if + factor = (radice - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + extcoice(ig) = extice3(index,ib) + fint * & + (extice3(index+1,ib) - extice3(index,ib)) + ssacoice(ig) = ssaice3(index,ib) + fint * & + (ssaice3(index+1,ib) - ssaice3(index,ib)) + gice(ig) = asyice3(index,ib) + fint * & + (asyice3(index+1,ib) - asyice3(index,ib)) + fdelta(ig) = fdlice3(index,ib) + fint * & + (fdlice3(index+1,ib) - fdlice3(index,ib)) + if (fdelta(ig) .lt. 0.0_rb) then + write(errmess, *) 'FDELTA LESS THAN 0.0' + !call wrf_error_fatal(errmess) + error stop errmess + end if + if (fdelta(ig) .gt. 1.0_rb) then + write(errmess, *) 'FDELTA GT THAN 1.0' +! call wrf_error_fatal(errmess) + error stop errmess + end if + forwice(ig) = fdelta(ig) + 0.5_rb / ssacoice(ig) +! See Fu 1996 p. 2067 + if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig) +! Check to ensure all calculated quantities are within physical limits. + if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0' + if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0' + if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0' + if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0' + if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0' + + endif + +!!!!!!!!!!!!!!!!!! Mukul !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE +!!!! Although far from perfect, the snow will utilize the +!!!! same lookup table constants as cloud ice. Changes +!!!! to those constants for larger particle snow would be +!!!! an improvement. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then + radsno = resnmc(lay) + if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then + write(errmess,'(A,i5,i5,f8.2,f8.2)' ) & + 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + ,ig, lay, cswpmc(ig,lay), radsno + ! call wrf_error_fatal(errmess) + error stop errmess + end if + factor = (radsno - 2._rb)/3._rb + index = int(factor) + if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + extcosno(ig) = extice3(index,ib) + fint * & + (extice3(index+1,ib) - extice3(index,ib)) + ssacosno(ig) = ssaice3(index,ib) + fint * & + (ssaice3(index+1,ib) - ssaice3(index,ib)) + gsno(ig) = asyice3(index,ib) + fint * & + (asyice3(index+1,ib) - asyice3(index,ib)) + fdelta(ig) = fdlice3(index,ib) + fint * & + (fdlice3(index+1,ib) - fdlice3(index,ib)) + if (fdelta(ig) .lt. 0.0_rb) then + write(errmess, *) 'FDELTA LESS THAN 0.0' + !call wrf_error_fatal(errmess) + error stop errmess + end if + if (fdelta(ig) .gt. 1.0_rb) then + write(errmess, *) 'FDELTA GT THAN 1.0' + !call wrf_error_fatal(errmess) + error stop errmess + end if + forwsno(ig) = fdelta(ig) + 0.5_rb / ssacosno(ig) +! See Fu 1996 p. 2067 + if (forwsno(ig) .gt. gsno(ig)) forwsno(ig) = gsno(ig) +! Check to ensure all calculated quantities are within physical limits. + if (extcosno(ig) .lt. 0.0_rb) then + write(errmess, *) 'SNOW EXTINCTION LESS THAN 0.0' + !call wrf_error_fatal(errmess) + error stop errmess + end if + if (ssacosno(ig) .gt. 1.0_rb) then + write(errmess, *) 'SNOW SSA GRTR THAN 1.0' + !call wrf_error_fatal(errmess) + error stop errmess + end if + if (ssacosno(ig) .lt. 0.0_rb) then + write(errmess, *) 'SNOW SSA LESS THAN 0.0' +! call wrf_error_fatal(errmess) + error stop errmess + end if + if (gsno(ig) .gt. 1.0_rb) then + write(errmess, *) 'SNOW ASYM GRTR THAN 1.0' + !call wrf_error_fatal(errmess) + error stop errmess + end if + if (gsno(ig) .lt. 0.0_rb) then + write(errmess, *) 'SNOW ASYM LESS THAN 0.0' + !call wrf_error_fatal(errmess) + error stop errmess + end if + else + extcosno(ig) = 0.0_rb + ssacosno(ig) = 0.0_rb + gsno(ig) = 0.0_rb + forwsno(ig) = 0.0_rb + endif + + +! Calculation of absorption coefficients due to water clouds. + if (clwpmc(ig,lay) .eq. 0.0_rb) then + extcoliq(ig) = 0.0_rb + ssacoliq(ig) = 0.0_rb + gliq(ig) = 0.0_rb + forwliq(ig) = 0.0_rb + + elseif (liqflag .eq. 1) then + radliq = relqmc(lay) + if (radliq .lt. 1.5_rb .or. radliq .gt. 60._rb) stop & + 'liquid effective radius out of bounds' + index = int(radliq - 1.5_rb) + if (index .eq. 0) index = 1 + if (index .eq. 58) index = 57 + fint = radliq - 1.5_rb - float(index) + ib = ngb(ig) + extcoliq(ig) = extliq1(index,ib) + fint * & + (extliq1(index+1,ib) - extliq1(index,ib)) + ssacoliq(ig) = ssaliq1(index,ib) + fint * & + (ssaliq1(index+1,ib) - ssaliq1(index,ib)) + if (fint .lt. 0._rb .and. ssacoliq(ig) .gt. 1._rb) & + ssacoliq(ig) = ssaliq1(index,ib) + gliq(ig) = asyliq1(index,ib) + fint * & + (asyliq1(index+1,ib) - asyliq1(index,ib)) + forwliq(ig) = gliq(ig)*gliq(ig) +! Check to ensure all calculated quantities are within physical limits. + if (extcoliq(ig) .lt. 0.0_rb) stop 'LIQUID EXTINCTION LESS THAN 0.0' + if (ssacoliq(ig) .gt. 1.0_rb) stop 'LIQUID SSA GRTR THAN 1.0' + if (ssacoliq(ig) .lt. 0.0_rb) stop 'LIQUID SSA LESS THAN 0.0' + if (gliq(ig) .gt. 1.0_rb) stop 'LIQUID ASYM GRTR THAN 1.0' + if (gliq(ig) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0' + endif + + + if (iceflag .lt. 5) then + tauliqorig = clwpmc(ig,lay) * extcoliq(ig) + tauiceorig = ciwpmc(ig,lay) * extcoice(ig) + taormc(ig,lay) = tauliqorig + tauiceorig + + ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / & + (1._rb - forwliq(ig) * ssacoliq(ig)) + tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig + ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / & + (1._rb - forwice(ig) * ssacoice(ig)) + tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig + scatliq = ssaliq * tauliq + scatice = ssaice * tauice + scatsno = 0.0_rb + taucmc(ig,lay) = tauliq + tauice + else + tauliqorig = clwpmc(ig,lay) * extcoliq(ig) + tauiceorig = ciwpmc(ig,lay) * extcoice(ig) + tausnoorig = cswpmc(ig,lay) * extcosno(ig) + taormc(ig,lay) = tauliqorig + tauiceorig + tausnoorig + + ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / & + (1._rb - forwliq(ig) * ssacoliq(ig)) + tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig + ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / & + (1._rb - forwice(ig) * ssacoice(ig)) + tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig + ssasno = ssacosno(ig) * (1._rb - forwsno(ig)) / & + (1._rb - forwsno(ig) * ssacosno(ig)) + tausno = (1._rb - forwsno(ig) * ssacosno(ig)) * tausnoorig + scatliq = ssaliq * tauliq + scatice = ssaice * tauice + scatsno = ssasno * tausno + taucmc(ig,lay) = tauliq + tauice + tausno + endif + +! Ensure non-zero taucmc and scatice + if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin + if(scatice.eq.0.) scatice = cldmin + if(scatsno.eq.0.) scatsno = cldmin + + if (iceflag .lt. 5) then + ssacmc(ig,lay) = (scatliq + scatice) / taucmc(ig,lay) + else + ssacmc(ig,lay) = (scatliq + scatice + scatsno) / taucmc(ig,lay) + endif + + if (iceflag .eq. 3 .or. iceflag.eq.4) then +! In accordance with the 1996 Fu paper, equation A.3, +! the moments for ice were calculated depending on whether using spheres +! or hexagonal ice crystals. +! Set asymetry parameter to first moment (istr=1) + istr = 1 + asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice))* & + (scatliq*(gliq(ig)**istr - forwliq(ig)) / & + (1.0_rb - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ & + (1.0_rb - forwice(ig)))**istr) + elseif (iceflag .eq. 5) then + istr = 1 + asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice+scatsno)) & + * (scatliq*(gliq(ig)**istr - forwliq(ig))/(1.0_rb - forwliq(ig)) & + + scatice * ((gice(ig)-forwice(ig))/(1.0_rb - forwice(ig))) & + + scatsno * ((gsno(ig)-forwsno(ig))/(1.0_rb - forwsno(ig)))**istr) + + else +! This code is the standard method for delta-m scaling. +! Set asymetry parameter to first moment (istr=1) + istr = 1 + asmcmc(ig,lay) = (scatliq * & + (gliq(ig)**istr - forwliq(ig)) / & + (1.0_rb - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / & + (1.0_rb - forwice(ig)))/(scatliq + scatice) + endif + + endif + + endif + +! End g-point interval loop + enddo + +! End layer loop + enddo + + end subroutine cldprmc_sw + + end module rrtmg_sw_cldprmc + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ + + module rrtmg_sw_reftra + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only : im => kind_im, rb => kind_rb + use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl + use rrsw_vsn, only : hvrrft, hnamrft + + implicit none + + contains + +! -------------------------------------------------------------------- + subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw, & + pref, prefd, ptra, ptrad) +! -------------------------------------------------------------------- + +! Purpose: computes the reflectivity and transmissivity of a clear or +! cloudy layer using a choice of various approximations. +! +! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt* +! +! Description: +! explicit arguments : +! -------------------- +! inputs +! ------ +! lrtchk = .t. for all layers in clear profile +! lrtchk = .t. for cloudy layers in cloud profile +! = .f. for clear layers in cloud profile +! pgg = assymetry factor +! prmuz = cosine solar zenith angle +! ptau = optical thickness +! pw = single scattering albedo +! +! outputs +! ------- +! pref : collimated beam reflectivity +! prefd : diffuse beam reflectivity +! ptra : collimated beam transmissivity +! ptrad : diffuse beam transmissivity +! +! +! Method: +! ------- +! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. +! kmodts = 1 eddington (joseph et al., 1976) +! = 2 pifm (zdunkowski et al., 1980) +! = 3 discrete ordinates (liou, 1973) +! +! +! Modifications: +! -------------- +! Original: J-JMorcrette, ECMWF, Feb 2003 +! Revised for F90 reformatting: MJIacono, AER, Jul 2006 +! Revised to add exponential lookup table: MJIacono, AER, Aug 2007 +! Reformulated some code to avoid potential fpes: MJIacono, AER, Nov 2008 +! +! ------------------------------------------------------------------ + +! ------- Declarations ------ + +! ------- Input ------- + + integer(kind=im), intent(in) :: nlayers + + logical, intent(in) :: lrtchk(:) ! Logical flag for reflectivity and + ! and transmissivity calculation; + ! Dimensions: (nlayers) + + real(kind=rb), intent(in) :: pgg(:) ! asymmetry parameter + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: ptau(:) ! optical depth + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: pw(:) ! single scattering albedo + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: prmuz ! cosine of solar zenith angle + +! ------- Output ------- + + real(kind=rb), intent(inout) :: pref(:) ! direct beam reflectivity + ! Dimensions: (nlayers+1) + real(kind=rb), intent(inout) :: prefd(:) ! diffuse beam reflectivity + ! Dimensions: (nlayers+1) + real(kind=rb), intent(inout) :: ptra(:) ! direct beam transmissivity + ! Dimensions: (nlayers+1) + real(kind=rb), intent(inout) :: ptrad(:) ! diffuse beam transmissivity + ! Dimensions: (nlayers+1) + +! ------- Local ------- + + integer(kind=im) :: jk, jl, kmodts + integer(kind=im) :: itind + + real(kind=rb) :: tblind + real(kind=rb) :: za, za1, za2 + real(kind=rb) :: zbeta, zdend, zdenr, zdent + real(kind=rb) :: ze1, ze2, zem1, zem2, zemm, zep1, zep2 + real(kind=rb) :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt + real(kind=rb) :: zr1, zr2, zr3, zr4, zr5 + real(kind=rb) :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp + real(kind=rb) :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1 + real(kind=rb) :: zw, zwcrit, zwo + real(kind=rb) :: denom + + real(kind=rb), parameter :: eps = 1.e-08_rb + +! ------------------------------------------------------------------ + +! Initialize + +!jm not thread safe hvrrft = '$Revision: 1.3 $' + + zsr3=sqrt(3._rb) + zwcrit=0.9999995_rb + kmodts=2 + + do jk=1, nlayers + if (.not.lrtchk(jk)) then + pref(jk) =0._rb + ptra(jk) =1._rb + prefd(jk)=0._rb + ptrad(jk)=1._rb + else + zto1=ptau(jk) + zw =pw(jk) + zg =pgg(jk) + +! General two-stream expressions + + zg3= 3._rb * zg + if (kmodts == 1) then + zgamma1= (7._rb - zw * (4._rb + zg3)) * 0.25_rb + zgamma2=-(1._rb - zw * (4._rb - zg3)) * 0.25_rb + zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb + else if (kmodts == 2) then + zgamma1= (8._rb - zw * (5._rb + zg3)) * 0.25_rb + zgamma2= 3._rb *(zw * (1._rb - zg )) * 0.25_rb + zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb + else if (kmodts == 3) then + zgamma1= zsr3 * (2._rb - zw * (1._rb + zg)) * 0.5_rb + zgamma2= zsr3 * zw * (1._rb - zg ) * 0.5_rb + zgamma3= (1._rb - zsr3 * zg * prmuz ) * 0.5_rb + end if + zgamma4= 1._rb - zgamma3 + +! Recompute original s.s.a. to test for conservative solution + zwo = 0._rb + denom = 1._rb + if (zg .ne. 1._rb) denom = (1._rb - (1._rb - zw) * (zg / (1._rb - zg))**2) + if (zw .gt. 0._rb .and. denom .ne. 0._rb) zwo = zw / denom + + if (zwo >= zwcrit) then +! Conservative scattering + + za = zgamma1 * prmuz + za1 = za - zgamma3 + zgt = zgamma1 * zto1 + +! Homogeneous reflectance and transmittance, +! collimated beam + + ze1 = min ( zto1 / prmuz , 500._rb) +! ze2 = exp( -ze1 ) + +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + if (ze1 .le. od_lo) then + ze2 = 1._rb - ze1 + 0.5_rb * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5_rb + ze2 = exp_tbl(itind) + endif +! + + pref(jk) = (zgt - za1 * (1._rb - ze2)) / (1._rb + zgt) + ptra(jk) = 1._rb - pref(jk) + +! isotropic incidence + + prefd(jk) = zgt / (1._rb + zgt) + ptrad(jk) = 1._rb - prefd(jk) + +! This is applied for consistency between total (delta-scaled) and direct (unscaled) +! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup +! table returns a transmittance of 1.0. + if (ze2 .eq. 1.0_rb) then + pref(jk) = 0.0_rb + ptra(jk) = 1.0_rb + prefd(jk) = 0.0_rb + ptrad(jk) = 1.0_rb + endif + + else +! Non-conservative scattering + + za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3 + za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4 + zrk = sqrt ( zgamma1**2 - zgamma2**2) + zrp = zrk * prmuz + zrp1 = 1._rb + zrp + zrm1 = 1._rb - zrp + zrk2 = 2._rb * zrk + zrpp = 1._rb - zrp*zrp + zrkg = zrk + zgamma1 + zr1 = zrm1 * (za2 + zrk * zgamma3) + zr2 = zrp1 * (za2 - zrk * zgamma3) + zr3 = zrk2 * (zgamma3 - za2 * prmuz ) + zr4 = zrpp * zrkg + zr5 = zrpp * (zrk - zgamma1) + zt1 = zrp1 * (za1 + zrk * zgamma4) + zt2 = zrm1 * (za1 - zrk * zgamma4) + zt3 = zrk2 * (zgamma4 + za1 * prmuz ) + zt4 = zr4 + zt5 = zr5 + +! mji - reformulated code to avoid potential floating point exceptions +! zbeta = - zr5 / zr4 + zbeta = (zgamma1 - zrk) / zrkg +!! + +! Homogeneous reflectance and transmittance + + ze1 = min ( zrk * zto1, 500._rb) + ze2 = min ( zto1 / prmuz , 500._rb) +! +! Original +! zep1 = exp( ze1 ) +! zem1 = exp(-ze1 ) +! zep2 = exp( ze2 ) +! zem2 = exp(-ze2 ) +! +! Revised original, to reduce exponentials +! zep1 = exp( ze1 ) +! zem1 = 1._rb / zep1 +! zep2 = exp( ze2 ) +! zem2 = 1._rb / zep2 +! +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + if (ze1 .le. od_lo) then + zem1 = 1._rb - ze1 + 0.5_rb * ze1 * ze1 + zep1 = 1._rb / zem1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5_rb + zem1 = exp_tbl(itind) + zep1 = 1._rb / zem1 + endif + + if (ze2 .le. od_lo) then + zem2 = 1._rb - ze2 + 0.5_rb * ze2 * ze2 + zep2 = 1._rb / zem2 + else + tblind = ze2 / (bpade + ze2) + itind = tblint * tblind + 0.5_rb + zem2 = exp_tbl(itind) + zep2 = 1._rb / zem2 + endif + +! collimated beam + +! mji - reformulated code to avoid potential floating point exceptions +! zdenr = zr4*zep1 + zr5*zem1 +! pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr +! zdent = zt4*zep1 + zt5*zem1 +! ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent + + zdenr = zr4*zep1 + zr5*zem1 + zdent = zt4*zep1 + zt5*zem1 + if (zdenr .ge. -eps .and. zdenr .le. eps) then + pref(jk) = eps + ptra(jk) = zem2 + else + pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr + ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent + endif +!! + +! diffuse beam + + zemm = zem1*zem1 + zdend = 1._rb / ( (1._rb - zbeta*zemm ) * zrkg) + prefd(jk) = zgamma2 * (1._rb - zemm) * zdend + ptrad(jk) = zrk2*zem1*zdend + + endif + + endif + + enddo + + end subroutine reftra_sw + + end module rrtmg_sw_reftra + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ + + module rrtmg_sw_setcoef + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrsw, only : mxmol + use rrsw_ref, only : pref, preflog, tref + use rrsw_vsn, only : hvrset, hnamset + + implicit none + + contains + +!---------------------------------------------------------------------------- + subroutine setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, coln2o, & + colo2, colo3, fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor) +!---------------------------------------------------------------------------- +! +! Purpose: For a given atmosphere, calculate the indices and +! fractions related to the pressure and temperature interpolations. + +! Modifications: +! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01) +! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224 +! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006 + +! ------ Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: nlayers ! total number of layers + + real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: tavel(:) ! layer temperatures (K) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: tz(0:) ! level (interface) temperatures (K) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: tbound ! surface temperature (K) + real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2) + ! Dimensions: (mxmol,nlayers) + +! ----- Output ----- + integer(kind=im), intent(out) :: laytrop ! tropopause layer index + integer(kind=im), intent(out) :: layswtch ! + integer(kind=im), intent(out) :: laylow ! + + integer(kind=im), intent(out) :: jp(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(out) :: jt(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(out) :: jt1(:) ! + ! Dimensions: (nlayers) + + real(kind=rb), intent(out) :: colh2o(:) ! column amount (h2o) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colco2(:) ! column amount (co2) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colo3(:) ! column amount (o3) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: coln2o(:) ! column amount (n2o) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colch4(:) ! column amount (ch4) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colo2(:) ! column amount (o2) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: colmol(:) ! + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: co2mult(:) ! + ! Dimensions: (nlayers) + + integer(kind=im), intent(out) :: indself(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(out) :: indfor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: selffac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: selffrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: forfac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(out) :: forfrac(:) + ! Dimensions: (nlayers) + + real(kind=rb), intent(out) :: & ! + fac00(:), fac01(:), & ! Dimensions: (nlayers) + fac10(:), fac11(:) + +! ----- Local ----- + + integer(kind=im) :: indbound + integer(kind=im) :: indlev0 + integer(kind=im) :: lay + integer(kind=im) :: jp1 + + real(kind=rb) :: stpfac + real(kind=rb) :: tbndfrac + real(kind=rb) :: t0frac + real(kind=rb) :: plog + real(kind=rb) :: fp + real(kind=rb) :: ft + real(kind=rb) :: ft1 + real(kind=rb) :: water + real(kind=rb) :: scalefac + real(kind=rb) :: factor + real(kind=rb) :: co2reg + real(kind=rb) :: compfp + + +! Initializations + stpfac = 296._rb/1013._rb + + indbound = tbound - 159._rb + tbndfrac = tbound - int(tbound) + indlev0 = tz(0) - 159._rb + t0frac = tz(0) - int(tz(0)) + + laytrop = 0 + layswtch = 0 + laylow = 0 + +! Begin layer loop + do lay = 1, nlayers +! Find the two reference pressures on either side of the +! layer pressure. Store them in JP and JP1. Store in FP the +! fraction of the difference (in ln(pressure)) between these +! two values that the layer pressure lies. + + plog = log(pavel(lay)) + jp(lay) = int(36._rb - 5*(plog+0.04_rb)) + if (jp(lay) .lt. 1) then + jp(lay) = 1 + elseif (jp(lay) .gt. 58) then + jp(lay) = 58 + endif + jp1 = jp(lay) + 1 + fp = 5._rb * (preflog(jp(lay)) - plog) + +! Determine, for each reference pressure (JP and JP1), which +! reference temperature (these are different for each +! reference pressure) is nearest the layer temperature but does +! not exceed it. Store these indices in JT and JT1, resp. +! Store in FT (resp. FT1) the fraction of the way between JT +! (JT1) and the next highest reference temperature that the +! layer temperature falls. + + jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb) + if (jt(lay) .lt. 1) then + jt(lay) = 1 + elseif (jt(lay) .gt. 4) then + jt(lay) = 4 + endif + ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - float(jt(lay)-3) + jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb) + if (jt1(lay) .lt. 1) then + jt1(lay) = 1 + elseif (jt1(lay) .gt. 4) then + jt1(lay) = 4 + endif + ft1 = ((tavel(lay)-tref(jp1))/15._rb) - float(jt1(lay)-3) + + water = wkl(1,lay)/coldry(lay) + scalefac = pavel(lay) * stpfac / tavel(lay) + +! If the pressure is less than ~100mb, perform a different +! set of species interpolations. + + if (plog .le. 4.56_rb) go to 5300 + laytrop = laytrop + 1 + if (plog .ge. 6.62_rb) laylow = laylow + 1 + +! Set up factors needed to separately include the water vapor +! foreign-continuum in the calculation of absorption coefficient. + + forfac(lay) = scalefac / (1.+water) + factor = (332.0_rb-tavel(lay))/36.0_rb + indfor(lay) = min(2, max(1, int(factor))) + forfrac(lay) = factor - float(indfor(lay)) + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + + selffac(lay) = water * forfac(lay) + factor = (tavel(lay)-188.0_rb)/7.2_rb + indself(lay) = min(9, max(1, int(factor)-7)) + selffrac(lay) = factor - float(indself(lay) + 7) + +! Calculate needed column amounts. + + colh2o(lay) = 1.e-20_rb * wkl(1,lay) + colco2(lay) = 1.e-20_rb * wkl(2,lay) + colo3(lay) = 1.e-20_rb * wkl(3,lay) +! colo3(lay) = 0._rb +! colo3(lay) = colo3(lay)/1.16_rb + coln2o(lay) = 1.e-20_rb * wkl(4,lay) + colch4(lay) = 1.e-20_rb * wkl(6,lay) + colo2(lay) = 1.e-20_rb * wkl(7,lay) + colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay) +! colco2(lay) = 0._rb +! colo3(lay) = 0._rb +! coln2o(lay) = 0._rb +! colch4(lay) = 0._rb +! colo2(lay) = 0._rb +! colmol(lay) = 0._rb + if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay) + if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay) + if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay) + if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay) +! Using E = 1334.2 cm-1. + co2reg = 3.55e-24_rb * coldry(lay) + co2mult(lay)= (colco2(lay) - co2reg) * & + 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay)) + goto 5400 + +! Above laytrop. + 5300 continue + +! Set up factors needed to separately include the water vapor +! foreign-continuum in the calculation of absorption coefficient. + + forfac(lay) = scalefac / (1.+water) + factor = (tavel(lay)-188.0_rb)/36.0_rb + indfor(lay) = 3 + forfrac(lay) = factor - 1.0_rb + +! Calculate needed column amounts. + + colh2o(lay) = 1.e-20_rb * wkl(1,lay) + colco2(lay) = 1.e-20_rb * wkl(2,lay) + colo3(lay) = 1.e-20_rb * wkl(3,lay) + coln2o(lay) = 1.e-20_rb * wkl(4,lay) + colch4(lay) = 1.e-20_rb * wkl(6,lay) + colo2(lay) = 1.e-20_rb * wkl(7,lay) + colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay) + if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay) + if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay) + if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay) + if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay) + co2reg = 3.55e-24_rb * coldry(lay) + co2mult(lay)= (colco2(lay) - co2reg) * & + 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay)) + + selffac(lay) = 0._rb + selffrac(lay)= 0._rb + indself(lay) = 0 + + 5400 continue + +! We have now isolated the layer ln pressure and temperature, +! between two reference pressures and two reference temperatures +! (for each reference pressure). We multiply the pressure +! fraction FP with the appropriate temperature fractions to get +! the factors that will be needed for the interpolation that yields +! the optical depths (performed in routines TAUGBn for band n). + + compfp = 1._rb - fp + fac10(lay) = compfp * ft + fac00(lay) = compfp * (1._rb - ft) + fac11(lay) = fp * ft1 + fac01(lay) = fp * (1._rb - ft1) + +! End layer loop + enddo + + end subroutine setcoef_sw + +!*************************************************************************** + subroutine swatmref +!*************************************************************************** + + save + +! These pressures are chosen such that the ln of the first pressure +! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and +! each subsequent ln(pressure) differs from the previous one by 0.2. + + pref(:) = (/ & + 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, & + 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, & + 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, & + 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, & + 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, & + 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, & + 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, & + 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, & + 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, & + 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, & + 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, & + 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb /) + + preflog(:) = (/ & + 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, & + 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, & + 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, & + 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, & + 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, & + 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, & + 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, & + -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, & + -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, & + -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, & + -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, & + -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb /) + +! These are the temperatures associated with the respective +! pressures for the MLS standard atmosphere. + + tref(:) = (/ & + 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, & + 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, & + 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, & + 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, & + 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, & + 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, & + 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, & + 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, & + 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, & + 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, & + 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, & + 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb /) + + end subroutine swatmref + + end module rrtmg_sw_setcoef + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ + + module rrtmg_sw_taumol + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only : im => kind_im, rb => kind_rb +! use parrrsw, only : mg, jpband, nbndsw, ngptsw + use rrsw_con, only: oneminus + use rrsw_wvn, only: nspa, nspb + use rrsw_vsn, only: hvrtau, hnamtau + + implicit none + + contains + +!---------------------------------------------------------------------------- + subroutine taumol_sw(nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- + +! ****************************************************************************** +! * * +! * Optical depths developed for the * +! * * +! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * +! * * +! * * +! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * +! * 131 HARTWELL AVENUE * +! * LEXINGTON, MA 02421 * +! * * +! * * +! * ELI J. MLAWER * +! * JENNIFER DELAMERE * +! * STEVEN J. TAUBMAN * +! * SHEPARD A. CLOUGH * +! * * +! * * +! * * +! * * +! * email: mlawer@aer.com * +! * email: jdelamer@aer.com * +! * * +! * The authors wish to acknowledge the contributions of the * +! * following people: Patrick D. Brown, Michael J. Iacono, * +! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * +! * * +! ****************************************************************************** +! * TAUMOL * +! * * +! * This file contains the subroutines TAUGBn (where n goes from * +! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions * +! * per g-value and layer for band n. * +! * * +! * Output: optical depths (unitless) * +! * fractions needed to compute Planck functions at every layer * +! * and g-value * +! * * +! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * +! * COMMON /PLANKG/ FRACS(MXLAY,MG) * +! * * +! * Input * +! * * +! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) * +! * * +! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * +! * COMMON /PRECISE/ ONEMINUS * +! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * +! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND * +! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * +! * & COLH2O(MXLAY),COLCO2(MXLAY), * +! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * +! * & COLO2(MXLAY),CO2MULT(MXLAY) * +! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * +! * & FAC10(MXLAY),FAC11(MXLAY) * +! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * +! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * +! * * +! * Description: * +! * NG(IBAND) - number of g-values in band IBAND * +! * NSPA(IBAND) - for the lower atmosphere, the number of reference * +! * atmospheres that are stored for band IBAND per * +! * pressure level and temperature. Each of these * +! * atmospheres has different relative amounts of the * +! * key species for the band (i.e. different binary * +! * species parameters). * +! * NSPB(IBAND) - same for upper atmosphere * +! * ONEMINUS - since problems are caused in some cases by interpolation * +! * parameters equal to or greater than 1, for these cases * +! * these parameters are set to this value, slightly < 1. * +! * PAVEL - layer pressures (mb) * +! * TAVEL - layer temperatures (degrees K) * +! * PZ - level pressures (mb) * +! * TZ - level temperatures (degrees K) * +! * LAYTROP - layer at which switch is made from one combination of * +! * key species to another * +! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * +! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * +! * respectively (molecules/cm**2) * +! * CO2MULT - for bands in which carbon dioxide is implemented as a * +! * trace species, this is the factor used to multiply the * +! * band's average CO2 absorption coefficient to get the added * +! * contribution to the optical depth relative to 355 ppm. * +! * FACij(LAY) - for layer LAY, these are factors that are needed to * +! * compute the interpolation factors that multiply the * +! * appropriate reference k-values. A value of 0 (1) for * +! * i,j indicates that the corresponding factor multiplies * +! * reference k-value for the lower (higher) of the two * +! * appropriate temperatures, and altitudes, respectively. * +! * JP - the index of the lower (in altitude) of the two appropriate * +! * reference pressure levels needed for interpolation * +! * JT, JT1 - the indices of the lower of the two appropriate reference * +! * temperatures needed for interpolation (for pressure * +! * levels JP and JP+1, respectively) * +! * SELFFAC - scale factor needed to water vapor self-continuum, equals * +! * (water vapor density)/(atmospheric density at 296K and * +! * 1013 mb) * +! * SELFFRAC - factor needed for temperature interpolation of reference * +! * water vapor self-continuum data * +! * INDSELF - index of the lower of the two appropriate reference * +! * temperatures needed for the self-continuum interpolation * +! * * +! * Data input * +! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * +! * (note: n is the band number) * +! * * +! * Description: * +! * KA - k-values for low reference atmospheres (no water vapor * +! * self-continuum) (units: cm**2/molecule) * +! * KB - k-values for high reference atmospheres (all sources) * +! * (units: cm**2/molecule) * +! * SELFREF - k-values for water vapor self-continuum for reference * +! * atmospheres (used below LAYTROP) * +! * (units: cm**2/molecule) * +! * * +! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * +! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * +! * * +! ***************************************************************************** +! +! Modifications +! +! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003 +! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003 +! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006 +! +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: nlayers ! total number of layers + + integer(kind=im), intent(in) :: laytrop ! tropopause layer index + integer(kind=im), intent(in) :: jp(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: jt(:) ! + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: jt1(:) ! + ! Dimensions: (nlayers) + + real(kind=rb), intent(in) :: colh2o(:) ! column amount (h2o) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colco2(:) ! column amount (co2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colo3(:) ! column amount (o3) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colch4(:) ! column amount (ch4) + ! Dimensions: (nlayers) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colo2(:) ! column amount (o2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colmol(:) ! + ! Dimensions: (nlayers) + + integer(kind=im), intent(in) :: indself(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: indfor(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: selffac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: selffrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: forfac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: forfrac(:) + ! Dimensions: (nlayers) + + real(kind=rb), intent(in) :: & ! + fac00(:), fac01(:), & ! Dimensions: (nlayers) + fac10(:), fac11(:) + +! ----- Output ----- + real(kind=rb), intent(out) :: sfluxzen(:) ! solar source function + ! Dimensions: (ngptsw) + real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth + ! Dimensions: (nlayers,ngptsw) + real(kind=rb), intent(out) :: taur(:,:) ! Rayleigh + ! Dimensions: (nlayers,ngptsw) +! real(kind=rb), intent(out) :: ssa(:,:) ! single scattering albedo (inactive) + ! Dimensions: (nlayers,ngptsw) + +!jm not thread safe hvrtau = '$Revision: 1.3 $' + +! Calculate gaseous optical depth and planck fractions for each spectral band. + + call taumol16 + call taumol17 + call taumol18 + call taumol19 + call taumol20 + call taumol21 + call taumol22 + call taumol23 + call taumol24 + call taumol25 + call taumol26 + call taumol27 + call taumol28 + call taumol29 + +!------------- + contains +!------------- + +!---------------------------------------------------------------------------- + subroutine taumol16 +!---------------------------------------------------------------------------- +! +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng16 + use rrsw_kg16, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat1 + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + speccomb = colh2o(lay) + strrat1*colch4(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng16 + taug(lay,ig) = speccomb * & + (fac000 * absa(ind0 ,ig) + & + fac100 * absa(ind0 +1,ig) + & + fac010 * absa(ind0 +9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1 ,ig) + & + fac101 * absa(ind1 +1,ig) + & + fac011 * absa(ind1 +9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(lay) * & + (selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ig) = tauray/taug(lay,ig) + taur(lay,ig) = tauray + enddo + enddo + + laysolfr = nlayers + +! Upper atmosphere loop + + do lay = laytrop+1, nlayers + if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) & + laysolfr = lay + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1 + tauray = colmol(lay) * rayl + + do ig = 1, ng16 + taug(lay,ig) = colch4(lay) * & + (fac00(lay) * absb(ind0 ,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1 ,ig) + & + fac11(lay) * absb(ind1+1,ig)) +! ssa(lay,ig) = tauray/taug(lay,ig) + if (lay .eq. laysolfr) sfluxzen(ig) = sfluxref(ig) + taur(lay,ig) = tauray + enddo + enddo + + end subroutine taumol16 + +!---------------------------------------------------------------------------- + subroutine taumol17 +!---------------------------------------------------------------------------- +! +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng17, ngs16 + use rrsw_kg17, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + speccomb = colh2o(lay) + strrat*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(17) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(17) + js + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng17 + taug(lay,ngs16+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(lay) * & + (selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) + taur(lay,ngs16+ig) = tauray + enddo + enddo + + laysolfr = nlayers + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) & + laysolfr = lay + speccomb = colh2o(lay) + strrat*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(17) + js + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(17) + js + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng17 + taug(lay,ngs16+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig) + & + fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) + & + colh2o(lay) * & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) +! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) + if (lay .eq. laysolfr) sfluxzen(ngs16+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(lay,ngs16+ig) = tauray + enddo + enddo + + end subroutine taumol17 + +!---------------------------------------------------------------------------- + subroutine taumol18 +!---------------------------------------------------------------------------- +! +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng18, ngs17 + use rrsw_kg18, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + speccomb = colh2o(lay) + strrat*colch4(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(18) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(18) + js + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng18 + taug(lay,ngs17+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(lay) * & + (selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) + if (lay .eq. laysolfr) sfluxzen(ngs17+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(lay,ngs17+ig) = tauray + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(18) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(18) + 1 + tauray = colmol(lay) * rayl + + do ig = 1, ng18 + taug(lay,ngs17+ig) = colch4(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) +! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) + taur(lay,ngs17+ig) = tauray + enddo + enddo + + end subroutine taumol18 + +!---------------------------------------------------------------------------- + subroutine taumol19 +!---------------------------------------------------------------------------- +! +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng19, ngs18 + use rrsw_kg19, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + speccomb = colh2o(lay) + strrat*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(19) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(19) + js + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1 , ng19 + taug(lay,ngs18+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(lay) * & + (selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) + if (lay .eq. laysolfr) sfluxzen(ngs18+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(lay,ngs18+ig) = tauray + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(19) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(19) + 1 + tauray = colmol(lay) * rayl + + do ig = 1 , ng19 + taug(lay,ngs18+ig) = colco2(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) +! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) + taur(lay,ngs18+ig) = tauray + enddo + enddo + + end subroutine taumol19 + +!---------------------------------------------------------------------------- + subroutine taumol20 +!---------------------------------------------------------------------------- +! +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng20, ngs19 + use rrsw_kg20, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, absch4, rayl, layreffr + + implicit none + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(20) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(20) + 1 + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng20 + taug(lay,ngs19+ig) = colh2o(lay) * & + ((fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) + & + selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) & + + colch4(lay) * absch4(ig) +! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) + taur(lay,ngs19+ig) = tauray + if (lay .eq. laysolfr) sfluxzen(ngs19+ig) = sfluxref(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(20) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(20) + 1 + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng20 + taug(lay,ngs19+ig) = colh2o(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) + & + colch4(lay) * absch4(ig) +! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) + taur(lay,ngs19+ig) = tauray + enddo + enddo + + end subroutine taumol20 + +!---------------------------------------------------------------------------- + subroutine taumol21 +!---------------------------------------------------------------------------- +! +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng21, ngs20 + use rrsw_kg21, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + speccomb = colh2o(lay) + strrat*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(21) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(21) + js + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng21 + taug(lay,ngs20+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(lay) * & + (selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) + if (lay .eq. laysolfr) sfluxzen(ngs20+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(lay,ngs20+ig) = tauray + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + speccomb = colh2o(lay) + strrat*colco2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(21) + js + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(21) + js + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng21 + taug(lay,ngs20+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig) + & + fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) + & + colh2o(lay) * & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig))) +! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) + taur(lay,ngs20+ig) = tauray + enddo + enddo + + end subroutine taumol21 + +!---------------------------------------------------------------------------- + subroutine taumol22 +!---------------------------------------------------------------------------- +! +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng22, ngs21 + use rrsw_kg22, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray, o2adj, o2cont + +! The following factor is the ratio of total O2 band intensity (lines +! and Mate continuum) to O2 band intensity (line only). It is needed +! to adjust the optical depths since the k's include only lines. + o2adj = 1.6_rb + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb) + speccomb = colh2o(lay) + o2adj*strrat*colo2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) +! odadj = specparm + o2adj * (1._rb - specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(22) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(22) + js + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng22 + taug(lay,ngs21+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(lay) * & + (selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) & + + o2cont +! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) + if (lay .eq. laysolfr) sfluxzen(ngs21+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(lay,ngs21+ig) = tauray + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb) + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(22) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(22) + 1 + tauray = colmol(lay) * rayl + + do ig = 1, ng22 + taug(lay,ngs21+ig) = colo2(lay) * o2adj * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) + & + o2cont +! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) + taur(lay,ngs21+ig) = tauray + enddo + enddo + + end subroutine taumol22 + +!---------------------------------------------------------------------------- + subroutine taumol23 +!---------------------------------------------------------------------------- +! +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng23, ngs22 + use rrsw_kg23, only : absa, ka, forref, selfref, & + sfluxref, rayl, layreffr, givfac + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(23) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(23) + 1 + inds = indself(lay) + indf = indfor(lay) + + do ig = 1, ng23 + tauray = colmol(lay) * rayl(ig) + taug(lay,ngs22+ig) = colh2o(lay) * & + (givfac * (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) + & + selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig) + if (lay .eq. laysolfr) sfluxzen(ngs22+ig) = sfluxref(ig) + taur(lay,ngs22+ig) = tauray + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + do ig = 1, ng23 +! taug(lay,ngs22+ig) = colmol(lay) * rayl(ig) +! ssa(lay,ngs22+ig) = 1.0_rb + taug(lay,ngs22+ig) = 0._rb + taur(lay,ngs22+ig) = colmol(lay) * rayl(ig) + enddo + enddo + + end subroutine taumol23 + +!---------------------------------------------------------------------------- + subroutine taumol24 +!---------------------------------------------------------------------------- +! +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng24, ngs23 + use rrsw_kg24, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, abso3a, abso3b, rayla, raylb, & + layreffr, strrat + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + speccomb = colh2o(lay) + strrat*colo2(lay) + specparm = colh2o(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(24) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(24) + js + inds = indself(lay) + indf = indfor(lay) + + do ig = 1, ng24 + tauray = colmol(lay) * (rayla(ig,js) + & + fs * (rayla(ig,js+1) - rayla(ig,js))) + taug(lay,ngs23+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colo3(lay) * abso3a(ig) + & + colh2o(lay) * & + (selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) + if (lay .eq. laysolfr) sfluxzen(ngs23+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(lay,ngs23+ig) = tauray + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(24) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(24) + 1 + + do ig = 1, ng24 + tauray = colmol(lay) * raylb(ig) + taug(lay,ngs23+ig) = colo2(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) + & + colo3(lay) * abso3b(ig) +! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) + taur(lay,ngs23+ig) = tauray + enddo + enddo + + end subroutine taumol24 + +!---------------------------------------------------------------------------- + subroutine taumol25 +!---------------------------------------------------------------------------- +! +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng25, ngs24 + use rrsw_kg25, only : absa, ka, & + sfluxref, abso3a, abso3b, rayl, layreffr + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(25) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(25) + 1 + + do ig = 1, ng25 + tauray = colmol(lay) * rayl(ig) + taug(lay,ngs24+ig) = colh2o(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) + & + colo3(lay) * abso3a(ig) +! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) + if (lay .eq. laysolfr) sfluxzen(ngs24+ig) = sfluxref(ig) + taur(lay,ngs24+ig) = tauray + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + do ig = 1, ng25 + tauray = colmol(lay) * rayl(ig) + taug(lay,ngs24+ig) = colo3(lay) * abso3b(ig) +! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) + taur(lay,ngs24+ig) = tauray + enddo + enddo + + end subroutine taumol25 + +!---------------------------------------------------------------------------- + subroutine taumol26 +!---------------------------------------------------------------------------- +! +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng26, ngs25 + use rrsw_kg26, only : sfluxref, rayl + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop + +! Lower atmosphere loop + do lay = 1, laytrop + do ig = 1, ng26 +! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig) +! ssa(lay,ngs25+ig) = 1.0_rb + if (lay .eq. laysolfr) sfluxzen(ngs25+ig) = sfluxref(ig) + taug(lay,ngs25+ig) = 0._rb + taur(lay,ngs25+ig) = colmol(lay) * rayl(ig) + enddo + enddo + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + do ig = 1, ng26 +! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig) +! ssa(lay,ngs25+ig) = 1.0_rb + taug(lay,ngs25+ig) = 0._rb + taur(lay,ngs25+ig) = colmol(lay) * rayl(ig) + enddo + enddo + + end subroutine taumol26 + +!---------------------------------------------------------------------------- + subroutine taumol27 +!---------------------------------------------------------------------------- +! +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng27, ngs26 + use rrsw_kg27, only : absa, ka, absb, kb, & + sfluxref, rayl, layreffr, scalekur + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(27) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(27) + 1 + + do ig = 1, ng27 + tauray = colmol(lay) * rayl(ig) + taug(lay,ngs26+ig) = colo3(lay) * & + (fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) +! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) + taur(lay,ngs26+ig) = tauray + enddo + enddo + + laysolfr = nlayers + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) & + laysolfr = lay + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(27) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(27) + 1 + + do ig = 1, ng27 + tauray = colmol(lay) * rayl(ig) + taug(lay,ngs26+ig) = colo3(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) +! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) + if (lay.eq.laysolfr) sfluxzen(ngs26+ig) = scalekur * sfluxref(ig) + taur(lay,ngs26+ig) = tauray + enddo + enddo + + end subroutine taumol27 + +!---------------------------------------------------------------------------- + subroutine taumol28 +!---------------------------------------------------------------------------- +! +! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng28, ngs27 + use rrsw_kg28, only : absa, ka, absb, kb, & + sfluxref, rayl, layreffr, strrat + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + speccomb = colo3(lay) + strrat*colo2(lay) + specparm = colo3(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(28) + js + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(28) + js + tauray = colmol(lay) * rayl + + do ig = 1, ng28 + taug(lay,ngs27+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) +! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) + taur(lay,ngs27+ig) = tauray + enddo + enddo + + laysolfr = nlayers + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) & + laysolfr = lay + speccomb = colo3(lay) + strrat*colo2(lay) + specparm = colo3(lay)/speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4._rb*(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1._rb ) + fac000 = (1._rb - fs) * fac00(lay) + fac010 = (1._rb - fs) * fac10(lay) + fac100 = fs * fac00(lay) + fac110 = fs * fac10(lay) + fac001 = (1._rb - fs) * fac01(lay) + fac011 = (1._rb - fs) * fac11(lay) + fac101 = fs * fac01(lay) + fac111 = fs * fac11(lay) + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(28) + js + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(28) + js + tauray = colmol(lay) * rayl + + do ig = 1, ng28 + taug(lay,ngs27+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig) + & + fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) +! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) + if (lay .eq. laysolfr) sfluxzen(ngs27+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(lay,ngs27+ig) = tauray + enddo + enddo + + end subroutine taumol28 + +!---------------------------------------------------------------------------- + subroutine taumol29 +!---------------------------------------------------------------------------- +! +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw, only : ng29, ngs28 + use rrsw_kg29, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, absh2o, absco2, rayl, layreffr + +! ------- Declarations ------- + +! Local + + integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, laytrop + ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(29) + 1 + ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(29) + 1 + inds = indself(lay) + indf = indfor(lay) + tauray = colmol(lay) * rayl + + do ig = 1, ng29 + taug(lay,ngs28+ig) = colh2o(lay) * & + ((fac00(lay) * absa(ind0,ig) + & + fac10(lay) * absa(ind0+1,ig) + & + fac01(lay) * absa(ind1,ig) + & + fac11(lay) * absa(ind1+1,ig)) + & + selffac(lay) * (selfref(inds,ig) + & + selffrac(lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(lay) * (forref(indf,ig) + & + forfrac(lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) & + + colco2(lay) * absco2(ig) +! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) + taur(lay,ngs28+ig) = tauray + enddo + enddo + + laysolfr = nlayers + +! Upper atmosphere loop + do lay = laytrop+1, nlayers + if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) & + laysolfr = lay + ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(29) + 1 + ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(29) + 1 + tauray = colmol(lay) * rayl + + do ig = 1, ng29 + taug(lay,ngs28+ig) = colco2(lay) * & + (fac00(lay) * absb(ind0,ig) + & + fac10(lay) * absb(ind0+1,ig) + & + fac01(lay) * absb(ind1,ig) + & + fac11(lay) * absb(ind1+1,ig)) & + + colh2o(lay) * absh2o(ig) +! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) + if (lay .eq. laysolfr) sfluxzen(ngs28+ig) = sfluxref(ig) + taur(lay,ngs28+ig) = tauray + enddo + enddo + + end subroutine taumol29 + + end subroutine taumol_sw + + end module rrtmg_sw_taumol + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ + + module rrtmg_sw_init + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + use parkind, only : im => kind_im, rb => kind_rb + use rrsw_wvn + use rrtmg_sw_setcoef, only: swatmref + + implicit none + + contains + +! ************************************************************************** + subroutine rrtmg_sw_ini(cpdair) +! ************************************************************************** +! +! Original version: Michael J. Iacono; February, 2004 +! Revision for F90 formatting: M. J. Iacono, July, 2006 +! +! This subroutine performs calculations necessary for the initialization +! of the shortwave model. Lookup tables are computed for use in the SW +! radiative transfer, and input absorption coefficient data for each +! spectral band are reduced from 224 g-point intervals to 112. +! ************************************************************************** + + use parrrsw, only : mg, nbndsw, ngptsw + use rrsw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl + use rrsw_vsn, only: hvrini, hnamini + + real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! ------- Local ------- + + integer(kind=im) :: ibnd, igc, ig, ind, ipr + integer(kind=im) :: igcsm, iprsm + integer(kind=im) :: itr + + real(kind=rb) :: wtsum, wtsm(mg) + real(kind=rb) :: tfn + + real(kind=rb), parameter :: expeps = 1.e-20 ! Smallest value for exponential table + +! ------- Definitions ------- +! Arrays for 10000-point look-up tables: +! TAU_TBL Clear-sky optical depth +! EXP_TBL Exponential lookup table for transmittance +! PADE Pade approximation constant (= 0.278) +! BPADE Inverse of the Pade approximation constant +! + +!jm not thread safe hvrini = '$Revision: 1.3 $' + +! Initialize model data + call swdatinit(cpdair) + call swcmbdat ! g-point interval reduction data + call swaerpr ! aerosol optical properties + call swcldpr ! cloud optical properties + call swatmref ! reference MLS profile +! Moved to module_ra_rrtmg_sw for WRF +! call sw_kgb16 ! molecular absorption coefficients +! call sw_kgb17 +! call sw_kgb18 +! call sw_kgb19 +! call sw_kgb20 +! call sw_kgb21 +! call sw_kgb22 +! call sw_kgb23 +! call sw_kgb24 +! call sw_kgb25 +! call sw_kgb26 +! call sw_kgb27 +! call sw_kgb28 +! call sw_kgb29 + +! Define exponential lookup tables for transmittance. Tau is +! computed as a function of the tau transition function, and transmittance +! is calculated as a function of tau. All tables are computed at intervals +! of 0.0001. The inverse of the constant used in the Pade approximation to +! the tau transition function is set to bpade. + + exp_tbl(0) = 1.0_rb + exp_tbl(ntbl) = expeps + bpade = 1.0_rb / pade + do itr = 1, ntbl-1 + tfn = float(itr) / float(ntbl) + tau_tbl = bpade * tfn / (1._rb - tfn) + exp_tbl(itr) = exp(-tau_tbl) + if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps + enddo + +! Perform g-point reduction from 16 per band (224 total points) to +! a band dependent number (112 total points) for all absorption +! coefficient input data and Planck fraction input data. +! Compute relative weighting for new g-point combinations. + + igcsm = 0 + do ibnd = 1,nbndsw + iprsm = 0 + if (ngc(ibnd).lt.mg) then + do igc = 1,ngc(ibnd) + igcsm = igcsm + 1 + wtsum = 0. + do ipr = 1, ngn(igcsm) + iprsm = iprsm + 1 + wtsum = wtsum + wt(iprsm) + enddo + wtsm(igc) = wtsum + enddo + do ig = 1, ng(ibnd+15) + ind = (ibnd-1)*mg + ig + rwgt(ind) = wt(ig)/wtsm(ngm(ind)) + enddo + else + do ig = 1, ng(ibnd+15) + igcsm = igcsm + 1 + ind = (ibnd-1)*mg + ig + rwgt(ind) = 1.0_rb + enddo + endif + enddo + +! Reduce g-points for absorption coefficient data in each LW spectral band. + + call cmbgb16s + call cmbgb17 + call cmbgb18 + call cmbgb19 + call cmbgb20 + call cmbgb21 + call cmbgb22 + call cmbgb23 + call cmbgb24 + call cmbgb25 + call cmbgb26 + call cmbgb27 + call cmbgb28 + call cmbgb29 + + end subroutine rrtmg_sw_ini + +!*************************************************************************** + subroutine swdatinit(cpdair) +!*************************************************************************** + +! --------- Modules ---------- + + use rrsw_con, only: heatfac, grav, planck, boltz, & + clight, avogad, alosmt, gascon, radcn1, radcn2, & + sbcnst, secdy, oneminus, pi + use rrsw_vsn + + save + + real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! Shortwave spectral band limits (wavenumbers) + wavenum1(:) = (/2600._rb, 3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, & + 8050._rb,12850._rb,16000._rb,22650._rb,29000._rb,38000._rb, 820._rb/) + wavenum2(:) = (/3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, 8050._rb, & + 12850._rb,16000._rb,22650._rb,29000._rb,38000._rb,50000._rb, 2600._rb/) + delwave(:) = (/ 650._rb, 750._rb, 650._rb, 500._rb, 1000._rb, 1550._rb, 350._rb, & + 4800._rb, 3150._rb, 6650._rb, 6350._rb, 9000._rb,12000._rb, 1780._rb/) + +! Spectral band information + ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/) + nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/) + nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/) + +! Fundamental physical constants from NIST 2002 + + grav = 9.8066_rb ! Acceleration of gravity + ! (m s-2) + planck = 6.62606876e-27_rb ! Planck constant + ! (ergs s; g cm2 s-1) + boltz = 1.3806503e-16_rb ! Boltzmann constant + ! (ergs K-1; g cm2 s-2 K-1) + clight = 2.99792458e+10_rb ! Speed of light in a vacuum + ! (cm s-1) + avogad = 6.02214199e+23_rb ! Avogadro constant + ! (mol-1) + alosmt = 2.6867775e+19_rb ! Loschmidt constant + ! (cm-3) + gascon = 8.31447200e+07_rb ! Molar gas constant + ! (ergs mol-1 K-1) + radcn1 = 1.191042772e-12_rb ! First radiation constant + ! (W cm2 sr-1) + radcn2 = 1.4387752_rb ! Second radiation constant + ! (cm K) + sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant + ! (W cm-2 K-4) + secdy = 8.6400e4_rb ! Number of seconds per day + ! (s d-1) + +!jm 20141107 moved here for thread safety + oneminus = 1.0_rb - 1.e-06_rb ! zepsec + pi = 2._rb * asin(1._rb) + +! +! units are generally cgs +! +! The first and second radiation constants are taken from NIST. +! They were previously obtained from the relations: +! radcn1 = 2.*planck*clight*clight*1.e-07 +! radcn2 = planck*clight/boltz + +! Heatfac is the factor by which delta-flux / delta-pressure is +! multiplied, with flux in W/m-2 and pressure in mbar, to get +! the heating rate in units of degrees/day. It is equal to: +! Original value: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.004) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.8066)(86400)(1e-5)/(1.004) +! heatfac = 8.4391_rb +! +! Modified value for consistency with CAM3: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.00464) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.80616)(86400)(1e-5)/(1.00464) +! heatfac = 8.43339130434_rb +! +! Calculated value (from constants above and input cpdair) +! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2) +! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2) +! converts mb to Pa when heatfac is multiplied by W m-2 mb-1. + heatfac = grav * secdy / (cpdair * 1.e2_rb) + + end subroutine swdatinit + +!*************************************************************************** + subroutine swcmbdat +!*************************************************************************** + + save + +! ------- Definitions ------- +! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands: +! This mapping from 224 to 112 points has been carefully selected to +! minimize the effect on the resulting fluxes and cooling rates, and +! caution should be used if the mapping is modified. The full 224 +! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc. +! ngpt The total number of new g-points +! ngc The number of new g-points in each band +! ngs The cumulative sum of new g-points for each band +! ngm The index of each new g-point relative to the original +! 16 g-points for each band. +! ngn The number of original g-points that are combined to make +! each new g-point in each band. +! ngb The band index for each new g-point. +! wt RRTM weights for 16 g-points. + +! Use this set for 112 quadrature point (g-point) model +! ------- Data statements ------- + ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /) + ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /) + ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 16 + 1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, & ! band 17 + 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 18 + 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 19 + 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 20 + 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 21 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 22 + 1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, & ! band 23 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 24 + 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 25 + 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 26 + 1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, & ! band 27 + 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 28 + 1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /) ! band 29 + ngn(:) = (/ 2,2,2,2,4,4, & ! band 16 + 1,1,1,1,1,2,1,2,1,2,1,2, & ! band 17 + 1,1,1,1,2,2,4,4, & ! band 18 + 1,1,1,1,2,2,4,4, & ! band 19 + 1,1,1,1,1,1,1,1,2,6, & ! band 20 + 1,1,1,1,1,1,1,1,2,6, & ! band 21 + 8,8, & ! band 22 + 2,2,1,1,1,1,1,1,2,4, & ! band 23 + 2,2,2,2,2,2,2,2, & ! band 24 + 1,1,2,2,4,6, & ! band 25 + 1,1,2,2,4,6, & ! band 26 + 1,1,1,1,1,1,4,6, & ! band 27 + 1,1,2,2,4,6, & ! band 28 + 1,1,1,1,2,2,2,2,1,1,1,1 /) ! band 29 + ngb(:) = (/ 16,16,16,16,16,16, & ! band 16 + 17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17 + 18,18,18,18,18,18,18,18, & ! band 18 + 19,19,19,19,19,19,19,19, & ! band 19 + 20,20,20,20,20,20,20,20,20,20, & ! band 20 + 21,21,21,21,21,21,21,21,21,21, & ! band 21 + 22,22, & ! band 22 + 23,23,23,23,23,23,23,23,23,23, & ! band 23 + 24,24,24,24,24,24,24,24, & ! band 24 + 25,25,25,25,25,25, & ! band 25 + 26,26,26,26,26,26, & ! band 26 + 27,27,27,27,27,27,27,27, & ! band 27 + 28,28,28,28,28,28, & ! band 28 + 29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29 + +! Use this set for full 224 quadrature point (g-point) model +! ------- Data statements ------- +! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /) +! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /) +! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29 +! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29 +! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16 +! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17 +! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18 +! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19 +! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20 +! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21 +! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22 +! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23 +! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24 +! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25 +! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26 +! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27 +! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28 +! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29 + + + wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, & + 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, & + 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, & + 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, & + 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, & + 0.0000750000_rb /) + + end subroutine swcmbdat + +!*************************************************************************** + subroutine swaerpr +!*************************************************************************** + +! Purpose: Define spectral aerosol properties for six ECMWF aerosol types +! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details) +! +! Original: Defined for rrtmg_sw 14 spectral bands, JJMorcrette, ECMWF Feb 2003 +! Revision: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006 + + use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya + + save + + rsrtaua( 1, :) = (/ & + 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/) + rsrtaua( 2, :) = (/ & + 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/) + rsrtaua( 3, :) = (/ & + 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/) + rsrtaua( 4, :) = (/ & + 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/) + rsrtaua( 5, :) = (/ & + 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/) + rsrtaua( 6, :) = (/ & + 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/) + rsrtaua( 7, :) = (/ & + 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/) + rsrtaua( 8, :) = (/ & + 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/) + rsrtaua( 9, :) = (/ & + 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/) + rsrtaua(10, :) = (/ & + 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/) + rsrtaua(11, :) = (/ & + 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/) + rsrtaua(12, :) = (/ & + 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/) + rsrtaua(13, :) = (/ & + 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/) + rsrtaua(14, :) = (/ & + 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/) + + rsrpiza( 1, :) = (/ & + .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/) + rsrpiza( 2, :) = (/ & + .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/) + rsrpiza( 3, :) = (/ & + .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/) + rsrpiza( 4, :) = (/ & + .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/) + rsrpiza( 5, :) = (/ & + .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/) + rsrpiza( 6, :) = (/ & + .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/) + rsrpiza( 7, :) = (/ & + .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/) + rsrpiza( 8, :) = (/ & + .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/) + rsrpiza( 9, :) = (/ & + .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/) + rsrpiza(10, :) = (/ & + .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/) + rsrpiza(11, :) = (/ & + .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/) + rsrpiza(12, :) = (/ & + .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/) + rsrpiza(13, :) = (/ & + .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/) + rsrpiza(14, :) = (/ & + .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/) + + rsrasya( 1, :) = (/ & + 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/) + rsrasya( 2, :) = (/ & + 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/) + rsrasya( 3, :) = (/ & + 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/) + rsrasya( 4, :) = (/ & + 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/) + rsrasya( 5, :) = (/ & + 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/) + rsrasya( 6, :) = (/ & + 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/) + rsrasya( 7, :) = (/ & + 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/) + rsrasya( 8, :) = (/ & + 0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/) + rsrasya( 9, :) = (/ & + 0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/) + rsrasya(10, :) = (/ & + 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/) + rsrasya(11, :) = (/ & + 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/) + rsrasya(12, :) = (/ & + 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/) + rsrasya(13, :) = (/ & + 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/) + rsrasya(14, :) = (/ & + 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/) + + end subroutine swaerpr + +!*************************************************************************** + subroutine cmbgb16s +!*************************************************************************** +! +! Original version: MJIacono; July 1998 +! Revision for RRTM_SW: MJIacono; November 2002 +! Revision for RRTMG_SW: MJIacono; December 2003 +! Revision for F90 reformatting: MJIacono; July 2006 +! +! The subroutines CMBGB16->CMBGB29 input the absorption coefficient +! data for each band, which are defined for 16 g-points and 14 spectral +! bands. The data are combined with appropriate weighting following the +! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source +! function data in array SFLUXREF are combined without weighting. All +! g-point reduced data are put into new arrays for use in RRTMG_SW. +! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! +!----------------------------------------------------------------------- + + use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(1) + sumf = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm) + enddo + sfluxref(igc) = sumf + enddo + + end subroutine cmbgb16s + +!*************************************************************************** + subroutine cmbgb17 +!*************************************************************************** +! +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------------------------------------------- + + use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp-12,iprsm)*rwgt(iprsm+16) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(2) + sumf = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb17 + +!*************************************************************************** + subroutine cmbgb18 +!*************************************************************************** +! +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +!----------------------------------------------------------------------- + + use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+32) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(3) + sumf = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb18 + +!*************************************************************************** + subroutine cmbgb19 +!*************************************************************************** +! +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +!----------------------------------------------------------------------- + + use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+48) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(4) + sumf = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb19 + +!*************************************************************************** + subroutine cmbgb20 +!*************************************************************************** +! +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +!----------------------------------------------------------------------- + + use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, & + absa, ka, absb, kb, selfref, forref, sfluxref, absch4 + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+64) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(5) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64) + enddo + sfluxref(igc) = sumf1 + absch4(igc) = sumf2 + enddo + + end subroutine cmbgb20 + +!*************************************************************************** + subroutine cmbgb21 +!*************************************************************************** +! +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------------------------------------------- + + use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp-12,iprsm)*rwgt(iprsm+80) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(6) + sumf = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb21 + +!*************************************************************************** + subroutine cmbgb22 +!*************************************************************************** +! +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +!----------------------------------------------------------------------- + + use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+96) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(7) + sumf = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb22 + +!*************************************************************************** + subroutine cmbgb23 +!*************************************************************************** +! +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +!----------------------------------------------------------------------- + + use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, raylo, & + absa, ka, selfref, forref, sfluxref, rayl + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(8) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112) + enddo + sfluxref(igc) = sumf1 + rayl(igc) = sumf2 + enddo + + end subroutine cmbgb23 + +!*************************************************************************** + subroutine cmbgb24 +!*************************************************************************** +! +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +!----------------------------------------------------------------------- + + use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + abso3ao, abso3bo, raylao, raylbo, & + absa, ka, absb, kb, selfref, forref, sfluxref, & + abso3a, abso3b, rayla, raylb + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2, sumf3 + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+128) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(9) + sumf1 = 0. + sumf2 = 0. + sumf3 = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128) + sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128) + sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128) + enddo + raylb(igc) = sumf1 + abso3a(igc) = sumf2 + abso3b(igc) = sumf3 + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(9) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm,jp) + sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128) + enddo + sfluxref(igc,jp) = sumf1 + rayla(igc,jp) = sumf2 + enddo + enddo + + end subroutine cmbgb24 + +!*************************************************************************** + subroutine cmbgb25 +!*************************************************************************** +! +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +!----------------------------------------------------------------------- + + use rrsw_kg25, only : kao, sfluxrefo, & + abso3ao, abso3bo, raylo, & + absa, ka, sfluxref, & + abso3a, abso3b, rayl + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2, sumf3, sumf4 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(10) + sumf1 = 0. + sumf2 = 0. + sumf3 = 0. + sumf4 = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144) + sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144) + sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144) + enddo + sfluxref(igc) = sumf1 + abso3a(igc) = sumf2 + abso3b(igc) = sumf3 + rayl(igc) = sumf4 + enddo + + end subroutine cmbgb25 + +!*************************************************************************** + subroutine cmbgb26 +!*************************************************************************** +! +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +!----------------------------------------------------------------------- + + use rrsw_kg26, only : sfluxrefo, raylo, & + sfluxref, rayl + +! ------- Local ------- + integer(kind=im) :: igc, ipr, iprsm + real(kind=rb) :: sumf1, sumf2 + + + iprsm = 0 + do igc = 1,ngc(11) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160) + sumf2 = sumf2 + sfluxrefo(iprsm) + enddo + rayl(igc) = sumf1 + sfluxref(igc) = sumf2 + enddo + + end subroutine cmbgb26 + +!*************************************************************************** + subroutine cmbgb27 +!*************************************************************************** +! +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +!----------------------------------------------------------------------- + + use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, & + absa, ka, absb, kb, sfluxref, rayl + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+176) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(12) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176) + enddo + sfluxref(igc) = sumf1 + rayl(igc) = sumf2 + enddo + + end subroutine cmbgb27 + +!*************************************************************************** + subroutine cmbgb28 +!*************************************************************************** +! +! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) +!----------------------------------------------------------------------- + + use rrsw_kg28, only : kao, kbo, sfluxrefo, & + absa, ka, absb, kb, sfluxref + +! ------- Local ------- + integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp-12,iprsm)*rwgt(iprsm+192) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(13) + sumf = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb28 + +!*************************************************************************** + subroutine cmbgb29 +!*************************************************************************** +! +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +!----------------------------------------------------------------------- + + use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absh2oo, absco2o, & + absa, ka, absb, kb, selfref, forref, sfluxref, & + absh2o, absco2 + +! ------- Local ------- + integer(kind=im) :: jt, jp, igc, ipr, iprsm + real(kind=rb) :: sumk, sumf1, sumf2, sumf3 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp-12,iprsm)*rwgt(iprsm+208) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(14) + sumf1 = 0. + sumf2 = 0. + sumf3 = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208) + sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208) + enddo + sfluxref(igc) = sumf1 + absco2(igc) = sumf2 + absh2o(igc) = sumf3 + enddo + + end subroutine cmbgb29 + +!*********************************************************************** + subroutine swcldpr + +! Purpose: Define cloud extinction coefficient, single scattering albedo +! and asymmetry parameter data. +! + +! ------- Modules ------- + + use rrsw_cld, only : extliq1, ssaliq1, asyliq1, & + extice2, ssaice2, asyice2, & + extice3, ssaice3, asyice3, fdlice3, & + abari, bbari, cbari, dbari, ebari, fbari + + save + +!----------------------------------------------------------------------- +! +! Explanation of the method for each value of INFLAG. A value of +! 0 for INFLAG do not distingish being liquid and ice clouds. +! INFLAG = 2 does distinguish between liquid and ice clouds, and +! requires further user input to specify the method to be used to +! compute the aborption due to each. +! INFLAG = 0: For each cloudy layer, the cloud fraction, the cloud optical +! depth, the cloud single-scattering albedo, and the +! moments of the phase function (0:NSTREAM). Note +! that these values are delta-m scaled within this +! subroutine. + +! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud +! water path (g/m2), and cloud ice fraction are input. +! ICEFLAG = 2: The ice effective radius (microns) is input and the +! optical properties due to ice clouds are computed from +! the optical properties stored in the RT code, STREAMER v3.0 +! (Reference: Key. J., Streamer User's Guide, Cooperative +! Institute for Meteorological Satellite Studies, 2001, 96 pp.). +! Valid range of values for re are between 5.0 and +! 131.0 micron. +! This version uses Ebert and Curry, JGR, (1992) method for +! ice particles larger than 131.0 microns. +! ICEFLAG = 3: The ice generalized effective size (dge) is input +! and the optical depths, single-scattering albedo, +! and phase function moments are calculated as in +! Q. Fu, J. Climate, (1996). Q. Fu provided high resolution +! tables which were appropriately averaged for the +! bands in RRTM_SW. Linear interpolation is used to +! get the coefficients from the stored tables. +! Valid range of values for dge are between 5.0 and +! 140.0 micron. +! This version uses Ebert and Curry, JGR, (1992) method for +! ice particles larger than 140.0 microns. +! LIQFLAG = 1: The water droplet effective radius (microns) is input +! and the optical depths due to water clouds are computed +! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with +! modified coefficients derived from Mie scattering calculations. +! The values for absorption coefficients appropriate for +! the spectral bands in RRTM/RRTMG have been obtained for a +! range of effective radii by an averaging procedure +! based on the work of J. Pinto (private communication). +! Linear interpolation is used to get the absorption +! coefficients for the input effective radius. +! +!..Updated tables suggested by Peter Blossey (Univ. Washington) that came from RRTM v3.9 from AER, Inc. +! +! ------------------------------------------------------------------ + +! Everything below is for INFLAG = 2. + +! Coefficients for Ebert and Curry method + abari(:) = (/ & + & 3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb /) + bbari(:) = (/ & + & 2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb /) + cbari(:) = (/ & + & 1.000e-05_rb,1.100e-04_rb,1.240e-02_rb,3.779e-02_rb,4.666e-01_rb /) + dbari(:) = (/ & + & 0.000e+00_rb,1.405e-05_rb,6.867e-04_rb,1.284e-03_rb,2.050e-05_rb /) + ebari(:) = (/ & + & 7.661e-01_rb,7.730e-01_rb,7.865e-01_rb,8.172e-01_rb,9.595e-01_rb /) + fbari(:) = (/ & + & 5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /) + +! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters +! Derived from on Mie scattering computations; based on Hu & Stamnes coefficients +! BAND 16 + extliq1(:, 16) = (/ & + & 9.004493E-01_rb,6.366723E-01_rb,4.542354E-01_rb,3.468253E-01_rb,2.816431E-01_rb,& + & 2.383415E-01_rb,2.070854E-01_rb,1.831854E-01_rb,1.642115E-01_rb,1.487539E-01_rb,& + & 1.359169E-01_rb,1.250900E-01_rb,1.158354E-01_rb,1.078400E-01_rb,1.008646E-01_rb,& + & 9.472307E-02_rb,8.928000E-02_rb,8.442308E-02_rb,8.005924E-02_rb,7.612231E-02_rb,& + & 7.255153E-02_rb,6.929539E-02_rb,6.631769E-02_rb,6.358153E-02_rb,6.106231E-02_rb,& + & 5.873077E-02_rb,5.656924E-02_rb,5.455769E-02_rb,5.267846E-02_rb,5.091923E-02_rb,& + & 4.926692E-02_rb,4.771154E-02_rb,4.623923E-02_rb,4.484385E-02_rb,4.351539E-02_rb,& + & 4.224615E-02_rb,4.103385E-02_rb,3.986538E-02_rb,3.874077E-02_rb,3.765462E-02_rb,& + & 3.660077E-02_rb,3.557384E-02_rb,3.457615E-02_rb,3.360308E-02_rb,3.265000E-02_rb,& + & 3.171770E-02_rb,3.080538E-02_rb,2.990846E-02_rb,2.903000E-02_rb,2.816461E-02_rb,& + & 2.731539E-02_rb,2.648231E-02_rb,2.566308E-02_rb,2.485923E-02_rb,2.407000E-02_rb,& + & 2.329615E-02_rb,2.253769E-02_rb,2.179615E-02_rb /) +! BAND 17 + extliq1(:, 17) = (/ & + & 6.741200e-01_rb,5.390739e-01_rb,4.198767e-01_rb,3.332553e-01_rb,2.735633e-01_rb,& + & 2.317727e-01_rb,2.012760e-01_rb,1.780400e-01_rb,1.596927e-01_rb,1.447980e-01_rb,& + & 1.324480e-01_rb,1.220347e-01_rb,1.131327e-01_rb,1.054313e-01_rb,9.870534e-02_rb,& + & 9.278200e-02_rb,8.752599e-02_rb,8.282933e-02_rb,7.860600e-02_rb,7.479133e-02_rb,& + & 7.132800e-02_rb,6.816733e-02_rb,6.527401e-02_rb,6.261266e-02_rb,6.015934e-02_rb,& + & 5.788867e-02_rb,5.578134e-02_rb,5.381667e-02_rb,5.198133e-02_rb,5.026067e-02_rb,& + & 4.864466e-02_rb,4.712267e-02_rb,4.568066e-02_rb,4.431200e-02_rb,4.300867e-02_rb,& + & 4.176600e-02_rb,4.057400e-02_rb,3.942534e-02_rb,3.832066e-02_rb,3.725068e-02_rb,& + & 3.621400e-02_rb,3.520533e-02_rb,3.422333e-02_rb,3.326400e-02_rb,3.232467e-02_rb,& + & 3.140535e-02_rb,3.050400e-02_rb,2.962000e-02_rb,2.875267e-02_rb,2.789800e-02_rb,& + & 2.705934e-02_rb,2.623667e-02_rb,2.542667e-02_rb,2.463200e-02_rb,2.385267e-02_rb,& + & 2.308667e-02_rb,2.233667e-02_rb,2.160067e-02_rb /) +! BAND 18 + extliq1(:, 18) = (/ & + & 9.250861e-01_rb,6.245692e-01_rb,4.347038e-01_rb,3.320208e-01_rb,2.714869e-01_rb,& + & 2.309516e-01_rb,2.012592e-01_rb,1.783315e-01_rb,1.600369e-01_rb,1.451000e-01_rb,& + & 1.326838e-01_rb,1.222069e-01_rb,1.132554e-01_rb,1.055146e-01_rb,9.876000e-02_rb,& + & 9.281386e-02_rb,8.754000e-02_rb,8.283078e-02_rb,7.860077e-02_rb,7.477769e-02_rb,& + & 7.130847e-02_rb,6.814461e-02_rb,6.524615e-02_rb,6.258462e-02_rb,6.012847e-02_rb,& + & 5.785462e-02_rb,5.574231e-02_rb,5.378000e-02_rb,5.194461e-02_rb,5.022462e-02_rb,& + & 4.860846e-02_rb,4.708462e-02_rb,4.564154e-02_rb,4.427462e-02_rb,4.297231e-02_rb,& + & 4.172769e-02_rb,4.053693e-02_rb,3.939000e-02_rb,3.828462e-02_rb,3.721692e-02_rb,& + & 3.618000e-02_rb,3.517077e-02_rb,3.418923e-02_rb,3.323077e-02_rb,3.229154e-02_rb,& + & 3.137154e-02_rb,3.047154e-02_rb,2.959077e-02_rb,2.872308e-02_rb,2.786846e-02_rb,& + & 2.703077e-02_rb,2.620923e-02_rb,2.540077e-02_rb,2.460615e-02_rb,2.382693e-02_rb,& + & 2.306231e-02_rb,2.231231e-02_rb,2.157923e-02_rb /) +! BAND 19 + extliq1(:, 19) = (/ & + & 9.298960e-01_rb,5.776460e-01_rb,4.083450e-01_rb,3.211160e-01_rb,2.666390e-01_rb,& + & 2.281990e-01_rb,1.993250e-01_rb,1.768080e-01_rb,1.587810e-01_rb,1.440390e-01_rb,& + & 1.317720e-01_rb,1.214150e-01_rb,1.125540e-01_rb,1.048890e-01_rb,9.819600e-02_rb,& + & 9.230201e-02_rb,8.706900e-02_rb,8.239698e-02_rb,7.819500e-02_rb,7.439899e-02_rb,& + & 7.095300e-02_rb,6.780700e-02_rb,6.492900e-02_rb,6.228600e-02_rb,5.984600e-02_rb,& + & 5.758599e-02_rb,5.549099e-02_rb,5.353801e-02_rb,5.171400e-02_rb,5.000500e-02_rb,& + & 4.840000e-02_rb,4.688500e-02_rb,4.545100e-02_rb,4.409300e-02_rb,4.279700e-02_rb,& + & 4.156100e-02_rb,4.037700e-02_rb,3.923800e-02_rb,3.813800e-02_rb,3.707600e-02_rb,& + & 3.604500e-02_rb,3.504300e-02_rb,3.406500e-02_rb,3.310800e-02_rb,3.217700e-02_rb,& + & 3.126600e-02_rb,3.036800e-02_rb,2.948900e-02_rb,2.862400e-02_rb,2.777500e-02_rb,& + & 2.694200e-02_rb,2.612300e-02_rb,2.531700e-02_rb,2.452800e-02_rb,2.375100e-02_rb,& + & 2.299100e-02_rb,2.224300e-02_rb,2.151201e-02_rb /) +! BAND 20 + extliq1(:, 20) = (/ & + & 8.780964e-01_rb,5.407031e-01_rb,3.961100e-01_rb,3.166645e-01_rb,2.640455e-01_rb,& + & 2.261070e-01_rb,1.974820e-01_rb,1.751775e-01_rb,1.573415e-01_rb,1.427725e-01_rb,& + & 1.306535e-01_rb,1.204195e-01_rb,1.116650e-01_rb,1.040915e-01_rb,9.747550e-02_rb,& + & 9.164800e-02_rb,8.647649e-02_rb,8.185501e-02_rb,7.770200e-02_rb,7.394749e-02_rb,& + & 7.053800e-02_rb,6.742700e-02_rb,6.457999e-02_rb,6.196149e-02_rb,5.954450e-02_rb,& + & 5.730650e-02_rb,5.522949e-02_rb,5.329450e-02_rb,5.148500e-02_rb,4.979000e-02_rb,& + & 4.819600e-02_rb,4.669301e-02_rb,4.527050e-02_rb,4.391899e-02_rb,4.263500e-02_rb,& + & 4.140500e-02_rb,4.022850e-02_rb,3.909500e-02_rb,3.800199e-02_rb,3.694600e-02_rb,& + & 3.592000e-02_rb,3.492250e-02_rb,3.395050e-02_rb,3.300150e-02_rb,3.207250e-02_rb,& + & 3.116250e-02_rb,3.027100e-02_rb,2.939500e-02_rb,2.853500e-02_rb,2.768900e-02_rb,& + & 2.686000e-02_rb,2.604350e-02_rb,2.524150e-02_rb,2.445350e-02_rb,2.368049e-02_rb,& + & 2.292150e-02_rb,2.217800e-02_rb,2.144800e-02_rb /) +! BAND 21 + extliq1(:, 21) = (/ & + & 7.937480e-01_rb,5.123036e-01_rb,3.858181e-01_rb,3.099622e-01_rb,2.586829e-01_rb,& + & 2.217587e-01_rb,1.939755e-01_rb,1.723397e-01_rb,1.550258e-01_rb,1.408600e-01_rb,& + & 1.290545e-01_rb,1.190661e-01_rb,1.105039e-01_rb,1.030848e-01_rb,9.659387e-02_rb,& + & 9.086775e-02_rb,8.577807e-02_rb,8.122452e-02_rb,7.712711e-02_rb,7.342193e-02_rb,& + & 7.005387e-02_rb,6.697840e-02_rb,6.416000e-02_rb,6.156903e-02_rb,5.917484e-02_rb,& + & 5.695807e-02_rb,5.489968e-02_rb,5.298097e-02_rb,5.118806e-02_rb,4.950645e-02_rb,& + & 4.792710e-02_rb,4.643581e-02_rb,4.502484e-02_rb,4.368547e-02_rb,4.241001e-02_rb,& + & 4.118936e-02_rb,4.002193e-02_rb,3.889711e-02_rb,3.781322e-02_rb,3.676387e-02_rb,& + & 3.574549e-02_rb,3.475548e-02_rb,3.379033e-02_rb,3.284678e-02_rb,3.192420e-02_rb,& + & 3.102032e-02_rb,3.013484e-02_rb,2.926258e-02_rb,2.840839e-02_rb,2.756742e-02_rb,& + & 2.674258e-02_rb,2.593064e-02_rb,2.513258e-02_rb,2.435000e-02_rb,2.358064e-02_rb,& + & 2.282581e-02_rb,2.208548e-02_rb,2.135936e-02_rb /) +! BAND 22 + extliq1(:, 22) = (/ & + & 7.533129e-01_rb,5.033129e-01_rb,3.811271e-01_rb,3.062757e-01_rb,2.558729e-01_rb,& + & 2.196828e-01_rb,1.924372e-01_rb,1.711714e-01_rb,1.541086e-01_rb,1.401114e-01_rb,& + & 1.284257e-01_rb,1.185200e-01_rb,1.100243e-01_rb,1.026529e-01_rb,9.620142e-02_rb,& + & 9.050714e-02_rb,8.544428e-02_rb,8.091714e-02_rb,7.684000e-02_rb,7.315429e-02_rb,& + & 6.980143e-02_rb,6.673999e-02_rb,6.394000e-02_rb,6.136000e-02_rb,5.897715e-02_rb,& + & 5.677000e-02_rb,5.472285e-02_rb,5.281286e-02_rb,5.102858e-02_rb,4.935429e-02_rb,& + & 4.778000e-02_rb,4.629714e-02_rb,4.489142e-02_rb,4.355857e-02_rb,4.228715e-02_rb,& + & 4.107285e-02_rb,3.990857e-02_rb,3.879000e-02_rb,3.770999e-02_rb,3.666429e-02_rb,& + & 3.565000e-02_rb,3.466286e-02_rb,3.370143e-02_rb,3.276143e-02_rb,3.184143e-02_rb,& + & 3.094000e-02_rb,3.005714e-02_rb,2.919000e-02_rb,2.833714e-02_rb,2.750000e-02_rb,& + & 2.667714e-02_rb,2.586714e-02_rb,2.507143e-02_rb,2.429143e-02_rb,2.352428e-02_rb,& + & 2.277143e-02_rb,2.203429e-02_rb,2.130857e-02_rb /) +! BAND 23 + extliq1(:, 23) = (/ & + & 7.079894e-01_rb,4.878198e-01_rb,3.719852e-01_rb,3.001873e-01_rb,2.514795e-01_rb,& + & 2.163013e-01_rb,1.897100e-01_rb,1.689033e-01_rb,1.521793e-01_rb,1.384449e-01_rb,& + & 1.269666e-01_rb,1.172326e-01_rb,1.088745e-01_rb,1.016224e-01_rb,9.527085e-02_rb,& + & 8.966240e-02_rb,8.467543e-02_rb,8.021144e-02_rb,7.619344e-02_rb,7.255676e-02_rb,& + & 6.924996e-02_rb,6.623030e-02_rb,6.346261e-02_rb,6.091499e-02_rb,5.856325e-02_rb,& + & 5.638385e-02_rb,5.435930e-02_rb,5.247156e-02_rb,5.070699e-02_rb,4.905230e-02_rb,& + & 4.749499e-02_rb,4.602611e-02_rb,4.463581e-02_rb,4.331543e-02_rb,4.205647e-02_rb,& + & 4.085241e-02_rb,3.969978e-02_rb,3.859033e-02_rb,3.751877e-02_rb,3.648168e-02_rb,& + & 3.547468e-02_rb,3.449553e-02_rb,3.354072e-02_rb,3.260732e-02_rb,3.169438e-02_rb,& + & 3.079969e-02_rb,2.992146e-02_rb,2.905875e-02_rb,2.821201e-02_rb,2.737873e-02_rb,& + & 2.656052e-02_rb,2.575586e-02_rb,2.496511e-02_rb,2.418783e-02_rb,2.342500e-02_rb,& + & 2.267646e-02_rb,2.194177e-02_rb,2.122146e-02_rb /) +! BAND 24 + extliq1(:, 24) = (/ & + & 6.850164e-01_rb,4.762468e-01_rb,3.642001e-01_rb,2.946012e-01_rb,2.472001e-01_rb,& + & 2.128588e-01_rb,1.868537e-01_rb,1.664893e-01_rb,1.501142e-01_rb,1.366620e-01_rb,& + & 1.254147e-01_rb,1.158721e-01_rb,1.076732e-01_rb,1.005530e-01_rb,9.431306e-02_rb,& + & 8.879891e-02_rb,8.389232e-02_rb,7.949714e-02_rb,7.553857e-02_rb,7.195474e-02_rb,& + & 6.869413e-02_rb,6.571444e-02_rb,6.298286e-02_rb,6.046779e-02_rb,5.814474e-02_rb,& + & 5.599141e-02_rb,5.399114e-02_rb,5.212443e-02_rb,5.037870e-02_rb,4.874321e-02_rb,& + & 4.720219e-02_rb,4.574813e-02_rb,4.437160e-02_rb,4.306460e-02_rb,4.181810e-02_rb,& + & 4.062603e-02_rb,3.948252e-02_rb,3.838256e-02_rb,3.732049e-02_rb,3.629192e-02_rb,& + & 3.529301e-02_rb,3.432190e-02_rb,3.337412e-02_rb,3.244842e-02_rb,3.154175e-02_rb,& + & 3.065253e-02_rb,2.978063e-02_rb,2.892367e-02_rb,2.808221e-02_rb,2.725478e-02_rb,& + & 2.644174e-02_rb,2.564175e-02_rb,2.485508e-02_rb,2.408303e-02_rb,2.332365e-02_rb,& + & 2.257890e-02_rb,2.184824e-02_rb,2.113224e-02_rb /) +! BAND 25 + extliq1(:, 25) = (/ & + & 6.673017e-01_rb,4.664520e-01_rb,3.579398e-01_rb,2.902234e-01_rb,2.439904e-01_rb,& + & 2.104149e-01_rb,1.849277e-01_rb,1.649234e-01_rb,1.488087e-01_rb,1.355515e-01_rb,& + & 1.244562e-01_rb,1.150329e-01_rb,1.069321e-01_rb,9.989310e-02_rb,9.372070e-02_rb,& + & 8.826450e-02_rb,8.340622e-02_rb,7.905378e-02_rb,7.513109e-02_rb,7.157859e-02_rb,& + & 6.834588e-02_rb,6.539114e-02_rb,6.268150e-02_rb,6.018621e-02_rb,5.788098e-02_rb,& + & 5.574351e-02_rb,5.375699e-02_rb,5.190412e-02_rb,5.017099e-02_rb,4.854497e-02_rb,& + & 4.701490e-02_rb,4.557030e-02_rb,4.420249e-02_rb,4.290304e-02_rb,4.166427e-02_rb,& + & 4.047820e-02_rb,3.934232e-02_rb,3.824778e-02_rb,3.719236e-02_rb,3.616931e-02_rb,& + & 3.517597e-02_rb,3.420856e-02_rb,3.326566e-02_rb,3.234346e-02_rb,3.144122e-02_rb,& + & 3.055684e-02_rb,2.968798e-02_rb,2.883519e-02_rb,2.799635e-02_rb,2.717228e-02_rb,& + & 2.636182e-02_rb,2.556424e-02_rb,2.478114e-02_rb,2.401086e-02_rb,2.325657e-02_rb,& + & 2.251506e-02_rb,2.178594e-02_rb,2.107301e-02_rb /) +! BAND 26 + extliq1(:, 26) = (/ & + & 6.552414e-01_rb,4.599454e-01_rb,3.538626e-01_rb,2.873547e-01_rb,2.418033e-01_rb,& + & 2.086660e-01_rb,1.834885e-01_rb,1.637142e-01_rb,1.477767e-01_rb,1.346583e-01_rb,& + & 1.236734e-01_rb,1.143412e-01_rb,1.063148e-01_rb,9.933905e-02_rb,9.322026e-02_rb,& + & 8.780979e-02_rb,8.299230e-02_rb,7.867554e-02_rb,7.478450e-02_rb,7.126053e-02_rb,& + & 6.805276e-02_rb,6.512143e-02_rb,6.243211e-02_rb,5.995541e-02_rb,5.766712e-02_rb,& + & 5.554484e-02_rb,5.357246e-02_rb,5.173222e-02_rb,5.001069e-02_rb,4.839505e-02_rb,& + & 4.687471e-02_rb,4.543861e-02_rb,4.407857e-02_rb,4.278577e-02_rb,4.155331e-02_rb,& + & 4.037322e-02_rb,3.924302e-02_rb,3.815376e-02_rb,3.710172e-02_rb,3.608296e-02_rb,& + & 3.509330e-02_rb,3.412980e-02_rb,3.319009e-02_rb,3.227106e-02_rb,3.137157e-02_rb,& + & 3.048950e-02_rb,2.962365e-02_rb,2.877297e-02_rb,2.793726e-02_rb,2.711500e-02_rb,& + & 2.630666e-02_rb,2.551206e-02_rb,2.473052e-02_rb,2.396287e-02_rb,2.320861e-02_rb,& + & 2.246810e-02_rb,2.174162e-02_rb,2.102927e-02_rb /) +! BAND 27 + extliq1(:, 27) = (/ & + & 6.430901e-01_rb,4.532134e-01_rb,3.496132e-01_rb,2.844655e-01_rb,2.397347e-01_rb,& + & 2.071236e-01_rb,1.822976e-01_rb,1.627640e-01_rb,1.469961e-01_rb,1.340006e-01_rb,& + & 1.231069e-01_rb,1.138441e-01_rb,1.058706e-01_rb,9.893678e-02_rb,9.285166e-02_rb,& + & 8.746871e-02_rb,8.267411e-02_rb,7.837656e-02_rb,7.450257e-02_rb,7.099318e-02_rb,& + & 6.779929e-02_rb,6.487987e-02_rb,6.220168e-02_rb,5.973530e-02_rb,5.745636e-02_rb,& + & 5.534344e-02_rb,5.337986e-02_rb,5.154797e-02_rb,4.983404e-02_rb,4.822582e-02_rb,& + & 4.671228e-02_rb,4.528321e-02_rb,4.392997e-02_rb,4.264325e-02_rb,4.141647e-02_rb,& + & 4.024259e-02_rb,3.911767e-02_rb,3.803309e-02_rb,3.698782e-02_rb,3.597140e-02_rb,& + & 3.498774e-02_rb,3.402852e-02_rb,3.309340e-02_rb,3.217818e-02_rb,3.128292e-02_rb,& + & 3.040486e-02_rb,2.954230e-02_rb,2.869545e-02_rb,2.786261e-02_rb,2.704372e-02_rb,& + & 2.623813e-02_rb,2.544668e-02_rb,2.466788e-02_rb,2.390313e-02_rb,2.315136e-02_rb,& + & 2.241391e-02_rb,2.168921e-02_rb,2.097903e-02_rb /) +! BAND 28 + extliq1(:, 28) = (/ & + & 6.367074e-01_rb,4.495768e-01_rb,3.471263e-01_rb,2.826149e-01_rb,2.382868e-01_rb,& + & 2.059640e-01_rb,1.813562e-01_rb,1.619881e-01_rb,1.463436e-01_rb,1.334402e-01_rb,& + & 1.226166e-01_rb,1.134096e-01_rb,1.054829e-01_rb,9.858838e-02_rb,9.253790e-02_rb,& + & 8.718582e-02_rb,8.241830e-02_rb,7.814482e-02_rb,7.429212e-02_rb,7.080165e-02_rb,& + & 6.762385e-02_rb,6.471838e-02_rb,6.205388e-02_rb,5.959726e-02_rb,5.732871e-02_rb,& + & 5.522402e-02_rb,5.326793e-02_rb,5.144230e-02_rb,4.973440e-02_rb,4.813188e-02_rb,& + & 4.662283e-02_rb,4.519798e-02_rb,4.384833e-02_rb,4.256541e-02_rb,4.134253e-02_rb,& + & 4.017136e-02_rb,3.904911e-02_rb,3.796779e-02_rb,3.692364e-02_rb,3.591182e-02_rb,& + & 3.492930e-02_rb,3.397230e-02_rb,3.303920e-02_rb,3.212572e-02_rb,3.123278e-02_rb,& + & 3.035519e-02_rb,2.949493e-02_rb,2.864985e-02_rb,2.781840e-02_rb,2.700197e-02_rb,& + & 2.619682e-02_rb,2.540674e-02_rb,2.462966e-02_rb,2.386613e-02_rb,2.311602e-02_rb,& + & 2.237846e-02_rb,2.165660e-02_rb,2.094756e-02_rb /) +! BAND 29 + extliq1(:, 29) = (/ & + & 4.298416e-01_rb,4.391639e-01_rb,3.975030e-01_rb,3.443028e-01_rb,2.957345e-01_rb,& + & 2.556461e-01_rb,2.234755e-01_rb,1.976636e-01_rb,1.767428e-01_rb,1.595611e-01_rb,& + & 1.452636e-01_rb,1.332156e-01_rb,1.229481e-01_rb,1.141059e-01_rb,1.064208e-01_rb,& + & 9.968527e-02_rb,9.373833e-02_rb,8.845221e-02_rb,8.372112e-02_rb,7.946667e-02_rb,& + & 7.561807e-02_rb,7.212029e-02_rb,6.893166e-02_rb,6.600944e-02_rb,6.332277e-02_rb,& + & 6.084277e-02_rb,5.854721e-02_rb,5.641361e-02_rb,5.442639e-02_rb,5.256750e-02_rb,& + & 5.082499e-02_rb,4.918556e-02_rb,4.763694e-02_rb,4.617222e-02_rb,4.477861e-02_rb,& + & 4.344861e-02_rb,4.217999e-02_rb,4.096111e-02_rb,3.978638e-02_rb,3.865361e-02_rb,& + & 3.755473e-02_rb,3.649028e-02_rb,3.545361e-02_rb,3.444361e-02_rb,3.345666e-02_rb,& + & 3.249167e-02_rb,3.154722e-02_rb,3.062083e-02_rb,2.971250e-02_rb,2.882083e-02_rb,& + & 2.794611e-02_rb,2.708778e-02_rb,2.624500e-02_rb,2.541750e-02_rb,2.460528e-02_rb,& + & 2.381194e-02_rb,2.303250e-02_rb,2.226833e-02_rb /) +! BAND 16 + ssaliq1(:, 16) = (/ & + & 8.362119e-01_rb,8.098460e-01_rb,7.762291e-01_rb,7.486042e-01_rb,7.294172e-01_rb,& + & 7.161000e-01_rb,7.060656e-01_rb,6.978387e-01_rb,6.907193e-01_rb,6.843551e-01_rb,& + & 6.785668e-01_rb,6.732450e-01_rb,6.683191e-01_rb,6.637264e-01_rb,6.594307e-01_rb,& + & 6.554033e-01_rb,6.516115e-01_rb,6.480295e-01_rb,6.446429e-01_rb,6.414306e-01_rb,& + & 6.383783e-01_rb,6.354750e-01_rb,6.327068e-01_rb,6.300665e-01_rb,6.275376e-01_rb,& + & 6.251245e-01_rb,6.228136e-01_rb,6.205944e-01_rb,6.184720e-01_rb,6.164330e-01_rb,& + & 6.144742e-01_rb,6.125962e-01_rb,6.108004e-01_rb,6.090740e-01_rb,6.074200e-01_rb,& + & 6.058381e-01_rb,6.043209e-01_rb,6.028681e-01_rb,6.014836e-01_rb,6.001626e-01_rb,& + & 5.988957e-01_rb,5.976864e-01_rb,5.965390e-01_rb,5.954379e-01_rb,5.943972e-01_rb,& + & 5.934019e-01_rb,5.924624e-01_rb,5.915579e-01_rb,5.907025e-01_rb,5.898913e-01_rb,& + & 5.891213e-01_rb,5.883815e-01_rb,5.876851e-01_rb,5.870158e-01_rb,5.863868e-01_rb,& + & 5.857821e-01_rb,5.852111e-01_rb,5.846579e-01_rb /) +! BAND 17 + ssaliq1(:, 17) = (/ & + & 6.995459e-01_rb,7.158012e-01_rb,7.076001e-01_rb,6.927244e-01_rb,6.786434e-01_rb,& + & 6.673545e-01_rb,6.585859e-01_rb,6.516314e-01_rb,6.459010e-01_rb,6.410225e-01_rb,& + & 6.367574e-01_rb,6.329554e-01_rb,6.295119e-01_rb,6.263595e-01_rb,6.234462e-01_rb,& + & 6.207274e-01_rb,6.181755e-01_rb,6.157678e-01_rb,6.134880e-01_rb,6.113173e-01_rb,& + & 6.092495e-01_rb,6.072689e-01_rb,6.053717e-01_rb,6.035507e-01_rb,6.018001e-01_rb,& + & 6.001134e-01_rb,5.984951e-01_rb,5.969294e-01_rb,5.954256e-01_rb,5.939698e-01_rb,& + & 5.925716e-01_rb,5.912265e-01_rb,5.899270e-01_rb,5.886771e-01_rb,5.874746e-01_rb,& + & 5.863185e-01_rb,5.852077e-01_rb,5.841460e-01_rb,5.831249e-01_rb,5.821474e-01_rb,& + & 5.812078e-01_rb,5.803173e-01_rb,5.794616e-01_rb,5.786443e-01_rb,5.778617e-01_rb,& + & 5.771236e-01_rb,5.764191e-01_rb,5.757400e-01_rb,5.750971e-01_rb,5.744842e-01_rb,& + & 5.739012e-01_rb,5.733482e-01_rb,5.728175e-01_rb,5.723214e-01_rb,5.718383e-01_rb,& + & 5.713827e-01_rb,5.709471e-01_rb,5.705330e-01_rb /) +! BAND 18 + ssaliq1(:, 18) = (/ & + & 9.929711e-01_rb,9.896942e-01_rb,9.852408e-01_rb,9.806820e-01_rb,9.764512e-01_rb,& + & 9.725375e-01_rb,9.688677e-01_rb,9.653832e-01_rb,9.620552e-01_rb,9.588522e-01_rb,& + & 9.557475e-01_rb,9.527265e-01_rb,9.497731e-01_rb,9.468756e-01_rb,9.440270e-01_rb,& + & 9.412230e-01_rb,9.384592e-01_rb,9.357287e-01_rb,9.330369e-01_rb,9.303778e-01_rb,& + & 9.277502e-01_rb,9.251546e-01_rb,9.225907e-01_rb,9.200553e-01_rb,9.175521e-01_rb,& + & 9.150773e-01_rb,9.126352e-01_rb,9.102260e-01_rb,9.078485e-01_rb,9.055057e-01_rb,& + & 9.031978e-01_rb,9.009306e-01_rb,8.987010e-01_rb,8.965177e-01_rb,8.943774e-01_rb,& + & 8.922869e-01_rb,8.902430e-01_rb,8.882551e-01_rb,8.863182e-01_rb,8.844373e-01_rb,& + & 8.826143e-01_rb,8.808499e-01_rb,8.791413e-01_rb,8.774940e-01_rb,8.759019e-01_rb,& + & 8.743650e-01_rb,8.728941e-01_rb,8.714712e-01_rb,8.701065e-01_rb,8.688008e-01_rb,& + & 8.675409e-01_rb,8.663295e-01_rb,8.651714e-01_rb,8.640637e-01_rb,8.629943e-01_rb,& + & 8.619762e-01_rb,8.609995e-01_rb,8.600581e-01_rb /) +! BAND 19 + ssaliq1(:, 19) = (/ & + & 9.910612e-01_rb,9.854226e-01_rb,9.795008e-01_rb,9.742920e-01_rb,9.695996e-01_rb,& + & 9.652274e-01_rb,9.610648e-01_rb,9.570521e-01_rb,9.531397e-01_rb,9.493086e-01_rb,& + & 9.455413e-01_rb,9.418362e-01_rb,9.381902e-01_rb,9.346016e-01_rb,9.310718e-01_rb,& + & 9.275957e-01_rb,9.241757e-01_rb,9.208038e-01_rb,9.174802e-01_rb,9.142058e-01_rb,& + & 9.109753e-01_rb,9.077895e-01_rb,9.046433e-01_rb,9.015409e-01_rb,8.984784e-01_rb,& + & 8.954572e-01_rb,8.924748e-01_rb,8.895367e-01_rb,8.866395e-01_rb,8.837864e-01_rb,& + & 8.809819e-01_rb,8.782267e-01_rb,8.755231e-01_rb,8.728712e-01_rb,8.702802e-01_rb,& + & 8.677443e-01_rb,8.652733e-01_rb,8.628678e-01_rb,8.605300e-01_rb,8.582593e-01_rb,& + & 8.560596e-01_rb,8.539352e-01_rb,8.518782e-01_rb,8.498915e-01_rb,8.479790e-01_rb,& + & 8.461384e-01_rb,8.443645e-01_rb,8.426613e-01_rb,8.410229e-01_rb,8.394495e-01_rb,& + & 8.379428e-01_rb,8.364967e-01_rb,8.351117e-01_rb,8.337820e-01_rb,8.325091e-01_rb,& + & 8.312874e-01_rb,8.301169e-01_rb,8.289985e-01_rb /) +! BAND 20 + ssaliq1(:, 20) = (/ & + & 9.969802e-01_rb,9.950445e-01_rb,9.931448e-01_rb,9.914272e-01_rb,9.898652e-01_rb,& + & 9.884250e-01_rb,9.870637e-01_rb,9.857482e-01_rb,9.844558e-01_rb,9.831755e-01_rb,& + & 9.819068e-01_rb,9.806477e-01_rb,9.794000e-01_rb,9.781666e-01_rb,9.769461e-01_rb,& + & 9.757386e-01_rb,9.745459e-01_rb,9.733650e-01_rb,9.721953e-01_rb,9.710398e-01_rb,& + & 9.698936e-01_rb,9.687583e-01_rb,9.676334e-01_rb,9.665192e-01_rb,9.654132e-01_rb,& + & 9.643208e-01_rb,9.632374e-01_rb,9.621625e-01_rb,9.611003e-01_rb,9.600518e-01_rb,& + & 9.590144e-01_rb,9.579922e-01_rb,9.569864e-01_rb,9.559948e-01_rb,9.550239e-01_rb,& + & 9.540698e-01_rb,9.531382e-01_rb,9.522280e-01_rb,9.513409e-01_rb,9.504772e-01_rb,& + & 9.496360e-01_rb,9.488220e-01_rb,9.480327e-01_rb,9.472693e-01_rb,9.465333e-01_rb,& + & 9.458211e-01_rb,9.451344e-01_rb,9.444732e-01_rb,9.438372e-01_rb,9.432268e-01_rb,& + & 9.426391e-01_rb,9.420757e-01_rb,9.415308e-01_rb,9.410102e-01_rb,9.405115e-01_rb,& + & 9.400326e-01_rb,9.395716e-01_rb,9.391313e-01_rb /) +! BAND 21 + ssaliq1(:, 21) = (/ & + & 9.980034e-01_rb,9.968572e-01_rb,9.958696e-01_rb,9.949747e-01_rb,9.941241e-01_rb,& + & 9.933043e-01_rb,9.924971e-01_rb,9.916978e-01_rb,9.909023e-01_rb,9.901046e-01_rb,& + & 9.893087e-01_rb,9.885146e-01_rb,9.877195e-01_rb,9.869283e-01_rb,9.861379e-01_rb,& + & 9.853523e-01_rb,9.845715e-01_rb,9.837945e-01_rb,9.830217e-01_rb,9.822567e-01_rb,& + & 9.814935e-01_rb,9.807356e-01_rb,9.799815e-01_rb,9.792332e-01_rb,9.784845e-01_rb,& + & 9.777424e-01_rb,9.770042e-01_rb,9.762695e-01_rb,9.755416e-01_rb,9.748152e-01_rb,& + & 9.740974e-01_rb,9.733873e-01_rb,9.726813e-01_rb,9.719861e-01_rb,9.713010e-01_rb,& + & 9.706262e-01_rb,9.699647e-01_rb,9.693144e-01_rb,9.686794e-01_rb,9.680596e-01_rb,& + & 9.674540e-01_rb,9.668657e-01_rb,9.662926e-01_rb,9.657390e-01_rb,9.652019e-01_rb,& + & 9.646820e-01_rb,9.641784e-01_rb,9.636945e-01_rb,9.632260e-01_rb,9.627743e-01_rb,& + & 9.623418e-01_rb,9.619227e-01_rb,9.615194e-01_rb,9.611341e-01_rb,9.607629e-01_rb,& + & 9.604057e-01_rb,9.600622e-01_rb,9.597322e-01_rb /) +! BAND 22 + ssaliq1(:, 22) = (/ & + & 9.988219e-01_rb,9.981767e-01_rb,9.976168e-01_rb,9.971066e-01_rb,9.966195e-01_rb,& + & 9.961566e-01_rb,9.956995e-01_rb,9.952481e-01_rb,9.947982e-01_rb,9.943495e-01_rb,& + & 9.938955e-01_rb,9.934368e-01_rb,9.929825e-01_rb,9.925239e-01_rb,9.920653e-01_rb,& + & 9.916096e-01_rb,9.911552e-01_rb,9.907067e-01_rb,9.902594e-01_rb,9.898178e-01_rb,& + & 9.893791e-01_rb,9.889453e-01_rb,9.885122e-01_rb,9.880837e-01_rb,9.876567e-01_rb,& + & 9.872331e-01_rb,9.868121e-01_rb,9.863938e-01_rb,9.859790e-01_rb,9.855650e-01_rb,& + & 9.851548e-01_rb,9.847491e-01_rb,9.843496e-01_rb,9.839521e-01_rb,9.835606e-01_rb,& + & 9.831771e-01_rb,9.827975e-01_rb,9.824292e-01_rb,9.820653e-01_rb,9.817124e-01_rb,& + & 9.813644e-01_rb,9.810291e-01_rb,9.807020e-01_rb,9.803864e-01_rb,9.800782e-01_rb,& + & 9.797821e-01_rb,9.794958e-01_rb,9.792179e-01_rb,9.789509e-01_rb,9.786940e-01_rb,& + & 9.784460e-01_rb,9.782090e-01_rb,9.779789e-01_rb,9.777553e-01_rb,9.775425e-01_rb,& + & 9.773387e-01_rb,9.771420e-01_rb,9.769529e-01_rb /) +! BAND 23 + ssaliq1(:, 23) = (/ & + & 9.998902e-01_rb,9.998395e-01_rb,9.997915e-01_rb,9.997442e-01_rb,9.997016e-01_rb,& + & 9.996600e-01_rb,9.996200e-01_rb,9.995806e-01_rb,9.995411e-01_rb,9.995005e-01_rb,& + & 9.994589e-01_rb,9.994178e-01_rb,9.993766e-01_rb,9.993359e-01_rb,9.992948e-01_rb,& + & 9.992533e-01_rb,9.992120e-01_rb,9.991723e-01_rb,9.991313e-01_rb,9.990906e-01_rb,& + & 9.990510e-01_rb,9.990113e-01_rb,9.989716e-01_rb,9.989323e-01_rb,9.988923e-01_rb,& + & 9.988532e-01_rb,9.988140e-01_rb,9.987761e-01_rb,9.987373e-01_rb,9.986989e-01_rb,& + & 9.986597e-01_rb,9.986239e-01_rb,9.985861e-01_rb,9.985485e-01_rb,9.985123e-01_rb,& + & 9.984762e-01_rb,9.984415e-01_rb,9.984065e-01_rb,9.983722e-01_rb,9.983398e-01_rb,& + & 9.983078e-01_rb,9.982758e-01_rb,9.982461e-01_rb,9.982157e-01_rb,9.981872e-01_rb,& + & 9.981595e-01_rb,9.981324e-01_rb,9.981068e-01_rb,9.980811e-01_rb,9.980580e-01_rb,& + & 9.980344e-01_rb,9.980111e-01_rb,9.979908e-01_rb,9.979690e-01_rb,9.979492e-01_rb,& + & 9.979316e-01_rb,9.979116e-01_rb,9.978948e-01_rb /) +! BAND 24 + ssaliq1(:, 24) = (/ & + & 9.999978e-01_rb,9.999948e-01_rb,9.999915e-01_rb,9.999905e-01_rb,9.999896e-01_rb,& + & 9.999887e-01_rb,9.999888e-01_rb,9.999888e-01_rb,9.999870e-01_rb,9.999854e-01_rb,& + & 9.999855e-01_rb,9.999856e-01_rb,9.999839e-01_rb,9.999834e-01_rb,9.999829e-01_rb,& + & 9.999809e-01_rb,9.999816e-01_rb,9.999793e-01_rb,9.999782e-01_rb,9.999779e-01_rb,& + & 9.999772e-01_rb,9.999764e-01_rb,9.999756e-01_rb,9.999744e-01_rb,9.999744e-01_rb,& + & 9.999736e-01_rb,9.999729e-01_rb,9.999716e-01_rb,9.999706e-01_rb,9.999692e-01_rb,& + & 9.999690e-01_rb,9.999675e-01_rb,9.999673e-01_rb,9.999660e-01_rb,9.999654e-01_rb,& + & 9.999647e-01_rb,9.999647e-01_rb,9.999625e-01_rb,9.999620e-01_rb,9.999614e-01_rb,& + & 9.999613e-01_rb,9.999607e-01_rb,9.999604e-01_rb,9.999594e-01_rb,9.999589e-01_rb,& + & 9.999586e-01_rb,9.999567e-01_rb,9.999550e-01_rb,9.999557e-01_rb,9.999542e-01_rb,& + & 9.999546e-01_rb,9.999539e-01_rb,9.999536e-01_rb,9.999526e-01_rb,9.999523e-01_rb,& + & 9.999508e-01_rb,9.999534e-01_rb,9.999507e-01_rb /) +! BAND 25 + ssaliq1(:, 25) = (/ & + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999995e-01_rb,& + & 9.999995e-01_rb,9.999990e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,& + & 9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999986e-01_rb,9.999988e-01_rb,& + & 9.999986e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,& + & 9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999983e-01_rb,9.999981e-01_rb,& + & 9.999981e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999984e-01_rb,& + & 9.999982e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999981e-01_rb,& + & 9.999978e-01_rb,9.999979e-01_rb,9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,& + & 9.999983e-01_rb,9.999983e-01_rb,9.999983e-01_rb /) +! BAND 26 + ssaliq1(:, 26) = (/ & + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999991e-01_rb,& + & 9.999990e-01_rb,9.999992e-01_rb,9.999995e-01_rb,9.999986e-01_rb,9.999994e-01_rb,& + & 9.999985e-01_rb,9.999980e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999979e-01_rb,& + & 9.999969e-01_rb,9.999977e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999969e-01_rb,& + & 9.999965e-01_rb,9.999970e-01_rb,9.999985e-01_rb,9.999973e-01_rb,9.999961e-01_rb,& + & 9.999968e-01_rb,9.999952e-01_rb,9.999970e-01_rb,9.999974e-01_rb,9.999965e-01_rb,& + & 9.999969e-01_rb,9.999970e-01_rb,9.999970e-01_rb,9.999960e-01_rb,9.999923e-01_rb,& + & 9.999958e-01_rb,9.999937e-01_rb,9.999960e-01_rb,9.999953e-01_rb,9.999946e-01_rb,& + & 9.999946e-01_rb,9.999957e-01_rb,9.999951e-01_rb /) +! BAND 27 + ssaliq1(:, 27) = (/ & + & 1.000000e+00_rb,1.000000e+00_rb,9.999983e-01_rb,9.999979e-01_rb,9.999965e-01_rb,& + & 9.999949e-01_rb,9.999948e-01_rb,9.999918e-01_rb,9.999917e-01_rb,9.999923e-01_rb,& + & 9.999908e-01_rb,9.999889e-01_rb,9.999902e-01_rb,9.999895e-01_rb,9.999881e-01_rb,& + & 9.999882e-01_rb,9.999876e-01_rb,9.999866e-01_rb,9.999866e-01_rb,9.999858e-01_rb,& + & 9.999860e-01_rb,9.999852e-01_rb,9.999836e-01_rb,9.999831e-01_rb,9.999818e-01_rb,& + & 9.999808e-01_rb,9.999816e-01_rb,9.999800e-01_rb,9.999783e-01_rb,9.999780e-01_rb,& + & 9.999763e-01_rb,9.999746e-01_rb,9.999731e-01_rb,9.999713e-01_rb,9.999762e-01_rb,& + & 9.999740e-01_rb,9.999670e-01_rb,9.999703e-01_rb,9.999687e-01_rb,9.999666e-01_rb,& + & 9.999683e-01_rb,9.999667e-01_rb,9.999611e-01_rb,9.999635e-01_rb,9.999600e-01_rb,& + & 9.999635e-01_rb,9.999594e-01_rb,9.999601e-01_rb,9.999586e-01_rb,9.999559e-01_rb,& + & 9.999569e-01_rb,9.999558e-01_rb,9.999523e-01_rb,9.999535e-01_rb,9.999529e-01_rb,& + & 9.999553e-01_rb,9.999495e-01_rb,9.999490e-01_rb /) +! BAND 28 + ssaliq1(:, 28) = (/ & + & 9.999920e-01_rb,9.999873e-01_rb,9.999855e-01_rb,9.999832e-01_rb,9.999807e-01_rb,& + & 9.999778e-01_rb,9.999754e-01_rb,9.999721e-01_rb,9.999692e-01_rb,9.999651e-01_rb,& + & 9.999621e-01_rb,9.999607e-01_rb,9.999567e-01_rb,9.999546e-01_rb,9.999521e-01_rb,& + & 9.999491e-01_rb,9.999457e-01_rb,9.999439e-01_rb,9.999403e-01_rb,9.999374e-01_rb,& + & 9.999353e-01_rb,9.999315e-01_rb,9.999282e-01_rb,9.999244e-01_rb,9.999234e-01_rb,& + & 9.999189e-01_rb,9.999130e-01_rb,9.999117e-01_rb,9.999073e-01_rb,9.999020e-01_rb,& + & 9.998993e-01_rb,9.998987e-01_rb,9.998922e-01_rb,9.998893e-01_rb,9.998869e-01_rb,& + & 9.998805e-01_rb,9.998778e-01_rb,9.998751e-01_rb,9.998708e-01_rb,9.998676e-01_rb,& + & 9.998624e-01_rb,9.998642e-01_rb,9.998582e-01_rb,9.998547e-01_rb,9.998546e-01_rb,& + & 9.998477e-01_rb,9.998487e-01_rb,9.998466e-01_rb,9.998403e-01_rb,9.998412e-01_rb,& + & 9.998406e-01_rb,9.998342e-01_rb,9.998326e-01_rb,9.998333e-01_rb,9.998328e-01_rb,& + & 9.998290e-01_rb,9.998276e-01_rb,9.998249e-01_rb /) +! BAND 29 + ssaliq1(:, 29) = (/ & + & 8.383753e-01_rb,8.461471e-01_rb,8.373325e-01_rb,8.212889e-01_rb,8.023834e-01_rb,& + & 7.829501e-01_rb,7.641777e-01_rb,7.466000e-01_rb,7.304023e-01_rb,7.155998e-01_rb,& + & 7.021259e-01_rb,6.898840e-01_rb,6.787615e-01_rb,6.686479e-01_rb,6.594414e-01_rb,& + & 6.510417e-01_rb,6.433668e-01_rb,6.363335e-01_rb,6.298788e-01_rb,6.239398e-01_rb,& + & 6.184633e-01_rb,6.134055e-01_rb,6.087228e-01_rb,6.043786e-01_rb,6.003439e-01_rb,& + & 5.965910e-01_rb,5.930917e-01_rb,5.898280e-01_rb,5.867798e-01_rb,5.839264e-01_rb,& + & 5.812576e-01_rb,5.787592e-01_rb,5.764163e-01_rb,5.742189e-01_rb,5.721598e-01_rb,& + & 5.702286e-01_rb,5.684182e-01_rb,5.667176e-01_rb,5.651237e-01_rb,5.636253e-01_rb,& + & 5.622228e-01_rb,5.609074e-01_rb,5.596713e-01_rb,5.585089e-01_rb,5.574223e-01_rb,& + & 5.564002e-01_rb,5.554411e-01_rb,5.545397e-01_rb,5.536914e-01_rb,5.528967e-01_rb,& + & 5.521495e-01_rb,5.514457e-01_rb,5.507818e-01_rb,5.501623e-01_rb,5.495750e-01_rb,& + & 5.490192e-01_rb,5.484980e-01_rb,5.480046e-01_rb /) +! BAND 16 + asyliq1(:, 16) = (/ & + & 8.038165e-01_rb,8.014154e-01_rb,7.942381e-01_rb,7.970521e-01_rb,8.086621e-01_rb,& + & 8.233392e-01_rb,8.374127e-01_rb,8.495742e-01_rb,8.596945e-01_rb,8.680497e-01_rb,& + & 8.750005e-01_rb,8.808589e-01_rb,8.858749e-01_rb,8.902403e-01_rb,8.940939e-01_rb,& + & 8.975379e-01_rb,9.006450e-01_rb,9.034741e-01_rb,9.060659e-01_rb,9.084561e-01_rb,& + & 9.106675e-01_rb,9.127198e-01_rb,9.146332e-01_rb,9.164194e-01_rb,9.180970e-01_rb,& + & 9.196658e-01_rb,9.211421e-01_rb,9.225352e-01_rb,9.238443e-01_rb,9.250841e-01_rb,& + & 9.262541e-01_rb,9.273620e-01_rb,9.284081e-01_rb,9.294002e-01_rb,9.303395e-01_rb,& + & 9.312285e-01_rb,9.320715e-01_rb,9.328716e-01_rb,9.336271e-01_rb,9.343427e-01_rb,& + & 9.350219e-01_rb,9.356647e-01_rb,9.362728e-01_rb,9.368495e-01_rb,9.373956e-01_rb,& + & 9.379113e-01_rb,9.383987e-01_rb,9.388608e-01_rb,9.392986e-01_rb,9.397132e-01_rb,& + & 9.401063e-01_rb,9.404776e-01_rb,9.408299e-01_rb,9.411641e-01_rb,9.414800e-01_rb,& + & 9.417787e-01_rb,9.420633e-01_rb,9.423364e-01_rb /) +! BAND 17 + asyliq1(:, 17) = (/ & + & 8.941000e-01_rb,9.054049e-01_rb,9.049510e-01_rb,9.027216e-01_rb,9.021636e-01_rb,& + & 9.037878e-01_rb,9.069852e-01_rb,9.109817e-01_rb,9.152013e-01_rb,9.193040e-01_rb,& + & 9.231177e-01_rb,9.265712e-01_rb,9.296606e-01_rb,9.324048e-01_rb,9.348419e-01_rb,& + & 9.370131e-01_rb,9.389529e-01_rb,9.406954e-01_rb,9.422727e-01_rb,9.437088e-01_rb,& + & 9.450221e-01_rb,9.462308e-01_rb,9.473488e-01_rb,9.483830e-01_rb,9.493492e-01_rb,& + & 9.502541e-01_rb,9.510999e-01_rb,9.518971e-01_rb,9.526455e-01_rb,9.533554e-01_rb,& + & 9.540249e-01_rb,9.546571e-01_rb,9.552551e-01_rb,9.558258e-01_rb,9.563603e-01_rb,& + & 9.568713e-01_rb,9.573569e-01_rb,9.578141e-01_rb,9.582485e-01_rb,9.586604e-01_rb,& + & 9.590525e-01_rb,9.594218e-01_rb,9.597710e-01_rb,9.601052e-01_rb,9.604181e-01_rb,& + & 9.607159e-01_rb,9.609979e-01_rb,9.612655e-01_rb,9.615184e-01_rb,9.617564e-01_rb,& + & 9.619860e-01_rb,9.622009e-01_rb,9.624031e-01_rb,9.625957e-01_rb,9.627792e-01_rb,& + & 9.629530e-01_rb,9.631171e-01_rb,9.632746e-01_rb /) +! BAND 18 + asyliq1(:, 18) = (/ & + & 8.574638e-01_rb,8.351383e-01_rb,8.142977e-01_rb,8.083068e-01_rb,8.129284e-01_rb,& + & 8.215827e-01_rb,8.307238e-01_rb,8.389963e-01_rb,8.460481e-01_rb,8.519273e-01_rb,& + & 8.568153e-01_rb,8.609116e-01_rb,8.643892e-01_rb,8.673941e-01_rb,8.700248e-01_rb,& + & 8.723707e-01_rb,8.744902e-01_rb,8.764240e-01_rb,8.782057e-01_rb,8.798593e-01_rb,& + & 8.814063e-01_rb,8.828573e-01_rb,8.842261e-01_rb,8.855196e-01_rb,8.867497e-01_rb,& + & 8.879164e-01_rb,8.890316e-01_rb,8.900941e-01_rb,8.911118e-01_rb,8.920832e-01_rb,& + & 8.930156e-01_rb,8.939091e-01_rb,8.947663e-01_rb,8.955888e-01_rb,8.963786e-01_rb,& + & 8.971350e-01_rb,8.978617e-01_rb,8.985590e-01_rb,8.992243e-01_rb,8.998631e-01_rb,& + & 9.004753e-01_rb,9.010602e-01_rb,9.016192e-01_rb,9.021542e-01_rb,9.026644e-01_rb,& + & 9.031535e-01_rb,9.036194e-01_rb,9.040656e-01_rb,9.044894e-01_rb,9.048933e-01_rb,& + & 9.052789e-01_rb,9.056481e-01_rb,9.060004e-01_rb,9.063343e-01_rb,9.066544e-01_rb,& + & 9.069604e-01_rb,9.072512e-01_rb,9.075290e-01_rb /) +! BAND 19 + asyliq1(:, 19) = (/ & + & 8.349569e-01_rb,8.034579e-01_rb,7.932136e-01_rb,8.010156e-01_rb,8.137083e-01_rb,& + & 8.255339e-01_rb,8.351938e-01_rb,8.428286e-01_rb,8.488944e-01_rb,8.538187e-01_rb,& + & 8.579255e-01_rb,8.614473e-01_rb,8.645338e-01_rb,8.672908e-01_rb,8.697947e-01_rb,& + & 8.720843e-01_rb,8.742015e-01_rb,8.761718e-01_rb,8.780160e-01_rb,8.797479e-01_rb,& + & 8.813810e-01_rb,8.829250e-01_rb,8.843907e-01_rb,8.857822e-01_rb,8.871059e-01_rb,& + & 8.883724e-01_rb,8.895810e-01_rb,8.907384e-01_rb,8.918456e-01_rb,8.929083e-01_rb,& + & 8.939284e-01_rb,8.949060e-01_rb,8.958463e-01_rb,8.967486e-01_rb,8.976129e-01_rb,& + & 8.984463e-01_rb,8.992439e-01_rb,9.000094e-01_rb,9.007438e-01_rb,9.014496e-01_rb,& + & 9.021235e-01_rb,9.027699e-01_rb,9.033859e-01_rb,9.039772e-01_rb,9.045419e-01_rb,& + & 9.050819e-01_rb,9.055975e-01_rb,9.060907e-01_rb,9.065607e-01_rb,9.070093e-01_rb,& + & 9.074389e-01_rb,9.078475e-01_rb,9.082388e-01_rb,9.086117e-01_rb,9.089678e-01_rb,& + & 9.093081e-01_rb,9.096307e-01_rb,9.099410e-01_rb /) +! BAND 20 + asyliq1(:, 20) = (/ & + & 8.109692e-01_rb,7.846657e-01_rb,7.881928e-01_rb,8.009509e-01_rb,8.131208e-01_rb,& + & 8.230400e-01_rb,8.309448e-01_rb,8.372920e-01_rb,8.424837e-01_rb,8.468166e-01_rb,& + & 8.504947e-01_rb,8.536642e-01_rb,8.564256e-01_rb,8.588513e-01_rb,8.610011e-01_rb,& + & 8.629122e-01_rb,8.646262e-01_rb,8.661720e-01_rb,8.675752e-01_rb,8.688582e-01_rb,& + & 8.700379e-01_rb,8.711300e-01_rb,8.721485e-01_rb,8.731027e-01_rb,8.740010e-01_rb,& + & 8.748499e-01_rb,8.756564e-01_rb,8.764239e-01_rb,8.771542e-01_rb,8.778523e-01_rb,& + & 8.785211e-01_rb,8.791601e-01_rb,8.797725e-01_rb,8.803589e-01_rb,8.809173e-01_rb,& + & 8.814552e-01_rb,8.819705e-01_rb,8.824611e-01_rb,8.829311e-01_rb,8.833791e-01_rb,& + & 8.838078e-01_rb,8.842148e-01_rb,8.846044e-01_rb,8.849756e-01_rb,8.853291e-01_rb,& + & 8.856645e-01_rb,8.859841e-01_rb,8.862904e-01_rb,8.865801e-01_rb,8.868551e-01_rb,& + & 8.871182e-01_rb,8.873673e-01_rb,8.876059e-01_rb,8.878307e-01_rb,8.880462e-01_rb,& + & 8.882501e-01_rb,8.884453e-01_rb,8.886339e-01_rb /) +! BAND 21 + asyliq1(:, 21) = (/ & + & 7.838510e-01_rb,7.803151e-01_rb,7.980477e-01_rb,8.144160e-01_rb,8.261784e-01_rb,& + & 8.344240e-01_rb,8.404278e-01_rb,8.450391e-01_rb,8.487593e-01_rb,8.518741e-01_rb,& + & 8.545484e-01_rb,8.568890e-01_rb,8.589560e-01_rb,8.607983e-01_rb,8.624504e-01_rb,& + & 8.639408e-01_rb,8.652945e-01_rb,8.665301e-01_rb,8.676634e-01_rb,8.687121e-01_rb,& + & 8.696855e-01_rb,8.705933e-01_rb,8.714448e-01_rb,8.722454e-01_rb,8.730014e-01_rb,& + & 8.737180e-01_rb,8.743982e-01_rb,8.750436e-01_rb,8.756598e-01_rb,8.762481e-01_rb,& + & 8.768089e-01_rb,8.773427e-01_rb,8.778532e-01_rb,8.783434e-01_rb,8.788089e-01_rb,& + & 8.792530e-01_rb,8.796784e-01_rb,8.800845e-01_rb,8.804716e-01_rb,8.808411e-01_rb,& + & 8.811923e-01_rb,8.815276e-01_rb,8.818472e-01_rb,8.821504e-01_rb,8.824408e-01_rb,& + & 8.827155e-01_rb,8.829777e-01_rb,8.832269e-01_rb,8.834631e-01_rb,8.836892e-01_rb,& + & 8.839034e-01_rb,8.841075e-01_rb,8.843021e-01_rb,8.844866e-01_rb,8.846631e-01_rb,& + & 8.848304e-01_rb,8.849910e-01_rb,8.851425e-01_rb /) +! BAND 22 + asyliq1(:, 22) = (/ & + & 7.760783e-01_rb,7.890215e-01_rb,8.090192e-01_rb,8.230252e-01_rb,8.321369e-01_rb,& + & 8.384258e-01_rb,8.431529e-01_rb,8.469558e-01_rb,8.501499e-01_rb,8.528899e-01_rb,& + & 8.552899e-01_rb,8.573956e-01_rb,8.592570e-01_rb,8.609098e-01_rb,8.623897e-01_rb,& + & 8.637169e-01_rb,8.649184e-01_rb,8.660097e-01_rb,8.670096e-01_rb,8.679338e-01_rb,& + & 8.687896e-01_rb,8.695880e-01_rb,8.703365e-01_rb,8.710422e-01_rb,8.717092e-01_rb,& + & 8.723378e-01_rb,8.729363e-01_rb,8.735063e-01_rb,8.740475e-01_rb,8.745661e-01_rb,& + & 8.750560e-01_rb,8.755275e-01_rb,8.759731e-01_rb,8.764000e-01_rb,8.768071e-01_rb,& + & 8.771942e-01_rb,8.775628e-01_rb,8.779126e-01_rb,8.782483e-01_rb,8.785626e-01_rb,& + & 8.788610e-01_rb,8.791482e-01_rb,8.794180e-01_rb,8.796765e-01_rb,8.799207e-01_rb,& + & 8.801522e-01_rb,8.803707e-01_rb,8.805777e-01_rb,8.807749e-01_rb,8.809605e-01_rb,& + & 8.811362e-01_rb,8.813047e-01_rb,8.814647e-01_rb,8.816131e-01_rb,8.817588e-01_rb,& + & 8.818930e-01_rb,8.820230e-01_rb,8.821445e-01_rb /) +! BAND 23 + asyliq1(:, 23) = (/ & + & 7.847907e-01_rb,8.099917e-01_rb,8.257428e-01_rb,8.350423e-01_rb,8.411971e-01_rb,& + & 8.457241e-01_rb,8.493010e-01_rb,8.522565e-01_rb,8.547660e-01_rb,8.569311e-01_rb,& + & 8.588181e-01_rb,8.604729e-01_rb,8.619296e-01_rb,8.632208e-01_rb,8.643725e-01_rb,& + & 8.654050e-01_rb,8.663363e-01_rb,8.671835e-01_rb,8.679590e-01_rb,8.686707e-01_rb,& + & 8.693308e-01_rb,8.699433e-01_rb,8.705147e-01_rb,8.710490e-01_rb,8.715497e-01_rb,& + & 8.720219e-01_rb,8.724669e-01_rb,8.728849e-01_rb,8.732806e-01_rb,8.736550e-01_rb,& + & 8.740099e-01_rb,8.743435e-01_rb,8.746601e-01_rb,8.749610e-01_rb,8.752449e-01_rb,& + & 8.755143e-01_rb,8.757688e-01_rb,8.760095e-01_rb,8.762375e-01_rb,8.764532e-01_rb,& + & 8.766579e-01_rb,8.768506e-01_rb,8.770323e-01_rb,8.772049e-01_rb,8.773690e-01_rb,& + & 8.775226e-01_rb,8.776679e-01_rb,8.778062e-01_rb,8.779360e-01_rb,8.780587e-01_rb,& + & 8.781747e-01_rb,8.782852e-01_rb,8.783892e-01_rb,8.784891e-01_rb,8.785824e-01_rb,& + & 8.786705e-01_rb,8.787546e-01_rb,8.788336e-01_rb /) +! BAND 24 + asyliq1(:, 24) = (/ & + & 8.054324e-01_rb,8.266282e-01_rb,8.378075e-01_rb,8.449848e-01_rb,8.502166e-01_rb,& + & 8.542268e-01_rb,8.573477e-01_rb,8.598022e-01_rb,8.617689e-01_rb,8.633859e-01_rb,& + & 8.647536e-01_rb,8.659354e-01_rb,8.669807e-01_rb,8.679143e-01_rb,8.687577e-01_rb,& + & 8.695222e-01_rb,8.702207e-01_rb,8.708591e-01_rb,8.714446e-01_rb,8.719836e-01_rb,& + & 8.724812e-01_rb,8.729426e-01_rb,8.733689e-01_rb,8.737665e-01_rb,8.741373e-01_rb,& + & 8.744834e-01_rb,8.748070e-01_rb,8.751131e-01_rb,8.754011e-01_rb,8.756676e-01_rb,& + & 8.759219e-01_rb,8.761599e-01_rb,8.763857e-01_rb,8.765984e-01_rb,8.767999e-01_rb,& + & 8.769889e-01_rb,8.771669e-01_rb,8.773373e-01_rb,8.774969e-01_rb,8.776469e-01_rb,& + & 8.777894e-01_rb,8.779237e-01_rb,8.780505e-01_rb,8.781703e-01_rb,8.782820e-01_rb,& + & 8.783886e-01_rb,8.784894e-01_rb,8.785844e-01_rb,8.786736e-01_rb,8.787584e-01_rb,& + & 8.788379e-01_rb,8.789130e-01_rb,8.789849e-01_rb,8.790506e-01_rb,8.791141e-01_rb,& + & 8.791750e-01_rb,8.792324e-01_rb,8.792867e-01_rb /) +! BAND 25 + asyliq1(:, 25) = (/ & + & 8.249534e-01_rb,8.391988e-01_rb,8.474107e-01_rb,8.526860e-01_rb,8.563983e-01_rb,& + & 8.592389e-01_rb,8.615144e-01_rb,8.633790e-01_rb,8.649325e-01_rb,8.662504e-01_rb,& + & 8.673841e-01_rb,8.683741e-01_rb,8.692495e-01_rb,8.700309e-01_rb,8.707328e-01_rb,& + & 8.713650e-01_rb,8.719432e-01_rb,8.724676e-01_rb,8.729498e-01_rb,8.733922e-01_rb,& + & 8.737981e-01_rb,8.741745e-01_rb,8.745225e-01_rb,8.748467e-01_rb,8.751512e-01_rb,& + & 8.754315e-01_rb,8.756962e-01_rb,8.759450e-01_rb,8.761774e-01_rb,8.763945e-01_rb,& + & 8.766021e-01_rb,8.767970e-01_rb,8.769803e-01_rb,8.771511e-01_rb,8.773151e-01_rb,& + & 8.774689e-01_rb,8.776147e-01_rb,8.777533e-01_rb,8.778831e-01_rb,8.780050e-01_rb,& + & 8.781197e-01_rb,8.782301e-01_rb,8.783323e-01_rb,8.784312e-01_rb,8.785222e-01_rb,& + & 8.786096e-01_rb,8.786916e-01_rb,8.787688e-01_rb,8.788411e-01_rb,8.789122e-01_rb,& + & 8.789762e-01_rb,8.790373e-01_rb,8.790954e-01_rb,8.791514e-01_rb,8.792018e-01_rb,& + & 8.792517e-01_rb,8.792990e-01_rb,8.793429e-01_rb /) +! BAND 26 + asyliq1(:, 26) = (/ & + & 8.323091e-01_rb,8.429776e-01_rb,8.498123e-01_rb,8.546929e-01_rb,8.584295e-01_rb,& + & 8.613489e-01_rb,8.636324e-01_rb,8.654303e-01_rb,8.668675e-01_rb,8.680404e-01_rb,& + & 8.690174e-01_rb,8.698495e-01_rb,8.705666e-01_rb,8.711961e-01_rb,8.717556e-01_rb,& + & 8.722546e-01_rb,8.727063e-01_rb,8.731170e-01_rb,8.734933e-01_rb,8.738382e-01_rb,& + & 8.741590e-01_rb,8.744525e-01_rb,8.747295e-01_rb,8.749843e-01_rb,8.752210e-01_rb,& + & 8.754437e-01_rb,8.756524e-01_rb,8.758472e-01_rb,8.760288e-01_rb,8.762030e-01_rb,& + & 8.763603e-01_rb,8.765122e-01_rb,8.766539e-01_rb,8.767894e-01_rb,8.769130e-01_rb,& + & 8.770310e-01_rb,8.771422e-01_rb,8.772437e-01_rb,8.773419e-01_rb,8.774355e-01_rb,& + & 8.775221e-01_rb,8.776047e-01_rb,8.776802e-01_rb,8.777539e-01_rb,8.778216e-01_rb,& + & 8.778859e-01_rb,8.779473e-01_rb,8.780031e-01_rb,8.780562e-01_rb,8.781097e-01_rb,& + & 8.781570e-01_rb,8.782021e-01_rb,8.782463e-01_rb,8.782845e-01_rb,8.783235e-01_rb,& + & 8.783610e-01_rb,8.783953e-01_rb,8.784273e-01_rb /) +! BAND 27 + asyliq1(:, 27) = (/ & + & 8.396448e-01_rb,8.480172e-01_rb,8.535934e-01_rb,8.574145e-01_rb,8.600835e-01_rb,& + & 8.620347e-01_rb,8.635500e-01_rb,8.648003e-01_rb,8.658758e-01_rb,8.668248e-01_rb,& + & 8.676697e-01_rb,8.684220e-01_rb,8.690893e-01_rb,8.696807e-01_rb,8.702046e-01_rb,& + & 8.706676e-01_rb,8.710798e-01_rb,8.714478e-01_rb,8.717778e-01_rb,8.720747e-01_rb,& + & 8.723431e-01_rb,8.725889e-01_rb,8.728144e-01_rb,8.730201e-01_rb,8.732129e-01_rb,& + & 8.733907e-01_rb,8.735541e-01_rb,8.737100e-01_rb,8.738533e-01_rb,8.739882e-01_rb,& + & 8.741164e-01_rb,8.742362e-01_rb,8.743485e-01_rb,8.744530e-01_rb,8.745512e-01_rb,& + & 8.746471e-01_rb,8.747373e-01_rb,8.748186e-01_rb,8.748973e-01_rb,8.749732e-01_rb,& + & 8.750443e-01_rb,8.751105e-01_rb,8.751747e-01_rb,8.752344e-01_rb,8.752902e-01_rb,& + & 8.753412e-01_rb,8.753917e-01_rb,8.754393e-01_rb,8.754843e-01_rb,8.755282e-01_rb,& + & 8.755662e-01_rb,8.756039e-01_rb,8.756408e-01_rb,8.756722e-01_rb,8.757072e-01_rb,& + & 8.757352e-01_rb,8.757653e-01_rb,8.757932e-01_rb /) +! BAND 28 + asyliq1(:, 28) = (/ & + & 8.374590e-01_rb,8.465669e-01_rb,8.518701e-01_rb,8.547627e-01_rb,8.565745e-01_rb,& + & 8.579065e-01_rb,8.589717e-01_rb,8.598632e-01_rb,8.606363e-01_rb,8.613268e-01_rb,& + & 8.619560e-01_rb,8.625340e-01_rb,8.630689e-01_rb,8.635601e-01_rb,8.640084e-01_rb,& + & 8.644180e-01_rb,8.647885e-01_rb,8.651220e-01_rb,8.654218e-01_rb,8.656908e-01_rb,& + & 8.659294e-01_rb,8.661422e-01_rb,8.663334e-01_rb,8.665037e-01_rb,8.666543e-01_rb,& + & 8.667913e-01_rb,8.669156e-01_rb,8.670242e-01_rb,8.671249e-01_rb,8.672161e-01_rb,& + & 8.672993e-01_rb,8.673733e-01_rb,8.674457e-01_rb,8.675103e-01_rb,8.675713e-01_rb,& + & 8.676267e-01_rb,8.676798e-01_rb,8.677286e-01_rb,8.677745e-01_rb,8.678178e-01_rb,& + & 8.678601e-01_rb,8.678986e-01_rb,8.679351e-01_rb,8.679693e-01_rb,8.680013e-01_rb,& + & 8.680334e-01_rb,8.680624e-01_rb,8.680915e-01_rb,8.681178e-01_rb,8.681428e-01_rb,& + & 8.681654e-01_rb,8.681899e-01_rb,8.682103e-01_rb,8.682317e-01_rb,8.682498e-01_rb,& + & 8.682677e-01_rb,8.682861e-01_rb,8.683041e-01_rb /) +! BAND 29 + asyliq1(:, 29) = (/ & + & 7.877069e-01_rb,8.244281e-01_rb,8.367971e-01_rb,8.409074e-01_rb,8.429859e-01_rb,& + & 8.454386e-01_rb,8.489350e-01_rb,8.534141e-01_rb,8.585814e-01_rb,8.641267e-01_rb,& + & 8.697999e-01_rb,8.754223e-01_rb,8.808785e-01_rb,8.860944e-01_rb,8.910354e-01_rb,& + & 8.956837e-01_rb,9.000392e-01_rb,9.041091e-01_rb,9.079071e-01_rb,9.114479e-01_rb,& + & 9.147462e-01_rb,9.178234e-01_rb,9.206903e-01_rb,9.233663e-01_rb,9.258668e-01_rb,& + & 9.282006e-01_rb,9.303847e-01_rb,9.324288e-01_rb,9.343418e-01_rb,9.361356e-01_rb,& + & 9.378176e-01_rb,9.393939e-01_rb,9.408736e-01_rb,9.422622e-01_rb,9.435670e-01_rb,& + & 9.447900e-01_rb,9.459395e-01_rb,9.470199e-01_rb,9.480335e-01_rb,9.489852e-01_rb,& + & 9.498782e-01_rb,9.507168e-01_rb,9.515044e-01_rb,9.522470e-01_rb,9.529409e-01_rb,& + & 9.535946e-01_rb,9.542071e-01_rb,9.547838e-01_rb,9.553256e-01_rb,9.558351e-01_rb,& + & 9.563139e-01_rb,9.567660e-01_rb,9.571915e-01_rb,9.575901e-01_rb,9.579685e-01_rb,& + & 9.583239e-01_rb,9.586602e-01_rb,9.589766e-01_rb /) + + +! Spherical Ice Particle Parameterization +! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] + extice2(:, 16) = (/ & +! band 16 + & 4.101824e-01_rb,2.435514e-01_rb,1.713697e-01_rb,1.314865e-01_rb,1.063406e-01_rb,& + & 8.910701e-02_rb,7.659480e-02_rb,6.711784e-02_rb,5.970353e-02_rb,5.375249e-02_rb,& + & 4.887577e-02_rb,4.481025e-02_rb,4.137171e-02_rb,3.842744e-02_rb,3.587948e-02_rb,& + & 3.365396e-02_rb,3.169419e-02_rb,2.995593e-02_rb,2.840419e-02_rb,2.701091e-02_rb,& + & 2.575336e-02_rb,2.461293e-02_rb,2.357423e-02_rb,2.262443e-02_rb,2.175276e-02_rb,& + & 2.095012e-02_rb,2.020875e-02_rb,1.952199e-02_rb,1.888412e-02_rb,1.829018e-02_rb,& + & 1.773586e-02_rb,1.721738e-02_rb,1.673144e-02_rb,1.627510e-02_rb,1.584579e-02_rb,& + & 1.544122e-02_rb,1.505934e-02_rb,1.469833e-02_rb,1.435654e-02_rb,1.403251e-02_rb,& + & 1.372492e-02_rb,1.343255e-02_rb,1.315433e-02_rb /) + extice2(:, 17) = (/ & +! band 17 + & 3.836650e-01_rb,2.304055e-01_rb,1.637265e-01_rb,1.266681e-01_rb,1.031602e-01_rb,& + & 8.695191e-02_rb,7.511544e-02_rb,6.610009e-02_rb,5.900909e-02_rb,5.328833e-02_rb,& + & 4.857728e-02_rb,4.463133e-02_rb,4.127880e-02_rb,3.839567e-02_rb,3.589013e-02_rb,& + & 3.369280e-02_rb,3.175027e-02_rb,3.002079e-02_rb,2.847121e-02_rb,2.707493e-02_rb,& + & 2.581031e-02_rb,2.465962e-02_rb,2.360815e-02_rb,2.264363e-02_rb,2.175571e-02_rb,& + & 2.093563e-02_rb,2.017592e-02_rb,1.947015e-02_rb,1.881278e-02_rb,1.819901e-02_rb,& + & 1.762463e-02_rb,1.708598e-02_rb,1.657982e-02_rb,1.610330e-02_rb,1.565390e-02_rb,& + & 1.522937e-02_rb,1.482768e-02_rb,1.444706e-02_rb,1.408588e-02_rb,1.374270e-02_rb,& + & 1.341619e-02_rb,1.310517e-02_rb,1.280857e-02_rb /) + extice2(:, 18) = (/ & +! band 18 + & 4.152673e-01_rb,2.436816e-01_rb,1.702243e-01_rb,1.299704e-01_rb,1.047528e-01_rb,& + & 8.756039e-02_rb,7.513327e-02_rb,6.575690e-02_rb,5.844616e-02_rb,5.259609e-02_rb,& + & 4.781531e-02_rb,4.383980e-02_rb,4.048517e-02_rb,3.761891e-02_rb,3.514342e-02_rb,& + & 3.298525e-02_rb,3.108814e-02_rb,2.940825e-02_rb,2.791096e-02_rb,2.656858e-02_rb,& + & 2.535869e-02_rb,2.426297e-02_rb,2.326627e-02_rb,2.235602e-02_rb,2.152164e-02_rb,& + & 2.075420e-02_rb,2.004613e-02_rb,1.939091e-02_rb,1.878296e-02_rb,1.821744e-02_rb,& + & 1.769015e-02_rb,1.719741e-02_rb,1.673600e-02_rb,1.630308e-02_rb,1.589615e-02_rb,& + & 1.551298e-02_rb,1.515159e-02_rb,1.481021e-02_rb,1.448726e-02_rb,1.418131e-02_rb,& + & 1.389109e-02_rb,1.361544e-02_rb,1.335330e-02_rb /) + extice2(:, 19) = (/ & +! band 19 + & 3.873250e-01_rb,2.331609e-01_rb,1.655002e-01_rb,1.277753e-01_rb,1.038247e-01_rb,& + & 8.731780e-02_rb,7.527638e-02_rb,6.611873e-02_rb,5.892850e-02_rb,5.313885e-02_rb,& + & 4.838068e-02_rb,4.440356e-02_rb,4.103167e-02_rb,3.813804e-02_rb,3.562870e-02_rb,& + & 3.343269e-02_rb,3.149539e-02_rb,2.977414e-02_rb,2.823510e-02_rb,2.685112e-02_rb,& + & 2.560015e-02_rb,2.446411e-02_rb,2.342805e-02_rb,2.247948e-02_rb,2.160789e-02_rb,& + & 2.080438e-02_rb,2.006139e-02_rb,1.937238e-02_rb,1.873177e-02_rb,1.813469e-02_rb,& + & 1.757689e-02_rb,1.705468e-02_rb,1.656479e-02_rb,1.610435e-02_rb,1.567081e-02_rb,& + & 1.526192e-02_rb,1.487565e-02_rb,1.451020e-02_rb,1.416396e-02_rb,1.383546e-02_rb,& + & 1.352339e-02_rb,1.322657e-02_rb,1.294392e-02_rb /) + extice2(:, 20) = (/ & +! band 20 + & 3.784280e-01_rb,2.291396e-01_rb,1.632551e-01_rb,1.263775e-01_rb,1.028944e-01_rb,& + & 8.666975e-02_rb,7.480952e-02_rb,6.577335e-02_rb,5.866714e-02_rb,5.293694e-02_rb,& + & 4.822153e-02_rb,4.427547e-02_rb,4.092626e-02_rb,3.804918e-02_rb,3.555184e-02_rb,& + & 3.336440e-02_rb,3.143307e-02_rb,2.971577e-02_rb,2.817912e-02_rb,2.679632e-02_rb,& + & 2.554558e-02_rb,2.440903e-02_rb,2.337187e-02_rb,2.242173e-02_rb,2.154821e-02_rb,& + & 2.074249e-02_rb,1.999706e-02_rb,1.930546e-02_rb,1.866212e-02_rb,1.806221e-02_rb,& + & 1.750152e-02_rb,1.697637e-02_rb,1.648352e-02_rb,1.602010e-02_rb,1.558358e-02_rb,& + & 1.517172e-02_rb,1.478250e-02_rb,1.441413e-02_rb,1.406498e-02_rb,1.373362e-02_rb,& + & 1.341872e-02_rb,1.311911e-02_rb,1.283371e-02_rb /) + extice2(:, 21) = (/ & +! band 21 + & 3.719909e-01_rb,2.259490e-01_rb,1.613144e-01_rb,1.250648e-01_rb,1.019462e-01_rb,& + & 8.595358e-02_rb,7.425064e-02_rb,6.532618e-02_rb,5.830218e-02_rb,5.263421e-02_rb,& + & 4.796697e-02_rb,4.405891e-02_rb,4.074013e-02_rb,3.788776e-02_rb,3.541071e-02_rb,& + & 3.324008e-02_rb,3.132280e-02_rb,2.961733e-02_rb,2.809071e-02_rb,2.671645e-02_rb,& + & 2.547302e-02_rb,2.434276e-02_rb,2.331102e-02_rb,2.236558e-02_rb,2.149614e-02_rb,& + & 2.069397e-02_rb,1.995163e-02_rb,1.926272e-02_rb,1.862174e-02_rb,1.802389e-02_rb,& + & 1.746500e-02_rb,1.694142e-02_rb,1.644994e-02_rb,1.598772e-02_rb,1.555225e-02_rb,& + & 1.514129e-02_rb,1.475286e-02_rb,1.438515e-02_rb,1.403659e-02_rb,1.370572e-02_rb,& + & 1.339124e-02_rb,1.309197e-02_rb,1.280685e-02_rb /) + extice2(:, 22) = (/ & +! band 22 + & 3.713158e-01_rb,2.253816e-01_rb,1.608461e-01_rb,1.246718e-01_rb,1.016109e-01_rb,& + & 8.566332e-02_rb,7.399666e-02_rb,6.510199e-02_rb,5.810290e-02_rb,5.245608e-02_rb,& + & 4.780702e-02_rb,4.391478e-02_rb,4.060989e-02_rb,3.776982e-02_rb,3.530374e-02_rb,& + & 3.314296e-02_rb,3.123458e-02_rb,2.953719e-02_rb,2.801794e-02_rb,2.665043e-02_rb,& + & 2.541321e-02_rb,2.428868e-02_rb,2.326224e-02_rb,2.232173e-02_rb,2.145688e-02_rb,& + & 2.065899e-02_rb,1.992067e-02_rb,1.923552e-02_rb,1.859808e-02_rb,1.800356e-02_rb,& + & 1.744782e-02_rb,1.692721e-02_rb,1.643855e-02_rb,1.597900e-02_rb,1.554606e-02_rb,& + & 1.513751e-02_rb,1.475137e-02_rb,1.438586e-02_rb,1.403938e-02_rb,1.371050e-02_rb,& + & 1.339793e-02_rb,1.310050e-02_rb,1.281713e-02_rb /) + extice2(:, 23) = (/ & +! band 23 + & 3.605883e-01_rb,2.204388e-01_rb,1.580431e-01_rb,1.229033e-01_rb,1.004203e-01_rb,& + & 8.482616e-02_rb,7.338941e-02_rb,6.465105e-02_rb,5.776176e-02_rb,5.219398e-02_rb,& + & 4.760288e-02_rb,4.375369e-02_rb,4.048111e-02_rb,3.766539e-02_rb,3.521771e-02_rb,& + & 3.307079e-02_rb,3.117277e-02_rb,2.948303e-02_rb,2.796929e-02_rb,2.660560e-02_rb,& + & 2.537086e-02_rb,2.424772e-02_rb,2.322182e-02_rb,2.228114e-02_rb,2.141556e-02_rb,& + & 2.061649e-02_rb,1.987661e-02_rb,1.918962e-02_rb,1.855009e-02_rb,1.795330e-02_rb,& + & 1.739514e-02_rb,1.687199e-02_rb,1.638069e-02_rb,1.591845e-02_rb,1.548276e-02_rb,& + & 1.507143e-02_rb,1.468249e-02_rb,1.431416e-02_rb,1.396486e-02_rb,1.363318e-02_rb,& + & 1.331781e-02_rb,1.301759e-02_rb,1.273147e-02_rb /) + extice2(:, 24) = (/ & +! band 24 + & 3.527890e-01_rb,2.168469e-01_rb,1.560090e-01_rb,1.216216e-01_rb,9.955787e-02_rb,& + & 8.421942e-02_rb,7.294827e-02_rb,6.432192e-02_rb,5.751081e-02_rb,5.199888e-02_rb,& + & 4.744835e-02_rb,4.362899e-02_rb,4.037847e-02_rb,3.757910e-02_rb,3.514351e-02_rb,& + & 3.300546e-02_rb,3.111382e-02_rb,2.942853e-02_rb,2.791775e-02_rb,2.655584e-02_rb,& + & 2.532195e-02_rb,2.419892e-02_rb,2.317255e-02_rb,2.223092e-02_rb,2.136402e-02_rb,& + & 2.056334e-02_rb,1.982160e-02_rb,1.913258e-02_rb,1.849087e-02_rb,1.789178e-02_rb,& + & 1.733124e-02_rb,1.680565e-02_rb,1.631187e-02_rb,1.584711e-02_rb,1.540889e-02_rb,& + & 1.499502e-02_rb,1.460354e-02_rb,1.423269e-02_rb,1.388088e-02_rb,1.354670e-02_rb,& + & 1.322887e-02_rb,1.292620e-02_rb,1.263767e-02_rb /) + extice2(:, 25) = (/ & +! band 25 + & 3.477874e-01_rb,2.143515e-01_rb,1.544887e-01_rb,1.205942e-01_rb,9.881779e-02_rb,& + & 8.366261e-02_rb,7.251586e-02_rb,6.397790e-02_rb,5.723183e-02_rb,5.176908e-02_rb,& + & 4.725658e-02_rb,4.346715e-02_rb,4.024055e-02_rb,3.746055e-02_rb,3.504080e-02_rb,& + & 3.291583e-02_rb,3.103507e-02_rb,2.935891e-02_rb,2.785582e-02_rb,2.650042e-02_rb,& + & 2.527206e-02_rb,2.415376e-02_rb,2.313142e-02_rb,2.219326e-02_rb,2.132934e-02_rb,& + & 2.053122e-02_rb,1.979169e-02_rb,1.910456e-02_rb,1.846448e-02_rb,1.786680e-02_rb,& + & 1.730745e-02_rb,1.678289e-02_rb,1.628998e-02_rb,1.582595e-02_rb,1.538835e-02_rb,& + & 1.497499e-02_rb,1.458393e-02_rb,1.421341e-02_rb,1.386187e-02_rb,1.352788e-02_rb,& + & 1.321019e-02_rb,1.290762e-02_rb,1.261913e-02_rb /) + extice2(:, 26) = (/ & +! band 26 + & 3.453721e-01_rb,2.130744e-01_rb,1.536698e-01_rb,1.200140e-01_rb,9.838078e-02_rb,& + & 8.331940e-02_rb,7.223803e-02_rb,6.374775e-02_rb,5.703770e-02_rb,5.160290e-02_rb,& + & 4.711259e-02_rb,4.334110e-02_rb,4.012923e-02_rb,3.736150e-02_rb,3.495208e-02_rb,& + & 3.283589e-02_rb,3.096267e-02_rb,2.929302e-02_rb,2.779560e-02_rb,2.644517e-02_rb,& + & 2.522119e-02_rb,2.410677e-02_rb,2.308788e-02_rb,2.215281e-02_rb,2.129165e-02_rb,& + & 2.049602e-02_rb,1.975874e-02_rb,1.907365e-02_rb,1.843542e-02_rb,1.783943e-02_rb,& + & 1.728162e-02_rb,1.675847e-02_rb,1.626685e-02_rb,1.580401e-02_rb,1.536750e-02_rb,& + & 1.495515e-02_rb,1.456502e-02_rb,1.419537e-02_rb,1.384463e-02_rb,1.351139e-02_rb,& + & 1.319438e-02_rb,1.289246e-02_rb,1.260456e-02_rb /) + extice2(:, 27) = (/ & +! band 27 + & 3.417883e-01_rb,2.113379e-01_rb,1.526395e-01_rb,1.193347e-01_rb,9.790253e-02_rb,& + & 8.296715e-02_rb,7.196979e-02_rb,6.353806e-02_rb,5.687024e-02_rb,5.146670e-02_rb,& + & 4.700001e-02_rb,4.324667e-02_rb,4.004894e-02_rb,3.729233e-02_rb,3.489172e-02_rb,& + & 3.278257e-02_rb,3.091499e-02_rb,2.924987e-02_rb,2.775609e-02_rb,2.640859e-02_rb,& + & 2.518695e-02_rb,2.407439e-02_rb,2.305697e-02_rb,2.212303e-02_rb,2.126273e-02_rb,& + & 2.046774e-02_rb,1.973090e-02_rb,1.904610e-02_rb,1.840801e-02_rb,1.781204e-02_rb,& + & 1.725417e-02_rb,1.673086e-02_rb,1.623902e-02_rb,1.577590e-02_rb,1.533906e-02_rb,& + & 1.492634e-02_rb,1.453580e-02_rb,1.416571e-02_rb,1.381450e-02_rb,1.348078e-02_rb,& + & 1.316327e-02_rb,1.286082e-02_rb,1.257240e-02_rb /) + extice2(:, 28) = (/ & +! band 28 + & 3.416111e-01_rb,2.114124e-01_rb,1.527734e-01_rb,1.194809e-01_rb,9.804612e-02_rb,& + & 8.310287e-02_rb,7.209595e-02_rb,6.365442e-02_rb,5.697710e-02_rb,5.156460e-02_rb,& + & 4.708957e-02_rb,4.332850e-02_rb,4.012361e-02_rb,3.736037e-02_rb,3.495364e-02_rb,& + & 3.283879e-02_rb,3.096593e-02_rb,2.929589e-02_rb,2.779751e-02_rb,2.644571e-02_rb,& + & 2.522004e-02_rb,2.410369e-02_rb,2.308271e-02_rb,2.214542e-02_rb,2.128195e-02_rb,& + & 2.048396e-02_rb,1.974429e-02_rb,1.905679e-02_rb,1.841614e-02_rb,1.781774e-02_rb,& + & 1.725754e-02_rb,1.673203e-02_rb,1.623807e-02_rb,1.577293e-02_rb,1.533416e-02_rb,& + & 1.491958e-02_rb,1.452727e-02_rb,1.415547e-02_rb,1.380262e-02_rb,1.346732e-02_rb,& + & 1.314830e-02_rb,1.284439e-02_rb,1.255456e-02_rb /) + extice2(:, 29) = (/ & +! band 29 + & 4.196611e-01_rb,2.493642e-01_rb,1.761261e-01_rb,1.357197e-01_rb,1.102161e-01_rb,& + & 9.269376e-02_rb,7.992985e-02_rb,7.022538e-02_rb,6.260168e-02_rb,5.645603e-02_rb,& + & 5.139732e-02_rb,4.716088e-02_rb,4.356133e-02_rb,4.046498e-02_rb,3.777303e-02_rb,& + & 3.541094e-02_rb,3.332137e-02_rb,3.145954e-02_rb,2.978998e-02_rb,2.828419e-02_rb,& + & 2.691905e-02_rb,2.567559e-02_rb,2.453811e-02_rb,2.349350e-02_rb,2.253072e-02_rb,& + & 2.164042e-02_rb,2.081464e-02_rb,2.004652e-02_rb,1.933015e-02_rb,1.866041e-02_rb,& + & 1.803283e-02_rb,1.744348e-02_rb,1.688894e-02_rb,1.636616e-02_rb,1.587244e-02_rb,& + & 1.540539e-02_rb,1.496287e-02_rb,1.454295e-02_rb,1.414392e-02_rb,1.376423e-02_rb,& + & 1.340247e-02_rb,1.305739e-02_rb,1.272784e-02_rb /) + +! single-scattering albedo: unitless + ssaice2(:, 16) = (/ & +! band 16 + & 6.630615e-01_rb,6.451169e-01_rb,6.333696e-01_rb,6.246927e-01_rb,6.178420e-01_rb,& + & 6.121976e-01_rb,6.074069e-01_rb,6.032505e-01_rb,5.995830e-01_rb,5.963030e-01_rb,& + & 5.933372e-01_rb,5.906311e-01_rb,5.881427e-01_rb,5.858395e-01_rb,5.836955e-01_rb,& + & 5.816896e-01_rb,5.798046e-01_rb,5.780264e-01_rb,5.763429e-01_rb,5.747441e-01_rb,& + & 5.732213e-01_rb,5.717672e-01_rb,5.703754e-01_rb,5.690403e-01_rb,5.677571e-01_rb,& + & 5.665215e-01_rb,5.653297e-01_rb,5.641782e-01_rb,5.630643e-01_rb,5.619850e-01_rb,& + & 5.609381e-01_rb,5.599214e-01_rb,5.589328e-01_rb,5.579707e-01_rb,5.570333e-01_rb,& + & 5.561193e-01_rb,5.552272e-01_rb,5.543558e-01_rb,5.535041e-01_rb,5.526708e-01_rb,& + & 5.518551e-01_rb,5.510561e-01_rb,5.502729e-01_rb /) + ssaice2(:, 17) = (/ & +! band 17 + & 7.689749e-01_rb,7.398171e-01_rb,7.205819e-01_rb,7.065690e-01_rb,6.956928e-01_rb,& + & 6.868989e-01_rb,6.795813e-01_rb,6.733606e-01_rb,6.679838e-01_rb,6.632742e-01_rb,& + & 6.591036e-01_rb,6.553766e-01_rb,6.520197e-01_rb,6.489757e-01_rb,6.461991e-01_rb,& + & 6.436531e-01_rb,6.413075e-01_rb,6.391375e-01_rb,6.371221e-01_rb,6.352438e-01_rb,& + & 6.334876e-01_rb,6.318406e-01_rb,6.302918e-01_rb,6.288315e-01_rb,6.274512e-01_rb,& + & 6.261436e-01_rb,6.249022e-01_rb,6.237211e-01_rb,6.225953e-01_rb,6.215201e-01_rb,& + & 6.204914e-01_rb,6.195055e-01_rb,6.185592e-01_rb,6.176492e-01_rb,6.167730e-01_rb,& + & 6.159280e-01_rb,6.151120e-01_rb,6.143228e-01_rb,6.135587e-01_rb,6.128177e-01_rb,& + & 6.120984e-01_rb,6.113993e-01_rb,6.107189e-01_rb /) + ssaice2(:, 18) = (/ & +! band 18 + & 9.956167e-01_rb,9.814770e-01_rb,9.716104e-01_rb,9.639746e-01_rb,9.577179e-01_rb,& + & 9.524010e-01_rb,9.477672e-01_rb,9.436527e-01_rb,9.399467e-01_rb,9.365708e-01_rb,& + & 9.334672e-01_rb,9.305921e-01_rb,9.279118e-01_rb,9.253993e-01_rb,9.230330e-01_rb,& + & 9.207954e-01_rb,9.186719e-01_rb,9.166501e-01_rb,9.147199e-01_rb,9.128722e-01_rb,& + & 9.110997e-01_rb,9.093956e-01_rb,9.077544e-01_rb,9.061708e-01_rb,9.046406e-01_rb,& + & 9.031598e-01_rb,9.017248e-01_rb,9.003326e-01_rb,8.989804e-01_rb,8.976655e-01_rb,& + & 8.963857e-01_rb,8.951389e-01_rb,8.939233e-01_rb,8.927370e-01_rb,8.915785e-01_rb,& + & 8.904464e-01_rb,8.893392e-01_rb,8.882559e-01_rb,8.871951e-01_rb,8.861559e-01_rb,& + & 8.851373e-01_rb,8.841383e-01_rb,8.831581e-01_rb /) + ssaice2(:, 19) = (/ & +! band 19 + & 9.723177e-01_rb,9.452119e-01_rb,9.267592e-01_rb,9.127393e-01_rb,9.014238e-01_rb,& + & 8.919334e-01_rb,8.837584e-01_rb,8.765773e-01_rb,8.701736e-01_rb,8.643950e-01_rb,& + & 8.591299e-01_rb,8.542942e-01_rb,8.498230e-01_rb,8.456651e-01_rb,8.417794e-01_rb,& + & 8.381324e-01_rb,8.346964e-01_rb,8.314484e-01_rb,8.283687e-01_rb,8.254408e-01_rb,& + & 8.226505e-01_rb,8.199854e-01_rb,8.174348e-01_rb,8.149891e-01_rb,8.126403e-01_rb,& + & 8.103808e-01_rb,8.082041e-01_rb,8.061044e-01_rb,8.040765e-01_rb,8.021156e-01_rb,& + & 8.002174e-01_rb,7.983781e-01_rb,7.965941e-01_rb,7.948622e-01_rb,7.931795e-01_rb,& + & 7.915432e-01_rb,7.899508e-01_rb,7.884002e-01_rb,7.868891e-01_rb,7.854156e-01_rb,& + & 7.839779e-01_rb,7.825742e-01_rb,7.812031e-01_rb /) + ssaice2(:, 20) = (/ & +! band 20 + & 9.933294e-01_rb,9.860917e-01_rb,9.811564e-01_rb,9.774008e-01_rb,9.743652e-01_rb,& + & 9.718155e-01_rb,9.696159e-01_rb,9.676810e-01_rb,9.659531e-01_rb,9.643915e-01_rb,& + & 9.629667e-01_rb,9.616561e-01_rb,9.604426e-01_rb,9.593125e-01_rb,9.582548e-01_rb,& + & 9.572607e-01_rb,9.563227e-01_rb,9.554347e-01_rb,9.545915e-01_rb,9.537888e-01_rb,& + & 9.530226e-01_rb,9.522898e-01_rb,9.515874e-01_rb,9.509130e-01_rb,9.502643e-01_rb,& + & 9.496394e-01_rb,9.490366e-01_rb,9.484542e-01_rb,9.478910e-01_rb,9.473456e-01_rb,& + & 9.468169e-01_rb,9.463039e-01_rb,9.458056e-01_rb,9.453212e-01_rb,9.448499e-01_rb,& + & 9.443910e-01_rb,9.439438e-01_rb,9.435077e-01_rb,9.430821e-01_rb,9.426666e-01_rb,& + & 9.422607e-01_rb,9.418638e-01_rb,9.414756e-01_rb /) + ssaice2(:, 21) = (/ & +! band 21 + & 9.900787e-01_rb,9.828880e-01_rb,9.779258e-01_rb,9.741173e-01_rb,9.710184e-01_rb,& + & 9.684012e-01_rb,9.661332e-01_rb,9.641301e-01_rb,9.623352e-01_rb,9.607083e-01_rb,& + & 9.592198e-01_rb,9.578474e-01_rb,9.565739e-01_rb,9.553856e-01_rb,9.542715e-01_rb,& + & 9.532226e-01_rb,9.522314e-01_rb,9.512919e-01_rb,9.503986e-01_rb,9.495472e-01_rb,& + & 9.487337e-01_rb,9.479549e-01_rb,9.472077e-01_rb,9.464897e-01_rb,9.457985e-01_rb,& + & 9.451322e-01_rb,9.444890e-01_rb,9.438673e-01_rb,9.432656e-01_rb,9.426826e-01_rb,& + & 9.421173e-01_rb,9.415684e-01_rb,9.410351e-01_rb,9.405164e-01_rb,9.400115e-01_rb,& + & 9.395198e-01_rb,9.390404e-01_rb,9.385728e-01_rb,9.381164e-01_rb,9.376707e-01_rb,& + & 9.372350e-01_rb,9.368091e-01_rb,9.363923e-01_rb /) + ssaice2(:, 22) = (/ & +! band 22 + & 9.986793e-01_rb,9.985239e-01_rb,9.983911e-01_rb,9.982715e-01_rb,9.981606e-01_rb,& + & 9.980562e-01_rb,9.979567e-01_rb,9.978613e-01_rb,9.977691e-01_rb,9.976798e-01_rb,& + & 9.975929e-01_rb,9.975081e-01_rb,9.974251e-01_rb,9.973438e-01_rb,9.972640e-01_rb,& + & 9.971855e-01_rb,9.971083e-01_rb,9.970322e-01_rb,9.969571e-01_rb,9.968830e-01_rb,& + & 9.968099e-01_rb,9.967375e-01_rb,9.966660e-01_rb,9.965951e-01_rb,9.965250e-01_rb,& + & 9.964555e-01_rb,9.963867e-01_rb,9.963185e-01_rb,9.962508e-01_rb,9.961836e-01_rb,& + & 9.961170e-01_rb,9.960508e-01_rb,9.959851e-01_rb,9.959198e-01_rb,9.958550e-01_rb,& + & 9.957906e-01_rb,9.957266e-01_rb,9.956629e-01_rb,9.955997e-01_rb,9.955367e-01_rb,& + & 9.954742e-01_rb,9.954119e-01_rb,9.953500e-01_rb /) + ssaice2(:, 23) = (/ & +! band 23 + & 9.997944e-01_rb,9.997791e-01_rb,9.997664e-01_rb,9.997547e-01_rb,9.997436e-01_rb,& + & 9.997327e-01_rb,9.997219e-01_rb,9.997110e-01_rb,9.996999e-01_rb,9.996886e-01_rb,& + & 9.996771e-01_rb,9.996653e-01_rb,9.996533e-01_rb,9.996409e-01_rb,9.996282e-01_rb,& + & 9.996152e-01_rb,9.996019e-01_rb,9.995883e-01_rb,9.995743e-01_rb,9.995599e-01_rb,& + & 9.995453e-01_rb,9.995302e-01_rb,9.995149e-01_rb,9.994992e-01_rb,9.994831e-01_rb,& + & 9.994667e-01_rb,9.994500e-01_rb,9.994329e-01_rb,9.994154e-01_rb,9.993976e-01_rb,& + & 9.993795e-01_rb,9.993610e-01_rb,9.993422e-01_rb,9.993230e-01_rb,9.993035e-01_rb,& + & 9.992837e-01_rb,9.992635e-01_rb,9.992429e-01_rb,9.992221e-01_rb,9.992008e-01_rb,& + & 9.991793e-01_rb,9.991574e-01_rb,9.991352e-01_rb /) + ssaice2(:, 24) = (/ & +! band 24 + & 9.999949e-01_rb,9.999947e-01_rb,9.999943e-01_rb,9.999939e-01_rb,9.999934e-01_rb,& + & 9.999927e-01_rb,9.999920e-01_rb,9.999913e-01_rb,9.999904e-01_rb,9.999895e-01_rb,& + & 9.999885e-01_rb,9.999874e-01_rb,9.999863e-01_rb,9.999851e-01_rb,9.999838e-01_rb,& + & 9.999824e-01_rb,9.999810e-01_rb,9.999795e-01_rb,9.999780e-01_rb,9.999764e-01_rb,& + & 9.999747e-01_rb,9.999729e-01_rb,9.999711e-01_rb,9.999692e-01_rb,9.999673e-01_rb,& + & 9.999653e-01_rb,9.999632e-01_rb,9.999611e-01_rb,9.999589e-01_rb,9.999566e-01_rb,& + & 9.999543e-01_rb,9.999519e-01_rb,9.999495e-01_rb,9.999470e-01_rb,9.999444e-01_rb,& + & 9.999418e-01_rb,9.999392e-01_rb,9.999364e-01_rb,9.999336e-01_rb,9.999308e-01_rb,& + & 9.999279e-01_rb,9.999249e-01_rb,9.999219e-01_rb /) + ssaice2(:, 25) = (/ & +! band 25 + & 9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,& + & 9.999995e-01_rb,9.999994e-01_rb,9.999993e-01_rb,9.999993e-01_rb,9.999992e-01_rb,& + & 9.999991e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,& + & 9.999984e-01_rb,9.999983e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb,& + & 9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999971e-01_rb,9.999969e-01_rb,& + & 9.999966e-01_rb,9.999964e-01_rb,9.999962e-01_rb,9.999960e-01_rb,9.999957e-01_rb,& + & 9.999955e-01_rb,9.999953e-01_rb,9.999950e-01_rb,9.999947e-01_rb,9.999945e-01_rb,& + & 9.999942e-01_rb,9.999939e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999931e-01_rb,& + & 9.999928e-01_rb,9.999925e-01_rb,9.999921e-01_rb /) + ssaice2(:, 26) = (/ & +! band 26 + & 9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,9.999994e-01_rb,& + & 9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,& + & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,& + & 9.999978e-01_rb,9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999970e-01_rb,& + & 9.999967e-01_rb,9.999965e-01_rb,9.999962e-01_rb,9.999959e-01_rb,9.999956e-01_rb,& + & 9.999954e-01_rb,9.999951e-01_rb,9.999947e-01_rb,9.999944e-01_rb,9.999941e-01_rb,& + & 9.999938e-01_rb,9.999934e-01_rb,9.999931e-01_rb,9.999927e-01_rb,9.999923e-01_rb,& + & 9.999920e-01_rb,9.999916e-01_rb,9.999912e-01_rb,9.999908e-01_rb,9.999904e-01_rb,& + & 9.999899e-01_rb,9.999895e-01_rb,9.999891e-01_rb /) + ssaice2(:, 27) = (/ & +! band 27 + & 9.999987e-01_rb,9.999987e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999982e-01_rb,& + & 9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,9.999973e-01_rb,9.999970e-01_rb,& + & 9.999967e-01_rb,9.999964e-01_rb,9.999960e-01_rb,9.999956e-01_rb,9.999952e-01_rb,& + & 9.999948e-01_rb,9.999944e-01_rb,9.999939e-01_rb,9.999934e-01_rb,9.999929e-01_rb,& + & 9.999924e-01_rb,9.999918e-01_rb,9.999913e-01_rb,9.999907e-01_rb,9.999901e-01_rb,& + & 9.999894e-01_rb,9.999888e-01_rb,9.999881e-01_rb,9.999874e-01_rb,9.999867e-01_rb,& + & 9.999860e-01_rb,9.999853e-01_rb,9.999845e-01_rb,9.999837e-01_rb,9.999829e-01_rb,& + & 9.999821e-01_rb,9.999813e-01_rb,9.999804e-01_rb,9.999796e-01_rb,9.999787e-01_rb,& + & 9.999778e-01_rb,9.999768e-01_rb,9.999759e-01_rb /) + ssaice2(:, 28) = (/ & +! band 28 + & 9.999989e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,& + & 9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999975e-01_rb,9.999972e-01_rb,& + & 9.999969e-01_rb,9.999966e-01_rb,9.999962e-01_rb,9.999958e-01_rb,9.999954e-01_rb,& + & 9.999950e-01_rb,9.999945e-01_rb,9.999941e-01_rb,9.999936e-01_rb,9.999931e-01_rb,& + & 9.999925e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,9.999902e-01_rb,& + & 9.999896e-01_rb,9.999889e-01_rb,9.999883e-01_rb,9.999876e-01_rb,9.999869e-01_rb,& + & 9.999861e-01_rb,9.999854e-01_rb,9.999846e-01_rb,9.999838e-01_rb,9.999830e-01_rb,& + & 9.999822e-01_rb,9.999814e-01_rb,9.999805e-01_rb,9.999796e-01_rb,9.999787e-01_rb,& + & 9.999778e-01_rb,9.999769e-01_rb,9.999759e-01_rb /) + ssaice2(:, 29) = (/ & +! band 29 + & 7.042143e-01_rb,6.691161e-01_rb,6.463240e-01_rb,6.296590e-01_rb,6.166381e-01_rb,& + & 6.060183e-01_rb,5.970908e-01_rb,5.894144e-01_rb,5.826968e-01_rb,5.767343e-01_rb,& + & 5.713804e-01_rb,5.665256e-01_rb,5.620867e-01_rb,5.579987e-01_rb,5.542101e-01_rb,& + & 5.506794e-01_rb,5.473727e-01_rb,5.442620e-01_rb,5.413239e-01_rb,5.385389e-01_rb,& + & 5.358901e-01_rb,5.333633e-01_rb,5.309460e-01_rb,5.286277e-01_rb,5.263988e-01_rb,& + & 5.242512e-01_rb,5.221777e-01_rb,5.201719e-01_rb,5.182280e-01_rb,5.163410e-01_rb,& + & 5.145062e-01_rb,5.127197e-01_rb,5.109776e-01_rb,5.092766e-01_rb,5.076137e-01_rb,& + & 5.059860e-01_rb,5.043911e-01_rb,5.028266e-01_rb,5.012904e-01_rb,4.997805e-01_rb,& + & 4.982951e-01_rb,4.968326e-01_rb,4.953913e-01_rb /) + +! asymmetry factor: unitless + asyice2(:, 16) = (/ & +! band 16 + & 7.946655e-01_rb,8.547685e-01_rb,8.806016e-01_rb,8.949880e-01_rb,9.041676e-01_rb,& + & 9.105399e-01_rb,9.152249e-01_rb,9.188160e-01_rb,9.216573e-01_rb,9.239620e-01_rb,& + & 9.258695e-01_rb,9.274745e-01_rb,9.288441e-01_rb,9.300267e-01_rb,9.310584e-01_rb,& + & 9.319665e-01_rb,9.327721e-01_rb,9.334918e-01_rb,9.341387e-01_rb,9.347236e-01_rb,& + & 9.352551e-01_rb,9.357402e-01_rb,9.361850e-01_rb,9.365942e-01_rb,9.369722e-01_rb,& + & 9.373225e-01_rb,9.376481e-01_rb,9.379516e-01_rb,9.382352e-01_rb,9.385010e-01_rb,& + & 9.387505e-01_rb,9.389854e-01_rb,9.392070e-01_rb,9.394163e-01_rb,9.396145e-01_rb,& + & 9.398024e-01_rb,9.399809e-01_rb,9.401508e-01_rb,9.403126e-01_rb,9.404670e-01_rb,& + & 9.406144e-01_rb,9.407555e-01_rb,9.408906e-01_rb /) + asyice2(:, 17) = (/ & +! band 17 + & 9.078091e-01_rb,9.195850e-01_rb,9.267250e-01_rb,9.317083e-01_rb,9.354632e-01_rb,& + & 9.384323e-01_rb,9.408597e-01_rb,9.428935e-01_rb,9.446301e-01_rb,9.461351e-01_rb,& + & 9.474555e-01_rb,9.486259e-01_rb,9.496722e-01_rb,9.506146e-01_rb,9.514688e-01_rb,& + & 9.522476e-01_rb,9.529612e-01_rb,9.536181e-01_rb,9.542251e-01_rb,9.547883e-01_rb,& + & 9.553124e-01_rb,9.558019e-01_rb,9.562601e-01_rb,9.566904e-01_rb,9.570953e-01_rb,& + & 9.574773e-01_rb,9.578385e-01_rb,9.581806e-01_rb,9.585054e-01_rb,9.588142e-01_rb,& + & 9.591083e-01_rb,9.593888e-01_rb,9.596569e-01_rb,9.599135e-01_rb,9.601593e-01_rb,& + & 9.603952e-01_rb,9.606219e-01_rb,9.608399e-01_rb,9.610499e-01_rb,9.612523e-01_rb,& + & 9.614477e-01_rb,9.616365e-01_rb,9.618192e-01_rb /) + asyice2(:, 18) = (/ & +! band 18 + & 8.322045e-01_rb,8.528693e-01_rb,8.648167e-01_rb,8.729163e-01_rb,8.789054e-01_rb,& + & 8.835845e-01_rb,8.873819e-01_rb,8.905511e-01_rb,8.932532e-01_rb,8.955965e-01_rb,& + & 8.976567e-01_rb,8.994887e-01_rb,9.011334e-01_rb,9.026221e-01_rb,9.039791e-01_rb,& + & 9.052237e-01_rb,9.063715e-01_rb,9.074349e-01_rb,9.084245e-01_rb,9.093489e-01_rb,& + & 9.102154e-01_rb,9.110303e-01_rb,9.117987e-01_rb,9.125253e-01_rb,9.132140e-01_rb,& + & 9.138682e-01_rb,9.144910e-01_rb,9.150850e-01_rb,9.156524e-01_rb,9.161955e-01_rb,& + & 9.167160e-01_rb,9.172157e-01_rb,9.176959e-01_rb,9.181581e-01_rb,9.186034e-01_rb,& + & 9.190330e-01_rb,9.194478e-01_rb,9.198488e-01_rb,9.202368e-01_rb,9.206126e-01_rb,& + & 9.209768e-01_rb,9.213301e-01_rb,9.216731e-01_rb /) + asyice2(:, 19) = (/ & +! band 19 + & 8.116560e-01_rb,8.488278e-01_rb,8.674331e-01_rb,8.788148e-01_rb,8.865810e-01_rb,& + & 8.922595e-01_rb,8.966149e-01_rb,9.000747e-01_rb,9.028980e-01_rb,9.052513e-01_rb,& + & 9.072468e-01_rb,9.089632e-01_rb,9.104574e-01_rb,9.117713e-01_rb,9.129371e-01_rb,& + & 9.139793e-01_rb,9.149174e-01_rb,9.157668e-01_rb,9.165400e-01_rb,9.172473e-01_rb,& + & 9.178970e-01_rb,9.184962e-01_rb,9.190508e-01_rb,9.195658e-01_rb,9.200455e-01_rb,& + & 9.204935e-01_rb,9.209130e-01_rb,9.213067e-01_rb,9.216771e-01_rb,9.220262e-01_rb,& + & 9.223560e-01_rb,9.226680e-01_rb,9.229636e-01_rb,9.232443e-01_rb,9.235112e-01_rb,& + & 9.237652e-01_rb,9.240074e-01_rb,9.242385e-01_rb,9.244594e-01_rb,9.246708e-01_rb,& + & 9.248733e-01_rb,9.250674e-01_rb,9.252536e-01_rb /) + asyice2(:, 20) = (/ & +! band 20 + & 8.047113e-01_rb,8.402864e-01_rb,8.570332e-01_rb,8.668455e-01_rb,8.733206e-01_rb,& + & 8.779272e-01_rb,8.813796e-01_rb,8.840676e-01_rb,8.862225e-01_rb,8.879904e-01_rb,& + & 8.894682e-01_rb,8.907228e-01_rb,8.918019e-01_rb,8.927404e-01_rb,8.935645e-01_rb,& + & 8.942943e-01_rb,8.949452e-01_rb,8.955296e-01_rb,8.960574e-01_rb,8.965366e-01_rb,& + & 8.969736e-01_rb,8.973740e-01_rb,8.977422e-01_rb,8.980820e-01_rb,8.983966e-01_rb,& + & 8.986889e-01_rb,8.989611e-01_rb,8.992153e-01_rb,8.994533e-01_rb,8.996766e-01_rb,& + & 8.998865e-01_rb,9.000843e-01_rb,9.002709e-01_rb,9.004474e-01_rb,9.006146e-01_rb,& + & 9.007731e-01_rb,9.009237e-01_rb,9.010670e-01_rb,9.012034e-01_rb,9.013336e-01_rb,& + & 9.014579e-01_rb,9.015767e-01_rb,9.016904e-01_rb /) + asyice2(:, 21) = (/ & +! band 21 + & 8.179122e-01_rb,8.480726e-01_rb,8.621945e-01_rb,8.704354e-01_rb,8.758555e-01_rb,& + & 8.797007e-01_rb,8.825750e-01_rb,8.848078e-01_rb,8.865939e-01_rb,8.880564e-01_rb,& + & 8.892765e-01_rb,8.903105e-01_rb,8.911982e-01_rb,8.919689e-01_rb,8.926446e-01_rb,& + & 8.932419e-01_rb,8.937738e-01_rb,8.942506e-01_rb,8.946806e-01_rb,8.950702e-01_rb,& + & 8.954251e-01_rb,8.957497e-01_rb,8.960477e-01_rb,8.963223e-01_rb,8.965762e-01_rb,& + & 8.968116e-01_rb,8.970306e-01_rb,8.972347e-01_rb,8.974255e-01_rb,8.976042e-01_rb,& + & 8.977720e-01_rb,8.979298e-01_rb,8.980784e-01_rb,8.982188e-01_rb,8.983515e-01_rb,& + & 8.984771e-01_rb,8.985963e-01_rb,8.987095e-01_rb,8.988171e-01_rb,8.989195e-01_rb,& + & 8.990172e-01_rb,8.991104e-01_rb,8.991994e-01_rb /) + asyice2(:, 22) = (/ & +! band 22 + & 8.169789e-01_rb,8.455024e-01_rb,8.586925e-01_rb,8.663283e-01_rb,8.713217e-01_rb,& + & 8.748488e-01_rb,8.774765e-01_rb,8.795122e-01_rb,8.811370e-01_rb,8.824649e-01_rb,& + & 8.835711e-01_rb,8.845073e-01_rb,8.853103e-01_rb,8.860068e-01_rb,8.866170e-01_rb,& + & 8.871560e-01_rb,8.876358e-01_rb,8.880658e-01_rb,8.884533e-01_rb,8.888044e-01_rb,& + & 8.891242e-01_rb,8.894166e-01_rb,8.896851e-01_rb,8.899324e-01_rb,8.901612e-01_rb,& + & 8.903733e-01_rb,8.905706e-01_rb,8.907545e-01_rb,8.909265e-01_rb,8.910876e-01_rb,& + & 8.912388e-01_rb,8.913812e-01_rb,8.915153e-01_rb,8.916419e-01_rb,8.917617e-01_rb,& + & 8.918752e-01_rb,8.919829e-01_rb,8.920851e-01_rb,8.921824e-01_rb,8.922751e-01_rb,& + & 8.923635e-01_rb,8.924478e-01_rb,8.925284e-01_rb /) + asyice2(:, 23) = (/ & +! band 23 + & 8.387642e-01_rb,8.569979e-01_rb,8.658630e-01_rb,8.711825e-01_rb,8.747605e-01_rb,& + & 8.773472e-01_rb,8.793129e-01_rb,8.808621e-01_rb,8.821179e-01_rb,8.831583e-01_rb,& + & 8.840361e-01_rb,8.847875e-01_rb,8.854388e-01_rb,8.860094e-01_rb,8.865138e-01_rb,& + & 8.869634e-01_rb,8.873668e-01_rb,8.877310e-01_rb,8.880617e-01_rb,8.883635e-01_rb,& + & 8.886401e-01_rb,8.888947e-01_rb,8.891298e-01_rb,8.893477e-01_rb,8.895504e-01_rb,& + & 8.897393e-01_rb,8.899159e-01_rb,8.900815e-01_rb,8.902370e-01_rb,8.903833e-01_rb,& + & 8.905214e-01_rb,8.906518e-01_rb,8.907753e-01_rb,8.908924e-01_rb,8.910036e-01_rb,& + & 8.911094e-01_rb,8.912101e-01_rb,8.913062e-01_rb,8.913979e-01_rb,8.914856e-01_rb,& + & 8.915695e-01_rb,8.916498e-01_rb,8.917269e-01_rb /) + asyice2(:, 24) = (/ & +! band 24 + & 8.522208e-01_rb,8.648132e-01_rb,8.711224e-01_rb,8.749901e-01_rb,8.776354e-01_rb,& + & 8.795743e-01_rb,8.810649e-01_rb,8.822518e-01_rb,8.832225e-01_rb,8.840333e-01_rb,& + & 8.847224e-01_rb,8.853162e-01_rb,8.858342e-01_rb,8.862906e-01_rb,8.866962e-01_rb,& + & 8.870595e-01_rb,8.873871e-01_rb,8.876842e-01_rb,8.879551e-01_rb,8.882032e-01_rb,& + & 8.884316e-01_rb,8.886425e-01_rb,8.888380e-01_rb,8.890199e-01_rb,8.891895e-01_rb,& + & 8.893481e-01_rb,8.894968e-01_rb,8.896366e-01_rb,8.897683e-01_rb,8.898926e-01_rb,& + & 8.900102e-01_rb,8.901215e-01_rb,8.902272e-01_rb,8.903276e-01_rb,8.904232e-01_rb,& + & 8.905144e-01_rb,8.906014e-01_rb,8.906845e-01_rb,8.907640e-01_rb,8.908402e-01_rb,& + & 8.909132e-01_rb,8.909834e-01_rb,8.910507e-01_rb /) + asyice2(:, 25) = (/ & +! band 25 + & 8.578202e-01_rb,8.683033e-01_rb,8.735431e-01_rb,8.767488e-01_rb,8.789378e-01_rb,& + & 8.805399e-01_rb,8.817701e-01_rb,8.827485e-01_rb,8.835480e-01_rb,8.842152e-01_rb,& + & 8.847817e-01_rb,8.852696e-01_rb,8.856949e-01_rb,8.860694e-01_rb,8.864020e-01_rb,& + & 8.866997e-01_rb,8.869681e-01_rb,8.872113e-01_rb,8.874330e-01_rb,8.876360e-01_rb,& + & 8.878227e-01_rb,8.879951e-01_rb,8.881548e-01_rb,8.883033e-01_rb,8.884418e-01_rb,& + & 8.885712e-01_rb,8.886926e-01_rb,8.888066e-01_rb,8.889139e-01_rb,8.890152e-01_rb,& + & 8.891110e-01_rb,8.892017e-01_rb,8.892877e-01_rb,8.893695e-01_rb,8.894473e-01_rb,& + & 8.895214e-01_rb,8.895921e-01_rb,8.896597e-01_rb,8.897243e-01_rb,8.897862e-01_rb,& + & 8.898456e-01_rb,8.899025e-01_rb,8.899572e-01_rb /) + asyice2(:, 26) = (/ & +! band 26 + & 8.625615e-01_rb,8.713831e-01_rb,8.755799e-01_rb,8.780560e-01_rb,8.796983e-01_rb,& + & 8.808714e-01_rb,8.817534e-01_rb,8.824420e-01_rb,8.829953e-01_rb,8.834501e-01_rb,& + & 8.838310e-01_rb,8.841549e-01_rb,8.844338e-01_rb,8.846767e-01_rb,8.848902e-01_rb,& + & 8.850795e-01_rb,8.852484e-01_rb,8.854002e-01_rb,8.855374e-01_rb,8.856620e-01_rb,& + & 8.857758e-01_rb,8.858800e-01_rb,8.859759e-01_rb,8.860644e-01_rb,8.861464e-01_rb,& + & 8.862225e-01_rb,8.862935e-01_rb,8.863598e-01_rb,8.864218e-01_rb,8.864800e-01_rb,& + & 8.865347e-01_rb,8.865863e-01_rb,8.866349e-01_rb,8.866809e-01_rb,8.867245e-01_rb,& + & 8.867658e-01_rb,8.868050e-01_rb,8.868423e-01_rb,8.868778e-01_rb,8.869117e-01_rb,& + & 8.869440e-01_rb,8.869749e-01_rb,8.870044e-01_rb /) + asyice2(:, 27) = (/ & +! band 27 + & 8.587495e-01_rb,8.684764e-01_rb,8.728189e-01_rb,8.752872e-01_rb,8.768846e-01_rb,& + & 8.780060e-01_rb,8.788386e-01_rb,8.794824e-01_rb,8.799960e-01_rb,8.804159e-01_rb,& + & 8.807660e-01_rb,8.810626e-01_rb,8.813175e-01_rb,8.815390e-01_rb,8.817335e-01_rb,& + & 8.819057e-01_rb,8.820593e-01_rb,8.821973e-01_rb,8.823220e-01_rb,8.824353e-01_rb,& + & 8.825387e-01_rb,8.826336e-01_rb,8.827209e-01_rb,8.828016e-01_rb,8.828764e-01_rb,& + & 8.829459e-01_rb,8.830108e-01_rb,8.830715e-01_rb,8.831283e-01_rb,8.831817e-01_rb,& + & 8.832320e-01_rb,8.832795e-01_rb,8.833244e-01_rb,8.833668e-01_rb,8.834071e-01_rb,& + & 8.834454e-01_rb,8.834817e-01_rb,8.835164e-01_rb,8.835495e-01_rb,8.835811e-01_rb,& + & 8.836113e-01_rb,8.836402e-01_rb,8.836679e-01_rb /) + asyice2(:, 28) = (/ & +! band 28 + & 8.561110e-01_rb,8.678583e-01_rb,8.727554e-01_rb,8.753892e-01_rb,8.770154e-01_rb,& + & 8.781109e-01_rb,8.788949e-01_rb,8.794812e-01_rb,8.799348e-01_rb,8.802952e-01_rb,& + & 8.805880e-01_rb,8.808300e-01_rb,8.810331e-01_rb,8.812058e-01_rb,8.813543e-01_rb,& + & 8.814832e-01_rb,8.815960e-01_rb,8.816956e-01_rb,8.817839e-01_rb,8.818629e-01_rb,& + & 8.819339e-01_rb,8.819979e-01_rb,8.820560e-01_rb,8.821089e-01_rb,8.821573e-01_rb,& + & 8.822016e-01_rb,8.822425e-01_rb,8.822801e-01_rb,8.823150e-01_rb,8.823474e-01_rb,& + & 8.823775e-01_rb,8.824056e-01_rb,8.824318e-01_rb,8.824564e-01_rb,8.824795e-01_rb,& + & 8.825011e-01_rb,8.825215e-01_rb,8.825408e-01_rb,8.825589e-01_rb,8.825761e-01_rb,& + & 8.825924e-01_rb,8.826078e-01_rb,8.826224e-01_rb /) + asyice2(:, 29) = (/ & +! band 29 + & 8.311124e-01_rb,8.688197e-01_rb,8.900274e-01_rb,9.040696e-01_rb,9.142334e-01_rb,& + & 9.220181e-01_rb,9.282195e-01_rb,9.333048e-01_rb,9.375689e-01_rb,9.412085e-01_rb,& + & 9.443604e-01_rb,9.471230e-01_rb,9.495694e-01_rb,9.517549e-01_rb,9.537224e-01_rb,& + & 9.555057e-01_rb,9.571316e-01_rb,9.586222e-01_rb,9.599952e-01_rb,9.612656e-01_rb,& + & 9.624458e-01_rb,9.635461e-01_rb,9.645756e-01_rb,9.655418e-01_rb,9.664513e-01_rb,& + & 9.673098e-01_rb,9.681222e-01_rb,9.688928e-01_rb,9.696256e-01_rb,9.703237e-01_rb,& + & 9.709903e-01_rb,9.716280e-01_rb,9.722391e-01_rb,9.728258e-01_rb,9.733901e-01_rb,& + & 9.739336e-01_rb,9.744579e-01_rb,9.749645e-01_rb,9.754546e-01_rb,9.759294e-01_rb,& + & 9.763901e-01_rb,9.768376e-01_rb,9.772727e-01_rb /) + +! Hexagonal Ice Particle Parameterization +! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] + extice3(:, 16) = (/ & +! band 16 + & 5.194013e-01_rb,3.215089e-01_rb,2.327917e-01_rb,1.824424e-01_rb,1.499977e-01_rb,& + & 1.273492e-01_rb,1.106421e-01_rb,9.780982e-02_rb,8.764435e-02_rb,7.939266e-02_rb,& + & 7.256081e-02_rb,6.681137e-02_rb,6.190600e-02_rb,5.767154e-02_rb,5.397915e-02_rb,& + & 5.073102e-02_rb,4.785151e-02_rb,4.528125e-02_rb,4.297296e-02_rb,4.088853e-02_rb,& + & 3.899690e-02_rb,3.727251e-02_rb,3.569411e-02_rb,3.424393e-02_rb,3.290694e-02_rb,& + & 3.167040e-02_rb,3.052340e-02_rb,2.945654e-02_rb,2.846172e-02_rb,2.753188e-02_rb,& + & 2.666085e-02_rb,2.584322e-02_rb,2.507423e-02_rb,2.434967e-02_rb,2.366579e-02_rb,& + & 2.301926e-02_rb,2.240711e-02_rb,2.182666e-02_rb,2.127551e-02_rb,2.075150e-02_rb,& + & 2.025267e-02_rb,1.977725e-02_rb,1.932364e-02_rb,1.889035e-02_rb,1.847607e-02_rb,& + & 1.807956e-02_rb /) + extice3(:, 17) = (/ & +! band 17 + & 4.901155e-01_rb,3.065286e-01_rb,2.230800e-01_rb,1.753951e-01_rb,1.445402e-01_rb,& + & 1.229417e-01_rb,1.069777e-01_rb,9.469760e-02_rb,8.495824e-02_rb,7.704501e-02_rb,& + & 7.048834e-02_rb,6.496693e-02_rb,6.025353e-02_rb,5.618286e-02_rb,5.263186e-02_rb,& + & 4.950698e-02_rb,4.673585e-02_rb,4.426164e-02_rb,4.203904e-02_rb,4.003153e-02_rb,& + & 3.820932e-02_rb,3.654790e-02_rb,3.502688e-02_rb,3.362919e-02_rb,3.234041e-02_rb,& + & 3.114829e-02_rb,3.004234e-02_rb,2.901356e-02_rb,2.805413e-02_rb,2.715727e-02_rb,& + & 2.631705e-02_rb,2.552828e-02_rb,2.478637e-02_rb,2.408725e-02_rb,2.342734e-02_rb,& + & 2.280343e-02_rb,2.221264e-02_rb,2.165242e-02_rb,2.112043e-02_rb,2.061461e-02_rb,& + & 2.013308e-02_rb,1.967411e-02_rb,1.923616e-02_rb,1.881783e-02_rb,1.841781e-02_rb,& + & 1.803494e-02_rb /) + extice3(:, 18) = (/ & +! band 18 + & 5.056264e-01_rb,3.160261e-01_rb,2.298442e-01_rb,1.805973e-01_rb,1.487318e-01_rb,& + & 1.264258e-01_rb,1.099389e-01_rb,9.725656e-02_rb,8.719819e-02_rb,7.902576e-02_rb,& + & 7.225433e-02_rb,6.655206e-02_rb,6.168427e-02_rb,5.748028e-02_rb,5.381296e-02_rb,& + & 5.058572e-02_rb,4.772383e-02_rb,4.516857e-02_rb,4.287317e-02_rb,4.079990e-02_rb,& + & 3.891801e-02_rb,3.720217e-02_rb,3.563133e-02_rb,3.418786e-02_rb,3.285686e-02_rb,& + & 3.162569e-02_rb,3.048352e-02_rb,2.942104e-02_rb,2.843018e-02_rb,2.750395e-02_rb,& + & 2.663621e-02_rb,2.582160e-02_rb,2.505539e-02_rb,2.433337e-02_rb,2.365185e-02_rb,& + & 2.300750e-02_rb,2.239736e-02_rb,2.181878e-02_rb,2.126937e-02_rb,2.074699e-02_rb,& + & 2.024968e-02_rb,1.977567e-02_rb,1.932338e-02_rb,1.889134e-02_rb,1.847823e-02_rb,& + & 1.808281e-02_rb /) + extice3(:, 19) = (/ & +! band 19 + & 4.881605e-01_rb,3.055237e-01_rb,2.225070e-01_rb,1.750688e-01_rb,1.443736e-01_rb,& + & 1.228869e-01_rb,1.070054e-01_rb,9.478893e-02_rb,8.509997e-02_rb,7.722769e-02_rb,& + & 7.070495e-02_rb,6.521211e-02_rb,6.052311e-02_rb,5.647351e-02_rb,5.294088e-02_rb,& + & 4.983217e-02_rb,4.707539e-02_rb,4.461398e-02_rb,4.240288e-02_rb,4.040575e-02_rb,& + & 3.859298e-02_rb,3.694016e-02_rb,3.542701e-02_rb,3.403655e-02_rb,3.275444e-02_rb,& + & 3.156849e-02_rb,3.046827e-02_rb,2.944481e-02_rb,2.849034e-02_rb,2.759812e-02_rb,& + & 2.676226e-02_rb,2.597757e-02_rb,2.523949e-02_rb,2.454400e-02_rb,2.388750e-02_rb,& + & 2.326682e-02_rb,2.267909e-02_rb,2.212176e-02_rb,2.159253e-02_rb,2.108933e-02_rb,& + & 2.061028e-02_rb,2.015369e-02_rb,1.971801e-02_rb,1.930184e-02_rb,1.890389e-02_rb,& + & 1.852300e-02_rb /) + extice3(:, 20) = (/ & +! band 20 + & 5.103703e-01_rb,3.188144e-01_rb,2.317435e-01_rb,1.819887e-01_rb,1.497944e-01_rb,& + & 1.272584e-01_rb,1.106013e-01_rb,9.778822e-02_rb,8.762610e-02_rb,7.936938e-02_rb,& + & 7.252809e-02_rb,6.676701e-02_rb,6.184901e-02_rb,5.760165e-02_rb,5.389651e-02_rb,& + & 5.063598e-02_rb,4.774457e-02_rb,4.516295e-02_rb,4.284387e-02_rb,4.074922e-02_rb,& + & 3.884792e-02_rb,3.711438e-02_rb,3.552734e-02_rb,3.406898e-02_rb,3.272425e-02_rb,& + & 3.148038e-02_rb,3.032643e-02_rb,2.925299e-02_rb,2.825191e-02_rb,2.731612e-02_rb,& + & 2.643943e-02_rb,2.561642e-02_rb,2.484230e-02_rb,2.411284e-02_rb,2.342429e-02_rb,& + & 2.277329e-02_rb,2.215686e-02_rb,2.157231e-02_rb,2.101724e-02_rb,2.048946e-02_rb,& + & 1.998702e-02_rb,1.950813e-02_rb,1.905118e-02_rb,1.861468e-02_rb,1.819730e-02_rb,& + & 1.779781e-02_rb /) + extice3(:, 21) = (/ & +! band 21 + & 5.031161e-01_rb,3.144511e-01_rb,2.286942e-01_rb,1.796903e-01_rb,1.479819e-01_rb,& + & 1.257860e-01_rb,1.093803e-01_rb,9.676059e-02_rb,8.675183e-02_rb,7.861971e-02_rb,& + & 7.188168e-02_rb,6.620754e-02_rb,6.136376e-02_rb,5.718050e-02_rb,5.353127e-02_rb,& + & 5.031995e-02_rb,4.747218e-02_rb,4.492952e-02_rb,4.264544e-02_rb,4.058240e-02_rb,& + & 3.870979e-02_rb,3.700242e-02_rb,3.543933e-02_rb,3.400297e-02_rb,3.267854e-02_rb,& + & 3.145345e-02_rb,3.031691e-02_rb,2.925967e-02_rb,2.827370e-02_rb,2.735203e-02_rb,& + & 2.648858e-02_rb,2.567798e-02_rb,2.491555e-02_rb,2.419710e-02_rb,2.351893e-02_rb,& + & 2.287776e-02_rb,2.227063e-02_rb,2.169491e-02_rb,2.114821e-02_rb,2.062840e-02_rb,& + & 2.013354e-02_rb,1.966188e-02_rb,1.921182e-02_rb,1.878191e-02_rb,1.837083e-02_rb,& + & 1.797737e-02_rb /) + extice3(:, 22) = (/ & +! band 22 + & 4.949453e-01_rb,3.095918e-01_rb,2.253402e-01_rb,1.771964e-01_rb,1.460446e-01_rb,& + & 1.242383e-01_rb,1.081206e-01_rb,9.572235e-02_rb,8.588928e-02_rb,7.789990e-02_rb,& + & 7.128013e-02_rb,6.570559e-02_rb,6.094684e-02_rb,5.683701e-02_rb,5.325183e-02_rb,& + & 5.009688e-02_rb,4.729909e-02_rb,4.480106e-02_rb,4.255708e-02_rb,4.053025e-02_rb,& + & 3.869051e-02_rb,3.701310e-02_rb,3.547745e-02_rb,3.406631e-02_rb,3.276512e-02_rb,& + & 3.156153e-02_rb,3.044494e-02_rb,2.940626e-02_rb,2.843759e-02_rb,2.753211e-02_rb,& + & 2.668381e-02_rb,2.588744e-02_rb,2.513839e-02_rb,2.443255e-02_rb,2.376629e-02_rb,& + & 2.313637e-02_rb,2.253990e-02_rb,2.197428e-02_rb,2.143718e-02_rb,2.092649e-02_rb,& + & 2.044032e-02_rb,1.997694e-02_rb,1.953478e-02_rb,1.911241e-02_rb,1.870855e-02_rb,& + & 1.832199e-02_rb /) + extice3(:, 23) = (/ & +! band 23 + & 5.052816e-01_rb,3.157665e-01_rb,2.296233e-01_rb,1.803986e-01_rb,1.485473e-01_rb,& + & 1.262514e-01_rb,1.097718e-01_rb,9.709524e-02_rb,8.704139e-02_rb,7.887264e-02_rb,& + & 7.210424e-02_rb,6.640454e-02_rb,6.153894e-02_rb,5.733683e-02_rb,5.367116e-02_rb,& + & 5.044537e-02_rb,4.758477e-02_rb,4.503066e-02_rb,4.273629e-02_rb,4.066395e-02_rb,& + & 3.878291e-02_rb,3.706784e-02_rb,3.549771e-02_rb,3.405488e-02_rb,3.272448e-02_rb,& + & 3.149387e-02_rb,3.035221e-02_rb,2.929020e-02_rb,2.829979e-02_rb,2.737397e-02_rb,& + & 2.650663e-02_rb,2.569238e-02_rb,2.492651e-02_rb,2.420482e-02_rb,2.352361e-02_rb,& + & 2.287954e-02_rb,2.226968e-02_rb,2.169136e-02_rb,2.114220e-02_rb,2.062005e-02_rb,& + & 2.012296e-02_rb,1.964917e-02_rb,1.919709e-02_rb,1.876524e-02_rb,1.835231e-02_rb,& + & 1.795707e-02_rb /) + extice3(:, 24) = (/ & +! band 24 + & 5.042067e-01_rb,3.151195e-01_rb,2.291708e-01_rb,1.800573e-01_rb,1.482779e-01_rb,& + & 1.260324e-01_rb,1.095900e-01_rb,9.694202e-02_rb,8.691087e-02_rb,7.876056e-02_rb,& + & 7.200745e-02_rb,6.632062e-02_rb,6.146600e-02_rb,5.727338e-02_rb,5.361599e-02_rb,& + & 5.039749e-02_rb,4.754334e-02_rb,4.499500e-02_rb,4.270580e-02_rb,4.063815e-02_rb,& + & 3.876135e-02_rb,3.705016e-02_rb,3.548357e-02_rb,3.404400e-02_rb,3.271661e-02_rb,& + & 3.148877e-02_rb,3.034969e-02_rb,2.929008e-02_rb,2.830191e-02_rb,2.737818e-02_rb,& + & 2.651279e-02_rb,2.570039e-02_rb,2.493624e-02_rb,2.421618e-02_rb,2.353650e-02_rb,& + & 2.289390e-02_rb,2.228541e-02_rb,2.170840e-02_rb,2.116048e-02_rb,2.063950e-02_rb,& + & 2.014354e-02_rb,1.967082e-02_rb,1.921975e-02_rb,1.878888e-02_rb,1.837688e-02_rb,& + & 1.798254e-02_rb /) + extice3(:, 25) = (/ & +! band 25 + & 5.022507e-01_rb,3.139246e-01_rb,2.283218e-01_rb,1.794059e-01_rb,1.477544e-01_rb,& + & 1.255984e-01_rb,1.092222e-01_rb,9.662516e-02_rb,8.663439e-02_rb,7.851688e-02_rb,& + & 7.179095e-02_rb,6.612700e-02_rb,6.129193e-02_rb,5.711618e-02_rb,5.347351e-02_rb,& + & 5.026796e-02_rb,4.742530e-02_rb,4.488721e-02_rb,4.260724e-02_rb,4.054790e-02_rb,& + & 3.867866e-02_rb,3.697435e-02_rb,3.541407e-02_rb,3.398029e-02_rb,3.265824e-02_rb,& + & 3.143535e-02_rb,3.030085e-02_rb,2.924551e-02_rb,2.826131e-02_rb,2.734130e-02_rb,& + & 2.647939e-02_rb,2.567026e-02_rb,2.490919e-02_rb,2.419203e-02_rb,2.351509e-02_rb,& + & 2.287507e-02_rb,2.226903e-02_rb,2.169434e-02_rb,2.114862e-02_rb,2.062975e-02_rb,& + & 2.013578e-02_rb,1.966496e-02_rb,1.921571e-02_rb,1.878658e-02_rb,1.837623e-02_rb,& + & 1.798348e-02_rb /) + extice3(:, 26) = (/ & +! band 26 + & 5.068316e-01_rb,3.166869e-01_rb,2.302576e-01_rb,1.808693e-01_rb,1.489122e-01_rb,& + & 1.265423e-01_rb,1.100080e-01_rb,9.728926e-02_rb,8.720201e-02_rb,7.900612e-02_rb,& + & 7.221524e-02_rb,6.649660e-02_rb,6.161484e-02_rb,5.739877e-02_rb,5.372093e-02_rb,& + & 5.048442e-02_rb,4.761431e-02_rb,4.505172e-02_rb,4.274972e-02_rb,4.067050e-02_rb,& + & 3.878321e-02_rb,3.706244e-02_rb,3.548710e-02_rb,3.403948e-02_rb,3.270466e-02_rb,& + & 3.146995e-02_rb,3.032450e-02_rb,2.925897e-02_rb,2.826527e-02_rb,2.733638e-02_rb,& + & 2.646615e-02_rb,2.564920e-02_rb,2.488078e-02_rb,2.415670e-02_rb,2.347322e-02_rb,& + & 2.282702e-02_rb,2.221513e-02_rb,2.163489e-02_rb,2.108390e-02_rb,2.056002e-02_rb,& + & 2.006128e-02_rb,1.958591e-02_rb,1.913232e-02_rb,1.869904e-02_rb,1.828474e-02_rb,& + & 1.788819e-02_rb /) + extice3(:, 27) = (/ & +! band 27 + & 5.077707e-01_rb,3.172636e-01_rb,2.306695e-01_rb,1.811871e-01_rb,1.491691e-01_rb,& + & 1.267565e-01_rb,1.101907e-01_rb,9.744773e-02_rb,8.734125e-02_rb,7.912973e-02_rb,& + & 7.232591e-02_rb,6.659637e-02_rb,6.170530e-02_rb,5.748120e-02_rb,5.379634e-02_rb,& + & 5.055367e-02_rb,4.767809e-02_rb,4.511061e-02_rb,4.280423e-02_rb,4.072104e-02_rb,& + & 3.883015e-02_rb,3.710611e-02_rb,3.552776e-02_rb,3.407738e-02_rb,3.274002e-02_rb,& + & 3.150296e-02_rb,3.035532e-02_rb,2.928776e-02_rb,2.829216e-02_rb,2.736150e-02_rb,& + & 2.648961e-02_rb,2.567111e-02_rb,2.490123e-02_rb,2.417576e-02_rb,2.349098e-02_rb,& + & 2.284354e-02_rb,2.223049e-02_rb,2.164914e-02_rb,2.109711e-02_rb,2.057222e-02_rb,& + & 2.007253e-02_rb,1.959626e-02_rb,1.914181e-02_rb,1.870770e-02_rb,1.829261e-02_rb,& + & 1.789531e-02_rb /) + extice3(:, 28) = (/ & +! band 28 + & 5.062281e-01_rb,3.163402e-01_rb,2.300275e-01_rb,1.807060e-01_rb,1.487921e-01_rb,& + & 1.264523e-01_rb,1.099403e-01_rb,9.723879e-02_rb,8.716516e-02_rb,7.898034e-02_rb,& + & 7.219863e-02_rb,6.648771e-02_rb,6.161254e-02_rb,5.740217e-02_rb,5.372929e-02_rb,& + & 5.049716e-02_rb,4.763092e-02_rb,4.507179e-02_rb,4.277290e-02_rb,4.069649e-02_rb,& + & 3.881175e-02_rb,3.709331e-02_rb,3.552008e-02_rb,3.407442e-02_rb,3.274141e-02_rb,& + & 3.150837e-02_rb,3.036447e-02_rb,2.930037e-02_rb,2.830801e-02_rb,2.738037e-02_rb,& + & 2.651132e-02_rb,2.569547e-02_rb,2.492810e-02_rb,2.420499e-02_rb,2.352243e-02_rb,& + & 2.287710e-02_rb,2.226604e-02_rb,2.168658e-02_rb,2.113634e-02_rb,2.061316e-02_rb,& + & 2.011510e-02_rb,1.964038e-02_rb,1.918740e-02_rb,1.875471e-02_rb,1.834096e-02_rb,& + & 1.794495e-02_rb /) + extice3(:, 29) = (/ & +! band 29 + & 1.338834e-01_rb,1.924912e-01_rb,1.755523e-01_rb,1.534793e-01_rb,1.343937e-01_rb,& + & 1.187883e-01_rb,1.060654e-01_rb,9.559106e-02_rb,8.685880e-02_rb,7.948698e-02_rb,& + & 7.319086e-02_rb,6.775669e-02_rb,6.302215e-02_rb,5.886236e-02_rb,5.517996e-02_rb,& + & 5.189810e-02_rb,4.895539e-02_rb,4.630225e-02_rb,4.389823e-02_rb,4.171002e-02_rb,& + & 3.970998e-02_rb,3.787493e-02_rb,3.618537e-02_rb,3.462471e-02_rb,3.317880e-02_rb,& + & 3.183547e-02_rb,3.058421e-02_rb,2.941590e-02_rb,2.832256e-02_rb,2.729724e-02_rb,& + & 2.633377e-02_rb,2.542675e-02_rb,2.457136e-02_rb,2.376332e-02_rb,2.299882e-02_rb,& + & 2.227443e-02_rb,2.158707e-02_rb,2.093400e-02_rb,2.031270e-02_rb,1.972091e-02_rb,& + & 1.915659e-02_rb,1.861787e-02_rb,1.810304e-02_rb,1.761055e-02_rb,1.713899e-02_rb,& + & 1.668704e-02_rb /) + +! single-scattering albedo: unitless + ssaice3(:, 16) = (/ & +! band 16 + & 6.749442e-01_rb,6.649947e-01_rb,6.565828e-01_rb,6.489928e-01_rb,6.420046e-01_rb,& + & 6.355231e-01_rb,6.294964e-01_rb,6.238901e-01_rb,6.186783e-01_rb,6.138395e-01_rb,& + & 6.093543e-01_rb,6.052049e-01_rb,6.013742e-01_rb,5.978457e-01_rb,5.946030e-01_rb,& + & 5.916302e-01_rb,5.889115e-01_rb,5.864310e-01_rb,5.841731e-01_rb,5.821221e-01_rb,& + & 5.802624e-01_rb,5.785785e-01_rb,5.770549e-01_rb,5.756759e-01_rb,5.744262e-01_rb,& + & 5.732901e-01_rb,5.722524e-01_rb,5.712974e-01_rb,5.704097e-01_rb,5.695739e-01_rb,& + & 5.687747e-01_rb,5.679964e-01_rb,5.672238e-01_rb,5.664415e-01_rb,5.656340e-01_rb,& + & 5.647860e-01_rb,5.638821e-01_rb,5.629070e-01_rb,5.618452e-01_rb,5.606815e-01_rb,& + & 5.594006e-01_rb,5.579870e-01_rb,5.564255e-01_rb,5.547008e-01_rb,5.527976e-01_rb,& + & 5.507005e-01_rb /) + ssaice3(:, 17) = (/ & +! band 17 + & 7.628550e-01_rb,7.567297e-01_rb,7.508463e-01_rb,7.451972e-01_rb,7.397745e-01_rb,& + & 7.345705e-01_rb,7.295775e-01_rb,7.247881e-01_rb,7.201945e-01_rb,7.157894e-01_rb,& + & 7.115652e-01_rb,7.075145e-01_rb,7.036300e-01_rb,6.999044e-01_rb,6.963304e-01_rb,& + & 6.929007e-01_rb,6.896083e-01_rb,6.864460e-01_rb,6.834067e-01_rb,6.804833e-01_rb,& + & 6.776690e-01_rb,6.749567e-01_rb,6.723397e-01_rb,6.698109e-01_rb,6.673637e-01_rb,& + & 6.649913e-01_rb,6.626870e-01_rb,6.604441e-01_rb,6.582561e-01_rb,6.561163e-01_rb,& + & 6.540182e-01_rb,6.519554e-01_rb,6.499215e-01_rb,6.479099e-01_rb,6.459145e-01_rb,& + & 6.439289e-01_rb,6.419468e-01_rb,6.399621e-01_rb,6.379686e-01_rb,6.359601e-01_rb,& + & 6.339306e-01_rb,6.318740e-01_rb,6.297845e-01_rb,6.276559e-01_rb,6.254825e-01_rb,& + & 6.232583e-01_rb /) + ssaice3(:, 18) = (/ & +! band 18 + & 9.924147e-01_rb,9.882792e-01_rb,9.842257e-01_rb,9.802522e-01_rb,9.763566e-01_rb,& + & 9.725367e-01_rb,9.687905e-01_rb,9.651157e-01_rb,9.615104e-01_rb,9.579725e-01_rb,& + & 9.544997e-01_rb,9.510901e-01_rb,9.477416e-01_rb,9.444520e-01_rb,9.412194e-01_rb,& + & 9.380415e-01_rb,9.349165e-01_rb,9.318421e-01_rb,9.288164e-01_rb,9.258373e-01_rb,& + & 9.229027e-01_rb,9.200106e-01_rb,9.171589e-01_rb,9.143457e-01_rb,9.115688e-01_rb,& + & 9.088263e-01_rb,9.061161e-01_rb,9.034362e-01_rb,9.007846e-01_rb,8.981592e-01_rb,& + & 8.955581e-01_rb,8.929792e-01_rb,8.904206e-01_rb,8.878803e-01_rb,8.853562e-01_rb,& + & 8.828464e-01_rb,8.803488e-01_rb,8.778616e-01_rb,8.753827e-01_rb,8.729102e-01_rb,& + & 8.704421e-01_rb,8.679764e-01_rb,8.655112e-01_rb,8.630445e-01_rb,8.605744e-01_rb,& + & 8.580989e-01_rb /) + ssaice3(:, 19) = (/ & +! band 19 + & 9.629413e-01_rb,9.517182e-01_rb,9.409209e-01_rb,9.305366e-01_rb,9.205529e-01_rb,& + & 9.109569e-01_rb,9.017362e-01_rb,8.928780e-01_rb,8.843699e-01_rb,8.761992e-01_rb,& + & 8.683536e-01_rb,8.608204e-01_rb,8.535873e-01_rb,8.466417e-01_rb,8.399712e-01_rb,& + & 8.335635e-01_rb,8.274062e-01_rb,8.214868e-01_rb,8.157932e-01_rb,8.103129e-01_rb,& + & 8.050336e-01_rb,7.999432e-01_rb,7.950294e-01_rb,7.902798e-01_rb,7.856825e-01_rb,& + & 7.812250e-01_rb,7.768954e-01_rb,7.726815e-01_rb,7.685711e-01_rb,7.645522e-01_rb,& + & 7.606126e-01_rb,7.567404e-01_rb,7.529234e-01_rb,7.491498e-01_rb,7.454074e-01_rb,& + & 7.416844e-01_rb,7.379688e-01_rb,7.342485e-01_rb,7.305118e-01_rb,7.267468e-01_rb,& + & 7.229415e-01_rb,7.190841e-01_rb,7.151628e-01_rb,7.111657e-01_rb,7.070811e-01_rb,& + & 7.028972e-01_rb /) + ssaice3(:, 20) = (/ & +! band 20 + & 9.942270e-01_rb,9.909206e-01_rb,9.876775e-01_rb,9.844960e-01_rb,9.813746e-01_rb,& + & 9.783114e-01_rb,9.753049e-01_rb,9.723535e-01_rb,9.694553e-01_rb,9.666088e-01_rb,& + & 9.638123e-01_rb,9.610641e-01_rb,9.583626e-01_rb,9.557060e-01_rb,9.530928e-01_rb,& + & 9.505211e-01_rb,9.479895e-01_rb,9.454961e-01_rb,9.430393e-01_rb,9.406174e-01_rb,& + & 9.382288e-01_rb,9.358717e-01_rb,9.335446e-01_rb,9.312456e-01_rb,9.289731e-01_rb,& + & 9.267255e-01_rb,9.245010e-01_rb,9.222980e-01_rb,9.201147e-01_rb,9.179496e-01_rb,& + & 9.158008e-01_rb,9.136667e-01_rb,9.115457e-01_rb,9.094359e-01_rb,9.073358e-01_rb,& + & 9.052436e-01_rb,9.031577e-01_rb,9.010763e-01_rb,8.989977e-01_rb,8.969203e-01_rb,& + & 8.948423e-01_rb,8.927620e-01_rb,8.906778e-01_rb,8.885879e-01_rb,8.864907e-01_rb,& + & 8.843843e-01_rb /) + ssaice3(:, 21) = (/ & +! band 21 + & 9.934014e-01_rb,9.899331e-01_rb,9.865537e-01_rb,9.832610e-01_rb,9.800523e-01_rb,& + & 9.769254e-01_rb,9.738777e-01_rb,9.709069e-01_rb,9.680106e-01_rb,9.651862e-01_rb,& + & 9.624315e-01_rb,9.597439e-01_rb,9.571212e-01_rb,9.545608e-01_rb,9.520605e-01_rb,& + & 9.496177e-01_rb,9.472301e-01_rb,9.448954e-01_rb,9.426111e-01_rb,9.403749e-01_rb,& + & 9.381843e-01_rb,9.360370e-01_rb,9.339307e-01_rb,9.318629e-01_rb,9.298313e-01_rb,& + & 9.278336e-01_rb,9.258673e-01_rb,9.239302e-01_rb,9.220198e-01_rb,9.201338e-01_rb,& + & 9.182700e-01_rb,9.164258e-01_rb,9.145991e-01_rb,9.127874e-01_rb,9.109884e-01_rb,& + & 9.091999e-01_rb,9.074194e-01_rb,9.056447e-01_rb,9.038735e-01_rb,9.021033e-01_rb,& + & 9.003320e-01_rb,8.985572e-01_rb,8.967766e-01_rb,8.949879e-01_rb,8.931888e-01_rb,& + & 8.913770e-01_rb /) + ssaice3(:, 22) = (/ & +! band 22 + & 9.994833e-01_rb,9.992055e-01_rb,9.989278e-01_rb,9.986500e-01_rb,9.983724e-01_rb,& + & 9.980947e-01_rb,9.978172e-01_rb,9.975397e-01_rb,9.972623e-01_rb,9.969849e-01_rb,& + & 9.967077e-01_rb,9.964305e-01_rb,9.961535e-01_rb,9.958765e-01_rb,9.955997e-01_rb,& + & 9.953230e-01_rb,9.950464e-01_rb,9.947699e-01_rb,9.944936e-01_rb,9.942174e-01_rb,& + & 9.939414e-01_rb,9.936656e-01_rb,9.933899e-01_rb,9.931144e-01_rb,9.928390e-01_rb,& + & 9.925639e-01_rb,9.922889e-01_rb,9.920141e-01_rb,9.917396e-01_rb,9.914652e-01_rb,& + & 9.911911e-01_rb,9.909171e-01_rb,9.906434e-01_rb,9.903700e-01_rb,9.900967e-01_rb,& + & 9.898237e-01_rb,9.895510e-01_rb,9.892784e-01_rb,9.890062e-01_rb,9.887342e-01_rb,& + & 9.884625e-01_rb,9.881911e-01_rb,9.879199e-01_rb,9.876490e-01_rb,9.873784e-01_rb,& + & 9.871081e-01_rb /) + ssaice3(:, 23) = (/ & +! band 23 + & 9.999343e-01_rb,9.998917e-01_rb,9.998492e-01_rb,9.998067e-01_rb,9.997642e-01_rb,& + & 9.997218e-01_rb,9.996795e-01_rb,9.996372e-01_rb,9.995949e-01_rb,9.995528e-01_rb,& + & 9.995106e-01_rb,9.994686e-01_rb,9.994265e-01_rb,9.993845e-01_rb,9.993426e-01_rb,& + & 9.993007e-01_rb,9.992589e-01_rb,9.992171e-01_rb,9.991754e-01_rb,9.991337e-01_rb,& + & 9.990921e-01_rb,9.990505e-01_rb,9.990089e-01_rb,9.989674e-01_rb,9.989260e-01_rb,& + & 9.988846e-01_rb,9.988432e-01_rb,9.988019e-01_rb,9.987606e-01_rb,9.987194e-01_rb,& + & 9.986782e-01_rb,9.986370e-01_rb,9.985959e-01_rb,9.985549e-01_rb,9.985139e-01_rb,& + & 9.984729e-01_rb,9.984319e-01_rb,9.983910e-01_rb,9.983502e-01_rb,9.983094e-01_rb,& + & 9.982686e-01_rb,9.982279e-01_rb,9.981872e-01_rb,9.981465e-01_rb,9.981059e-01_rb,& + & 9.980653e-01_rb /) + ssaice3(:, 24) = (/ & +! band 24 + & 9.999978e-01_rb,9.999965e-01_rb,9.999952e-01_rb,9.999939e-01_rb,9.999926e-01_rb,& + & 9.999913e-01_rb,9.999900e-01_rb,9.999887e-01_rb,9.999873e-01_rb,9.999860e-01_rb,& + & 9.999847e-01_rb,9.999834e-01_rb,9.999821e-01_rb,9.999808e-01_rb,9.999795e-01_rb,& + & 9.999782e-01_rb,9.999769e-01_rb,9.999756e-01_rb,9.999743e-01_rb,9.999730e-01_rb,& + & 9.999717e-01_rb,9.999704e-01_rb,9.999691e-01_rb,9.999678e-01_rb,9.999665e-01_rb,& + & 9.999652e-01_rb,9.999639e-01_rb,9.999626e-01_rb,9.999613e-01_rb,9.999600e-01_rb,& + & 9.999587e-01_rb,9.999574e-01_rb,9.999561e-01_rb,9.999548e-01_rb,9.999535e-01_rb,& + & 9.999522e-01_rb,9.999509e-01_rb,9.999496e-01_rb,9.999483e-01_rb,9.999470e-01_rb,& + & 9.999457e-01_rb,9.999444e-01_rb,9.999431e-01_rb,9.999418e-01_rb,9.999405e-01_rb,& + & 9.999392e-01_rb /) + ssaice3(:, 25) = (/ & +! band 25 + & 9.999994e-01_rb,9.999993e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,& + & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999982e-01_rb,& + & 9.999980e-01_rb,9.999979e-01_rb,9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,& + & 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999967e-01_rb,& + & 9.999966e-01_rb,9.999965e-01_rb,9.999963e-01_rb,9.999962e-01_rb,9.999960e-01_rb,& + & 9.999959e-01_rb,9.999957e-01_rb,9.999956e-01_rb,9.999954e-01_rb,9.999953e-01_rb,& + & 9.999952e-01_rb,9.999950e-01_rb,9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,& + & 9.999944e-01_rb,9.999943e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb,& + & 9.999937e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999933e-01_rb,9.999931e-01_rb,& + & 9.999930e-01_rb /) + ssaice3(:, 26) = (/ & +! band 26 + & 9.999997e-01_rb,9.999995e-01_rb,9.999992e-01_rb,9.999990e-01_rb,9.999987e-01_rb,& + & 9.999985e-01_rb,9.999983e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,& + & 9.999973e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999967e-01_rb,9.999965e-01_rb,& + & 9.999963e-01_rb,9.999960e-01_rb,9.999958e-01_rb,9.999956e-01_rb,9.999954e-01_rb,& + & 9.999952e-01_rb,9.999950e-01_rb,9.999948e-01_rb,9.999946e-01_rb,9.999944e-01_rb,& + & 9.999942e-01_rb,9.999939e-01_rb,9.999937e-01_rb,9.999935e-01_rb,9.999933e-01_rb,& + & 9.999931e-01_rb,9.999929e-01_rb,9.999927e-01_rb,9.999925e-01_rb,9.999923e-01_rb,& + & 9.999920e-01_rb,9.999918e-01_rb,9.999916e-01_rb,9.999914e-01_rb,9.999911e-01_rb,& + & 9.999909e-01_rb,9.999907e-01_rb,9.999905e-01_rb,9.999902e-01_rb,9.999900e-01_rb,& + & 9.999897e-01_rb /) + ssaice3(:, 27) = (/ & +! band 27 + & 9.999991e-01_rb,9.999985e-01_rb,9.999980e-01_rb,9.999974e-01_rb,9.999968e-01_rb,& + & 9.999963e-01_rb,9.999957e-01_rb,9.999951e-01_rb,9.999946e-01_rb,9.999940e-01_rb,& + & 9.999934e-01_rb,9.999929e-01_rb,9.999923e-01_rb,9.999918e-01_rb,9.999912e-01_rb,& + & 9.999907e-01_rb,9.999901e-01_rb,9.999896e-01_rb,9.999891e-01_rb,9.999885e-01_rb,& + & 9.999880e-01_rb,9.999874e-01_rb,9.999869e-01_rb,9.999863e-01_rb,9.999858e-01_rb,& + & 9.999853e-01_rb,9.999847e-01_rb,9.999842e-01_rb,9.999836e-01_rb,9.999831e-01_rb,& + & 9.999826e-01_rb,9.999820e-01_rb,9.999815e-01_rb,9.999809e-01_rb,9.999804e-01_rb,& + & 9.999798e-01_rb,9.999793e-01_rb,9.999787e-01_rb,9.999782e-01_rb,9.999776e-01_rb,& + & 9.999770e-01_rb,9.999765e-01_rb,9.999759e-01_rb,9.999754e-01_rb,9.999748e-01_rb,& + & 9.999742e-01_rb /) + ssaice3(:, 28) = (/ & +! band 28 + & 9.999975e-01_rb,9.999961e-01_rb,9.999946e-01_rb,9.999931e-01_rb,9.999917e-01_rb,& + & 9.999903e-01_rb,9.999888e-01_rb,9.999874e-01_rb,9.999859e-01_rb,9.999845e-01_rb,& + & 9.999831e-01_rb,9.999816e-01_rb,9.999802e-01_rb,9.999788e-01_rb,9.999774e-01_rb,& + & 9.999759e-01_rb,9.999745e-01_rb,9.999731e-01_rb,9.999717e-01_rb,9.999702e-01_rb,& + & 9.999688e-01_rb,9.999674e-01_rb,9.999660e-01_rb,9.999646e-01_rb,9.999631e-01_rb,& + & 9.999617e-01_rb,9.999603e-01_rb,9.999589e-01_rb,9.999574e-01_rb,9.999560e-01_rb,& + & 9.999546e-01_rb,9.999532e-01_rb,9.999517e-01_rb,9.999503e-01_rb,9.999489e-01_rb,& + & 9.999474e-01_rb,9.999460e-01_rb,9.999446e-01_rb,9.999431e-01_rb,9.999417e-01_rb,& + & 9.999403e-01_rb,9.999388e-01_rb,9.999374e-01_rb,9.999359e-01_rb,9.999345e-01_rb,& + & 9.999330e-01_rb /) + ssaice3(:, 29) = (/ & +! band 29 + & 4.526500e-01_rb,5.287890e-01_rb,5.410487e-01_rb,5.459865e-01_rb,5.485149e-01_rb,& + & 5.498914e-01_rb,5.505895e-01_rb,5.508310e-01_rb,5.507364e-01_rb,5.503793e-01_rb,& + & 5.498090e-01_rb,5.490612e-01_rb,5.481637e-01_rb,5.471395e-01_rb,5.460083e-01_rb,& + & 5.447878e-01_rb,5.434946e-01_rb,5.421442e-01_rb,5.407514e-01_rb,5.393309e-01_rb,& + & 5.378970e-01_rb,5.364641e-01_rb,5.350464e-01_rb,5.336582e-01_rb,5.323140e-01_rb,& + & 5.310283e-01_rb,5.298158e-01_rb,5.286914e-01_rb,5.276704e-01_rb,5.267680e-01_rb,& + & 5.260000e-01_rb,5.253823e-01_rb,5.249311e-01_rb,5.246629e-01_rb,5.245946e-01_rb,& + & 5.247434e-01_rb,5.251268e-01_rb,5.257626e-01_rb,5.266693e-01_rb,5.278653e-01_rb,& + & 5.293698e-01_rb,5.312022e-01_rb,5.333823e-01_rb,5.359305e-01_rb,5.388676e-01_rb,& + & 5.422146e-01_rb /) + +! asymmetry factor: unitless + asyice3(:, 16) = (/ & +! band 16 + & 8.340752e-01_rb,8.435170e-01_rb,8.517487e-01_rb,8.592064e-01_rb,8.660387e-01_rb,& + & 8.723204e-01_rb,8.780997e-01_rb,8.834137e-01_rb,8.882934e-01_rb,8.927662e-01_rb,& + & 8.968577e-01_rb,9.005914e-01_rb,9.039899e-01_rb,9.070745e-01_rb,9.098659e-01_rb,& + & 9.123836e-01_rb,9.146466e-01_rb,9.166734e-01_rb,9.184817e-01_rb,9.200886e-01_rb,& + & 9.215109e-01_rb,9.227648e-01_rb,9.238661e-01_rb,9.248304e-01_rb,9.256727e-01_rb,& + & 9.264078e-01_rb,9.270505e-01_rb,9.276150e-01_rb,9.281156e-01_rb,9.285662e-01_rb,& + & 9.289806e-01_rb,9.293726e-01_rb,9.297557e-01_rb,9.301435e-01_rb,9.305491e-01_rb,& + & 9.309859e-01_rb,9.314671e-01_rb,9.320055e-01_rb,9.326140e-01_rb,9.333053e-01_rb,& + & 9.340919e-01_rb,9.349861e-01_rb,9.360000e-01_rb,9.371451e-01_rb,9.384329e-01_rb,& + & 9.398744e-01_rb /) + asyice3(:, 17) = (/ & +! band 17 + & 8.728160e-01_rb,8.777333e-01_rb,8.823754e-01_rb,8.867535e-01_rb,8.908785e-01_rb,& + & 8.947611e-01_rb,8.984118e-01_rb,9.018408e-01_rb,9.050582e-01_rb,9.080739e-01_rb,& + & 9.108976e-01_rb,9.135388e-01_rb,9.160068e-01_rb,9.183106e-01_rb,9.204595e-01_rb,& + & 9.224620e-01_rb,9.243271e-01_rb,9.260632e-01_rb,9.276788e-01_rb,9.291822e-01_rb,& + & 9.305817e-01_rb,9.318853e-01_rb,9.331012e-01_rb,9.342372e-01_rb,9.353013e-01_rb,& + & 9.363013e-01_rb,9.372450e-01_rb,9.381400e-01_rb,9.389939e-01_rb,9.398145e-01_rb,& + & 9.406092e-01_rb,9.413856e-01_rb,9.421511e-01_rb,9.429131e-01_rb,9.436790e-01_rb,& + & 9.444561e-01_rb,9.452517e-01_rb,9.460729e-01_rb,9.469270e-01_rb,9.478209e-01_rb,& + & 9.487617e-01_rb,9.497562e-01_rb,9.508112e-01_rb,9.519335e-01_rb,9.531294e-01_rb,& + & 9.544055e-01_rb /) + asyice3(:, 18) = (/ & +! band 18 + & 7.897566e-01_rb,7.948704e-01_rb,7.998041e-01_rb,8.045623e-01_rb,8.091495e-01_rb,& + & 8.135702e-01_rb,8.178290e-01_rb,8.219305e-01_rb,8.258790e-01_rb,8.296792e-01_rb,& + & 8.333355e-01_rb,8.368524e-01_rb,8.402343e-01_rb,8.434856e-01_rb,8.466108e-01_rb,& + & 8.496143e-01_rb,8.525004e-01_rb,8.552737e-01_rb,8.579384e-01_rb,8.604990e-01_rb,& + & 8.629597e-01_rb,8.653250e-01_rb,8.675992e-01_rb,8.697867e-01_rb,8.718916e-01_rb,& + & 8.739185e-01_rb,8.758715e-01_rb,8.777551e-01_rb,8.795734e-01_rb,8.813308e-01_rb,& + & 8.830315e-01_rb,8.846799e-01_rb,8.862802e-01_rb,8.878366e-01_rb,8.893534e-01_rb,& + & 8.908350e-01_rb,8.922854e-01_rb,8.937090e-01_rb,8.951099e-01_rb,8.964925e-01_rb,& + & 8.978609e-01_rb,8.992192e-01_rb,9.005718e-01_rb,9.019229e-01_rb,9.032765e-01_rb,& + & 9.046369e-01_rb /) + asyice3(:, 19) = (/ & +! band 19 + & 7.812615e-01_rb,7.887764e-01_rb,7.959664e-01_rb,8.028413e-01_rb,8.094109e-01_rb,& + & 8.156849e-01_rb,8.216730e-01_rb,8.273846e-01_rb,8.328294e-01_rb,8.380166e-01_rb,& + & 8.429556e-01_rb,8.476556e-01_rb,8.521258e-01_rb,8.563753e-01_rb,8.604131e-01_rb,& + & 8.642481e-01_rb,8.678893e-01_rb,8.713455e-01_rb,8.746254e-01_rb,8.777378e-01_rb,& + & 8.806914e-01_rb,8.834948e-01_rb,8.861566e-01_rb,8.886854e-01_rb,8.910897e-01_rb,& + & 8.933779e-01_rb,8.955586e-01_rb,8.976402e-01_rb,8.996311e-01_rb,9.015398e-01_rb,& + & 9.033745e-01_rb,9.051436e-01_rb,9.068555e-01_rb,9.085185e-01_rb,9.101410e-01_rb,& + & 9.117311e-01_rb,9.132972e-01_rb,9.148476e-01_rb,9.163905e-01_rb,9.179340e-01_rb,& + & 9.194864e-01_rb,9.210559e-01_rb,9.226505e-01_rb,9.242784e-01_rb,9.259476e-01_rb,& + & 9.276661e-01_rb /) + asyice3(:, 20) = (/ & +! band 20 + & 7.640720e-01_rb,7.691119e-01_rb,7.739941e-01_rb,7.787222e-01_rb,7.832998e-01_rb,& + & 7.877304e-01_rb,7.920177e-01_rb,7.961652e-01_rb,8.001765e-01_rb,8.040551e-01_rb,& + & 8.078044e-01_rb,8.114280e-01_rb,8.149294e-01_rb,8.183119e-01_rb,8.215791e-01_rb,& + & 8.247344e-01_rb,8.277812e-01_rb,8.307229e-01_rb,8.335629e-01_rb,8.363046e-01_rb,& + & 8.389514e-01_rb,8.415067e-01_rb,8.439738e-01_rb,8.463560e-01_rb,8.486568e-01_rb,& + & 8.508795e-01_rb,8.530274e-01_rb,8.551039e-01_rb,8.571122e-01_rb,8.590558e-01_rb,& + & 8.609378e-01_rb,8.627618e-01_rb,8.645309e-01_rb,8.662485e-01_rb,8.679178e-01_rb,& + & 8.695423e-01_rb,8.711251e-01_rb,8.726697e-01_rb,8.741792e-01_rb,8.756571e-01_rb,& + & 8.771065e-01_rb,8.785307e-01_rb,8.799331e-01_rb,8.813169e-01_rb,8.826854e-01_rb,& + & 8.840419e-01_rb /) + asyice3(:, 21) = (/ & +! band 21 + & 7.602598e-01_rb,7.651572e-01_rb,7.699014e-01_rb,7.744962e-01_rb,7.789452e-01_rb,& + & 7.832522e-01_rb,7.874205e-01_rb,7.914538e-01_rb,7.953555e-01_rb,7.991290e-01_rb,& + & 8.027777e-01_rb,8.063049e-01_rb,8.097140e-01_rb,8.130081e-01_rb,8.161906e-01_rb,& + & 8.192645e-01_rb,8.222331e-01_rb,8.250993e-01_rb,8.278664e-01_rb,8.305374e-01_rb,& + & 8.331153e-01_rb,8.356030e-01_rb,8.380037e-01_rb,8.403201e-01_rb,8.425553e-01_rb,& + & 8.447121e-01_rb,8.467935e-01_rb,8.488022e-01_rb,8.507412e-01_rb,8.526132e-01_rb,& + & 8.544210e-01_rb,8.561675e-01_rb,8.578554e-01_rb,8.594875e-01_rb,8.610665e-01_rb,& + & 8.625951e-01_rb,8.640760e-01_rb,8.655119e-01_rb,8.669055e-01_rb,8.682594e-01_rb,& + & 8.695763e-01_rb,8.708587e-01_rb,8.721094e-01_rb,8.733308e-01_rb,8.745255e-01_rb,& + & 8.756961e-01_rb /) + asyice3(:, 22) = (/ & +! band 22 + & 7.568957e-01_rb,7.606995e-01_rb,7.644072e-01_rb,7.680204e-01_rb,7.715402e-01_rb,& + & 7.749682e-01_rb,7.783057e-01_rb,7.815541e-01_rb,7.847148e-01_rb,7.877892e-01_rb,& + & 7.907786e-01_rb,7.936846e-01_rb,7.965084e-01_rb,7.992515e-01_rb,8.019153e-01_rb,& + & 8.045011e-01_rb,8.070103e-01_rb,8.094444e-01_rb,8.118048e-01_rb,8.140927e-01_rb,& + & 8.163097e-01_rb,8.184571e-01_rb,8.205364e-01_rb,8.225488e-01_rb,8.244958e-01_rb,& + & 8.263789e-01_rb,8.281993e-01_rb,8.299586e-01_rb,8.316580e-01_rb,8.332991e-01_rb,& + & 8.348831e-01_rb,8.364115e-01_rb,8.378857e-01_rb,8.393071e-01_rb,8.406770e-01_rb,& + & 8.419969e-01_rb,8.432682e-01_rb,8.444923e-01_rb,8.456706e-01_rb,8.468044e-01_rb,& + & 8.478952e-01_rb,8.489444e-01_rb,8.499533e-01_rb,8.509234e-01_rb,8.518561e-01_rb,& + & 8.527528e-01_rb /) + asyice3(:, 23) = (/ & +! band 23 + & 7.575066e-01_rb,7.606912e-01_rb,7.638236e-01_rb,7.669035e-01_rb,7.699306e-01_rb,& + & 7.729046e-01_rb,7.758254e-01_rb,7.786926e-01_rb,7.815060e-01_rb,7.842654e-01_rb,& + & 7.869705e-01_rb,7.896211e-01_rb,7.922168e-01_rb,7.947574e-01_rb,7.972428e-01_rb,& + & 7.996726e-01_rb,8.020466e-01_rb,8.043646e-01_rb,8.066262e-01_rb,8.088313e-01_rb,& + & 8.109796e-01_rb,8.130709e-01_rb,8.151049e-01_rb,8.170814e-01_rb,8.190001e-01_rb,& + & 8.208608e-01_rb,8.226632e-01_rb,8.244071e-01_rb,8.260924e-01_rb,8.277186e-01_rb,& + & 8.292856e-01_rb,8.307932e-01_rb,8.322411e-01_rb,8.336291e-01_rb,8.349570e-01_rb,& + & 8.362244e-01_rb,8.374312e-01_rb,8.385772e-01_rb,8.396621e-01_rb,8.406856e-01_rb,& + & 8.416476e-01_rb,8.425479e-01_rb,8.433861e-01_rb,8.441620e-01_rb,8.448755e-01_rb,& + & 8.455263e-01_rb /) + asyice3(:, 24) = (/ & +! band 24 + & 7.568829e-01_rb,7.597947e-01_rb,7.626745e-01_rb,7.655212e-01_rb,7.683337e-01_rb,& + & 7.711111e-01_rb,7.738523e-01_rb,7.765565e-01_rb,7.792225e-01_rb,7.818494e-01_rb,& + & 7.844362e-01_rb,7.869819e-01_rb,7.894854e-01_rb,7.919459e-01_rb,7.943623e-01_rb,& + & 7.967337e-01_rb,7.990590e-01_rb,8.013373e-01_rb,8.035676e-01_rb,8.057488e-01_rb,& + & 8.078802e-01_rb,8.099605e-01_rb,8.119890e-01_rb,8.139645e-01_rb,8.158862e-01_rb,& + & 8.177530e-01_rb,8.195641e-01_rb,8.213183e-01_rb,8.230149e-01_rb,8.246527e-01_rb,& + & 8.262308e-01_rb,8.277483e-01_rb,8.292042e-01_rb,8.305976e-01_rb,8.319275e-01_rb,& + & 8.331929e-01_rb,8.343929e-01_rb,8.355265e-01_rb,8.365928e-01_rb,8.375909e-01_rb,& + & 8.385197e-01_rb,8.393784e-01_rb,8.401659e-01_rb,8.408815e-01_rb,8.415240e-01_rb,& + & 8.420926e-01_rb /) + asyice3(:, 25) = (/ & +! band 25 + & 7.548616e-01_rb,7.575454e-01_rb,7.602153e-01_rb,7.628696e-01_rb,7.655067e-01_rb,& + & 7.681249e-01_rb,7.707225e-01_rb,7.732978e-01_rb,7.758492e-01_rb,7.783750e-01_rb,& + & 7.808735e-01_rb,7.833430e-01_rb,7.857819e-01_rb,7.881886e-01_rb,7.905612e-01_rb,& + & 7.928983e-01_rb,7.951980e-01_rb,7.974588e-01_rb,7.996789e-01_rb,8.018567e-01_rb,& + & 8.039905e-01_rb,8.060787e-01_rb,8.081196e-01_rb,8.101115e-01_rb,8.120527e-01_rb,& + & 8.139416e-01_rb,8.157764e-01_rb,8.175557e-01_rb,8.192776e-01_rb,8.209405e-01_rb,& + & 8.225427e-01_rb,8.240826e-01_rb,8.255585e-01_rb,8.269688e-01_rb,8.283117e-01_rb,& + & 8.295856e-01_rb,8.307889e-01_rb,8.319198e-01_rb,8.329767e-01_rb,8.339579e-01_rb,& + & 8.348619e-01_rb,8.356868e-01_rb,8.364311e-01_rb,8.370930e-01_rb,8.376710e-01_rb,& + & 8.381633e-01_rb /) + asyice3(:, 26) = (/ & +! band 26 + & 7.491854e-01_rb,7.518523e-01_rb,7.545089e-01_rb,7.571534e-01_rb,7.597839e-01_rb,& + & 7.623987e-01_rb,7.649959e-01_rb,7.675737e-01_rb,7.701303e-01_rb,7.726639e-01_rb,& + & 7.751727e-01_rb,7.776548e-01_rb,7.801084e-01_rb,7.825318e-01_rb,7.849230e-01_rb,& + & 7.872804e-01_rb,7.896020e-01_rb,7.918862e-01_rb,7.941309e-01_rb,7.963345e-01_rb,& + & 7.984951e-01_rb,8.006109e-01_rb,8.026802e-01_rb,8.047009e-01_rb,8.066715e-01_rb,& + & 8.085900e-01_rb,8.104546e-01_rb,8.122636e-01_rb,8.140150e-01_rb,8.157072e-01_rb,& + & 8.173382e-01_rb,8.189063e-01_rb,8.204096e-01_rb,8.218464e-01_rb,8.232148e-01_rb,& + & 8.245130e-01_rb,8.257391e-01_rb,8.268915e-01_rb,8.279682e-01_rb,8.289675e-01_rb,& + & 8.298875e-01_rb,8.307264e-01_rb,8.314824e-01_rb,8.321537e-01_rb,8.327385e-01_rb,& + & 8.332350e-01_rb /) + asyice3(:, 27) = (/ & +! band 27 + & 7.397086e-01_rb,7.424069e-01_rb,7.450955e-01_rb,7.477725e-01_rb,7.504362e-01_rb,& + & 7.530846e-01_rb,7.557159e-01_rb,7.583283e-01_rb,7.609199e-01_rb,7.634888e-01_rb,& + & 7.660332e-01_rb,7.685512e-01_rb,7.710411e-01_rb,7.735009e-01_rb,7.759288e-01_rb,& + & 7.783229e-01_rb,7.806814e-01_rb,7.830024e-01_rb,7.852841e-01_rb,7.875246e-01_rb,& + & 7.897221e-01_rb,7.918748e-01_rb,7.939807e-01_rb,7.960380e-01_rb,7.980449e-01_rb,& + & 7.999995e-01_rb,8.019000e-01_rb,8.037445e-01_rb,8.055311e-01_rb,8.072581e-01_rb,& + & 8.089235e-01_rb,8.105255e-01_rb,8.120623e-01_rb,8.135319e-01_rb,8.149326e-01_rb,& + & 8.162626e-01_rb,8.175198e-01_rb,8.187025e-01_rb,8.198089e-01_rb,8.208371e-01_rb,& + & 8.217852e-01_rb,8.226514e-01_rb,8.234338e-01_rb,8.241306e-01_rb,8.247399e-01_rb,& + & 8.252599e-01_rb /) + asyice3(:, 28) = (/ & +! band 28 + & 7.224533e-01_rb,7.251681e-01_rb,7.278728e-01_rb,7.305654e-01_rb,7.332444e-01_rb,& + & 7.359078e-01_rb,7.385539e-01_rb,7.411808e-01_rb,7.437869e-01_rb,7.463702e-01_rb,& + & 7.489291e-01_rb,7.514616e-01_rb,7.539661e-01_rb,7.564408e-01_rb,7.588837e-01_rb,& + & 7.612933e-01_rb,7.636676e-01_rb,7.660049e-01_rb,7.683034e-01_rb,7.705612e-01_rb,& + & 7.727767e-01_rb,7.749480e-01_rb,7.770733e-01_rb,7.791509e-01_rb,7.811789e-01_rb,& + & 7.831556e-01_rb,7.850791e-01_rb,7.869478e-01_rb,7.887597e-01_rb,7.905131e-01_rb,& + & 7.922062e-01_rb,7.938372e-01_rb,7.954044e-01_rb,7.969059e-01_rb,7.983399e-01_rb,& + & 7.997047e-01_rb,8.009985e-01_rb,8.022195e-01_rb,8.033658e-01_rb,8.044357e-01_rb,& + & 8.054275e-01_rb,8.063392e-01_rb,8.071692e-01_rb,8.079157e-01_rb,8.085768e-01_rb,& + & 8.091507e-01_rb /) + asyice3(:, 29) = (/ & +! band 29 + & 8.850026e-01_rb,9.005489e-01_rb,9.069242e-01_rb,9.121799e-01_rb,9.168987e-01_rb,& + & 9.212259e-01_rb,9.252176e-01_rb,9.289028e-01_rb,9.323000e-01_rb,9.354235e-01_rb,& + & 9.382858e-01_rb,9.408985e-01_rb,9.432734e-01_rb,9.454218e-01_rb,9.473557e-01_rb,& + & 9.490871e-01_rb,9.506282e-01_rb,9.519917e-01_rb,9.531904e-01_rb,9.542374e-01_rb,& + & 9.551461e-01_rb,9.559298e-01_rb,9.566023e-01_rb,9.571775e-01_rb,9.576692e-01_rb,& + & 9.580916e-01_rb,9.584589e-01_rb,9.587853e-01_rb,9.590851e-01_rb,9.593729e-01_rb,& + & 9.596632e-01_rb,9.599705e-01_rb,9.603096e-01_rb,9.606954e-01_rb,9.611427e-01_rb,& + & 9.616667e-01_rb,9.622826e-01_rb,9.630060e-01_rb,9.638524e-01_rb,9.648379e-01_rb,& + & 9.659788e-01_rb,9.672916e-01_rb,9.687933e-01_rb,9.705014e-01_rb,9.724337e-01_rb,& + & 9.746084e-01_rb /) + +! fdelta: unitless + fdlice3(:, 16) = (/ & +! band 16 + & 4.959277e-02_rb,4.685292e-02_rb,4.426104e-02_rb,4.181231e-02_rb,3.950191e-02_rb,& + & 3.732500e-02_rb,3.527675e-02_rb,3.335235e-02_rb,3.154697e-02_rb,2.985578e-02_rb,& + & 2.827395e-02_rb,2.679666e-02_rb,2.541909e-02_rb,2.413640e-02_rb,2.294378e-02_rb,& + & 2.183639e-02_rb,2.080940e-02_rb,1.985801e-02_rb,1.897736e-02_rb,1.816265e-02_rb,& + & 1.740905e-02_rb,1.671172e-02_rb,1.606585e-02_rb,1.546661e-02_rb,1.490917e-02_rb,& + & 1.438870e-02_rb,1.390038e-02_rb,1.343939e-02_rb,1.300089e-02_rb,1.258006e-02_rb,& + & 1.217208e-02_rb,1.177212e-02_rb,1.137536e-02_rb,1.097696e-02_rb,1.057210e-02_rb,& + & 1.015596e-02_rb,9.723704e-03_rb,9.270516e-03_rb,8.791565e-03_rb,8.282026e-03_rb,& + & 7.737072e-03_rb,7.151879e-03_rb,6.521619e-03_rb,5.841467e-03_rb,5.106597e-03_rb,& + & 4.312183e-03_rb /) + fdlice3(:, 17) = (/ & +! band 17 + & 5.071224e-02_rb,5.000217e-02_rb,4.933872e-02_rb,4.871992e-02_rb,4.814380e-02_rb,& + & 4.760839e-02_rb,4.711170e-02_rb,4.665177e-02_rb,4.622662e-02_rb,4.583426e-02_rb,& + & 4.547274e-02_rb,4.514007e-02_rb,4.483428e-02_rb,4.455340e-02_rb,4.429544e-02_rb,& + & 4.405844e-02_rb,4.384041e-02_rb,4.363939e-02_rb,4.345340e-02_rb,4.328047e-02_rb,& + & 4.311861e-02_rb,4.296586e-02_rb,4.282024e-02_rb,4.267977e-02_rb,4.254248e-02_rb,& + & 4.240640e-02_rb,4.226955e-02_rb,4.212995e-02_rb,4.198564e-02_rb,4.183462e-02_rb,& + & 4.167494e-02_rb,4.150462e-02_rb,4.132167e-02_rb,4.112413e-02_rb,4.091003e-02_rb,& + & 4.067737e-02_rb,4.042420e-02_rb,4.014854e-02_rb,3.984840e-02_rb,3.952183e-02_rb,& + & 3.916683e-02_rb,3.878144e-02_rb,3.836368e-02_rb,3.791158e-02_rb,3.742316e-02_rb,& + & 3.689645e-02_rb /) + fdlice3(:, 18) = (/ & +! band 18 + & 1.062938e-01_rb,1.065234e-01_rb,1.067822e-01_rb,1.070682e-01_rb,1.073793e-01_rb,& + & 1.077137e-01_rb,1.080693e-01_rb,1.084442e-01_rb,1.088364e-01_rb,1.092439e-01_rb,& + & 1.096647e-01_rb,1.100970e-01_rb,1.105387e-01_rb,1.109878e-01_rb,1.114423e-01_rb,& + & 1.119004e-01_rb,1.123599e-01_rb,1.128190e-01_rb,1.132757e-01_rb,1.137279e-01_rb,& + & 1.141738e-01_rb,1.146113e-01_rb,1.150385e-01_rb,1.154534e-01_rb,1.158540e-01_rb,& + & 1.162383e-01_rb,1.166045e-01_rb,1.169504e-01_rb,1.172741e-01_rb,1.175738e-01_rb,& + & 1.178472e-01_rb,1.180926e-01_rb,1.183080e-01_rb,1.184913e-01_rb,1.186405e-01_rb,& + & 1.187538e-01_rb,1.188291e-01_rb,1.188645e-01_rb,1.188580e-01_rb,1.188076e-01_rb,& + & 1.187113e-01_rb,1.185672e-01_rb,1.183733e-01_rb,1.181277e-01_rb,1.178282e-01_rb,& + & 1.174731e-01_rb /) + fdlice3(:, 19) = (/ & +! band 19 + & 1.076195e-01_rb,1.065195e-01_rb,1.054696e-01_rb,1.044673e-01_rb,1.035099e-01_rb,& + & 1.025951e-01_rb,1.017203e-01_rb,1.008831e-01_rb,1.000808e-01_rb,9.931116e-02_rb,& + & 9.857151e-02_rb,9.785939e-02_rb,9.717230e-02_rb,9.650774e-02_rb,9.586322e-02_rb,& + & 9.523623e-02_rb,9.462427e-02_rb,9.402484e-02_rb,9.343544e-02_rb,9.285358e-02_rb,& + & 9.227675e-02_rb,9.170245e-02_rb,9.112818e-02_rb,9.055144e-02_rb,8.996974e-02_rb,& + & 8.938056e-02_rb,8.878142e-02_rb,8.816981e-02_rb,8.754323e-02_rb,8.689919e-02_rb,& + & 8.623517e-02_rb,8.554869e-02_rb,8.483724e-02_rb,8.409832e-02_rb,8.332943e-02_rb,& + & 8.252807e-02_rb,8.169175e-02_rb,8.081795e-02_rb,7.990419e-02_rb,7.894796e-02_rb,& + & 7.794676e-02_rb,7.689809e-02_rb,7.579945e-02_rb,7.464834e-02_rb,7.344227e-02_rb,& + & 7.217872e-02_rb /) + fdlice3(:, 20) = (/ & +! band 20 + & 1.119014e-01_rb,1.122706e-01_rb,1.126690e-01_rb,1.130947e-01_rb,1.135456e-01_rb,& + & 1.140199e-01_rb,1.145154e-01_rb,1.150302e-01_rb,1.155623e-01_rb,1.161096e-01_rb,& + & 1.166703e-01_rb,1.172422e-01_rb,1.178233e-01_rb,1.184118e-01_rb,1.190055e-01_rb,& + & 1.196025e-01_rb,1.202008e-01_rb,1.207983e-01_rb,1.213931e-01_rb,1.219832e-01_rb,& + & 1.225665e-01_rb,1.231411e-01_rb,1.237050e-01_rb,1.242561e-01_rb,1.247926e-01_rb,& + & 1.253122e-01_rb,1.258132e-01_rb,1.262934e-01_rb,1.267509e-01_rb,1.271836e-01_rb,& + & 1.275896e-01_rb,1.279669e-01_rb,1.283134e-01_rb,1.286272e-01_rb,1.289063e-01_rb,& + & 1.291486e-01_rb,1.293522e-01_rb,1.295150e-01_rb,1.296351e-01_rb,1.297104e-01_rb,& + & 1.297390e-01_rb,1.297189e-01_rb,1.296480e-01_rb,1.295244e-01_rb,1.293460e-01_rb,& + & 1.291109e-01_rb /) + fdlice3(:, 21) = (/ & +! band 21 + & 1.133298e-01_rb,1.136777e-01_rb,1.140556e-01_rb,1.144615e-01_rb,1.148934e-01_rb,& + & 1.153492e-01_rb,1.158269e-01_rb,1.163243e-01_rb,1.168396e-01_rb,1.173706e-01_rb,& + & 1.179152e-01_rb,1.184715e-01_rb,1.190374e-01_rb,1.196108e-01_rb,1.201897e-01_rb,& + & 1.207720e-01_rb,1.213558e-01_rb,1.219389e-01_rb,1.225194e-01_rb,1.230951e-01_rb,& + & 1.236640e-01_rb,1.242241e-01_rb,1.247733e-01_rb,1.253096e-01_rb,1.258309e-01_rb,& + & 1.263352e-01_rb,1.268205e-01_rb,1.272847e-01_rb,1.277257e-01_rb,1.281415e-01_rb,& + & 1.285300e-01_rb,1.288893e-01_rb,1.292173e-01_rb,1.295118e-01_rb,1.297710e-01_rb,& + & 1.299927e-01_rb,1.301748e-01_rb,1.303154e-01_rb,1.304124e-01_rb,1.304637e-01_rb,& + & 1.304673e-01_rb,1.304212e-01_rb,1.303233e-01_rb,1.301715e-01_rb,1.299638e-01_rb,& + & 1.296983e-01_rb /) + fdlice3(:, 22) = (/ & +! band 22 + & 1.145360e-01_rb,1.153256e-01_rb,1.161453e-01_rb,1.169929e-01_rb,1.178666e-01_rb,& + & 1.187641e-01_rb,1.196835e-01_rb,1.206227e-01_rb,1.215796e-01_rb,1.225522e-01_rb,& + & 1.235383e-01_rb,1.245361e-01_rb,1.255433e-01_rb,1.265579e-01_rb,1.275779e-01_rb,& + & 1.286011e-01_rb,1.296257e-01_rb,1.306494e-01_rb,1.316703e-01_rb,1.326862e-01_rb,& + & 1.336951e-01_rb,1.346950e-01_rb,1.356838e-01_rb,1.366594e-01_rb,1.376198e-01_rb,& + & 1.385629e-01_rb,1.394866e-01_rb,1.403889e-01_rb,1.412678e-01_rb,1.421212e-01_rb,& + & 1.429469e-01_rb,1.437430e-01_rb,1.445074e-01_rb,1.452381e-01_rb,1.459329e-01_rb,& + & 1.465899e-01_rb,1.472069e-01_rb,1.477819e-01_rb,1.483128e-01_rb,1.487976e-01_rb,& + & 1.492343e-01_rb,1.496207e-01_rb,1.499548e-01_rb,1.502346e-01_rb,1.504579e-01_rb,& + & 1.506227e-01_rb /) + fdlice3(:, 23) = (/ & +! band 23 + & 1.153263e-01_rb,1.161445e-01_rb,1.169932e-01_rb,1.178703e-01_rb,1.187738e-01_rb,& + & 1.197016e-01_rb,1.206516e-01_rb,1.216217e-01_rb,1.226099e-01_rb,1.236141e-01_rb,& + & 1.246322e-01_rb,1.256621e-01_rb,1.267017e-01_rb,1.277491e-01_rb,1.288020e-01_rb,& + & 1.298584e-01_rb,1.309163e-01_rb,1.319736e-01_rb,1.330281e-01_rb,1.340778e-01_rb,& + & 1.351207e-01_rb,1.361546e-01_rb,1.371775e-01_rb,1.381873e-01_rb,1.391820e-01_rb,& + & 1.401593e-01_rb,1.411174e-01_rb,1.420540e-01_rb,1.429671e-01_rb,1.438547e-01_rb,& + & 1.447146e-01_rb,1.455449e-01_rb,1.463433e-01_rb,1.471078e-01_rb,1.478364e-01_rb,& + & 1.485270e-01_rb,1.491774e-01_rb,1.497857e-01_rb,1.503497e-01_rb,1.508674e-01_rb,& + & 1.513367e-01_rb,1.517554e-01_rb,1.521216e-01_rb,1.524332e-01_rb,1.526880e-01_rb,& + & 1.528840e-01_rb /) + fdlice3(:, 24) = (/ & +! band 24 + & 1.160842e-01_rb,1.169118e-01_rb,1.177697e-01_rb,1.186556e-01_rb,1.195676e-01_rb,& + & 1.205036e-01_rb,1.214616e-01_rb,1.224394e-01_rb,1.234349e-01_rb,1.244463e-01_rb,& + & 1.254712e-01_rb,1.265078e-01_rb,1.275539e-01_rb,1.286075e-01_rb,1.296664e-01_rb,& + & 1.307287e-01_rb,1.317923e-01_rb,1.328550e-01_rb,1.339149e-01_rb,1.349699e-01_rb,& + & 1.360179e-01_rb,1.370567e-01_rb,1.380845e-01_rb,1.390991e-01_rb,1.400984e-01_rb,& + & 1.410803e-01_rb,1.420429e-01_rb,1.429840e-01_rb,1.439016e-01_rb,1.447936e-01_rb,& + & 1.456579e-01_rb,1.464925e-01_rb,1.472953e-01_rb,1.480642e-01_rb,1.487972e-01_rb,& + & 1.494923e-01_rb,1.501472e-01_rb,1.507601e-01_rb,1.513287e-01_rb,1.518511e-01_rb,& + & 1.523252e-01_rb,1.527489e-01_rb,1.531201e-01_rb,1.534368e-01_rb,1.536969e-01_rb,& + & 1.538984e-01_rb /) + fdlice3(:, 25) = (/ & +! band 25 + & 1.168725e-01_rb,1.177088e-01_rb,1.185747e-01_rb,1.194680e-01_rb,1.203867e-01_rb,& + & 1.213288e-01_rb,1.222923e-01_rb,1.232750e-01_rb,1.242750e-01_rb,1.252903e-01_rb,& + & 1.263187e-01_rb,1.273583e-01_rb,1.284069e-01_rb,1.294626e-01_rb,1.305233e-01_rb,& + & 1.315870e-01_rb,1.326517e-01_rb,1.337152e-01_rb,1.347756e-01_rb,1.358308e-01_rb,& + & 1.368788e-01_rb,1.379175e-01_rb,1.389449e-01_rb,1.399590e-01_rb,1.409577e-01_rb,& + & 1.419389e-01_rb,1.429007e-01_rb,1.438410e-01_rb,1.447577e-01_rb,1.456488e-01_rb,& + & 1.465123e-01_rb,1.473461e-01_rb,1.481483e-01_rb,1.489166e-01_rb,1.496492e-01_rb,& + & 1.503439e-01_rb,1.509988e-01_rb,1.516118e-01_rb,1.521808e-01_rb,1.527038e-01_rb,& + & 1.531788e-01_rb,1.536037e-01_rb,1.539764e-01_rb,1.542951e-01_rb,1.545575e-01_rb,& + & 1.547617e-01_rb /) + fdlice3(:, 26) = (/ & +!band 26 + & 1.180509e-01_rb,1.189025e-01_rb,1.197820e-01_rb,1.206875e-01_rb,1.216171e-01_rb,& + & 1.225687e-01_rb,1.235404e-01_rb,1.245303e-01_rb,1.255363e-01_rb,1.265564e-01_rb,& + & 1.275888e-01_rb,1.286313e-01_rb,1.296821e-01_rb,1.307392e-01_rb,1.318006e-01_rb,& + & 1.328643e-01_rb,1.339284e-01_rb,1.349908e-01_rb,1.360497e-01_rb,1.371029e-01_rb,& + & 1.381486e-01_rb,1.391848e-01_rb,1.402095e-01_rb,1.412208e-01_rb,1.422165e-01_rb,& + & 1.431949e-01_rb,1.441539e-01_rb,1.450915e-01_rb,1.460058e-01_rb,1.468947e-01_rb,& + & 1.477564e-01_rb,1.485888e-01_rb,1.493900e-01_rb,1.501580e-01_rb,1.508907e-01_rb,& + & 1.515864e-01_rb,1.522428e-01_rb,1.528582e-01_rb,1.534305e-01_rb,1.539578e-01_rb,& + & 1.544380e-01_rb,1.548692e-01_rb,1.552494e-01_rb,1.555767e-01_rb,1.558490e-01_rb,& + & 1.560645e-01_rb /) + fdlice3(:, 27) = (/ & +! band 27 + & 1.200480e-01_rb,1.209267e-01_rb,1.218304e-01_rb,1.227575e-01_rb,1.237059e-01_rb,& + & 1.246739e-01_rb,1.256595e-01_rb,1.266610e-01_rb,1.276765e-01_rb,1.287041e-01_rb,& + & 1.297420e-01_rb,1.307883e-01_rb,1.318412e-01_rb,1.328988e-01_rb,1.339593e-01_rb,& + & 1.350207e-01_rb,1.360813e-01_rb,1.371393e-01_rb,1.381926e-01_rb,1.392396e-01_rb,& + & 1.402783e-01_rb,1.413069e-01_rb,1.423235e-01_rb,1.433263e-01_rb,1.443134e-01_rb,& + & 1.452830e-01_rb,1.462332e-01_rb,1.471622e-01_rb,1.480681e-01_rb,1.489490e-01_rb,& + & 1.498032e-01_rb,1.506286e-01_rb,1.514236e-01_rb,1.521863e-01_rb,1.529147e-01_rb,& + & 1.536070e-01_rb,1.542614e-01_rb,1.548761e-01_rb,1.554491e-01_rb,1.559787e-01_rb,& + & 1.564629e-01_rb,1.568999e-01_rb,1.572879e-01_rb,1.576249e-01_rb,1.579093e-01_rb,& + & 1.581390e-01_rb /) + fdlice3(:, 28) = (/ & +! band 28 + & 1.247813e-01_rb,1.256496e-01_rb,1.265417e-01_rb,1.274560e-01_rb,1.283905e-01_rb,& + & 1.293436e-01_rb,1.303135e-01_rb,1.312983e-01_rb,1.322964e-01_rb,1.333060e-01_rb,& + & 1.343252e-01_rb,1.353523e-01_rb,1.363855e-01_rb,1.374231e-01_rb,1.384632e-01_rb,& + & 1.395042e-01_rb,1.405441e-01_rb,1.415813e-01_rb,1.426140e-01_rb,1.436404e-01_rb,& + & 1.446587e-01_rb,1.456672e-01_rb,1.466640e-01_rb,1.476475e-01_rb,1.486157e-01_rb,& + & 1.495671e-01_rb,1.504997e-01_rb,1.514117e-01_rb,1.523016e-01_rb,1.531673e-01_rb,& + & 1.540073e-01_rb,1.548197e-01_rb,1.556026e-01_rb,1.563545e-01_rb,1.570734e-01_rb,& + & 1.577576e-01_rb,1.584054e-01_rb,1.590149e-01_rb,1.595843e-01_rb,1.601120e-01_rb,& + & 1.605962e-01_rb,1.610349e-01_rb,1.614266e-01_rb,1.617693e-01_rb,1.620614e-01_rb,& + & 1.623011e-01_rb /) + fdlice3(:, 29) = (/ & +! band 29 + & 1.006055e-01_rb,9.549582e-02_rb,9.063960e-02_rb,8.602900e-02_rb,8.165612e-02_rb,& + & 7.751308e-02_rb,7.359199e-02_rb,6.988496e-02_rb,6.638412e-02_rb,6.308156e-02_rb,& + & 5.996942e-02_rb,5.703979e-02_rb,5.428481e-02_rb,5.169657e-02_rb,4.926719e-02_rb,& + & 4.698880e-02_rb,4.485349e-02_rb,4.285339e-02_rb,4.098061e-02_rb,3.922727e-02_rb,& + & 3.758547e-02_rb,3.604733e-02_rb,3.460497e-02_rb,3.325051e-02_rb,3.197604e-02_rb,& + & 3.077369e-02_rb,2.963558e-02_rb,2.855381e-02_rb,2.752050e-02_rb,2.652776e-02_rb,& + & 2.556772e-02_rb,2.463247e-02_rb,2.371415e-02_rb,2.280485e-02_rb,2.189670e-02_rb,& + & 2.098180e-02_rb,2.005228e-02_rb,1.910024e-02_rb,1.811781e-02_rb,1.709709e-02_rb,& + & 1.603020e-02_rb,1.490925e-02_rb,1.372635e-02_rb,1.247363e-02_rb,1.114319e-02_rb,& + & 9.727157e-03_rb /) + + end subroutine swcldpr + + end module rrtmg_sw_init + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module rrtmg_sw_vrtqdr + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only: im => kind_im, rb => kind_rb +! use parrrsw, only: ngptsw + + implicit none + + contains + +! -------------------------------------------------------------------------- + subroutine vrtqdr_sw(klev, kw, & + pref, prefd, ptra, ptrad, & + pdbt, prdnd, prup, prupd, ptdbt, & + pfd, pfu) +! -------------------------------------------------------------------------- + +! Purpose: This routine performs the vertical quadrature integration +! +! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw* +! +! Modifications. +! +! Original: H. Barker +! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002 +! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006 +! +!----------------------------------------------------------------------- + +! ------- Declarations ------- + +! Input + + integer(kind=im), intent (in) :: klev ! number of model layers + integer(kind=im), intent (in) :: kw ! g-point index + + real(kind=rb), intent(in) :: pref(:) ! direct beam reflectivity + ! Dimensions: (nlayers+1) + real(kind=rb), intent(in) :: prefd(:) ! diffuse beam reflectivity + ! Dimensions: (nlayers+1) + real(kind=rb), intent(in) :: ptra(:) ! direct beam transmissivity + ! Dimensions: (nlayers+1) + real(kind=rb), intent(in) :: ptrad(:) ! diffuse beam transmissivity + ! Dimensions: (nlayers+1) + + real(kind=rb), intent(in) :: pdbt(:) + ! Dimensions: (nlayers+1) + real(kind=rb), intent(in) :: ptdbt(:) + ! Dimensions: (nlayers+1) + + real(kind=rb), intent(inout) :: prdnd(:) + ! Dimensions: (nlayers+1) + real(kind=rb), intent(inout) :: prup(:) + ! Dimensions: (nlayers+1) + real(kind=rb), intent(inout) :: prupd(:) + ! Dimensions: (nlayers+1) + +! Output + real(kind=rb), intent(out) :: pfd(:,:) ! downwelling flux (W/m2) + ! Dimensions: (nlayers+1,ngptsw) + ! unadjusted for earth/sun distance or zenith angle + real(kind=rb), intent(out) :: pfu(:,:) ! upwelling flux (W/m2) + ! Dimensions: (nlayers+1,ngptsw) + ! unadjusted for earth/sun distance or zenith angle + +! Local + + integer(kind=im) :: ikp, ikx, jk + + real(kind=rb) :: zreflect + real(kind=rb) :: ztdn(klev+1) + +! Definitions +! +! pref(jk) direct reflectance +! prefd(jk) diffuse reflectance +! ptra(jk) direct transmittance +! ptrad(jk) diffuse transmittance +! +! pdbt(jk) layer mean direct beam transmittance +! ptdbt(jk) total direct beam transmittance at levels +! +!----------------------------------------------------------------------------- + +! Link lowest layer with surface + + zreflect = 1._rb / (1._rb - prefd(klev+1) * prefd(klev)) + prup(klev) = pref(klev) + (ptrad(klev) * & + ((ptra(klev) - pdbt(klev)) * prefd(klev+1) + & + pdbt(klev) * pref(klev+1))) * zreflect + prupd(klev) = prefd(klev) + ptrad(klev) * ptrad(klev) * & + prefd(klev+1) * zreflect + +! Pass from bottom to top + + do jk = 1,klev-1 + ikp = klev+1-jk + ikx = ikp-1 + zreflect = 1._rb / (1._rb -prupd(ikp) * prefd(ikx)) + prup(ikx) = pref(ikx) + (ptrad(ikx) * & + ((ptra(ikx) - pdbt(ikx)) * prupd(ikp) + & + pdbt(ikx) * prup(ikp))) * zreflect + prupd(ikx) = prefd(ikx) + ptrad(ikx) * ptrad(ikx) * & + prupd(ikp) * zreflect + enddo + +! Upper boundary conditions + + ztdn(1) = 1._rb + prdnd(1) = 0._rb + ztdn(2) = ptra(1) + prdnd(2) = prefd(1) + +! Pass from top to bottom + + do jk = 2,klev + ikp = jk+1 + zreflect = 1._rb / (1._rb - prefd(jk) * prdnd(jk)) + ztdn(ikp) = ptdbt(jk) * ptra(jk) + & + (ptrad(jk) * ((ztdn(jk) - ptdbt(jk)) + & + ptdbt(jk) * pref(jk) * prdnd(jk))) * zreflect + prdnd(ikp) = prefd(jk) + ptrad(jk) * ptrad(jk) * & + prdnd(jk) * zreflect + enddo + +! Up and down-welling fluxes at levels + + do jk = 1,klev+1 + zreflect = 1._rb / (1._rb - prdnd(jk) * prupd(jk)) + pfu(jk,kw) = (ptdbt(jk) * prup(jk) + & + (ztdn(jk) - ptdbt(jk)) * prupd(jk)) * zreflect + pfd(jk,kw) = ptdbt(jk) + (ztdn(jk) - ptdbt(jk)+ & + ptdbt(jk) * prup(jk) * prdnd(jk)) * zreflect + enddo + + end subroutine vrtqdr_sw + + end module rrtmg_sw_vrtqdr + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ + + module rrtmg_sw_spcvmc + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + + use parkind, only : im => kind_im, rb => kind_rb + use parrrsw, only : nbndsw, ngptsw, mxmol, jpband + use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl + use rrsw_vsn, only : hvrspc, hnamspc + use rrsw_wvn, only : ngc, ngs + use rrtmg_sw_reftra, only: reftra_sw + use rrtmg_sw_taumol, only: taumol_sw + use rrtmg_sw_vrtqdr, only: vrtqdr_sw + + implicit none + + contains + +! --------------------------------------------------------------------------- + subroutine spcvmc_sw & + (nlayers, istart, iend, icpr, iout, & + pavel, tavel, pz, tz, tbound, palbd, palbp, & + pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, & + ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, & + pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir) +! --------------------------------------------------------------------------- +! +! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, +! using the two-stream method of H. Barker and McICA, the Monte-Carlo +! Independent Column Approximation, for the representation of +! sub-grid cloud variability (i.e. cloud overlap). +! +! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90* +! +! Method: +! Adapted from two-stream model of H. Barker; +! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90): +! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates +! +! Modifications: +! +! Original: H. Barker +! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003 +! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003 +! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003 +! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004 +! Revision: Code modified so that delta scaling is not done in cloudy profiles +! if routine cldprop is used; delta scaling can be applied by swithcing +! code below if cldprop is not used to get cloud properties. +! AER, Jan 2005 +! Revision: Modified to use McICA: MJIacono, AER, Nov 2005 +! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 +! Revision: Use exponential lookup table for transmittance: MJIacono, AER, +! Aug 2007 +! +! ------------------------------------------------------------------ + +! ------- Declarations ------ + +! ------- Input ------- + + integer(kind=im), intent(in) :: nlayers + integer(kind=im), intent(in) :: istart + integer(kind=im), intent(in) :: iend + integer(kind=im), intent(in) :: icpr + integer(kind=im), intent(in) :: iout + integer(kind=im), intent(in) :: laytrop + integer(kind=im), intent(in) :: layswtch + integer(kind=im), intent(in) :: laylow + + integer(kind=im), intent(in) :: indfor(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: indself(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: jp(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: jt(:) + ! Dimensions: (nlayers) + integer(kind=im), intent(in) :: jt1(:) + ! Dimensions: (nlayers) + + real(kind=rb), intent(in) :: pavel(:) ! layer pressure (hPa, mb) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: tavel(:) ! layer temperature (K) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressure (hPa, mb) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: tz(0:) ! level temperatures (hPa, mb) + ! Dimensions: (0:nlayers) + real(kind=rb), intent(in) :: tbound ! surface temperature (K) + real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm2) + ! Dimensions: (mxmol,nlayers) + real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colmol(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: adjflux(:) ! Earth/Sun distance adjustment + ! Dimensions: (jpband) + + real(kind=rb), intent(in) :: palbd(:) ! surface albedo (diffuse) + ! Dimensions: (nbndsw) + real(kind=rb), intent(in) :: palbp(:) ! surface albedo (direct) + ! Dimensions: (nbndsw) + real(kind=rb), intent(in) :: prmu0 ! cosine of solar zenith angle + real(kind=rb), intent(in) :: pcldfmc(:,:) ! cloud fraction [mcica] + ! Dimensions: (nlayers,ngptsw) + real(kind=rb), intent(in) :: ptaucmc(:,:) ! cloud optical depth [mcica] + ! Dimensions: (nlayers,ngptsw) + real(kind=rb), intent(in) :: pasycmc(:,:) ! cloud asymmetry parameter [mcica] + ! Dimensions: (nlayers,ngptsw) + real(kind=rb), intent(in) :: pomgcmc(:,:) ! cloud single scattering albedo [mcica] + ! Dimensions: (nlayers,ngptsw) + real(kind=rb), intent(in) :: ptaormc(:,:) ! cloud optical depth, non-delta scaled [mcica] + ! Dimensions: (nlayers,ngptsw) + real(kind=rb), intent(in) :: ptaua(:,:) ! aerosol optical depth + ! Dimensions: (nlayers,nbndsw) + real(kind=rb), intent(in) :: pasya(:,:) ! aerosol asymmetry parameter + ! Dimensions: (nlayers,nbndsw) + real(kind=rb), intent(in) :: pomga(:,:) ! aerosol single scattering albedo + ! Dimensions: (nlayers,nbndsw) + + real(kind=rb), intent(in) :: colh2o(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colco2(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colch4(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: co2mult(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colo3(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: colo2(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: coln2o(:) + ! Dimensions: (nlayers) + + real(kind=rb), intent(in) :: forfac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: forfrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: selffac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: selffrac(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: fac00(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: fac01(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: fac10(:) + ! Dimensions: (nlayers) + real(kind=rb), intent(in) :: fac11(:) + ! Dimensions: (nlayers) + +! ------- Output ------- + ! All Dimensions: (nlayers+1) + real(kind=rb), intent(out) :: pbbcd(:) + real(kind=rb), intent(out) :: pbbcu(:) + real(kind=rb), intent(out) :: pbbfd(:) + real(kind=rb), intent(out) :: pbbfu(:) + real(kind=rb), intent(out) :: pbbfddir(:) + real(kind=rb), intent(out) :: pbbcddir(:) + + real(kind=rb), intent(out) :: puvcd(:) + real(kind=rb), intent(out) :: puvfd(:) + real(kind=rb), intent(out) :: puvcddir(:) + real(kind=rb), intent(out) :: puvfddir(:) + + real(kind=rb), intent(out) :: pnicd(:) + real(kind=rb), intent(out) :: pnifd(:) + real(kind=rb), intent(out) :: pnicddir(:) + real(kind=rb), intent(out) :: pnifddir(:) + +! Output - inactive ! All Dimensions: (nlayers+1) +! real(kind=rb), intent(out) :: puvcu(:) +! real(kind=rb), intent(out) :: puvfu(:) +! real(kind=rb), intent(out) :: pnicu(:) +! real(kind=rb), intent(out) :: pnifu(:) +! real(kind=rb), intent(out) :: pvscd(:) +! real(kind=rb), intent(out) :: pvscu(:) +! real(kind=rb), intent(out) :: pvsfd(:) +! real(kind=rb), intent(out) :: pvsfu(:) + +! ------- Local ------- + + logical :: lrtchkclr(nlayers),lrtchkcld(nlayers) + + integer(kind=im) :: klev + integer(kind=im) :: ib1, ib2, ibm, igt, ikl, ikp, ikx + integer(kind=im) :: iw, jb, jg, jl, jk +! integer(kind=im), parameter :: nuv = ?? +! integer(kind=im), parameter :: nvs = ?? + integer(kind=im) :: itind + + real(kind=rb) :: tblind, ze1 + real(kind=rb) :: zclear, zcloud + real(kind=rb) :: zdbt(nlayers+1), zdbt_nodel(nlayers+1) + real(kind=rb) :: zgc(nlayers), zgcc(nlayers), zgco(nlayers) + real(kind=rb) :: zomc(nlayers), zomcc(nlayers), zomco(nlayers) + real(kind=rb) :: zrdnd(nlayers+1), zrdndc(nlayers+1) + real(kind=rb) :: zref(nlayers+1), zrefc(nlayers+1), zrefo(nlayers+1) + real(kind=rb) :: zrefd(nlayers+1), zrefdc(nlayers+1), zrefdo(nlayers+1) + real(kind=rb) :: zrup(nlayers+1), zrupd(nlayers+1) + real(kind=rb) :: zrupc(nlayers+1), zrupdc(nlayers+1) + real(kind=rb) :: zs1(nlayers+1) + real(kind=rb) :: ztauc(nlayers), ztauo(nlayers) + real(kind=rb) :: ztdn(nlayers+1), ztdnd(nlayers+1), ztdbt(nlayers+1) + real(kind=rb) :: ztoc(nlayers), ztor(nlayers) + real(kind=rb) :: ztra(nlayers+1), ztrac(nlayers+1), ztrao(nlayers+1) + real(kind=rb) :: ztrad(nlayers+1), ztradc(nlayers+1), ztrado(nlayers+1) + real(kind=rb) :: zdbtc(nlayers+1), ztdbtc(nlayers+1) + real(kind=rb) :: zincflx(ngptsw), zdbtc_nodel(nlayers+1) + real(kind=rb) :: ztdbt_nodel(nlayers+1), ztdbtc_nodel(nlayers+1) + + real(kind=rb) :: zdbtmc, zdbtmo, zf, zgw, zreflect + real(kind=rb) :: zwf, tauorig, repclc +! real(kind=rb) :: zincflux ! inactive + +! Arrays from rrtmg_sw_taumoln routines + +! real(kind=rb) :: ztaug(nlayers,16), ztaur(nlayers,16) +! real(kind=rb) :: zsflxzen(16) + real(kind=rb) :: ztaug(nlayers,ngptsw), ztaur(nlayers,ngptsw) + real(kind=rb) :: zsflxzen(ngptsw) + +! Arrays from rrtmg_sw_vrtqdr routine + + real(kind=rb) :: zcd(nlayers+1,ngptsw), zcu(nlayers+1,ngptsw) + real(kind=rb) :: zfd(nlayers+1,ngptsw), zfu(nlayers+1,ngptsw) + +! Inactive arrays +! real(kind=rb) :: zbbcd(nlayers+1), zbbcu(nlayers+1) +! real(kind=rb) :: zbbfd(nlayers+1), zbbfu(nlayers+1) +! real(kind=rb) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1) + +! ------------------------------------------------------------------ + +! Initializations + + ib1 = istart + ib2 = iend + klev = nlayers + iw = 0 + repclc = 1.e-12_rb +! zincflux = 0.0_rb + + do jk=1,klev+1 + pbbcd(jk)=0._rb + pbbcu(jk)=0._rb + pbbfd(jk)=0._rb + pbbfu(jk)=0._rb + pbbcddir(jk)=0._rb + pbbfddir(jk)=0._rb + puvcd(jk)=0._rb + puvfd(jk)=0._rb + puvcddir(jk)=0._rb + puvfddir(jk)=0._rb + pnicd(jk)=0._rb + pnifd(jk)=0._rb + pnicddir(jk)=0._rb + pnifddir(jk)=0._rb + enddo + + zsflxzen = 0._rb + ztaug = 0._rb + ztaur = 0._rb + + ! Calculate the optical depths for gaseous absorption and Rayleigh scattering + call taumol_sw(klev, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + zsflxzen, ztaug, ztaur) + +! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14 + + do jb = ib1, ib2 + ibm = jb-15 + igt = ngc(ibm) + +! Reinitialize g-point counter for each band if output for each band is requested. + if (iout.gt.0.and.ibm.ge.2) iw = ngs(ibm-1) + +! do jk=1,klev+1 +! zbbcd(jk)=0.0_rb +! zbbcu(jk)=0.0_rb +! zbbfd(jk)=0.0_rb +! zbbfu(jk)=0.0_rb +! enddo + +! Top of g-point interval loop within each band (iw is cumulative counter) + do jg = 1,igt + iw = iw+1 + +! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming solar flux + zincflx(iw) = adjflux(jb) * zsflxzen(iw) * prmu0 +! zincflux = zincflux + adjflux(jb) * zsflxzen(iw) * prmu0 ! inactive + +! Compute layer reflectances and transmittances for direct and diffuse sources, +! first clear then cloudy + +! zrefc(jk) direct albedo for clear +! zrefo(jk) direct albedo for cloud +! zrefdc(jk) diffuse albedo for clear +! zrefdo(jk) diffuse albedo for cloud +! ztrac(jk) direct transmittance for clear +! ztrao(jk) direct transmittance for cloudy +! ztradc(jk) diffuse transmittance for clear +! ztrado(jk) diffuse transmittance for cloudy +! +! zref(jk) direct reflectance +! zrefd(jk) diffuse reflectance +! ztra(jk) direct transmittance +! ztrad(jk) diffuse transmittance +! +! zdbtc(jk) clear direct beam transmittance +! zdbto(jk) cloudy direct beam transmittance +! zdbt(jk) layer mean direct beam transmittance +! ztdbt(jk) total direct beam transmittance at levels + +! Clear-sky +! TOA direct beam + ztdbtc(1)=1.0_rb + ztdbtc_nodel(1)=1.0_rb +! Surface values + zdbtc(klev+1) =0.0_rb + ztrac(klev+1) =0.0_rb + ztradc(klev+1)=0.0_rb + zrefc(klev+1) =palbp(ibm) + zrefdc(klev+1)=palbd(ibm) + zrupc(klev+1) =palbp(ibm) + zrupdc(klev+1)=palbd(ibm) + +! Total sky +! TOA direct beam + ztdbt(1)=1.0_rb + ztdbt_nodel(1)=1.0_rb +! Surface values + zdbt(klev+1) =0.0_rb + ztra(klev+1) =0.0_rb + ztrad(klev+1)=0.0_rb + zref(klev+1) =palbp(ibm) + zrefd(klev+1)=palbd(ibm) + zrup(klev+1) =palbp(ibm) + zrupd(klev+1)=palbd(ibm) + +! Top of layer loop + do jk=1,klev + +! Note: two-stream calculations proceed from top to bottom; +! RRTMG_SW quantities are given bottom to top and are reversed here + + ikl=klev+1-jk + +! Set logical flag to do REFTRA calculation +! Do REFTRA for all clear layers + lrtchkclr(jk)=.true. + +! Do REFTRA only for cloudy layers in profile, since already done for clear layers + lrtchkcld(jk)=.false. + lrtchkcld(jk)=(pcldfmc(ikl,iw) > repclc) + +! Clear-sky optical parameters - this section inactive +! Original +! ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) +! zomcc(jk) = ztaur(ikl,iw) / ztauc(jk) +! zgcc(jk) = 0.0001_rb +! Total sky optical parameters +! ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaucmc(ikl,iw) +! zomco(jk) = ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + ztaur(ikl,iw) +! zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + & +! ztaur(ikl,iw) * 0.0001_rb) / zomco(jk) +! zomco(jk) = zomco(jk) / ztauo(jk) + +! Clear-sky optical parameters including aerosols + ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + ptaua(ikl,ibm) * pomga(ikl,ibm) + zgcc(jk) = pasya(ikl,ibm) * pomga(ikl,ibm) * ptaua(ikl,ibm) / zomcc(jk) + zomcc(jk) = zomcc(jk) / ztauc(jk) + +! Pre-delta-scaling clear and cloudy direct beam transmittance (must use 'orig', unscaled cloud OD) +! \/\/\/ This block of code is only needed for direct beam calculation +! + zclear = 1.0_rb - pcldfmc(ikl,iw) + zcloud = pcldfmc(ikl,iw) + +! Clear +! zdbtmc = exp(-ztauc(jk) / prmu0) + +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + ze1 = ztauc(jk) / prmu0 + if (ze1 .le. od_lo) then + zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5_rb + zdbtmc = exp_tbl(itind) + endif + + zdbtc_nodel(jk) = zdbtmc + ztdbtc_nodel(jk+1) = zdbtc_nodel(jk) * ztdbtc_nodel(jk) + +! Clear + Cloud + tauorig = ztauc(jk) + ptaormc(ikl,iw) +! zdbtmo = exp(-tauorig / prmu0) + +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + ze1 = tauorig / prmu0 + if (ze1 .le. od_lo) then + zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5_rb + zdbtmo = exp_tbl(itind) + endif + + zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo + ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk) +! /\/\/\ Above code only needed for direct beam calculation + + +! Delta scaling - clear + zf = zgcc(jk) * zgcc(jk) + zwf = zomcc(jk) * zf + ztauc(jk) = (1.0_rb - zwf) * ztauc(jk) + zomcc(jk) = (zomcc(jk) - zwf) / (1.0_rb - zwf) + zgcc (jk) = (zgcc(jk) - zf) / (1.0_rb - zf) + + +! Total sky optical parameters (cloud properties already delta-scaled) +! Use this code if cloud properties are derived in rrtmg_sw_cldprop + if (icpr .ge. 1) then + ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw) + zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + & + ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk) + zomco(jk) = zomco(jk) / ztauo(jk) + +! Total sky optical parameters (if cloud properties not delta scaled) +! Use this code if cloud properties are not derived in rrtmg_sw_cldprop + elseif (icpr .eq. 0) then + ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + ptaucmc(ikl,iw) + zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + & + ztaur(ikl,iw) * 1.0_rb + zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + & + ptaua(ikl,ibm)*pomga(ikl,ibm)*pasya(ikl,ibm)) / zomco(jk) + zomco(jk) = zomco(jk) / ztauo(jk) + +! Delta scaling - clouds +! Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties and to apply delta scaling + zf = zgco(jk) * zgco(jk) + zwf = zomco(jk) * zf + ztauo(jk) = (1._rb - zwf) * ztauo(jk) + zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf) + zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf) + endif + +! End of layer loop + enddo + +! Clear sky reflectivities + call reftra_sw (klev, & + lrtchkclr, zgcc, prmu0, ztauc, zomcc, & + zrefc, zrefdc, ztrac, ztradc) + +! Total sky reflectivities + call reftra_sw (klev, & + lrtchkcld, zgco, prmu0, ztauo, zomco, & + zrefo, zrefdo, ztrao, ztrado) + + do jk=1,klev + +! Combine clear and cloudy contributions for total sky + ikl = klev+1-jk + zclear = 1.0_rb - pcldfmc(ikl,iw) + zcloud = pcldfmc(ikl,iw) + + zref(jk) = zclear*zrefc(jk) + zcloud*zrefo(jk) + zrefd(jk)= zclear*zrefdc(jk) + zcloud*zrefdo(jk) + ztra(jk) = zclear*ztrac(jk) + zcloud*ztrao(jk) + ztrad(jk)= zclear*ztradc(jk) + zcloud*ztrado(jk) + +! Direct beam transmittance + +! Clear +! zdbtmc = exp(-ztauc(jk) / prmu0) + +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + ze1 = ztauc(jk) / prmu0 + if (ze1 .le. od_lo) then + zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5_rb + zdbtmc = exp_tbl(itind) + endif + + zdbtc(jk) = zdbtmc + ztdbtc(jk+1) = zdbtc(jk)*ztdbtc(jk) + +! Clear + Cloud +! zdbtmo = exp(-ztauo(jk) / prmu0) + +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + ze1 = ztauo(jk) / prmu0 + if (ze1 .le. od_lo) then + zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5_rb + zdbtmo = exp_tbl(itind) + endif + + zdbt(jk) = zclear*zdbtmc + zcloud*zdbtmo + ztdbt(jk+1) = zdbt(jk)*ztdbt(jk) + + enddo + +! Vertical quadrature for clear-sky fluxes + + call vrtqdr_sw(klev, iw, & + zrefc, zrefdc, ztrac, ztradc, & + zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, & + zcd, zcu) + +! Vertical quadrature for cloudy fluxes + + call vrtqdr_sw(klev, iw, & + zref, zrefd, ztra, ztrad, & + zdbt, zrdnd, zrup, zrupd, ztdbt, & + zfd, zfu) + +! Upwelling and downwelling fluxes at levels +! Two-stream calculations go from top to bottom; +! layer indexing is reversed to go bottom to top for output arrays + + do jk=1,klev+1 + ikl=klev+2-jk + +! Accumulate spectral fluxes over bands - inactive +! zbbfu(ikl) = zbbfu(ikl) + zincflx(iw)*zfu(jk,iw) +! zbbfd(ikl) = zbbfd(ikl) + zincflx(iw)*zfd(jk,iw) +! zbbcu(ikl) = zbbcu(ikl) + zincflx(iw)*zcu(jk,iw) +! zbbcd(ikl) = zbbcd(ikl) + zincflx(iw)*zcd(jk,iw) +! zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) +! zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) + +! Accumulate spectral fluxes over whole spectrum + pbbfu(ikl) = pbbfu(ikl) + zincflx(iw)*zfu(jk,iw) + pbbfd(ikl) = pbbfd(ikl) + zincflx(iw)*zfd(jk,iw) + pbbcu(ikl) = pbbcu(ikl) + zincflx(iw)*zcu(jk,iw) + pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw) + pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) + pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) + +! Accumulate direct fluxes for UV/visible bands + if (ibm >= 10 .and. ibm <= 13) then + puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw) + puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw) + puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) + puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) +! Accumulate direct fluxes for near-IR bands + else if (ibm == 14 .or. ibm <= 9) then + pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw) + pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw) + pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) + pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) + endif + + enddo + +! End loop on jg, g-point interval + enddo + +! End loop on jb, spectral band + enddo + + end subroutine spcvmc_sw + + end module rrtmg_sw_spcvmc + +! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $ +! author: $Author: trn $ +! revision: $Revision: 1.3 $ +! created: $Date: 2009/04/16 19:54:22 $ +! + module rrtmg_sw_rad + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- +! +! **************************************************************************** +! * * +! * RRTMG_SW * +! * * +! * * +! * * +! * a rapid radiative transfer model * +! * for the solar spectral region * +! * for application to general circulation models * +! * * +! * * +! * Atmospheric and Environmental Research, Inc. * +! * 131 Hartwell Avenue * +! * Lexington, MA 02421 * +! * * +! * * +! * Eli J. Mlawer * +! * Jennifer S. Delamere * +! * Michael J. Iacono * +! * Shepard A. Clough * +! * * +! * * +! * * +! * * +! * * +! * * +! * email: miacono@aer.com * +! * email: emlawer@aer.com * +! * email: jdelamer@aer.com * +! * * +! * The authors wish to acknowledge the contributions of the * +! * following people: Steven J. Taubman, Patrick D. Brown, * +! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * +! * * +! **************************************************************************** + +! --------- Modules --------- + + use parkind, only : im => kind_im, rb => kind_rb + use rrsw_vsn + use mcica_subcol_gen_sw, only: mcica_subcol_sw + use rrtmg_sw_cldprmc, only: cldprmc_sw +! *** Move the required call to rrtmg_sw_ini below and the following +! use association to GCM initialization area *** +! use rrtmg_sw_init, only: rrtmg_sw_ini + use rrtmg_sw_setcoef, only: setcoef_sw + use rrtmg_sw_spcvmc, only: spcvmc_sw + + implicit none + +! public interfaces/functions/subroutines + public :: rrtmg_sw, inatm_sw, earth_sun + +!------------------------------------------------------------------ + contains +!------------------------------------------------------------------ + +!------------------------------------------------------------------ +! Public subroutines +!------------------------------------------------------------------ + + subroutine rrtmg_sw & + (ncol ,nlay ,icld , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + asdir ,asdif ,aldir ,aldif , & + coszen ,adjes ,dyofyr ,scon , & + inflgsw ,iceflgsw,liqflgsw,cldfmcl , & + taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , & + ciwpmcl ,clwpmcl ,cswpmcl ,reicmcl ,relqmcl ,resnmcl, & + tauaer ,ssaaer ,asmaer ,ecaer , & + swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln ,swdflxcln , aer_opt, & +! --------- Add the following four compenants for ssib shortwave down radiation ---! +! ------------------- by Zhenxin 2011-06-20 --------------------------------! + sibvisdir, sibvisdif, sibnirdir, sibnirdif, & +! ---------------------- End, Zhenxin 2011-06-20 --------------------------------! + swdkdir,swdkdif, & ! jararias, 2013/08/10 + swdkdirc & ! PAJ + ,calc_clean_atm_diag & + ) + + +! ------- Description ------- + +! This program is the driver for RRTMG_SW, the AER SW radiation model for +! application to GCMs, that has been adapted from RRTM_SW for improved +! efficiency and to provide fractional cloudiness and cloud overlap +! capability using McICA. +! +! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization +! area, since this has to be called only once. +! +! This routine +! b) calls INATM_SW to read in the atmospheric profile; +! all layering in RRTMG is ordered from surface to toa. +! c) calls CLDPRMC_SW to set cloud optical depth for McICA based +! on input cloud properties +! d) calls SETCOEF_SW to calculate various quantities needed for +! the radiative transfer algorithm +! e) calls SPCVMC to call the two-stream model that in turn +! calls TAUMOL to calculate gaseous optical depths for each +! of the 16 spectral bands and to perform the radiative transfer +! using McICA, the Monte-Carlo Independent Column Approximation, +! to represent sub-grid scale cloud variability +! f) passes the calculated fluxes and cooling rates back to GCM +! +! Two modes of operation are possible: +! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use +! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM. +! +! 1) Standard, single forward model calculation (imca = 0); this is +! valid only for clear sky or fully overcast clouds +! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., +! JC, 2003) method is applied to the forward model calculation (imca = 1) +! This method is valid for clear sky or partial cloud conditions. +! +! This call to RRTMG_SW must be preceeded by a call to the module +! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator, +! which will provide the cloud physical or cloud optical properties +! on the RRTMG quadrature point (ngptsw) dimension. +! +! Two methods of cloud property input are possible: +! Cloud properties can be input in one of two ways (controlled by input +! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions +! and subroutine rrtmg_sw_cldprop.f90 for further details): +! +! 1) Input cloud fraction, cloud optical depth, single scattering albedo +! and asymmetry parameter directly (inflgsw = 0) +! 2) Input cloud fraction and cloud physical properties: ice fracion, +! ice and liquid particle sizes (inflgsw = 1 or 2); +! cloud optical properties are calculated by cldprop or cldprmc based +! on input settings of iceflgsw and liqflgsw +! +! Two methods of aerosol property input are possible: +! Aerosol properties can be input in one of two ways (controlled by input +! flag iaer, see text file rrtmg_sw_instructions for further details): +! +! 1) Input aerosol optical depth, single scattering albedo and asymmetry +! parameter directly by layer and spectral band (iaer=10) +! 2) Input aerosol optical depth and 0.55 micron directly by layer and use +! one or more of six ECMWF aerosol types (iaer=6) +! +! +! ------- Modifications ------- +! +! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced +! set of g-point intervals and a two-stream model for application to GCMs. +! +!-- Original version (derived from RRTM_SW) +! 2002: AER. Inc. +!-- Conversion to F90 formatting; addition of 2-stream radiative transfer +! Feb 2003: J.-J. Morcrette, ECMWF +!-- Additional modifications for GCM application +! Aug 2003: M. J. Iacono, AER Inc. +!-- Total number of g-points reduced from 224 to 112. Original +! set of 224 can be restored by exchanging code in module parrrsw.f90 +! and in file rrtmg_sw_init.f90. +! Apr 2004: M. J. Iacono, AER, Inc. +!-- Modifications to include output for direct and diffuse +! downward fluxes. There are output as "true" fluxes without +! any delta scaling applied. Code can be commented to exclude +! this calculation in source file rrtmg_sw_spcvrt.f90. +! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc. +!-- Revised to add McICA capability. +! Nov 2005: M. J. Iacono, AER, Inc. +!-- Reformatted for consistency with rrtmg_lw. +! Feb 2007: M. J. Iacono, AER, Inc. +!-- Modifications to formatting to use assumed-shape arrays. +! Aug 2007: M. J. Iacono, AER, Inc. + +! --------- Modules --------- + + use parrrsw, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, & + jpband, jpb1, jpb2 + use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya + use rrsw_con, only : heatfac, oneminus, pi + use rrsw_wvn, only : wavenum1, wavenum2 + +! ------- Declarations + +! ----- Input ----- + + integer(kind=im), intent(in) :: ncol ! Number of horizontal columns + integer(kind=im), intent(in) :: nlay ! Number of model layers + integer(kind=im), intent(inout) :: icld ! Cloud overlap method + ! 0: Clear only + ! 1: Random + ! 2: Maximum/random + ! 3: Maximum + ! 4: Exponential + ! 5: Exponential/random + real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K) + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: asdir(:) ! UV/vis surface albedo direct rad + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: aldir(:) ! Near-IR surface albedo direct rad + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: asdif(:) ! UV/vis surface albedo: diffuse rad + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: aldif(:) ! Near-IR surface albedo: diffuse rad + ! Dimensions: (ncol) + + integer(kind=im), intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun + ! distance if adjflx not provided) + real(kind=rb), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance + real(kind=rb), intent(in) :: coszen(:) ! Cosine of solar zenith angle + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: scon ! Solar constant (W/m2) + + integer(kind=im), intent(in) :: inflgsw ! Flag for cloud optical properties + integer(kind=im), intent(in) :: iceflgsw ! Flag for ice particle specification + integer(kind=im), intent(in) :: liqflgsw ! Flag for liquid droplet specification + + real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: fsfcmcl(:,:,:) ! In-cloud forward scattering fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns) + ! Dimensions: (ncol,nlay) + ! specific definition of reicmcl depends on setting of iceflglw: + ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflglw = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: resnmcl(:,:) ! Cloud snow effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real(kind=rb), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real(kind=rb), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real(kind=rb), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) + ! Dimensions: (ncol,nlay,naerec) + ! (non-delta scaled) + integer, intent(in) :: calc_clean_atm_diag! Control for clean air diagnositic calls for WRF-Chem + +! ----- Output ----- + + real(kind=rb), intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real(kind=rb), intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real(kind=rb), intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real(kind=rb), intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real(kind=rb), intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(out) :: swuflxcln(:,:) ! Clean sky shortwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(out) :: swdflxcln(:,:) ! Clean sky shortwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + + integer, intent(in) :: aer_opt + real(kind=rb), intent(out) :: & + swdkdir(:,:), & ! Total shortwave downward direct flux (W/m2), Dimensions: (ncol,nlay) jararias, 2013/08/10 + swdkdif(:,:), & ! Total shortwave downward diffuse flux (W/m2), Dimensions: (ncol,nlay) jararias, 2013/08/10 + swdkdirc(:,:) ! Total shortwave downward direct flux clear sky (W/m2), Dimensions: (ncol,nlay) + + + + + +! ----- Local ----- + +! Control + integer(kind=im) :: nlayers ! total number of layers + integer(kind=im) :: istart ! beginning band of calculation + integer(kind=im) :: iend ! ending band of calculation + integer(kind=im) :: icpr ! cldprop/cldprmc use flag + integer(kind=im) :: iout ! output option flag (inactive) + integer(kind=im) :: iaer ! aerosol option flag + integer(kind=im) :: idelm ! delta-m scaling flag (inactive) + integer(kind=im) :: isccos ! instrumental cosine response flag (inactive) + integer(kind=im) :: iplon ! column loop index + integer(kind=im) :: i ! layer loop index ! jk + integer(kind=im) :: ib ! band loop index ! jsw + integer(kind=im) :: ia, ig ! indices + integer(kind=im) :: k ! layer loop index + integer(kind=im) :: ims ! value for changing mcica permute seed + integer(kind=im) :: imca ! flag for mcica [0=off, 1=on] + + real(kind=rb) :: zepsec, zepzen ! epsilon + real(kind=rb) :: zdpgcp ! flux to heating conversion ratio + +! Atmosphere + real(kind=rb) :: pavel(nlay+1) ! layer pressures (mb) + real(kind=rb) :: tavel(nlay+1) ! layer temperatures (K) + real(kind=rb) :: pz(0:nlay+1) ! level (interface) pressures (hPa, mb) + real(kind=rb) :: tz(0:nlay+1) ! level (interface) temperatures (K) + real(kind=rb) :: tbound ! surface temperature (K) + real(kind=rb) :: pdp(nlay+1) ! layer pressure thickness (hPa, mb) + real(kind=rb) :: coldry(nlay+1) ! dry air column amount + real(kind=rb) :: wkl(mxmol,nlay+1) ! molecular amounts (mol/cm-2) + +! real(kind=rb) :: earth_sun ! function for Earth/Sun distance factor + real(kind=rb) :: cossza ! Cosine of solar zenith angle + real(kind=rb) :: adjflux(jpband) ! adjustment for current Earth/Sun distance + real(kind=rb) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw + ! default value of 1368.22 Wm-2 at 1 AU + real(kind=rb) :: albdir(nbndsw) ! surface albedo, direct ! zalbp + real(kind=rb) :: albdif(nbndsw) ! surface albedo, diffuse ! zalbd + + real(kind=rb) :: taua(nlay+1,nbndsw) ! Aerosol optical depth + real(kind=rb) :: ssaa(nlay+1,nbndsw) ! Aerosol single scattering albedo + real(kind=rb) :: asma(nlay+1,nbndsw) ! Aerosol asymmetry parameter + +! Atmosphere - setcoef + integer(kind=im) :: laytrop ! tropopause layer index + integer(kind=im) :: layswtch ! tropopause layer index + integer(kind=im) :: laylow ! tropopause layer index + integer(kind=im) :: jp(nlay+1) ! + integer(kind=im) :: jt(nlay+1) ! + integer(kind=im) :: jt1(nlay+1) ! + + real(kind=rb) :: colh2o(nlay+1) ! column amount (h2o) + real(kind=rb) :: colco2(nlay+1) ! column amount (co2) + real(kind=rb) :: colo3(nlay+1) ! column amount (o3) + real(kind=rb) :: coln2o(nlay+1) ! column amount (n2o) + real(kind=rb) :: colch4(nlay+1) ! column amount (ch4) + real(kind=rb) :: colo2(nlay+1) ! column amount (o2) + real(kind=rb) :: colmol(nlay+1) ! column amount + real(kind=rb) :: co2mult(nlay+1) ! column amount + + integer(kind=im) :: indself(nlay+1) + integer(kind=im) :: indfor(nlay+1) + real(kind=rb) :: selffac(nlay+1) + real(kind=rb) :: selffrac(nlay+1) + real(kind=rb) :: forfac(nlay+1) + real(kind=rb) :: forfrac(nlay+1) + + real(kind=rb) :: & ! + fac00(nlay+1), fac01(nlay+1), & + fac10(nlay+1), fac11(nlay+1) + +! Atmosphere/clouds - cldprop + integer(kind=im) :: ncbands ! number of cloud spectral bands + integer(kind=im) :: inflag ! flag for cloud property method + integer(kind=im) :: iceflag ! flag for ice cloud properties + integer(kind=im) :: liqflag ! flag for liquid cloud properties + +! real(kind=rb) :: cldfrac(nlay+1) ! layer cloud fraction +! real(kind=rb) :: tauc(nlay+1) ! in-cloud optical depth (non-delta scaled) +! real(kind=rb) :: ssac(nlay+1) ! in-cloud single scattering albedo (non-delta scaled) +! real(kind=rb) :: asmc(nlay+1) ! in-cloud asymmetry parameter (non-delta scaled) +! real(kind=rb) :: fsfc(nlay+1) ! in-cloud forward scattering fraction (non-delta scaled) +! real(kind=rb) :: ciwp(nlay+1) ! in-cloud ice water path +! real(kind=rb) :: clwp(nlay+1) ! in-cloud liquid water path +! real(kind=rb) :: rei(nlay+1) ! cloud ice particle size +! real(kind=rb) :: rel(nlay+1) ! cloud liquid particle size + +! real(kind=rb) :: taucloud(nlay+1,jpband) ! in-cloud optical depth +! real(kind=rb) :: taucldorig(nlay+1,jpband)! in-cloud optical depth (non-delta scaled) +! real(kind=rb) :: ssacloud(nlay+1,jpband) ! in-cloud single scattering albedo +! real(kind=rb) :: asmcloud(nlay+1,jpband) ! in-cloud asymmetry parameter + +! Atmosphere/clouds - cldprmc [mcica] + real(kind=rb) :: cldfmc(ngptsw,nlay+1) ! cloud fraction [mcica] + real(kind=rb) :: ciwpmc(ngptsw,nlay+1) ! in-cloud ice water path [mcica] + real(kind=rb) :: clwpmc(ngptsw,nlay+1) ! in-cloud liquid water path [mcica] + real(kind=rb) :: cswpmc(ngptsw,nlay+1) ! in-cloud snow water path [mcica] + real(kind=rb) :: relqmc(nlay+1) ! liquid particle effective radius (microns) + real(kind=rb) :: reicmc(nlay+1) ! ice particle effective size (microns) + real(kind=rb) :: resnmc(nlay+1) ! snow particle effective size (microns) + real(kind=rb) :: taucmc(ngptsw,nlay+1) ! in-cloud optical depth [mcica] + real(kind=rb) :: taormc(ngptsw,nlay+1) ! unscaled in-cloud optical depth [mcica] + real(kind=rb) :: ssacmc(ngptsw,nlay+1) ! in-cloud single scattering albedo [mcica] + real(kind=rb) :: asmcmc(ngptsw,nlay+1) ! in-cloud asymmetry parameter [mcica] + real(kind=rb) :: fsfcmc(ngptsw,nlay+1) ! in-cloud forward scattering fraction [mcica] + +! Atmosphere/clouds/aerosol - spcvrt,spcvmc + real(kind=rb) :: ztauc(nlay+1,nbndsw) ! cloud optical depth + real(kind=rb) :: ztaucorig(nlay+1,nbndsw) ! unscaled cloud optical depth + real(kind=rb) :: zasyc(nlay+1,nbndsw) ! cloud asymmetry parameter + ! (first moment of phase function) + real(kind=rb) :: zomgc(nlay+1,nbndsw) ! cloud single scattering albedo + real(kind=rb) :: ztaua(nlay+1,nbndsw) ! total aerosol optical depth + real(kind=rb) :: ztauacln(nlay+1,nbndsw) ! dummy total aerosol optical depth for clean case (=zero) + real(kind=rb) :: zasya(nlay+1,nbndsw) ! total aerosol asymmetry parameter + real(kind=rb) :: zomga(nlay+1,nbndsw) ! total aerosol single scattering albedo + + real(kind=rb) :: zcldfmc(nlay+1,ngptsw) ! cloud fraction [mcica] + real(kind=rb) :: ztaucmc(nlay+1,ngptsw) ! cloud optical depth [mcica] + real(kind=rb) :: ztaormc(nlay+1,ngptsw) ! unscaled cloud optical depth [mcica] + real(kind=rb) :: zasycmc(nlay+1,ngptsw) ! cloud asymmetry parameter [mcica] + real(kind=rb) :: zomgcmc(nlay+1,ngptsw) ! cloud single scattering albedo [mcica] + + real(kind=rb) :: zbbfu(nlay+2) ! temporary upward shortwave flux (w/m2) + real(kind=rb) :: zbbfd(nlay+2) ! temporary downward shortwave flux (w/m2) + real(kind=rb) :: zbbcu(nlay+2) ! temporary clear sky upward shortwave flux (w/m2) + real(kind=rb) :: zbbcd(nlay+2) ! temporary clear sky downward shortwave flux (w/m2) + real(kind=rb) :: zbbfddir(nlay+2) ! temporary downward direct shortwave flux (w/m2) + real(kind=rb) :: zbbcddir(nlay+2) ! temporary clear sky downward direct shortwave flux (w/m2) + real(kind=rb) :: zuvfd(nlay+2) ! temporary UV downward shortwave flux (w/m2) + real(kind=rb) :: zuvcd(nlay+2) ! temporary clear sky UV downward shortwave flux (w/m2) + real(kind=rb) :: zuvfddir(nlay+2) ! temporary UV downward direct shortwave flux (w/m2) + real(kind=rb) :: zuvcddir(nlay+2) ! temporary clear sky UV downward direct shortwave flux (w/m2) + real(kind=rb) :: znifd(nlay+2) ! temporary near-IR downward shortwave flux (w/m2) + real(kind=rb) :: znicd(nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2) + real(kind=rb) :: znifddir(nlay+2) ! temporary near-IR downward direct shortwave flux (w/m2) + real(kind=rb) :: znicddir(nlay+2) ! temporary clear sky near-IR downward direct shortwave flux (w/m2) + real(kind=rb) :: zbbclnu(nlay+2) ! temporary clean sky upward shortwave flux (w/m2) + real(kind=rb) :: zbbclnd(nlay+2) ! temporary clean sky downward shortwave flux (w/m2) + real(kind=rb) :: zbbclnddir(nlay+2) ! temporary clean sky downward direct shortwave flux (w/m2) + real(kind=rb) :: zuvclnd(nlay+2) ! temporary clean sky UV downward shortwave flux (w/m2) + real(kind=rb) :: zuvclnddir(nlay+2) ! temporary clean sky UV downward direct shortwave flux (w/m2) + real(kind=rb) :: zniclnd(nlay+2) ! temporary clean sky near-IR downward shortwave flux (w/m2) + real(kind=rb) :: zniclnddir(nlay+2) ! temporary clean sky near-IR downward direct shortwave flux (w/m2) + +! Optional output fields + real(kind=rb) :: swnflx(nlay+2) ! Total sky shortwave net flux (W/m2) + real(kind=rb) :: swnflxc(nlay+2) ! Clear sky shortwave net flux (W/m2) + real(kind=rb) :: dirdflux(nlay+2) ! Direct downward shortwave surface flux + real(kind=rb) :: difdflux(nlay+2) ! Diffuse downward shortwave surface flux + real(kind=rb) :: uvdflx(nlay+2) ! Total sky downward shortwave flux, UV/vis + real(kind=rb) :: nidflx(nlay+2) ! Total sky downward shortwave flux, near-IR + real(kind=rb) :: dirdnuv(nlay+2) ! Direct downward shortwave flux, UV/vis + real(kind=rb) :: difdnuv(nlay+2) ! Diffuse downward shortwave flux, UV/vis + real(kind=rb) :: dirdnir(nlay+2) ! Direct downward shortwave flux, near-IR + real(kind=rb) :: difdnir(nlay+2) ! Diffuse downward shortwave flux, near-IR + +! Output - inactive +! real(kind=rb) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2) +! real(kind=rb) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2) +! real(kind=rb) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2) +! real(kind=rb) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2) +! real(kind=rb) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2) +! real(kind=rb) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2) +! real(kind=rb) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2) +! real(kind=rb) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2) +! real(kind=rb) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2) +! real(kind=rb) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2) +! real(kind=rb) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2) +! real(kind=rb) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2) + + +! Initializations + + iout = 0 !BSINGH(PNNL) initializing iout to zero(Might be wrong!) as this variable is never initialized but used in spcvmc_sw + zepsec = 1.e-06_rb + zepzen = 1.e-10_rb +!jm not thread safe oneminus = 1.0_rb - zepsec +!jm not thread safe pi = 2._rb * asin(1._rb) + + istart = jpb1 + iend = jpb2 + icpr = 0 + ims = 2 + +! In a GCM with or without McICA, set nlon to the longitude dimension +! +! Set imca to select calculation type: +! imca = 0, use standard forward model calculation (clear and overcast only) +! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability +! (clear, overcast or partial cloud conditions) + +! *** This version uses McICA (imca = 1) *** + +! Set icld to select of clear or cloud calculation and cloud +! overlap method (read by subroutine readprof from input file INPUT_RRTM): +! icld = 0, clear only +! icld = 1, with clouds using random cloud overlap (McICA only) +! icld = 2, with clouds using maximum/random cloud overlap (McICA only) +! icld = 3, with clouds using maximum cloud overlap (McICA only) +! icld = 4, with clouds using exponential cloud overlap (McICA only) +! icld = 5, with clouds using exponential/random cloud overlap (McICA only) + +! Set iaer to select aerosol option +! iaer = 0, no aerosols +! iaer = 6, use six ECMWF aerosol types +! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer) +! iaer = 10, input total aerosol optical depth, single scattering albedo +! and asymmetry parameter (tauaer, ssaaer, asmaer) directly + if ( aer_opt.eq.0 .or. aer_opt.eq.2 .or. aer_opt.eq.3) then + iaer = 10 + else if ( aer_opt .eq. 1 ) then + iaer = 6 + endif + +! Call model and data initialization, compute lookup tables, perform +! reduction of g-points from 224 to 112 for input absorption +! coefficient data and other arrays. +! +! In a GCM this call should be placed in the model initialization +! area, since this has to be called only once. +! call rrtmg_sw_ini(cpdair) + +! This is the main longitude/column loop in RRTMG. +! Modify to loop over all columns (nlon) or over daylight columns + + do iplon = 1, ncol + +! Prepare atmosphere profile from GCM for use in RRTMG, and define +! other input parameters + + call inatm_sw (iplon, nlay, icld, iaer, & + play, plev, tlay, tlev, tsfc, h2ovmr, & + o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, & + adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, & + cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, & + reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, & + nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, & + adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, & + ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, & + taua, ssaa, asma) + +! For cloudy atmosphere, use cldprop to set cloud optical properties based on +! input cloud physical properties. Select method based on choices described +! in cldprop. Cloud fraction, water path, liquid droplet and ice particle +! effective radius must be passed in cldprop. Cloud fraction and cloud +! optical properties are transferred to rrtmg_sw arrays in cldprop. + + call cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & + ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, & + taormc, taucmc, ssacmc, asmcmc, fsfcmc) + icpr = 1 + +! Calculate coefficients for the temperature and pressure dependence of the +! molecular absorption coefficients by interpolating data from stored +! reference atmospheres. + + call setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, coln2o, & + colo2, colo3, fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor) + + +! Cosine of the solar zenith angle +! Prevent using value of zero; ideally, SW model is not called from host model when sun +! is below horizon + + cossza = coszen(iplon) + if (cossza .le. zepzen) cossza = zepzen + +! Transfer albedo, cloud and aerosol properties into arrays for 2-stream radiative transfer + +! Surface albedo +! Near-IR bands 16-24 and 29 (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns + do ib=1,9 + albdir(ib) = aldir(iplon) + albdif(ib) = aldif(iplon) + enddo + albdir(nbndsw) = aldir(iplon) + albdif(nbndsw) = aldif(iplon) +! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron + do ib=10,13 + albdir(ib) = asdir(iplon) + albdif(ib) = asdif(iplon) + enddo + + +! Clouds + if (icld.eq.0) then + + zcldfmc(:,:) = 0._rb + ztaucmc(:,:) = 0._rb + ztaormc(:,:) = 0._rb + zasycmc(:,:) = 0._rb + zomgcmc(:,:) = 1._rb + + elseif (icld.ge.1) then + do i=1,nlayers + do ig=1,ngptsw + zcldfmc(i,ig) = cldfmc(ig,i) + ztaucmc(i,ig) = taucmc(ig,i) + ztaormc(i,ig) = taormc(ig,i) + zasycmc(i,ig) = asmcmc(ig,i) + zomgcmc(i,ig) = ssacmc(ig,i) + enddo + enddo + + endif + +! Aerosol +! IAER = 0: no aerosols + if (iaer.eq.0) then + + ztaua(:,:) = 0._rb + zasya(:,:) = 0._rb + zomga(:,:) = 1._rb + +! IAER = 6: Use ECMWF six aerosol types. See rrsw_aer.f90 for details. +! Input aerosol optical thickness at 0.55 micron for each aerosol type (ecaer), +! or set manually here for each aerosol and layer. + elseif (iaer.eq.6) then + +! do i = 1, nlayers +! do ia = 1, naerec +! ecaer(iplon,i,ia) = 1.0e-15_rb +! enddo +! enddo + + do i = 1, nlayers + do ib = 1, nbndsw + ztaua(i,ib) = 0._rb + zasya(i,ib) = 0._rb + zomga(i,ib) = 0._rb + do ia = 1, naerec + ztaua(i,ib) = ztaua(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) + zomga(i,ib) = zomga(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * & + rsrpiza(ib,ia) + zasya(i,ib) = zasya(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * & + rsrpiza(ib,ia) * rsrasya(ib,ia) + enddo + if (zomga(i,ib) /= 0._rb) then + zasya(i,ib) = zasya(i,ib) / zomga(i,ib) + endif + if (ztaua(i,ib) /= 0._rb) then + zomga(i,ib) = zomga(i,ib) / ztaua(i,ib) + endif + enddo + enddo + +! IAER=10: Direct specification of aerosol optical properties from GCM + elseif (iaer.eq.10) then + + do i = 1 ,nlayers + do ib = 1 ,nbndsw + ztaua(i,ib) = taua(i,ib) + ztauacln(i,ib) = 0.0 + zasya(i,ib) = asma(i,ib) + zomga(i,ib) = ssaa(i,ib) + enddo + enddo + + endif + + +! Call the 2-stream radiation transfer model + + do i=1,nlayers+1 + zbbcu(i) = 0._rb + zbbcd(i) = 0._rb + zbbfu(i) = 0._rb + zbbfd(i) = 0._rb + zbbcddir(i) = 0._rb + zbbfddir(i) = 0._rb + zuvcd(i) = 0._rb + zuvfd(i) = 0._rb + zuvcddir(i) = 0._rb + zuvfddir(i) = 0._rb + znicd(i) = 0._rb + znifd(i) = 0._rb + znicddir(i) = 0._rb + znifddir(i) = 0._rb + enddo + + call spcvmc_sw & + (nlayers, istart, iend, icpr, iout, & + pavel, tavel, pz, tz, tbound, albdif, albdir, & + zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, & + ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, & + zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir) + +! Transfer up and down, clear and total sky fluxes to output arrays. +! Vertical indexing goes from bottom to top; reverse here for GCM if necessary. + + do i = 1, nlayers+1 + swuflxc(iplon,i) = zbbcu(i) + swdflxc(iplon,i) = zbbcd(i) + swuflx(iplon,i) = zbbfu(i) + swdflx(iplon,i) = zbbfd(i) + uvdflx(i) = zuvfd(i) + nidflx(i) = znifd(i) + +! Direct/diffuse fluxes + dirdflux(i) = zbbfddir(i) + difdflux(i) = swdflx(iplon,i) - dirdflux(i) + swdkdir(iplon,i) = dirdflux(i) ! all-sky direct flux jararias, 2013/08/10 + swdkdif(iplon,i) = difdflux(i) ! all-sky diffuse flux jararias, 2013/08/10 + swdkdirc(iplon,i) = zbbcddir(i) ! PAJ: clear-sky direct flux + +! UV/visible direct/diffuse fluxes + dirdnuv(i) = zuvfddir(i) + difdnuv(i) = zuvfd(i) - dirdnuv(i) +! ------- Zhenxin add vis/uv downwards dir or dif here --! + sibvisdir(iplon,i) = dirdnuv(i) + sibvisdif(iplon,i) = difdnuv(i) +! ----- End of Zhenxin addition ------------! +! Near-IR direct/diffuse fluxes + dirdnir(i) = znifddir(i) + difdnir(i) = znifd(i) - dirdnir(i) +! ---------Zhenxin add nir downwards dir and dif here --! + sibnirdir(iplon,i) = dirdnir(i) + sibnirdif(iplon,i) = difdnir(i) +! -------- End of Zhenxin addition 2011-05 ---------! + enddo + +! Total and clear sky net fluxes + do i = 1, nlayers+1 + swnflxc(i) = swdflxc(iplon,i) - swuflxc(iplon,i) + swnflx(i) = swdflx(iplon,i) - swuflx(iplon,i) + enddo + +! Total and clear sky heating rates + do i = 1, nlayers + zdpgcp = heatfac / pdp(i) + swhrc(iplon,i) = (swnflxc(i+1) - swnflxc(i)) * zdpgcp + swhr(iplon,i) = (swnflx(i+1) - swnflx(i)) * zdpgcp + enddo + swhrc(iplon,nlayers) = 0._rb + swhr(iplon,nlayers) = 0._rb + +#if (WRF_CHEM == 1) + ! Repeat call to 2-stream radiation model using "clean sky" + ! variables and aerosol tau set to 0 + if(calc_clean_atm_diag .gt. 0)then + do i=1,nlayers+1 + zbbcu(i) = 0._rb + zbbcd(i) = 0._rb + zbbclnu(i) = 0._rb + zbbclnd(i) = 0._rb + zbbcddir(i) = 0._rb + zbbclnddir(i) = 0._rb + zuvcd(i) = 0._rb + zuvclnd(i) = 0._rb + zuvcddir(i) = 0._rb + zuvclnddir(i) = 0._rb + znicd(i) = 0._rb + zniclnd(i) = 0._rb + znicddir(i) = 0._rb + zniclnddir(i) = 0._rb + enddo + + call spcvmc_sw & + (nlayers, istart, iend, icpr, iout, & + pavel, tavel, pz, tz, tbound, albdif, albdir, & + zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, & + ztauacln, zasya, zomga, cossza, coldry, wkl, adjflux, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + zbbclnd, zbbclnu, zbbcd, zbbcu, zuvclnd, zuvcd, zniclnd, znicd, & + zbbclnddir, zbbcddir, zuvclnddir, zuvcddir, zniclnddir, znicddir) + + do i = 1, nlayers+1 + swuflxcln(iplon,i) = zbbclnu(i) + swdflxcln(iplon,i) = zbbclnd(i) + enddo + else + do i = 1, nlayers+1 + swuflxcln(iplon,i) = 0.0 + swdflxcln(iplon,i) = 0.0 + enddo + end if + +#else + do i = 1, nlayers+1 + swuflxcln(iplon,i) = 0.0 + swdflxcln(iplon,i) = 0.0 + enddo + +#endif +! End longitude loop + enddo + + end subroutine rrtmg_sw + +!************************************************************************* + real(kind=rb) function earth_sun(idn) +!************************************************************************* +! +! Purpose: Function to calculate the correction factor of Earth's orbit +! for current day of the year + +! idn : Day of the year +! earth_sun : square of the ratio of mean to actual Earth-Sun distance + +! ------- Modules ------- + + use rrsw_con, only : pi + + integer(kind=im), intent(in) :: idn + + real(kind=rb) :: gamma + + gamma = 2._rb*pi*(idn-1)/365._rb + +! Use Iqbal's equation 1.2.1 + + earth_sun = 1.000110_rb + .034221_rb * cos(gamma) + .001289_rb * sin(gamma) + & + .000719_rb * cos(2._rb*gamma) + .000077_rb * sin(2._rb*gamma) + + end function earth_sun + +!*************************************************************************** + subroutine inatm_sw (iplon, nlay, icld, iaer, & + play, plev, tlay, tlev, tsfc, h2ovmr, & + o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, & + adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, & + cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, & + reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, & + nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, & + adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, & + ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, & + taua, ssaa, asma) +!*************************************************************************** +! +! Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW. +! Set other RRTMG_SW input parameters. +! +!*************************************************************************** + +! --------- Modules ---------- + + use parrrsw, only : nbndsw, ngptsw, nstr, nmol, mxmol, & + jpband, jpb1, jpb2, rrsw_scon + use rrsw_con, only : heatfac, oneminus, pi, grav, avogad + use rrsw_wvn, only : ng, nspa, nspb, wavenum1, wavenum2, delwave + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=im), intent(in) :: iplon ! column loop index + integer(kind=im), intent(in) :: nlay ! number of model layers + integer(kind=im), intent(in) :: icld ! clear/cloud and cloud overlap flag + integer(kind=im), intent(in) :: iaer ! aerosol option flag + + real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K) + ! Dimensions: (ncol) + real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + + integer(kind=im), intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun + ! distance if adjflx not provided) + real(kind=rb), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance + real(kind=rb), intent(in) :: scon ! Solar constant (W/m2) + + integer(kind=im), intent(in) :: inflgsw ! Flag for cloud optical properties + integer(kind=im), intent(in) :: iceflgsw ! Flag for ice particle specification + integer(kind=im), intent(in) :: liqflgsw ! Flag for liquid droplet specification + + real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth (optional) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: fsfcmcl(:,:,:) ! In-cloud forward scattering fraction + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptsw,ncol,nlay) + real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real(kind=rb), intent(in) :: resnmcl(:,:) ! Cloud snow effective radius (microns) + ! Dimensions: (ncol,nlay) + + real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth + ! Dimensions: (ncol,nlay,nbndsw) + real(kind=rb), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo + ! Dimensions: (ncol,nlay,nbndsw) + real(kind=rb), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter + ! Dimensions: (ncol,nlay,nbndsw) + +! Atmosphere + integer(kind=im), intent(out) :: nlayers ! number of layers + + real(kind=rb), intent(out) :: pavel(:) ! layer pressures (mb) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: tavel(:) ! layer temperatures (K) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb) + ! Dimensions: (0:nlay) + real(kind=rb), intent(out) :: tz(0:) ! level (interface) temperatures (K) + ! Dimensions: (0:nlay) + real(kind=rb), intent(out) :: tbound ! surface temperature (K) + real(kind=rb), intent(out) :: pdp(:) ! layer pressure thickness (hPa, mb) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: coldry(:) ! dry air column density (mol/cm2) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2) + ! Dimensions: (mxmol,nlay) + + real(kind=rb), intent(out) :: adjflux(:) ! adjustment for current Earth/Sun distance + ! Dimensions: (jpband) + real(kind=rb), intent(out) :: solvar(:) ! solar constant scaling factor from rrtmg_sw + ! Dimensions: (jpband) + ! default value of 1368.22 Wm-2 at 1 AU + real(kind=rb), intent(out) :: taua(:,:) ! Aerosol optical depth + ! Dimensions: (nlay,nbndsw) + real(kind=rb), intent(out) :: ssaa(:,:) ! Aerosol single scattering albedo + ! Dimensions: (nlay,nbndsw) + real(kind=rb), intent(out) :: asma(:,:) ! Aerosol asymmetry parameter + ! Dimensions: (nlay,nbndsw) + +! Atmosphere/clouds - cldprop + integer(kind=im), intent(out) :: inflag ! flag for cloud property method + integer(kind=im), intent(out) :: iceflag ! flag for ice cloud properties + integer(kind=im), intent(out) :: liqflag ! flag for liquid cloud properties + + real(kind=rb), intent(out) :: cldfmc(:,:) ! layer cloud fraction + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: taucmc(:,:) ! in-cloud optical depth (non-delta scaled) + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: ssacmc(:,:) ! in-cloud single scattering albedo (non-delta-scaled) + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: asmcmc(:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: fsfcmc(:,:) ! in-cloud forward scattering fraction (non-delta scaled) + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: ciwpmc(:,:) ! in-cloud ice water path + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: clwpmc(:,:) ! in-cloud liquid water path + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: cswpmc(:,:) ! in-cloud snow path + ! Dimensions: (ngptsw,nlay) + real(kind=rb), intent(out) :: relqmc(:) ! liquid particle effective radius (microns) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: reicmc(:) ! ice particle effective size (microns) + ! Dimensions: (nlay) + real(kind=rb), intent(out) :: resnmc(:) ! snow particle effective size (microns) + ! Dimensions: (nlay) + +! ----- Local ----- + real(kind=rb), parameter :: amd = 28.9660_rb ! Effective molecular weight of dry air (g/mol) + real(kind=rb), parameter :: amw = 18.0160_rb ! Molecular weight of water vapor (g/mol) +! real(kind=rb), parameter :: amc = 44.0098_rb ! Molecular weight of carbon dioxide (g/mol) +! real(kind=rb), parameter :: amo = 47.9998_rb ! Molecular weight of ozone (g/mol) +! real(kind=rb), parameter :: amo2 = 31.9999_rb ! Molecular weight of oxygen (g/mol) +! real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol) +! real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol) + +! Set molecular weight ratios (for converting mmr to vmr) +! e.g. h2ovmr = h2ommr * amdw) + real(kind=rb), parameter :: amdw = 1.607793_rb ! Molecular weight of dry air / water vapor + real(kind=rb), parameter :: amdc = 0.658114_rb ! Molecular weight of dry air / carbon dioxide + real(kind=rb), parameter :: amdo = 0.603428_rb ! Molecular weight of dry air / ozone + real(kind=rb), parameter :: amdm = 1.805423_rb ! Molecular weight of dry air / methane + real(kind=rb), parameter :: amdn = 0.658090_rb ! Molecular weight of dry air / nitrous oxide + real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen + + real(kind=rb), parameter :: sbc = 5.67e-08_rb ! Stefan-Boltzmann constant (W/m2K4) + + integer(kind=im) :: isp, l, ix, n, imol, ib, ig ! Loop indices + real(kind=rb) :: amm, summol ! + real(kind=rb) :: adjflx ! flux adjustment for Earth/Sun distance +! real(kind=rb) :: earth_sun ! function for Earth/Sun distance adjustment + + nlayers = nlay + +! Initialize all molecular amounts to zero here, then pass input amounts +! into RRTM array WKL below. + + wkl(:,:) = 0.0_rb + cldfmc(:,:) = 0.0_rb + taucmc(:,:) = 0.0_rb + ssacmc(:,:) = 1.0_rb + asmcmc(:,:) = 0.0_rb + fsfcmc(:,:) = 0.0_rb + ciwpmc(:,:) = 0.0_rb + clwpmc(:,:) = 0.0_rb + cswpmc(:,:) = 0.0_rb + reicmc(:) = 0.0_rb + relqmc(:) = 0.0_rb + resnmc(:) = 0.0_rb + taua(:,:) = 0.0_rb + ssaa(:,:) = 1.0_rb + asma(:,:) = 0.0_rb + +! Set flux adjustment for current Earth/Sun distance (two options). +! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes); + adjflx = adjes +! +! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year. +! (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU). + if (dyofyr .gt. 0) then + adjflx = earth_sun(dyofyr) + endif + +! Set incoming solar flux adjustment to include adjustment for +! current Earth/Sun distance (ADJFLX) and scaling of default internal +! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR). SOLVAR can be set +! to a single scaling factor as needed, or to a different value in each +! band, which may be necessary for paleoclimate simulations. +! + do ib = jpb1,jpb2 +! solvar(ib) = 1._rb + solvar(ib) = scon / rrsw_scon + adjflux(ib) = adjflx * solvar(ib) + enddo + +! Set surface temperature. + tbound = tsfc(iplon) + +! Install input GCM arrays into RRTMG_SW arrays for pressure, temperature, +! and molecular amounts. +! Pressures are input in mb, or are converted to mb here. +! Molecular amounts are input in volume mixing ratio, or are converted from +! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio +! here. These are then converted to molecular amount (molec/cm2) below. +! The dry air column COLDRY (in molec/cm2) is calculated from the level +! pressures, pz (in mb), based on the hydrostatic equation and includes a +! correction to account for h2o in the layer. The molecular weight of moist +! air (amm) is calculated for each layer. +! Note: In RRTMG, layer indexing goes from bottom to top, and coding below +! assumes GCM input fields are also bottom to top. Input layer indexing +! from GCM fields should be reversed here if necessary. + + pz(0) = plev(iplon,1) + tz(0) = tlev(iplon,1) + do l = 1, nlayers + pavel(l) = play(iplon,l) + tavel(l) = tlay(iplon,l) + pz(l) = plev(iplon,l+1) + tz(l) = tlev(iplon,l+1) + pdp(l) = pz(l-1) - pz(l) +! For h2o input in vmr: + wkl(1,l) = h2ovmr(iplon,l) +! For h2o input in mmr: +! wkl(1,l) = h2o(iplon,l)*amdw +! For h2o input in specific humidity; +! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw + wkl(2,l) = co2vmr(iplon,l) + wkl(3,l) = o3vmr(iplon,l) + wkl(4,l) = n2ovmr(iplon,l) + wkl(6,l) = ch4vmr(iplon,l) + wkl(7,l) = o2vmr(iplon,l) + amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw + coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / & + (1.e2_rb * grav * amm * (1._rb + wkl(1,l))) + enddo + +! The following section can be used to set values for an additional layer (from +! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes. +! Temperature and molecular amounts in the extra model layer are set to +! their values in the top GCM model layer, though these can be modified +! here if necessary. +! If this feature is utilized, increase nlayers by one above, limit the two +! loops above to (nlayers-1), and set the top most (nlayers) layer values here. + +! pavel(nlayers) = 0.5_rb * pz(nlayers-1) +! tavel(nlayers) = tavel(nlayers-1) +! pz(nlayers) = 1.e-4_rb +! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1)) +! tz(nlayers) = tz(nlayers-1) +! pdp(nlayers) = pz(nlayers-1) - pz(nlayers) +! wkl(1,nlayers) = wkl(1,nlayers-1) +! wkl(2,nlayers) = wkl(2,nlayers-1) +! wkl(3,nlayers) = wkl(3,nlayers-1) +! wkl(4,nlayers) = wkl(4,nlayers-1) +! wkl(6,nlayers) = wkl(6,nlayers-1) +! wkl(7,nlayers) = wkl(7,nlayers-1) +! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw +! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / & +! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1))) + +! At this point all molecular amounts in wkl are in volume mixing ratio; +! convert to molec/cm2 based on coldry for use in rrtm. + + do l = 1, nlayers + do imol = 1, nmol + wkl(imol,l) = coldry(l) * wkl(imol,l) + enddo + enddo + +! Transfer aerosol optical properties to RRTM variables; +! modify to reverse layer indexing here if necessary. + + if (iaer .ge. 1) then + do l = 1, nlayers + do ib = 1, nbndsw + taua(l,ib) = tauaer(iplon,l,ib) + ssaa(l,ib) = ssaaer(iplon,l,ib) + asma(l,ib) = asmaer(iplon,l,ib) + enddo + enddo + endif + +! Transfer cloud fraction and cloud optical properties to RRTM variables; +! modify to reverse layer indexing here if necessary. + + if (icld .ge. 1) then + inflag = inflgsw + iceflag = iceflgsw + liqflag = liqflgsw + +! Move incoming GCM cloud arrays to RRTMG cloud arrays. +! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflgsw) + + do l = 1, nlayers + do ig = 1, ngptsw + cldfmc(ig,l) = cldfmcl(ig,iplon,l) + taucmc(ig,l) = taucmcl(ig,iplon,l) + ssacmc(ig,l) = ssacmcl(ig,iplon,l) + asmcmc(ig,l) = asmcmcl(ig,iplon,l) + fsfcmc(ig,l) = fsfcmcl(ig,iplon,l) + ciwpmc(ig,l) = ciwpmcl(ig,iplon,l) + clwpmc(ig,l) = clwpmcl(ig,iplon,l) + if (iceflag.eq.5) then + cswpmc(ig,l)=cswpmcl(ig,iplon,l) + endif + enddo + reicmc(l) = reicmcl(iplon,l) + relqmc(l) = relqmcl(iplon,l) + if (iceflag.eq.5) then + resnmc(l) = resnmcl(iplon,l) + endif + enddo + +! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer. + +! cldfmc(:,nlayers) = 0.0_rb +! taucmc(:,nlayers) = 0.0_rb +! ssacmc(:,nlayers) = 1.0_rb +! asmcmc(:,nlayers) = 0.0_rb +! fsfcmc(:,nlayers) = 0.0_rb +! ciwpmc(:,nlayers) = 0.0_rb +! clwpmc(:,nlayers) = 0.0_rb +! reicmc(nlayers) = 0.0_rb +! relqmc(nlayers) = 0.0_rb + + endif + + end subroutine inatm_sw + + end module rrtmg_sw_rad + +!------------------------------------------------------------------ +MODULE module_ra_rrtmg_sw + +!use module_model_constants, only : cp +use icar_constants, only : cp +!USE module_wrf_error +!#if (HWRF == 1) +!USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF +!#else +!USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT +!#endif +!USE module_dm + +use parrrsw, only : nbndsw, ngptsw, naerec +use rrtmg_sw_init, only: rrtmg_sw_ini +use rrtmg_sw_rad, only: rrtmg_sw +use mcica_subcol_gen_sw, only: mcica_subcol_sw + +use module_ra_rrtmg_lw, only : inirad, o3data, relcalc, reicalc, retab +! mcica_random_numbers, randomNumberSequence, & +! new_RandomNumberSequence, getRandomReal + +CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE RRTMG_SWRAD( & + rthratensw, & + swupt, swuptc, swuptcln, swdnt, swdntc, swdntcln, & + swupb, swupbc, swupbcln, swdnb, swdnbc, swdnbcln, & +! swupflx, swupflxc, swdnflx, swdnflxc, & + swcf, gsw, & + xtime, gmt, xlat, xlong, & + radt, degrad, declin, & + coszr, julday, solcon, & + albedo, t3d, t8w, tsk, & + p3d, p8w, pi3d, rho3d, & + dz8w, cldfra3d, lradius, iradius, & + is_cammgmp_used, r, g, & + re_cloud,re_ice,re_snow, & + has_reqc,has_reqi,has_reqs, & + icloud, warm_rain, & + cldovrlp, & ! J. Henderson AER: cldovrlp namelist value + f_ice_phy, f_rain_phy, & + xland, xice, snow, & + qv3d, qc3d, qr3d, & + qi3d, qs3d, qg3d, & + o3input, o33d, & + aer_opt, aerod, no_src, & + alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011) + alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011) + swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011) + swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011) + sf_surface_physics, & !Zhenxin + f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, & + tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao + gaer300,gaer400,gaer600,gaer999, & ! czhao + waer300,waer400,waer600,waer999, & ! czhao + aer_ra_feedback, & +!jdfcz progn,prescribe, & + progn,calc_clean_atm_diag, & + qndrop3d,f_qndrop, & !czhao + mp_physics, & !wang 2014/12 + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + swupflx, swupflxc, & + swdnflx, swdnflxc, & + tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw, & ! jararias 2013/11 + swddir, swddni, swddif, & ! jararias 2013/08 + swdownc, swddnic, swddirc, & ! PAJ + xcoszen,yr,julian, & ! jararias 2013/08 + mp_options & + ) +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + LOGICAL, INTENT(IN ) :: warm_rain + LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: ICLOUD + INTEGER, INTENT(IN ) :: MP_PHYSICS +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: dz8w, & + t3d, & + t8w, & + p3d, & + p8w, & + pi3d, & + rho3d + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RTHRATENSW + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: GSW, & + SWCF, & + COSZR + + INTEGER, INTENT(IN ) :: JULDAY + REAL, INTENT(IN ) :: RADT,DEGRAD, & + XTIME,DECLIN,SOLCON,GMT + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: XLAT, & + XLONG, & + XLAND, & + XICE, & + SNOW, & + TSK, & + ALBEDO +! +!!! ------------------- Zhenxin (2011-06/20) ------------------ + REAL, DIMENSION( ims:ime, jms:jme ) , & + OPTIONAL , & + INTENT(IN) :: ALSWVISDIR, & ! ssib albedo of sw and lw + ALSWVISDIF, & + ALSWNIRDIR, & + ALSWNIRDIF + + REAL, DIMENSION( ims:ime, jms:jme ) , & + OPTIONAL , & + INTENT(OUT) :: SWVISDIR, & + SWVISDIF, & + SWNIRDIR, & + SWNIRDIF ! ssib sw dir and diff rad + INTEGER, INTENT(IN) :: sf_surface_physics ! ssib para + + INTEGER, INTENT(in) :: mp_options + +! ----------------------- end Zhenxin -------------------------- +! + +! ------------------------ jararias 2013/08/10 ----------------- + real, dimension(ims:ime,jms:jme), intent(out), optional :: & + swddir, & ! All-sky broadband surface direct horiz irradiance + swddni, & ! All-sky broadband surface direct normal irradiance + swddif, & ! All-sky broadband surface diffuse irradiance + swdownc, & ! Clear sky GHI + swddnic, & ! Clear ski DNI + swddirc ! Clear ski direct horizontal irradiance + + integer, intent(in) :: yr + real, optional, intent(in) :: & + julian ! julian day (1-366) + real, dimension(ims:ime,jms:jme), intent(in) :: & + xcoszen ! cosine of the solar zenith angle + real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw +! ------------------------ jararias end snippet ----------------- + + REAL, INTENT(IN ) :: R,G +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + CLDFRA3D, & + LRADIUS, & + IRADIUS, & + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D, & + QNDROP3D + +!..Added by G. Thompson to couple cloud physics effective radii. + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + RE_CLOUD, & + RE_ICE, & + RE_SNOW + INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs + + real pi,third,relconst,lwpmin,rhoh2o + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + F_ICE_PHY, & + F_RAIN_PHY + + LOGICAL, OPTIONAL, INTENT(IN) :: & + F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP + +! Optional + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao + gaer300,gaer400,gaer600,gaer999, & ! czhao + waer300,waer400,waer600,waer999 ! czhao + + INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback +!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe + INTEGER, INTENT(IN ), OPTIONAL :: progn + INTEGER, INTENT(IN ) :: calc_clean_atm_diag + +! Ozone + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: O33D + INTEGER, OPTIONAL, INTENT(IN ) :: o3input +! EC aerosol: no_src = naerec = 6 + INTEGER, INTENT(IN ) :: no_src + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src ) , & + OPTIONAL , & + INTENT(IN ) :: aerod + INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt + + !wavelength corresponding to wavenum1 and wavenum2 (cm-1) + real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals + data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, & + 1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/ + real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval + data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, & + 1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/ + real wavemid(nbndsw) ! Mid wavelength (um) of interval + real, parameter :: thresh=1.e-9 + real ang,slope + character(len=200) :: msg + +! Top of atmosphere and surface shortwave fluxes (W m-2) + REAL, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + SWUPT,SWUPTC,SWUPTCLN,SWDNT,SWDNTC,SWDNTCLN, & + SWUPB,SWUPBC,SWUPBCLN,SWDNB,SWDNBC,SWDNBCLN + +! Layer shortwave fluxes (including extra layer above model top) +! Vertical ordering is from bottom to top (W m-2) + REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), & + OPTIONAL, INTENT(OUT) :: & + SWUPFLX,SWUPFLXC, & + SWDNFLX,SWDNFLXC + +! LOCAL VARS + + REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & + Tw1D + + REAL, DIMENSION( kts:kte ) :: TTEN1D, & + CLDFRA1D, & + DZ1D, & + P1D, & + T1D, & + QV1D, & + QC1D, & + QR1D, & + QI1D, & + RHO1D, & + QS1D, & + QG1D, & + O31D, & + qndrop1d + +!BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996) + real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, & + re_30C=1250.0/9.208, re_20C=1250.0/9.387 + +! Added local arrays for RRTMG + integer :: ncol, & + nlay, & + icld, & + cldovrlp, & ! J. Henderson AER + inflgsw, & + iceflgsw, & + liqflgsw +! Dimension with extra layer from model top to TOA + real, dimension( 1, kts:kte+2 ) :: plev, & + tlev + real, dimension( 1, kts:kte+1 ) :: play, & + tlay, & + h2ovmr, & + o3vmr, & + co2vmr, & + o2vmr, & + ch4vmr, & + n2ovmr + real, dimension( kts:kte+1 ) :: o3mmr +! mji - Add height of each layer for exponential-random cloud overlap +! This will be derived below from the dz in each layer + real, dimension( 1, kts:kte+1 ) :: hgt + real :: dzsum +! Surface albedo (for UV/visible and near-IR spectral regions, +! and for direct and diffuse radiation) + real, dimension( 1 ) :: asdir, & + asdif, & + aldir, & + aldif +! Dimension with extra layer from model top to TOA, +! though no clouds are allowed in extra layer + real, dimension( 1, kts:kte+1 ) :: clwpth, & + ciwpth, & + cswpth, & + rel, & + rei, & + res, & + cldfrac, & + relqmcl, & + reicmcl, & + resnmcl + real, dimension( nbndsw, 1, kts:kte+1 ) :: taucld, & + ssacld, & + asmcld, & + fsfcld + real, dimension( ngptsw, 1, kts:kte+1 ) :: cldfmcl, & + clwpmcl, & + ciwpmcl, & + cswpmcl, & + taucmcl, & + ssacmcl, & + asmcmcl, & + fsfcmcl + real, dimension( 1, kts:kte+1, nbndsw ) :: tauaer, & + ssaaer, & + asmaer + real, dimension( 1, kts:kte+1, naerec ) :: ecaer + +! Output arrays contain extra layer from model top to TOA + real, dimension( 1, kts:kte+2 ) :: swuflx, & + swdflx, & + swuflxc, & + swdflxc, & + swuflxcln, & + swdflxcln, & + sibvisdir, & ! Zhenxin 2011-06-20 + sibvisdif, & + sibnirdir, & + sibnirdif ! Zhenxin 2011-06-20 + + real, dimension( 1, kts:kte+2 ) :: swdkdir, & ! jararias, 2013/08/10 + swdkdif, & ! jararias, 2013/08/10 + swdkdirc ! PAJ + + real, dimension( 1, kts:kte+1 ) :: swhr, & + swhrc + + real, dimension ( 1 ) :: tsfc, & + ps, & + coszen + real :: ro, & + dz, & + adjes, & + scon, & + snow_mass_factor + integer :: dyofyr + + integer:: idx_rei + real:: corr + +! Set trace gas volume mixing ratios, 2005 values, IPCC (2007) +! carbon dioxide (379 ppmv) - this is being replaced by an annual function in v4.2 + real :: co2 +! data co2 / 379.e-6 / +! methane (1774 ppbv) + real :: ch4 + data ch4 / 1774.e-9 / +! nitrous oxide (319 ppbv) + real :: n2o + data n2o / 319.e-9 / +! Set oxygen volume mixing ratio (for o2mmr=0.23143) + real :: o2 + data o2 / 0.209488 / + + integer :: iplon, irng, permuteseed + integer :: nb + +! For old lw cloud property specification +! Cloud and precipitation absorption coefficients +! real :: abcw,abice,abrn,absn +! data abcw /0.144/ +! data abice /0.0735/ +! data abrn /0.330e-3/ +! data absn /2.34e-3/ + +! Molecular weights and ratios for converting mmr to vmr units +! real :: amd ! Effective molecular weight of dry air (g/mol) +! real :: amw ! Molecular weight of water vapor (g/mol) +! real :: amo ! Molecular weight of ozone (g/mol) +! real :: amo2 ! Molecular weight of oxygen (g/mol) +! Atomic weights for conversion from mass to volume mixing ratios +! data amd / 28.9660 / +! data amw / 18.0160 / +! data amo / 47.9998 / +! data amo2 / 31.9999 / + + real :: amdw ! Molecular weight of dry air / water vapor + real :: amdo ! Molecular weight of dry air / ozone + real :: amdo2 ! Molecular weight of dry air / oxygen + data amdw / 1.607793 / + data amdo / 0.603461 / + data amdo2 / 0.905190 / + +!! + real, dimension(1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb) + + real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path + cliqwp, & ! in-cloud cloud liquid water path + csnowp, & ! in-cloud snow water path + reliq, & ! effective drop radius (microns) + reice ! ice effective drop size (microns) + real, dimension(1, 1:kte-kts+1):: recloud1d, & + reice1d, & + resnow1d + real :: gliqwp, gicewp, gsnowp, gravmks, tem1,tem2,tem3 + +! +! REAL :: TSFC,GLW0,OLR0,EMISS0,FP + REAL :: FP + +! real, dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns + real :: coszrs ! Cosine of solar zenith angle for present latitude + logical :: dorrsw ! Flag to allow shortwave calculation + + real, dimension (1) :: landfrac, landm, snowh, icefrac + + integer :: pcols, pver + + INTEGER :: i,j,K, na + LOGICAL :: predicate + + REAL :: da, eot ! jararias, 14/08/2013 + +!------------------------------------------------------------------ +! Annual function for co2 in WRF v4.2 + co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6 +#if ( WRF_CHEM == 1 ) + IF ( aer_ra_feedback == 1) then + IF ( .NOT. & + ( PRESENT(tauaer300) .AND. & + PRESENT(tauaer400) .AND. & + PRESENT(tauaer600) .AND. & + PRESENT(tauaer999) .AND. & + PRESENT(gaer300) .AND. & + PRESENT(gaer400) .AND. & + PRESENT(gaer600) .AND. & + PRESENT(gaer999) .AND. & + PRESENT(waer300) .AND. & + PRESENT(waer400) .AND. & + PRESENT(waer600) .AND. & + PRESENT(waer999) ) ) THEN + !CALL wrf_error_fatal & +! ('Warning: missing fields required for aerosol radiation' ) + error stop 'Warning: missing fields required for aerosol radiation' + ENDIF + ENDIF +#endif + +!-----CALCULATE SHORT WAVE RADIATION +! +! All fields are ordered vertically from bottom to top +! Pressures are in mb + +! latitude loop + j_loop: do j = jts,jte + +! longitude loop + i_loop: do i = its,ite + rho1d(kts:kte)=rho3d(i,kts:kte,j) ! BUG FIX (SGT): this was uninitialized +! +! Do shortwave by default, deactivate below if sun below horizon + dorrsw = .true. + +! Cosine solar zenith angle for current time step +! + ! jararias, 14/08/2013 + coszr(i,j)=xcoszen(i,j) + coszrs=xcoszen(i,j) + +! Set flag to prevent shortwave calculation when sun below horizon + if (coszrs.le.0.0) dorrsw = .false. +! Perform shortwave calculation if sun above horizon + if (dorrsw) then + + do k=kts,kte+1 + Pw1D(K) = p8w(I,K,J)/100. + Tw1D(K) = t8w(I,K,J) + enddo + + DO K=kts,kte + QV1D(K)=0. + QC1D(K)=0. + QR1D(K)=0. + QI1D(K)=0. + QS1D(K)=0. + CLDFRA1D(k)=0. + QNDROP1D(k)=0. + ENDDO + + DO K=kts,kte + QV1D(K)=QV3D(I,K,J) + QV1D(K)=max(0.,QV1D(K)) + ENDDO + + IF (PRESENT(O33D)) THEN + DO K=kts,kte + O31D(K)=O33D(I,K,J) + ENDDO + ELSE + DO K=kts,kte + O31D(K)=0.0 + ENDDO + ENDIF + + DO K=kts,kte + TTEN1D(K)=0. + T1D(K)=t3d(I,K,J) + P1D(K)=p3d(I,K,J)/100. + DZ1D(K)=dz8w(I,K,J) + ENDDO + +! moist variables + + IF (ICLOUD .ne. 0) THEN + IF ( PRESENT( CLDFRA3D ) ) THEN + DO K=kts,kte + CLDFRA1D(k)=CLDFRA3D(I,K,J) + ENDDO + ENDIF + + IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN + IF ( F_QC) THEN + DO K=kts,kte + QC1D(K)=QC3D(I,K,J) + QC1D(K)=max(0.,QC1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN + IF ( F_QR) THEN + DO K=kts,kte + QR1D(K)=QR3D(I,K,J) + QR1D(K)=max(0.,QR1D(K)) + ENDDO + ENDIF + ENDIF + + IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN + IF (F_QNDROP) THEN + DO K=kts,kte + qndrop1d(K)=qndrop3d(I,K,J) + ENDDO + ENDIF + ENDIF + +! This logic is tortured because cannot test F_QI unless +! it is present, and order of evaluation of expressions +! is not specified in Fortran + + IF ( PRESENT ( F_QI ) ) THEN + predicate = F_QI + ELSE + predicate = .FALSE. + ENDIF + +! For MP option 3 + IF (.NOT. predicate .and. .not. warm_rain) THEN + DO K=kts,kte + IF (T1D(K) .lt. 273.15) THEN + QI1D(K)=QC1D(K) + QS1D(K)=QR1D(K) + QC1D(K)=0. + QR1D(K)=0. + ENDIF + ENDDO + ENDIF + + IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN + IF (F_QI) THEN + DO K=kts,kte + QI1D(K)=QI3D(I,K,J) + QI1D(K)=max(0.,QI1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN + IF (F_QS) THEN + DO K=kts,kte + QS1D(K)=QS3D(I,K,J) + QS1D(K)=max(0.,QS1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN + IF (F_QG) THEN + DO K=kts,kte + QG1D(K)=QG3D(I,K,J) + QG1D(K)=max(0.,QG1D(K)) + ENDDO + ENDIF + ENDIF + +! mji - For MP option 5 + IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN + IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN + DO K=kts,kte + qi1d(k) = 0.1*qs3d(i,k,j) + qs1d(k) = 0.9*qs3d(i,k,j) + qc1d(k) = qc3d(i,k,j) + qi1d(k) = max(0.,qi1d(k)) + qc1d(k) = max(0.,qc1d(k)) + ENDDO + ENDIF + ENDIF + ELSE + reice1d = 10 + recloud1d = 5 + resnow1d = 10 + ENDIF + +! For mp option=5 or 85 (new Ferrier- Aligo or called fer_hires +! scheme), QI3D saves all frozen water (ice+snow) +! ++ trude, remove this test, we will not use mp option 5 or 85. +!#if (HWRF == 1) +! IF ( mp_physics == FER_MP_HIRES .OR. & +! mp_physics == FER_MP_HIRES_ADVECT .OR. & +! mp_physics == ETAMP_HWRF ) THEN +!#else +! IF ( mp_physics == FER_MP_HIRES .OR. & +! mp_physics == FER_MP_HIRES_ADVECT) THEN +!#endif +! DO K=kts,kte +! qi1d(k) = qi3d(i,k,j) +! qs1d(k) = 0.0 +! qc1d(k) = qc3d(i,k,j) +! qi1d(k) = max(0.,qi1d(k)) +! qc1d(k) = max(0.,qc1d(k)) +! ENDDO +! ENDIF +!-- Trude + +! EMISS0=EMISS(I,J) +! GLW0=0. +! OLR0=0. +! TSFC=TSK(I,J) + DO K=kts,kte + QV1D(K)=AMAX1(QV1D(K),1.E-12) + ENDDO + +! Set up input for shortwave + ncol = 1 +! Add extra layer from top of model to top of atmosphere + nlay = (kte - kts + 1) + 1 + +! Select cloud overlap assumption (1 = random, 2 = maximum-random, 3 = maximum, 4 = exponential, 5 = exponential-random + icld=cldovrlp ! J. Henderson AER assign namelist variable cldovrlp to existing icld + +! Select cloud liquid and ice optics parameterization options +! For passing in cloud optical properties directly: +! inflgsw = 0 +! iceflgsw = 0 +! liqflgsw = 0 +! For passing in cloud physical properties; cloud optics parameterized in RRTMG: + inflgsw = 2 + iceflgsw = 3 + liqflgsw = 1 + +!Mukul change the flags here with reference to the new effective cloud/ice/snow radius + IF (ICLOUD .ne. 0) THEN + IF ( has_reqc .ne. 0) THEN + inflgsw = 3 + DO K=kts,kte + recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6) + if (mp_options.ne.5) then + recloud1D(ncol,K)=10.5 + endif + if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean + recloud1D(ncol,K) = 10.5 + elseif (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land + recloud1D(ncol,K) = 7.5 + endif + ENDDO + ELSE + DO K=kts,kte +#if (EM_CORE==1) + recloud1D(ncol,K) = 5.0 +#else + recloud1D(ncol,K) = 10.0 ! was 5.0 +#endif + ENDDO + ENDIF + + IF ( has_reqi .ne. 0) THEN + inflgsw = 4 + iceflgsw = 4 + DO K=kts,kte + reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6) + if (mp_options.ne.5) then + reice1D(ncol,K)=30 + endif + if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then + idx_rei = int(t3d(i,k,j)-179.) + idx_rei = min(max(idx_rei,1),75) + corr = t3d(i,k,j) - int(t3d(i,k,j)) + reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + & + & retab(idx_rei+1)*corr + reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0) + endif + ENDDO + ELSE + DO K=kts,kte + reice1D(ncol,K) = 10. + ENDDO + ENDIF + + IF ( has_reqs .ne. 0) THEN + inflgsw = 5 + iceflgsw = 5 + DO K=kts,kte + resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6) + if (mp_options.ne.5) then + resnow1D(ncol,K)=500 + endif + ENDDO + ELSE + DO K=kts,kte +#if (EM_CORE==1) + resnow1D(ncol,K) = 10.0 +#else + tem2 = 25.0 !- was 10.0 + tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3) + if (tem3>thresh) then !- Only when IWC>1.e-9 g m^-3 + tem1=t1d(k)-273.15 + if (tem1 < -50.0) then + tem2 = re_50C*tem3**0.109 + elseif (tem1 < -40.0) then + tem2 = re_40C*tem3**0.08 + elseif (tem1 < -30.0) then + tem2 = re_30C*tem3**0.055 + else + tem2 = re_20C*tem3**0.031 + endif + tem2 = max(25.,tem2) + endif + reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice <= 140 microns +#endif + ENDDO + ENDIF + +! special case for P3 microphysics +! put ice into snow category for optics, then set ice to zero + IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN + inflgsw = 5 + iceflgsw = 5 + DO K=kts,kte + resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6) + QS1D(K)=QI3D(I,K,J) + QI1D(K)=0. + reice1D(ncol,K)=10. + END DO + + END IF + + ENDIF + +! Set cosine of solar zenith angle + coszen(ncol) = coszrs +! Set solar constant + scon = solcon +! For Earth/Sun distance adjustment in RRTMG +! dyofyr = julday +! adjes = 0.0 +! For WRF, solar constant is already provided with eccentricity adjustment, +! so do not do this in RRTMG + dyofyr = 0 + adjes = 1.0 + +! Layer indexing goes bottom to top here for all fields. +! Water vapor and ozone are converted from mmr to vmr. +! Pressures are in units of mb here. + plev(ncol,1) = pw1d(1) + tlev(ncol,1) = tw1d(1) + tsfc(ncol) = tsk(i,j) + do k = kts, kte + play(ncol,k) = p1d(k) + plev(ncol,k+1) = pw1d(k+1) + pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1) + tlay(ncol,k) = t1d(k) + tlev(ncol,k+1) = tw1d(k+1) + h2ovmr(ncol,k) = qv1d(k) * amdw + co2vmr(ncol,k) = co2 + o2vmr(ncol,k) = o2 + ch4vmr(ncol,k) = ch4 + n2ovmr(ncol,k) = n2o + enddo + +! mji - Derive height of each layer mid-point from layer thickness. +! Needed for exponential (icld=4) and exponential-random overlap option (icld=5) only. + dzsum = 0.0 + do k = kts, kte + dz = dz1d(k) + hgt(ncol,k) = dzsum + 0.5*dz + dzsum = dzsum + dz + enddo + +! Define profile values for extra layer from model top to top of atmosphere. +! The top layer temperature for all gridpoints is set to the top layer-1 +! temperature plus a constant (0 K) that represents an isothermal layer +! above ptop. Top layer interface temperatures are linearly interpolated +! from the layer temperatures. + + play(ncol,kte+1) = 0.5 * plev(ncol,kte+1) + tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0 + plev(ncol,kte+2) = 1.0e-5 + tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0 + tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0 + h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte) + co2vmr(ncol,kte+1) = co2vmr(ncol,kte) + o2vmr(ncol,kte+1) = o2vmr(ncol,kte) + ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte) + n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte) + +! mji - Fill in height array above model top to top of atmosphere using +! dz from model top layer for completeness, though this information is not +! likely to be used by the exponential-random cloud overlap method. + hgt(ncol,kte+1) = dzsum + 0.5*dz + +! Get ozone profile including amount in extra layer above model top + call inirad (o3mmr,plev,kts,kte) + + if(present(o33d)) then + do k = kts, kte+1 + o3vmr(ncol,k) = o3mmr(k) * amdo + IF ( PRESENT( O33D ) ) THEN + if(o3input .eq. 2)then + if(k.le.kte)then + o3vmr(ncol,k) = o31d(k) + else +! apply shifted climatology profile above model top + o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo + if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo + endif + endif + ENDIF + enddo + else + do k = kts, kte+1 + o3vmr(ncol,k) = o3mmr(k) * amdo + enddo + endif + +! Set surface albedo for direct and diffuse radiation in UV/visible and +! near-IR spectral regions +! -------------- Zhenxin 2011-06-20 ----------- ! + +! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- ! +! asdir(ncol) = albedo(i,j) +! asdif(ncol) = albedo(i,j) +! aldir(ncol) = albedo(i,j) +! aldif(ncol) = albedo(i,j) +! ------- End of Comments ------ ! + +! ------- 2. New Addiation ------ ! + IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN + asdir(ncol) = ALSWVISDIR(I,J) + asdif(ncol) = ALSWVISDIF(I,J) + aldir(ncol) = ALSWNIRDIR(I,J) + aldif(ncol) = ALSWNIRDIF(I,J) + ELSE + asdir(ncol) = albedo(i,j) + asdif(ncol) = albedo(i,j) + aldir(ncol) = albedo(i,j) + aldif(ncol) = albedo(i,j) + ENDIF + +! ---------- End of Addiation ------! +! ---------- End of fds_Zhenxin 2011-06-20 --------------! + +! Define cloud optical properties for radiation (inflgsw = 0) +! This option is not currently active +! Cloud and precipitation paths in g/m2 +! qi=0 if no ice phase +! qs=0 if no ice phase + if (inflgsw .eq. 0) then + +! Set cloud fraction and cloud optical properties here; not yet active + do k = kts, kte + cldfrac(ncol,k) = cldfra1d(k) + do nb = 1, nbndsw + taucld(nb,ncol,k) = 0.0 + ssacld(nb,ncol,k) = 1.0 + asmcld(nb,ncol,k) = 0.0 + fsfcld(nb,ncol,k) = 0.0 + enddo + enddo + +! Zero out cloud physical property arrays; not used when passing optical properties +! into radiation + do k = kts, kte + clwpth(ncol,k) = 0.0 + ciwpth(ncol,k) = 0.0 + rel(ncol,k) = 10.0 + rei(ncol,k) = 10. + enddo + endif + +! Define cloud physical properties for radiation (inflgsw = 1 or 2) +! Cloud fraction +! Set cloud arrays if passing cloud physical properties into radiation + if (inflgsw .gt. 0) then + do k = kts, kte + cldfrac(ncol,k) = cldfra1d(k) + enddo + +! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method) + pcols = ncol + pver = kte - kts + 1 + gravmks = g + landfrac(ncol) = 2.-XLAND(I,J) + landm(ncol) = landfrac(ncol) + snowh(ncol) = 0.001*SNOW(I,J) + icefrac(ncol) = XICE(I,J) + +! From module_ra_cam: Convert liquid and ice mixing ratios to water paths; +! pdel is in mb here; convert back to Pa (*100.) +! Water paths are in units of g/m2 +! snow added as ice cloud (JD 091022) + do k = kts, kte + gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path. + cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path. + cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path. + end do + +! Mukul +!..The ice water path is already sum of cloud ice and snow, but when we have explicit +!.. ice effective radius, overwrite the ice path with only the cloud ice variable, +!.. leaving out the snow for its own effect. + if(iceflgsw.ge.4)then + do k = kts, kte + gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path. + end do + end if + +!..Here the snow path is adjusted if (radiation) effective radius of snow is +!.. larger than what we currently have in the lookup tables. Since mass goes +!.. rather close to diameter squared, adjust the mixing ratio of snow used +!.. to compute its water path in combination with the max diameter. Not a +!.. perfect fix, but certainly better than using all snow mass when diameter is +!.. far larger than table currently contains and crystal sizes much larger than +!.. about 140 microns have lesser impact than those much smaller sizes. + + if(iceflgsw.eq.5)then + do k = kts, kte + snow_mass_factor = 1.0 + if (resnow1d(ncol,k) .gt. 130.)then + snow_mass_factor = (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k)) + resnow1d(ncol,k) = 130.0 + endif + gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path. + csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k)) + end do + end if + + +!link the aerosol feedback to cloud -czhao + if( PRESENT( progn ) ) then + if (progn == 1) then +!jdfcz if(prescribe==0) then + + pi = 4.*atan(1.0) + third=1./3. + rhoh2o=1.e3 + relconst=3/(4.*pi*rhoh2o) +! minimun liquid water path to calculate rel +! corresponds to optical depth of 1.e-3 for radius 4 microns. + lwpmin=3.e-5 + do k = kts, kte + reliq(ncol,k) = 10. + if( PRESENT( F_QNDROP ) ) then + if( F_QNDROP ) then + if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. & + qndrop1d(k).gt.1000. ) then + reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m +! apply scaling from Martin et al., JAS 51, 1830. + reliq(ncol,k)=1.1*reliq(ncol,k) + reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns + reliq(ncol,k)=max(reliq(ncol,k),4.) + reliq(ncol,k)=min(reliq(ncol,k),20.) + end if + end if + end if + end do +!jdfcz else ! prescribe +! following Kiehl +! call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) +! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d) +!jdfcz endif + else ! progn (progn=1) + call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + else !progn (PRESENT) + call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + +! following Kristjansson and Mitchell + call reicalc(ncol, pcols, pver, tlay, reice) + + + +!..If we already have effective radius of cloud and ice, then just overwrite what +!.. was computed in the relcalc and reicalc subroutines above. + + if (inflgsw .ge. 3) then + do k = kts, kte + reliq(ncol,k) = recloud1d(ncol,k) + end do + endif +#if (EM_CORE==1) + if (iceflgsw .ge. 4) then +#else + if (iceflgsw .ge. 3) then !BSF: was .ge. 4 +#endif + do k = kts, kte + reice(ncol,k) = reice1d(ncol,k) + end do + endif + + +#if 0 + if (i==80.and.j==30) then +#if defined( DM_PARALLEL ) && ! defined( STUBMPI) + if( PRESENT( progn ) ) write(0,*) 'aerosol indirect',progn + write(0,*)'sw water eff radius',reliq(ncol,10),reliq(ncol,20),reliq(ncol,25) + write(0,*)'sw ice eff radius',reice(ncol,10),reice(ncol,20),reice(ncol,25) +#endif + endif +#endif + + +! Limit upper bound of reice for Fu ice parameterization and convert +! from effective radius to generalized effective size (*1.0315; Fu, 1996) + if (iceflgsw .eq. 3) then + do k = kts, kte + reice(ncol,k) = reice(ncol,k) * 1.0315 + reice(ncol,k) = min(140.0,reice(ncol,k)) + end do + endif + +!if CAMMGMP is used, use output from CAMMGMP +!PMA + if(is_CAMMGMP_used) then + do k = kts, kte + if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then + reice(ncol,k) = iradius(i,k,j) + else + reice(ncol,k) = 25. + end if + reice(ncol,k) = max(5., min(140.0,reice(ncol,k))) + if ( qc1d(k) .gt. 1.e-20) then + reliq(ncol,k) = lradius(i,k,j) + else + reliq(ncol,k) = 10. + end if + reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k))) + enddo + endif + +! Set cloud physical property arrays + do k = kts, kte + clwpth(ncol,k) = cliqwp(ncol,k) + ciwpth(ncol,k) = cicewp(ncol,k) + rel(ncol,k) = reliq(ncol,k) + rei(ncol,k) = reice(ncol,k) + enddo + +!Mukul + if (inflgsw .eq. 5) then + do k = kts, kte + cswpth(ncol,k) = csnowp(ncol,k) + res(ncol,k) = resnow1d(ncol,k) + end do + else + do k = kts, kte + cswpth(ncol,k) = 0.0 + res(ncol,k) = 10.0 + end do + endif + +! Zero out cloud optical properties here, calculated in radiation + do k = kts, kte + do nb = 1, nbndsw + taucld(nb,ncol,k) = 0.0 + ssacld(nb,ncol,k) = 1.0 + asmcld(nb,ncol,k) = 0.0 + fsfcld(nb,ncol,k) = 0.0 + enddo + enddo + endif + +! No clouds are allowed in the extra layer from model top to TOA + clwpth(ncol,kte+1) = 0. + ciwpth(ncol,kte+1) = 0. + cswpth(ncol,kte+1) = 0. + rel(ncol,kte+1) = 10. + rei(ncol,kte+1) = 10. + res(ncol,kte+1) = 10. + cldfrac(ncol,kte+1) = 0. + do nb = 1, nbndsw + taucld(nb,ncol,kte+1) = 0. + ssacld(nb,ncol,kte+1) = 1. + asmcld(nb,ncol,kte+1) = 0. + fsfcld(nb,ncol,kte+1) = 0. + enddo + + iplon = 1 + irng = 0 + permuteseed = 1 + +! Sub-column generator for McICA +! mji - Add layer height needed for exponential (icld=4) and exponential-random (icld=5) overlap options + call mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, hgt, & + cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, & + cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, & + taucmcl, ssacmcl, asmcmcl, fsfcmcl) + + +!-------------------------------------------------------------------------- +! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010 +!-------------------------------------------------------------------------- +! by layer for each RRTMG shortwave band +! No aerosols in top layer above model top (kte+1). +!cz do nb = 1, nbndsw +!cz do k = kts, kte+1 +!cz tauaer(ncol,k,nb) = 0. +!cz ssaaer(ncol,k,nb) = 1. +!cz asmaer(ncol,k,nb) = 0. +!cz enddo +!cz enddo + +! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao +! + do nb = 1, nbndsw + do k = kts,kte+1 + tauaer(ncol,k,nb) = 0. + ssaaer(ncol,k,nb) = 1. + asmaer(ncol,k,nb) = 0. + end do + end do + + if ( associated (tauaer3d_sw) ) then +! ---- jararias 11/2012 + do nb=1,nbndsw + do k=kts,kte + tauaer(ncol,k,nb)=tauaer3d_sw(i,k,j,nb) + ssaaer(ncol,k,nb)=ssaaer3d_sw(i,k,j,nb) + asmaer(ncol,k,nb)=asyaer3d_sw(i,k,j,nb) + end do + end do + end if + +#if ( WRF_CHEM == 1 ) + IF ( AER_RA_FEEDBACK == 1) then + do nb = 1, nbndsw + wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um + do k = kts,kte !wig + +! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths +! tauaer - use angstrom exponent + if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then + ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.) + tauaer(ncol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang + !tauaer(ncol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang + if (i==30.and.j==49.and.k==2.and.nb==12) then + write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j) + print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j) + write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang + print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang + endif +! ssa - linear interpolation; extrapolation + slope=(waer600(i,k,j)-waer400(i,k,j))/.2 + ssaaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j) + if(ssaaer(ncol,k,nb).lt.0.4) ssaaer(ncol,k,nb)=0.4 + if(ssaaer(ncol,k,nb).ge.1.0) ssaaer(ncol,k,nb)=1.0 +! g - linear interpolation;extrapolation + slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2 + asmaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles + if(asmaer(ncol,k,nb).lt.0.5) asmaer(ncol,k,nb)=0.5 + if(asmaer(ncol,k,nb).ge.1.0) asmaer(ncol,k,nb)=1.0 + endif + end do ! k + end do ! nb + +!wig beg + do nb = 1, nbndsw + slope = 0. !use slope as a sum holder + do k = kts,kte + slope = slope + tauaer(ncol,k,nb) + end do + if( slope < 0. ) then + write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb + !call wrf_error_fatal(msg) + error stop msg + else if( slope > 6. ) then + !call wrf_message("-------------------------") + write(*,*) "-------------------------" + write(msg,'("WARNING: Large total sw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb + write(*,*) msg + !call wrf_message(msg) + !call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer") + wrirte(*,*) "Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer" + do k=kts,kte + write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), & + tauaer600(i,k,j), tauaer999(i,k,j),tauaer(ncol,k,nb) + !call wrf_message(msg) + write(*,*) msg + !czhao set an up-limit here to avoid segmentation fault + !from extreme AOD + tauaer(ncol,k,nb)=tauaer(ncol,k,nb)*6.0/slope + end do + + !call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999") + write(*,*) "Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999" + do k=kts,kte + write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), & + gaer600(i,k,j), gaer999(i,k,j) + !call wrf_message(msg) + write(*,*) msg + end do + + !call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999") + write(*,*) "Diagnostics 3: k, waer300, waer400, waer600, waer999" + do k=kts,kte + write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), & + waer600(i,k,j), waer999(i,k,j) + !call wrf_message(msg) + write(*,*) msg + end do + + !call wrf_message("Diagnostics 4: k, ssaal, asyal, taual") + write(*,*) "Diagnostics 4: k, ssaal, asyal, taual" + do k=kts-1,kte + write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb) +! call wrf_message(msg) + write(*,*) msg + end do +! call wrf_message("-------------------------") + write(*,*) "-------------------------" + endif + enddo ! nb + endif ! aer_ra_feedback +#endif + + +! Zero array for input of aerosol optical thickness for use with +! ECMWF aerosol types (not used) + do na = 1, naerec + do k = kts, kte+1 + ecaer(ncol,k,na) = 0. + enddo + enddo + + IF ( PRESENT( aerod ) ) THEN + if ( aer_opt .eq. 0 ) then + do na = 1, naerec + do k = kts, kte+1 + ecaer(ncol,k,na) = 0. + enddo + enddo + else if ( aer_opt .eq. 1 ) then + do na = 1, naerec + do k = kts, kte + ecaer(ncol,k,na) = aerod(i,k,j,na) + enddo +! assuming 0 or same value at the top? +! ecaer(ncol,kte+1,na) = ecaer(ncol,kte,na) + ecaer(ncol,kte+1,na) = 0. + enddo + endif + ENDIF + +! Call RRTMG shortwave radiation model + + call rrtmg_sw & + (ncol ,nlay ,icld , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + asdir ,asdif ,aldir ,aldif , & + coszen ,adjes ,dyofyr ,scon , & + inflgsw ,iceflgsw,liqflgsw,cldfmcl , & + taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , & + ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl, & + tauaer ,ssaaer ,asmaer ,ecaer , & + swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln, swdflxcln, aer_opt, & +! ----- Zhenxin added for ssib coupiling 2011-06-20 --------! + sibvisdir, sibvisdif, sibnirdir, sibnirdif, & +! -------------------- End of addiation by Zhenxin 2011-06-20 ------! + swdkdir, swdkdif, & ! jararias, 2012/08/10 + swdkdirc & ! PAJ + ,calc_clean_atm_diag & + ) + + +! Output net absorbed shortwave surface flux and shortwave cloud forcing +! at the top of atmosphere (W/m2) + gsw(i,j) = swdflx(1,1) - swuflx(1,1) + swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2) - swuflxc(1,kte+2)) + +! Output up and down toa fluxes for total and clear sky + if (present(swupt)) swupt(i,j) = swuflx(1,kte+2) + if (present(swuptc)) swuptc(i,j) = swuflxc(1,kte+2) + if (present(swdnt)) swdnt(i,j) = swdflx(1,kte+2) + if (present(swdntc)) swdntc(i,j) = swdflxc(1,kte+2) +! Output up and down surface fluxes for total and clear sky + if (present(swupb)) swupb(i,j) = swuflx(1,1) + if (present(swupbc)) swupbc(i,j) = swuflxc(1,1) + if (present(swdnb)) swdnb(i,j) = swdflx(1,1) +! Added by Zhenxin for 4 compenants of swdown radiation + if (present(swvisdir)) swvisdir(i,j) = sibvisdir(1,1) + if (present(swvisdif)) swvisdif(i,j) = sibvisdif(1,1) + if (present(swnirdir)) swnirdir(i,j) = sibnirdir(1,1) + if (present(swnirdif)) swnirdif(i,j) = sibnirdif(1,1) +! Ended, Zhenxin (2011/06/20) + if (present(swdnbc)) swdnbc(i,j) = swdflxc(1,1) + if(calc_clean_atm_diag .gt. 0)then + swuptcln(i,j) = swuflxcln(1,kte+2) + swdntcln(i,j) = swdflxcln(1,kte+2) + swupbcln(i,j) = swuflxcln(1,1) + swdnbcln(i,j) = swdflxcln(1,1) + end if +! endif + if (present(swddir)) then + swddir(i,j) = swdkdir(1,1) ! jararias 2013/08/10 + swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10 + swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10 + swdownc(i, j) = swdflxc(1,1) ! PAJ: clear-sky GHI + swddirc(i,j) = swdkdirc(1,1) ! PAJ: clear-sky direct normal irradiance + swddnic(i,j) = swddirc(i,j) / coszrs ! PAJ: clear-sky direct normal irradiance + endif +! Output up and down layer fluxes for total and clear sky. +! Vertical ordering is from bottom to top in units of W m-2. + if ( present (swupflx) ) then + do k=kts,kte+2 + swupflx(i,k,j) = swuflx(1,k) + swupflxc(i,k,j) = swuflxc(1,k) + swdnflx(i,k,j) = swdflx(1,k) + swdnflxc(i,k,j) = swdflxc(1,k) + enddo + endif + +! Output heating rate tendency; convert heating rate from K/d to K/s +! Heating rate arrays are ordered vertically from bottom to top here. + do k=kts,kte + tten1d(k) = swhr(ncol,k)/86400. + rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j) + enddo + else + if (present(swupt)) then +! Output up and down toa fluxes for total and clear sky + swupt(i,j) = 0. + swuptc(i,j) = 0. + swdnt(i,j) = 0. + swdntc(i,j) = 0. +! Output up and down surface fluxes for total and clear sky + swupb(i,j) = 0. + swupbc(i,j) = 0. + swdnb(i,j) = 0. + swdnbc(i,j) = 0. + swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20) + swvisdif(i,j) = 0. + swnirdir(i,j) = 0. + swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20) + if(calc_clean_atm_diag .gt. 0)then + swuptcln(i,j) = 0. + swdntcln(i,j) = 0. + swupbcln(i,j) = 0. + swdnbcln(i,j) = 0. + end if + endif + if (present(swddir)) then + swddir(i,j) = 0. ! jararias 2013/08/10 + swddni(i,j) = 0. ! jararias 2013/08/10 + swddif(i,j) = 0. ! jararias 2013/08/10 + swdownc(i, j) = 0.0 ! PAJ + swddnic(i,j) = 0.0 ! PAJ + swddirc(i,j) = 0.0 ! PAJ + swcf(i,j) = 0. + endif + endif +! + end do i_loop + end do j_loop + + +!------------------------------------------------------------------- + + END SUBROUTINE RRTMG_SWRAD + + +!==================================================================== + SUBROUTINE rrtmg_swinit( & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + +! Read in absorption coefficients and other data + IF ( allowed_to_read ) THEN + CALL rrtmg_swlookuptable + ENDIF + +! Perform g-point reduction and other initializations +! Specific heat of dry air (cp) used in flux to heating rate conversion factor. + call rrtmg_sw_ini(cp) + + END SUBROUTINE rrtmg_swinit + + +! ************************************************************************** + SUBROUTINE rrtmg_swlookuptable +! ************************************************************************** +USE io_routines, ONLY: io_newunit, io_read +IMPLICIT NONE + +! Local + INTEGER :: i + LOGICAL :: opened + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER*80 errmess + INTEGER rrtmg_unit + + rrtmg_unit = io_newunit() + IF ( rrtmg_unit < 0 ) THEN + error stop 'module_ra_rrtmg_sw: rrtm_swlookuptable: Can not find unused fortran unit to read in lookup table.' + ENDIF + + call sw_kgb16(rrtmg_unit) + call sw_kgb17(rrtmg_unit) + call sw_kgb18(rrtmg_unit) + call sw_kgb19(rrtmg_unit) + call sw_kgb20(rrtmg_unit) + call sw_kgb21(rrtmg_unit) + call sw_kgb22(rrtmg_unit) + call sw_kgb23(rrtmg_unit) + call sw_kgb24(rrtmg_unit) + call sw_kgb25(rrtmg_unit) + call sw_kgb26(rrtmg_unit) + call sw_kgb27(rrtmg_unit) + call sw_kgb28(rrtmg_unit) + call sw_kgb29(rrtmg_unit) + + CLOSE (rrtmg_unit) + + RETURN +9009 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error opening RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + END SUBROUTINE rrtmg_swlookuptable + +! ************************************************************************** +! RRTMG Shortwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original by J.Delamere, Atmospheric & Environmental Research. +! Reformatted for F90: JJMorcrette, ECMWF +! Revision for GCMs: Michael J. Iacono, AER, July 2002 +! Further F90 reformatting: Michael J. Iacono, AER, June 2006 +! +! This file contains 14 READ statements that include the +! absorption coefficients and other data for each of the 14 shortwave +! spectral bands used in RRTMG_SW. Here, the data are defined for 16 +! g-points, or sub-intervals, per band. These data are combined and +! weighted using a mapping procedure in module RRTMG_SW_INIT to reduce +! the total number of g-points from 224 to 112 for use in the GCM. +! ************************************************************************** + +! ************************************************************************** + subroutine sw_kgb16(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat1, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_16_sw.nc", "rayl", rayl) + call io_read0d("rrtmg_support/strrat1_16_sw.nc", "strrat1", strrat1) + call io_read0di("rrtmg_support/layreffr_16_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_16_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_16_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_16_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_16_sw.nc", "forrefo", forrefo) + call io_read1d("rrtmg_support/sfluxrefo_16_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb16 + +! ************************************************************************** + subroutine sw_kgb17(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_17_sw.nc", "rayl", rayl) + call io_read0d("rrtmg_support/strrat_17_sw.nc", "strrat", strrat) + call io_read0di("rrtmg_support/layreffr_17_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_17_sw.nc", "kao", kao) + call io_read4d("rrtmg_support/kbo_17_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_17_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_17_sw.nc", "forrefo", forrefo) + call io_read2d("rrtmg_support/sfluxrefo_17_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb17 + +! ************************************************************************** + subroutine sw_kgb18(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_18_sw.nc", "rayl", rayl) + call io_read0d("rrtmg_support/strrat_18_sw.nc", "strrat", strrat) + call io_read0di("rrtmg_support/layreffr_18_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_18_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_18_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_18_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_18_sw.nc", "forrefo", forrefo) + call io_read2d("rrtmg_support/sfluxrefo_18_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb18 + +! ************************************************************************** + subroutine sw_kgb19(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_19_sw.nc", "rayl", rayl) + call io_read0d("rrtmg_support/strrat_19_sw.nc", "strrat", strrat) + call io_read0di("rrtmg_support/layreffr_19_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_19_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_19_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_19_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_19_sw.nc", "forrefo", forrefo) + call io_read2d("rrtmg_support/sfluxrefo_19_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb19 + +! ************************************************************************** + subroutine sw_kgb20(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absch4o, rayl, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1. + +! Array absch4o contains the absorption coefficients for methane. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_20_sw.nc", "rayl", rayl) + call io_read1d("rrtmg_support/absch4o_20_sw.nc", "absch4o", absch4o) + call io_read0di("rrtmg_support/layreffr_20_sw.nc", "layreffr", layreffr) + call io_read3d("rrtmg_support/kao_20_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_20_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_20_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_20_sw.nc", "forrefo", forrefo) + call io_read1d("rrtmg_support/sfluxrefo_20_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb20 + +! ************************************************************************** + subroutine sw_kgb21(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_21_sw.nc", "rayl", rayl) + call io_read0d("rrtmg_support/strrat_21_sw.nc", "strrat", strrat) + call io_read0di("rrtmg_support/layreffr_21_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_21_sw.nc", "kao", kao) + call io_read4d("rrtmg_support/kbo_21_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_21_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_21_sw.nc", "forrefo", forrefo) + call io_read2d("rrtmg_support/sfluxrefo_21_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb21 + +! ************************************************************************** + subroutine sw_kgb22(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296_rb,260_rb,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_22_sw.nc", "rayl", rayl) + call io_read0d("rrtmg_support/strrat_22_sw.nc", "strrat", strrat) + call io_read0di("rrtmg_support/layreffr_22_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_22_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_22_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_22_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_22_sw.nc", "forrefo", forrefo) + call io_read2d("rrtmg_support/sfluxrefo_22_sw.nc", "sfluxrefo", sfluxrefo) + + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb22 + +! ************************************************************************** + subroutine sw_kgb23(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, & + raylo, givfac, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v for this band + +! Array givfac is the average Giver et al. correction factor for this band. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read1d("rrtmg_support/raylo_23_sw.nc", "raylo", raylo) + call io_read0d("rrtmg_support/givfac_23_sw.nc", "givfac", givfac) + call io_read0di("rrtmg_support/layreffr_23_sw.nc", "layreffr", layreffr) + call io_read3d("rrtmg_support/kao_23_sw.nc", "kao", kao) + call io_read2d("rrtmg_support/selfrefo_23_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_23_sw.nc", "forrefo", forrefo) + call io_read1d("rrtmg_support/sfluxrefo_23_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb23 + +! ************************************************************************** + subroutine sw_kgb24(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + raylao, raylbo, abso3ao, abso3bo, strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Arrays raylao and raylbo contain the Rayleigh extinction coefficient at +! all v for this band for the upper and lower atmosphere. + +! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at +! all v for this band for the upper and lower atmosphere. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read2d("rrtmg_support/raylao_24_sw.nc", "raylao", raylao) + call io_read1d("rrtmg_support/raylbo_24_sw.nc", "raylbo", raylbo) + call io_read1d("rrtmg_support/abso3ao_24_sw.nc", "abso3ao", abso3ao) + call io_read1d("rrtmg_support/abso3bo_24_sw.nc", "abso3bo", abso3bo) + call io_read0d("rrtmg_support/strrat_24_sw.nc", "strrat", strrat) + call io_read0di("rrtmg_support/layreffr_24_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_24_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_24_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_24_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_24_sw.nc", "forrefo", forrefo) + call io_read2d("rrtmg_support/sfluxrefo_24_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb24 + +! ************************************************************************** + subroutine sw_kgb25(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg25, only : kao, sfluxrefo, & + raylo, abso3ao, abso3bo, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1. + +! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at +! all v for this band for the upper and lower atmosphere. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + call io_read1d("rrtmg_support/raylo_25_sw.nc", "raylo", raylo) + call io_read1d("rrtmg_support/abso3ao_25_sw.nc", "abso3ao", abso3ao) + call io_read1d("rrtmg_support/abso3bo_25_sw.nc", "abso3bo", abso3bo) + call io_read0di("rrtmg_support/layreffr_25_sw.nc", "layreffr", layreffr) + call io_read3d("rrtmg_support/kao_25_sw.nc", "kao", kao) + call io_read1d("rrtmg_support/sfluxrefo_25_sw.nc", "sfluxrefo", sfluxrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb25 + +! ************************************************************************** + subroutine sw_kgb26(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg26, only : sfluxrefo, raylo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v for this band. + + call io_read1d("rrtmg_support/raylo_26_sw.nc", "raylo", raylo) + call io_read1d("rrtmg_support/sfluxrefo_26_sw.nc", "sfluxrefo", sfluxrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb26 + +! ************************************************************************** + subroutine sw_kgb27(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, & + scalekur, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. +! The values in array sfluxrefo were obtained using the "low resolution" +! version of the Kurucz solar source function. For unknown reasons, +! the total irradiance in this band differs from the corresponding +! total in the "high-resolution" version of the Kurucz function. +! Therefore, these values are scaled by the factor SCALEKUR. + +! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + call io_read1d("rrtmg_support/raylo_27_sw.nc", "raylo", raylo) + call io_read0di("rrtmg_support/layreffr_27_sw.nc", "layreffr", layreffr) + call io_read0d("rrtmg_support/scalekur_27_sw.nc", "scalekur", scalekur) + call io_read3d("rrtmg_support/kao_27_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_27_sw.nc", "kbo", kbo) + call io_read1d("rrtmg_support/sfluxrefo_27_sw.nc", "sfluxrefo", sfluxrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb27 + +! ************************************************************************** + subroutine sw_kgb28(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg28, only : kao, kbo, sfluxrefo, & + rayl, strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + + call io_read0d("rrtmg_support/rayl_28_sw.nc", "rayl", rayl) + call io_read0d("rrtmg_support/strrat_28_sw.nc", "strrat", strrat) + call io_read0di("rrtmg_support/layreffr_28_sw.nc", "layreffr", layreffr) + call io_read4d("rrtmg_support/kao_28_sw.nc", "kao", kao) + call io_read4d("rrtmg_support/kbo_28_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/sfluxrefo_28_sw.nc", "sfluxrefo", sfluxrefo) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + end subroutine sw_kgb28 + +! ************************************************************************** + subroutine sw_kgb29(rrtmg_unit) +! ************************************************************************** + USE io_routines + use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absh2oo, absco2o, rayl, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess +! logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1. + +! Array absh2oo contains the water vapor absorption coefficient for this band. + +! Array absco2o contains the carbon dioxide absorption coefficient for this band. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + + call io_read0d("rrtmg_support/rayl_29_sw.nc", "rayl", rayl) + call io_read1d("rrtmg_support/absh2oo_29_sw.nc", "absh2oo", absh2oo) + call io_read1d("rrtmg_support/absco2o_29_sw.nc", "absco2o", absco2o) + call io_read0di("rrtmg_support/layreffr_29_sw.nc", "layreffr", layreffr) + call io_read3d("rrtmg_support/kao_29_sw.nc", "kao", kao) + call io_read3d("rrtmg_support/kbo_29_sw.nc", "kbo", kbo) + call io_read2d("rrtmg_support/selfrefo_29_sw.nc", "selfrefo", selfrefo) + call io_read2d("rrtmg_support/forrefo_29_sw.nc", "forrefo", forrefo) + call io_read1d("rrtmg_support/sfluxrefo_29_sw.nc", "sfluxrefo", sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit + error stop errmess + + end subroutine sw_kgb29 + +!------------------------------------------------------------------ + +END MODULE module_ra_rrtmg_sw +!*********************************************************************** diff --git a/src/physics/ra_simple.f90 b/src/physics/ra_simple.f90 index e3902412..6a5ca8dd 100644 --- a/src/physics/ra_simple.f90 +++ b/src/physics/ra_simple.f90 @@ -56,7 +56,7 @@ module module_ra_simple real, allocatable, dimension(:,:) :: cos_lat_m,sin_lat_m integer :: nrad_layers real, parameter :: So = 1367.0 ! Solar "constant" W/m^2 - real, parameter :: qcmin = 1e-5 ! Minimum "cloud" water content to affect radiation + real, parameter :: qcmin = 1e-6 ! Minimum "cloud" water content to affect radiation contains subroutine ra_simple_init(domain,options) @@ -97,8 +97,8 @@ function shortwave(day_frac, cloud_cover, solar_elevation, ims,ime, its,ite) shortwave(its:ite) = So * (1 + 0.035 * cos(day_frac(its:ite) * 2*pi)) * sin_solar_elev * (0.48 + 0.29 * sin_solar_elev) - ! note it is cloud_cover**3.4 in Reiff, but this makes almost no difference and integer powers are fast - shortwave(its:ite) = shortwave(its:ite) * (1 - (0.75 * (cloud_cover(its:ite)**3)) ) + ! note it is cloud_cover**3.4 in Reiff, but this makes almost no difference and integer powers are fast so could use **3 + shortwave(its:ite) = shortwave(its:ite) * (1 - (0.75 * (cloud_cover(its:ite)**3.4)) ) end function shortwave @@ -136,9 +136,9 @@ function cloudfrac(rh, qc, ims,ime, its,ite) where(temporary < 0.0001) temporary=0.0001 cloudfrac(its:ite) = qc(its:ite) - qcmin - where(cloudfrac < 0) cloudfrac = 0 + where(cloudfrac < 5e-8) cloudfrac = 5e-8 - cloudfrac(its:ite) = (rh(its:ite)**0.25) * (1-exp((-2000*(cloudfrac(its:ite))) / temporary)) + cloudfrac(its:ite) = (rh(its:ite)**0.25) * (1 - exp((-2000*(cloudfrac(its:ite))) / temporary)) where(cloudfrac < 0) cloudfrac = 0 where(cloudfrac > 1) cloudfrac = 1 @@ -190,7 +190,8 @@ end function calc_solar_elevation subroutine ra_simple(theta, pii, qv, qc, qs, qr, p, swdown, lwdown, cloud_cover, lat, lon, date, options, dt, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) + its, ite, jts, jte, kts, kte, & + F_runlw) implicit none real, intent(inout):: theta (ims:ime, kms:kme, jms:jme) real, intent(in) :: pii (ims:ime, kms:kme, jms:jme) @@ -209,15 +210,20 @@ subroutine ra_simple(theta, pii, qv, qc, qs, qr, p, swdown, lwdown, cloud_cover, real, intent(in) :: dt integer, intent(in) :: ims, ime, jms, jme, kms, kme integer, intent(in) :: its, ite, jts, jte, kts, kte + logical, intent(in), optional :: F_runlw + logical :: runlw real :: coolingrate integer :: j, k real, allocatable, dimension(:) :: rh, T_air, solar_elevation, hydrometeors, day_frac + runlw = .True. + if (present(F_runlw)) runlw = F_runlw + !$omp parallel private(j,k,rh,T_air,solar_elevation,hydrometeors,day_frac,coolingrate) & !$omp shared(theta,pii,qv,p,qc,qs,qr,date,lon,cloud_cover,swdown,lwdown) & - !$omp firstprivate(ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte) + !$omp firstprivate(runlw, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte) allocate(rh (ims:ime)) allocate(T_air (ims:ime)) @@ -251,11 +257,12 @@ subroutine ra_simple(theta, pii, qv, qc, qs, qr, p, swdown, lwdown, cloud_cover, cloud_cover(:,j) = cloudfrac(rh, hydrometeors, ims,ime, its,ite) swdown(:,j) = shortwave(day_frac, cloud_cover(:,j), solar_elevation, ims,ime, its,ite) - lwdown(:,j) = longwave(T_air, cloud_cover(:,j), ims,ime, its,ite) - - ! apply a simple radiative cooling to the atmosphere - theta(its:ite, kts:kte, j) = theta(its:ite, kts:kte, j) - (((theta(its:ite, kts:kte, j) * pii(its:ite, kts:kte, j)) ** 4) * coolingrate) + if (runlw) then + lwdown(:,j) = longwave(T_air, cloud_cover(:,j), ims,ime, its,ite) + ! apply a simple radiative cooling to the atmosphere + theta(its:ite, kts:kte, j) = theta(its:ite, kts:kte, j) - (((theta(its:ite, kts:kte, j) * pii(its:ite, kts:kte, j)) ** 4) * coolingrate) + endif end do !$omp end do diff --git a/src/physics/water_lake.f90 b/src/physics/water_lake.f90 new file mode 100644 index 00000000..bea56069 --- /dev/null +++ b/src/physics/water_lake.f90 @@ -0,0 +1,5433 @@ +MODULE module_water_lake + +! The lake scheme was retrieved from the Community Land Model version 4.5 +! (Oleson et al. 2013) with some modifications by Gu et al. (2013). It is a +! one-dimensional mass and energy balance scheme with 20-25 model layers, +! including up to 5 snow layers on the lake ice, 10 water layers, and 10 soil +! layers on the lake bottom. The lake scheme is used with actual lake points and +! lake depth derived from the WPS, and it also can be used with user defined +! lake points and lake depth in WRF (lake_min_elev and lakedepth_default). +! The lake scheme is independent of a land surface scheme and therefore +! can be used with any land surface scheme embedded in WRF. The lake scheme +! developments and evaluations were included in Subin et al. (2012) and Gu et al. (2013) +! +! Subin et al. 2012: Improved lake model for climate simulations, J. Adv. Model. +! Earth Syst., 4, M02001. DOI:10.1029/2011MS000072; +! Gu et al. 2013: Calibration and validation of lake surface temperature simulations +! with the coupled WRF-Lake model. Climatic Change, 1-13, 10.1007/s10584-013-0978-y. +! Supporting info to Subin et al 2012: +! https://agupubs.onlinelibrary.wiley.com/action/downloadSupplement?doi=10.1029%2F2011MS000072&file=jame53-sup-0003-txts02.pdf +! +!_____________________________________________________________________________________________________________ +! +! Adapted for use in ICAR by Bert Kruyt, august 2022. Modifications include: +! - reduction of nr of soil layers (and modification of the code where this was hardcoded/shared +! with nlevlake, as they used to have the same value) +! - the clause(s) in lakeini that determine wether a gridpoint is lake or not. +! (also commented out any overwriting of the vegtype and xland pars.) +! - original code has been left in place, but commented out for documentation. +! ToDo: +! - test lakeflag = 0 case (no LU lake cat provided, lakeini deteremines lakes by vegtype==water & ht>lake_min_elev) +! - reduce nr of lake levels (nlakelev), and make nsoillev, nlakelev, and nsnowlev namelist arguments. +! - lakedepth_default and lake_min_elev should become namelist options. +!_____________________________________________________________________________________________________________ + + +! USE module_wrf_error + USE mod_wrf_constants, ONLY : rcp + + implicit none + integer, parameter :: r8 = selected_real_kind(12) + + integer, parameter :: nlevsoil = 4 ! was 10 ! number of soil layers + integer, parameter :: nlevlake = 10 ! number of lake layers -> line 5165 and below have hardcoded values that need to be revised before changing nlevlake + integer, parameter :: nlevsnow = 5 ! maximum number of snow layers + + integer,parameter :: lbp = 1 ! pft-index bounds + integer,parameter :: ubp = 1 + integer,parameter :: lbc = 1 ! column-index bounds + integer,parameter :: ubc = 1 + integer,parameter :: num_shlakec = 1 ! number of columns in lake filter + integer,parameter :: filter_shlakec(1) = 1 ! lake filter (columns) + integer,parameter :: num_shlakep = 1 ! number of pfts in lake filter + integer,parameter :: filter_shlakep(1) = 1 ! lake filter (pfts) + integer,parameter :: pcolumn(1) = 1 + integer,parameter :: pgridcell(1) = 1 + integer,parameter :: cgridcell(1) = 1 ! gridcell index of column + integer,parameter :: clandunit(1) = 1 ! landunit index of column + + integer,parameter :: begg = 1 + integer,parameter :: endg = 1 + integer,parameter :: begl = 1 + integer,parameter :: endl = 1 + integer,parameter :: begc = 1 + integer,parameter :: endc = 1 + integer,parameter :: begp = 1 + integer,parameter :: endp = 1 + + integer,parameter :: column =1 + logical,parameter :: lakpoi(1) = .true. + + + + +!Initialize physical constants: + real(r8), parameter :: vkc = 0.4_r8 !von Karman constant [-] + real(r8), parameter :: pie = 3.141592653589793_r8 ! pi + real(r8), parameter :: grav = 9.80616_r8 !gravity constant [m/s2] + real(r8), parameter :: sb = 5.67e-8_r8 !stefan-boltzmann constant [W/m2/K4] + real(r8), parameter :: tfrz = 273.16_r8 !freezing temperature [K] + real(r8), parameter :: denh2o = 1.000e3_r8 !density of liquid water [kg/m3] + real(r8), parameter :: denice = 0.917e3_r8 !density of ice [kg/m3] + real(r8), parameter :: cpice = 2.11727e3_r8 !Specific heat of ice [J/kg-K] + real(r8), parameter :: cpliq = 4.188e3_r8 !Specific heat of water [J/kg-K] + real(r8), parameter :: hfus = 3.337e5_r8 !Latent heat of fusion for ice [J/kg] + real(r8), parameter :: hvap = 2.501e6_r8 !Latent heat of evap for water [J/kg] + real(r8), parameter :: hsub = 2.501e6_r8+3.337e5_r8 !Latent heat of sublimation [J/kg] + real(r8), parameter :: rair = 287.0423_r8 !gas constant for dry air [J/kg/K] + real(r8), parameter :: cpair = 1.00464e3_r8 !specific heat of dry air [J/kg/K] + real(r8), parameter :: tcrit = 2.5 !critical temperature to determine rain or snow + real(r8), parameter :: tkwat = 0.6 !thermal conductivity of water [W/m/k] + real(r8), parameter :: tkice = 2.290 !thermal conductivity of ice [W/m/k] + real(r8), parameter :: tkairc = 0.023 !thermal conductivity of air [W/m/k] + real(r8), parameter :: bdsno = 250. !bulk density snow (kg/m**3) + + real(r8), public, parameter :: spval = 1.e36 !special value for missing data (ocean) + + real, parameter :: depth_c = 50. ! below the level t_lake3d will be 277.0 !mchen + + + ! These are tunable constants + real(r8), parameter :: wimp = 0.05 !Water impremeable if porosity less than wimp + real(r8), parameter :: ssi = 0.033 !Irreducible water saturation of snow + real(r8), parameter :: cnfac = 0.5 !Crank Nicholson factor between 0 and 1 + + + ! Initialize water type constants + integer,parameter :: istsoil = 1 !soil "water" type + integer, private :: i ! loop index + real(r8) :: dtime ! land model time step (sec) + + real(r8) :: zlak(1:nlevlake) !lake z (layers) + real(r8) :: dzlak(1:nlevlake) !lake dz (thickness) + real(r8) :: zsoi(1:nlevsoil) !soil z (layers) + real(r8) :: dzsoi(1:nlevsoil) !soil dz (thickness) + real(r8) :: zisoi(0:nlevsoil) !soil zi (interfaces) + + + real(r8) :: sand(19) ! percent sand + real(r8) :: clay(19) ! percent clay + + data(sand(i), i=1,19)/92.,80.,66.,20.,5.,43.,60.,& + 10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./ + + data(clay(i), i=1,19)/ 3., 5.,10.,15.,5.,18.,27.,& + 33.,33.,41.,47.,58.,14.7,0., 0., 8.5,54., 0., 3./ + + + ! real(r8) :: dtime ! land model time step (sec) + real(r8) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(r8) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(r8) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(r8) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(r8) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + CONTAINS + + + SUBROUTINE Lake( t_phy ,p8w ,dz8w ,qvcurr ,& !i + u_phy ,v_phy , glw ,emiss ,& + rainbl ,dtbl ,swdown ,albedo ,& + xlat_urb2d ,z_lake3d ,dz_lake3d ,lakedepth2d ,& + watsat3d ,csol3d ,tkmg3d ,tkdry3d ,& + tksatu3d ,ivgtyp ,ht ,xland ,& + iswater, xice, xice_threshold, lake_min_elev ,& + ids ,ide ,jds ,jde ,& + kds ,kde ,ims ,ime ,& + jms ,jme ,kms ,kme ,& + its ,ite ,jts ,jte ,& + kts ,kte ,& + h2osno2d ,snowdp2d ,snl2d ,z3d ,& !h + dz3d ,zi3d ,h2osoi_vol3d ,h2osoi_liq3d ,& + h2osoi_ice3d ,t_grnd2d ,t_soisno3d ,t_lake3d ,& + savedtke12d ,lake_icefrac3d ,& +! #if (EM_CORE==1) + lakemask ,lakeflag ,& +! #endif + ! lakemask ,& + + hfx ,lh ,grdflx ,tsk ,& !o + qfx ,t2 ,th2 ,q2 ) + +!============================================================================== +! This subroutine was first edited by Hongping Gu and Jiming Jin for coupling +! 07/20/2010 +!============================================================================== + IMPLICIT NONE + +!in: + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER , INTENT (IN) :: iswater + REAL, INTENT(IN) :: xice_threshold + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: XICE +! #if (EM_CORE==1) + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: LAKEMASK + INTEGER, INTENT(IN):: LAKEFLAG +! #endif + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: t_phy + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: p8w + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: dz8w + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: qvcurr + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: U_PHY + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: V_PHY + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: glw + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: emiss + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: rainbl + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: swdown + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(INOUT) :: albedo + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: XLAND + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: XLAT_URB2D + INTEGER, DIMENSION( ims:ime, jms:jme ) ,INTENT(INOUT) :: IVGTYP + REAL, INTENT(IN) :: dtbl + + REAL, DIMENSION( ims:ime,1:nlevlake,jms:jme ),INTENT(IN) :: z_lake3d + REAL, DIMENSION( ims:ime,1:nlevlake,jms:jme ),INTENT(IN) :: dz_lake3d + REAL, DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN) :: watsat3d + REAL, DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN) :: csol3d + REAL, DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN) :: tkmg3d + REAL, DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN) :: tkdry3d + REAL, DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN) :: tksatu3d + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: lakedepth2d + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(IN) :: ht + REAL ,INTENT(IN) :: lake_min_elev + +!out: + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: HFX + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: LH + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: GRDFLX + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: TSK + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: QFX + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: T2 + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: TH2 + REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(OUT) :: Q2 + +!in&out: + + real, dimension(ims:ime,jms:jme ) ,intent(inout) :: savedtke12d + real, dimension(ims:ime,jms:jme ) ,intent(inout) :: snowdp2d, & + h2osno2d, & + snl2d, & + t_grnd2d + + real, dimension( ims:ime,1:nlevlake, jms:jme ) ,INTENT(inout) :: t_lake3d, & + lake_icefrac3d + real, dimension( ims:ime,-nlevsnow+1:nlevsoil, jms:jme ) ,INTENT(inout) :: t_soisno3d, & + h2osoi_ice3d, & + h2osoi_liq3d, & + h2osoi_vol3d, & + z3d, & + dz3d + real, dimension( ims:ime,-nlevsnow+0:nlevsoil, jms:jme ) ,INTENT(inout) :: zi3d + + +!local variable: + + REAL :: SFCTMP,PBOT,PSFC,ZLVL,Q2K,EMISSI,LWDN,PRCP,SOLDN,SOLNET + INTEGER :: C,i,j,k + + + !tempory varibles in: + real(r8) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(r8) :: forc_pbot(1) ! atm bottom level pressure (Pa) + real(r8) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(r8) :: forc_hgt(1) ! atmospheric reference height (m) + real(r8) :: forc_hgt_q(1) ! observational height of humidity [m] + real(r8) :: forc_hgt_t(1) ! observational height of temperature [m] + real(r8) :: forc_hgt_u(1) ! observational height of wind [m] + real(r8) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(r8) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(r8) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + ! real(r8) :: forc_rho(1) ! density (kg/m**3) + real(r8) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + real(r8) :: prec(1) ! snow or rain rate [mm/s] + real(r8) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(r8) :: lat(1) ! latitude (radians) + real(r8) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(r8) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + + real(r8) :: lakedepth(1) ! column lake depth (m) + logical :: do_capsnow(1) ! true => do snow capping + + !in&out + real(r8) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(r8) :: t_grnd(1) ! ground temperature (Kelvin) + real(r8) :: h2osno(1) ! snow water (mm H2O) + real(r8) :: snowdp(1) ! snow height (m) + real(r8) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(r8) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(r8) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(r8) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + integer :: snl(1) ! number of snow layers + real(r8) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(r8) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(r8) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(r8) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(r8) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + + + !out: + real(r8) :: eflx_gnet(1) !net heat flux into ground (W/m**2) + real(r8) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(r8) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(r8) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(r8) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(r8) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(r8) :: ram1(1) ! aerodynamical resistance (s/m) + ! for calculation of decay of eddy diffusivity with depth + ! Change the type variable to pass back to WRF. + real(r8) :: z0mg(1) ! roughness length over ground, momentum (m( + + + dtime = dtbl + + DO J = jts,jte + DO I = its,ite + + SFCTMP = t_phy(i,1,j) + PBOT = p8w(i,2,j) + PSFC = P8w(i,1,j) + ZLVL = 0.5 * dz8w(i,1,j) + Q2K = qvcurr(i,1,j)/(1.0 + qvcurr(i,1,j)) + EMISSI = EMISS(I,J) + LWDN = GLW(I,J)*EMISSI + PRCP = RAINBL(i,j)/dtbl + SOLDN = SWDOWN(I,J) ! SOLDN is total incoming solar + SOLNET = SOLDN*(1.-ALBEDO(I,J)) ! use mid-day albedo to determine net downward solar + ! (no solar zenith angle correction) +! IF (XLAND(I,J).GT.1.5) THEN + + ! if ( xice(i,j).gt.xice_threshold) then + ! ivgtyp(i,j) = iswater + ! xland(i,j) = 2. + ! lake_icefrac3d(i,1,j) = xice(i,j) + ! endif + +! #if (EM_CORE==1) + if (lakemask(i,j).eq.1) THEN + ! if((lakemask(i,j).eq.1) .or. (ivgtyp(i,j)==iswater.and.ht(i,j)>=lake_min_elev)) then ! BK modified cause lake cat is not always water cat. +! #else + ! if (ivgtyp(i,j)==iswater.and.ht(i,j)>= lake_min_elev ) THEN +! #endif + + do c = 1,column + + forc_t(c) = SFCTMP ! [K] + forc_pbot(c) = PBOT + forc_psrf(c) = PSFC + forc_hgt(c) = ZLVL ! [m] + forc_hgt_q(c) = ZLVL ! [m] + forc_hgt_t(c) = ZLVL ! [m] + forc_hgt_u(c) = ZLVL ! [m] + forc_q(c) = Q2K ! [kg/kg] + forc_u(c) = U_PHY(I,1,J) + forc_v(c) = V_PHY(I,1,J) + ! forc_rho(c) = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] + forc_lwrad(c) = LWDN ! [W/m/m] + prec(c) = PRCP ! [mm/s] + sabg(c) = SOLNET + lat(c) = XLAT_URB2D(I,J)*pie/180 ! [radian] + do_capsnow(c) = .false. + + lakedepth(c) = lakedepth2d(i,j) + savedtke1(c) = savedtke12d(i,j) + snowdp(c) = snowdp2d(i,j) + h2osno(c) = h2osno2d(i,j) + snl(c) = snl2d(i,j) + t_grnd(c) = t_grnd2d(i,j) + do k = 1,nlevlake + t_lake(c,k) = t_lake3d(i,k,j) + lake_icefrac(c,k) = lake_icefrac3d(i,k,j) + z_lake(c,k) = z_lake3d(i,k,j) + dz_lake(c,k) = dz_lake3d(i,k,j) + enddo + do k = -nlevsnow+1,nlevsoil + t_soisno(c,k) = t_soisno3d(i,k,j) + h2osoi_ice(c,k) = h2osoi_ice3d(i,k,j) + h2osoi_liq(c,k) = h2osoi_liq3d(i,k,j) + h2osoi_vol(c,k) = h2osoi_vol3d(i,k,j) + z(c,k) = z3d(i,k,j) + dz(c,k) = dz3d(i,k,j) + enddo + do k = -nlevsnow+0,nlevsoil + zi(c,k) = zi3d(i,k,j) + enddo + do k = 1,nlevsoil + watsat(c,k) = watsat3d(i,k,j) + csol(c,k) = csol3d(i,k,j) + tkmg(c,k) = tkmg3d(i,k,j) + tkdry(c,k) = tkdry3d(i,k,j) + tksatu(c,k) = tksatu3d(i,k,j) + enddo + + enddo + + CALL LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I + forc_hgt_t,forc_hgt_u,forc_q, forc_u, & + forc_v,forc_lwrad,prec, sabg,lat, & + z_lake,dz_lake,lakedepth,do_capsnow, & + h2osno,snowdp,snl,z,dz,zi, & !H + h2osoi_vol,h2osoi_liq,h2osoi_ice, & + t_grnd,t_soisno,t_lake, & + savedtke1,lake_icefrac, & + eflx_lwrad_net,eflx_gnet, & !O + eflx_sh_tot,eflx_lh_tot, & + t_ref2m,q_ref2m, & + taux,tauy,ram1,z0mg) + + + do c = 1,column + HFX(I,J) = eflx_sh_tot(c) ![W/m/m] + LH(I,J) = eflx_lh_tot(c) !W/m/m] + GRDFLX(I,J) = eflx_gnet(c) !W/m/m] + TSK(I,J) = t_grnd(c) ![K] + T2(I,J) = t_ref2m(c) + TH2(I,J) = T2(I,J)*(1.E5/PSFC)**RCP + Q2(I,J) = q_ref2m(c) + albedo(i,j) = ( 0.6 * lake_icefrac(c,1) ) + ( (1.0-lake_icefrac(c,1)) * 0.08) + + if( tsk(i,j) >= tfrz ) then + qfx(i,j) = eflx_lh_tot(c)/hvap + else + qfx(i,j) = eflx_lh_tot(c)/hsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) + endif + enddo + +! Renew Lake State Varialbes:(14) + do c = 1,column + + savedtke12d(i,j) = savedtke1(c) + snowdp2d(i,j) = snowdp(c) + h2osno2d(i,j) = h2osno(c) + snl2d(i,j) = snl(c) + t_grnd2d(i,j) = t_grnd(c) + do k = 1,nlevlake + t_lake3d(i,k,j) = t_lake(c,k) + lake_icefrac3d(i,k,j) = lake_icefrac(c,k) + enddo + do k = -nlevsnow+1,nlevsoil + z3d(i,k,j) = z(c,k) + dz3d(i,k,j) = dz(c,k) + t_soisno3d(i,k,j) = t_soisno(c,k) + h2osoi_liq3d(i,k,j) = h2osoi_liq(c,k) + h2osoi_ice3d(i,k,j) = h2osoi_ice(c,k) + h2osoi_vol3d(i,k,j) = h2osoi_vol(c,k) + enddo + do k = -nlevsnow+0,nlevsoil + zi3d(i,k,j) = zi(c,k) + enddo + + enddo + + endif +! ENDIF ! if xland = 2 + ENDDO + ENDDO + + END SUBROUTINE Lake + + + SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I + forc_hgt_t,forc_hgt_u,forc_q, forc_u, & + forc_v,forc_lwrad,prec, sabg,lat, & + z_lake,dz_lake,lakedepth,do_capsnow, & + h2osno,snowdp,snl,z,dz,zi, & !H + h2osoi_vol,h2osoi_liq,h2osoi_ice, & + t_grnd,t_soisno,t_lake, & + savedtke1,lake_icefrac, & + eflx_lwrad_net,eflx_gnet, & !O + eflx_sh_tot,eflx_lh_tot, & + t_ref2m,q_ref2m, & + taux,tauy,ram1,z0mg) + implicit none +!in: + + real(r8),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(r8),intent(in) :: forc_pbot(1) ! atm bottom level pressure (Pa) + real(r8),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(r8),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(r8),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + real(r8),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(r8),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(r8),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(r8),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(r8),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + ! real(r8),intent(in) :: forc_rho(1) ! density (kg/m**3) + real(r8),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + real(r8),intent(in) :: prec(1) ! snow or rain rate [mm/s] + real(r8),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(r8),intent(in) :: lat(1) ! latitude (radians) + real(r8),intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(r8),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + + real(r8), intent(in) :: lakedepth(1) ! column lake depth (m) + !!!!!!!!!!!!!!!!tep(in),hydro(in) + ! real(r8), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) + !!!!!!!!!!!!!!!!hydro + logical , intent(in) :: do_capsnow(1) ! true => do snow capping + + + +!in&out + real(r8),intent(inout) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(r8),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) + real(r8),intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(r8),intent(inout) :: snowdp(1) ! snow height (m) + real(r8),intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(r8),intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(r8),intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(r8),intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + integer ,intent(inout) :: snl(1) ! number of snow layers + real(r8),intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(r8),intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(r8),intent(inout) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(r8),intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(r8),intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + + +!out: + real(r8),intent(out) :: eflx_gnet(1) !net heat flux into ground (W/m**2) + real(r8),intent(out) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8),intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8),intent(out) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(r8),intent(out) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(r8),intent(out) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(r8),intent(out) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(r8),intent(out) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(r8),intent(out) :: ram1(1) ! aerodynamical resistance (s/m) + ! for calculation of decay of eddy diffusivity with depth + ! Change the type variable to pass back to WRF. + real(r8),intent(out) :: z0mg(1) ! roughness length over ground, momentum (m( + + +!local output + + real(r8) :: begwb(1) ! water mass begining of the time step + real(r8) :: t_veg(1) ! vegetation temperature (Kelvin) + real(r8) :: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] + real(r8) :: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] + real(r8) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(r8) :: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) + real(r8) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(r8) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(r8) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8) :: forc_snow(1) ! snow rate [mm/s] + real(r8) :: forc_rain(1) ! rain rate [mm/s] + real(r8) :: ws(1) ! surface friction velocity (m/s) + real(r8) :: ks(1) ! coefficient passed to ShalLakeTemperature + real(r8) :: qflx_snomelt(1) !snow melt (mm H2O /s) tem(out),snowwater(in) + integer :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + real(r8) :: endwb(1) ! water mass end of the time step + real(r8) :: snowage(1) ! non dimensional snow age [-] + real(r8) :: snowice(1) ! average snow ice lens + real(r8) :: snowliq(1) ! average snow liquid water + real(r8) :: t_snow(1) ! vertically averaged snow temperature + real(r8) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) + real(r8) :: qflx_surf(1) ! surface runoff (mm H2O /s) + real(r8) :: qflx_infl(1) ! infiltration (mm H2O /s) + real(r8) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes + real(r8) :: qcharge(1) ! aquifer recharge rate (mm/s) + real(r8) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(r8) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(r8) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] + real(r8) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] + real(r8) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] + real(r8) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(r8) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) + real(r8) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) + real(r8) :: zwt(1) !water table depth + real(r8) :: fcov(1) !fractional area with water table at surface + real(r8) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer + real(r8) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] + real(r8) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] + real(r8) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] + real(r8) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] + + +! lat = lat*pie/180 ! [radian] + + if (prec(1)> 0.) then + if ( forc_t(1) > (tfrz + tcrit)) then + forc_rain(1) = prec(1) + forc_snow(1) = 0. + ! flfall(1) = 1. + else + forc_rain(1) = 0. + forc_snow(1) = prec(1) + + ! if ( forc_t(1) <= tfrz) then + ! flfall(1) = 0. + ! else if ( forc_t(1) <= tfrz+2.) then + ! flfall(1) = -54.632 + 0.2 * forc_t(1) + ! else + ! flfall(1) = 0.4 + endif + else + forc_rain(1) = 0. + forc_snow(1) = 0. + ! flfall(1) = 1. + endif + + CALL ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !i + forc_hgt_t,forc_hgt_u,forc_q, & + forc_u,forc_v,forc_lwrad,forc_snow, & + forc_rain,t_grnd,h2osno,snowdp,sabg,lat, & + dz,dz_lake,t_soisno,t_lake,snl,h2osoi_liq, & + h2osoi_ice,savedtke1, & + qflx_prec_grnd,qflx_evap_soi,qflx_evap_tot, & !o + eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net, & + eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot, & + eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & + ram1,ws,ks,eflx_gnet,z0mg) + + + CALL ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & !i + z_lake,ws,ks,snl,eflx_gnet,lakedepth, & + lake_icefrac,snowdp, & !i&o + eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd, & !o + t_lake,t_soisno,h2osoi_liq, & + h2osoi_ice,savedtke1, & + frac_iceold,qflx_snomelt,imelt) + + + + CALL ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & !i + begwb,qflx_evap_tot,forc_t,do_capsnow, & + t_grnd,qflx_evap_soi, & + qflx_snomelt,imelt,frac_iceold, & !i add by guhp + z,dz,zi,snl,h2osno,snowdp,lake_icefrac,t_lake, & !i&o + endwb,snowage,snowice,snowliq,t_snow, & !o + t_soisno,h2osoi_ice,h2osoi_liq,h2osoi_vol, & + qflx_drain,qflx_surf,qflx_infl,qflx_qrgwl, & + qcharge,qflx_prec_grnd,qflx_snowcap, & + qflx_snowcap_col,qflx_snow_grnd_pft, & + qflx_snow_grnd_col,qflx_rain_grnd, & + qflx_evap_tot_col,soilalpha,zwt,fcov, & + rootr_column,qflx_evap_grnd,qflx_sub_snow, & + qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col) + +!================================================================================== +! !DESCRIPTION: +! Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is +! done. However, there is no infiltration, and the water budget is balanced with + + END SUBROUTINE LakeMain + + +SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !i + forc_hgt_t,forc_hgt_u,forc_q, & + forc_u,forc_v,forc_lwrad,forc_snow, & + forc_rain,t_grnd,h2osno,snowdp,sabg,lat, & + dz,dz_lake,t_soisno,t_lake,snl,h2osoi_liq, & + h2osoi_ice,savedtke1, & + qflx_prec_grnd,qflx_evap_soi,qflx_evap_tot, & !o + eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net, & + eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot, & + eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & + ram1,ws,ks,eflx_gnet,z0mg) +!============================================================================== +! DESCRIPTION: +! Calculates lake temperatures and surface fluxes for shallow lakes. +! +! Shallow lakes have variable depth, possible snow layers above, freezing & thawing of lake water, +! and soil layers with active temperature and gas diffusion below. +! +! WARNING: This subroutine assumes lake columns have one and only one pft. +! +! REVISION HISTORY: +! Created by Zack Subin, 2009 +! Reedited by Hongping Gu, 2010 +!============================================================================== + + ! implicit none + + implicit none + +!in: + + real(r8),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(r8),intent(in) :: forc_pbot(1) ! atmospheric pressure (Pa) + real(r8),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(r8),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(r8),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + real(r8),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(r8),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(r8),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(r8),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(r8),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + real(r8),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + ! real(r8),intent(in) :: forc_rho(1) ! density (kg/m**3) + real(r8),intent(in) :: forc_snow(1) ! snow rate [mm/s] + real(r8),intent(in) :: forc_rain(1) ! rain rate [mm/s] + real(r8),intent(in) :: h2osno(1) ! snow water (mm H2O) + real(r8),intent(in) :: snowdp(1) ! snow height (m) + real(r8),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(r8),intent(in) :: lat(1) ! latitude (radians) + real(r8),intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(r8),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(r8),intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(r8),intent(in) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + integer ,intent(in) :: snl(1) ! number of snow layers + real(r8),intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(r8),intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(r8),intent(in) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + +!inout: + real(r8),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) +!out: + real(r8),intent(out):: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8),intent(out):: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(r8),intent(out):: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(r8),intent(out):: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(r8),intent(out):: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) + real(r8),intent(out):: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(r8),intent(out):: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] + real(r8),intent(out):: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8),intent(out):: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(r8),intent(out):: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] + real(r8),intent(out):: t_veg(1) ! vegetation temperature (Kelvin) + real(r8),intent(out):: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(r8),intent(out):: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(r8),intent(out):: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(r8),intent(out):: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(r8),intent(out):: ram1(1) ! aerodynamical resistance (s/m) + real(r8),intent(out):: ws(1) ! surface friction velocity (m/s) + real(r8),intent(out):: ks(1) ! coefficient passed to ShalLakeTemperature + ! for calculation of decay of eddy diffusivity with depth + real(r8),intent(out):: eflx_gnet(1) !net heat flux into ground (W/m**2) + ! Change the type variable to pass back to WRF. + real(r8),intent(out):: z0mg(1) ! roughness length over ground, momentum (m( + + + +!OTHER LOCAL VARIABLES: + + integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake + integer , parameter :: niters = 3 ! maximum number of iterations for surface temperature + real(r8), parameter :: beta1 = 1._r8 ! coefficient of convective velocity (in computing W_*) [-] + real(r8), parameter :: emg = 0.97_r8 ! ground emissivity (0.97 for snow) + real(r8), parameter :: zii = 1000._r8! convective boundary height [m] + real(r8), parameter :: tdmax = 277._r8 ! temperature of maximum water density + real(r8) :: forc_th(1) ! atmospheric potential temperature (Kelvin) + real(r8) :: forc_vp(1) !atmospheric vapor pressure (Pa) + real(r8) :: forc_rho(1) ! density (kg/m**3) + integer :: i,fc,fp,g,c,p ! do loop or array index + integer :: fncopy ! number of values in pft filter copy + integer :: fnold ! previous number of pft filter values + integer :: fpcopy(num_shlakep) ! pft filter copy for iteration loop + integer :: iter ! iteration index + integer :: nmozsgn(lbp:ubp) ! number of times moz changes sign + integer :: jtop(lbc:ubc) ! top level for each column (no longer all 1) +! real(r8) :: dtime ! land model time step (sec) + real(r8) :: ax ! used in iteration loop for calculating t_grnd (numerator of NR solution) + real(r8) :: bx ! used in iteration loop for calculating t_grnd (denomin. of NR solution) + real(r8) :: degdT ! d(eg)/dT + real(r8) :: dqh(lbp:ubp) ! diff of humidity between ref. height and surface + real(r8) :: dth(lbp:ubp) ! diff of virtual temp. between ref. height and surface + real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8) :: dzsur(lbc:ubc) ! 1/2 the top layer thickness (m) + real(r8) :: eg ! water vapor pressure at temperature T [pa] + real(r8) :: htvp(lbc:ubc) ! latent heat of vapor of water (or sublimation) [j/kg] + real(r8) :: obu(lbp:ubp) ! monin-obukhov length (m) + real(r8) :: obuold(lbp:ubp) ! monin-obukhov length of previous iteration + real(r8) :: qsatg(lbc:ubc) ! saturated humidity [kg/kg] + real(r8) :: qsatgdT(lbc:ubc) ! d(qsatg)/dT + real(r8) :: qstar ! moisture scaling parameter + real(r8) :: ram(lbp:ubp) ! aerodynamical resistance [s/m] + real(r8) :: rah(lbp:ubp) ! thermal resistance [s/m] + real(r8) :: raw(lbp:ubp) ! moisture resistance [s/m] + real(r8) :: stftg3(lbp:ubp) ! derivative of fluxes w.r.t ground temperature + real(r8) :: temp1(lbp:ubp) ! relation for potential temperature profile + real(r8) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m + real(r8) :: temp2(lbp:ubp) ! relation for specific humidity profile + real(r8) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m + real(r8) :: tgbef(lbc:ubc) ! initial ground temperature + real(r8) :: thm(lbc:ubc) ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(r8) :: thv(lbc:ubc) ! virtual potential temperature (kelvin) + real(r8) :: thvstar ! virtual potential temperature scaling parameter + real(r8) :: tksur ! thermal conductivity of snow/soil (w/m/kelvin) + real(r8) :: tsur ! top layer temperature + real(r8) :: tstar ! temperature scaling parameter + real(r8) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] + real(r8) :: ur(lbp:ubp) ! wind speed at reference height [m/s] + real(r8) :: ustar(lbp:ubp) ! friction velocity [m/s] + real(r8) :: wc ! convective velocity [m/s] + real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: zldis(lbp:ubp) ! reference height "minus" zero displacement height [m] + real(r8) :: displa(lbp:ubp) ! displacement (always zero) [m] +! real(r8) :: z0mg(lbp:ubp) ! roughness length over ground, momentum [m] + real(r8) :: z0hg(lbp:ubp) ! roughness length over ground, sensible heat [m] + real(r8) :: z0qg(lbp:ubp) ! roughness length over ground, latent heat [m] + real(r8) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type + real(r8) :: u2m ! 2 m wind speed (m/s) + real(r8) :: u10(1) ! 10-m wind (m/s) (for dust model) + real(r8) :: fv(1) ! friction velocity (m/s) (for dust model) + + real(r8) :: fm(lbp:ubp) ! needed for BGC only to diagnose 10m wind speed + real(r8) :: bw ! partial density of water (ice + liquid) + real(r8) :: t_grnd_temp ! Used in surface flux correction over frozen ground + real(r8) :: betaprime(lbc:ubc) ! Effective beta: 1 for snow layers, beta(islak) otherwise + character*256 :: message + ! This assumes all radiation is absorbed in the top snow layer and will need + ! to be changed for CLM 4. +! +! Constants for lake temperature model +! + data beta/0.4_r8, 0.4_r8/ ! (deep lake, shallow lake) + ! This is the energy absorbed at the lake surface if no snow. +! data za /0.6_r8, 0.5_r8/ +! data eta /0.1_r8, 0.5_r8/ +!----------------------------------------------------------------------- + + +! dtime = get_step_size() + +! Begin calculations + +!dir$ concurrent +!cdir nodep + forc_th(1) = forc_t(1) * (forc_psrf(1)/ forc_pbot(1))**(rair/cpair) + forc_vp(1) = forc_q(1) * forc_pbot(1)/ (0.622 + 0.378 * forc_q(1)) + forc_rho(1) = (forc_pbot(1) - 0.378 * forc_vp(1)) / (rair * forc_t(1)) + + do fc = 1, num_shlakec + c = filter_shlakec(fc) + g = cgridcell(c) + + ! Surface temperature and fluxes + + ! Find top layer + if (snl(c) > 0 .or. snl(c) < -5) then + WRITE(message,*) 'snl is not defined in ShalLakeFluxesMod' + ! CALL wrf_message(message) + ! CALL wrf_error_fatal("snl: out of range value") + end if +! if (snl(c) /= 0) then +! write(6,*)'snl is not equal to zero in ShalLakeFluxesMod' +! call endrun() +! end if + jtop(c) = snl(c) + 1 + + if (snl(c) < 0) then + betaprime(c) = 1._r8 !Assume all solar rad. absorbed at the surface of the top snow layer. + dzsur(c) = dz(c,jtop(c))/2._r8 + else + betaprime(c) = beta(islak) + dzsur(c) = dz_lake(c,1)/2._r8 + end if + ! Originally this was 1*dz, but shouldn't it be 1/2? + + ! Saturated vapor pressure, specific humidity and their derivatives + ! at lake surface + + call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c)) + + ! Potential, virtual potential temperature, and wind speed at the + ! reference height + + thm(c) = forc_t(g) + 0.0098_r8*forc_hgt_t(g) ! intermediate variable + thv(c) = forc_th(g)*(1._r8+0.61_r8*forc_q(g)) ! virtual potential T + end do + +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) + + nmozsgn(p) = 0 + obuold(p) = 0._r8 + displa(p) = 0._r8 + + ! Roughness lengths + + +! changed by Hongping Gu + ! if (t_grnd(c) >= tfrz) then ! for unfrozen lake + ! z0mg(p) = 0.01_r8 + ! else ! for frozen lake + ! ! Is this okay even if it is snow covered? What is the roughness over + ! non-veg. snow? + ! z0mg(p) = 0.04_r8 + ! end if + + if (t_grnd(c) >= tfrz) then ! for unfrozen lake + z0mg(p) = 0.001_r8 !original 0.01 + else if(snl(c) == 0 ) then ! for frozen lake + ! Is this okay even if it is snow covered? What is the roughness over + ! non-veg. snow? + z0mg(p) = 0.005_r8 !original 0.04, now for frozen lake without snow + else ! for frozen lake with snow + z0mg(p) = 0.0024_r8 + end if + + + + + z0hg(p) = z0mg(p) + z0qg(p) = z0mg(p) + + ! Latent heat + +#if (defined PERGRO) + htvp(c) = hvap +#else + if (t_grnd(c) > tfrz) then + htvp(c) = hvap + else + htvp(c) = hsub + end if +#endif + ! Zack Subin, 3/26/09: Shouldn't this be the ground temperature rather than the air temperature above? + ! I'll change it for now. + + ! Initialize stability variables + + ur(p) = max(1.0_r8,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) + dth(p) = thm(c)-t_grnd(c) + dqh(p) = forc_q(g)-qsatg(c) + dthv = dth(p)*(1._r8+0.61_r8*forc_q(g))+0.61_r8*forc_th(g)*dqh(p) + zldis(p) = forc_hgt_u(g) - 0._r8 + + ! Initialize Monin-Obukhov length and wind speed + + call MoninObukIni(ur(p), thv(c), dthv, zldis(p), z0mg(p), um(p), obu(p)) + + end do + + iter = 1 + fncopy = num_shlakep + fpcopy(1:num_shlakep) = filter_shlakep(1:num_shlakep) + + ! Begin stability iteration + + ITERATION : do while (iter <= niters .and. fncopy > 0) + + ! Determine friction velocity, and potential temperature and humidity + ! profiles of the surface boundary layer + + call FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i + forc_hgt_t,forc_hgt_q, & !i + lbp, ubp, fncopy, fpcopy, & !i + displa, z0mg, z0hg, z0qg, & !i + obu, iter, ur, um, & !i + ustar,temp1, temp2, temp12m, temp22m, & !o + u10,fv, & !o + fm) !i&o + +!dir$ concurrent +!cdir nodep + do fp = 1, fncopy + p = fpcopy(fp) + c = pcolumn(p) + g = pgridcell(p) + + tgbef(c) = t_grnd(c) + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + tksur = savedtke1(c) + ! Set this to the eddy conductivity from the last + ! timestep, as the molecular conductivity will be orders of magnitude too small. + ! Will have to deal with first timestep. + tsur = t_lake(c,1) + else if (snl(c) == 0) then !frozen but no snow layers + tksur = tkice + tsur = t_lake(c,1) + else + !Need to calculate thermal conductivity of the top snow layer + bw = (h2osoi_ice(c,jtop(c))+h2osoi_liq(c,jtop(c)))/dz(c,jtop(c)) + tksur = tkairc + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkairc) + tsur = t_soisno(c,jtop(c)) + end if + + ! Determine aerodynamic resistances + + ram(p) = 1._r8/(ustar(p)*ustar(p)/um(p)) + rah(p) = 1._r8/(temp1(p)*ustar(p)) + raw(p) = 1._r8/(temp2(p)*ustar(p)) + ram1(p) = ram(p) !pass value to global variable + + ! Get derivative of fluxes with respect to ground temperature + + stftg3(p) = emg*sb*tgbef(c)*tgbef(c)*tgbef(c) + + ! Changed surface temperature from t_lake(c,1) to tsur. + ! Also adjusted so that if there are snow layers present, all radiation is absorbed in the top layer. + ax = betaprime(c)*sabg(p) + emg*forc_lwrad(g) + 3._r8*stftg3(p)*tgbef(c) & + + forc_rho(g)*cpair/rah(p)*thm(c) & + - htvp(c)*forc_rho(g)/raw(p)*(qsatg(c)-qsatgdT(c)*tgbef(c) - forc_q(g)) & + + tksur*tsur/dzsur(c) + !Changed sabg(p) and to betaprime(c)*sabg(p). + bx = 4._r8*stftg3(p) + forc_rho(g)*cpair/rah(p) & + + htvp(c)*forc_rho(g)/raw(p)*qsatgdT(c) + tksur/dzsur(c) + + t_grnd(c) = ax/bx + + ! Update htvp +#ifndef PERGRO + if (t_grnd(c) > tfrz) then + htvp(c) = hvap + else + htvp(c) = hsub + end if +#endif + + ! Surface fluxes of momentum, sensible and latent heat + ! using ground temperatures from previous time step + + eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p) + qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-tgbef(c))-forc_q(g))/raw(p) + + ! Re-calculate saturated vapor pressure, specific humidity and their + ! derivatives at lake surface + + call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c)) + + dth(p)=thm(c)-t_grnd(c) + dqh(p)=forc_q(g)-qsatg(c) + + tstar = temp1(p)*dth(p) + qstar = temp2(p)*dqh(p) + + thvstar=tstar*(1._r8+0.61_r8*forc_q(g)) + 0.61_r8*forc_th(g)*qstar + zeta=zldis(p)*vkc * grav*thvstar/(ustar(p)**2*thv(c)) + + if (zeta >= 0._r8) then !stable + zeta = min(2._r8,max(zeta,0.01_r8)) + um(p) = max(ur(p),0.1_r8) + else !unstable + zeta = max(-100._r8,min(zeta,-0.01_r8)) + wc = beta1*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_r8 + um(p) = sqrt(ur(p)*ur(p)+wc*wc) + end if + obu(p) = zldis(p)/zeta + + if (obuold(p)*obu(p) < 0._r8) nmozsgn(p) = nmozsgn(p)+1 + + obuold(p) = obu(p) + + end do ! end of filtered pft loop + + iter = iter + 1 + if (iter <= niters ) then + ! Rebuild copy of pft filter for next pass through the ITERATION loop + + fnold = fncopy + fncopy = 0 + do fp = 1, fnold + p = fpcopy(fp) + if (nmozsgn(p) < 3) then + fncopy = fncopy + 1 + fpcopy(fncopy) = p + end if + end do ! end of filtered pft loop + end if + + end do ITERATION ! end of stability iteration + +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) + + ! If there is snow on the ground and t_grnd > tfrz: reset t_grnd = tfrz. + ! Re-evaluate ground fluxes. + ! h2osno > 0.5 prevents spurious fluxes. + ! note that qsatg and qsatgdT should be f(tgbef) (PET: not sure what this + ! comment means) + ! Zack Subin, 3/27/09: Since they are now a function of whatever t_grnd was before cooling + ! to freezing temperature, then this value should be used in the derivative correction term. + ! Should this happen if the lake temperature is below freezing, too? I'll assume that for now. + ! Also, allow convection if ground temp is colder than lake but warmer than 4C, or warmer than + ! lake which is warmer than freezing but less than 4C. +!#ifndef SHLAKETEST + if ( (h2osno(c) > 0.5_r8 .or. t_lake(c,1) <= tfrz) .and. t_grnd(c) > tfrz) then +!#else +! if ( t_lake(c,1) <= tfrz .and. t_grnd(c) > tfrz) then +!#endif + t_grnd_temp = t_grnd(c) + t_grnd(c) = tfrz + eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p) + qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-t_grnd_temp) - forc_q(g))/raw(p) + else if ( (t_lake(c,1) > t_grnd(c) .and. t_grnd(c) > tdmax) .or. & + (t_lake(c,1) < t_grnd(c) .and. t_lake(c,1) > tfrz .and. t_grnd(c) < tdmax) ) then + ! Convective mixing will occur at surface + t_grnd_temp = t_grnd(c) + t_grnd(c) = t_lake(c,1) + eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p) + qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-t_grnd_temp) - forc_q(g))/raw(p) + end if + + ! Update htvp +#ifndef PERGRO + if (t_grnd(c) > tfrz) then + htvp(c) = hvap + else + htvp(c) = hsub + end if +#endif + + ! Net longwave from ground to atmosphere + +! eflx_lwrad_out(p) = (1._r8-emg)*forc_lwrad(g) + stftg3(p)*(-3._r8*tgbef(c)+4._r8*t_grnd(c)) + ! What is tgbef doing in this equation? Can't it be exact now? --Zack Subin, 4/14/09 + eflx_lwrad_out(p) = (1._r8-emg)*forc_lwrad(g) + emg*sb*t_grnd(c)**4 + + ! Ground heat flux + + eflx_soil_grnd(p) = sabg(p) + forc_lwrad(g) - eflx_lwrad_out(p) - & + eflx_sh_grnd(p) - htvp(c)*qflx_evap_soi(p) + !Why is this sabg(p) and not beta*sabg(p)?? + !I've kept this as the incorrect sabg so that the energy balance check will be correct. + !This is the effective energy flux into the ground including the lake solar absorption + !below the surface. The variable eflx_gnet will be used to pass the actual heat flux + !from the ground interface into the lake. + + taux(p) = -forc_rho(g)*forc_u(g)/ram(p) + tauy(p) = -forc_rho(g)*forc_v(g)/ram(p) + + eflx_sh_tot(p) = eflx_sh_grnd(p) + qflx_evap_tot(p) = qflx_evap_soi(p) + eflx_lh_tot(p) = htvp(c)*qflx_evap_soi(p) + eflx_lh_grnd(p) = htvp(c)*qflx_evap_soi(p) +#if (defined LAKEDEBUG) + write(message,*) 'c, sensible heat = ', c, eflx_sh_tot(p), 'latent heat = ', eflx_lh_tot(p) & + , 'ground temp = ', t_grnd(c), 'h2osno = ', h2osno(c) + ! CALL wrf_message(message) + ! if (abs(eflx_sh_tot(p)) > 1500 .or. abs(eflx_lh_tot(p)) > 1500) then + ! write(message,*)'WARNING: SH, LH = ', eflx_sh_tot(p), eflx_lh_tot(p) + ! CALL wrf_message(message) + ! end if + ! if (abs(eflx_sh_tot(p)) > 10000 .or. abs(eflx_lh_tot(p)) > 10000 & + ! .or. abs(t_grnd(c)-288)>200 ) CALL wrf_error_fatal ( 't_grnd is out of range' ) +#endif + ! 2 m height air temperature + t_ref2m(p) = thm(c) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p)) + + ! 2 m height specific humidity + q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p)) + + ! Energy residual used for melting snow + ! Effectively moved to ShalLakeTemp + + ! Prepare for lake layer temperature calculations below + ! fin(c) = betaprime * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + & + ! eflx_sh_tot(p) + eflx_lh_tot(p)) + ! NOW this is just the net ground heat flux calculated below. + + eflx_gnet(p) = betaprime(c) * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + & + eflx_sh_tot(p) + eflx_lh_tot(p)) + ! This is the actual heat flux from the ground interface into the lake, not including + ! the light that penetrates the surface. + +! u2m = max(1.0_r8,ustar(p)/vkc*log(2._r8/z0mg(p))) + ! u2 often goes below 1 m/s; it seems like the only reason for this minimum is to + ! keep it from being zero in the ks equation below; 0.1 m/s is a better limit for + ! stable conditions --ZS + u2m = max(0.1_r8,ustar(p)/vkc*log(2._r8/z0mg(p))) + + ws(c) = 1.2e-03_r8 * u2m + ks(c) = 6.6_r8*sqrt(abs(sin(lat(g))))*(u2m**(-1.84_r8)) + + end do + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! End of surface flux relevant code in original BiogeophysicsLakeMod until history loop. + + ! The following are needed for global average on history tape. + +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) +! t_veg(p) = forc_t(g) + !This is an odd choice, since elsewhere t_veg = t_grnd for bare ground. + !Zack Subin, 4/09 + t_veg(p) = t_grnd(c) + eflx_lwrad_net(p) = eflx_lwrad_out(p) - forc_lwrad(g) + qflx_prec_grnd(p) = forc_rain(g) + forc_snow(g) + end do + +END SUBROUTINE ShalLakeFluxes + +SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & !i + z_lake,ws,ks,snl,eflx_gnet,lakedepth, & + lake_icefrac,snowdp, & !i&o + eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd, & !o + t_lake,t_soisno,h2osoi_liq, & + h2osoi_ice,savedtke1, & + frac_iceold,qflx_snomelt,imelt) +!======================================================================================================= +! !DESCRIPTION: +! Calculates temperatures in the 20-25 layer column of (possible) snow, +! lake water, and soil beneath lake. +! Snow and soil temperatures are determined as in SoilTemperature, except +! for appropriate boundary conditions at the top of the snow (the flux is fixed +! to be the ground heat flux calculated in ShalLakeFluxes), the bottom of the snow +! (adjacent to top lake layer), and the top of the soil (adjacent to the bottom +! lake layer). Also, the soil is assumed to be always fully saturated (ShalLakeHydrology +! will have to insure this). The whole column is solved simultaneously as one tridiagonal matrix. +! Lake temperatures are determined from the Hostetler model as before, except now: +! i) Lake water layers can freeze by any fraction and release latent heat; thermal +! and mechanical properties are adjusted for ice fraction. +! ii) Convective mixing (though not eddy diffusion) still occurs for frozen lakes. +! iii) No sunlight is absorbed in the lake if there are snow layers. +! iv) Light is allowed to reach the top soil layer (where it is assumed to be completely absorbed). +! v) Lakes have variable depth, set ultimately in surface data set but now in initShalLakeMod. +! +! Eddy + molecular diffusion: +! d ts d d ts 1 ds +! ---- = -- [(km + ke) ----] + -- -- +! dt dz dz cw dz +! +! where: ts = temperature (kelvin) +! t = time (s) +! z = depth (m) +! km = molecular diffusion coefficient (m**2/s) +! ke = eddy diffusion coefficient (m**2/s) +! cw = heat capacity (j/m**3/kelvin) +! s = heat source term (w/m**2) +! +! Shallow lakes are allowed to have variable depth, set in _____. +! +! For shallow lakes: ke > 0 if unfrozen, +! and convective mixing occurs WHETHER OR NOT frozen. (See e.g. Martynov...) +! +! Use the Crank-Nicholson method to set up tridiagonal system of equations to +! solve for ts at time n+1, where the temperature equation for layer i is +! r_i = a_i [ts_i-1] n+1 + b_i [ts_i] n+1 + c_i [ts_i+1] n+1 +! +! The solution conserves energy as: +! +! [For lake layers] +! cw*([ts( 1)] n+1 - [ts( 1)] n)*dz( 1)/dt + ... + +! cw*([ts(nlevlake)] n+1 - [ts(nlevlake)] n)*dz(nlevlake)/dt = fin +! But now there is phase change, so cv is not constant and there is +! latent heat. +! +! where: +! [ts] n = old temperature (kelvin) +! [ts] n+1 = new temperature (kelvin) +! fin = heat flux into lake (w/m**2) +! = betaprime*sabg + forc_lwrad - eflx_lwrad_out - eflx_sh_tot - eflx_lh_tot +! (This is now the same as the ground heat flux.) +! + phi(1) + ... + phi(nlevlake) + phi(top soil level) +! betaprime = beta(islak) for no snow layers, and 1 for snow layers. +! This assumes all radiation is absorbed in the top snow layer and will need +! to be changed for CLM 4. +! +! WARNING: This subroutine assumes lake columns have one and only one pft. +! +! Outline: +! 1!) Initialization +! 2!) Lake density +! 3!) Diffusivity +! 4!) Heat source term from solar radiation penetrating lake +! 5!) Set thermal props and find initial energy content +! 6!) Set up vectors for tridiagonal matrix solution +! 7!) Solve tridiagonal and back-substitute +! 8!) (Optional) Do first energy check using temperature change at constant heat capacity. +! 9!) Phase change +! 9.5!) (Optional) Do second energy check using temperature change and latent heat, considering changed heat capacity. +! Also do soil water balance check. +!10!) Convective mixing +!11!) Do final energy check to detect small numerical errors (especially from convection) +! and dump small imbalance into sensible heat, or pass large errors to BalanceCheckMod for abort. +! +! REVISION HISTORY: +! Created by Zack Subin, 2009. +! Reedited by Hongping Gu, 2010. +!========================================================================================================= + + +! use TridiagonalMod , only : Tridiagonal + + implicit none + +!in: + real(r8), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) + real(r8), intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(r8), intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(r8), intent(in) :: dz(1,-nlevsnow + 1:nlevsoil) ! layer thickness for snow & soil (m) + real(r8), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(r8), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(r8), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + ! the other z and dz variables + real(r8), intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(r8), intent(in) :: ws(1) ! surface friction velocity (m/s) + real(r8), intent(in) :: ks(1) ! coefficient passed to ShalLakeTemperature + ! for calculation of decay of eddy diffusivity with depth + integer , intent(in) :: snl(1) ! negative of number of snow layers + real(r8), intent(inout) :: eflx_gnet(1) ! net heat flux into ground (W/m**2) at the surface interface + real(r8), intent(in) :: lakedepth(1) ! column lake depth (m) + + ! real(r8), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(r8), intent(inout) :: snowdp(1) !snow height (m) +!out: + + real(r8), intent(out) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(r8), intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(r8), intent(out) :: eflx_soil_grnd(1) ! heat flux into snow / lake (W/m**2) [+ = into soil] + ! Here this includes the whole lake radiation absorbed. +#if (defined SHLAKETEST) + real(r8), intent(out) :: qmelt(1) ! snow melt [mm/s] [temporary] +#endif + real(r8), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) [for snow & soil layers] + real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) [for snow & soil layers] + real(r8), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(r8), intent(out) :: savedtke1(1) ! top level thermal conductivity (W/mK) + real(r8), intent(out) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(r8), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) + integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + + +! OTHER LOCAL VARIABLES: + + integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake + real(r8), parameter :: p0 = 1._r8 ! neutral value of turbulent prandtl number + integer :: i,j,fc,fp,g,c,p ! do loop or array index +! real(r8) :: dtime ! land model time step (sec) + real(r8) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type + real(r8) :: za(2) ! base of surface absorption layer (m): depends on lake type + real(r8) :: eta(2) ! light extinction coefficient (/m): depends on lake type + real(r8) :: cwat ! specific heat capacity of water (j/m**3/kelvin) + real(r8) :: cice_eff ! effective heat capacity of ice (using density of + ! water because layer depth is not adjusted when freezing + real(r8) :: cfus ! effective heat of fusion per unit volume + ! using water density as above + real(r8) :: km ! molecular diffusion coefficient (m**2/s) + real(r8) :: tkice_eff ! effective conductivity since layer depth is constant + real(r8) :: a(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "a" vector for tridiagonal matrix + real(r8) :: b(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "b" vector for tridiagonal matrix + real(r8) :: c1(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "c" vector for tridiagonal matrix + real(r8) :: r(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "r" vector for tridiagonal solution + real(r8) :: rhow(lbc:ubc,nlevlake) ! density of water (kg/m**3) + real(r8) :: phi(lbc:ubc,nlevlake) ! solar radiation absorbed by layer (w/m**2) + real(r8) :: kme(lbc:ubc,nlevlake) ! molecular + eddy diffusion coefficient (m**2/s) + real(r8) :: rsfin ! relative flux of solar radiation into layer + real(r8) :: rsfout ! relative flux of solar radiation out of layer + real(r8) :: phi_soil(lbc:ubc) ! solar radiation into top soil layer (W/m**2) + real(r8) :: ri ! richardson number + real(r8) :: fin(lbc:ubc) ! net heat flux into lake at ground interface (w/m**2) + real(r8) :: ocvts(lbc:ubc) ! (cwat*(t_lake[n ])*dz + real(r8) :: ncvts(lbc:ubc) ! (cwat*(t_lake[n+1])*dz + real(r8) :: ke ! eddy diffusion coefficient (m**2/s) + real(r8) :: zin ! depth at top of layer (m) + real(r8) :: zout ! depth at bottom of layer (m) + real(r8) :: drhodz ! d [rhow] /dz (kg/m**4) + real(r8) :: n2 ! brunt-vaisala frequency (/s**2) + real(r8) :: num ! used in calculating ri + real(r8) :: den ! used in calculating ri + real(r8) :: tav_froz(lbc:ubc) ! used in aver temp for convectively mixed layers (C) + real(r8) :: tav_unfr(lbc:ubc) ! " + real(r8) :: nav(lbc:ubc) ! used in aver temp for convectively mixed layers + real(r8) :: phidum ! temporary value of phi + real(r8) :: iceav(lbc:ubc) ! used in calc aver ice for convectively mixed layers + real(r8) :: qav(lbc:ubc) ! used in calc aver heat content for conv. mixed layers + integer :: jtop(lbc:ubc) ! top level for each column (no longer all 1) + real(r8) :: cv (lbc:ubc,-nlevsnow+1:nlevsoil) !heat capacity of soil/snow [J/(m2 K)] + real(r8) :: tk (lbc:ubc,-nlevsnow+1:nlevsoil) !thermal conductivity of soil/snow [W/(m K)] + !(at interface below, except for j=0) + real(r8) :: cv_lake (lbc:ubc,1:nlevlake) !heat capacity [J/(m2 K)] + real(r8) :: tk_lake (lbc:ubc,1:nlevlake) !thermal conductivity at layer node [W/(m K)] + real(r8) :: cvx (lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat capacity for whole column [J/(m2 K)] + real(r8) :: tkix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !thermal conductivity at layer interfaces + !for whole column [W/(m K)] + real(r8) :: tx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! temperature of whole column [K] + real(r8) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] + real(r8) :: fnx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat diffusion through the layer interface below [W/m2] + real(r8) :: phix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !solar source term for whole column [W/m**2] + real(r8) :: zx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !interface depth (+ below surface) for whole column [m] + real(r8) :: dzm !used in computing tridiagonal matrix [m] + real(r8) :: dzp !used in computing tridiagonal matrix [m] + integer :: jprime ! j - nlevlake + real(r8) :: factx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !coefficient used in computing tridiagonal matrix + real(r8) :: t_lake_bef(lbc:ubc,1:nlevlake) !beginning lake temp for energy conservation check [K] + real(r8) :: t_soisno_bef(lbc:ubc,-nlevsnow+1:nlevsoil) !beginning soil temp for E cons. check [K] + real(r8) :: lhabs(lbc:ubc) ! total per-column latent heat abs. from phase change (J/m^2) + real(r8) :: esum1(lbc:ubc) ! temp for checking energy (J/m^2) + real(r8) :: esum2(lbc:ubc) ! "" + real(r8) :: zsum(lbc:ubc) ! temp for putting ice at the top during convection (m) + real(r8) :: wsum(lbc:ubc) ! temp for checking water (kg/m^2) + real(r8) :: wsum_end(lbc:ubc) ! temp for checking water (kg/m^2) + real(r8) :: errsoi(1) ! soil/lake energy conservation error (W/m**2) + real(r8) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) + CHARACTER*256 :: message +! +! Constants for lake temperature model +! + data beta/0.4_r8, 0.4_r8/ ! (deep lake, shallow lake) + data za /0.6_r8, 0.6_r8/ +! For now, keep beta and za for shallow lake the same as deep lake, until better data is found. +! It looks like eta is key and that larger values give better results for shallow lakes. Use +! empirical expression from Hakanson (below). This is still a very unconstrained parameter +! that deserves more attention. +! Some radiation will be allowed to reach the soil. +!----------------------------------------------------------------------- + + ! 1!) Initialization + ! Determine step size + +! dtime = get_step_size() + + ! Initialize constants + cwat = cpliq*denh2o ! water heat capacity per unit volume + cice_eff = cpice*denh2o !use water density because layer depth is not adjusted + !for freezing + cfus = hfus*denh2o ! latent heat per unit volume + tkice_eff = tkice * denice/denh2o !effective conductivity since layer depth is constant + km = tkwat/cwat ! a constant (molecular diffusivity) + + ! Begin calculations + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + ! Initialize Ebal quantities computed below + + ocvts(c) = 0._r8 + ncvts(c) = 0._r8 + esum1(c) = 0._r8 + esum2(c) = 0._r8 + + end do + + ! Initialize set of previous time-step variables as in DriverInit, + ! which is currently not called over lakes. This has to be done + ! here because phase change will occur in this routine. + ! Ice fraction of snow at previous time step + + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (j >= snl(c) + 1) then + frac_iceold(c,j) = h2osoi_ice(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j)) + end if + end do + end do + + ! Sum soil water. + do j = 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (j == 1) wsum(c) = 0._r8 + wsum(c) = wsum(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + end do + +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + + + ! Prepare for lake layer temperature calculations below + + ! fin(c) = betaprime * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + & + ! eflx_sh_tot(p) + eflx_lh_tot(p)) + ! fin(c) now passed from ShalLakeFluxes as eflx_gnet + fin(c) = eflx_gnet(p) + + end do + + ! 2!) Lake density + + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + rhow(c,j) = (1._r8 - lake_icefrac(c,j)) * & + 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,j)-277._r8))**1.68_r8 ) & + + lake_icefrac(c,j)*denice + ! Allow for ice fraction; assume constant ice density. + ! Is this the right weighted average? + ! Using this average will make sure that surface ice is treated properly during + ! convective mixing. + end do + end do + + ! 3!) Diffusivity and implied thermal "conductivity" = diffusivity * cwat + do j = 1, nlevlake-1 +!dir$ prefervector +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + drhodz = (rhow(c,j+1)-rhow(c,j)) / (z_lake(c,j+1)-z_lake(c,j)) + n2 = grav / rhow(c,j) * drhodz + ! Fixed sign error here: our z goes up going down into the lake, so no negative + ! sign is needed to make this positive unlike in Hostetler. --ZS + num = 40._r8 * n2 * (vkc*z_lake(c,j))**2 + den = max( (ws(c)**2) * exp(-2._r8*ks(c)*z_lake(c,j)), 1.e-10_r8 ) + ri = ( -1._r8 + sqrt( max(1._r8+num/den, 0._r8) ) ) / 20._r8 + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + ! ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri) + + if( t_lake(c,1) > 277.15_r8 ) then + if (lakedepth(c) > 15.0 ) then + ke = 1.e+2_r8*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri) + else + ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri) + endif + else + if (lakedepth(c) > 15.0 ) then + if (lakedepth(c) > 150.0 ) then + ke = 1.e+5_r8*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri) + else + ke =1.e+4_r8*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri) + end if + else + ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri) + endif + end if + + kme(c,j) = km + ke + tk_lake(c,j) = kme(c,j)*cwat + ! If there is some ice in this layer (this should rarely happen because the surface + ! is unfrozen and it will be unstable), still use the cwat to get out the tk b/c the eddy + ! diffusivity equation assumes water. + else + kme(c,j) = km + tk_lake(c,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + + tkwat*lake_icefrac(c,j) ) + ! Assume the resistances add as for the calculation of conductivities at layer interfaces. + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + j = nlevlake + kme(c,nlevlake) = kme(c,nlevlake-1) + + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + tk_lake(c,j) = tk_lake(c,j-1) + else + tk_lake(c,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + + tkwat*lake_icefrac(c,j) ) + end if + + ! Use in surface flux calculation for next timestep. + savedtke1(c) = kme(c,1)*cwat ! Will only be used if unfrozen + ! set number of column levels for use by Tridiagonal below + jtop(c) = snl(c) + 1 + end do + + ! 4!) Heat source term: unfrozen lakes only + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + + ! Set eta(:), the extinction coefficient, according to L Hakanson, Aquatic Sciences, 1995 + ! (regression of Secchi Depth with lake depth for small glacial basin lakes), and the + ! Poole & Atkins expression for extinction coeffient of 1.7 / Secchi Depth (m). +#ifndef ETALAKE + eta(:) = 1.1925_r8*lakedepth(c)**(-0.424) +#else + eta(:) = ETALAKE +#endif + + zin = z_lake(c,j) - 0.5_r8*dz_lake(c,j) + zout = z_lake(c,j) + 0.5_r8*dz_lake(c,j) + rsfin = exp( -eta(islak)*max( zin-za(islak),0._r8 ) ) + rsfout = exp( -eta(islak)*max( zout-za(islak),0._r8 ) ) + + ! Let rsfout for bottom layer go into soil. + ! This looks like it should be robust even for pathological cases, + ! like lakes thinner than za. + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + phidum = (rsfin-rsfout) * sabg(p) * (1._r8-beta(islak)) + if (j == nlevlake) then + phi_soil(c) = rsfout * sabg(p) * (1._r8-beta(islak)) + end if + else if (j == 1 .and. snl(c) == 0) then !if frozen but no snow layers + phidum = sabg(p) * (1._r8-beta(islak)) + else !radiation absorbed at surface + phidum = 0._r8 + if (j == nlevlake) phi_soil(c) = 0._r8 + end if + phi(c,j) = phidum + + end do + end do + + ! 5!) Set thermal properties and check initial energy content. + + ! For lake + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) + end do + end do + + ! For snow / soil + call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & + tk, cv, tktopsoillay) + + ! Sum cv*t_lake for energy check + ! Include latent heat term, and correction for changing heat capacity with phase change. + + ! This will need to be over all soil / lake / snow layers. Lake is below. + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + +! ocvts(c) = ocvts(c) + cv_lake(c,j)*t_lake(c,j) & + ocvts(c) = ocvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & + + cfus*dz_lake(c,j)*(1._r8-lake_icefrac(c,j)) !& +! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term + t_lake_bef(c,j) = t_lake(c,j) + end do + end do + + ! Now do for soil / snow layers + do j = -nlevsnow + 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then +! ocvts(c) = ocvts(c) + cv(c,j)*t_soisno(c,j) & + ocvts(c) = ocvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + + hfus*h2osoi_liq(c,j) !& +! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term + if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(c)) then + ocvts(c) = ocvts(c) - h2osno(c)*hfus + end if + t_soisno_bef(c,j) = t_soisno(c,j) + if(abs(t_soisno(c,j)-288) > 150) then + WRITE( message,* ) 'WARNING: Extreme t_soisno at c, level',c, j + ! CALL wrf_error_fatal ( message ) + endif + end if + end do + end do + +!!!!!!!!!!!!!!!!!!! + ! 6!) Set up vector r and vectors a, b, c1 that define tridiagonal matrix + + ! Heat capacity and resistance of snow without snow layers (<1cm) is ignored during diffusion, + ! but its capacity to absorb latent heat may be used during phase change. + + ! Set up interface depths, zx, heat capacities, cvx, solar source terms, phix, and temperatures, tx. + do j = -nlevsnow+1, nlevlake+nlevsoil +!dir$ prefervector +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + jprime = j - nlevlake + + if (j >= jtop(c)) then + if (j < 1) then !snow layer + zx(c,j) = z(c,j) + cvx(c,j) = cv(c,j) + phix(c,j) = 0._r8 + tx(c,j) = t_soisno(c,j) + else if (j <= nlevlake) then !lake layer + zx(c,j) = z_lake(c,j) + cvx(c,j) = cv_lake(c,j) + phix(c,j) = phi(c,j) + tx(c,j) = t_lake(c,j) + else !soil layer + zx(c,j) = zx(c,nlevlake) + dz_lake(c,nlevlake)/2._r8 + z(c,jprime) + cvx(c,j) = cv(c,jprime) + if (j == nlevlake + 1) then !top soil layer + phix(c,j) = phi_soil(c) + else !middle or bottom soil layer + phix(c,j) = 0._r8 + end if + tx(c,j) = t_soisno(c,jprime) + end if + end if + + end do + end do + + ! Determine interface thermal conductivities, tkix + + do j = -nlevsnow+1, nlevlake+nlevsoil +!dir$ prefervector +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + jprime = j - nlevlake + + if (j >= jtop(c)) then + if (j < 0) then !non-bottom snow layer + tkix(c,j) = tk(c,j) + else if (j == 0) then !bottom snow layer + dzp = zx(c,j+1) - zx(c,j) + tkix(c,j) = tk_lake(c,1)*tk(c,j)*dzp / & + (tk(c,j)*z_lake(c,1) + tk_lake(c,1)*(-z(c,j)) ) + ! tk(c,0) is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake + else if (j < nlevlake) then !non-bottom lake layer + tkix(c,j) = ( tk_lake(c,j)*tk_lake(c,j+1) * (dz_lake(c,j+1)+dz_lake(c,j)) ) & + / ( tk_lake(c,j)*dz_lake(c,j+1) + tk_lake(c,j+1)*dz_lake(c,j) ) + else if (j == nlevlake) then !bottom lake layer + dzp = zx(c,j+1) - zx(c,j) + tkix(c,j) = (tktopsoillay(c)*tk_lake(c,j)*dzp / & + (tktopsoillay(c)*dz_lake(c,j)/2._r8 + tk_lake(c,j)*z(c,1) ) ) + ! tktopsoillay is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake + else !soil layer + tkix(c,j) = tk(c,jprime) + end if + end if + + end do + end do + + + ! Determine heat diffusion through the layer interface and factor used in computing + ! tridiagonal matrix and set up vector r and vectors a, b, c1 that define tridiagonal + ! matrix and solve system + + do j = -nlevsnow+1, nlevlake+nlevsoil +!dir$ prefervector +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (j >= jtop(c)) then + if (j < nlevlake+nlevsoil) then !top or interior layer + factx(c,j) = dtime/cvx(c,j) + fnx(c,j) = tkix(c,j)*(tx(c,j+1)-tx(c,j))/(zx(c,j+1)-zx(c,j)) + else !bottom soil layer + factx(c,j) = dtime/cvx(c,j) + fnx(c,j) = 0._r8 !not used + end if + end if + enddo + end do + + do j = -nlevsnow+1,nlevlake+nlevsoil +!dir$ prefervector +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (j >= jtop(c)) then + if (j == jtop(c)) then !top layer + dzp = zx(c,j+1)-zx(c,j) + a(c,j) = 0._r8 + b(c,j) = 1+(1._r8-cnfac)*factx(c,j)*tkix(c,j)/dzp + c1(c,j) = -(1._r8-cnfac)*factx(c,j)*tkix(c,j)/dzp + r(c,j) = tx(c,j) + factx(c,j)*( fin(c) + phix(c,j) + cnfac*fnx(c,j) ) + else if (j < nlevlake+nlevsoil) then !middle layer + dzm = (zx(c,j)-zx(c,j-1)) + dzp = (zx(c,j+1)-zx(c,j)) + a(c,j) = - (1._r8-cnfac)*factx(c,j)* tkix(c,j-1)/dzm + b(c,j) = 1._r8+ (1._r8-cnfac)*factx(c,j)*(tkix(c,j)/dzp + tkix(c,j-1)/dzm) + c1(c,j) = - (1._r8-cnfac)*factx(c,j)* tkix(c,j)/dzp + r(c,j) = tx(c,j) + cnfac*factx(c,j)*( fnx(c,j) - fnx(c,j-1) ) + factx(c,j)*phix(c,j) + else !bottom soil layer + dzm = (zx(c,j)-zx(c,j-1)) + a(c,j) = - (1._r8-cnfac)*factx(c,j)*tkix(c,j-1)/dzm + b(c,j) = 1._r8+ (1._r8-cnfac)*factx(c,j)*tkix(c,j-1)/dzm + c1(c,j) = 0._r8 + r(c,j) = tx(c,j) - cnfac*factx(c,j)*fnx(c,j-1) + end if + end if + enddo + end do +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + ! 7!) Solve for tdsolution + + call Tridiagonal(lbc, ubc, -nlevsnow + 1, nlevlake + nlevsoil, jtop, num_shlakec, filter_shlakec, & + a, b, c1, r, tx) + + ! Set t_soisno and t_lake + do j = -nlevsnow+1, nlevlake + nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + jprime = j - nlevlake + + ! Don't do anything with invalid snow layers. + if (j >= jtop(c)) then + if (j < 1) then !snow layer + t_soisno(c,j) = tx(c,j) + else if (j <= nlevlake) then !lake layer + t_lake(c,j) = tx(c,j) + else !soil layer + t_soisno(c,jprime) = tx(c,j) + end if + end if + end do + end do + +!!!!!!!!!!!!!!!!!!!!!!! + + ! 8!) Sum energy content and total energy into lake for energy check. Any errors will be from the + ! Tridiagonal solution. + +#if (defined LAKEDEBUG) + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + esum1(c) = esum1(c) + (t_lake(c,j)-t_lake_bef(c,j))*cv_lake(c,j) + esum2(c) = esum2(c) + (t_lake(c,j)-tfrz)*cv_lake(c,j) + end do + end do + + do j = -nlevsnow+1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then + esum1(c) = esum1(c) + (t_soisno(c,j)-t_soisno_bef(c,j))*cv(c,j) + esum2(c) = esum2(c) + (t_soisno(c,j)-tfrz)*cv(c,j) + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + ! Again assuming only one pft per column +! esum1(c) = esum1(c) + lhabs(c) + errsoi(c) = esum1(c)/dtime - eflx_soil_grnd(p) + ! eflx_soil_grnd includes all the solar radiation absorbed in the lake, + ! unlike eflx_gnet + if(abs(errsoi(c)) > 1.e-5_r8) then + WRITE( message,* )'Primary soil energy conservation error in shlake & + column during Tridiagonal Solution,', 'error (W/m^2):', c, errsoi(c) + ! CALL wrf_error_fatal ( message ) + end if + end do + ! This has to be done before convective mixing because the heat capacities for each layer + ! will get scrambled. + +#endif + +!!!!!!!!!!!!!!!!!!!!!!! + + ! 9!) Phase change + call PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i + t_soisno,h2osoi_liq,h2osoi_ice, & !i&o + lake_icefrac,t_lake, snowdp, & !i&o + qflx_snomelt,eflx_snomelt,imelt, & !o + cv, cv_lake, & !i&o + lhabs) !o + +!!!!!!!!!!!!!!!!!!!!!!! + + ! 9.5!) Second energy check and water check. Now check energy balance before and after phase + ! change, considering the possibility of changed heat capacity during phase change, by + ! using initial heat capacity in the first step, final heat capacity in the second step, + ! and differences from tfrz only to avoid enthalpy correction for (cpliq-cpice)*melt*tfrz. + ! Also check soil water sum. + +#if (defined LAKEDEBUG) + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + esum2(c) = esum2(c) - (t_lake(c,j)-tfrz)*cv_lake(c,j) + end do + end do + + do j = -nlevsnow+1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then + esum2(c) = esum2(c) - (t_soisno(c,j)-tfrz)*cv(c,j) + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + ! Again assuming only one pft per column + esum2(c) = esum2(c) - lhabs(c) + errsoi(c) = esum2(c)/dtime + if(abs(errsoi(c)) > 1.e-5_r8) then + write(message,*)'Primary soil energy conservation error in shlake column during Phase Change, error (W/m^2):', & + c, errsoi(c) + ! CALL wrf_error_fatal ( message ) + end if + end do + + ! Check soil water + ! Sum soil water. + do j = 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (j == 1) wsum_end(c) = 0._r8 + wsum_end(c) = wsum_end(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + if (j == nlevsoil) then + if (abs(wsum(c)-wsum_end(c))>1.e-7_r8) then + write(message,*)'Soil water balance error during phase change in ShalLakeTemperature.', & + 'column, error (kg/m^2):', c, wsum_end(c)-wsum(c) + ! CALL wrf_error_fatal ( message ) + end if + end if + end do + end do + +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!! + ! 10!) Convective mixing: make sure fracice*dz is conserved, heat content c*dz*T is conserved, and + ! all ice ends up at the top. Done over all lakes even if frozen. + ! Either an unstable density profile or ice in a layer below an incompletely frozen layer will trigger. + + !Recalculate density + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + rhow(c,j) = (1._r8 - lake_icefrac(c,j)) * & + 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,j)-277._r8))**1.68_r8 ) & + + lake_icefrac(c,j)*denice + end do + end do + + do j = 1, nlevlake-1 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + qav(c) = 0._r8 + nav(c) = 0._r8 + iceav(c) = 0._r8 + end do + + do i = 1, j+1 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (rhow(c,j) > rhow(c,j+1) .or. & + (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) then +#if (defined LAKEDEBUG) + if (i==1) then + write(message,*), 'Convective Mixing in column ', c, '.' + ! CALL wrf_message(message) + endif +#endif + qav(c) = qav(c) + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & + ((1._r8 - lake_icefrac(c,i))*cwat + lake_icefrac(c,i)*cice_eff) +! tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i) + iceav(c) = iceav(c) + lake_icefrac(c,i)*dz_lake(c,i) + nav(c) = nav(c) + dz_lake(c,i) + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (rhow(c,j) > rhow(c,j+1) .or. & + (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) then + qav(c) = qav(c)/nav(c) + iceav(c) = iceav(c)/nav(c) + !If the average temperature is above freezing, put the extra energy into the water. + !If it is below freezing, take it away from the ice. + if (qav(c) > 0._r8) then + tav_froz(c) = 0._r8 !Celsius + tav_unfr(c) = qav(c) / ((1._r8 - iceav(c))*cwat) + else if (qav(c) < 0._r8) then + tav_froz(c) = qav(c) / (iceav(c)*cice_eff) + tav_unfr(c) = 0._r8 !Celsius + else + tav_froz(c) = 0._r8 + tav_unfr(c) = 0._r8 + end if + end if + end do + + do i = 1, j+1 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (nav(c) > 0._r8) then +! if(0==1) then + + !Put all the ice at the top.! + !If the average temperature is above freezing, put the extra energy into the water. + !If it is below freezing, take it away from the ice. + !For the layer with both ice & water, be careful to use the average temperature + !that preserves the correct total heat content given what the heat capacity of that + !layer will actually be. + if (i == 1) zsum(c) = 0._r8 + if ((zsum(c)+dz_lake(c,i))/nav(c) <= iceav(c)) then + lake_icefrac(c,i) = 1._r8 + t_lake(c,i) = tav_froz(c) + tfrz + else if (zsum(c)/nav(c) < iceav(c)) then + lake_icefrac(c,i) = (iceav(c)*nav(c) - zsum(c)) / dz_lake(c,i) + ! Find average value that preserves correct heat content. + t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(c)*cice_eff & + + (1._r8 - lake_icefrac(c,i))*tav_unfr(c)*cwat ) & + / ( lake_icefrac(c,i)*cice_eff + (1-lake_icefrac(c,i))*cwat ) + tfrz + else + lake_icefrac(c,i) = 0._r8 + t_lake(c,i) = tav_unfr(c) + tfrz + end if + zsum(c) = zsum(c) + dz_lake(c,i) + + rhow(c,i) = (1._r8 - lake_icefrac(c,i)) * & + 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,i)-277._r8))**1.68_r8 ) & + + lake_icefrac(c,i)*denice + end if + end do + end do + end do + +!!!!!!!!!!!!!!!!!!!!!!! + ! 11!) Re-evaluate thermal properties and sum energy content. + ! For lake + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) +#if (defined LAKEDEBUG) + write(message,*)'Lake Ice Fraction, c, level:', c, j, lake_icefrac(c,j) + ! CALL wrf_message(message) +#endif + end do + end do + ! For snow / soil + ! call SoilThermProp_Lake(lbc, ubc, num_shlakec, filter_shlakec, tk, cv, tktopsoillay) + call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & + tk, cv, tktopsoillay) + + + ! Do as above to sum energy content + do j = 1, nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + +! ncvts(c) = ncvts(c) + cv_lake(c,j)*t_lake(c,j) & + ncvts(c) = ncvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & + + cfus*dz_lake(c,j)*(1._r8-lake_icefrac(c,j)) !& +! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term + fin(c) = fin(c) + phi(c,j) + end do + end do + + do j = -nlevsnow + 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then +! ncvts(c) = ncvts(c) + cv(c,j)*t_soisno(c,j) & + ncvts(c) = ncvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + + hfus*h2osoi_liq(c,j) !& +! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term + if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(c)) then + ncvts(c) = ncvts(c) - h2osno(c)*hfus + end if + end if + if (j == 1) fin(c) = fin(c) + phi_soil(c) + end do + end do + + + ! Check energy conservation. + + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) +#ifndef LAKEDEBUG +! if (abs(errsoi(c)) < 0.10_r8) then ! else send to Balance Check and abort + if (abs(errsoi(c)) < 10._r8) then ! else send to Balance Check and abort +#else + if (abs(errsoi(c)) < 1._r8) then +#endif + eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) + eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) + eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) + eflx_gnet(p) = eflx_gnet(p) + errsoi(c) +! if (abs(errsoi(c)) > 1.e-3_r8) then + if (abs(errsoi(c)) > 1.e-1_r8) then + write(message,*)'errsoi incorporated into sensible heat in ShalLakeTemperature: c, (W/m^2):', c, errsoi(c) + ! CALL wrf_message(message) + end if + errsoi(c) = 0._r8 +#if (defined LAKEDEBUG) + else + write(message,*)'Soil Energy Balance Error at column, ', c, 'G, fintotal, column E tendency = ', & + eflx_gnet(p), fin(c), (ncvts(c)-ocvts(c)) / dtime + ! CALL wrf_message(message) +#endif + end if + end do + ! This loop assumes only one point per column. + + end subroutine ShalLakeTemperature + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!----------------------------------------------------------------------- +!BOP +! +! ROUTINE: SoilThermProp_Lake +! +! !INTERFACE: + subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & + tk, cv, tktopsoillay) + +! +! !DESCRIPTION: +! Calculation of thermal conductivities and heat capacities of +! snow/soil layers +! (1) The volumetric heat capacity is calculated as a linear combination +! in terms of the volumetric fraction of the constituent phases. +! +! (2) The thermal conductivity of soil is computed from the algorithm of +! Johansen (as reported by Farouki 1981), and of snow is from the +! formulation used in SNTHERM (Jordan 1991). +! The thermal conductivities at the interfaces between two neighboring +! layers (j, j+1) are derived from an assumption that the flux across +! the interface is equal to that from the node j to the interface and the +! flux from the interface to the node j+1. +! +! For lakes, the proper soil layers (not snow) should always be saturated. +! +! !USES: + + implicit none +!in + + integer , intent(in) :: snl(1) ! number of snow layers +! real(r8), intent(in) :: h2osno(1) ! snow water (mm H2O) + ! real(r8), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + ! real(r8), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + ! real(r8), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + ! real(r8), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + ! real(r8), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(r8), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness (m) + real(r8), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(r8), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) + real(r8), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil temperature (Kelvin) + real(r8), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(r8), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + +!out + real(r8), intent(out) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] + real(r8), intent(out) :: tk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity [W/(m K)] + real(r8), intent(out) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !CALLED FROM: +! subroutine ShalLakeTemperature in this module. +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/13/02, Peter Thornton: migrated to new data structures +! 7/01/03, Mariana Vertenstein: migrated to vector code +! 4/09, Zack Subin, adjustment for ShalLake code. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !LOCAL VARIABLES: +! +! local pointers to original implicit in scalars +! +! integer , pointer :: clandunit(:) ! column's landunit +! integer , pointer :: ityplun(:) ! landunit type +! +!EOP + + +! OTHER LOCAL VARIABLES: + + integer :: l,c,j ! indices + integer :: fc ! lake filtered column indices + real(r8) :: bw ! partial density of water (ice + liquid) + real(r8) :: dksat ! thermal conductivity for saturated soil (j/(k s m)) + real(r8) :: dke ! kersten number + real(r8) :: fl ! fraction of liquid or unfrozen water to total water + real(r8) :: satw ! relative total water content of soil. + real(r8) :: thk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity of layer + character*256 :: message + +! Thermal conductivity of soil from Farouki (1981) + + do j = -nlevsnow+1,nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + ! Only examine levels from 1->nlevsoil + if (j >= 1) then +! l = clandunit(c) +! if (ityplun(l) /= istwet .AND. ityplun(l) /= istice) then + ! This could be altered later for allowing this to be over glaciers. + + ! Soil should be saturated. +#if (defined LAKEDEBUG) + satw = (h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice)/(dz(c,j)*watsat(c,j)) +! satw = min(1._r8, satw) + if (satw < 0.999_r8) then + write(message,*)'WARNING: soil layer unsaturated in SoilThermProp_Lake, satw, j = ', satw, j + ! CALL wrf_error_fatal ( message ) + end if + ! Could use denice because if it starts out frozen, the volume of water will go below sat., + ! since we're not yet doing excess ice. + ! But take care of this in HydrologyLake. +#endif + satw = 1._r8 + fl = h2osoi_liq(c,j)/(h2osoi_ice(c,j)+h2osoi_liq(c,j)) + if (t_soisno(c,j) >= tfrz) then ! Unfrozen soil + dke = max(0._r8, log10(satw) + 1.0_r8) + dksat = tksatu(c,j) + else ! Frozen soil + dke = satw + dksat = tkmg(c,j)*0.249_r8**(fl*watsat(c,j))*2.29_r8**watsat(c,j) + endif + thk(c,j) = dke*dksat + (1._r8-dke)*tkdry(c,j) +! else +! thk(c,j) = tkwat +! if (t_soisno(c,j) < tfrz) thk(c,j) = tkice +! endif + endif + + ! Thermal conductivity of snow, which from Jordan (1991) pp. 18 + ! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1 + if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then + bw = (h2osoi_ice(c,j)+h2osoi_liq(c,j))/dz(c,j) + thk(c,j) = tkairc + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkairc) + end if + + end do + end do + + ! Thermal conductivity at the layer interface + + ! Have to correct for the fact that bottom snow layer and top soil layer border lake. + ! For the first case, the snow layer conductivity for the middle of the layer will be returned. + ! Because the interfaces are below the soil layers, the conductivity for the top soil layer + ! will have to be returned separately. + do j = -nlevsnow+1,nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (j >= snl(c)+1 .AND. j <= nlevsoil-1 .AND. j /= 0) then + tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) & + /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j))) + else if (j == 0) then + tk(c,j) = thk(c,j) + else if (j == nlevsoil) then + tk(c,j) = 0._r8 + end if + ! For top soil layer. + if (j == 1) tktopsoillay(c) = thk(c,j) + end do + end do + + ! Soil heat capacity, from de Vires (1963) + + do j = 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) +! l = clandunit(c) +! if (ityplun(l) /= istwet .AND. ityplun(l) /= istice) then + cv(c,j) = csol(c,j)*(1-watsat(c,j))*dz(c,j) + & + (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) +! else +! cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) +! endif +! if (j == 1) then +! if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8) then +! cv(c,j) = cv(c,j) + cpice*h2osno(c) +! end if +! end if + ! Won't worry about heat capacity for thin snow on lake with no snow layers. + enddo + end do + + ! Snow heat capacity + + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (snl(c)+1 < 1 .and. j >= snl(c)+1) then + cv(c,j) = cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j) + end if + end do + end do + + end subroutine SoilThermProp_Lake + + +!----------------------------------------------------------------------- +!BOP +! +! ROUTINE: PhaseChange_Lake +! +! !INTERFACE: + subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i + t_soisno,h2osoi_liq,h2osoi_ice, & !i&o + lake_icefrac,t_lake, snowdp, & !i&o + qflx_snomelt,eflx_snomelt,imelt, & !o + cv, cv_lake, & !i&o + lhabs) !o +!============================================================================================= +! !DESCRIPTION: +! Calculation of the phase change within snow, soil, & lake layers: +! (1) Check the conditions for which the phase change may take place, +! i.e., the layer temperature is great than the freezing point +! and the ice mass is not equal to zero (i.e. melting), +! or the layer temperature is less than the freezing point +! and the liquid water mass is greater than the allowable supercooled +! (i.e. freezing). +! (2) Assess the amount of phase change from the energy excess (or deficit) +! after setting the layer temperature to freezing point, depending on +! how much water or ice is available. +! (3) Re-adjust the ice and liquid mass, and the layer temperature: either to +! the freezing point if enough water or ice is available to fully compensate, +! or to a remaining temperature. +! The specific heats are assumed constant. Potential cycling errors resulting from +! this assumption will be trapped at the end of ShalLakeTemperature. +! !CALLED FROM: +! subroutine ShalLakeTemperature in this module +! +! !REVISION HISTORY: +! 04/2009 Zack Subin: Initial code +!============================================================================================== +! !USES: +! +! !ARGUMENTS: + implicit none +!in: + + integer , intent(in) :: snl(1) !number of snow layers + real(r8), intent(inout) :: h2osno(1) !snow water (mm H2O) + real(r8), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + real(r8), intent(in) :: dz_lake(1,nlevlake) !lake layer thickness (m) + ! Needed in case snow height is less than critical value. + +!inout: + + real(r8), intent(inout) :: snowdp(1) !snow height (m) + real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(r8), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(r8), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) +!out: + + real(r8), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) + real(r8), intent(out) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) + integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + !What's the sign of this? Is it just output? + real(r8), intent(inout) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] + real(r8), intent(inout) :: cv_lake (lbc:ubc,1:nlevlake) ! heat capacity [J/(m2 K)] + real(r8), intent(out):: lhabs(lbc:ubc) ! total per-column latent heat abs. (J/m^2) + + +! OTHER LOCAL VARIABLES: + + integer :: j,c,g !do loop index + integer :: fc !lake filtered column indices +! real(r8) :: dtime !land model time step (sec) + real(r8) :: heatavail !available energy for melting or freezing (J/m^2) + real(r8) :: heatrem !energy residual or loss after melting or freezing + real(r8) :: melt !actual melting (+) or freezing (-) [kg/m2] + real(r8), parameter :: smallnumber = 1.e-7_r8 !to prevent tiny residuals from rounding error + logical :: dophasechangeflag +!----------------------------------------------------------------------- + +! dtime = get_step_size() + + ! Initialization + +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + qflx_snomelt(c) = 0._r8 + eflx_snomelt(c) = 0._r8 + lhabs(c) = 0._r8 + end do + + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + if (j >= snl(c) + 1) imelt(c,j) = 0 + end do + end do + + ! Check for case of snow without snow layers and top lake layer temp above freezing. + +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + if (snl(c) == 0 .and. h2osno(c) > 0._r8 .and. t_lake(c,1) > tfrz) then + heatavail = (t_lake(c,1) - tfrz) * cv_lake(c,1) + melt = min(h2osno(c), heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0._r8) + !catch small negative value to keep t at tfrz + t_lake(c,1) = tfrz + heatrem/(cv_lake(c,1)) + snowdp(c) = snowdp(c)*(1._r8 - melt/h2osno(c)) + h2osno(c) = h2osno(c) - melt + lhabs(c) = lhabs(c) + melt*hfus + qflx_snomelt(c) = qflx_snomelt(c) + melt + ! Prevent tiny residuals + if (h2osno(c) < smallnumber) h2osno(c) = 0._r8 + if (snowdp(c) < smallnumber) snowdp(c) = 0._r8 + end if + end do + + ! Lake phase change + + do j = 1,nlevlake +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + dophasechangeflag = .false. + if (t_lake(c,j) > tfrz .and. lake_icefrac(c,j) > 0._r8) then ! melting + dophasechangeflag = .true. + heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) + melt = min(lake_icefrac(c,j)*denh2o*dz_lake(c,j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = max(heatavail - melt*hfus, 0._r8) + !catch small negative value to keep t at tfrz + else if (t_lake(c,j) < tfrz .and. lake_icefrac(c,j) < 1._r8) then !freezing + dophasechangeflag = .true. + heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) + melt = max(-(1._r8-lake_icefrac(c,j))*denh2o*dz_lake(c,j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = min(heatavail - melt*hfus, 0._r8) + !catch small positive value to keep t at tfrz + end if + ! Update temperature and ice fraction. + if (dophasechangeflag) then + lake_icefrac(c,j) = lake_icefrac(c,j) - melt/(denh2o*dz_lake(c,j)) + lhabs(c) = lhabs(c) + melt*hfus + ! Update heat capacity + cv_lake(c,j) = cv_lake(c,j) + melt*(cpliq-cpice) + t_lake(c,j) = tfrz + heatrem/cv_lake(c,j) + ! Prevent tiny residuals + if (lake_icefrac(c,j) > 1._r8 - smallnumber) lake_icefrac(c,j) = 1._r8 + if (lake_icefrac(c,j) < smallnumber) lake_icefrac(c,j) = 0._r8 + end if + end do + end do + + ! Snow & soil phase change + + do j = -nlevsnow+1,nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + dophasechangeflag = .false. + + if (j >= snl(c) + 1) then + + if (t_soisno(c,j) > tfrz .and. h2osoi_ice(c,j) > 0._r8) then ! melting + dophasechangeflag = .true. + heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) + melt = min(h2osoi_ice(c,j), heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0._r8) + !catch small negative value to keep t at tfrz + if (j <= 0) then !snow + imelt(c,j) = 1 + qflx_snomelt(c) = qflx_snomelt(c) + melt + end if + else if (t_soisno(c,j) < tfrz .and. h2osoi_liq(c,j) > 0._r8) then !freezing + dophasechangeflag = .true. + heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) + melt = max(-h2osoi_liq(c,j), heatavail/hfus) + heatrem = min(heatavail - melt*hfus, 0._r8) + !catch small positive value to keep t at tfrz + if (j <= 0) then !snow + imelt(c,j) = 2 + qflx_snomelt(c) = qflx_snomelt(c) + melt + ! Does this works for both signs of melt in SnowHydrology? I think + ! qflx_snomelt(c) is just output. + end if + end if + + ! Update temperature and soil components. + if (dophasechangeflag) then + h2osoi_ice(c,j) = h2osoi_ice(c,j) - melt + h2osoi_liq(c,j) = h2osoi_liq(c,j) + melt + lhabs(c) = lhabs(c) + melt*hfus + ! Update heat capacity + cv(c,j) = cv(c,j) + melt*(cpliq-cpice) + t_soisno(c,j) = tfrz + heatrem/cv(c,j) + ! Prevent tiny residuals + if (h2osoi_ice(c,j) < smallnumber) h2osoi_ice(c,j) = 0._r8 + if (h2osoi_liq(c,j) < smallnumber) h2osoi_liq(c,j) = 0._r8 + end if + + end if + end do + end do + + ! Update eflx_snomelt(c) +!dir$ concurrent +!cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + eflx_snomelt(c) = qflx_snomelt(c)*hfus + end do +!!! + + end subroutine PhaseChange_Lake + + + subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & !i + begwb,qflx_evap_tot,forc_t,do_capsnow, & + t_grnd,qflx_evap_soi, & + qflx_snomelt,imelt,frac_iceold, & !i add by guhp + z,dz,zi,snl,h2osno,snowdp,lake_icefrac,t_lake, & !i&o + endwb,snowage,snowice,snowliq,t_snow, & !o + t_soisno,h2osoi_ice,h2osoi_liq,h2osoi_vol, & + qflx_drain,qflx_surf,qflx_infl,qflx_qrgwl, & + qcharge,qflx_prec_grnd,qflx_snowcap, & + qflx_snowcap_col,qflx_snow_grnd_pft, & + qflx_snow_grnd_col,qflx_rain_grnd, & + qflx_evap_tot_col,soilalpha,zwt,fcov, & + rootr_column,qflx_evap_grnd,qflx_sub_snow, & + qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col) + +!================================================================================== +! !DESCRIPTION: +! Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is +! done. However, there is no infiltration, and the water budget is balanced with +! qflx_qrgwl. Lake water mass is kept constant. The soil is simply maintained at +! volumetric saturation if ice melting frees up pore space. Likewise, if the water +! portion alone at some point exceeds pore capacity, it is reduced. This is consistent +! with the possibility of initializing the soil layer with excess ice. The only +! real error with that is that the thermal conductivity will ignore the excess ice +! (and accompanying thickness change). +! +! If snow layers are present over an unfrozen lake, and the top layer of the lake +! is capable of absorbing the latent heat without going below freezing, +! the snow-water is runoff and the latent heat is subtracted from the lake. +! +! WARNING: This subroutine assumes lake columns have one and only one pft. +! +! Sequence is: +! ShalLakeHydrology: +! Do needed tasks from Hydrology1, Biogeophysics2, & top of Hydrology2. +! -> SnowWater: change of snow mass and snow water onto soil +! -> SnowCompaction: compaction of snow layers +! -> CombineSnowLayers: combine snow layers that are thinner than minimum +! -> DivideSnowLayers: subdivide snow layers that are thicker than maximum +! Add water to soil if melting has left it with open pore space. +! Cleanup and do water balance. +! If snow layers are found above a lake with unfrozen top layer, whose top +! layer has enough heat to melt all the snow ice without freezing, do so +! and eliminate the snow layers. +! +! !REVISION HISTORY: +! Created by Zack Subin, 2009 +! +!============================================================================================ + +! USES: +! + implicit none + +! in: + + ! integer , intent(in) :: clandunit(1) ! column's landunit + ! integer , intent(in) :: ityplun(1) ! landunit type + ! real(r8), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) + real(r8), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(r8), intent(in) :: forc_rain(1) ! rain rate [mm/s] + real(r8), intent(in) :: forc_snow(1) ! snow rate [mm/s] + real(r8), intent(in) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(r8), intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) +#if (defined OFFLINE) + real(r8), intent(in) :: flfall(1) ! fraction of liquid water within falling precipitation +#endif + logical , intent(in) :: do_capsnow(1) ! true => do snow capping + real(r8), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) + real(r8), intent(in) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(r8), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) + integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 + +!inout: + + real(r8), intent(inout) :: begwb(1) ! water mass begining of the time step + +! inout: + + + real(r8), intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) + real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness depth (m) + real(r8), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface depth (m) + integer , intent(inout) :: snl(1) ! number of snow layers + real(r8), intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(r8), intent(inout) :: snowdp(1) ! snow height (m) + real(r8), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(r8), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + + real(r8), intent(inout) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water +! out: + + + real(r8), intent(out) :: endwb(1) ! water mass end of the time step + real(r8), intent(out) :: snowage(1) ! non dimensional snow age [-] + real(r8), intent(out) :: snowice(1) ! average snow ice lens + real(r8), intent(out) :: snowliq(1) ! average snow liquid water + real(r8), intent(out) :: t_snow(1) ! vertically averaged snow temperature + real(r8), intent(out) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! snow temperature (Kelvin) + real(r8), intent(out) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(r8), intent(out) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(r8), intent(out) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(r8), intent(out) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) + real(r8), intent(out) :: qflx_surf(1) ! surface runoff (mm H2O /s) + real(r8), intent(out) :: qflx_infl(1) ! infiltration (mm H2O /s) + real(r8), intent(out) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes + real(r8), intent(out) :: qcharge(1) ! aquifer recharge rate (mm/s) + real(r8), intent(out) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(r8), intent(out) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(r8), intent(out) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(r8), intent(out) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] + real(r8), intent(out) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] + real(r8), intent(out) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] + real(r8), intent(out) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) + real(r8) ,intent(out) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) + real(r8), intent(out) :: zwt(1) !water table depth + real(r8), intent(out) :: fcov(1) !fractional area with water table at surface + real(r8), intent(out) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer + real(r8), intent(out) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] + real(r8), intent(out) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] + real(r8), intent(out) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] + real(r8), intent(out) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] + real(r8), intent(out) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] + +! Block of biogeochem currently not used. +#ifndef SHLAKE + real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm) + real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b" + real(r8), pointer :: bsw2(:,:) ! Clapp and Hornberger "b" for CN code + real(r8), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa) + real(r8), pointer :: vwcsat(:,:) ! volumetric water content at saturation for CN code (m3/m3) + real(r8), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m + real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) + real(r8) :: psi,vwc,fsat ! temporary variables for soilpsi calculation +#if (defined DGVM) || (defined CN) + real(r8) :: watdry ! temporary + real(r8) :: rwat(lbc:ubc) ! soil water wgted by depth to maximum depth of 0.5 m + real(r8) :: swat(lbc:ubc) ! same as rwat but at saturation + real(r8) :: rz(lbc:ubc) ! thickness of soil layers contributing to rwat (m) + real(r8) :: tsw ! volumetric soil water to 0.5 m + real(r8) :: stsw ! volumetric soil water to 0.5 m at saturation +#endif +#endif + + +! OTHER LOCAL VARIABLES: + + integer :: p,fp,g,l,c,j,fc,jtop ! indices + integer :: num_shlakesnowc ! number of column snow points + integer :: filter_shlakesnowc(ubc-lbc+1) ! column filter for snow points + integer :: num_shlakenosnowc ! number of column non-snow points + integer :: filter_shlakenosnowc(ubc-lbc+1) ! column filter for non-snow points +! real(r8) :: dtime ! land model time step (sec) + integer :: newnode ! flag when new snow node is set, (1=yes, 0=no) + real(r8) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s] + real(r8) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(r8) :: fracsnow(lbp:ubp) ! frac of precipitation that is snow + real(r8) :: fracrain(lbp:ubp) ! frac of precipitation that is rain + real(r8) :: qflx_prec_grnd_snow(lbp:ubp) ! snow precipitation incident on ground [mm/s] + real(r8) :: qflx_prec_grnd_rain(lbp:ubp) ! rain precipitation incident on ground [mm/s] + real(r8) :: qflx_evap_soi_lim ! temporary evap_soi limited by top snow layer content [mm/s] + real(r8) :: h2osno_temp ! temporary h2osno [kg/m^2] + real(r8), parameter :: snow_bd = 250._r8 !constant snow bulk density (only used in special case here) [kg/m^3] + real(r8) :: sumsnowice(lbc:ubc) ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] + logical :: unfrozen(lbc:ubc) ! true if top lake layer is unfrozen with snow layers above + real(r8) :: heatrem ! used in case above [J/m^2] + real(r8) :: heatsum(lbc:ubc) ! used in case above [J/m^2] + real(r8) :: qflx_top_soil(1) !net water input into soil from top (mm/s) + character*256 :: message + +#if (defined LAKEDEBUG) + real(r8) :: snow_water(lbc:ubc) ! temporary sum of snow water for Bal Check [kg/m^2] +#endif +!----------------------------------------------------------------------- + + + ! Determine step size + +! dtime = get_step_size() + + ! Add soil water to water balance. + do j = 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + end do + +!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Do precipitation onto ground, etc., from Hydrology1. + +!dir$ concurrent +!cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + g = pgridcell(p) +! l = plandunit(p) + c = pcolumn(p) + + ! Precipitation onto ground (kg/(m2 s)) +! ! PET, 1/18/2005: Added new terms for mass balance correction +! ! due to dynamic pft weight shifting (column-level h2ocan_loss) +! ! Because the fractionation between rain and snow is indeterminate if +! ! rain + snow = 0, I am adding this very small flux only to the rain +! ! components. + ! Not relevant unless PFTs are added to lake later. +! if (frac_veg_nosno(p) == 0) then + qflx_prec_grnd_snow(p) = forc_snow(g) + qflx_prec_grnd_rain(p) = forc_rain(g) !+ h2ocan_loss(c) +! else +! qflx_prec_grnd_snow(p) = qflx_through_snow(p) + (qflx_candrip(p) * fracsnow(p)) +! qflx_prec_grnd_rain(p) = qflx_through_rain(p) + (qflx_candrip(p) * fracrain(p)) + h2ocan_loss(c) +! end if + qflx_prec_grnd(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p) + + if (do_capsnow(c)) then + qflx_snowcap(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p) + qflx_snow_grnd_pft(p) = 0._r8 + qflx_rain_grnd(p) = 0._r8 + else + qflx_snowcap(p) = 0._r8 +#if (defined OFFLINE) + qflx_snow_grnd_pft(p) = qflx_prec_grnd(p)*(1._r8-flfall(g)) ! ice onto ground (mm/s) + qflx_rain_grnd(p) = qflx_prec_grnd(p)*flfall(g) ! liquid water onto ground (mm/s) +#else + qflx_snow_grnd_pft(p) = qflx_prec_grnd_snow(p) ! ice onto ground (mm/s) + qflx_rain_grnd(p) = qflx_prec_grnd_rain(p) ! liquid water onto ground (mm/s) +#endif + end if + ! Assuming one PFT; needed for below + qflx_snow_grnd_col(c) = qflx_snow_grnd_pft(p) + qflx_rain_grnd_col(c) = qflx_rain_grnd(p) + + end do ! (end pft loop) + + ! Determine snow height and snow water + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) +! l = clandunit(c) + g = cgridcell(c) + + ! Use Alta relationship, Anderson(1976); LaChapelle(1961), + ! U.S.Department of Agriculture Forest Service, Project F, + ! Progress Rep. 1, Alta Avalanche Study Center:Snow Layer Densification. + + if (do_capsnow(c)) then + dz_snowf = 0._r8 + else + if (forc_t(g) > tfrz + 2._r8) then + bifall=50._r8 + 1.7_r8*(17.0_r8)**1.5_r8 + else if (forc_t(g) > tfrz - 15._r8) then + bifall=50._r8 + 1.7_r8*(forc_t(g) - tfrz + 15._r8)**1.5_r8 + else + bifall=50._r8 + end if + dz_snowf = qflx_snow_grnd_col(c)/bifall + snowdp(c) = snowdp(c) + dz_snowf*dtime + h2osno(c) = h2osno(c) + qflx_snow_grnd_col(c)*dtime ! snow water equivalent (mm) + end if + +! if (itype(l)==istwet .and. t_grnd(c)>tfrz) then +! h2osno(c)=0._r8 +! snowdp(c)=0._r8 +! snowage(c)=0._r8 +! end if + ! Take care of this later in function. + + ! When the snow accumulation exceeds 10 mm, initialize snow layer + ! Currently, the water temperature for the precipitation is simply set + ! as the surface air temperature + + newnode = 0 ! flag for when snow node will be initialized + if (snl(c) == 0 .and. qflx_snow_grnd_col(c) > 0.0_r8 .and. snowdp(c) >= 0.01_r8) then + newnode = 1 + snl(c) = -1 + dz(c,0) = snowdp(c) ! meter + z(c,0) = -0.5_r8*dz(c,0) + zi(c,-1) = -dz(c,0) + snowage(c) = 0._r8 ! snow age + t_soisno(c,0) = min(tfrz, forc_t(g)) ! K + h2osoi_ice(c,0) = h2osno(c) ! kg/m2 + h2osoi_liq(c,0) = 0._r8 ! kg/m2 + frac_iceold(c,0) = 1._r8 + end if + + ! The change of ice partial density of surface node due to precipitation. + ! Only ice part of snowfall is added here, the liquid part will be added + ! later. + + if (snl(c) < 0 .and. newnode == 0) then + h2osoi_ice(c,snl(c)+1) = h2osoi_ice(c,snl(c)+1)+dtime*qflx_snow_grnd_col(c) + dz(c,snl(c)+1) = dz(c,snl(c)+1)+dz_snowf*dtime + end if + + end do + + ! Calculate sublimation and dew, adapted from HydrologyLake and Biogeophysics2. + +!dir$ concurrent +!cdir nodep + do fp = 1,num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + jtop = snl(c)+1 + + ! Use column variables here + qflx_evap_grnd(c) = 0._r8 + qflx_sub_snow(c) = 0._r8 + qflx_dew_snow(c) = 0._r8 + qflx_dew_grnd(c) = 0._r8 + + if (jtop <= 0) then ! snow layers + j = jtop + ! Assign ground evaporation to sublimation from soil ice or to dew + ! on snow or ground + + if (qflx_evap_soi(p) >= 0._r8) then + ! for evaporation partitioning between liquid evap and ice sublimation, + ! use the ratio of liquid to (liquid+ice) in the top layer to determine split + ! Since we're not limiting evap over lakes, but still can't remove more from top + ! snow layer than there is there, create temp. limited evap_soi. + qflx_evap_soi_lim = min(qflx_evap_soi(p), (h2osoi_liq(c,j)+h2osoi_ice(c,j))/dtime) + if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0._r8) then + qflx_evap_grnd(c) = max(qflx_evap_soi_lim*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._r8) + else + qflx_evap_grnd(c) = 0._r8 + end if + qflx_sub_snow(c) = qflx_evap_soi_lim - qflx_evap_grnd(c) + else + if (t_grnd(c) < tfrz) then + qflx_dew_snow(c) = abs(qflx_evap_soi(p)) + else + qflx_dew_grnd(c) = abs(qflx_evap_soi(p)) + end if + end if + ! Update the pft-level qflx_snowcap + ! This was moved in from Hydrology2 to keep all pft-level + ! calculations out of Hydrology2 + if (do_capsnow(c)) qflx_snowcap(p) = qflx_snowcap(p) + qflx_dew_snow(c) + qflx_dew_grnd(c) + + else ! No snow layers: do as in HydrologyLake but with actual clmtype variables + if (qflx_evap_soi(p) >= 0._r8) then + ! Sublimation: do not allow for more sublimation than there is snow + ! after melt. Remaining surface evaporation used for infiltration. + qflx_sub_snow(c) = min(qflx_evap_soi(p), h2osno(c)/dtime) + qflx_evap_grnd(c) = qflx_evap_soi(p) - qflx_sub_snow(c) + else + if (t_grnd(c) < tfrz-0.1_r8) then + qflx_dew_snow(c) = abs(qflx_evap_soi(p)) + else + qflx_dew_grnd(c) = abs(qflx_evap_soi(p)) + end if + end if + + ! Update snow pack for dew & sub. + h2osno_temp = h2osno(c) + if (do_capsnow(c)) then + h2osno(c) = h2osno(c) - qflx_sub_snow(c)*dtime + qflx_snowcap(p) = qflx_snowcap(p) + qflx_dew_snow(c) + qflx_dew_grnd(c) + else + h2osno(c) = h2osno(c) + (-qflx_sub_snow(c)+qflx_dew_snow(c))*dtime + end if + if (h2osno_temp > 0._r8) then + snowdp(c) = snowdp(c) * h2osno(c) / h2osno_temp + else + snowdp(c) = h2osno(c)/snow_bd !Assume a constant snow bulk density = 250. + end if + +#if (defined PERGRO) + if (abs(h2osno(c)) < 1.e-10_r8) h2osno(c) = 0._r8 +#else + h2osno(c) = max(h2osno(c), 0._r8) +#endif + + end if + + qflx_snowcap_col(c) = qflx_snowcap(p) + + end do + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Determine initial snow/no-snow filters (will be modified possibly by + ! routines CombineSnowLayers and DivideSnowLayers below + + call BuildSnowFilter(lbc, ubc, num_shlakec, filter_shlakec,snl, & !i + num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) !o + + ! Determine the change of snow mass and the snow water onto soil + + call SnowWater(lbc, ubc, num_shlakesnowc, filter_shlakesnowc, & !i + num_shlakenosnowc, filter_shlakenosnowc, & !i + snl,do_capsnow,qflx_snomelt,qflx_rain_grnd, & !i + qflx_sub_snow,qflx_evap_grnd, & !i + qflx_dew_snow,qflx_dew_grnd,dz, & !i + h2osoi_ice,h2osoi_liq, & !i&o + qflx_top_soil) !o + + + ! Determine soil hydrology + ! Here this consists only of making sure that soil is saturated even as it melts and 10% + ! of pore space opens up. Conversely, if excess ice is melting and the liquid water exceeds the + ! saturation value, then remove water. + + do j = 1,nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (h2osoi_vol(c,j) < watsat(c,j)) then + h2osoi_liq(c,j) = (watsat(c,j)*dz(c,j) - h2osoi_ice(c,j)/denice)*denh2o + ! h2osoi_vol will be updated below, and this water addition will come from qflx_qrgwl + else if (h2osoi_liq(c,j) > watsat(c,j)*denh2o*dz(c,j)) then + h2osoi_liq(c,j) = watsat(c,j)*denh2o*dz(c,j) + end if + + end do + end do +!!!!!!!!!! + +! if (.not. is_perpetual()) then + if (1==1) then + + ! Natural compaction and metamorphosis. + + call SnowCompaction(lbc, ubc, num_shlakesnowc, filter_shlakesnowc, &!i + snl,imelt,frac_iceold,t_soisno, &!i + h2osoi_ice,h2osoi_liq, &!i + dz) !&o + + ! Combine thin snow elements + + call CombineSnowLayers(lbc, ubc, & !i + num_shlakesnowc, filter_shlakesnowc, & !i&o + snl,h2osno,snowdp,dz,zi, & !i&o + t_soisno,h2osoi_ice,h2osoi_liq, & !i&o + z) !o + + + ! Divide thick snow elements + + call DivideSnowLayers(lbc, ubc, & !i + num_shlakesnowc, filter_shlakesnowc, & !i&o + snl,dz,zi,t_soisno, & !i&o + h2osoi_ice,h2osoi_liq, & !i&o + z) !o + + + else + + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + h2osno(c) = 0._r8 + end do + do j = -nlevsnow+1,0 + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end if + end do + end do + + end if + + ! Check for snow layers above lake with unfrozen top layer. Mechanically, + ! the snow will fall into the lake and melt or turn to ice. If the top layer has + ! sufficient heat to melt the snow without freezing, then that will be done. + ! Otherwise, the top layer will undergo freezing, but only if the top layer will + ! not freeze completely. Otherwise, let the snow layers persist and melt by diffusion. +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (t_lake(c,1) > tfrz .and. lake_icefrac(c,1) == 0._r8 .and. snl(c) < 0) then + unfrozen(c) = .true. + else + unfrozen(c) = .false. + end if + end do + + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (unfrozen(c)) then + if (j == -nlevsnow+1) then + sumsnowice(c) = 0._r8 + heatsum(c) = 0._r8 + end if + if (j >= snl(c)+1) then + sumsnowice(c) = sumsnowice(c) + h2osoi_ice(c,j) + heatsum(c) = heatsum(c) + h2osoi_ice(c,j)*cpice*(tfrz - t_soisno(c,j)) & + + h2osoi_liq(c,j)*cpliq*(tfrz - t_soisno(c,j)) + end if + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (unfrozen(c)) then + heatsum(c) = heatsum(c) + sumsnowice(c)*hfus + heatrem = (t_lake(c,1) - tfrz)*cpliq*denh2o*dz_lake(c,1) - heatsum(c) + + if (heatrem + denh2o*dz_lake(c,1)*hfus > 0._r8) then + ! Remove snow and subtract the latent heat from the top layer. + h2osno(c) = 0._r8 + snl(c) = 0 + ! The rest of the bookkeeping for the removed snow will be done below. +#if (defined LAKEDEBUG) + write(message,*)'Snow layers removed above unfrozen lake for column, snowice:', & + c, sumsnowice(c) + ! CALL wrf_message(message) +#endif + if (heatrem > 0._r8) then ! simply subtract the heat from the layer + t_lake(c,1) = t_lake(c,1) - heatrem/(cpliq*denh2o*dz_lake(c,1)) + else !freeze part of the layer + t_lake(c,1) = tfrz + lake_icefrac(c,1) = -heatrem/(denh2o*dz_lake(c,1)*hfus) + end if + end if + end if + end do +!!!!!!!!!!!! + + ! Set snow age to zero if no snow + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (snl(c) == 0) then + snowage(c) = 0._r8 + end if + end do + + ! Set empty snow layers to zero + + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j <= snl(c) .and. snl(c) > -nlevsnow) then + h2osoi_ice(c,j) = 0._r8 + h2osoi_liq(c,j) = 0._r8 + t_soisno(c,j) = 0._r8 + dz(c,j) = 0._r8 + z(c,j) = 0._r8 + zi(c,j-1) = 0._r8 + end if + end do + end do + + ! Build new snow filter + + call BuildSnowFilter(lbc, ubc, num_shlakec, filter_shlakec, snl,& !i + num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) !o + + ! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice + ! over all snow layers for history output + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + t_snow(c) = 0._r8 + snowice(c) = 0._r8 + snowliq(c) = 0._r8 + end do +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakenosnowc + c = filter_shlakenosnowc(fc) + t_snow(c) = spval + snowice(c) = spval + snowliq(c) = spval + end do + + do j = -nlevsnow+1, 0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j >= snl(c)+1) then + t_snow(c) = t_snow(c) + t_soisno(c,j) + snowice(c) = snowice(c) + h2osoi_ice(c,j) + snowliq(c) = snowliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Determine ending water balance and volumetric soil water + +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + + c = filter_shlakec(fc) + if (snl(c) < 0) t_snow(c) = t_snow(c)/abs(snl(c)) + endwb(c) = h2osno(c) + end do + + do j = 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + endwb(c) = endwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + end do + end do + +#if (defined LAKEDEBUG) + ! Check to make sure snow water adds up correctly. + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + jtop = snl(c)+1 + if(j == jtop) snow_water(c) = 0._r8 + if(j >= jtop) then + snow_water(c) = snow_water(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + if(j == 0 .and. abs(snow_water(c)-h2osno(c))>1.e-7_r8) then + write(message,*)'h2osno does not equal sum of snow layers in ShalLakeHydrology:', & + 'column, h2osno, sum of snow layers =', c, h2osno(c), snow_water(c) + ! CALL wrf_error_fatal ( message ) + end if + end if + end do + end do +#endif + +!!!!!!!!!!!!! + ! Do history variables and set special landunit runoff (adapted from end of HydrologyLake) +!dir$ concurrent +!cdir nodep + do fp = 1,num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) + + qflx_infl(c) = 0._r8 + qflx_surf(c) = 0._r8 + qflx_drain(c) = 0._r8 + rootr_column(c,:) = spval + soilalpha(c) = spval + zwt(c) = spval + fcov(c) = spval + qcharge(c) = spval +! h2osoi_vol(c,:) = spval + + ! Insure water balance using qflx_qrgwl + qflx_qrgwl(c) = forc_rain(g) + forc_snow(g) - qflx_evap_tot(p) - (endwb(c)-begwb(c))/dtime +#if (defined LAKEDEBUG) + write(message,*)'c, rain, snow, evap, endwb, begwb, qflx_qrgwl:', & + c, forc_rain(g), forc_snow(g), qflx_evap_tot(p), endwb(c), begwb(c), qflx_qrgwl(c) + ! CALL wrf_message(message) +#endif + + ! The pft average must be done here for output to history tape + qflx_evap_tot_col(c) = qflx_evap_tot(p) + end do + +!!!!!!!!!!!!! +!For now, bracket off the remaining biogeochem code. May need to bring it back +!to do soil carbon and methane beneath lakes. +#if (defined CN) +#ifndef SHLAKE + do j = 1, nlevsoil +!dir$ concurrent +!cdir nodep + do fc = 1, num_soilc + c = filter_soilc(fc) + + if (h2osoi_liq(c,j) > 0._r8) then + vwc = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + + ! the following limit set to catch very small values of + ! fractional saturation that can crash the calculation of psi + + fsat = max(vwc/vwcsat(c,j), 0.001_r8) + psi = psisat(c,j) * (fsat)**bsw2(c,j) + soilpsi(c,j) = min(max(psi,-15.0_r8),0._r8) + else + soilpsi(c,j) = -15.0_r8 + end if + end do + end do +#endif +#endif + +#if (defined DGVM) || (defined CN) +#ifndef SHLAKE + ! Available soil water up to a depth of 0.5 m. + ! Potentially available soil water (=whc) up to a depth of 0.5 m. + ! Water content as fraction of whc up to a depth of 0.5 m. + +!dir$ concurrent +!cdir nodep + do c = lbc,ubc + l = clandunit(c) + if (ityplun(l) == istsoil) then + rwat(c) = 0._r8 + swat(c) = 0._r8 + rz(c) = 0._r8 + end if + end do + + do j = 1, nlevsoil +!dir$ concurrent +!cdir nodep + do c = lbc,ubc + l = clandunit(c) + if (ityplun(l) == istsoil) then + if (z(c,j)+0.5_r8*dz(c,j) <= 0.5_r8) then + watdry = watsat(c,j) * (316230._r8/sucsat(c,j)) ** (-1._r8/bsw(c,j)) + rwat(c) = rwat(c) + (h2osoi_vol(c,j)-watdry) * dz(c,j) + swat(c) = swat(c) + (watsat(c,j) -watdry) * dz(c,j) + rz(c) = rz(c) + dz(c,j) + end if + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do c = lbc,ubc + l = clandunit(c) + if (ityplun(l) == istsoil) then + if (rz(c) /= 0._r8) then + tsw = rwat(c)/rz(c) + stsw = swat(c)/rz(c) + else + watdry = watsat(c,1) * (316230._r8/sucsat(c,1)) ** (-1._r8/bsw(c,1)) + tsw = h2osoi_vol(c,1) - watdry + stsw = watsat(c,1) - watdry + end if + wf(c) = tsw/stsw + else + wf(c) = 1.0_r8 + end if + end do + +#endif +#endif + + end subroutine ShalLakeHydrology + + subroutine QSat (T, p, es, esdT, qs, qsdT) +! +! !DESCRIPTION: +! Computes saturation mixing ratio and the change in saturation +! mixing ratio with respect to temperature. +! Reference: Polynomial approximations from: +! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation +! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513. +! +! !USES: +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: T ! temperature (K) + real(r8), intent(in) :: p ! surface atmospheric pressure (pa) + real(r8), intent(out) :: es ! vapor pressure (pa) + real(r8), intent(out) :: esdT ! d(es)/d(T) + real(r8), intent(out) :: qs ! humidity (kg/kg) + real(r8), intent(out) :: qsdT ! d(qs)/d(T) +! +! !CALLED FROM: +! subroutine Biogeophysics1 in module Biogeophysics1Mod +! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod +! subroutine CanopyFluxesMod CanopyFluxesMod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +!EOP +! +! !LOCAL VARIABLES: +! + real(r8) :: T_limit + real(r8) :: td,vp,vp1,vp2 +! +! For water vapor (temperature range 0C-100C) +! + real(r8), parameter :: a0 = 6.11213476 + real(r8), parameter :: a1 = 0.444007856 + real(r8), parameter :: a2 = 0.143064234e-01 + real(r8), parameter :: a3 = 0.264461437e-03 + real(r8), parameter :: a4 = 0.305903558e-05 + real(r8), parameter :: a5 = 0.196237241e-07 + real(r8), parameter :: a6 = 0.892344772e-10 + real(r8), parameter :: a7 = -0.373208410e-12 + real(r8), parameter :: a8 = 0.209339997e-15 +! +! For derivative:water vapor +! + real(r8), parameter :: b0 = 0.444017302 + real(r8), parameter :: b1 = 0.286064092e-01 + real(r8), parameter :: b2 = 0.794683137e-03 + real(r8), parameter :: b3 = 0.121211669e-04 + real(r8), parameter :: b4 = 0.103354611e-06 + real(r8), parameter :: b5 = 0.404125005e-09 + real(r8), parameter :: b6 = -0.788037859e-12 + real(r8), parameter :: b7 = -0.114596802e-13 + real(r8), parameter :: b8 = 0.381294516e-16 +! +! For ice (temperature range -75C-0C) +! + real(r8), parameter :: c0 = 6.11123516 + real(r8), parameter :: c1 = 0.503109514 + real(r8), parameter :: c2 = 0.188369801e-01 + real(r8), parameter :: c3 = 0.420547422e-03 + real(r8), parameter :: c4 = 0.614396778e-05 + real(r8), parameter :: c5 = 0.602780717e-07 + real(r8), parameter :: c6 = 0.387940929e-09 + real(r8), parameter :: c7 = 0.149436277e-11 + real(r8), parameter :: c8 = 0.262655803e-14 +! +! For derivative:ice +! + real(r8), parameter :: d0 = 0.503277922 + real(r8), parameter :: d1 = 0.377289173e-01 + real(r8), parameter :: d2 = 0.126801703e-02 + real(r8), parameter :: d3 = 0.249468427e-04 + real(r8), parameter :: d4 = 0.313703411e-06 + real(r8), parameter :: d5 = 0.257180651e-08 + real(r8), parameter :: d6 = 0.133268878e-10 + real(r8), parameter :: d7 = 0.394116744e-13 + real(r8), parameter :: d8 = 0.498070196e-16 +!----------------------------------------------------------------------- + + T_limit = T - tfrz + if (T_limit > 100.0) T_limit=100.0 + if (T_limit < -75.0) T_limit=-75.0 + + td = T_limit + if (td >= 0.0) then + es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & + + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & + + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) + else + es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & + + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & + + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + endif + + es = es * 100. ! pa + esdT = esdT * 100. ! pa/K + + vp = 1.0 / (p - 0.378*es) + vp1 = 0.622 * vp + vp2 = vp1 * vp + + qs = es * vp1 ! kg/kg + qsdT = esdT * vp2 * p ! 1 / K + + end subroutine QSat + + + subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & + a, b, c, r, u) +! +! !DESCRIPTION: +! Tridiagonal matrix solution +! +! !USES: + ! use shr_kind_mod, only: r8 => shr_kind_r8 +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: lbc, ubc ! lbinning and ubing column indices + integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices + integer , intent(in) :: jtop(lbc:ubc) ! top level for each column + integer , intent(in) :: numf ! filter dimension + integer , intent(in) :: filter(1:numf) ! filter + real(r8), intent(in) :: a(lbc:ubc, lbj:ubj) ! "a" left off diagonal of tridiagonal matrix + real(r8), intent(in) :: b(lbc:ubc, lbj:ubj) ! "b" diagonal column for tridiagonal matrix + real(r8), intent(in) :: c(lbc:ubc, lbj:ubj) ! "c" right off diagonal tridiagonal matrix + real(r8), intent(in) :: r(lbc:ubc, lbj:ubj) ! "r" forcing term of tridiagonal matrix + real(r8), intent(inout) :: u(lbc:ubc, lbj:ubj) ! solution +! +! !CALLED FROM: +! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod +! subroutine SoilTemperature in module SoilTemperatureMod +! subroutine SoilWater in module HydrologyMod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 1 July 2003: Mariana Vertenstein; modified for vectorization +! +!EOP +! +! !OTHER LOCAL VARIABLES: +! + integer :: j,ci,fc !indices + real(r8) :: gam(lbc:ubc,lbj:ubj) !temporary + real(r8) :: bet(lbc:ubc) !temporary +!----------------------------------------------------------------------- + + ! Solve the matrix + +!dir$ concurrent +!cdir nodep + do fc = 1,numf + ci = filter(fc) + bet(ci) = b(ci,jtop(ci)) + end do + + do j = lbj, ubj +!dir$ prefervector +!dir$ concurrent +!cdir nodep + do fc = 1,numf + ci = filter(fc) + if (j >= jtop(ci)) then + if (j == jtop(ci)) then + u(ci,j) = r(ci,j) / bet(ci) + else + gam(ci,j) = c(ci,j-1) / bet(ci) + bet(ci) = b(ci,j) - a(ci,j) * gam(ci,j) + u(ci,j) = (r(ci,j) - a(ci,j)*u(ci,j-1)) / bet(ci) + end if + end if + end do + end do + +!Cray X1 unroll directive used here as work-around for compiler issue 2003/10/20 +!dir$ unroll 0 + do j = ubj-1,lbj,-1 +!dir$ prefervector +!dir$ concurrent +!cdir nodep + do fc = 1,numf + ci = filter(fc) + if (j >= jtop(ci)) then + u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1) + end if + end do + end do + + end subroutine Tridiagonal + + + subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i + num_nosnowc, filter_nosnowc, & !i + snl,do_capsnow,qflx_snomelt,qflx_rain_grnd, & !i + qflx_sub_snow,qflx_evap_grnd, & !i + qflx_dew_snow,qflx_dew_grnd,dz, & !i + h2osoi_ice,h2osoi_liq, & !i&o + qflx_top_soil) !o +!=============================================================================== +! !DESCRIPTION: +! Evaluate the change of snow mass and the snow water onto soil. +! Water flow within snow is computed by an explicit and non-physical +! based scheme, which permits a part of liquid water over the holding +! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to +! percolate into the underlying layer. Except for cases where the +! porosity of one of the two neighboring layers is less than 0.05, zero +! flow is assumed. The water flow out of the bottom of the snow pack will +! participate as the input of the soil water and runoff. This subroutine +! uses a filter for columns containing snow which must be constructed prior +! to being called. +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 15 November 2000: Mariana Vertenstein +! 2/26/02, Peter Thornton: Migrated to new data structures. +!============================================================================= +! !USES: + ! use clmtype + + implicit none + +!in: + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(in) :: num_nosnowc ! number of non-snow points in column filter + integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points + + integer , intent(in) :: snl(1) !number of snow layers + logical , intent(in) :: do_capsnow(1) !true => do snow capping + real(r8), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) + real(r8), intent(in) :: qflx_rain_grnd(1) !rain on ground after interception (mm H2O/s) [+] + real(r8), intent(in) :: qflx_sub_snow(1) !sublimation rate from snow pack (mm H2O /s) [+] + real(r8), intent(in) :: qflx_evap_grnd(1) !ground surface evaporation rate (mm H2O/s) [+] + real(r8), intent(in) :: qflx_dew_snow(1) !surface dew added to snow pack (mm H2O /s) [+] + real(r8), intent(in) :: qflx_dew_grnd(1) !ground surface dew formation (mm H2O /s) [+] + real(r8), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + + +!inout: + + real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + +!out: + + real(r8), intent(out) :: qflx_top_soil(1) !net water input into soil from top (mm/s) + + +! OTHER LOCAL VARIABLES: + + integer :: c, j, fc !do loop/array indices + real(r8) :: qin(lbc:ubc) !water flow into the elmement (mm/s) + real(r8) :: qout(lbc:ubc) !water flow out of the elmement (mm/s) + real(r8) :: wgdif !ice mass after minus sublimation + real(r8) :: vol_liq(lbc:ubc,-nlevsnow+1:0) !partial volume of liquid water in layer + real(r8) :: vol_ice(lbc:ubc,-nlevsnow+1:0) !partial volume of ice lens in layer + real(r8) :: eff_porosity(lbc:ubc,-nlevsnow+1:0) !effective porosity = porosity - vol_ice +!----------------------------------------------------------------------- + ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the + ! surface snow layer resulting from sublimation (frost) / evaporation (condense) + +!dir$ concurrent +!cdir nodep + do fc = 1,num_snowc + c = filter_snowc(fc) + if (do_capsnow(c)) then + wgdif = h2osoi_ice(c,snl(c)+1) - qflx_sub_snow(c)*dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0.) then + h2osoi_ice(c,snl(c)+1) = 0. + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) - qflx_evap_grnd(c) * dtime + else + wgdif = h2osoi_ice(c,snl(c)+1) + (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0.) then + h2osoi_ice(c,snl(c)+1) = 0. + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + & + (qflx_rain_grnd(c) + qflx_dew_grnd(c) - qflx_evap_grnd(c)) * dtime + end if + h2osoi_liq(c,snl(c)+1) = max(0._r8, h2osoi_liq(c,snl(c)+1)) + end do + + ! Porosity and partial volume + + do j = -nlevsnow+1, 0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + vol_ice(c,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*denice)) + eff_porosity(c,j) = 1. - vol_ice(c,j) + vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*denh2o)) + end if + end do + end do + + ! Capillary forces within snow are usually two or more orders of magnitude + ! less than those of gravity. Only gravity terms are considered. + ! the genernal expression for water flow is "K * ss**3", however, + ! no effective parameterization for "K". Thus, a very simple consideration + ! (not physically based) is introduced: + ! when the liquid water of layer exceeds the layer's holding + ! capacity, the excess meltwater adds to the underlying neighbor layer. + + qin(:) = 0._r8 + + do j = -nlevsnow+1, 0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c) + if (j <= -1) then + ! No runoff over snow surface, just ponding on surface + if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then + qout(c) = 0._r8 + else + qout(c) = max(0._r8,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j)) + qout(c) = min(qout(c),(1.-vol_ice(c,j+1)-vol_liq(c,j+1))*dz(c,j+1)) + end if + else + qout(c) = max(0._r8,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j)) + end if + qout(c) = qout(c)*1000. + h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c) + qin(c) = qout(c) + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + ! Qout from snow bottom + qflx_top_soil(c) = qout(c) / dtime + end do + +!dir$ concurrent +!cdir nodep + do fc = 1, num_nosnowc + c = filter_nosnowc(fc) + qflx_top_soil(c) = qflx_rain_grnd(c) + qflx_snomelt(c) + end do + + end subroutine SnowWater + + subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i + snl,imelt,frac_iceold,t_soisno, &!i + h2osoi_ice,h2osoi_liq, &!i + dz) !i&o + + +!================================================================================ +! !DESCRIPTION: +! Determine the change in snow layer thickness due to compaction and +! settling. +! Three metamorphisms of changing snow characteristics are implemented, +! i.e., destructive, overburden, and melt. The treatments of the former +! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution +! due to melt metamorphism is simply taken as a ratio of snow ice +! fraction after the melting versus before the melting. +! +! CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures +!============================================================================== +! USES: + ! use clmtype +! +! !ARGUMENTS: + implicit none + +!in: + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of column snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(in) :: snl(1) !number of snow layers + integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 + real(r8), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !fraction of ice relative to the tot water + real(r8), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(r8), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(r8), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + +!inout: + + real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + +! OTHER LOCAL VARIABLES: + + integer :: j, c, fc ! indices + real(r8), parameter :: c2 = 23.e-3 ! [m3/kg] + real(r8), parameter :: c3 = 2.777e-6 ! [1/s] + real(r8), parameter :: c4 = 0.04 ! [1/K] + real(r8), parameter :: c5 = 2.0 ! + real(r8), parameter :: dm = 100.0 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(r8), parameter :: eta0 = 9.e+5 ! The Viscosity Coefficient Eta0 [kg-s/m2] + real(r8) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2] + real(r8) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. + real(r8) :: ddz2 ! Rate of compaction of snowpack due to overburden. + real(r8) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s] + real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(r8) :: fi ! Fraction of ice relative to the total water content at current time step + real(r8) :: td ! t_soisno - tfrz [K] + real(r8) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(r8) :: void ! void (1 - vol_ice - vol_liq) + real(r8) :: wx ! water mass (ice+liquid) [kg/m2] + real(r8) :: bi ! partial density of ice [kg/m3] + +!----------------------------------------------------------------------- + + + ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0 + + burden(:) = 0._r8 + + do j = -nlevsnow+1, 0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + + wx = h2osoi_ice(c,j) + h2osoi_liq(c,j) + void = 1. - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o) / dz(c,j) + + ! Allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. h2osoi_ice(c,j) > .1) then + bi = h2osoi_ice(c,j) / dz(c,j) + fi = h2osoi_ice(c,j) / wx + td = tfrz-t_soisno(c,j) + dexpf = exp(-c4*td) + + ! Settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! Liquid water term + + if (h2osoi_liq(c,j) > 0.01*dz(c,j)) ddz1=ddz1*c5 + + ! Compaction due to overburden + + ddz2 = -burden(c)*exp(-0.08*td - c2*bi)/eta0 + + ! Compaction occurring during melt + + if (imelt(c,j) == 1) then + ddz3 = - 1./dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + else + ddz3 = 0._r8 + end if + + ! Time rate of fractional change in dz (units of s-1) + + pdzdtc = ddz1 + ddz2 + ddz3 + + ! The change in dz due to compaction + + dz(c,j) = dz(c,j) * (1.+pdzdtc*dtime) + end if + + ! Pressure of overlying snow + + burden(c) = burden(c) + wx + + end if + end do + end do + + end subroutine SnowCompaction + + subroutine CombineSnowLayers(lbc, ubc, & !i + num_snowc, filter_snowc, & !i&o + snl,h2osno,snowdp,dz,zi, & !i&o + t_soisno,h2osoi_ice,h2osoi_liq, & !i&o + z) !o +!========================================================================== +! !DESCRIPTION: +! Combine snow layers that are less than a minimum thickness or mass +! If the snow element thickness or mass is less than a prescribed minimum, +! then it is combined with a neighboring element. The subroutine +! clm\_combo.f90 then executes the combination of mass and energy. +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +!========================================================================= +! !USES: + ! use clmtype +! +! !ARGUMENTS: + implicit none +!in: + integer, intent(in) :: lbc, ubc ! column bounds + ! integer, intent(in) :: clandunit(1) !landunit index for each column + ! integer, intent(in) :: ityplun(1) !landunit type + +!inout: + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer , intent(inout) :: snl(1) !number of snow layers + real(r8), intent(inout) :: h2osno(1) !snow water (mm H2O) + real(r8), intent(inout) :: snowdp(1) !snow height (m) + real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(r8), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) + real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + +!out: + + real(r8), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) +! +!EOP +! +! !OTHER LOCAL VARIABLES: +! + integer :: c, fc ! column indices + integer :: i,k ! loop indices + integer :: j,l ! node indices + integer :: msn_old(lbc:ubc) ! number of top snow layer + integer :: mssi(lbc:ubc) ! node index + integer :: neibor ! adjacent node selected for combination + real(r8):: zwice(lbc:ubc) ! total ice mass in snow + real(r8):: zwliq (lbc:ubc) ! total liquid water in snow + real(r8):: dzmin(5) ! minimum of top snow layer + + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ +!----------------------------------------------------------------------- + + ! Check the mass of ice lens of snow, when the total is less than a small value, + ! combine it with the underlying neighbor. + +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + msn_old(c) = snl(c) + end do + + ! The following loop is NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + ! l = clandunit(c) + do j = msn_old(c)+1,0 + if (h2osoi_ice(c,j) <= .1) then + ! if (ityplun(l) == istsoil) then + ! h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + ! h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + ! else if (ityplun(l) /= istsoil .and. j /= 0) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + ! end if + + ! shift all elements above this down one. + if (j > snl(c)+1 .and. snl(c) < -1) then + do i = j, snl(c)+2, -1 + t_soisno(c,i) = t_soisno(c,i-1) + h2osoi_liq(c,i) = h2osoi_liq(c,i-1) + h2osoi_ice(c,i) = h2osoi_ice(c,i-1) + dz(c,i) = dz(c,i-1) + end do + end if + snl(c) = snl(c) + 1 + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + h2osno(c) = 0._r8 + snowdp(c) = 0._r8 + zwice(c) = 0._r8 + zwliq(c) = 0._r8 + end do + + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + snowdp(c) = snowdp(c) + dz(c,j) + zwice(c) = zwice(c) + h2osoi_ice(c,j) + zwliq(c) = zwliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Check the snow depth - all snow gone + ! The liquid water assumes ponding on soil surface. + +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + ! l = clandunit(c) + if (snowdp(c) < 0.01 .and. snowdp(c) > 0.) then + snl(c) = 0 + h2osno(c) = zwice(c) + if (h2osno(c) <= 0.) snowdp(c) = 0._r8 + ! if (ityplun(l) == istsoil) h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c) !change by guhp + end if + end do + + ! Check the snow depth - snow layers combined + ! The following loop IS NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + + ! Two or more layers + + if (snl(c) < -1) then + + msn_old(c) = snl(c) + mssi(c) = 1 + + do i = msn_old(c)+1,0 + if (dz(c,i) < dzmin(mssi(c))) then + + if (i == snl(c)+1) then + ! If top node is removed, combine with bottom neighbor. + neibor = i + 1 + else if (i == 0) then + ! If the bottom neighbor is not snow, combine with the top neighbor. + neibor = i - 1 + else + ! If none of the above special cases apply, combine with the thinnest neighbor + neibor = i + 1 + if ((dz(c,i-1)+dz(c,i)) < (dz(c,i+1)+dz(c,i))) neibor = i-1 + end if + + ! Node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call Combo (dz(c,j), h2osoi_liq(c,j), h2osoi_ice(c,j), & + t_soisno(c,j), dz(c,l), h2osoi_liq(c,l), h2osoi_ice(c,l), t_soisno(c,l) ) + + ! Now shift all elements above this down one. + if (j-1 > snl(c)+1) then + do k = j-1, snl(c)+2, -1 + t_soisno(c,k) = t_soisno(c,k-1) + h2osoi_ice(c,k) = h2osoi_ice(c,k-1) + h2osoi_liq(c,k) = h2osoi_liq(c,k-1) + dz(c,k) = dz(c,k-1) + end do + end if + + ! Decrease the number of snow layers + snl(c) = snl(c) + 1 + if (snl(c) >= -1) EXIT + + else + + ! The layer thickness is greater than the prescribed minimum value + mssi(c) = mssi(c) + 1 + + end if + end do + + end if + + end do + + ! Reset the node depth and the depth of layer interface + + do j = 0, -nlevsnow+1, -1 +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c) + 1) then + z(c,j) = zi(c,j) - 0.5*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine CombineSnowLayers + + subroutine DivideSnowLayers(lbc, ubc, & !i + num_snowc, filter_snowc, & !i&o + snl,dz,zi,t_soisno, & !i&o + h2osoi_ice,h2osoi_liq, & !i&o + z) !o + + +!============================================================================ +! !DESCRIPTION: +! Subdivides snow layers if they exceed their prescribed maximum thickness. +! !CALLED FROM: +! subroutine Hydrology2 in module Hydrology2Mod +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 2/28/02, Peter Thornton: Migrated to new data structures. +!============================================================================ +! !USES: + ! use clmtype +! +! !ARGUMENTS: + implicit none + +!in: + integer, intent(in) :: lbc, ubc ! column bounds + +!inout: + + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer , intent(inout) :: snl(1) !number of snow layers + real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(r8), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) + real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + +!out: + + real(r8), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + + + +! OTHER LOCAL VARIABLES: + + integer :: j, c, fc ! indices + real(r8) :: drr ! thickness of the combined [m] + integer :: msno ! number of snow layer 1 (top) to msno (bottom) + real(r8) :: dzsno(lbc:ubc,nlevsnow) ! Snow layer thickness [m] + real(r8) :: swice(lbc:ubc,nlevsnow) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(lbc:ubc,nlevsnow) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(lbc:ubc ,nlevsnow) ! Nodel temperature [K] + real(r8) :: zwice ! temporary + real(r8) :: zwliq ! temporary + real(r8) :: propor ! temporary +!----------------------------------------------------------------------- + + ! Begin calculation - note that the following column loops are only invoked + ! for snow-covered columns + + do j = 1,nlevsnow +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j <= abs(snl(c))) then + dzsno(c,j) = dz(c,j+snl(c)) + swice(c,j) = h2osoi_ice(c,j+snl(c)) + swliq(c,j) = h2osoi_liq(c,j+snl(c)) + tsno(c,j) = t_soisno(c,j+snl(c)) + end if + end do + end do + +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + + msno = abs(snl(c)) + + if (msno == 1) then + ! Specify a new snow layer + if (dzsno(c,1) > 0.03) then + msno = 2 + dzsno(c,1) = dzsno(c,1)/2. + swice(c,1) = swice(c,1)/2. + swliq(c,1) = swliq(c,1)/2. + dzsno(c,2) = dzsno(c,1) + swice(c,2) = swice(c,1) + swliq(c,2) = swliq(c,1) + tsno(c,2) = tsno(c,1) + end if + end if + + if (msno > 1) then + if (dzsno(c,1) > 0.02) then + drr = dzsno(c,1) - 0.02 + propor = drr/dzsno(c,1) + zwice = propor*swice(c,1) + zwliq = propor*swliq(c,1) + propor = 0.02/dzsno(c,1) + swice(c,1) = propor*swice(c,1) + swliq(c,1) = propor*swliq(c,1) + dzsno(c,1) = 0.02 + + call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, & + zwliq, zwice, tsno(c,1)) + + ! Subdivide a new layer + if (msno <= 2 .and. dzsno(c,2) > 0.07) then + msno = 3 + dzsno(c,2) = dzsno(c,2)/2. + swice(c,2) = swice(c,2)/2. + swliq(c,2) = swliq(c,2)/2. + dzsno(c,3) = dzsno(c,2) + swice(c,3) = swice(c,2) + swliq(c,3) = swliq(c,2) + tsno(c,3) = tsno(c,2) + end if + end if + end if + + if (msno > 2) then + if (dzsno(c,2) > 0.05) then + drr = dzsno(c,2) - 0.05 + propor = drr/dzsno(c,2) + zwice = propor*swice(c,2) + zwliq = propor*swliq(c,2) + propor = 0.05/dzsno(c,2) + swice(c,2) = propor*swice(c,2) + swliq(c,2) = propor*swliq(c,2) + dzsno(c,2) = 0.05 + + call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, & + zwliq, zwice, tsno(c,2)) + + ! Subdivided a new layer + if (msno <= 3 .and. dzsno(c,3) > 0.18) then + msno = 4 + dzsno(c,3) = dzsno(c,3)/2. + swice(c,3) = swice(c,3)/2. + swliq(c,3) = swliq(c,3)/2. + dzsno(c,4) = dzsno(c,3) + swice(c,4) = swice(c,3) + swliq(c,4) = swliq(c,3) + tsno(c,4) = tsno(c,3) + end if + end if + end if + + if (msno > 3) then + if (dzsno(c,3) > 0.11) then + drr = dzsno(c,3) - 0.11 + propor = drr/dzsno(c,3) + zwice = propor*swice(c,3) + zwliq = propor*swliq(c,3) + propor = 0.11/dzsno(c,3) + swice(c,3) = propor*swice(c,3) + swliq(c,3) = propor*swliq(c,3) + dzsno(c,3) = 0.11 + + call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, & + zwliq, zwice, tsno(c,3)) + + ! Subdivided a new layer + if (msno <= 4 .and. dzsno(c,4) > 0.41) then + msno = 5 + dzsno(c,4) = dzsno(c,4)/2. + swice(c,4) = swice(c,4)/2. + swliq(c,4) = swliq(c,4)/2. + dzsno(c,5) = dzsno(c,4) + swice(c,5) = swice(c,4) + swliq(c,5) = swliq(c,4) + tsno(c,5) = tsno(c,4) + end if + end if + end if + + if (msno > 4) then + if (dzsno(c,4) > 0.23) then + drr = dzsno(c,4) - 0.23 + propor = drr/dzsno(c,4) + zwice = propor*swice(c,4) + zwliq = propor*swliq(c,4) + propor = 0.23/dzsno(c,4) + swice(c,4) = propor*swice(c,4) + swliq(c,4) = propor*swliq(c,4) + dzsno(c,4) = 0.23 + + call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, & + zwliq, zwice, tsno(c,4)) + end if + end if + + snl(c) = -msno + + end do + + do j = -nlevsnow+1,0 +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = dzsno(c,j-snl(c)) + h2osoi_ice(c,j) = swice(c,j-snl(c)) + h2osoi_liq(c,j) = swliq(c,j-snl(c)) + t_soisno(c,j) = tsno(c,j-snl(c)) + end if + end do + end do + + do j = 0, -nlevsnow+1, -1 +!dir$ concurrent +!cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + z(c,j) = zi(c,j) - 0.5*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine DivideSnowLayers + + subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! +! !DESCRIPTION: +! Combines two elements and returns the following combined +! variables: dz, t, wliq, wice. +! The combined temperature is based on the equation: +! the sum of the enthalpies of the two elements = +! that of the combined element. +! +! !USES: +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K] + real(r8), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] + real(r8), intent(inout) :: wliq ! liquid water of element 1 + real(r8), intent(inout) :: wice ! ice of element 1 [kg/m2] + real(r8), intent(inout) :: t ! nodel temperature of elment 1 [K] +! +! !CALLED FROM: +! subroutine CombineSnowLayers in this module +! subroutine DivideSnowLayers in this module +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +!EOP +! +! !LOCAL VARIABLES: +! + real(r8) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2). + real(r8) :: wliqc ! Combined liquid water [kg/m2] + real(r8) :: wicec ! Combined ice [kg/m2] + real(r8) :: tc ! Combined node temperature [K] + real(r8) :: h ! enthalpy of element 1 [J/m2] + real(r8) :: h2 ! enthalpy of element 2 [J/m2] + real(r8) :: hc ! temporary +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cpice*wice+cpliq*wliq) * (t-tfrz)+hfus*wliq + h2= (cpice*wice2+cpliq*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cpice*wicec + cpliq*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cpice*wicec + cpliq*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine Combo + + subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec,snl, & !i + num_snowc, filter_snowc, & !o + num_nosnowc, filter_nosnowc) !o +! +! !DESCRIPTION: +! Constructs snow filter for use in vectorized loops for snow hydrology. +! +! !USES: +! use clmtype +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(in) :: snl(1) ! number of snow layers + integer, intent(out) :: num_snowc ! number of column snow points in column filter + integer, intent(out) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(out) :: num_nosnowc ! number of column non-snow points in column filter + integer, intent(out) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points +! +! !CALLED FROM: +! subroutine Hydrology2 in Hydrology2Mod +! subroutine CombineSnowLayers in this module +! +! !REVISION HISTORY: +! 2003 July 31: Forrest Hoffman +! +! !LOCAL VARIABLES: +! local pointers to implicit in arguments +! +!EOP +! +! !OTHER LOCAL VARIABLES: + integer :: fc, c +!----------------------------------------------------------------------- + + + ! Build snow/no-snow filters for other subroutines + + num_snowc = 0 + num_nosnowc = 0 + do fc = 1, num_nolakec + c = filter_nolakec(fc) + if (snl(c) < 0) then + num_snowc = num_snowc + 1 + filter_snowc(num_snowc) = c + else + num_nosnowc = num_nosnowc + 1 + filter_nosnowc(num_nosnowc) = c + end if + end do + + end subroutine BuildSnowFilter + + + +subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i + forc_hgt_t,forc_hgt_q, & !i + lbp, ubp, fn, filterp, & !i + displa, z0m, z0h, z0q, & !i + obu, iter, ur, um, & !i + ustar,temp1, temp2, temp12m, temp22m, & !o + u10,fv, & !o + fm) !i&o + +!============================================================================= +! !DESCRIPTION: +! Calculation of the friction velocity, relation for potential +! temperature and humidity profiles of surface boundary layer. +! The scheme is based on the work of Zeng et al. (1998): +! Intercomparison of bulk aerodynamic algorithms for the computation +! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, +! Vol. 11, 2628-2644. +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! 12/19/01, Peter Thornton +! Added arguments to eliminate passing clm derived type into this function. +! Created by Mariana Vertenstein +!============================================================================ +! !USES: + ! use clmtype + !!use clm_atmlnd, only : clm_a2l +! +! !ARGUMENTS: + implicit none + +!in: + + integer , intent(in) :: pgridcell(1) ! pft's gridcell index + real(r8), intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(r8), intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(r8), intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(r8), intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + integer , intent(in) :: lbp, ubp ! pft array bounds + integer , intent(in) :: fn ! number of filtered pft elements + integer , intent(in) :: filterp(fn) ! pft filter + real(r8), intent(in) :: displa(lbp:ubp) ! displacement height (m) + real(r8), intent(in) :: z0m(lbp:ubp) ! roughness length over vegetation, momentum [m] + real(r8), intent(in) :: z0h(lbp:ubp) ! roughness length over vegetation, sensible heat [m] + real(r8), intent(in) :: z0q(lbp:ubp) ! roughness length over vegetation, latent heat [m] + real(r8), intent(in) :: obu(lbp:ubp) ! monin-obukhov length (m) + integer, intent(in) :: iter ! iteration number + real(r8), intent(in) :: ur(lbp:ubp) ! wind speed at reference height [m/s] + real(r8), intent(in) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] + +!out: + + real(r8), intent(out) :: ustar(lbp:ubp) ! friction velocity [m/s] + real(r8), intent(out) :: temp1(lbp:ubp) ! relation for potential temperature profile + real(r8), intent(out) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m + real(r8), intent(out) :: temp2(lbp:ubp) ! relation for specific humidity profile + real(r8), intent(out) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m + real(r8), intent(out) :: u10(1) ! 10-m wind (m/s) (for dust model) + real(r8), intent(out) :: fv(1) ! friction velocity (m/s) (for dust model) + +!inout: + real(r8), intent(inout) :: fm(lbp:ubp) ! needed for DGVM only to diagnose 10m wind + +! OTHER LOCAL VARIABLES: + + real(r8), parameter :: zetam = 1.574_r8 ! transition point of flux-gradient relation (wind profile) + real(r8), parameter :: zetat = 0.465_r8 ! transition point of flux-gradient relation (temp. profile) + integer :: f ! pft-filter index + integer :: p ! pft index + integer :: g ! gridcell index + real(r8):: zldis(lbp:ubp) ! reference height "minus" zero displacement heght [m] + real(r8):: zeta(lbp:ubp) ! dimensionless height used in Monin-Obukhov theory +#if (defined DGVM) || (defined DUST) + real(r8) :: tmp1,tmp2,tmp3,tmp4 ! Used to diagnose the 10 meter wind + real(r8) :: fmnew ! Used to diagnose the 10 meter wind + real(r8) :: fm10 ! Used to diagnose the 10 meter wind + real(r8) :: zeta10 ! Used to diagnose the 10 meter wind +#endif +!------------------------------------------------------------------------------ + + + ! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + +#if (!defined PERGRO) + +!dir$ concurrent +!cdir nodep + do f = 1, fn + p = filterp(f) + g = pgridcell(p) + + ! Wind profile + + zldis(p) = forc_hgt_u(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetam) then + ustar(p) = vkc*um(p)/(log(-zetam*obu(p)/z0m(p))& + - StabilityFunc1(-zetam) & + + StabilityFunc1(z0m(p)/obu(p)) & + + 1.14_r8*((-zeta(p))**0.333_r8-(zetam)**0.333_r8)) + else if (zeta(p) < 0._r8) then + ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p))& + - StabilityFunc1(zeta(p))& + + StabilityFunc1(z0m(p)/obu(p))) + else if (zeta(p) <= 1._r8) then + ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p)) + 5._r8*zeta(p) -5._r8*z0m(p)/obu(p)) + else + ustar(p) = vkc*um(p)/(log(obu(p)/z0m(p))+5._r8-5._r8*z0m(p)/obu(p) & + +(5._r8*log(zeta(p))+zeta(p)-1._r8)) + end if + + ! Temperature profile + + zldis(p) = forc_hgt_t(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp1(p) = vkc/(log(-zetat*obu(p)/z0h(p))& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h(p)/obu(p)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8))) + else if (zeta(p) < 0._r8) then + temp1(p) = vkc/(log(zldis(p)/z0h(p)) & + - StabilityFunc2(zeta(p)) & + + StabilityFunc2(z0h(p)/obu(p))) + else if (zeta(p) <= 1._r8) then + temp1(p) = vkc/(log(zldis(p)/z0h(p)) + 5._r8*zeta(p) - 5._r8*z0h(p)/obu(p)) + else + temp1(p) = vkc/(log(obu(p)/z0h(p)) + 5._r8 - 5._r8*z0h(p)/obu(p) & + + (5._r8*log(zeta(p))+zeta(p)-1._r8)) + end if + + ! Humidity profile + + if (forc_hgt_q(g) == forc_hgt_t(g) .and. z0q(p) == z0h(p)) then + temp2(p) = temp1(p) + else + zldis(p) = forc_hgt_q(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp2(p) = vkc/(log(-zetat*obu(p)/z0q(p)) & + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0q(p)/obu(p)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8))) + else if (zeta(p) < 0._r8) then + temp2(p) = vkc/(log(zldis(p)/z0q(p)) & + - StabilityFunc2(zeta(p)) & + + StabilityFunc2(z0q(p)/obu(p))) + else if (zeta(p) <= 1._r8) then + temp2(p) = vkc/(log(zldis(p)/z0q(p)) + 5._r8*zeta(p)-5._r8*z0q(p)/obu(p)) + else + temp2(p) = vkc/(log(obu(p)/z0q(p)) + 5._r8 - 5._r8*z0q(p)/obu(p) & + + (5._r8*log(zeta(p))+zeta(p)-1._r8)) + end if + endif + + ! Temperature profile applied at 2-m + + zldis(p) = 2.0_r8 + z0h(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp12m(p) = vkc/(log(-zetat*obu(p)/z0h(p))& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h(p)/obu(p)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8))) + else if (zeta(p) < 0._r8) then + temp12m(p) = vkc/(log(zldis(p)/z0h(p)) & + - StabilityFunc2(zeta(p)) & + + StabilityFunc2(z0h(p)/obu(p))) + else if (zeta(p) <= 1._r8) then + temp12m(p) = vkc/(log(zldis(p)/z0h(p)) + 5._r8*zeta(p) - 5._r8*z0h(p)/obu(p)) + else + temp12m(p) = vkc/(log(obu(p)/z0h(p)) + 5._r8 - 5._r8*z0h(p)/obu(p) & + + (5._r8*log(zeta(p))+zeta(p)-1._r8)) + end if + + ! Humidity profile applied at 2-m + + if (z0q(p) == z0h(p)) then + temp22m(p) = temp12m(p) + else + zldis(p) = 2.0_r8 + z0q(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp22m(p) = vkc/(log(-zetat*obu(p)/z0q(p)) - & + StabilityFunc2(-zetat) + StabilityFunc2(z0q(p)/obu(p)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8))) + else if (zeta(p) < 0._r8) then + temp22m(p) = vkc/(log(zldis(p)/z0q(p)) - & + StabilityFunc2(zeta(p))+StabilityFunc2(z0q(p)/obu(p))) + else if (zeta(p) <= 1._r8) then + temp22m(p) = vkc/(log(zldis(p)/z0q(p)) + 5._r8*zeta(p)-5._r8*z0q(p)/obu(p)) + else + temp22m(p) = vkc/(log(obu(p)/z0q(p)) + 5._r8 - 5._r8*z0q(p)/obu(p) & + + (5._r8*log(zeta(p))+zeta(p)-1._r8)) + end if + end if + +#if (defined DGVM) || (defined DUST) + ! diagnose 10-m wind for dust model (dstmbl.F) + ! Notes from C. Zender's dst.F: + ! According to Bon96 p. 62, the displacement height d (here displa) is + ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees). + ! Therefore d <= 0.034*z1 and may safely be neglected. + ! Code from LSM routine SurfaceTemperature was used to obtain u10 + + zldis(p) = forc_hgt_u(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (min(zeta(p), 1._r8) < 0._r8) then + tmp1 = (1._r8 - 16._r8*min(zeta(p),1._r8))**0.25_r8 + tmp2 = log((1._r8+tmp1*tmp1)/2._r8) + tmp3 = log((1._r8+tmp1)/2._r8) + fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8 + else + fmnew = -5._r8*min(zeta(p),1._r8) + endif + if (iter == 1) then + fm(p) = fmnew + else + fm(p) = 0.5_r8 * (fm(p)+fmnew) + end if + zeta10 = min(10._r8/obu(p), 1._r8) + if (zeta(p) == 0._r8) zeta10 = 0._r8 + if (zeta10 < 0._r8) then + tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8 + tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8) + tmp3 = log((1.0_r8 + tmp1)/2.0_r8) + fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8 + else ! not stable + fm10 = -5.0_r8 * zeta10 + end if + tmp4 = log(forc_hgt(g) / 10._r8) + u10(p) = ur(p) - ustar(p)/vkc * (tmp4 - fm(p) + fm10) + fv(p) = ustar(p) +#endif + + end do +#endif + + +#if (defined PERGRO) + + !=============================================================================== + ! The following only applies when PERGRO is defined + !=============================================================================== + +!dir$ concurrent +!cdir nodep + do f = 1, fn + p = filterp(f) + g = pgridcell(p) + + zldis(p) = forc_hgt_u(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetam) then ! zeta < -1 + ustar(p) = vkc * um(p) / log(-zetam*obu(p)/z0m(p)) + else if (zeta(p) < 0._r8) then ! -1 <= zeta < 0 + ustar(p) = vkc * um(p) / log(zldis(p)/z0m(p)) + else if (zeta(p) <= 1._r8) then ! 0 <= ztea <= 1 + ustar(p)=vkc * um(p)/log(zldis(p)/z0m(p)) + else ! 1 < zeta, phi=5+zeta + ustar(p)=vkc * um(p)/log(obu(p)/z0m(p)) + endif + + zldis(p) = forc_hgt_t(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp1(p)=vkc/log(-zetat*obu(p)/z0h(p)) + else if (zeta(p) < 0._r8) then + temp1(p)=vkc/log(zldis(p)/z0h(p)) + else if (zeta(p) <= 1._r8) then + temp1(p)=vkc/log(zldis(p)/z0h(p)) + else + temp1(p)=vkc/log(obu(p)/z0h(p)) + end if + + zldis(p) = forc_hgt_q(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp2(p)=vkc/log(-zetat*obu(p)/z0q(p)) + else if (zeta(p) < 0._r8) then + temp2(p)=vkc/log(zldis(p)/z0q(p)) + else if (zeta(p) <= 1._r8) then + temp2(p)=vkc/log(zldis(p)/z0q(p)) + else + temp2(p)=vkc/log(obu(p)/z0q(p)) + end if + + zldis(p) = 2.0_r8 + z0h(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp12m(p)=vkc/log(-zetat*obu(p)/z0h(p)) + else if (zeta(p) < 0._r8) then + temp12m(p)=vkc/log(zldis(p)/z0h(p)) + else if (zeta(p) <= 1._r8) then + temp12m(p)=vkc/log(zldis(p)/z0h(p)) + else + temp12m(p)=vkc/log(obu(p)/z0h(p)) + end if + + zldis(p) = 2.0_r8 + z0q(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp22m(p)=vkc/log(-zetat*obu(p)/z0q(p)) + else if (zeta(p) < 0._r8) then + temp22m(p)=vkc/log(zldis(p)/z0q(p)) + else if (zeta(p) <= 1._r8) then + temp22m(p)=vkc/log(zldis(p)/z0q(p)) + else + temp22m(p)=vkc/log(obu(p)/z0q(p)) + end if +#if (defined DGVM) || (defined DUST) + ! diagnose 10-m wind for dust model (dstmbl.F) + ! Notes from C. Zender's dst.F: + ! According to Bon96 p. 62, the displacement height d (here displa) is + ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees). + ! Therefore d <= 0.034*z1 and may safely be neglected. + ! Code from LSM routine SurfaceTemperature was used to obtain u10 + + zldis(p) = forc_hgt_u(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (min(zeta(p), 1._r8) < 0._r8) then + tmp1 = (1._r8 - 16._r8*min(zeta(p),1._r8))**0.25_r8 + tmp2 = log((1._r8+tmp1*tmp1)/2._r8) + tmp3 = log((1._r8+tmp1)/2._r8) + fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8 + else + fmnew = -5._r8*min(zeta(p),1._r8) + endif + if (iter == 1) then + fm(p) = fmnew + else + fm(p) = 0.5_r8 * (fm(p)+fmnew) + end if + zeta10 = min(10._r8/obu(p), 1._r8) + if (zeta(p) == 0._r8) zeta10 = 0._r8 + if (zeta10 < 0._r8) then + tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8 + tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8) + tmp3 = log((1.0_r8 + tmp1)/2.0_r8) + fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8 + else ! not stable + fm10 = -5.0_r8 * zeta10 + end if + tmp4 = log(forc_hgt(g) / 10._r8) + u10(p) = ur(p) - ustar(p)/vkc * (tmp4 - fm(p) + fm10) + fv(p) = ustar(p) +#endif + end do + +#endif + + end subroutine FrictionVelocity + +! !IROUTINE: StabilityFunc +! +! !INTERFACE: + real(r8) function StabilityFunc1(zeta) +! +! !DESCRIPTION: +! Stability function for rib < 0. +! +! !USES: +! use shr_const_mod, only: SHR_CONST_PI +!Zack Subin, 7/8/08 +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory +! +! !CALLED FROM: +! subroutine FrictionVelocity in this module +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +!EOP +! +! !LOCAL VARIABLES: + real(r8) :: chik, chik2 +!------------------------------------------------------------------------------ + + chik2 = sqrt(1._r8-16._r8*zeta) + chik = sqrt(chik2) + StabilityFunc1 = 2._r8*log((1._r8+chik)*0.5_r8) & +!Changed to pie, Zack Subin, 7/9/08 + + log((1._r8+chik2)*0.5_r8)-2._r8*atan(chik)+pie*0.5_r8 + + end function StabilityFunc1 + +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: StabilityFunc2 +! +! !INTERFACE: + real(r8) function StabilityFunc2(zeta) +! +! !DESCRIPTION: +! Stability function for rib < 0. +! +! !USES: +!Removed by Zack Subin, 7/9/08 +! use shr_const_mod, only: SHR_CONST_PI +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory +! +! !CALLED FROM: +! subroutine FrictionVelocity in this module +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +!EOP +! +! !LOCAL VARIABLES: + real(r8) :: chik2 +!------------------------------------------------------------------------------ + + chik2 = sqrt(1._r8-16._r8*zeta) + StabilityFunc2 = 2._r8*log((1._r8+chik2)*0.5_r8) + + end function StabilityFunc2 + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: MoninObukIni +! +! !INTERFACE: + subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) +! +! !DESCRIPTION: +! Initialization of the Monin-Obukhov length. +! The scheme is based on the work of Zeng et al. (1998): +! Intercomparison of bulk aerodynamic algorithms for the computation +! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, +! Vol. 11, 2628-2644. +! +! !USES: +! +! !ARGUMENTS: + implicit none + real(r8), intent(in) :: ur ! wind speed at reference height [m/s] + real(r8), intent(in) :: thv ! virtual potential temperature (kelvin) + real(r8), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] + real(r8), intent(in) :: z0m ! roughness length, momentum [m] + real(r8), intent(out) :: um ! wind speed including the stability effect [m/s] + real(r8), intent(out) :: obu ! monin-obukhov length (m) +! +! !CALLED FROM: +! subroutine BareGroundFluxes in module BareGroundFluxesMod.F90 +! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod.F90 +! subroutine CanopyFluxes in module CanopyFluxesMod.F90 +! +! !REVISION HISTORY: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! +!EOP +! +! !LOCAL VARIABLES: +! + real(r8) :: wc ! convective velocity [m/s] + real(r8) :: rib ! bulk Richardson number + real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: ustar ! friction velocity [m/s] +!----------------------------------------------------------------------- + + ! Initial values of u* and convective velocity + + ustar=0.06_r8 + wc=0.5_r8 + if (dthv >= 0._r8) then + um=max(ur,0.1_r8) + else + um=sqrt(ur*ur+wc*wc) + endif + + rib=grav*zldis*dthv/(thv*um*um) +#if (defined PERGRO) + rib = 0._r8 +#endif + + if (rib >= 0._r8) then ! neutral or stable + zeta = rib*log(zldis/z0m)/(1._r8-5._r8*min(rib,0.19_r8)) + zeta = min(2._r8,max(zeta,0.01_r8 )) + else ! unstable + zeta=rib*log(zldis/z0m) + zeta = max(-100._r8,min(zeta,-0.01_r8 )) + endif + + obu=zldis/zeta + + end subroutine MoninObukIni + +subroutine LakeDebug( str ) + + IMPLICIT NONE + CHARACTER*(*), str + +! CALL wrf_debug( 0 , TRIM(str) ) + +end subroutine LakeDebug + + SUBROUTINE lakeini(IVGTYP, ISLTYP, HT, SNOW, & !i + lake_min_elev, restart, lakedepth_default, lake_depth, & + lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o + snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & + z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & + h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & + zi3d, watsat3d, csol3d, tkmg3d, & + iswater, xice, xice_threshold, xland, tsk, & + ! lakemask, & ! BK added +! #if (EM_CORE == 1) + lakemask, lakeflag, & +! #endif + lake_depth_flag, use_lakedepth, & + tkdry3d, tksatu3d, lake, its, ite, jts, jte, & + ims,ime, jms,jme) + +!============================================================================== +! This subroutine was first edited by Hongping Gu for coupling +! 07/20/2010 +!============================================================================== + +! USE module_wrf_error + implicit none + + INTEGER , INTENT (IN) :: iswater + REAL, INTENT(IN) :: xice_threshold + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: XICE + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN):: TSK +! REAL, DIMENSION( ims:ime, jms:jme ) ,INTENT(INOUT) :: XLAND + INTEGER, DIMENSION( ims:ime, jms:jme ) ,INTENT(INOUT) :: XLAND + +! #if (EM_CORE == 1) + REAL, DIMENSION( ims:ime , jms:jme ) :: LAKEMASK + INTEGER , INTENT (IN) :: lakeflag +! #endif + INTEGER , INTENT (INOUT) :: lake_depth_flag + INTEGER , INTENT (IN) :: use_lakedepth + + LOGICAL , INTENT(IN) :: restart + INTEGER, INTENT(IN ) :: ims,ime, jms,jme + INTEGER, INTENT(IN ) :: its,ite, jts,jte + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: IVGTYP, & + ISLTYP + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: HT + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SNOW + real, intent(in) :: lakedepth_default,lake_min_elev + + real, dimension(ims:ime,jms:jme ),intent(out) :: lakedepth2d, & + savedtke12d + real, dimension(ims:ime,jms:jme ),intent(out) :: snowdp2d, & + h2osno2d, & + snl2d, & + t_grnd2d + + real, dimension( ims:ime,1:nlevlake, jms:jme ),INTENT(out) :: t_lake3d, & + lake_icefrac3d, & + z_lake3d, & + dz_lake3d + real, dimension( ims:ime,-nlevsnow+1:nlevsoil, jms:jme ),INTENT(out) :: t_soisno3d, & + h2osoi_ice3d, & + h2osoi_liq3d, & + h2osoi_vol3d, & + z3d, & + dz3d + real, dimension( ims:ime,1:nlevsoil, jms:jme ),INTENT(out) :: watsat3d, & + csol3d, & + tkmg3d, & + tkdry3d, & + tksatu3d + real, dimension( ims:ime,-nlevsnow+0:nlevsoil, jms:jme ),INTENT(out) :: zi3d + + LOGICAL, DIMENSION( ims:ime, jms:jme ),intent(out) :: lake + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lake_depth + + real, dimension( ims:ime,1:nlevsoil, jms:jme ) :: bsw3d, & + bsw23d, & + psisat3d, & + vwcsat3d, & + watdry3d, & + watopt3d, & + hksat3d, & + sucsat3d, & + clay3d, & + sand3d + integer :: n,i,j,k,ib,lev,bottom ! indices + real(r8),dimension(ims:ime,jms:jme ) :: bd2d ! bulk density of dry soil material [kg/m^3] + real(r8),dimension(ims:ime,jms:jme ) :: tkm2d ! mineral conductivity + real(r8),dimension(ims:ime,jms:jme ) :: xksat2d ! maximum hydraulic conductivity of soil [mm/s] + real(r8),dimension(ims:ime,jms:jme ) :: depthratio2d ! ratio of lake depth to standard deep lake depth + real(r8),dimension(ims:ime,jms:jme ) :: clay2d ! temporary + real(r8),dimension(ims:ime,jms:jme ) :: sand2d ! temporary + + real(r8) :: scalez = 0.025_r8 ! Soil layer thickness discretization (m) + logical,parameter :: arbinit = .true. + real,parameter :: defval = -999.0 + integer :: isl + integer :: numb_lak ! for debug + character*256 :: message + + IF ( RESTART ) RETURN + + DO j = jts,jte + DO i = its,ite + snowdp2d(i,j) = snow(i,j)*0.005 ! SNOW in kg/m^2 and snowdp in m + h2osno2d(i,j) = snow(i,j) ! mm + ENDDO + ENDDO + +! initialize all the grid with default value + DO j = jts,jte + DO i = its,ite + + lakedepth2d(i,j) = defval ! lake depth + snl2d(i,j) = defval ! snow level (?) + do k = -nlevsnow+1,nlevsoil + h2osoi_liq3d(i,k,j) = defval ! soil liquid water? + h2osoi_ice3d(i,k,j) = defval ! soil ice? + t_soisno3d(i,k,j) = defval ! soil/snow temperature ? + z3d(i,k,j) = defval ! + dz3d(i,k,j) = defval + enddo + do k = 1,nlevlake + t_lake3d(i,k,j) = defval ! lake temperature? + lake_icefrac3d(i,k,j) = defval ! lake icefraction + z_lake3d(i,k,j) = defval ! depth 3d? + dz_lake3d(i,k,j) = defval ! dz + enddo + + ENDDO + ENDDO + +! judge whether the grid is lake grid + numb_lak = 0 + do i=its,ite + do j=jts,jte +! #if (EM_CORE==1) + IF (lakeflag.eq.0) THEN ! No lake cat in LU data provided : not properly tested for iCAR! + ! write(*,*)" lakeflag=0 ???" + if(ht(i,j)>=lake_min_elev) then + if ( xice(i,j).gt.xice_threshold) then !mchen + ! ivgtyp(i,j) = iswater ! BK dont overwrite this for now, need to properly test the ice scenario + ! xland(i,j) = 2 + lake_icefrac3d(i,1,j) = xice(i,j) + xice(i,j)=0.0 + endif + endif + + if(ivgtyp(i,j)==iswater.and.ht(i,j)>=lake_min_elev) then + lake(i,j) = .true. + lakemask(i,j) = 1 + numb_lak = numb_lak + 1 + else + lake(i,j) = .false. + lakemask(i,j) = 0 + end if + ELSE ! i.e. we have a lakemask from LU lake cat data: + if(lakemask(i,j).eq.1) then + lake(i,j) = .true. + numb_lak = numb_lak + 1 + if ( xice(i,j).gt.xice_threshold) then !mchen + ! ivgtyp(i,j) = iswater ! BK: dont overwrite this, we want to keep the lake category ? + ! xland(i,j) = 2 + lake_icefrac3d(i,1,j) = xice(i,j) + xice(i,j)=0.0 + endif + else + lake(i,j) = .false. + endif + ENDIF ! end if lakeflag=0 +! #else + ! if(ht(i,j)>=lake_min_elev) then + ! if ( xice(i,j).gt.xice_threshold) then !mchen + ! ! ivgtyp(i,j) = iswater ! BK debug, lets not overwrite this? ... + ! ! xland(i,j) = 2 + ! lake_icefrac3d(i,1,j) = xice(i,j) + ! xice(i,j)=0.0 + ! endif + ! endif + ! if((lakemask(i,j).eq.1) .or. (ivgtyp(i,j)==iswater.and.ht(i,j)>=lake_min_elev)) then ! BK modified cause lake cat is not always water cat. + ! ! if(ivgtyp(i,j)==iswater.and.ht(i,j)>=lake_min_elev) then + ! lake(i,j) = .true. + ! numb_lak = numb_lak + 1 + ! ! xland(i,j) = 2 ! BK commented out. If anything this should become kLC_WATER + ! else + ! lake(i,j) = .false. + ! end if + +! #endif + end do + end do + write(message,*) "the total number of lake grid is :", numb_lak + if(this_image()==1) write(*,*) " the total number of lake gridcells (in image 1) is :", numb_lak, "" + ! CALL wrf_message(message) +! CALL LakeDebug(msg) +! initialize lake grid + + DO j = jts,jte + DO i = its,ite + + if ( lake(i,j) ) then + +! t_soisno3d(i,:,j) = tsk(i,j) +! t_lake3d(i,:,j) = tsk(i,j) +! t_grnd2d(i,j) = tsk(i,j) + + z3d(i,:,j) = 0.0 + dz3d(i,:,j) = 0.0 + zi3d(i,:,j) = 0.0 + h2osoi_liq3d(i,:,j) = 0.0 + h2osoi_ice3d(i,:,j) = 0.0 + lake_icefrac3d(i,:,j) = 0.0 + h2osoi_vol3d(i,:,j) = 0.0 + snl2d(i,j) = 0.0 + if ( use_lakedepth.eq.1 .and.lake_depth_flag.eq.0 ) then !mchen + ! call wrf_error_fatal ( 'STOP: You need lake-depth information. Rerun WPS or set use_lakedepth = 0') + if(this_image()==1) write(*,*) ( 'STOP: You need lake-depth information. Rerun WPS or set use_lakedepth = 0') + end if + if ( use_lakedepth.eq.0 .and.lake_depth_flag.eq.1 ) then !mchen + lake_depth_flag = 0 + end if + if ( lake_depth_flag.eq.1 ) then + + if (lake_depth(i,j) > 0.0) then + lakedepth2d(i,j) = lake_depth(i,j) + else + if ( lakedepth_default > 0.0 ) then + lakedepth2d(i,j) = lakedepth_default + else + lakedepth2d(i,j) = spval + endif + endif + + else + if ( lakedepth_default > 0.0 ) then + lakedepth2d(i,j) = lakedepth_default + else + lakedepth2d(i,j) = spval + endif + endif + endif + + ENDDO + ENDDO + + !! BK: the lines below should become a function of nlevlake! +#ifndef EXTRALAKELAYERS +! dzlak(1) = 0.1_r8 +! dzlak(2) = 1._r8 +! dzlak(3) = 2._r8 +! dzlak(4) = 3._r8 +! dzlak(5) = 4._r8 +! dzlak(6) = 5._r8 +! dzlak(7) = 7._r8 +! dzlak(8) = 7._r8 +! dzlak(9) = 10.45_r8 +! dzlak(10)= 10.45_r8 +! +! zlak(1) = 0.05_r8 +! zlak(2) = 0.6_r8 +! zlak(3) = 2.1_r8 +! zlak(4) = 4.6_r8 +! zlak(5) = 8.1_r8 +! zlak(6) = 12.6_r8 +! zlak(7) = 18.6_r8 +! zlak(8) = 25.6_r8 +! zlak(9) = 34.325_r8 +! zlak(10)= 44.775_r8 + dzlak(1) = 0.1_r8 + dzlak(2) = 0.1_r8 + dzlak(3) = 0.1_r8 + dzlak(4) = 0.1_r8 + dzlak(5) = 0.1_r8 + dzlak(6) = 0.1_r8 + dzlak(7) = 0.1_r8 + dzlak(8) = 0.1_r8 + dzlak(9) = 0.1_r8 + dzlak(10)= 0.1_r8 + + zlak(1) = 0.05_r8 + zlak(2) = 0.15_r8 + zlak(3) = 0.25_r8 + zlak(4) = 0.35_r8 + zlak(5) = 0.45_r8 + zlak(6) = 0.55_r8 + zlak(7) = 0.65_r8 + zlak(8) = 0.75_r8 + zlak(9) = 0.85_r8 + zlak(10)= 0.95_r8 +#else + dzlak(1) =0.1_r8 + dzlak(2) =0.25_r8 + dzlak(3) =0.25_r8 + dzlak(4) =0.25_r8 + dzlak(5) =0.25_r8 + dzlak(6) =0.5_r8 + dzlak(7) =0.5_r8 + dzlak(8) =0.5_r8 + dzlak(9) =0.5_r8 + dzlak(10) =0.75_r8 + dzlak(11) =0.75_r8 + dzlak(12) =0.75_r8 + dzlak(13) =0.75_r8 + dzlak(14) =2_r8 + dzlak(15) =2_r8 + dzlak(16) =2.5_r8 + dzlak(17) =2.5_r8 + dzlak(18) =3.5_r8 + dzlak(19) =3.5_r8 + dzlak(20) =3.5_r8 + dzlak(21) =3.5_r8 + dzlak(22) =5.225_r8 + dzlak(23) =5.225_r8 + dzlak(24) =5.225_r8 + dzlak(25) =5.225_r8 + + zlak(1) = dzlak(1)/2._r8 + do k = 2,nlevlake + zlak(k) = zlak(k-1) + (dzlak(k-1)+dzlak(k))/2._r8 + end do +#endif + + ! "0" refers to soil surface and "nlevsoil" refers to the bottom of model soil + + do j = 1, nlevsoil + zsoi(j) = scalez*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths + enddo + + dzsoi(1) = 0.5_r8*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces + do j = 2,nlevsoil-1 + dzsoi(j)= 0.5_r8*(zsoi(j+1)-zsoi(j-1)) + enddo + dzsoi(nlevsoil) = zsoi(nlevsoil)-zsoi(nlevsoil-1) + + zisoi(0) = 0._r8 + do j = 1, nlevsoil-1 + zisoi(j) = 0.5_r8*(zsoi(j)+zsoi(j+1)) !interface depths + enddo + zisoi(nlevsoil) = zsoi(nlevsoil) + 0.5_r8*dzsoi(nlevsoil) + + +!!!!!!!!!!!!!!!!!!begin to initialize lake variables!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + DO j = jts,jte + DO i = its,ite + + if ( lake(i,j) ) then + + ! Soil hydraulic and thermal properties + isl = ISLTYP(i,j) + if (isl == 14 ) isl = isl + 1 + do k = 1,nlevsoil + sand3d(i,k,j) = sand(isl) + clay3d(i,k,j) = clay(isl) + enddo + + do k = 1,nlevsoil + clay2d(i,j) = clay3d(i,k,j) + sand2d(i,j) = sand3d(i,k,j) + watsat3d(i,k,j) = 0.489_r8 - 0.00126_r8*sand2d(i,j) + bd2d(i,j) = (1._r8-watsat3d(i,k,j))*2.7e3_r8 + xksat2d(i,j) = 0.0070556_r8 *( 10._r8**(-0.884_r8+0.0153_r8*sand2d(i,j)) ) ! mm/s + tkm2d(i,j) = (8.80_r8*sand2d(i,j)+2.92_r8*clay2d(i,j))/(sand2d(i,j)+clay2d(i,j)) ! W/(m K) + + bsw3d(i,k,j) = 2.91_r8 + 0.159_r8*clay2d(i,j) + bsw23d(i,k,j) = -(3.10_r8 + 0.157_r8*clay2d(i,j) - 0.003_r8*sand2d(i,j)) + psisat3d(i,k,j) = -(exp((1.54_r8 - 0.0095_r8*sand2d(i,j) + 0.0063_r8*(100.0_r8-sand2d(i,j) & + -clay2d(i,j)))*log(10.0_r8))*9.8e-5_r8) + vwcsat3d(i,k,j) = (50.5_r8 - 0.142_r8*sand2d(i,j) - 0.037_r8*clay2d(i,j))/100.0_r8 + hksat3d(i,k,j) = xksat2d(i,j) + sucsat3d(i,k,j) = 10._r8 * ( 10._r8**(1.88_r8-0.0131_r8*sand2d(i,j)) ) + tkmg3d(i,k,j) = tkm2d(i,j) ** (1._r8- watsat3d(i,k,j)) + tksatu3d(i,k,j) = tkmg3d(i,k,j)*0.57_r8**watsat3d(i,k,j) + tkdry3d(i,k,j) = (0.135_r8*bd2d(i,j) + 64.7_r8) / (2.7e3_r8 - 0.947_r8*bd2d(i,j)) + csol3d(i,k,j) = (2.128_r8*sand2d(i,j)+2.385_r8*clay2d(i,j)) / (sand2d(i,j)+clay2d(i,j))*1.e6_r8 ! J/(m3 K) + watdry3d(i,k,j) = watsat3d(i,k,j) * (316230._r8/sucsat3d(i,k,j)) ** (-1._r8/bsw3d(i,k,j)) + watopt3d(i,k,j) = watsat3d(i,k,j) * (158490._r8/sucsat3d(i,k,j)) ** (-1._r8/bsw3d(i,k,j)) + end do + if (lakedepth2d(i,j) == spval) then + lakedepth2d(i,j) = zlak(nlevlake) + 0.5_r8*dzlak(nlevlake) + z_lake3d(i,1:nlevlake,j) = zlak(1:nlevlake) + dz_lake3d(i,1:nlevlake,j) = dzlak(1:nlevlake) + else + depthratio2d(i,j) = lakedepth2d(i,j) / (zlak(nlevlake) + 0.5_r8*dzlak(nlevlake)) + z_lake3d(i,1,j) = zlak(1) + dz_lake3d(i,1,j) = dzlak(1) + dz_lake3d(i,2:nlevlake,j) = dzlak(2:nlevlake)*depthratio2d(i,j) + z_lake3d(i,2:nlevlake,j) = zlak(2:nlevlake)*depthratio2d(i,j) + dz_lake3d(i,1,j)*(1._r8 - depthratio2d(i,j)) + end if +! initial t_lake3d here + t_soisno3d(i,1,j) = tsk(i,j) + t_lake3d(i,1,j) = tsk(i,j) + t_grnd2d(i,j) = 277.0 + do k = 2, nlevlake + if(z_lake3d(i,k,j).le.depth_c) then + ! t_soisno3d(i,k,j)=tsk(i,j)+(277.0-tsk(i,j))/depth_c*z_lake3d(i,k,j) ! BK commented out; dims incorrect: dimension( ims:ime,-nlevsnow+1:nlevsoil, jms:jme ),INTENT(out) :: t_soisno3d, This works only when nlevsoil=nlevlake. Sloppy coding! + t_lake3d(i,k,j)=tsk(i,j)+(277.0-tsk(i,j))/depth_c*z_lake3d(i,k,j) + else + ! t_soisno3d(i,k,j) = 277.0 + t_lake3d(i,k,j) = 277.0 + end if + enddo + ! BK added for nlevsoil !=nlevlake: + do k = 2, nlevsoil + if(z_lake3d(i,k,j).le.depth_c) then + t_soisno3d(i,k,j)=tsk(i,j)+(277.0-tsk(i,j))/depth_c*z_lake3d(i,k,j) + else + t_soisno3d(i,k,j) = 277.0 + end if + enddo ! END BK addition + +!end initial t_lake3d here + z3d(i,1:nlevsoil,j) = zsoi(1:nlevsoil) + zi3d(i,0:nlevsoil,j) = zisoi(0:nlevsoil) + dz3d(i,1:nlevsoil,j) = dzsoi(1:nlevsoil) + savedtke12d(i,j) = tkwat ! Initialize for first timestep. + + + if (snowdp2d(i,j) < 0.01_r8) then + snl2d(i,j) = 0 + dz3d(i,-nlevsnow+1:0,j) = 0._r8 + z3d (i,-nlevsnow+1:0,j) = 0._r8 + zi3d(i,-nlevsnow+0:0,j) = 0._r8 + else + if ((snowdp2d(i,j) >= 0.01_r8) .and. (snowdp2d(i,j) <= 0.03_r8)) then + snl2d(i,j) = -1 + dz3d(i,0,j) = snowdp2d(i,j) + else if ((snowdp2d(i,j) > 0.03_r8) .and. (snowdp2d(i,j) <= 0.04_r8)) then + snl2d(i,j) = -2 + dz3d(i,-1,j) = snowdp2d(i,j)/2._r8 + dz3d(i, 0,j) = dz3d(i,-1,j) + else if ((snowdp2d(i,j) > 0.04_r8) .and. (snowdp2d(i,j) <= 0.07_r8)) then + snl2d(i,j) = -2 + dz3d(i,-1,j) = 0.02_r8 + dz3d(i, 0,j) = snowdp2d(i,j) - dz3d(i,-1,j) + else if ((snowdp2d(i,j) > 0.07_r8) .and. (snowdp2d(i,j) <= 0.12_r8)) then + snl2d(i,j) = -3 + dz3d(i,-2,j) = 0.02_r8 + dz3d(i,-1,j) = (snowdp2d(i,j) - 0.02_r8)/2._r8 + dz3d(i, 0,j) = dz3d(i,-1,j) + else if ((snowdp2d(i,j) > 0.12_r8) .and. (snowdp2d(i,j) <= 0.18_r8)) then + snl2d(i,j) = -3 + dz3d(i,-2,j) = 0.02_r8 + dz3d(i,-1,j) = 0.05_r8 + dz3d(i, 0,j) = snowdp2d(i,j) - dz3d(i,-2,j) - dz3d(i,-1,j) + else if ((snowdp2d(i,j) > 0.18_r8) .and. (snowdp2d(i,j) <= 0.29_r8)) then + snl2d(i,j) = -4 + dz3d(i,-3,j) = 0.02_r8 + dz3d(i,-2,j) = 0.05_r8 + dz3d(i,-1,j) = (snowdp2d(i,j) - dz3d(i,-3,j) - dz3d(i,-2,j))/2._r8 + dz3d(i, 0,j) = dz3d(i,-1,j) + else if ((snowdp2d(i,j) > 0.29_r8) .and. (snowdp2d(i,j) <= 0.41_r8)) then + snl2d(i,j) = -4 + dz3d(i,-3,j) = 0.02_r8 + dz3d(i,-2,j) = 0.05_r8 + dz3d(i,-1,j) = 0.11_r8 + dz3d(i, 0,j) = snowdp2d(i,j) - dz3d(i,-3,j) - dz3d(i,-2,j) - dz3d(i,-1,j) + else if ((snowdp2d(i,j) > 0.41_r8) .and. (snowdp2d(i,j) <= 0.64_r8)) then + snl2d(i,j) = -5 + dz3d(i,-4,j) = 0.02_r8 + dz3d(i,-3,j) = 0.05_r8 + dz3d(i,-2,j) = 0.11_r8 + dz3d(i,-1,j) = (snowdp2d(i,j) - dz3d(i,-4,j) - dz3d(i,-3,j) - dz3d(i,-2,j))/2._r8 + dz3d(i, 0,j) = dz3d(i,-1,j) + else if (snowdp2d(i,j) > 0.64_r8) then + snl2d(i,j) = -5 + dz3d(i,-4,j) = 0.02_r8 + dz3d(i,-3,j) = 0.05_r8 + dz3d(i,-2,j) = 0.11_r8 + dz3d(i,-1,j) = 0.23_r8 + dz3d(i, 0,j)=snowdp2d(i,j)-dz3d(i,-4,j)-dz3d(i,-3,j)-dz3d(i,-2,j)-dz3d(i,-1,j) + endif + end if + + do k = 0, snl2d(i,j)+1, -1 + z3d(i,k,j) = zi3d(i,k,j) - 0.5_r8*dz3d(i,k,j) + zi3d(i,k-1,j) = zi3d(i,k,j) - dz3d(i,k,j) + end do + +! 3:subroutine makearbinit + + if (snl2d(i,j) < 0) then + do k = snl2d(i,j)+1, 0 + ! Be careful because there may be new snow layers with bad temperatures like 0 even if + ! coming from init. con. file. + if(arbinit .or. t_soisno3d(i,k,j) > 300 .or. t_soisno3d(i,k,j) < 200) t_soisno3d(i,k,j) = 250._r8 + enddo + end if + + do k = 1, nlevsoil + if(arbinit .or. t_soisno3d(i,k,j) > 1000 .or. t_soisno3d(i,k,j) < 0) t_soisno3d(i,k,j) = t_lake3d(i,nlevlake,j) + end do + + do k = 1, nlevlake + if(arbinit .or. lake_icefrac3d(i,k,j) > 1._r8 .or. lake_icefrac3d(i,k,j) < 0._r8) then + if(t_lake3d(i,k,j) >= tfrz) then + lake_icefrac3d(i,k,j) = 0._r8 + else + lake_icefrac3d(i,k,j) = 1._r8 + end if + end if + end do + + do k = 1,nlevsoil + if (arbinit .or. h2osoi_vol3d(i,k,j) > 10._r8 .or. h2osoi_vol3d(i,k,j) < 0._r8) h2osoi_vol3d(i,k,j) = 1.0_r8 + h2osoi_vol3d(i,k,j) = min(h2osoi_vol3d(i,k,j),watsat3d(i,k,j)) + + ! soil layers + if (t_soisno3d(i,k,j) <= tfrz) then + h2osoi_ice3d(i,k,j) = dz3d(i,k,j)*denice*h2osoi_vol3d(i,k,j) + h2osoi_liq3d(i,k,j) = 0._r8 + else + h2osoi_ice3d(i,k,j) = 0._r8 + h2osoi_liq3d(i,k,j) = dz3d(i,k,j)*denh2o*h2osoi_vol3d(i,k,j) + endif + enddo + + do k = -nlevsnow+1, 0 + if (k > snl2d(i,j)) then + h2osoi_ice3d(i,k,j) = dz3d(i,k,j)*bdsno + h2osoi_liq3d(i,k,j) = 0._r8 + end if + end do + + end if !lake(i,j) + ENDDO + ENDDO + + END SUBROUTINE lakeini + +END MODULE module_water_lake diff --git a/src/physics/water_simple.f90 b/src/physics/water_simple.f90 index 64095dc2..29bc15f7 100644 --- a/src/physics/water_simple.f90 +++ b/src/physics/water_simple.f90 @@ -6,7 +6,9 @@ !! !!---------------------------------------------------------- module module_water_simple - use data_structures + use data_structures, + use options_interface, only : options_t + use icar_constants implicit none real, parameter :: freezing_threshold=273.15 @@ -78,15 +80,19 @@ function ocean_roughness(ustar) result(z0) z0 = 8e-6 / max(ustar,1e-7) end function ocean_roughness - subroutine water_simple(sst, psfc, wind, ustar, qv, temperature, & + module subroutine water_simple(options, sst, psfc, wind, ustar, qv, temperature, & sensible_heat, latent_heat, & z_atm, Z0, landmask, & - qv_surf, evap_flux, tskin) + qv_surf, evap_flux, tskin, vegtype ) implicit none + type(options_t),intent(in) :: options real, dimension(:,:,:),intent(in) :: qv, temperature real, dimension(:,:), intent(inout) :: sensible_heat, latent_heat, Z0, qv_surf, evap_flux, tskin real, dimension(:,:), intent(in) :: sst, psfc, wind, ustar, z_atm integer, dimension(:,:), intent(in) :: landmask + integer, dimension(:,:), intent(in), optional :: vegtype + ! real, dimension(:), intent(in) :: lake_min_elev + ! integer, dimension(:), intent(in) :: lakeflag integer :: nx, ny, i, j real :: base_exchange_term, lnz_atm_term, exchange_C, z @@ -96,7 +102,17 @@ subroutine water_simple(sst, psfc, wind, ustar, qv, temperature, & do j=2,ny-1 do i=2,nx-1 - if (landmask(i,j)==kLC_WATER) then + if( & + ( (options%physics%watersurface==kWATER_SIMPLE) .AND. & ! If lakemodel is not selected, use this + (landmask(i,j)==kLC_WATER) & !(n.b. in case noah (mp or lsm) is not used, landmask may not be set correctly!) + ) & + .OR. & + ( (options%physics%watersurface==kWATER_LAKE) .AND. & ! if lake model is selected, and + (vegtype(i,j).eq.options%lsm_options%water_category) .AND. & ! gridcell is water, + (vegtype(i,j).ne.options%lsm_options%lake_category) & ! but not lake (i.e ocean) + ) & + )then + qv_surf(i,j) = 0.98 * sat_mr(sst(i,j),psfc(i,j)) ! multiply by 0.98 to account for salinity Z0(i,j) = ocean_roughness(ustar(i,j)) diff --git a/src/physics/wind.f90 b/src/physics/wind.f90 index 50b01935..dfc602d3 100644 --- a/src/physics/wind.f90 +++ b/src/physics/wind.f90 @@ -23,7 +23,7 @@ module wind implicit none private - public::update_winds, init_winds, wind_var_request + public::update_winds, init_winds, wind_var_request, balance_uvw real, parameter::deg2rad=0.017453293 !2*pi/360 contains @@ -62,6 +62,9 @@ subroutine wind_var_request(options) if (options%physics%windtype == kWIND_LINEAR) then call wind_linear_var_request(options) endif + if (options%physics%windtype == kLINEAR_ITERATIVE_WINDS) then + call wind_linear_var_request(options) + endif end subroutine wind_var_request @@ -75,11 +78,11 @@ end subroutine wind_var_request !! Starts by setting w out of the ground=0 then works through layers !! !!------------------------------------------------------------ - subroutine balance_uvw(u,v,w, jaco_u,jaco_v,jaco_w,dz,dx,jaco,smooth_height, options) + subroutine balance_uvw(u,v,w, jaco_u,jaco_v,jaco_w,dz,dx,jaco, options) implicit none real, intent(inout) :: u(:,:,:), v(:,:,:), w(:,:,:) real, intent(in) :: jaco_u(:,:,:), jaco_v(:,:,:), jaco_w(:,:,:), dz(:,:,:), jaco(:,:,:) - real, intent(in) :: dx, smooth_height + real, intent(in) :: dx type(options_t),intent(in) :: options real, allocatable, dimension(:,:) :: rhou, rhov, rhow @@ -112,7 +115,7 @@ subroutine balance_uvw(u,v,w, jaco_u,jaco_v,jaco_w,dz,dx,jaco,smooth_height, opt allocate(divergence(ims:ime,kms:kme,jms:jme)) - call calc_divergence(divergence,u,v,w,jaco_u,jaco_v,jaco_w,dz,dx,jaco,smooth_height,horz_only=.True.) + call calc_divergence(divergence,u,v,w,jaco_u,jaco_v,jaco_w,dz,dx,jaco,horz_only=.True.) ! If this becomes a bottle neck in the code it could be parallelized over y ! loop over domain levels @@ -166,11 +169,11 @@ subroutine balance_uvw(u,v,w, jaco_u,jaco_v,jaco_w,dz,dx,jaco,smooth_height, opt end subroutine balance_uvw - subroutine calc_divergence(div, u, v, w, jaco_u, jaco_v, jaco_w, dz, dx, jaco, smooth_height,horz_only) + subroutine calc_divergence(div, u, v, w, jaco_u, jaco_v, jaco_w, dz, dx, jaco,horz_only) implicit none real, intent(inout) :: div(:,:,:) real, intent(in) :: u(:,:,:), v(:,:,:), w(:,:,:), dz(:,:,:), jaco_u(:,:,:), jaco_v(:,:,:), jaco_w(:,:,:), jaco(:,:,:) - real, intent(in) :: dx, smooth_height + real, intent(in) :: dx logical, optional, intent(in) :: horz_only ! type(options_t),intent(in) :: options @@ -207,8 +210,7 @@ subroutine calc_divergence(div, u, v, w, jaco_u, jaco_v, jaco_w, dz, dx, jaco, s div(ims:ime,kms:kme,jms:jme) = (diff_U+diff_V)/(dx) if (.NOT.(horz)) then - w_met = w * jaco_w !(:,kms:kme-1,:) = w(:,kms:kme-1,:) * (jaco(:,kms:kme-1,:)+jaco(:,kms+1:kme,:))/2 - !w_met(:,kme,:) = w(:,kme,:) * jaco(:,kme,:) + w_met = w * jaco_w do k = kms,kme if (k == kms) then @@ -218,6 +220,8 @@ subroutine calc_divergence(div, u, v, w, jaco_u, jaco_v, jaco_w, dz, dx, jaco, s (w_met(ims:ime,k,jms:jme)-w_met(ims:ime,k-1,jms:jme))/(dz(ims:ime,k,jms:jme)) endif enddo + ! If we are doing a full calculation of divergence, and not just U+V differencing for balance_uvw, then divide by + ! jacobian at the end div = div/jaco endif @@ -315,11 +319,17 @@ subroutine update_winds(domain, options) elseif (options%physics%windtype==kITERATIVE_WINDS) then call iterative_winds(domain, options) + elseif (options%physics%windtype==kLINEAR_ITERATIVE_WINDS) then + call linear_perturb(domain,options,options%lt_options%vert_smooth,.False.,options%parameters%advect_density, update=.False.) + call iterative_winds(domain, options) + endif ! else assumes even flow over the mountains ! use horizontal divergence (convergence) to calculate vertical convergence (divergence) - call balance_uvw(domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, domain%jacobian_u, domain%jacobian_v, domain%jacobian_w, domain%advection_dz, domain%dx, domain%jacobian, domain%smooth_height, options) + call balance_uvw(domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, & + domain%jacobian_u, domain%jacobian_v, domain%jacobian_w, & + domain%advection_dz, domain%dx, domain%jacobian, options) else @@ -340,15 +350,18 @@ subroutine update_winds(domain, options) elseif (options%physics%windtype==kITERATIVE_WINDS) then call iterative_winds(domain, options, update_in=.True.) + elseif (options%physics%windtype==kLINEAR_ITERATIVE_WINDS) then + call linear_perturb(domain,options,options%lt_options%vert_smooth,.False.,options%parameters%advect_density, update=.True.) + call iterative_winds(domain, options, update_in=.True.) endif - ! use horizontal divergence (convergence) to calculate vertical convergence (divergence) + ! use horizontal divergence (convergence) to calculate vertical convergence (divergence) call balance_uvw(domain% u %meta_data%dqdt_3d, & domain% v %meta_data%dqdt_3d, & domain% w %meta_data%dqdt_3d, & domain%jacobian_u, domain%jacobian_v, domain%jacobian_w, & domain%advection_dz, domain%dx, & - domain%jacobian, domain%smooth_height, options) + domain%jacobian, options) endif @@ -394,8 +407,9 @@ subroutine iterative_winds(domain, options, update_in) call domain%v%exchange_v() !First call bal_uvw to generate an initial-guess for vertical winds - call balance_uvw(domain%u%data_3d,domain%v%data_3d,domain%w%data_3d,domain%jacobian_u,domain%jacobian_v,domain%jacobian_w,domain%advection_dz,& - domain%dx,domain%jacobian,domain%smooth_height,options) + call balance_uvw(domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, & + domain%jacobian_u, domain%jacobian_v, domain%jacobian_w, & + domain%advection_dz, domain%dx, domain%jacobian, options) allocate(div(ims:ime,kms:kme,jms:jme)) allocate(ADJ_coef(ims:ime,kms:kme,jms:jme)) @@ -405,28 +419,34 @@ subroutine iterative_winds(domain, options, update_in) ! Calculate and apply correction to w-winds wind_k = kme - do k = kms,kme - if (sum(domain%advection_dz(ims,1:k,jms)) > domain%smooth_height) then - wind_k = k - exit - endif - enddo - + ! previously this code was solving for 0 vertical motion at the flat z height instead of the top boundary. + ! left in for now as it could be useful to implement something similar in the future. + ! however, this was also creating weird artifacts above the flat z height that need to be fixed if re-implementing. + ! do k = kms,kme + ! if (sum(domain%advection_dz(ims,1:k,jms)) > domain%smooth_height) then + ! wind_k = k + ! exit + ! endif + ! enddo + ! domain%smooth_height = sum(domain%advection_dz(ims,:,jms)) !Compute relative correction factors for U and V based on input speeds U_cor = ABS(domain%u%data_3d(ims:ime,:,jms:jme))/ & (ABS(domain%u%data_3d(ims:ime,:,jms:jme))+ABS(domain%v%data_3d(ims:ime,:,jms:jme))) - do k = kms,kme - corr_factor = ((sum(domain%advection_dz(ims,1:k,jms)))/domain%smooth_height) - !corr_factor = (k*1.0)/wind_k - corr_factor = min(corr_factor,1.0) - do i = ims,ime - do j = jms,jme + do i = ims,ime + do j = jms,jme + domain%smooth_height = sum(domain%advection_dz(i,:,j)) ! + do k = kms,kme + corr_factor = ((sum(domain%advection_dz(i,1:k,j)))/domain%smooth_height) + corr_factor = min(corr_factor,1.0) domain%w%data_3d(i,k,j) = domain%w%data_3d(i,k,j) - corr_factor * (domain%w%data_3d(i,wind_k,j)) !if ( (domain%u%data_3d(i,k,j)+domain%v%data_3d(i,k,j)) == 0) U_cor(i,k,j) = 0.5 enddo enddo + enddo + + do k = kms,kme ! Compute this now, since it wont change in the loop ADJ_coef(:,k,:) = -2/domain%dx enddo @@ -440,8 +460,9 @@ subroutine iterative_winds(domain, options, update_in) ! Now, fixing w-winds, iterate over U/V to reduce divergence with new w-winds do it = 0,options%parameters%wind_iterations !Compute divergence in new wind field - call calc_divergence(div,domain%u%data_3d,domain%v%data_3d,domain%w%data_3d,domain%jacobian_u,domain%jacobian_v,domain%jacobian_w, & - domain%advection_dz,domain%dx,domain%jacobian,domain%smooth_height) + call calc_divergence(div, domain%u%data_3d, domain%v%data_3d, domain%w%data_3d, & + domain%jacobian_u, domain%jacobian_v, domain%jacobian_w, & + domain%advection_dz, domain%dx, domain%jacobian) !Compute adjustment based on divergence ADJ = div/ADJ_coef @@ -520,7 +541,7 @@ subroutine init_winds(domain,options) jms = lbound(domain%latitude%data_2d, 2) jme = ubound(domain%latitude%data_2d, 2) - if (this_image()==1) print*, "Reading Sinalph/cosalpha" + if (this_image()==1) print*, "Reading sin/cos alpha" call io_read(options%parameters%init_conditions_file, options%parameters%sinalpha_var, temporary_2d) domain%sintheta = temporary_2d(ims:ime, jms:jme) @@ -538,6 +559,7 @@ subroutine init_winds(domain,options) ime = ubound(lat,1) jms = lbound(lat,2) jme = ubound(lat,2) + if (this_image()==1) print*, "Computing sin/cos alpha" do j = jms, jme do i = ims, ime ! in case we are in the first or last grid, reset boundaries diff --git a/src/tests/test_calendar.f90 b/src/tests/test_calendar.f90 index b1f86826..27a1586f 100644 --- a/src/tests/test_calendar.f90 +++ b/src/tests/test_calendar.f90 @@ -10,7 +10,8 @@ !! !!------------------------------------------------------------ module calendar_test_module - use time + use iso_fortran_env, only: real128 + use time_object integer, parameter :: STRING_LENGTH = 255 real, parameter :: MAX_ERROR = 1e-5 ! allow less than 1 second error (over a 2100 yr period) contains @@ -18,22 +19,25 @@ logical function calendar_test(calendar_name,error) character(len=STRING_LENGTH), intent(in) :: calendar_name character(len=STRING_LENGTH), intent(out) :: error - double precision :: mjd_input, mjd_output - double precision :: min_mjd, max_mjd, mjd_step + type(time_type) :: time + real(real128) :: mjd_input, mjd_output + real(real128) :: min_mjd, max_mjd, mjd_step integer :: year, month, day, hour, minute, second error="" calendar_test=.True. - call time_init(calendar_name) + call time%init(calendar_name) min_mjd=365.0*1.d0 max_mjd=365.0*2100.d0 mjd_step=0.1 - MJDLOOP: do mjd_input = min_mjd, max_mjd, mjd_step + mjd_input = min_mjd + do while (mjd_input .le. max_mjd) ! test that input and output Modified Julian Days stay the same - call calendar_date(mjd_input, year, month, day, hour, minute, second) - mjd_output=date_to_mjd(year, month, day, hour, minute, second) + call time%set(mjd_input) + call time%date(year, month, day, hour, minute, second) + mjd_output=time%date_to_mjd(year, month, day, hour, minute, second) ! test that month and day values are at least realistic (rare to fail) if ((day<1).or.(day>31)) then @@ -43,13 +47,15 @@ logical function calendar_test(calendar_name,error) print*, " min_mjd, max_mjd, mjd_step" print*, min_mjd, max_mjd, mjd_step print*, " Corresponding First Date" - call calendar_date(min_mjd, year, month, day, hour, minute, second) + call time%set(min_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second print*, " Corresponding Last Date" - call calendar_date(max_mjd, year, month, day, hour, minute, second) + call time%set(max_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second print*, " " - EXIT MJDLOOP + EXIT endif if ((month<1).or.(month>12)) then calendar_test=.False. @@ -58,13 +64,15 @@ logical function calendar_test(calendar_name,error) print*, " min_mjd, max_mjd, mjd_step" print*, min_mjd, max_mjd, mjd_step print*, " Corresponding First Date" - call calendar_date(min_mjd, year, month, day, hour, minute, second) + call time%set(min_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second print*, " Corresponding Last Date" - call calendar_date(max_mjd, year, month, day, hour, minute, second) + call time%set(max_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second print*, " " - EXIT MJDLOOP + EXIT endif ! this is the main test it is likely to fail @@ -75,26 +83,29 @@ logical function calendar_test(calendar_name,error) print*, " min_mjd, max_mjd, mjd_step" print*, min_mjd, max_mjd, mjd_step print*, " Corresponding First Date" - call calendar_date(min_mjd, year, month, day, hour, minute, second) + call time%set(min_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second print*, " Corresponding Last Date" - call calendar_date(max_mjd, year, month, day, hour, minute, second) + call time%set(max_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second print*, " " - EXIT MJDLOOP + EXIT endif - end do MJDLOOP + mjd_input = mjd_input + mjd_step + end do end function calendar_test subroutine detailed_tests(calendar_name) character(len=STRING_LENGTH), intent(in) :: calendar_name - - double precision :: mjd_input, mjd_output - double precision :: min_mjd, max_mjd, mjd_step + type(time_type) :: time + real(real128) :: mjd_input, mjd_output + real(real128) :: min_mjd, max_mjd, mjd_step integer :: year, month, day, hour, minute, second - call time_init(calendar_name) + call time%init(calendar_name) min_mjd=365.0*1.d0 max_mjd=365.0*2.d0 mjd_step=1 @@ -103,21 +114,24 @@ subroutine detailed_tests(calendar_name) print*, " min_mjd, max_mjd, mjd_step" print*, min_mjd, max_mjd, mjd_step print*, " Corresponding First Date" - call calendar_date(min_mjd, year, month, day, hour, minute, second) + call time%set(min_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second print*, " Corresponding Last Date" - call calendar_date(max_mjd, year, month, day, hour, minute, second) + call time%set(max_mjd) + call time%date(year, month, day, hour, minute, second) print*, year, month, day, hour, minute, second - MJDLOOP: do mjd_input = min_mjd, max_mjd, mjd_step + mjd_input = min_mjd + do while (mjd_input .le. max_mjd) ! test that input and output Modified Julian Days stay the same - call calendar_date(mjd_input, year, month, day, hour, minute, second) - mjd_output=date_to_mjd(year, month, day, hour, minute, second) + call time%set(mjd_input) + call time%date(year, month, day, hour, minute, second) + mjd_output=time%date_to_mjd(year, month, day, hour, minute, second) print*, mjd_input, mjd_output, mjd_output - mjd_input print*, year, month, day, hour, minute, second - end do MJDLOOP - - + mjd_input = mjd_input + mjd_step + end do end subroutine end module calendar_test_module diff --git a/src/tests/test_time_obj.f90 b/src/tests/test_time_obj.f90 new file mode 100644 index 00000000..9083b250 --- /dev/null +++ b/src/tests/test_time_obj.f90 @@ -0,0 +1,71 @@ +! Test if the precision of the time_delta_t object will lead to +! precision errors +program test_time_object + use iso_fortran_env, only: real64, real128, int64 + use time_object, only: time_type + use time_delta_object, only: time_delta_t + implicit none + + type(time_type) :: t_obj + type(time_delta_t) :: dt + real(real128) :: t128, err_r128 + real :: delta_r32, tmp1 + real(real64) :: delta_r64, tmp2 + integer(int64) :: i, n, i64 , err_i64 + character(len=44) :: c_i + + ! add delta_t n times to the time object + n = 10000000 + write(c_i, '(i44)') n + + ! --- setup experiment --- + ! tmp variables used so compiler doesn't optimize out + tmp1 = 3600 / 86400.0 + delta_r32 = tmp1 * 86400.0 + + tmp2 = 3600 / 86400.0 + delta_r64 = tmp2 * 86400.0 + call t_obj%set(1980, 1, 1, 0, 0, 0) + call dt%set(seconds=delta_r32) + t128 = t_obj%seconds() + i64 = int(t_obj%seconds(), kind=int64) + + print *, "iterating ", trim(adjustl(c_i)), " times" + print *, "delta_r32 = ", delta_r32 + print *, "delta_r64 = ", delta_r64 + print *, "--- running ---" + + ! do loop incrementing time object + do i = 0, n + ! increment time + t_obj = t_obj + dt + t128 = t128 + delta_r32 + i64 = i64 + 3600 + + ! calculate difference between time object and variables of type real128 + ! and type int64 + err_r128 = abs(t128 - t_obj%seconds()) + err_i64 = int(abs(i64 - t_obj%seconds()), kind=int64) + + ! report if error difference too large + if (err_r128 .gt. 1.0) then + print *, "err = ", err_r128 + stop "ERROR ERR_R128 > 1.0" + end if + if (err_i64 .gt. 0) then + print *, "err_i64 = ", err_i64 + stop "ERROR ERR_I64 > 0" + end if + end do + + ! report or expirement + write(c_i, '(i44)') i64 + print *, "SUCCESS" + print *, "t_obj = ", t_obj%seconds(), "seconds" + print *, "t128 = ", t128, "seconds" + print *, "i64 = ", trim(adjustl(c_i)), " seconds" + + print *, "final err_r128 = ", err_r128 + print *, "final err_i64 = ", err_i64 + +end program test_time_object diff --git a/src/utilities/array_utilities.f90 b/src/utilities/array_utilities.f90 index 844c7f9f..c909db0f 100644 --- a/src/utilities/array_utilities.f90 +++ b/src/utilities/array_utilities.f90 @@ -17,6 +17,87 @@ module array_utilities contains + subroutine make_2d(lat,lon) + implicit none + real, intent(inout), allocatable :: lat(:,:), lon(:,:) + integer :: ims, ime, jms, jme, i + real, allocatable :: temporary_geo_data(:,:) + + if (size(lat,2)==1) then + + ims = lbound(lon,1) + ime = ubound(lon,1) + jms = lbound(lat,1) + jme = ubound(lat,1) + + allocate(temporary_geo_data(ims:ime, jms:jme)) + do i = jms,jme + temporary_geo_data(:,i) = lon(:,1) + end do + + deallocate(lon) + allocate(lon(ims:ime, jms:jme)) + lon = temporary_geo_data + + do i = ims, ime + temporary_geo_data(i,:) = lat(:,1) + end do + deallocate(lat) + allocate(lat(ims:ime, jms:jme)) + lat = temporary_geo_data + + endif + end subroutine make_2d + + subroutine make_2d_x(dataarray, ms, me) + implicit none + real, intent(inout), allocatable :: dataarray(:,:) + integer, intent(in) :: ms, me + + integer :: ims, ime, j + real, allocatable :: temporary_data(:,:) + + if (size(dataarray,2)==1) then + + ims = lbound(dataarray,1) + ime = ubound(dataarray,1) + allocate(temporary_data(ims:ime, ms:me)) + do j = ms,me + temporary_data(:,j) = dataarray(:,1) + end do + + deallocate(dataarray) + allocate(dataarray(ims:ime, ms:me)) + dataarray = temporary_data + endif + + end subroutine make_2d_x + + subroutine make_2d_y(dataarray, ms, me) + implicit none + real, intent(inout), allocatable :: dataarray(:,:) + integer, intent(in) :: ms, me + + integer :: jms, jme, j + real, allocatable :: temporary_data(:,:) + + if (size(dataarray,2)==1) then + + jms = lbound(dataarray,1) + jme = ubound(dataarray,1) + allocate(temporary_data(ms:me, jms:jme)) + do j = jms,jme + temporary_data(:,j) = dataarray(j,1) + end do + + deallocate(dataarray) + allocate(dataarray(ms:me, jms:jme)) + dataarray = temporary_data + endif + + end subroutine make_2d_y + + subroutine interpolate_in_z(input) implicit none real, allocatable, intent(inout) :: input(:,:,:) @@ -90,12 +171,19 @@ subroutine array_offset_y_2d(input_array, output_array) ny = size(input_array,2) if (allocated(output_array)) deallocate(output_array) - allocate(output_array(nx, ny+1)) - - output_array(:,1) = (1.5 * input_array(:,1) - 0.5 * input_array(:,2)) ! extrapolate past the end - output_array(:,2:ny) = (input_array(:,1:ny-1) + input_array(:,2:ny) ) / 2 ! interpolate between points - output_array(:,ny+1) = (1.5 * input_array(:,ny) - 0.5 * input_array(:,ny-1))! extrapolate past the end - + if (ny > 1) then + allocate(output_array(nx, ny+1)) + + output_array(:,1) = (1.5 * input_array(:,1) - 0.5 * input_array(:,2)) ! extrapolate past the end + output_array(:,2:ny) = (input_array(:,1:ny-1) + input_array(:,2:ny) ) / 2 ! interpolate between points + output_array(:,ny+1) = (1.5 * input_array(:,ny) - 0.5 * input_array(:,ny-1))! extrapolate past the end + else ! this came in as essentially a 1D array with y really being in the x position as a result + allocate(output_array(nx+1, ny)) + + output_array(1,:) = (1.5 * input_array(1,:) - 0.5 * input_array(2,:)) ! extrapolate past the end + output_array(2:nx,:) = (input_array(1:nx-1,:) + input_array(2:nx,:) ) / 2 ! interpolate between points + output_array(nx+1,:) = (1.5 * input_array(nx,:) - 0.5 * input_array(nx-1,:))! extrapolate past the end + endif end subroutine subroutine array_offset_y_3d(input_array, output_array) @@ -110,6 +198,7 @@ subroutine array_offset_y_3d(input_array, output_array) ny = size(input_array,3) if (allocated(output_array)) deallocate(output_array) + allocate(output_array(nx, nz, ny+1)) output_array(:,:,1) = (1.5 * input_array(:,:,1) - 0.5 * input_array(:,:,2)) ! extrapolate past the end diff --git a/src/utilities/atm_utilities.f90 b/src/utilities/atm_utilities.f90 index c97c5e4c..e1b32908 100644 --- a/src/utilities/atm_utilities.f90 +++ b/src/utilities/atm_utilities.f90 @@ -24,6 +24,83 @@ module mod_atm_utilities contains + !>---------------------------------------------------------- + !! Compute column integrated vapor transport (non-directional) + !! + !! Input humidity is mixing ratio [kg/kg] + !! Pressures are in Pascals [Pa] + !! U/V are EW and NS wind on the mass grid [m/s] + !! + !!---------------------------------------------------------- + subroutine compute_ivt(ivt, qv, u, v, pi) + implicit none + real, intent(in), dimension(:,:,:) :: pi, qv, u, v + real, intent(inout), dimension(:,:) :: ivt + + integer :: i, ims, ime + integer :: k, kms, kme + integer :: j, jms, jme + + ims = lbound(qv,1) + ime = ubound(qv,1) + kms = lbound(qv,2) + kme = ubound(qv,2) + jms = lbound(qv,3) + jme = ubound(qv,3) + + ivt = 0 + do j = jms, jme + do k = kms, kme-1 + do i = ims, ime + if (pi(i,k+1,j) > 50000) then + ivt(i,j) = ivt(i,j) + ( qv(i,k,j) * sqrt(u(i,k,j)**2 + v(i,k,j)**2) * (pi(i,k,j) - pi(i,k+1,j)) ) / gravity + elseif (pi(i,k,j) > 50000) then + ivt(i,j) = ivt(i,j) + ( qv(i,k,j) * sqrt(u(i,k,j)**2 + v(i,k,j)**2) * (pi(i,k,j) - 50000) ) / gravity + endif + enddo + enddo + end do + + end subroutine compute_ivt + + !>---------------------------------------------------------- + !! Compute column integrated scalar (q) + !! + !! Input scalar is mixing ratio [kg/kg] + !! Pressures are in Pascals [Pa] + !! + !!---------------------------------------------------------- + subroutine compute_iq(iq, q, pi) + implicit none + real, intent(in), dimension(:,:,:) :: pi, q + real, intent(inout), dimension(:,:) :: iq + + integer :: i, ims, ime + integer :: k, kms, kme + integer :: j, jms, jme + + ims = lbound(q,1) + ime = ubound(q,1) + kms = lbound(q,2) + kme = ubound(q,2) + jms = lbound(q,3) + jme = ubound(q,3) + + iq = 0 + do j = jms, jme + do k = kms, kme-1 + do i = ims, ime + if (pi(i,k+1,j) > 50000) then + iq(i,j) = iq(i,j) + ( q(i,k,j) * (pi(i,k,j) - pi(i,k+1,j)) ) / gravity + elseif (pi(i,k,j) > 50000) then + iq(i,j) = iq(i,j) + ( q(i,k,j) * (pi(i,k,j) - 50000) ) / gravity + endif + enddo + enddo + end do + + end subroutine compute_iq + !>---------------------------------------------------------- !! Compute a 3D height field given a surface (or sea level) pressure @@ -632,4 +709,434 @@ subroutine init_atm_utilities(options) end subroutine init_atm_utilities +!+---+-----------------------------------------------------------------+ +!..Cloud fraction scheme by G. Thompson (NCAR-RAL), not intended for +!.. combining with any cumulus or shallow cumulus parameterization +!.. scheme cloud fractions. This is intended as a stand-alone for +!.. cloud fraction and is relatively good at getting widespread stratus +!.. and stratoCu without caring whether any deep/shallow Cu param schemes +!.. is making sub-grid-spacing clouds/precip. Under the hood, this +!.. scheme follows Mocko and Cotton (1995) in applicaiton of the +!.. Sundqvist et al (1989) scheme but using a grid-scale dependent +!.. RH threshold, one each for land v. ocean points based on +!.. experiences with HWRF testing. +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ + + SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & + & p, t, XLAND, gridkm, & + & modify_qvapor, max_relh, & + & kts,kte) + ! + USE module_mp_thompson , ONLY : rsif, rslf + IMPLICIT NONE + ! + INTEGER, INTENT(IN):: kts, kte + LOGICAL, INTENT(IN):: modify_qvapor + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qv, qc, qi, cldfra + REAL, DIMENSION(kts:kte), INTENT(IN):: p, t, dz, qs + REAL, INTENT(IN):: gridkm, XLAND, max_relh + + !..Local vars. + REAL:: RH_00L, RH_00O, RH_00 + REAL:: entrmnt=0.5 + INTEGER:: k + REAL:: TC, qvsi, qvsw, RHUM, delz + REAL, DIMENSION(kts:kte):: qvs, rh, rhoa + + !+---+ + + !..Initialize cloud fraction, compute RH, and rho-air. + + DO k = kts,kte + CLDFRA(K) = 0.0 + qvsw = rslf(P(k), t(k)) + qvsi = rsif(P(k), t(k)) + + tc = t(k) - 273.15 + if (tc .ge. -12.0) then + qvs(k) = qvsw + elseif (tc .lt. -35.0) then + qvs(k) = qvsi + else + qvs(k) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+35.) + endif + + rh(k) = MAX(0.01, qv(k)/qvs(k)) + rhoa(k) = p(k)/(287.0*t(k)) + ENDDO + + + !..First cut scale-aware. Higher resolution should require closer to + !.. saturated grid box for higher cloud fraction. Simple functions + !.. chosen based on Mocko and Cotton (1995) starting point and desire + !.. to get near 100% RH as grid spacing moves toward 1.0km, but higher + !.. RH over ocean required as compared to over land. + + DO k = kts,kte + + delz = MAX(100., dz(k)) + RH_00L = 0.65 + SQRT(1./(25.0+gridkm*gridkm*delz*0.01)) + RH_00O = 0.81 + SQRT(1./(50.0+gridkm*gridkm*delz*0.01)) + RHUM = rh(k) + + if (qc(k).gt.1.E-7 .or. qi(k).ge.1.E-7 & + & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then + CLDFRA(K) = 1.0 + qvs(k) = qv(k) + else + + IF ((XLAND-1.5).GT.0.) THEN !--- Ocean + RH_00 = RH_00O + ELSE !--- Land + RH_00 = RH_00L + ENDIF + + tc = t(k) - 273.15 + if (tc .lt. -12.0) RH_00 = RH_00L + + if (tc .ge. 20.0) then + CLDFRA(K) = 0.0 + elseif (tc .ge. -12.0) then + RHUM = MIN(rh(k), 1.0) + CLDFRA(K) = MAX(0., 1.0-SQRT((1.005-RHUM)/(1.005-RH_00))) + else + if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then + !..For HRRR model, the following look OK. + RHUM = MIN(rh(k), 1.45) + RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+100.) + if (RH_00 .ge. 1.5) then + WRITE (*,*) ' FATAL: RH_00 too large (1.5): ', RH_00, RH_00L, tc + endif + RH_00 = min(RH_00, 1.45) + CLDFRA(K) = MAX(0., 1.0-SQRT((1.5-RHUM)/(1.5-RH_00))) + else + !..but for the GFS model, RH is way lower. + RHUM = MIN(rh(k), 1.05) + RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+100.) + if (RH_00 .ge. 1.05) then + WRITE (*,*) ' FATAL: RH_00 too large (1.05): ', RH_00, RH_00L, tc + endif + CLDFRA(K) = MAX(0., 1.0-SQRT((1.05-RHUM)/(1.05-RH_00))) + endif + endif + if (CLDFRA(K).gt.0.) CLDFRA(K) = MAX(0.01, MIN(CLDFRA(K),0.9)) + endif + ENDDO + + call find_cloudLayers(qvs, cldfra, T, P, Dz, entrmnt, & + & qc, qi, qs, kts,kte) + + !..Do a final total column adjustment since we may have added more than 1mm + !.. LWP/IWP for multiple cloud decks. + + call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte) + if (modify_qvapor) then + DO k = kts,kte + if (cldfra(k).gt.0.20 .and. cldfra(k).lt.1.0) then + qv(k) = qvs(k) + endif + ENDDO + endif + + END SUBROUTINE cal_cldfra3 + +!+---+-----------------------------------------------------------------+ +!..From cloud fraction array, find clouds of multi-level depth and compute +!.. a reasonable value of LWP or IWP that might be contained in that depth, +!.. unless existing LWC/IWC is already there. + + SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& + & qc1d, qi1d, qs1d, kts,kte) + ! + IMPLICIT NONE + ! + INTEGER, INTENT(IN):: kts, kte + REAL, INTENT(IN):: entrmnt + REAL, DIMENSION(kts:kte), INTENT(IN):: qs1d,qvs1d,T1d,P1d,Dz1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d, qc1d, qi1d + + !..Local vars. + REAL, DIMENSION(kts:kte):: theta + REAL:: theta1, theta2, delz + INTEGER:: k, k2, k_tropo, k_m12C, k_cldb, k_cldt, kbot + LOGICAL:: in_cloud + + !+---+ + + k_m12C = 0 + DO k = kte, kts, -1 + theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.)) + if (T1d(k)-273.16 .gt. -12.0 .and. P1d(k).gt.10100.0) k_m12C = MAX(k_m12C, k) + ENDDO + if (k_m12C .le. kts) k_m12C = kts + + ! if (k_m12C.gt.kte-3) then + ! WRITE (*,*) 'DEBUG-GT: WARNING, no possible way neg12C can occur this high up: ', k_m12C + ! do k = kte, kts, -1 + ! WRITE (*,*) 'DEBUG-GT, k, P, T : ', k,P1d(k)*0.01,T1d(k)-273.15 + ! enddo + ! write(*,*) ('FATAL ERROR, problem in temperature profile.') + ! endif + + !..Find tropopause height, best surrogate, because we would not really + !.. wish to put fake clouds into the stratosphere. The 10/1500 ratio + !.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart + !.. near typical (mid-latitude) tropopause height. Since messy data + !.. could give us a false signal of such a transition, do the check over + !.. three K-level change, not just a level-to-level check. This method + !.. has potential failure in arctic-like conditions with extremely low + !.. tropopause height, as would any other diagnostic, so ensure resulting + !.. k_tropo level is above 700hPa. + + DO k = kte-3, kts, -1 + theta1 = theta(k) + theta2 = theta(k+2) + delz = dz1d(k) + dz1d(k+1) + dz1d(k+2) + if ( ((((theta2-theta1)/delz) .lt. 10./1500. ) .AND. & + & (P1d(k).gt.8500.)) .or. (P1d(k).gt.70000.) ) then + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, MIN(k+2, kte-1)) + + !if (k_tropo.gt.kte-2) then + ! WRITE (*,*) 'DEBUG-GT: CAUTION, tropopause appears to be very high up: ', k_tropo + ! do k = kte, kts, -1 + ! WRITE (*,*) 'DEBUG-GT, P, T : ', k,P1d(k)*0.01,T1d(k)-273.16 + ! enddo + !endif + + !..Eliminate possible fractional clouds above supposed tropopause. + DO k = k_tropo+1, kte + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) then + cfr1d(k) = 0. + endif + ENDDO + + !..We would like to prevent fractional clouds below LCL in idealized + !.. situation with deep well-mixed convective PBL, that otherwise is + !.. likely to get clouds in more realistic capping inversion layer. + + kbot = kts+2 + DO k = kbot, k_m12C + if ( (theta(k)-theta(k-1)) .gt. 0.025E-3*Dz1d(k)) EXIT + ENDDO + kbot = MAX(kts+1, k-2) + DO k = kts, kbot + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.1.0) cfr1d(k) = 0. + ENDDO + + !..Starting below tropo height, if cloud fraction greater than 1 percent, + !.. compute an approximate total layer depth of cloud, determine a total + !.. liquid water/ice path (LWP/IWP), then reduce that amount with tuning + !.. parameter to represent entrainment factor, then divide up LWP/IWP + !.. into delta-Z weighted amounts for individual levels per cloud layer. + + k_cldb = k_tropo + in_cloud = .false. + k = k_tropo + DO WHILE (.not. in_cloud .AND. k.gt.k_m12C+1) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif + if (in_cloud) then + DO k2 = k_cldt-1, k_m12C, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.k_m12C) then + k_cldb = k2+1 + goto 87 + endif + ENDDO + 87 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then + call adjust_cloudIce(cfr1d, qi1d, qs1d, qvs1d, T1d, Dz1d, & + & entrmnt, k_cldb,k_cldt,kts,kte) + k = k_cldb + elseif ((k_cldt - k_cldb + 1) .eq. 1) then + if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) & + & qi1d(k_cldb)=0.05*qvs1d(k_cldb) + k = k_cldb + endif + k = k - 1 + ENDDO + + + k_cldb = k_m12C + 3 + in_cloud = .false. + k = min(size(cfr1d), k_m12C + 2) + DO WHILE (.not. in_cloud .AND. k.gt.kbot) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif + if (in_cloud) then + DO k2 = k_cldt-1, kbot, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.kbot) then + k_cldb = k2+1 + goto 88 + endif + ENDDO + 88 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then + call adjust_cloudH2O(cfr1d, qc1d, qvs1d, T1d, Dz1d, & + & entrmnt, k_cldb,k_cldt,kts,kte) + k = k_cldb + elseif ((k_cldt - k_cldb + 1) .eq. 1) then + if (cfr1d(k_cldb).gt.0.and.cfr1d(k_cldb).lt.1.) & + & qc1d(k_cldb)=0.05*qvs1d(k_cldb) + k = k_cldb + endif + k = k - 1 + ENDDO + + END SUBROUTINE find_cloudLayers + +!+---+-----------------------------------------------------------------+ + + SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) + ! + IMPLICIT NONE + ! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, INTENT(IN):: entr + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qs, qvs, T, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi + REAL:: iwc, max_iwc, tdz, this_iwc, this_dz + INTEGER:: k + + tdz = 0. + do k = k1, k2 + tdz = tdz + dz(k) + enddo + max_iwc = ABS(qvs(k2)-qvs(k1)) + + do k = k1, k2 + max_iwc = MAX(1.E-6, max_iwc - (qi(k)+qs(k))) + enddo + max_iwc = MIN(1.E-3, max_iwc) + + this_dz = 0.0 + do k = k1, k2 + if (k.eq.k1) then + this_dz = this_dz + 0.5*dz(k) + else + this_dz = this_dz + dz(k) + endif + this_iwc = max_iwc*this_dz/tdz + iwc = MAX(1.E-6, this_iwc*(1.-entr)) + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then + qi(k) = qi(k) + cfr(k)*cfr(k)*iwc + endif + enddo + + END SUBROUTINE adjust_cloudIce + + !+---+----------------------------------------------------------------- + + SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) + ! + IMPLICIT NONE + ! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, INTENT(IN):: entr + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc + REAL:: lwc, max_lwc, tdz, this_lwc, this_dz + INTEGER:: k + + tdz = 0. + do k = k1, k2 + tdz = tdz + dz(k) + enddo + max_lwc = ABS(qvs(k2)-qvs(k1)) + + do k = k1, k2 + max_lwc = MAX(1.E-6, max_lwc - qc(k)) + enddo + max_lwc = MIN(1.E-3, max_lwc) + this_dz = 0.0 + do k = k1, k2 + if (k.eq.k1) then + this_dz = this_dz + 0.5*dz(k) + else + this_dz = this_dz + dz(k) + endif + this_lwc = max_lwc*this_dz/tdz + lwc = MAX(1.E-6, this_lwc*(1.-entr)) + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then + qc(k) = qc(k) + cfr(k)*cfr(k)*lwc + endif + enddo + + END SUBROUTINE adjust_cloudH2O + + !+---+-----------------------------------------------------------------+ + + !..Do not alter any grid-explicitly resolved hydrometeors, rather only + !.. the supposed amounts due to the cloud fraction scheme. + + SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) + + IMPLICIT NONE + ! + INTEGER, INTENT(IN):: kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, Rho, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc, qi + REAL:: lwp, iwp, xfac + INTEGER:: k + + lwp = 0. + iwp = 0. + do k = kts, kte + if (cfr(k).gt.0.0) then + lwp = lwp + qc(k)*Rho(k)*dz(k) + iwp = iwp + qi(k)*Rho(k)*dz(k) + endif + enddo + + if (lwp .gt. 1.5) then + xfac = 1.5/lwp + do k = kts, kte + if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then + qc(k) = qc(k)*xfac + endif + enddo + endif + + if (iwp .gt. 1.5) then + xfac = 1.5/iwp + do k = kts, kte + if (cfr(k).gt.0.0 .and. cfr(k).lt.1.0) then + qi(k) = qi(k)*xfac + endif + enddo + endif + + END SUBROUTINE adjust_cloudFinal + + !+---+-----------------------------------------------------------------+ + ! + ! Calculate the (Bulk?) Richardson number (for use in pbl_driver, lsm_driver) + ! + + subroutine calc_Richardson_nr(Ri,airt_3d, tskin, z_atm, wind_2d) + IMPLICIT NONE + REAL, DIMENSION(:,:), INTENT(OUT):: Ri + REAL, DIMENSION(:,:,:), INTENT(IN):: airt_3d + REAL, DIMENSION(:,:), INTENT(IN):: tskin, wind_2d, z_atm + ! ! Richardson number (from lsm driver) + ! where(wind_2d==0) wind_2d=1e-5 + Ri = gravity/airt_3d(:,1,:) * (airt_3d(:,1,:)-tskin)*z_atm/(wind_2d**2) + end subroutine calc_Richardson_nr + + end module mod_atm_utilities diff --git a/src/utilities/debug_utils.f90 b/src/utilities/debug_utils.f90 index 7cb2697f..abcb87a3 100644 --- a/src/utilities/debug_utils.f90 +++ b/src/utilities/debug_utils.f90 @@ -1,6 +1,7 @@ module debug_module use domain_interface, only : domain_t use string, only : str + use ieee_arithmetic implicit none contains @@ -29,15 +30,26 @@ subroutine domain_check(domain, error_msg, fix) call check_var(domain%graupel_number%data_3d, name="ngrau", msg=error_msg, less_than =-1e-1, fix=fix_data) call check_var(domain%w%data_3d, name="w", msg=error_msg, less_than =-1e5, fix=fix_data) call check_var(domain%w%data_3d, name="w", msg=error_msg, greater_than =1e5, fix=fix_data) + call check_var2d(domain%sensible_heat%data_2d, name="hfx", msg=error_msg) ! check for NaN's only. + call check_var2d(domain%latent_heat%data_2d, name="lfx", msg=error_msg) + call check_var2d(domain%skin_temperature%data_2d, name="tskin", msg=error_msg) + call check_var2d(domain%roughness_z0%data_2d, name="z0", msg=error_msg) + call check_var2d(domain%surface_pressure%data_2d, name="psfc", msg=error_msg) + ! call check_var2d(domain%ustar, name="ustar", msg=error_msg) + call check_var(domain%exner%data_3d, name="pii", msg=error_msg) + call check_var(domain%pressure_interface%data_3d, name="pi", msg=error_msg) + call check_var(domain%pressure%data_3d, name="p", msg=error_msg) end subroutine domain_check + subroutine check_var(var, name, msg, greater_than, less_than, fix) implicit none real, intent(inout), dimension(:,:,:), pointer :: var character(len=*), intent(in) :: name, msg real, intent(in), optional :: greater_than, less_than logical, intent(in), optional :: fix + integer :: n real :: vmax, vmin logical :: printed @@ -47,6 +59,14 @@ subroutine check_var(var, name, msg, greater_than, less_than, fix) return endif + if (any(ieee_is_nan(var))) then + n = COUNT(ieee_is_nan(var)) + ! ALLOCATE(IsNanIdx(n)) + ! IsNanIdx = PACK( (/(i,i=1,SIZE(var))/), MASK=IsNan(var) ) ! if someone can get this to work it would be nice to have. + write(*,*) trim(msg) + write(*,*) trim(name)//" has", n," NaN(s) " + endif + if (present(greater_than)) then vmax = maxval(var) if (vmax > greater_than) then @@ -107,6 +127,31 @@ subroutine check_var(var, name, msg, greater_than, less_than, fix) end subroutine check_var + subroutine check_var2d(var, name, msg, greater_than, less_than, fix) + implicit none + real, intent(inout), dimension(:,:), pointer :: var + character(len=*), intent(in) :: name, msg + real, intent(in), optional :: greater_than, less_than + logical, intent(in), optional :: fix + integer :: n + real :: vmax, vmin + logical :: printed + + printed = .False. + + if (.not.associated(var)) then + return + endif + + if (any(ieee_is_nan(var))) then + n = COUNT(ieee_is_nan(var)) + ! ALLOCATE(IsNanIdx(n)) + ! IsNanIdx = PACK( (/(i,i=1,SIZE(var))/), MASK=IsNan(var) ) ! if someone can get this to work it would be nice to have. + write(*,*) trim(msg) + write(*,*) trim(name)//" has", n," NaN(s) " + endif + end subroutine check_var2d + ! subroutine domain_fix(domain) ! implicit none ! type(domain_t), intent(inout) :: domain diff --git a/src/utilities/geo_reader.f90 b/src/utilities/geo_reader.f90 index 725e26aa..89f93b89 100644 --- a/src/utilities/geo_reader.f90 +++ b/src/utilities/geo_reader.f90 @@ -1204,7 +1204,7 @@ subroutine geo_interp2d(fieldout, fieldin, geolut) !! ---------------------------------------------------------------------------- subroutine standardize_coordinates(domain, longitude_system) implicit none - class(interpolable_type), intent(inout) :: domain + type(interpolable_type), intent(inout) :: domain integer, intent(in), optional :: longitude_system real, dimension(:,:), allocatable :: temporary_geo_data diff --git a/src/utilities/pbl_utilities.f90 b/src/utilities/pbl_utilities.f90 new file mode 100644 index 00000000..4d06862e --- /dev/null +++ b/src/utilities/pbl_utilities.f90 @@ -0,0 +1,823 @@ +! ------------------------------------------------------------------------------ +! copied from WRF/var/da/da_physics/da_sfc_wtq.inc to support the YSU pbl scheme. +! Specifically the calculation of psim, psih, which are made output vars here. +! +! Bert Kruyt 2022 +! +! ------------------------------------------------------------------------------ +module mod_pbl_utilities + use icar_constants, only : pi, gravity, Rd, Rw, cp, LH_vaporization,SVPT0 + ! use data_structures + ! use domain_interface, only : domain_t + ! use options_interface, only : options_t + + implicit none + +contains + +subroutine da_tp_to_qs( t, p, es, qs) + + !--------------------------------------------------------------------------- + ! Purpose: Convert T/p to saturation specific humidity. + ! + ! Method: qs = es_alpha * es / ( p - ( 1 - rd_over_rv ) * es ). + ! use Rogers & Yau (1989) formula: es = a exp( bTc / (T_c + c) ) + !-------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: t, p + real, intent(out) :: es, qs + + real :: t_c ! T in degreesC. + real, parameter :: es_alpha = 611.2 ! (= SVP1*1000) + real, parameter :: es_beta = 17.67 ! (= SVP2 = 17.67 ) + real, parameter :: es_gamma = 243.5 + real, parameter :: rd_over_rv = Rd / Rw! gas_constant / gas_constant_v + real, parameter :: rd_over_rv1 = 1.0 - rd_over_rv + real, parameter :: t_kelvin =SVPT0 + ! if (trace_use_dull) call da_trace_entry("da_tp_to_qs") + + !--------------------------------------------------------------------------- + ! [1.0] initialise: + !--------------------------------------------------------------------------- + ! write(*,*) "t_kelvin",t_kelvin + ! write(*,*) "t ",t + t_c = t - t_kelvin + + !--------------------------------------------------------------------------- + ! [2.0] Calculate saturation vapour pressure: + !--------------------------------------------------------------------------- + + es = es_alpha * exp( es_beta * t_c / ( t_c + es_gamma ) ) + + !--------------------------------------------------------------------------- + ! [3.0] Calculate saturation specific humidity: + !--------------------------------------------------------------------------- + + qs = rd_over_rv * es / ( p - rd_over_rv1 * es ) + + ! if (trace_use_dull) call da_trace_exit("da_tp_to_qs") + + end subroutine da_tp_to_qs + + + + + + +subroutine da_sfc_wtq (psfc, tg, ps, ts, qs, us, vs, & + hs, roughness, xland, dx, u10, v10, t2, q2, regime, psim, psih, & + has_lsm, regime_wrf, qsfc_wrf, znt_wrf, ust_wrf, mol_wrf, hfx, qfx, pblh, ims, ime, jms, jme) + + !--------------------------------------------------------------------------- + ! Purpose: Calculate the 10m wind, 2m temperature and moisture based on the + ! similarity theory/ + ! + ! The unit for pressure : psfc, ps is Pa. + ! The unit for temperature: tg, ts, t2 is K. + ! The unit for moisture : qs, q2 is kg/kg. + ! The unit for wind : us, vs, u10, v10 is m/s. + ! The unit for height : hs, roughness is m. + ! xland and regime are dimensionless. (BK: unitless?) + ! + ! History: Nov 2010 - improve calculation consistency with WRF model (Eric Chiang) + ! Jul 2015 - further improvement on consistency + ! + ! Reference: + ! --------- + ! + ! input Variables: + ! + ! psfc, tg : surface pressure and ground temperature + ! ps, ts, qs, us, vs, hs : model variable at lowlest half sigma level + ! dx (m) : horizontal resolution + ! + ! + ! Constants: + ! + ! hs : height at the lowest half sigma level + ! roughness : roughness + ! xland : land-water-mask (=2 water, =1 land) + ! + ! output Variables: + ! + ! regime : PBL regime + ! u10, v10 : 10-m high observed wind components + ! t2 , q2 : 2-m high observed temperature and mixing ratio + ! + !--------------------------------------------------------------------------- + ! (BK 2022 made psim and psih outputs.) + ! psim : mechanical psi at lowlest sigma level + ! psim2 : mechanical psi at 2m + ! psimz : mechanical psi at 10m + ! + !--------------------------------------------------------------------------- + + implicit none + + real, dimension( ims:ime, jms:jme ), intent (in) :: ps , ts , qs , us, vs + real, dimension( ims:ime, jms:jme ), intent (in) :: psfc, tg + real, dimension( ims:ime, jms:jme ), intent (in) :: hs, roughness , xland + ! integer, dimension(:,:), intent(in) :: xland + real, dimension( ims:ime, jms:jme ), intent (out) :: regime + real, dimension( ims:ime, jms:jme ), intent (out) :: psim, psih + real, dimension( ims:ime, jms:jme ), intent (out) :: u10, v10, t2, q2 + logical, intent(in), optional :: has_lsm + real, intent(in), optional :: regime_wrf, qsfc_wrf, znt_wrf, mol_wrf + real, intent(in), optional :: pblh + real, dimension( ims:ime, jms:jme ), intent(in), optional :: hfx, qfx, ust_wrf + integer, intent(in) :: ims, ime, jms, jme + + ! logical :: use_table = .true. + logical :: use_ust_wrf = .false. + logical :: vconv_wrf + integer :: nn, nz, n2, i, j + real :: rr, rz, r2 + real :: cqs2, chs2, rho, rhox, fluxc, visc, restar, z0t, z0q + + ! h10 is the height of 10m where the wind observed + ! h2 is the height of 2m where the temperature and + ! moisture observed. + + real, parameter :: h10 = 10.0, h2 = 2.0 + + ! Default roughness over the land + + real, parameter :: zint0 = 0.01 + + ! Von Karman constant + + real, parameter :: k_kar = 0.4 + + ! Working variables + + real :: Vc2, Va2, V2, vc, wspd + real :: rib, rcp, xx, yy, cc + real :: psiw, psiz, mol, ust, hol, holz, hol2 + real :: psimz, psim2, psihz, psih2 !psim, psih, ! BK 2022 now output vars for YSU + real :: psit, psit2, psiq, psiq2 + real :: gzsoz0, gz10oz0, gz2oz0 + real :: eg, qg, tvg, tvs, tvs2 + real :: ths, thg, thvs, thvg, thvs2, vsgd, vsgd2, dx + real :: zq0, z0, gas_constant + + real, parameter :: ka = 2.4E-5 + + ! if (trace_use_dull) call da_trace_entry("da_sfc_wtq") + gas_constant=Rd + rcp = gas_constant/cp + + + do j=jms,jme ! BK added these loops to make 2d + do i=ims,ime + + ! 1 Compute the roughness length based upon season and land use + + ! 1.1 Define the roughness length + + z0 = roughness(i,j) + + if (z0 < 0.0001) z0 = 0.0001 + + if ( present(znt_wrf) ) then + if ( znt_wrf > 0.0 ) then + z0 = znt_wrf + end if + end if + + ! 1.2 Define the rouhgness length for moisture + + if (xland(i,j) .ge. 1.5) then + zq0 = z0 + else + zq0 = zint0 + end if + + ! 1.3 Define the some constant variable for psi + + gzsoz0 = log(hs(i,j)/z0) + + gz10oz0 = log(h10/z0) + + gz2oz0 = log(h2/z0) + + + ! 2. Calculate the virtual temperature + + ! 2.1 Compute Virtual temperature on the lowest half sigma level + + tvs = ts(i,j) * (1.0 + 0.608 * qs(i,j)) + + ! 2.2 Convert ground virtual temperature assuming it's saturated + ! write(*,*)"tg(i,j)", tg(i,j) + + call da_tp_to_qs(tg(i,j), psfc(i,j), eg, qg) !output qg is specific humidity + qg = qg*(1.0-qg) !hcl convert to mixing ratio + if ( present(qsfc_wrf) ) then + if ( qsfc_wrf > 0.0 ) then + qg = qsfc_wrf + end if + endif + + tvg = tg(i,j) * (1.0 + 0.608 * qg) + + ! 3. Compute the potential temperature + + ! 3.1 Potential temperature on the lowest half sigma level + + ths = ts(i,j) * (1000.0 / (ps(i,j)/100.0)) ** rcp + + ! 3.2 Potential temperature at the ground + + thg = tg(i,j) * (1000.0 / (psfc(i,j)/100.0)) ** rcp + + ! 4. Virtual potential temperature + + ! 4.1 Virtual potential temperature on the lowest half sigma level + + thvs = tvs * (1000.0 / (ps(i,j)/100.0)) ** rcp + + ! 4.2 Virtual potential temperature at ground + + thvg = tvg * (1000.0 / (psfc(i,j)/100.0)) ** rcp + + + ! 5. BULK RICHARDSON NUMBER AND MONI-OBUKOV LENGTH + + ! 5.1 Velocity + + ! Wind speed: + + Va2 = us(i,j)*us(i,j) + vs(i,j)*vs(i,j) + ! + ! Convective velocity: + + vconv_wrf = .false. + if ( present(hfx) .and. present(qfx) .and. present(pblh) ) then + ! calculating vconv over land following wrf method + if ( pblh > 0.0 ) then + vconv_wrf = .true. + end if + end if + + if (thvg >= thvs) then + ! prior to V3.7, Vc2 = 4.0 * (thvg - thvs) + Vc2 = thvg - thvs + else + Vc2 = 0.0 + end if + if ( xland(i,j) < 1.5 ) then !land + if ( vconv_wrf ) then + ! following the calculation as in module_sf_sfclay.F + rhox = psfc(i,j)/(gas_constant*tvg) + fluxc = max(hfx(i,j)/rhox/cp+0.608*tvg*qfx(i,j)/rhox, 0.0) + vc = (gravity/tg(i,j)*pblh*fluxc)**0.33 + vc2 = vc*vc + end if + end if + + ! Calculate Mahrt and Sun low-res correction ! Add by Eric Chiang ( July 2010 ) + vsgd = 0.32 * (max(dx/5000.-1.,0.))**0.33 ! Add by Eric Chiang ( July 2010 ) + vsgd2 = vsgd * vsgd ! Add by Eric Chiang ( July 2010 ) + + V2 = Va2 + Vc2 + vsgd2 ! Add by Eric Chiang ( July 2010 ) + wspd = sqrt(v2) + wspd = max(wspd,0.1) + v2 = wspd*wspd + + ! 5.2 Bulk richardson number + + rib = (gravity * hs(i,j) / ths) * (thvs - thvg) / V2 + + ! if previously unstable, do not let into regime 1 and 2 + if ( present(mol_wrf) ) then + if ( mol_wrf < 0.0 ) rib = min(rib, 0.0) + end if + + ! Calculate ust, m/L (mol), h/L (hol) + + psim(i,j) = 0.0 + psih(i,j) = 0.0 + + ! Friction speed + + if ( present(ust_wrf) ) then + if ( ust_wrf(i,j) > 0.0 ) then + use_ust_wrf = .true. + ust = ust_wrf(i,j) + end if + end if + if ( .not. use_ust_wrf ) then + !ust = 0.0001 !init value as in phys/module_physics_init.F + ust = k_kar * sqrt(v2) /(gzsoz0 - psim(i,j)) + end if + + ! Heat flux factor + + if ( present(mol_wrf) ) then + mol = mol_wrf + else + mol = k_kar * (ths - thg)/(gzsoz0 - psih(i,j)) + !mol = 0.0 + end if + + ! set regimes based on rib + if (rib .GE. 0.2) then + ! Stable conditions (REGIME 1) + regime(i,j) = 1.1 + else if ((rib .LT. 0.2) .AND. (rib .GT. 0.0)) then + ! Mechanically driven turbulence (REGIME 2) + regime(i,j) = 2.1 + else if (rib .EQ. 0.0) then + ! Unstable Forced convection (REGIME 3) + regime(i,j) = 3.1 + else + ! Free convection (REGIME 4) + regime(i,j) = 4.1 + end if + + if ( present(regime_wrf) ) then + if ( regime_wrf > 0.0 ) then + regime(i,j) = regime_wrf + end if + end if + + ! 6. CALCULATE PSI BASED UPON REGIME + + !if (rib .GE. 0.2) then + if ( nint(regime(i,j)) == 1 ) then + ! 6.1 Stable conditions (regime(i,j) 1) + ! --------------------------- + regime(i,j) = 1.1 + psim(i,j) = -10.0*gzsoz0 + psim(i,j) = max(psim(i,j),-10.0) + psimz = h10/hs(i,j) * psim(i,j) + psimz = max(psimz,-10.0) + psim2 = h2 /hs(i,j) * psim(i,j) + psim2 = max(psim2,-10.0) + psih(i,j) = psim(i,j) + psihz = psimz + psih2 = psim2 + + !else if ((rib .LT. 0.2) .AND. (rib .GT. 0.0)) then + else if ( nint(regime(i,j)) == 2 ) then + + ! 6.2 Mechanically driven turbulence (regime(i,j) 2) + + regime(i,j) = 2.1 + psim(i,j) = (-5.0 * rib) * gzsoz0 / (1.1 - 5.0*rib) + psim(i,j) = max(psim(i,j),-10.0) + psimz = h10/hs(i,j) * psim(i,j) + psimz = max(psimz,-10.0) + psim2 = h2 /hs(i,j) * psim(i,j) + psim2 = max(psim2,-10.0) + psih(i,j) = psim(i,j) + psihz = psimz + psih2 = psim2 + + !else if (rib .EQ. 0.0) then + else if ( nint(regime(i,j)) == 3 ) then + ! 6.3 Unstable Forced convection (regime(i,j) 3) + + regime(i,j) = 3.1 + psim(i,j) = 0.0 + psimz = 0.0 + psim2 = 0.0 + psih(i,j) = psim(i,j) + psihz = psimz + psih2 = psim2 + + else + ! 6.4 Free convection (regime(i,j) 4) + regime(i,j) = 4.1 + + cc = 2.0 * atan(1.0) + + ! Ratio of PBL height to Monin-Obukhov length + + if (ust .LT. 0.01) then + hol = rib * gzsoz0 + else + hol = k_kar * gravity * hs(i,j) * mol / (ths * ust * ust) + end if + + ! 6.4.2 Calculate n, nz, R, Rz + + holz = (h10 / hs(i,j)) * hol + hol2 = (h2 / hs(i,j)) * hol + + hol = min(hol,0.0) + hol = max(hol,-9.9999) + + holz = min(holz,0.0) + holz = max(holz,-9.9999) + + hol2 = min(hol2,0.0) + hol2 = max(hol2,-9.9999) + + ! 6.4.3 Calculate Psim & psih(i,j) + + ! if ( use_table ) then + ! ! Using the look-up table: + ! nn = int(-100.0 * hol) + ! rr = (-100.0 * hol) - nn + ! psim = psimtb(nn) + rr * (psimtb(nn+1) - psimtb(nn)) + ! psih(i,j) = psihtb(nn) + rr * (psihtb(nn+1) - psihtb(nn)) + ! else + ! Using the continuous function: + xx = (1.0 - 16.0 * hol) ** 0.25 + yy = log((1.0+xx*xx)/2.0) + psim(i,j) = 2.0 * log((1.0+xx)/2.0) + yy - 2.0 * atan(xx) + cc + psih(i,j) = 2.0 * yy + ! end if + + ! if ( use_table ) then + ! ! Using the look-up table: + ! nz = int(-100.0 * holz) + ! rz = (-100.0 * holz) - nz + ! psimz = psimtb(nz) + rz * (psimtb(nz+1) - psimtb(nz)) + ! psihz = psihtb(nz) + rz * (psihtb(nz+1) - psihtb(nz)) + ! else + ! Using the continuous function: + xx = (1.0 - 16.0 * holz) ** 0.25 + yy = log((1.0+xx*xx)/2.0) + psimz = 2.0 * log((1.0+xx)/2.0) + yy - 2.0 * atan(xx) + cc + psihz = 2.0 * yy + ! end if + + ! if ( use_table ) then + ! ! Using the look-up table: + ! n2 = int(-100.0 * hol2) + ! r2 = (-100.0 * hol2) - n2 + ! psim2 = psimtb(n2) + r2 * (psimtb(n2+1) - psimtb(n2)) + ! psih2 = psihtb(n2) + r2 * (psihtb(n2+1) - psihtb(n2)) + ! else + ! Using the continuous function: + xx = (1.0 - 16.0 * hol2) ** 0.25 + yy = log((1.0+xx*xx)/2.0) + psim2 = 2.0 * log((1.0+xx)/2.0) + yy - 2.0 * atan(xx) + cc + psih2 = 2.0 * yy + ! end if + + ! 6.4.4 Define the limit value for psim & psih(i,j) + + psim(i,j) = min(psim(i,j),0.9*gzsoz0) + psimz = min(psimz,0.9*gz10oz0) + psim2 = min(psim2,0.9*gz2oz0) + psih(i,j) = min(psih(i,j),0.9*gzsoz0) + psihz = min(psihz,0.9*gz10oz0) + psih2 = min(psih2,0.9*gz2oz0) + end if ! regime(i,j) + + ! 7. Calculate psi for wind, temperature and moisture + + psiw = gzsoz0 - psim(i,j) + psiz = gz10oz0 - psimz + psit = max(gzsoz0-psih(i,j), 2.0) + psit2 = gz2oz0 - psih2 + + if ( .not. use_ust_wrf ) then + ! re-calculate ust since psim(i,j) is now available + ust = k_kar * sqrt(v2) /(gzsoz0 - psim(i,j)) + end if + + psiq = log(k_kar*ust*hs(i,j)/ka + hs(i,j) / zq0) - psih(i,j) + psiq2 = log(k_kar*ust*h2/ka + h2 / zq0) - psih2 + + !V3.7, as in module_sf_sfclay.F + if ( xland(i,j) >= 1.5 ) then !water + visc = (1.32+0.009*(ts(i,j)-273.15))*1.e-5 + restar = ust*z0/visc + z0t = (5.5e-5)*(restar**(-0.60)) + z0t = min(z0t,1.0e-4) + z0t = max(z0t,2.0e-9) + z0q = z0t + psiq = max(log((hs(i,j)+z0q)/z0q)-psih(i,j), 2.) + psit = max(log((hs(i,j)+z0t)/z0t)-psih(i,j), 2.) + psiq2 = max(log((2.+z0q)/z0q)-psih2, 2.) + psit2 = max(log((2.+z0t)/z0t)-psih2, 2.) + end if + + ! 8. Calculate 10m wind, 2m temperature and moisture + + u10(i,j) = us(i,j) * psiz / psiw + v10(i,j) = vs(i,j) * psiz / psiw + t2(i,j) = (thg + (ths - thg)*psit2/psit)*((psfc(i,j)/100.0)/1000.0)**rcp + q2(i,j) = qg + (qs(i,j) - qg)*psiq2/psiq + + if ( present(has_lsm) ) then + if ( has_lsm ) then + !cqs2: 2m surface exchange coefficient for moisture + !chs2: 2m surface exchange coefficient for heat + cqs2 = ust*k_kar/psiq2 + if (xland(i,j) .ge. 1.5) then + !water + chs2 = ust*k_kar/psit2 + else + !land + chs2 = cqs2 !as in subroutine lsm in phys/module_sf_noahdrv.F + end if + + !re-calculate T2/Q2 as in module_sf_sfcdiags.F + rho = psfc(i,j)/(gas_constant*tg(i,j)) + if ( cqs2 < 1.e-5 ) then + q2(i,j) = qg + else + if ( present(qfx) ) then + q2(i,j) = qg - qfx(i,j)/(rho*cqs2) + end if + end if + if ( chs2 < 1.e-5 ) then + t2(i,j) = tg(i,j) + else + if ( present(hfx) ) then + t2(i,j) = tg(i,j) - hfx(i,j)/(rho*cp*chs2) + end if + end if + end if + end if + + ! if (trace_use_dull) call da_trace_exit("da_sfc_wtq") + enddo + enddo + end subroutine da_sfc_wtq + + + ! !-------------------------------------------------------- + ! ! + ! ! from old ICAR model (v1) - currently notused + ! ! + ! !-------------------------------------------------------- + + ! subroutine calc_surface_stuff + ! ! ----- start surface layer calculations usually done by surface layer scheme ----- ! + ! write(*,*) "start surface layer calculations" + ! if (options%physics%boundarylayer==kPBL_SIMPLE) then + ! write(*,*) "calculate surface layer based on log wind profile" + ! ! ! temporary constant + ! ! ! use log-law of the wall to convert from first model level to surface + ! ! currw = karman / log((domain%z(2:nx-1,1,2:ny-1)-domain%terrain(2:nx-1,2:ny-1)) & + ! ! / domain%znt(2:nx-1,2:ny-1)) + ! ! ! use log-law of the wall to convert from surface to 10m height + ! ! lastw = log(10.0 / domain%znt(2:nx-1,2:ny-1)) / karman + ! ! domain%ustar(2:nx-1,2:ny-1) = domain%Um(2:nx-1,1,2:ny-1) * currw + ! ! domain%u10(2:nx-1,2:ny-1) = domain%ustar(2:nx-1,2:ny-1) * lastw + ! ! domain%ustar(2:nx-1,2:ny-1) = domain%Vm(2:nx-1,1,2:ny-1) * currw + ! ! domain%v10(2:nx-1,2:ny-1) = domain%ustar(2:nx-1,2:ny-1) * lastw + + ! ! ! now calculate master ustar based on U and V combined in quadrature + ! ! domain%ustar(2:nx-1,2:ny-1) = sqrt(domain%Um(2:nx-1,1,2:ny-1)**2 & + ! ! + domain%Vm(2:nx-1,1,2:ny-1)**2) * currw + ! ! ! counter is just a variable helping me to detect how much rounds + ! ! ! this subroutine went through + ! ! write(*,*) "Counter: ", counter + ! ! counter = counter + 1 + ! ! write(*,*) "Counter: ", counter + ! elseif (options%physics%boundarylayer==kPBL_YSU) then + ! ! start surface layer calculations introduced by Patrik Bohlinger + ! write(*,*) "calculate surface layer based on monin-obukhov similarity theory" + + ! ! ----- start temporary solution ----- ! + ! ! use log-law of the wall to convert from first model level to surface + ! currw = karman / log((domain%z(2:nx-1,1,2:ny-1)-domain%terrain(2:nx-1,2:ny-1)) & + ! / domain%znt(2:nx-1,2:ny-1)) + ! ! use log-law of the wall to convert from surface to 10m height + ! lastw = log(10.0 / domain%znt(2:nx-1,2:ny-1)) / karman + ! ! calculate ustar = horizontal wind speed scale + ! if (counter==1) then + ! domain%ustar_new(2:nx-1,2:ny-1) = domain%ustar(2:nx-1,2:ny-1) + ! endif + ! ! preventing ustar from being smaller than 0.1 as it could be under + ! ! very stable conditions, Jiminez et al. 2012 + ! where(domain%ustar_new(2:nx-1,2:ny-1) < 0.1) + ! domain%ustar_new(2:nx-1,2:ny-1) = 0.1 + ! endwhere + ! !domain%ustar(2:nx-1,2:ny-1) = domain%Um(2:nx-1,1,2:ny-1) * currw + ! domain%u10(2:nx-1,2:ny-1) = domain%ustar_new(2:nx-1,2:ny-1) * lastw + ! domain%ustar(2:nx-1,2:ny-1) = domain%Vm(2:nx-1,1,2:ny-1) * currw + ! domain%v10(2:nx-1,2:ny-1) = domain%ustar_new(2:nx-1,2:ny-1) * lastw + ! !now calculate master ustar based on U and V combined in quadrature + ! domain%wspd3d(2:nx-1,1:nz,2:ny-1) = sqrt(domain%Um(2:nx-1,1:nz,2:ny-1)**2 & + ! + domain%Vm(2:nx-1,1:nz,2:ny-1)**2) + ! ! added by Patrik Bohlinger in case we need this later for YSU (some variables seem to + ! ! be 3D in articles like the YSU paper Hong et al. 2006) + ! domain%wspd(2:nx-1,2:ny-1) = sqrt(domain%Um(2:nx-1,1,2:ny-1)**2 & + ! + domain%Vm(2:nx-1,1,2:ny-1)**2) + ! ! added by Patrik Bohlinger since we need this as input for YSU + ! domain%ustar(2:nx-1,2:ny-1) = domain%wspd(2:nx-1,2:ny-1) * currw + ! ! ----- end temporary solution ----- ! + + ! ! compute z above ground used for estimating indices for + ! domain%z_agl(2:nx-1,2:ny-1) = (domain%z(2:nx-1,1,2:ny-1)-domain%terrain(2:nx-1,2:ny-1)) + ! !added by Patrik in case we need this later for YSU + ! ! calculate the Bulk-Richardson number Rib + ! domain%thv(2:nx-1,2:ny-1) = domain%th(2:nx-1,1,2:ny-1) & + ! *(1+0.608*domain%qv(2:nx-1,1,2:ny-1)*1000) + ! ! should domain%qv be multiplied by 1000? Did it since domain%qv is in kg/kg and not in g/kg + ! ! normally should be specific humidity and not mixing ratio domain%qv but for first order approach does not matter + ! domain%thv3d(2:nx-1,1:nz,2:ny-1) = domain%th(2:nx-1,1:nz,2:ny-1) & + ! * (1+0.608*domain%qv(2:nx-1,1:nz,2:ny-1)*1000) !thv 3D + ! domain%thvg(2:nx-1,2:ny-1) = (domain%t2m(2:nx-1,2:ny-1)/domain%pii(2:nx-1,1,2:ny-1)) & + ! *(1+0.608*domain%qv(2:nx-1,1,2:ny-1)*1000) + ! ! t2m should rather be used than skin_t + ! domain%thg(2:nx-1,2:ny-1) = domain%t2m(2:nx-1,2:ny-1)/domain%pii(2:nx-1,1,2:ny-1) + ! ! t2m should rather be used than skin_t + + ! ! variables described for YSU but probably not needed to be calculated outside of the scheme: + ! !domain%wstar(2:nx-1,2:ny-1) = domain%ustar(2:nx-1,2:ny-1) / domain%psim(2:nx-1,2:ny-1) ! wstar = vertical wind speed scale + ! !domain%thT(2:nx-1,2:ny-1) = propfact * (virtual heat flux)/ domain%wstar ! virtual temperature excess + ! !domain%thvg(2:nx-1,2:ny-1) = domain%thv(2:nx-1,2:ny-1) ! for init thvg=thv since thT = 0, + ! !t2m should rather be used than skin_t, b=proportionality factor=7.8, Hong et al, 2006 + + ! ! find value of pbl heights for wspd3d + ! !domain%PBLh(2:nx-1,2:ny-1) = Rib_cr * domain%thv(2:nx-1,2:ny-1) * domain%wspd(2:nx-1,2:ny-1)**2 & + ! ! / gravity * (domain%thv(2:nx-1,2:ny-1) - domain%thvg(2:nx-1,2:ny-1)) !U^2 and thv are from height PBLh in equation + + ! !write(*,*) "max min domain%pbl_height: ", maxval(domain%pbl_height), minval(domain%pbl_height) + ! !write(*,*) "max min domain%PBLh: ", maxval(domain%PBLh), minval(domain%PBLh) ! introduced the + ! !PBLh variabel to not overwrite pbl_height and compare new with old calculations as the pbl + ! !height is one of the most crucial factors of the non-local surface layer calculations needed by the YSU-scheme + + ! ! Constraint to prevent Rib from becoming too high a lower limit of 0.1 is + ! ! applied in for the original surface layer formulation Jiminez et al 2012 + ! where(domain%wspd(2:nx-1,2:ny-1) < 0.1) + ! domain%wspd(2:nx-1,2:ny-1) = 0.1 + ! endwhere + + ! domain%Rib(2:nx-1,2:ny-1) = gravity/domain%th(2:nx-1,1,2:ny-1) * domain%z_agl(2:nx-1,2:ny-1) & + ! * (domain%thv(2:nx-1,2:ny-1) - domain%thvg(2:nx-1,2:ny-1)) & + ! / domain%wspd(2:nx-1,2:ny-1)**2 + ! ! From Jiminez et al. 2012, from what height should the theta variables really be, Rib is a function of height? To my understanding the appropriate height is the lower most level. + + ! ! calculate the integrated similarity functions + ! where(domain%Rib(2:nx-1,2:ny-1) >= 0.2) + ! !regime = 1, very stable night time conditions + ! domain%psim(2:nx-1,2:ny-1) = -10*log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) + ! domain%psim10(2:nx-1,2:ny-1) = -10*log(10/domain%znt(2:nx-1,2:ny-1)) + ! domain%psim2m(2:nx-1,2:ny-1) = -10*log(2/domain%znt(2:nx-1,2:ny-1)) + ! domain%psih(2:nx-1,2:ny-1) = domain%psim(2:nx-1,2:ny-1) + ! domain%psih2m(2:nx-1,2:ny-1) = domain%psim2m(2:nx-1,2:ny-1) + ! !impose constraints + ! where (domain%Rib(2:nx-1,2:ny-1) >= 0.2 .and. domain%psim(2:nx-1,2:ny-1) < -10.) + ! domain%psim(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) >= 0.2 .and. domain%psih(2:nx-1,2:ny-1) < -10.) + ! domain%psih(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) >= 0.2 .and. domain%psim10(2:nx-1,2:ny-1) < -10.) + ! domain%psim10(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) >= 0.2 .and. domain%psih2m(2:nx-1,2:ny-1) < -10.) + ! domain%psih2m(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) >= 0.2 .and. domain%psim2m(2:nx-1,2:ny-1) < -10.) + ! domain%psim2m(2:nx-1,2:ny-1) = -10. + ! endwhere + ! elsewhere (domain%Rib(2:nx-1,2:ny-1) < 0.2 .and. domain%Rib(2:nx-1,2:ny-1) > 0.0) + ! !regime = 2, damped mechanical turbulence + ! domain%psim(2:nx-1,2:ny-1) = -5*domain%Rib(2:nx-1,2:ny-1)*log(domain%z_agl(2:nx-1,2:ny-1) & + ! /domain%znt(2:nx-1,2:ny-1))/(1.1-5*domain%Rib(2:nx-1,2:ny-1)) + ! domain%psim10(2:nx-1,2:ny-1) = -5*domain%Rib(2:nx-1,2:ny-1)*log(10/domain%znt(2:nx-1,2:ny-1)) & + ! /(1.1-5*domain%Rib(2:nx-1,2:ny-1)) ! Should maybe compute Rib at 10m as well? + ! domain%psim2m(2:nx-1,2:ny-1) = -5*domain%Rib(2:nx-1,2:ny-1)*log(2/domain%znt(2:nx-1,2:ny-1)) & + ! /(1.1-5*domain%Rib(2:nx-1,2:ny-1)) ! Should maybe compute Rib at 2m as well? + ! domain%psih(2:nx-1,2:ny-1) = domain%psim(2:nx-1,2:ny-1) + ! domain%psih2m(2:nx-1,2:ny-1) = domain%psim2m(2:nx-1,2:ny-1) + ! !impose constraints + ! where (domain%Rib(2:nx-1,2:ny-1) < 0.2 .and. & + ! domain%Rib(2:nx-1,2:ny-1) > 0.0 .and. & + ! domain%psim(2:nx-1,2:ny-1) < -10.) + ! domain%psim(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0.2 .and. & + ! domain%Rib(2:nx-1,2:ny-1) > 0.0 .and. & + ! domain%psih(2:nx-1,2:ny-1) < -10.) + ! domain%psih(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0.2 .and. & + ! domain%Rib(2:nx-1,2:ny-1) > 0.0 .and. & + ! domain%psim10(2:nx-1,2:ny-1) < -10.) + ! domain%psim10(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0.2 .and. & + ! domain%Rib(2:nx-1,2:ny-1) > 0.0 .and. & + ! domain%psih2m(2:nx-1,2:ny-1) < -10.) + ! domain%psih2m(2:nx-1,2:ny-1) = -10. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0.2 .and. & + ! domain%Rib(2:nx-1,2:ny-1) > 0.0 .and. & + ! domain%psim2m(2:nx-1,2:ny-1) < -10.) + ! domain%psim2m(2:nx-1,2:ny-1) = -10. + ! endwhere + ! elsewhere (domain%Rib(2:nx-1,2:ny-1).eq.0.0) + ! !regime = 3, forced convection + ! domain%psim(2:nx-1,2:ny-1) = 0.0 + ! domain%psim10(2:nx-1,2:ny-1) = 0.0 + ! domain%psih(2:nx-1,2:ny-1) = 0.0 + ! domain%psih2m(2:nx-1,2:ny-1) = 0.0 + ! elsewhere (domain%Rib(2:nx-1,2:ny-1) < 0) + ! !regime = 4, free convection + ! ! constraints + ! where (domain%Rib(2:nx-1,2:ny-1) < 0. .and. domain%zol(2:nx-1,2:ny-1) < -9.9999) + ! domain%zol(2:nx-1,2:ny-1) = -9.9999 + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0. .and. domain%zol(2:nx-1,2:ny-1) > 0.) + ! domain%zol(2:nx-1,2:ny-1) = 0. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0. .and. domain%zol10(2:nx-1,2:ny-1) < -9.9999) + ! domain%zol10(2:nx-1,2:ny-1) = -9.9999 + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0. .and. domain%zol10(2:nx-1,2:ny-1) > 0.) + ! domain%zol10(2:nx-1,2:ny-1) = 0. + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0. .and. domain%zol2m(2:nx-1,2:ny-1) < -9.9999) + ! domain%zol2m(2:nx-1,2:ny-1) = -9.9999 + ! endwhere + ! where (domain%Rib(2:nx-1,2:ny-1) < 0. .and. domain%zol2m(2:nx-1,2:ny-1) > 0.) + ! domain%zol2m(2:nx-1,2:ny-1) = 0. + ! endwhere + ! domain%psix(2:nx-1,2:ny-1) = (1.-16.*(domain%zol(2:nx-1,2:ny-1)))**0.25 + ! domain%psix10(2:nx-1,2:ny-1) = (1.-16.*(domain%zol10(2:nx-1,2:ny-1)))**0.25 + ! domain%psix2m(2:nx-1,2:ny-1) = (1.-16.*(domain%zol2m(2:nx-1,2:ny-1)))**0.25 + ! domain%psim(2:nx-1,2:ny-1) = 2.*log((1.+domain%psix(2:nx-1,2:ny-1))/2.) & + ! + log((1.+domain%psix(2:nx-1,2:ny-1)**2.)/2.) & + ! - 2.*atan(domain%psix(2:nx-1,2:ny-1))+pi/2. + ! domain%psim10(2:nx-1,2:ny-1) = 2.*log((1.+domain%psix10(2:nx-1,2:ny-1))/2.) & + ! + log((1.+domain%psix10(2:nx-1,2:ny-1)**2.)/2.) & + ! - 2.*atan(domain%psix10(2:nx-1,2:ny-1))+pi/2. + ! domain%psih(2:nx-1,2:ny-1) = 2.*log((1.+domain%psix(2:nx-1,2:ny-1)**2.)/2.) + ! domain%psih2m(2:nx-1,2:ny-1) = 2.*log((1.+domain%psix2m(2:nx-1,2:ny-1)**2.)/2.) + ! endwhere + ! ! constrain psim and psih also for 2m and 10m + ! where (domain%psim(2:nx-1,2:ny-1) > 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1))) + ! domain%psim(2:nx-1,2:ny-1) = 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) + ! endwhere + ! where (domain%psim2m(2:nx-1,2:ny-1) > 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1))) + ! domain%psim2m(2:nx-1,2:ny-1) = 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) + ! endwhere + ! where (domain%psim10(2:nx-1,2:ny-1) > 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1))) + ! domain%psim10(2:nx-1,2:ny-1) = 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) + ! endwhere + ! where (domain%psih(2:nx-1,2:ny-1) > 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1))) + ! domain%psih(2:nx-1,2:ny-1) = 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) + ! endwhere + ! where (domain%psih2m(2:nx-1,2:ny-1) > 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1))) + ! domain%psih2m(2:nx-1,2:ny-1) = 0.9 * log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) + ! endwhere + + ! ! calculate thstar = temperature scale + ! domain%thstar(2:nx-1,2:ny-1) = karman*(domain%th(2:nx-1,1,2:ny-1)-domain%thg) & + ! / log(domain%z_agl(2:nx-1,2:ny-1) & + ! / domain%znt(2:nx-1,2:ny-1))-domain%psih(2:nx-1,2:ny-1) + ! ! Averaging ustar with ustar from previous time step to suppress + ! ! large oscillations + ! domain%ustar_tmp(2:nx-1,2:ny-1) = karman*domain%wspd(2:nx-1,2:ny-1)/(log(domain%z_agl(2:nx-1,2:ny-1) & + ! / domain%znt(2:nx-1,2:ny-1))-domain%psim(2:nx-1,2:ny-1)) + ! domain%ustar_new(2:nx-1,2:ny-1) = (domain%ustar_tmp(2:nx-1,2:ny-1) + domain%ustar_new(2:nx-1,2:ny-1))/2.0 + ! ! preventing ustar from being smaller than 0.1 as it could be under + ! ! very stable conditions, Jiminez et al. 2012 + ! where(domain%ustar_new(2:nx-1,2:ny-1) < 0.1) + ! domain%ustar_new(2:nx-1,2:ny-1) = 0.1 + ! endwhere + ! ! calculate the Monin-Obukhov stability parameter zol (z over l) + ! ! using ustar from the similarity theory + ! domain%zol(2:nx-1,2:ny-1) = (karman*gravity*domain%z_agl(2:nx-1,2:ny-1))/domain%th(2:nx-1,1,2:ny-1) & + ! * domain%thstar(2:nx-1,2:ny-1)/(domain%ustar_new(2:nx-1,2:ny-1) & + ! * domain%ustar_new(2:nx-1,2:ny-1)) + ! domain%zol10(2:nx-1,2:ny-1) = (karman*gravity*10)/domain%th(2:nx-1,1,2:ny-1) * domain%thstar(2:nx-1,2:ny-1) & + ! / (domain%ustar_new(2:nx-1,2:ny-1)*domain%ustar_new(2:nx-1,2:ny-1)) + ! domain%zol2m(2:nx-1,2:ny-1) = (karman*gravity*2)/domain%th(2:nx-1,1,2:ny-1) * domain%thstar(2:nx-1,2:ny-1) & + ! / (domain%ustar_new(2:nx-1,2:ny-1)*domain%ustar_new(2:nx-1,2:ny-1)) + ! ! calculate pblh over l using ustar and thstar from the similarity theory + ! domain%hol(2:nx-1,2:ny-1) = (karman*gravity*domain%PBLh(2:nx-1,2:ny-1))/domain%th(2:nx-1,1,2:ny-1) & + ! * domain%thstar(2:nx-1,2:ny-1)/(domain%ustar_new(2:nx-1,2:ny-1) & + ! * domain%ustar_new(2:nx-1,2:ny-1)) + ! ! arbitrary variables + ! domain%gz1oz0(2:nx-1,2:ny-1)=log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) + ! ! calculating dtmin + ! domain%dtmin = domain%dt / 60.0 + ! ! p_top as a scalar, choosing just minimum from ptop as a start + ! p_top = minval(domain%ptop) + ! ! compute the dimensionless bulk coefficent for momentum, heat and + ! ! moisture + ! !domain%exch_m(2:nx-1,2:ny-1) = (karman**2)/(log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) & + ! !- domain%psim(2:nx-1,2:ny-1))**2 + ! !domain%exch_h(2:nx-1,2:ny-1) = (karman**2)/((log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1))& + ! !- domain%psim(2:nx-1,2:ny-1))*(log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1))-domain%psih(2:nx-1,2:ny-1))) + ! !domain%exch_q(2:nx-1,2:ny-1) = (karman**2)/((log(domain%z_agl(2:nx-1,2:ny-1)/domain%znt(2:nx-1,2:ny-1)) & + ! !- domain%psim(2:nx-1,2:ny-1)) * (log(domain%rho(2:nx-1,1,2:ny-1)*cp*karman*domain%ustar_new(2:nx-1,2:ny-1) & + ! !*domain%z_agl(2:nx-1,2:ny-1)/cs)-psih(2:nx-1,2:ny-1))) + + ! ! counter is just a variable helping me to detect how much rounds this subroutine went through + ! write(*,*) "Counter: ", counter + ! counter = counter + 1 + ! write(*,*) "Counter: ", counter + ! ! end surface layer calculations introduced by Patrik Bohlinger + ! endif + ! write(*,*) "end surface layer calculations" + ! ! ----- end sfc layer calculations ----- ! + ! end subroutine + + +end module mod_pbl_utilities \ No newline at end of file diff --git a/src/utilities/time.f90 b/src/utilities/time.f90 deleted file mode 100644 index 055cd448..00000000 --- a/src/utilities/time.f90 +++ /dev/null @@ -1,207 +0,0 @@ -!>------------------------------------------------------------ -!! date / time module -!! -!! Contains various utilities for working with dates and times. -!! Utilities are capable of handling multiple model calendars. -!! -!! @author -!! Ethan Gutmann (gutmann@ucar.edu) -!! -!!------------------------------------------------------------ -module time - implicit none - ! define calendars - integer, parameter :: GREGORIAN=0, NOLEAP=1, THREESIXTY=2 - integer, parameter :: YEAR_ZERO=1800 ! starting year for noleap and 360day calendars - integer :: calendar - integer, dimension(13) :: month_start - private - public :: time_init, date_to_mjd, calendar_date, calc_day_of_year, parse_date, calc_year_fraction - public :: calendar - public :: GREGORIAN, NOLEAP, THREESIXTY, YEAR_ZERO -contains - - subroutine time_init(calendar_name) - implicit none - character(len=*), intent(in) :: calendar_name - integer :: i - - ! zero based month_starts (will have 1 added below) - month_start=[0,31,59,90,120,151,181,212,243,273,304,334,365] - - if (trim(calendar_name)=="gregorian") then - calendar=GREGORIAN - else if (trim(calendar_name)=="standard") then - calendar=GREGORIAN - else if (trim(calendar_name)=="365-day") then - calendar=NOLEAP - else if (trim(calendar_name)=="noleap") then - calendar=NOLEAP - else if (trim(calendar_name)=="360-day") then - calendar=THREESIXTY - else - write(*,*) "Unknown Calendar: ", trim(calendar_name) - write(*,*) "Acceptable names = " - write(*,*) " gregorian, standard, 365-day, noleap, 360-day" - write(*,*) " " - stop - endif - - if (calendar==THREESIXTY) then - do i=0,12 - month_start(i+1)=i*30 - end do - endif - do i=0,12 - month_start(i+1)=month_start(i+1)+1 - end do - - - end subroutine time_init - - ! algorithms from Wikipedia: http://en.wikipedia.org/wiki/Julian_day - ! originally from Richards, E. G. (2013). Calendars. In S. E. Urban & P. K. Seidelmann, eds. - ! Explanatory Supplement to the Astronomical Almanac, 3rd ed. (pp. 585–624). - ! Mill Valley, Calif.: University Science Books. ISBN 978-1-89138-985-6 - ! p617-9 - function date_to_mjd(year, month, day, hour, minute, second) - implicit none - integer, intent(in) :: year, month, day, hour, minute, second - double precision :: date_to_mjd - double precision :: d,m,y - integer :: a,b - - if (calendar==GREGORIAN) then - a = (14-month)/12 - y = year+4800-a - m = month+12*a-3 - ! Gregorian calendar - b = day + floor((153*m+2)/5) + 365*y + floor(y/4) - floor(y/100) + floor(y/400) - 32045 - ! Julian calendar - ! b = day + floor(153*m+2/5) + 365*y + floor(y/4) - 32083 - date_to_mjd = b + (((second/60d+0)+minute)/60d+0 + hour-12)/24.0 - 2400000.5 - else if (calendar==NOLEAP) then - date_to_mjd = (year-YEAR_ZERO)*365 + month_start(month)-1 + day-1 + (hour + (minute+second/60d+0)/60d+0)/24d+0 - else if (calendar==THREESIXTY) then - date_to_mjd = (year-YEAR_ZERO)*360 + month_start(month)-1 + day-1 + (hour + (minute+second/60d+0)/60d+0)/24d+0 - end if - - end function date_to_mjd - - ! compute the year, month, day, hour, minute, second corresponding - ! to the input modified julian day (mjd) - ! note mjd for NOLEAP and 360day calendars is not a true MJD - ! arguably, seconds should be a real number, not an integer... - subroutine calendar_date(inputmjd, year, month, day, hour, minute, second) - implicit none - double precision, intent(in) :: inputmjd - integer, intent(out) :: year, month, day, hour, minute, second - integer :: y=4716,j=1401,m=2,n=12,r=4,p=1461 - integer :: v=3,u=5,s=153,w=2,B=274277,C=-38 - integer ::f,e,g,h, jday - double precision :: day_fraction,mjd - mjd = inputmjd+1d-5 ! add less than one second - if (calendar==GREGORIAN) then - jday=nint(mjd+2400000.5) - f=jday+j+(((4*jday+B)/146097)*3)/4+C - e=r*f+v - g=mod(e,p)/r - h=u*g+w - day=mod(h,s)/u+1 - month=mod(h/s+m,n)+1 - year=e/p-y+(n+m-month)/n - else if (calendar==NOLEAP) then - year=floor(mjd/365) - day_fraction=mjd - year*365+1 - do f=1,12 - if (day_fraction>month_start(f)) then - month=f - endif - end do - day = floor(day_fraction - month_start(month))+1 - year=year+YEAR_ZERO - else if (calendar==THREESIXTY) then - year=floor(mjd/360) - day_fraction=mjd - year*360+1 - do f=1,12 - if (day_fraction>month_start(f)) then - month=f - endif - end do - day = floor(day_fraction - month_start(month))+1 - year=year+YEAR_ZERO - end if - - day_fraction=mod(mjd,1.0) - hour=floor(day_fraction*24) - - day_fraction=day_fraction*24-hour - minute=floor(day_fraction*60) - - day_fraction=day_fraction*60-minute - second = nint((day_fraction-(24d0*60*1d-5))*60) - - end subroutine - - ! calculate the day of the year from a "modified julian day" - ! note mjd for NOLEAP and 360day calendars is not a true MJD - function calc_day_of_year(mjd) - implicit none - real :: calc_day_of_year - double precision, intent(in) :: mjd - - integer :: year, month, day, hour, minute, second - - if (calendar==GREGORIAN) then - call calendar_date(mjd,year, month, day, hour, minute, second) - calc_day_of_year = mjd - date_to_mjd(year, 1,1,0,0,0) - else if (calendar==NOLEAP) then - calc_day_of_year = mod(mjd,365.0) - else if (calendar==THREESIXTY) then - calc_day_of_year = mod(mjd,360.0) - endif - end function calc_day_of_year - - - function calc_year_fraction(mjd) - implicit none - real :: calc_year_fraction - double precision, intent(in) :: mjd - double precision :: year_start - - integer :: year, month, day, hour, minute, second - - if (calendar==GREGORIAN) then - call calendar_date(mjd,year, month, day, hour, minute, second) - year_start = date_to_mjd(year, 1,1,0,0,0) - calc_year_fraction = (mjd - year_start) / (date_to_mjd(year+1, 1,1,0,0,0) - year_start) - else if (calendar==NOLEAP) then - calc_year_fraction = calc_day_of_year(mjd) / 365.0 - else if (calendar==THREESIXTY) then - calc_year_fraction = calc_day_of_year(mjd) / 360.0 - endif - end function calc_year_fraction - - ! convert an input date string in the form YYYY/MM/DD or YYYY/MM/DD hh:mm:ss - ! into integer variables - subroutine parse_date(date, year, month, day, hour, min, sec) - implicit none - character (len=*), intent(in) :: date - integer, intent(out) :: sec, min, hour, day, month, year - - read(date(9:10),*) day - read(date(6:7),*) month - read(date(1:4),*) year - if(len_trim(date) <= 11) then - sec = 0 - min = 0 - hour = 0 - else - read(date(18:19), *) sec - read(date(15:16), *) min - read(date(12:13), *) hour - endif - end subroutine parse_date - - -end module time diff --git a/src/utilities/time_delta_obj.f90 b/src/utilities/time_delta_obj.f90 index 67a6621c..b00d1747 100644 --- a/src/utilities/time_delta_obj.f90 +++ b/src/utilities/time_delta_obj.f90 @@ -12,13 +12,14 @@ !!------------------------------------------------------------ module time_delta_object use icar_constants, only : MAXSTRINGLENGTH + use iso_fortran_env, only: real64 implicit none private type, public :: time_delta_t private - double precision :: delta = 0 + real(real64) :: delta = 0 contains procedure, public :: days procedure, public :: hours @@ -40,9 +41,9 @@ module time_delta_object subroutine set_time_delta_d(self, seconds, days, hours, minutes) implicit none class(time_delta_t) :: self - double precision, intent(in) :: seconds - double precision, intent(in), optional :: days, hours, minutes - double precision :: dt + real(real64), intent(in) :: seconds + real(real64), intent(in), optional :: days, hours, minutes + real(real64) :: dt dt=0 if (present(days)) dt = dt + days @@ -60,14 +61,14 @@ subroutine set_time_delta_f(self, seconds, days, hours, minutes) class(time_delta_t) :: self real, intent(in) :: seconds real, intent(in), optional :: days, hours, minutes - double precision :: dt + real(real64) :: dt dt=0 if (present(days)) dt = dt + days - if (present(hours)) dt = dt + hours / 24.0 - if (present(minutes)) dt = dt + minutes / 1440.0 + if (present(hours)) dt = dt + hours / 24.0D0 + if (present(minutes)) dt = dt + minutes / 1440.0D0 - dt = dt + seconds / 86400.0 + dt = dt + seconds / 86400.0D0 self%delta = dt @@ -78,14 +79,14 @@ subroutine set_time_delta_i(self, seconds, days, hours, minutes) class(time_delta_t) :: self integer, intent(in) :: seconds integer, intent(in), optional :: days, hours, minutes - double precision :: dt + real(real64) :: dt dt=0 if (present(days)) dt = dt + days - if (present(hours)) dt = dt + hours / 24.0 - if (present(minutes)) dt = dt + minutes / 1440.0 + if (present(hours)) dt = dt + hours / 24.0D0 + if (present(minutes)) dt = dt + minutes / 1440.0D0 - dt = dt + seconds / 86400.0 + dt = dt + seconds / 86400.0D0 self%delta = dt @@ -95,7 +96,7 @@ end subroutine set_time_delta_i function days(self) implicit none class(time_delta_t), intent(in) :: self - double precision :: days + real(real64) :: days days = self%delta @@ -104,7 +105,7 @@ end function days function hours(self) implicit none class(time_delta_t), intent(in) :: self - double precision :: hours + real(real64) :: hours hours = self%delta * 24 @@ -113,7 +114,7 @@ end function hours function minutes(self) implicit none class(time_delta_t), intent(in) :: self - double precision :: minutes + real(real64) :: minutes minutes = self%delta * 1440 @@ -122,7 +123,7 @@ end function minutes function seconds(self) implicit none class(time_delta_t), intent(in) :: self - double precision :: seconds + real(real64) :: seconds seconds = self%delta * 86400 diff --git a/src/utilities/time_h.f90 b/src/utilities/time_h.f90 index bc9e6f27..0fe7f30d 100644 --- a/src/utilities/time_h.f90 +++ b/src/utilities/time_h.f90 @@ -12,6 +12,7 @@ !!------------------------------------------------------------ module time_object use time_delta_object, only : time_delta_t + use iso_fortran_env, only: real128 implicit none @@ -38,7 +39,7 @@ module time_object integer, dimension(13) :: month_start integer :: year, month, day, hour, minute, second - double precision :: current_date_time = 0 + real(real128) :: current_date_time = 0 contains procedure, public :: date => calendar_date @@ -51,6 +52,8 @@ module time_object procedure, public :: equals => equals_with_precision procedure, public :: units => units procedure, public :: broadcast => bcast + procedure, public :: get_calendar=> get_calendar + procedure, public :: get_month => get_month generic, public :: init => time_init_c generic, public :: init => time_init_i @@ -115,6 +118,7 @@ module subroutine time_init_i(this, calendar, year_zero, month_zero, day_zero, h end subroutine time_init_i + !>------------------------------------------------------------ !! Set the calendar from a given name !! @@ -144,11 +148,23 @@ end subroutine set_calendar module function get_seconds(this) result(seconds) implicit none class(Time_type) :: this - double precision :: seconds + real(real128) :: seconds end function get_seconds + !>--------------------------------- + !! Convience function, just return the month of the year. + !! + !!--------------------------------- + module function get_month(this) result(month) + implicit none + integer :: month + class(Time_type), intent(in):: this + + end function get_month + + !>------------------------------------------------------------ !! Return the current date number (days since initial year) !! @@ -159,10 +175,23 @@ end function get_seconds module function get_mjd(this) result(mjd) implicit none class(Time_type) :: this - double precision :: mjd + real(real128) :: mjd end function get_mjd + !>------------------------------------------------------------ + !! Return the calendar being used by a time object + !! + !! Either gregorian, 360-day, or noleap + !! GREGORIAN=0, NOLEAP=1, THREESIXTY=2, NOCALENDAR=-1 + !! + !!------------------------------------------------------------ + module function get_calendar(this) result(calendar) + implicit none + class(Time_type) :: this + integer :: calendar + + end function get_calendar !>------------------------------------------------------------ !! Convert a Year, Month, Day, hour, minute, second into a single number @@ -175,7 +204,7 @@ module function date_to_mjd(this, year, month, day, hour, minute, second) implicit none class(Time_type), intent(in) :: this integer, intent(in) :: year, month, day, hour, minute, second - double precision :: date_to_mjd + real(real128) :: date_to_mjd end function date_to_mjd @@ -262,7 +291,7 @@ end subroutine set_from_date module subroutine set_from_mjd(this, days) implicit none class(Time_type), intent(inout) :: this - double precision, intent(in) :: days + real(real128), intent(in) :: days end subroutine set_from_mjd diff --git a/src/utilities/time_io.f90 b/src/utilities/time_io.f90 index fa6b5de6..560406dd 100644 --- a/src/utilities/time_io.f90 +++ b/src/utilities/time_io.f90 @@ -6,6 +6,7 @@ module time_io use time_delta_object, only : time_delta_t use string, only : get_integer use io_routines, only : io_read, io_read_attribute + use iso_fortran_env, only: real64, real128 implicit none @@ -73,16 +74,16 @@ end function find_timestep_in_file function time_gain_from_units(units) result(gain) implicit none character(len=*), intent(in) :: units - double precision :: gain + real(real128) :: gain if ((units(1:4)=="days").or.(units(1:4)=="Days")) then - gain = 1.0D0 + gain = 1.0Q0 else if ((units(1:4)=="hour").or.(units(1:4)=="Hour")) then - gain = 24.0D0 + gain = 24.0Q0 else if ((units(1:3)=="min").or.(units(1:3)=="Min")) then - gain = 1440.0D0 + gain = 1440.0Q0 else if ((units(1:3)=="sec").or.(units(1:3)=="Sec")) then - gain = 86400.0D0 + gain = 86400.0Q0 else write(*,*) trim(units) stop "Error: unknown units" @@ -170,20 +171,21 @@ subroutine read_times(filename, varname, times, timezone_offset, curstep) implicit none character(len=*), intent(in) :: filename, varname type(Time_type), intent(inout), allocatable, dimension(:) :: times - double precision, intent(in), optional :: timezone_offset + real(real128), intent(in), optional :: timezone_offset integer, intent(in), optional :: curstep - double precision, allocatable, dimension(:) :: temp_times + real(real64), allocatable, dimension(:) :: temp_times_64 + real(real128), allocatable, dimension(:) :: temp_times_128 integer :: time_idx, error integer :: start_year, start_month, start_day, start_hour character(len=MAXSTRINGLENGTH) :: calendar, units - double precision :: calendar_gain + real(real128) :: calendar_gain - ! first read the time variable (presumebly a 1D double precision array) + ! first read the time variable (presumebly a 1D real(real64) array) if (present(curstep)) then - call io_read(trim(filename), trim(varname), temp_times, curstep=curstep) + call io_read(trim(filename), trim(varname), temp_times_64, curstep=curstep) else - call io_read(trim(filename), trim(varname), temp_times) + call io_read(trim(filename), trim(varname), temp_times_64) endif ! attempt to read the calendar attribute from the time variable @@ -206,27 +208,80 @@ subroutine read_times(filename, varname, times, timezone_offset, curstep) ! based off of the string "Days since" (or "seconds" or...) calendar_gain = time_gain_from_units(units) else + stop "Time variable does not have units attribute" endif ! converts the input units to "days since ..." ! in case it is in units of e.g. "hours since" or "seconds since" - temp_times = temp_times / calendar_gain + allocate(temp_times_128(size(temp_times_64))) + temp_times_128 = temp_times_64 / calendar_gain if (present(timezone_offset)) then - temp_times = temp_times + timezone_offset / 24.0 + temp_times_128 = temp_times_128 + timezone_offset / 24.0 endif if (allocated(times)) deallocate(times) - allocate(times(size(temp_times))) + allocate(times(size(temp_times_128))) - do time_idx = 1, size(temp_times,1) + do time_idx = 1, size(temp_times_128,1) call times(time_idx)%init(calendar, start_year, start_month, start_day, start_hour) - call times(time_idx)%set(days=temp_times(time_idx)) + call times(time_idx)%set(days=temp_times_128(time_idx)) end do - deallocate(temp_times) + deallocate(temp_times_64, temp_times_128) end subroutine read_times + function get_output_time(time, units, round_seconds) result(output_time) + implicit none + type(Time_type), intent(in) :: time + character(len=*), intent(in), optional :: units + logical, intent(in), optional :: round_seconds + + type(Time_type) :: output_time + type(time_delta_t) :: half_minute + + integer :: year, month, day, hour, minute, seconds + integer :: year0, month0, day0, hour0, minute0, seconds0 + character(len=kMAX_NAME_LENGTH) :: use_units + + if (present(units)) then + use_units = units + else + use_units = time%units() + endif + + call time%date(year, month, day, hour, minute, seconds) + year0 = year_from_units(use_units) + month0 = month_from_units(use_units) + day0 = day_from_units(use_units) + hour0 = hour_from_units(use_units) + minute0 = 0 ! minute_from_units(use_units) + seconds0 = 0 ! seconds_from_units(use_units) + + call output_time%init(time%get_calendar(), year0, month0, day0, hour0) + + if (present(round_seconds)) then + if (round_seconds) then + if (seconds > 30) then + call output_time%set(year, month, day, hour, minute, seconds) + call half_minute%set(seconds=30) + output_time = output_time + half_minute + ! get a new date after adding 30 seconds + call output_time%date(year, month, day, hour, minute, seconds) + ! use that date after setting seconds to 0 this rounds the old date up by up to 30s + call output_time%set(year, month, day, hour, minute, 0) + else + call output_time%set(year, month, day, hour, minute, 0) + endif + else + call output_time%set(year, month, day, hour, minute, seconds) + endif + else + call output_time%set(year, month, day, hour, minute, seconds) + endif + + end function get_output_time + end module time_io diff --git a/src/utilities/time_obj.f90 b/src/utilities/time_obj.f90 index 4a45a7d1..11eb8be6 100644 --- a/src/utilities/time_obj.f90 +++ b/src/utilities/time_obj.f90 @@ -11,7 +11,8 @@ !! !!------------------------------------------------------------ submodule(time_object) time_implementation - use co_util, only : broadcast + use co_util, only: broadcast + use iso_fortran_env, only: real128 implicit none @@ -106,6 +107,8 @@ module subroutine time_init_i(this, calendar, year_zero, month_zero, day_zero, h end subroutine time_init_i + + !>------------------------------------------------------------ !! Set the calendar from a given name !! @@ -175,6 +178,22 @@ module subroutine set_calendar(this, calendar_name) end subroutine set_calendar + !>------------------------------------------------------------ + !! Return the calendar being used by a time object + !! + !! Either gregorian, 360-day, or noleap + !! + !!------------------------------------------------------------ + module function get_calendar(this) result(calendar) + implicit none + class(Time_type) :: this + integer :: calendar + + calendar = this%calendar + + end function get_calendar + + !>------------------------------------------------------------ !! Return the current date number (seconds since reference time) !! @@ -186,7 +205,7 @@ end subroutine set_calendar module function get_seconds(this) result(seconds) implicit none class(Time_type) :: this - double precision :: seconds + real(real128) :: seconds seconds = this%current_date_time * 86400.0D0 end function get_seconds @@ -202,13 +221,13 @@ end function get_seconds module function get_mjd(this) result(mjd) implicit none class(Time_type) :: this - double precision :: mjd + real(real128) :: mjd mjd = this%current_date_time end function get_mjd !>------------------------------------------------------------ - !! Calcualte the julian day number corresponding to a given year, month and day + !! Calculate the julian day number corresponding to a given year, month and day !! in a gregorian calendar !! !! Algorithm from Wikipedia: http://en.wikipedia.org/wiki/Julian_day @@ -221,10 +240,12 @@ end function get_mjd function gregorian_julian_day(year, month, day, hour, minute, second) result(julian_day) implicit none integer, intent(in) :: year, month, day, hour, minute, second - double precision :: julian_day - double precision :: d,m,y + real(real128) :: julian_day + real(real128) :: d,m,y integer :: a,b + real(real128) :: internal_seconds + internal_seconds = second a = (14-month)/12 y = year+4800-a m = month+12*a-3 @@ -235,7 +256,7 @@ function gregorian_julian_day(year, month, day, hour, minute, second) result(jul ! Julian calendar ! b = day + floor(153*m+2/5) + 365*y + floor(y/4) - 32083 - julian_day = b + (((second/60d+0)+minute)/60d+0 + hour-12)/24.0 + julian_day = b + (((internal_seconds/60d+0)+minute)/60d+0 + hour-12)/24.0 end function @@ -250,18 +271,19 @@ module function date_to_mjd(this, year, month, day, hour, minute, second) implicit none class(Time_type), intent(in) :: this integer, intent(in) :: year, month, day, hour, minute, second - double precision :: date_to_mjd + real(real128) :: date_to_mjd, internal_seconds + internal_seconds = second if (this%calendar==GREGORIAN) then date_to_mjd = gregorian_julian_day(year, month, day, hour, minute, second) date_to_mjd = date_to_mjd - gregorian_julian_day(this%year_zero, this%month_zero, this%day_zero, this%hour_zero, 0, 0) else if (this%calendar==NOLEAP) then - date_to_mjd = (year*365 + this%month_start(month)-1 + day-1 + (hour + (minute+second/60d+0)/60d+0)/24d+0) & + date_to_mjd = (year*365 + this%month_start(month)-1 + day-1 + (hour + (minute + internal_seconds/60d+0)/60d+0)/24d+0) & - (this%year_zero*365 + this%month_start(this%month_zero)-1 + this%day_zero-1 + (this%hour_zero)/24d+0) else if (this%calendar==THREESIXTY) then - date_to_mjd = (year*360 + this%month_start(month)-1 + day-1 + (hour + (minute+second/60d+0)/60d+0)/24d+0) & + date_to_mjd = (year*360 + this%month_start(month)-1 + day-1 + (hour + (minute + internal_seconds/60d+0)/60d+0)/24d+0) & - (this%year_zero*360 + this%month_start(this%month_zero)-1 + this%day_zero-1 + (this%hour_zero)/24d+0) end if @@ -282,7 +304,7 @@ module subroutine calendar_date(this, year, month, day, hour, minute, second) integer :: y=4716,j=1401,m=2,n=12,r=4,p=1461 integer :: v=3,u=5,s=153,w=2,B=274277,C=-38 integer ::f,e,g,h, jday - double precision :: day_fraction, mjd + real(real128) :: day_fraction, mjd mjd = this%current_date_time+1d-5 ! add less than one second @@ -358,6 +380,21 @@ module subroutine calendar_date(this, year, month, day, hour, minute, second) end subroutine calendar_date + !>--------------------------------- + !! Convience function, just return the month of the year. + !! + !!--------------------------------- + module function get_month(this) result(month) + implicit none + integer :: month + class(Time_type), intent(in):: this + + integer :: year, day, hour, minute, second + + call this%date(year, month, day, hour, minute, second) + + end function get_month + !>------------------------------------------------------------ !! Return the day of the year corresponding to the current date_time !! @@ -403,7 +440,7 @@ module function calc_year_fraction(this, lon) real, intent(in), optional :: lon real :: offset - double precision :: year_start + real(real128) :: year_start integer :: year, month, day, hour, minute, second @@ -509,7 +546,7 @@ end subroutine set_from_date module subroutine set_from_mjd(this, days) implicit none class(Time_type), intent(inout) :: this - double precision, intent(in) :: days + real(real128), intent(in) :: days integer :: year, month, day, hour, minute, second this%current_date_time = days @@ -832,7 +869,7 @@ module function difference(t1, t2) result(dt) if (((t1%calendar == t2%calendar).and.(t1%year_zero == t2%year_zero)) & .and.((t1%month_zero == t2%month_zero).and.(t1%day_zero == t2%day_zero).and.(t1%hour_zero == t2%hour_zero))) then - call dt%set(seconds=(t1%mjd() - t2%mjd()) * 86400.0D0) + call dt%set(seconds=dble((t1%mjd() - t2%mjd())) * 86400.0D0) else ! if the two time object reference calendars don't match ! create a new time object with the same referecnce as t1 @@ -841,7 +878,7 @@ module function difference(t1, t2) result(dt) call t2%date(year, month, day, hour, minute, second) call temp_time%set(year, month, day, hour, minute, second) - call dt%set(seconds=((t1%mjd() - temp_time%mjd()) * 86400.0D0)) + call dt%set(seconds=dble((t1%mjd() - temp_time%mjd()) * 86400.0D0)) endif end function difference diff --git a/tests/gen_ideal_test.py b/tests/gen_ideal_test.py old mode 100644 new mode 100755 index ed33bc3f..f5553126 --- a/tests/gen_ideal_test.py +++ b/tests/gen_ideal_test.py @@ -1,6 +1,7 @@ +#!/usr/bin/env python3 +from ast import Or from netCDF4 import Dataset import numpy as np -import math from sys import exit, path from os import getcwd path.insert(0, getcwd()+'/../helpers/genNetCDF') @@ -8,35 +9,121 @@ import Forcing as fc import ICARoptions as opt -# Python program generates an ideal case -class IdealTest: - # from ideal test - sealevel_pressure = 100000.0 # pressure at sea level [Pa] - dz_value = 500.0 # thickness of each model gridcell [m] - # hill values currently do nothing - hill_height = 1000.0 # height of the ideal hill(s) [m] - n_hills = 1.0 # number of hills across the domain +# --------------------------------------- +# ----- Settings For Generating Files ----- +# --------------------------------------- +# choose dimensions of hi-res grid: +nz = 80 +nx = 300 +ny = 20 +dx=dy=1000 - def __init__(self, nz=10, nx=2, ny=2, n_hills=1.0): - rh = 0.9 - u_test_val = 0.5 - v_test_val = 0.5 - w_test_val = 0.0 - water_vapor_test_val = 0.001 - theta_test_val = 300.0 +dz_levels= [50., 75., 125., 200., 300., 400.] + [500.] * 50 +decay_rate_L_topo = 2.0 +decay_rate_S_topo = 5.0 +terrain_smooth_windowsize = 4 +terrain_smooth_cycles = 5 - self.forcing = fc.Forcing(nz, nx, ny, self.sealevel_pressure, - rh, u_test_val, v_test_val, w_test_val, - water_vapor_test_val, theta_test_val, - dz_value=self.dz_value) +# Paramters to generate hi-res topography: +hill_height = 3000.0 # height of the ideal hill(s) [m] +n_hills = 5.0 # number of hills across the domain (ignored for Schaer test) - self.init = tg.Topography(nz, nx, ny) +# perform an advection test, like the one in Schär 2002. Should have mp=pbl=0, adv=1 or 2. This will overwrite any Forcing u/v specified below. +# More details in 'A New Terrain-Following Vertical Coordinate Formulation for Atmospheric Prediction Models' Christoph Schär et al, 2002, Monthly Weather Review vol 130. +Schaer_test=True +if Schaer_test==True: + print(" - - - Setting up an idealized advection test - - - \n") + # Values below are as specified in Schaer et al 2002. + dx = dy = 1000 # 1000 m + nx = 300; ny = 20 # 300 m, ..m ? + nz = 50 # 50 m + dz_levels = [500]*nz # 500 m , model top at 25 km + decay_rate_L_topo = 1.6667 # s1 = 15 km + decay_rate_S_topo = 13.0 # s2 = 2.5 km + hill_height = 3000.0 # height of the ideal hill(s) [m] + + + +# ---- Forcing specs ----- +nt_lo = 4 # nr of timesteps (hours) - this is also how long the ideal sim will run. +nz_lo = 51 +nx_lo = 300; ny_lo = 20 +dx_lo = dy_lo = 1000 # make sure dx_lo*nx_lo => dx*nx & dy_lo*ny_lo => dy*ny +dz_lo = 500.0 # thickness of each (Forcing?) model gridcell [m] + +if dx_lo*nx_lo < dx*nx or dy_lo*ny_lo < dy*ny or dz_lo*nz_lo < np.sum(dz_levels) : + print("\n ERROR: Forcing domain smaller than hi-res domain. Incease forcing domain size \n") + +# u field can be a constant, or an array of size nz. When Schaer_test is chosen, this get overwritten. +u_test_val = np.array([0., 0., 0., 0., 0., 0. , 0. ,2.] + [5.] *35) # u field in z-direction +# u_test_val = 5.0 +v_test_val = 0.0 + +# relative_humidity = 0.01 +water_vapor_test_val = 0.000 +mixing_ratio = 0.001 # water vapor # not if constant +qv_val = mixing_ratio + +# --- choose function for creating pressure --- +pressure_func = 'calc_pressure_from_sea' +# pressure_func = 'calc_pressure_dz_iter' +# pressure_func = 'calc_pressure_1m_iter' +# --- choose weather model --- +# weather_model = 'basic' +weather_model = 'WeismanKlemp' def main(): # ICAR Options generate the ICAR namelist - options = opt.ICARoptions() - test = IdealTest(nz=40, nx=40, ny=40, n_hills=1.0) + opt.ICARoptions(nz=nz, + output_vars=['pressure','temperature', 'lon', 'lat', 'z', 'dz', 'dz_i', 'u', 'v', 'w', 'w_grid', 'qv', 'terrain' ], + dz_levels=dz_levels, + model_comment = 'flat_z_height=-10', + flat_z_height=-10, + sleve= ".True.", + terrain_smooth_windowsize = terrain_smooth_windowsize, + terrain_smooth_cycles = terrain_smooth_cycles , + decay_rate_L_topo = decay_rate_L_topo, + decay_rate_S_topo = decay_rate_S_topo, + sleve_n = 1.35, + space_varying = ".True.", + dx = dx, # <- affects advection speed! + phys_opt_mp = 0, + phys_opt_adv = 1, + phys_opt_wind = 3, + smooth_wind_distance = dx_lo, # Very important - has effect on vertical speeds! + use_agl_height = True, # ! Use height above ground level to interpolate the wind field instead of height above sea level. + agl_cap = 400, # ! Height at which we switch from AGL-interpolation to using ASL-interpolation + output_file = 'icar_out_', + qv_is_relative_humidity ='false', + output_interval = 1200, + end_date = '2020-12-01 02:00:00', +) + print("Generated icar_options.nml") + + tg.Topography(nz, nx, ny, + n_hills=n_hills, hill_height=hill_height, + dx=dx, dy=dy, + lat0 = 39.5,lon0 = -105, + Schaer_test=Schaer_test + ) + print("Generated init.nc") + + # double check all passed variable get used + forcing = fc.Forcing(nt=nt_lo, nz=nz_lo, nx=nx_lo+10, ny=ny_lo+10, + u_val=u_test_val, + v_val=v_test_val, + water_vapor_val=water_vapor_test_val, + dz_value=dz_lo, + dx=dx_lo, dy=dy_lo, + qv_val=qv_val, + weather_model=weather_model, + pressure_func=pressure_func, + hill_height=hill_height, + lat0 = 39.5,lon0 = -105, + Schaer_test=Schaer_test + ) + print("Generated forcing.nc") if __name__ == "__main__": main()