Commit 1ce6a711 authored by Ethan Coon's avatar Ethan Coon
Browse files

adds sample iso_c test

parent c01fd9cc
subroutine CanopyHydrologyKern1( dtime, &
qflx_prec_intr, frac_veg_nosno, dewmx, elai, esai, h2ocan, &
n_irrig_steps_left, qflx_irrig, qflx_prec_grnd, &
qflx_snwcp_liq, qflx_snwcp_ice, qflx_snow_grnd_patch, qflx_rain_grnd,irrig_rate, &
ltype, urbpoi, &
ctype, do_capsnow, forc_rain, forc_snow )
use shr_kind_mod, only : &
r8 => shr_kind_r8, &
i4 => shr_kind_i4, &
bool => shr_kind_bool
use column_varcon , only : icol_sunwall, icol_shadewall
use landunit_varcon , only : istcrop, istice, istwet, istsoil, istice_mec
implicit none
real(r8), intent(in) :: dtime
integer(i4), intent(in) :: ltype , ctype
integer(i4), intent(inout) :: n_irrig_steps_left
logical(bool), intent(in) :: urbpoi, do_capsnow
real(r8), intent(out) :: qflx_prec_intr
integer(i4), intent(in) :: frac_veg_nosno
real(r8), intent(in) :: forc_rain
real(r8), intent(in) :: forc_snow
real(r8), intent(in) :: dewmx
real(r8), intent(in) :: elai
real(r8), intent(in) :: esai
real(r8), intent(inout) :: h2ocan
real(r8), intent(out) :: qflx_irrig
real(r8), intent(out) :: qflx_prec_grnd
real(r8), intent(out) :: qflx_snwcp_liq, qflx_snwcp_ice, qflx_snow_grnd_patch, qflx_rain_grnd
real(r8), intent(in) :: irrig_rate
!local variables
real(r8) :: fpi, xrun, h2ocanmx
real(r8) :: qflx_candrip, qflx_through_snow, qflx_through_rain
real(r8) :: qflx_prec_grnd_snow
real(r8) :: qflx_prec_grnd_rain
real(r8) :: fracsnow
real(r8) :: fracrain
! Canopy interception and precipitation onto ground surface
! Add precipitation to leaf water
if (ltype==istsoil .or. ltype==istwet .or. urbpoi .or. &
ltype==istcrop) then
qflx_candrip = 0._r8 ! rate of canopy runoff
qflx_through_snow = 0._r8 ! rain precipitation direct through canopy
qflx_through_rain = 0._r8 ! snow precipitation direct through canopy
qflx_prec_intr = 0._r8 ! total intercepted precipitation
fracsnow = 0._r8 ! fraction of input precip that is snow
fracrain = 0._r8 ! fraction of input precip that is rain
if (ctype /= icol_sunwall .and. ctype /= icol_shadewall) then
if (frac_veg_nosno == 1 .and. (forc_rain + forc_snow) > 0._r8) then
! determine fraction of input precipitation that is snow and rain
fracsnow = forc_snow/(forc_snow + forc_rain)
fracrain = forc_rain/(forc_snow + forc_rain)
! The leaf water capacities for solid and liquid are different,
! generally double for snow, but these are of somewhat less
! significance for the water budget because of lower evap. rate at
! lower temperature. Hence, it is reasonable to assume that
! vegetation storage of solid water is the same as liquid water.
h2ocanmx = dewmx * (elai + esai)
! Coefficient of interception
! set fraction of potential interception to max 0.25
fpi = 0.25_r8*(1._r8 - exp(-0.5_r8*(elai + esai)))
! Direct throughfall
qflx_through_snow = forc_snow * (1._r8-fpi)
qflx_through_rain = forc_rain * (1._r8-fpi)
! Intercepted precipitation [mm/s]
qflx_prec_intr = (forc_snow + forc_rain) * fpi
! Water storage of intercepted precipitation and dew
h2ocan = max(0._r8, h2ocan + dtime*qflx_prec_intr)
! Initialize rate of canopy runoff and snow falling off canopy
qflx_candrip = 0._r8
! Excess water that exceeds the leaf capacity
xrun = (h2ocan - h2ocanmx)/dtime
! Test on maximum dew on leaf
! Note if xrun > 0 then h2ocan must be at least h2ocanmx
if (xrun > 0._r8) then
qflx_candrip = xrun
h2ocan = h2ocanmx
end if
end if
end if
else if (ltype==istice .or. ltype==istice_mec) then
h2ocan = 0._r8
qflx_candrip = 0._r8
qflx_through_snow = 0._r8
qflx_through_rain = 0._r8
qflx_prec_intr = 0._r8
fracsnow = 0._r8
fracrain = 0._r8
end if
! Precipitation onto ground (kg/(m2 s))
if (ctype /= icol_sunwall .and. ctype /= icol_shadewall) then
if (frac_veg_nosno == 0) then
qflx_prec_grnd_snow = forc_snow
qflx_prec_grnd_rain = forc_rain
else
qflx_prec_grnd_snow = qflx_through_snow + (qflx_candrip * fracsnow)
qflx_prec_grnd_rain = qflx_through_rain + (qflx_candrip * fracrain)
end if
! Urban sunwall and shadewall have no intercepted precipitation
else
qflx_prec_grnd_snow = 0.
qflx_prec_grnd_rain = 0.
end if
! Determine whether we're irrigating here; set qflx_irrig appropriately
if (n_irrig_steps_left > 0) then
qflx_irrig = irrig_rate
n_irrig_steps_left = n_irrig_steps_left - 1
else
qflx_irrig = 0._r8
end if
! Add irrigation water directly onto ground (bypassing canopy interception)
! Note that it's still possible that (some of) this irrigation water will runoff (as runoff is computed later)
qflx_prec_grnd_rain = qflx_prec_grnd_rain + qflx_irrig
! Done irrigation
qflx_prec_grnd = qflx_prec_grnd_snow + qflx_prec_grnd_rain
if (do_capsnow) then
qflx_snwcp_liq = qflx_prec_grnd_rain
qflx_snwcp_ice = qflx_prec_grnd_snow
qflx_snow_grnd_patch = 0._r8
qflx_rain_grnd = 0._r8
else
qflx_snwcp_liq = 0._r8
qflx_snwcp_ice = 0._r8
qflx_snow_grnd_patch = qflx_prec_grnd_snow ! ice onto ground (mm/s)
qflx_rain_grnd = qflx_prec_grnd_rain ! liquid water onto ground (mm/s)
end if
return
end subroutine CanopyHydrologyKern1
......@@ -4,26 +4,14 @@ OBJECT = .
default: all
include $(OBJECT)/config/Makefile.config
FCFLAGS += -I$(ELM_UTILS_DIR)
# Order is important due to .mod file creation
OBJS = \
$(ELM_UTILS_DIR)/shr_kind_mod.o \
$(ELM_UTILS_DIR)/shr_sys_mod.o \
$(ELM_UTILS_DIR)/shr_infnan_mod.o \
$(ELM_UTILS_DIR)/shr_strconvert_mod.o \
$(ELM_UTILS_DIR)/shr_assert_mod.o \
landunit_varcon.o \
column_varcon.o \
CanopyHydrologyKern1.o
all: $(OBJS)
$(AR) cr libelm.a $(OBJS)
all:
$(MAKE) -C fortran all
clean:
@$(ELM_CLEAN);
@cd $(ELM_UTILS_DIR); $(ELM_CLEAN)
$(MAKE) -C fortran clean
allclean:
$(MAKE) -C fortran clean
This diff is collapsed.
This diff is collapsed.
MODULE shr_kind_mod
!----------------------------------------------------------------------------
! precision/kind constants add data public
!----------------------------------------------------------------------------
use ISO_C_BINDING, only: C_DOUBLE, C_INT, C_FLOAT, C_BOOL
public
integer,parameter :: SHR_KIND_R8 = C_DOUBLE ! 8 byte real
integer,parameter :: SHR_KIND_R4 = C_FLOAT ! 4 byte real
integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real
integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer
integer,parameter :: SHR_KIND_I4 = C_INT ! 4 byte integer
integer,parameter :: SHR_KIND_IN = kind(1) ! native integer
integer,parameter :: SHR_KIND_CS = 80 ! short char
integer,parameter :: SHR_KIND_CM = 160 ! mid-sized char
integer,parameter :: SHR_KIND_CL = 256 ! long char
integer,parameter :: SHR_KIND_CX = 512 ! extra-long char
integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char
integer,parameter :: SHR_KIND_BOOL = C_BOOL ! boolean
END MODULE shr_kind_mod
module shr_strconvert_mod
! This module defines toString, a generic function for creating character type
! representations of data, as implemented for the most commonly used intrinsic
! types:
!
! - 4 and 8 byte integer
! - 4 and 8 byte real
! - logical
!
! No toString implementation is provided for character input, but this may be
! added if some use case arises.
!
! Currently, only scalar inputs are supported. The return type of this function
! is character with deferred (allocatable) length.
!
! The functions for integers and reals allow an optional format_string argument,
! which can be used to control the padding and precision of output as with any
! write statement. However, the implementations internally must use a
! preallocated buffer, so a format_string that significantly increases the size
! of the output may cause a run-time error or undefined behavior in the program.
!
! Other modules may want to provide extensions of toString for their own derived
! types. In this case there are two guidelines to observe:
!
! - It is preferable to have only one mandatory argument, which is the object to
! produce a string from. There may be other formatting options, but the
! implementation should do something sensible without these.
!
! - Since the main purpose of toString is to provide a human-readable
! representation of a type, especially for documentation or debugging
! purposes, refrain from printing large array components in their entirety
! (instead consider printing only the shape, or statistics such as
! min/mean/max for arrays of numbers).
use shr_kind_mod, only: &
i4 => shr_kind_i4, &
i8 => shr_kind_i8, &
r4 => shr_kind_r4, &
r8 => shr_kind_r8, &
cs => shr_kind_cs
use shr_infnan_mod, only: &
isnan => shr_infnan_isnan
implicit none
private
! Human-readable representation of data.
public :: toString
interface toString
module procedure i4ToString
module procedure i8ToString
module procedure r4ToString
module procedure r8ToString
module procedure logicalToString
end interface toString
contains
pure function i4ToString(input, format_string) result(string)
integer(i4), intent(in) :: input
character(len=*), intent(in), optional :: format_string
character(len=:), allocatable :: string
character(len=cs) :: buffer
if (present(format_string)) then
write(buffer, format_string) input
else
! For most compilers, these two statements are equivalent to a format of
! '(I0)', but that's not technically in the standard.
write(buffer, '(I11)') input
buffer = adjustl(buffer)
end if
allocate(string, source=trim(buffer))
end function i4ToString
pure function i8ToString(input, format_string) result(string)
integer(i8), intent(in) :: input
character(len=*), intent(in), optional :: format_string
character(len=:), allocatable :: string
character(len=cs) :: buffer
if (present(format_string)) then
write(buffer, format_string) input
else
! For most compilers, these two statements are equivalent to a format of
! '(I0)', but that's not technically in the standard.
write(buffer, '(I20)') input
buffer = adjustl(buffer)
end if
allocate(string, source=trim(buffer))
end function i8ToString
pure function r4ToString(input, format_string) result(string)
real(r4), intent(in) :: input
character(len=*), intent(in), optional :: format_string
character(len=:), allocatable :: string
character(len=cs) :: buffer
if (present(format_string)) then
write(buffer, format_string) input
else
write(buffer, '(ES15.8 E2)') input
buffer = adjustl(buffer)
! Deal with the fact that the "+" sign is optional by simply adding it if
! it is not present, so that the default format is standardized across
! compilers.
! Assumes that compilers do not treat the sign bit on NaN values specially.
if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then
buffer = "+" // trim(buffer)
end if
end if
allocate(string, source=trim(buffer))
end function r4ToString
pure function r8ToString(input, format_string) result(string)
real(r8), intent(in) :: input
character(len=*), intent(in), optional :: format_string
character(len=:), allocatable :: string
character(len=cs) :: buffer
if (present(format_string)) then
write(buffer, format_string) input
else
write(buffer, '(ES24.16 E3)') input
buffer = adjustl(buffer)
! Deal with the fact that the "+" sign is optional by simply adding it if
! it is not present, so that the default format is standardized across
! compilers.
! Assumes that compilers do not treat the sign bit on NaN values specially.
if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then
buffer = "+" // trim(buffer)
end if
end if
allocate(string, source=trim(buffer))
end function r8ToString
pure function logicalToString(input) result(string)
logical, intent(in) :: input
character(len=:), allocatable :: string
! We could use a write statement, but this is easier.
allocate(character(len=1) :: string)
if (input) then
string = "T"
else
string = "F"
end if
end function logicalToString
end module shr_strconvert_mod
!
! Mocked cime shr_sys_mod
!
! NOTE this abort is simpler than CIME's real abort -- just die
! already and don't require too many other libraries.
!----------------------------------------------------------------
module shr_sys_mod
use shr_kind_mod, only : shr_kind_in, shr_kind_cx
implicit none
! PUBLIC: Public interfaces
private
! Imported from shr_abort_mod and republished with renames. Other code that wishes to
! use these routines should use these shr_sys names rather than directly using the
! routines from shr_abort_abort. (This is for consistency with older code, from when
! these routines were defined in shr_sys_mod.)
public :: shr_sys_abort ! abort a program
!===============================================================================
contains
!===============================================================================
!===============================================================================
subroutine shr_sys_abort(string,rc)
! Consistent stopping mechanism
!----- arguments -----
character(len=*) , intent(in), optional :: string ! error message string
integer(shr_kind_in), intent(in), optional :: rc ! error code
! Local version of the string.
! (Gets a default value if string is not present.)
character(len=shr_kind_cx) :: local_string
!-------------------------------------------------------------------------------
if (present(string)) then
local_string = trim(string)
else
local_string = "Unknown error submitted to shr_abort_abort."
end if
! A compiler's abort method may print a backtrace or do other nice
! things, but in fact we can rarely leverage this, because MPI_Abort
! usually sends SIGTERM to the process, and we don't catch that signal.
call abort()
end subroutine shr_sys_abort
end module shr_sys_mod
module column_varcon
!-----------------------------------------------------------------------
! !DESCRIPTION:
! Module containing landunit indices and associated variables and routines.
!
! Drastically simplified from the original version --etc
!-----------------------------------------------------------------------
use landunit_varcon, only : isturb_MIN
implicit none
save
private
!------------------------------------------------------------------
! Initialize column type constants
!------------------------------------------------------------------
! urban column types
integer, parameter, public :: icol_roof = isturb_MIN*10 + 1
integer, parameter, public :: icol_sunwall = isturb_MIN*10 + 2
integer, parameter, public :: icol_shadewall = isturb_MIN*10 + 3
integer, parameter, public :: icol_road_imperv = isturb_MIN*10 + 4
integer, parameter, public :: icol_road_perv = isturb_MIN*10 + 5
end module column_varcon
......@@ -10,7 +10,7 @@
$(F77) $(FFLAGS) -c $< -o $@
.f.o:
$(F77) $(FFLAGS) -c $< -o $@
.c.o:
.cc.o:
$(CC) $(CFLAGS) $(CPPFLAGS) -c $< -o $@
.cxx.o:
$(CXX) $(CFLAGS) $(CPPFLAGS) -c $< -o $@
......@@ -26,7 +26,7 @@ ELM_DIR = elm
ELM_LIB_DEPEND = $(PARFLOW_LIB_DIR)/libelm.a
NETCDF_ROOT = /Users/uec/codes/ats/amanzi-tpls/install-0.88
STD_LIB_ROOT = /usr
ELM_UTILS_DIR = cime_utils
......@@ -41,6 +41,9 @@ FC = gfortran
FCFLAGS = -Wall -Wunused -fimplicit-none -free -g3 -fbounds-check
#FCFLAGS = -Wall -Wunused -fimplicit-none -free -O3
CC = clang++
CPPFLAGS = -g -Wall -std=c++11
LINKER = gfortran
AR = ar
......
module landunit_varcon
!-----------------------------------------------------------------------
! !DESCRIPTION:
! Module containing landunit indices and associated variables and routines.
!
! Drastically simplifed from original --etc
! -----------------------------------------------------------------------
implicit none
save
private
!------------------------------------------------------------------
! Initialize landunit type constants
!------------------------------------------------------------------
integer, parameter, public :: istsoil = 1 !soil landunit type (natural vegetation)
integer, parameter, public :: istcrop = 2 !crop landunit type
integer, parameter, public :: istice = 3 !land ice landunit type (glacier)
integer, parameter, public :: istice_mec = 4 !land ice (multiple elevation classes) landunit type
integer, parameter, public :: istdlak = 5 !deep lake landunit type (now used for all lakes)
integer, parameter, public :: istwet = 6 !wetland landunit type (swamp, marsh, etc.)
integer, parameter, public :: isturb_MIN = 7 !minimum urban type index
integer, parameter, public :: isturb_tbd = 7 !urban tbd landunit type
integer, parameter, public :: isturb_hd = 8 !urban hd landunit type
integer, parameter, public :: isturb_md = 9 !urban md landunit type
integer, parameter, public :: isturb_MAX = 9 !maximum urban type index
integer, parameter, public :: max_lunit = 9 !maximum value that lun_pp%itype can have
!(i.e., largest value in the above list)
integer, parameter, public :: landunit_name_length = 40 ! max length of landunit names
character(len=landunit_name_length), public :: landunit_names(max_lunit) ! name of each landunit type
! parameters that depend on the above constants
integer, parameter, public :: numurbl = isturb_MAX - isturb_MIN + 1 ! number of urban landunits
end module landunit_varcon
......@@ -80,11 +80,12 @@ program testcanopyhydrologykern1
urbpoi=.false.
do_capsnow = .false.
call CanopyHydrologyKern1( dtime, &
qflx_prec_intr, frac_veg_nosno, dewmx, elai, esai, h2ocan, &
n_irrig_steps_left, qflx_irrig, qflx_prec_grnd, &
qflx_snwcp_liq, qflx_snwcp_ice, qflx_snow_grnd_patch, qflx_rain_grnd,irrig_rate, &
ltype, urbpoi, &
ctype, do_capsnow, forc_rain, forc_snow )
forc_rain, forc_snow, irrig_rate, &
ltype, ctype, urbpoi, do_capsnow, &
elai, esai, dewmx, frac_veg_nosno, &
h2ocan, n_irrig_steps_left, &
qflx_prec_intr, qflx_irrig, qflx_prec_grnd, &
qflx_snwcp_liq, qflx_snwcp_ice, qflx_snow_grnd_patch, qflx_rain_grnd)
print *, itime, forc_rain, h2ocan, qflx_prec_grnd, qflx_prec_intr
end do
......
.PHONY: links library
.PHONY: links library CanopyHydrology_kern1_single
SRCDIR = ../src/
SRCDIR = ../src/fortran/
OBJECT = ../src/
default: all
......@@ -11,19 +11,28 @@ FCFLAGS += -I$(SRCDIR) -I$(SRCDIR)$(ELM_UTILS_DIR) -I$(NETCDF_ROOT)/include
all: links library CanopyHydrology_kern1_single
CanopyHydrology_kern1_single: test_CanopyHydrology_kern1_single
# ./test_$@
echo 'fail'
test_%: %.o
$(LINKER) $(FCFLAGS) -L$(OBJECT) -lelm -L$(NETCDF_ROOT)/lib -lnetcdff $< -o $@
$(LINKER) $(FCFLAGS) -L$(OBJECT)fortran -lelm -L$(NETCDF_ROOT)/lib -lnetcdff $< -o $@
test: test_CanopyHydrology_kern1_single
./test_CanopyHydrology_kern1_single
clean:
@$(ELM_CLEAN)
$(RM) test_*
allclean:
@$(ELM_CLEAN)
$(RM) test_*
$(MAKE) -C $(OBJECT) allclean
links:
@echo