Updating to F03 F08, Iterators for Data Structures
DanielNScott edited this page May 19, 2014
·
10 revisions
This article addresses two separate but related topics of interest; The implementation of iterators for the principal data structures in the model and the potential benefits, difficulties, and motivations for adopting the Fortran 2003 or Fortran 2008 standards. Information about these standards, object oriented programming, and compiler compatibility can be found in the resources section below.
It should be noted that no portion of the current mainline appears to be incompatible with either the Fortran 2003 or the Fortran 2008 standard; That is, one should be able to take ED as it is, add most of the new F08 features, build it with a compiler supporting these, and have no problems. In fact, compilers with support for F03/F08 features even recognize *.f90 files as 'free form' rather than Fortran 90/95 specific, and therefore as F03/F08 code. These points in themselves provide a strong argument in favor of 'updating' ED, because updating really means using up to date compilers and OK-ing the use of newer features, thereby providing ED developers a larger toolkit as well as potentially generating better executables.
Adding variables to ED is a time consuming, tedious, and potentially error prone task. Every new variable must be added to the subroutines that will allocate, deallocate, nullify, initialize, rescale, copy, integrate, average, and output it, to give an incomplete list. Additionally, when dealing with a variable's integrations there are frequently hierarchies of nested conditionals to negotiate in properly accomplishing these tasks; A diagnostic variable in ED is likely to have 5 corresponding integration variables (daily, daily mean, monthly mean, monthly mean of diurnal cycle, polygon averages) which will all need to be added to these subroutines as well, within various conditionals. As variable types (i.e. 13C vs total C) proliferate this problem will only get worse.
Consider the following code: One pernicious bug in creating output for a new variable, lassim_resp (leaf assimilate respiration) was recently resolved when the following code was amended to remove the today_lassim_resp assigment.
subroutine reset_averaged_vars(cgrid)
...
cohortloop: do ico=1,cpatch%ncohorts
cpatch%leaf_respiration(ico) = 0.0
cpatch%root_respiration(ico) = 0.0
...
if (c_alloc_flg > 0) then
cpatch%lassim_resp (ico) = 0.0
cpatch%today_lassim_resp(ico) = 0.0
end if
...
end subroutine reset_averaged_vars
It's removal fixed an anomalously low integration of the lassim_var. With 20/20 hindsight, it is clear the daily integration should not have been zeroed here. But given that leaf_resp and today_leaf_resp (the templates on which this variable elaborates) are paired in many routines pepperred throughout the model, it was an easy bug to create and a difficult bug to find; One heuristic for debugging, using the observation that two variables are almost invariably paired, was in conflict with a close reading/ semantic understanding of the code.
Consider now the following piece of code, also from average_utils:
patchloop: do ipa=1,csite%npatches
csite%today_A_decomp (ipa) = csite%today_A_decomp(ipa) * timefac1
csite%today_Af_decomp(ipa) = csite%today_Af_decomp(ipa) * timefac1
!----- Copy the decomposition terms to the daily mean if they are sought. -----!
if (save_daily) then
csite%dmean_A_decomp(ipa) = csite%today_A_decomp(ipa)
csite%dmean_Af_decomp(ipa) = csite%today_Af_decomp(ipa)
!----- Integrate the monthly mean. -----------------------------------------!
if (save_monthly) then
csite%mmean_A_decomp(ipa) = csite%mmean_A_decomp(ipa) &
+ csite%dmean_A_decomp(ipa)
csite%mmean_Af_decomp(ipa) = csite%mmean_Af_decomp(ipa) &
+ csite%dmean_Af_decomp(ipa)
end if
end if
cpatch => csite%patch(ipa)
!----- Included a loop so it won't crash with empty cohorts... ----------------!
cohortloop: do ico=1,cpatch%ncohorts
!---------------------------------------------------------------------------!
! Normalise the variables used to compute carbon balance. !
!---------------------------------------------------------------------------!
cpatch%today_gpp (ico) = cpatch%today_gpp (ico) * timefac1
cpatch%today_gpp_pot (ico) = cpatch%today_gpp_pot (ico) * timefac1
cpatch%today_gpp_lightmax (ico) = cpatch%today_gpp_lightmax (ico) * timefac1
cpatch%today_gpp_moistmax (ico) = cpatch%today_gpp_moistmax (ico) * timefac1
cpatch%today_leaf_resp (ico) = cpatch%today_leaf_resp (ico) * timefac1
cpatch%today_root_resp (ico) = cpatch%today_root_resp (ico) * timefac1
if (c_alloc_flg > 0) then
cpatch%today_lassim_resp(ico) = cpatch%today_lassim_resp(ico) * timefac1
end if
if (c13af > 0) then !!!DSC!!!
cpatch%today_gpp_C13 (ico) = cpatch%today_gpp_C13 (ico)*timefac1
cpatch%today_leaf_resp_C13(ico) = cpatch%today_leaf_resp_C13(ico)*timefac1
cpatch%today_root_resp_C13(ico) = cpatch%today_root_resp_C13(ico)*timefac1
if (c_alloc_flg > 0) then
cpatch%today_lassim_resp_C13(ico) = cpatch%today_lassim_resp_C13(ico) &
* timefac1
end if
end if
!---------------------------------------------------------------------------!
!---------------------------------------------------------------------------!
! We now update the daily means of GPP, and leaf and root respiration, !
! and we convert them to kgC/plant/yr. !
!---------------------------------------------------------------------------!
if (save_daily) then
cpatch%dmean_gpp(ico) = cpatch%today_gpp(ico) &
* umols_2_kgCyr / cpatch%nplant(ico)
cpatch%dmean_leaf_resp(ico) = cpatch%today_leaf_resp(ico) &
* umols_2_kgCyr / cpatch%nplant(ico)
cpatch%dmean_root_resp(ico) = cpatch%today_root_resp(ico) &
* umols_2_kgCyr / cpatch%nplant(ico)
pss_gpp = pss_gpp &
+ cpatch%today_gpp(ico) &
* csite%area(ipa) &
* umols_2_kgCyr
pss_leaf_resp = pss_leaf_resp &
+ cpatch%today_leaf_resp(ico) &
* csite%area(ipa) &
* umols_2_kgCyr
pss_root_resp = pss_root_resp &
+ cpatch%today_root_resp(ico) &
* csite%area(ipa) &
* umols_2_kgCyr
if (c_alloc_flg > 0) then
cpatch%dmean_lassim_resp(ico) = cpatch%today_lassim_resp(ico) &
* umols_2_kgCyr / cpatch%nplant(ico)
end if
if (c13af > 0) then !!!DSC!!!
cpatch%dmean_gpp_C13(ico) = cpatch%today_gpp_C13(ico) &
* umols_2_kgCyr / cpatch%nplant(ico)
cpatch%dmean_leaf_resp_C13(ico) = cpatch%today_leaf_resp_C13(ico) &
* umols_2_kgCyr / cpatch%nplant(ico)
cpatch%dmean_root_resp_C13(ico) = cpatch%today_root_resp_C13(ico) &
* umols_2_kgCyr / cpatch%nplant(ico)
pss_gpp_C13 = pss_gpp_C13 &
+ cpatch%today_gpp_C13(ico) &
* csite%area(ipa) &
* umols_2_kgCyr
pss_leaf_resp_C13 = pss_leaf_resp_C13 &
+ cpatch%today_leaf_resp_C13(ico) &
* csite%area(ipa) &
* umols_2_kgCyr
pss_root_resp_C13 = pss_root_resp_C13 &
+ cpatch%today_root_resp_C13(ico) &
* csite%area(ipa) &
* umols_2_kgCyr
if (c_alloc_flg > 0) then
cpatch%dmean_lassim_resp_C13(ico) = cpatch%today_lassim_resp_C13(ico)&
* umols_2_kgCyr / cpatch%nplant(ico)
end if
end if
end if
!---------------------------------------------------------------------------!
!---------------------------------------------------------------------------!
! We update the following monthly means here because these dmean vari- !
! ables will be discarded before integrate_ed_monthly_output_vars is !
! called. !
!---------------------------------------------------------------------------!
if (save_monthly) then
cpatch%mmean_gpp(ico) = cpatch%mmean_gpp(ico) &
+ cpatch%dmean_gpp(ico)
cpatch%mmean_leaf_resp(ico) = cpatch%mmean_leaf_resp(ico) &
+ cpatch%dmean_leaf_resp(ico)
cpatch%mmean_root_resp(ico) = cpatch%mmean_root_resp(ico) &
+ cpatch%dmean_root_resp(ico)
if (c_alloc_flg > 0) then
cpatch%mmean_lassim_resp(ico)= cpatch%mmean_lassim_resp(ico) &
+ cpatch%dmean_lassim_resp(ico)
end if
if (c13af > 0) then !!!DSC!!!
cpatch%mmean_gpp_C13(ico) = cpatch%mmean_gpp_C13(ico) &
+ cpatch%dmean_gpp_C13(ico)
cpatch%mmean_leaf_resp_C13(ico) = cpatch%mmean_leaf_resp_C13(ico) &
+ cpatch%dmean_leaf_resp_C13(ico)
cpatch%mmean_root_resp_C13(ico) = cpatch%mmean_root_resp_C13(ico) &
+ cpatch%dmean_root_resp_C13(ico)
if (c_alloc_flg > 0) then
cpatch%mmean_lassim_resp_C13(ico)= cpatch%mmean_lassim_resp_C13(ico)&
+ cpatch%dmean_lassim_resp_C13(ico)
end if
end if
end if
!---------------------------------------------------------------------------!
end do cohortloop
!------------------------------------------------------------------------------!
end do patchloop
The first interesting thing to note here is that at the site level the save_monthly block is being conditioned on the save_daily block, whereas at the patch level it is not. While this is not presently problematic it could easily become so; At some point someone may want to re-factor the code to allow for certain monthly outputs which are not derived from daily means, at which point every situation like this will have to be checked.
The second thing to point out is that the additional conditions of c_alloc_flg and c13af, because they overlap with both save_daily and save_monthly as well as each other, require the addition of 6 conditionals, which provides a simple illustration of a point touched upon above; As variable types in the model increase, the number of conditionals required to deal with them increases combinatorially and nesting hierarchies become significantly more complicated. While somewhat unwieldy branching may be a fact of life when working with many conditionals, their dispersion throughout the model is not. It would be quite preferable that conditional decision making be as centralized as possible, for the sake of clarity, parsimony, and the localization of bugs.
Both of these examples reflect a particular aspect of the model's data structures. They are not traversable. The adoption of traversable data structures would substantially reduce the number of lines any developer is required to add in creating a diagnostic variable and facilitate centralized conditional evaluation. One way of accomplishing this is to create a hierarchy of sub-structures to which variables point, replacing the anonymous locations currently created via subroutines like allocate_patchtype. The implementation of these substructures need not necessarily use any more memory than the current (e.g. patchtype) variables; They may simply be indexed locations for the values of those variables. Additionally, the localization of information about manipulating these variables may be accomplished by expanding the content and scope of application of the already extant user defined type var_table.
The primary design principle of object oriented programming is the packaging of data and subroutines that manipulate that data into objects. This packaging is done to affect a partition of code into more or less conceptually self contained elements, with an aim to improve maintainability and clarity while making it structurally more difficult to use data/subroutines inappropriately, i.e. to create bugs. It is likely that this principle can be fruitfully applied to various aspects of ED. For example, in the construction of the iterable containers outlined above, packaging the basic model book-keeping elements as type bound procedures could potentially aid in hiding the details of their implementation from model developers while enhancing model clarity by putting all the interfaces between those implementations and their data in the same place. A type bound procedure could reference the control elements of the sub-patch it's being invoked from and automatically perform the correct calculation.
Of course the utilization of type bound procedures is only one of many potential uses of the new features of the F03/F08 standards. It would also be worth investigating how we might leverage polymorphism and inheritance within the model, both of which are potentially powerful concepts. With regards to inheritance, the model is full of variables that have 'is a' relationships to one another; Root mass is a plant tissue; An early successional hardwood is a hardwood is a tree pft; A carbon-13 variable is a carbon variable.
The code below is a partial implement and illustration of the ideas outlined above, followed by output. It is a work in progress, and is, in particular, a bit messy in dealing with the carbon balance variable in the patchtype mock up. It will be further refined/commented etc over the course of the next few days, assuming ongoing interest.
NOTICE The wiki crams the following code into a window with a low column dimension, but left-right scrolling can be accomplished by clicking the code box and using left/right arrows. Sorry.
!---------------------------------------------------------------------------------------------!
! This program is designed to provide a proof of concept for the idea that ed (patch?) !
! variables can be reworked so that all of the existing code functions properly AND meets the !
! goals that... !
! !
! - adding variables should be conceptually straight-forward and require a minimum of coding !
! to ensure proper functionality in all non-specific respects. (e.g. if a var is a patch !
! variable it should automatically be manipulated in fussion/fission) !
! !
! - we should be capable of iterating over ed structures, which would greatly reduce code !
! size, while improving interpretability, maintainability, and readability !
! !
! - a variable should contain information about it's use and manipulation, obviating the need !
! for a developer to (correctly) make those choices throughout aspects of the model which !
! are not actually of scientific or project-related interest. !
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
! The program 'main' is a series of tests/implementations of the toy version of certain ed !
! subcomponents built in ed_state_vars.
!---------------------------------------------------------------------------------------------!
program main
use ed_state_vars
implicit none
!--- General Local Vars ------------------------------------------------------------------!
type(subpatype), pointer, dimension(:) :: mysubpa ! Sub-patch
type(patchtype) :: mypatch ! Local toy patch structure
logical :: assoc = .true. ! Flag for init_subpa
integer :: i ! Loop index
integer :: ncohorts = 3 ! Number of cohorts
!--- Local Fusion/Fission Vars -----------------------------------------------------------!
integer :: donc ! Donating cohort. (std ED name)
integer :: recc ! Receptor cohort. (std ED name)
real, allocatable, dimension(:) :: nplant ! 'Current' nplant (std ED name)
real, allocatable, dimension(:) :: lai ! 'Current' nplant (std ED name)
real :: newn ! New nplant (std ED name)
!-----------------------------------------------------------------------------------------!
! NOTES: !
! - SUBPATYPE is defined in ed_state_vars. It is my solution to the problem of making !
! an iterator for the 'patchtype' data structure that currently lives in ED. !
! !
! - PATCHTYPE is a mock up of the standard patchtype in ED !
! !
! - ASSOC is a flag to tell init_subpa if it should associate or nullify patch pointers !
! to the sub-patch data structure. !
!-----------------------------------------------------------------------------------------!
!-----------------------------------------------------------------------------------------!
! Allocate and set varprops variable which localizes information about how a variable !
! gets manipulated. It can be deallocated when not required. This particular !
! implenentation is clumsy but illustrates the point. A character matrix that gets !
! tokenized would probably be the most intuitive, easy to manipulate approach. !
!-----------------------------------------------------------------------------------------!
allocate(varprops(mypatch%nvars))
varprops(:)%name = &
['bleaf ', 'broot ', 'bdead ', 'bsapwooda ', &
'bsapwoodb ', 'leaf_resp ', 'today_leaf_resp ', 'dmean_leaf_resp ', &
'mmean_leaf_resp ', 'root_resp ', 'today_root_resp ', 'dmean_root_resp ', &
'mmean_root_resp ', 'cb ']
varprops(:)%init_val = 0
varprops(:)%is_cbvar = [.false.,.false.,.false.,.false.,.false.,.false.,.false.,.false., &
.false.,.false.,.false.,.false.,.false.,.true.]
varprops(:)%val_dim = [1,1,1,1,1,1,1,1,1,1,1,1,1,2]
varprops(1:13)%val_dim_len1 = ncohorts
varprops(14)%val_dim_len1 = 13
varprops(14)%val_dim_len2 = ncohorts
!-----------------------------------------------------------------------------------------!
! Initialize mysubpa and assign values to it, then print it. !
!-----------------------------------------------------------------------------------------!
write(*,*) ''
write(*,*) '-------------------------------------------------------'
write(*,*) ' Testing init_subpa and print_subpa.'
write(*,*) 'Iterating through subpa, allocating, valuing, printing'
write(*,*) '-------------------------------------------------------'
call init_subpa(mysubpa,mypatch%nvars)
do i = 1,mypatch%nvars
if (varprops(i)%val_dim == 1) then
mysubpa(i)%val_1d(1) = 38.0 - i
end if
end do
call print_subpa(mysubpa)
!-----------------------------------------------------------------------------------------!
! Test assoc_subpa fuction which associates a patchtype variable with a sub-patch. This !
! way of associating a patch compresses all the allocate, deallocate, nullify code at the !
! patch level by a factor of 3 and, with the aid of varprops for centrally storing !
! information about variables makes organizing allocations by conditionals unneccessary. !
!-----------------------------------------------------------------------------------------!
write(*,*) ''
write(*,*) '----------------------------------------------------'
write(*,*) ' Testing assoc_subpa association function'
write(*,*) 'Assigning mypatch%bleaf => subpa(-)%val variables'
write(*,*) '----------------------------------------------------'
call assoc_subpa(mysubpa,mypatch,assoc)
write(*,*) 'mypatch%bleaf : ', mypatch%bleaf
write(*,*) 'mypatch%broot : ', mypatch%broot
write(*,*) 'mypatch%bdead : ', mypatch%bdead
write(*,*) 'mypatch%bsapwooda : ', mypatch%bsapwooda
write(*,*) 'mypatch%bsapwoodb : ', mypatch%bsapwoodb
do i=1,mypatch%nvars
if (varprops(i)%val_dim == 1) then
write(*,*) 'i, subpa(i)%name, subpa(i)%val_1d : ', i, mysubpa(i)%name, mysubpa(i)%val_1d
else if (varprops(i)%val_dim == 2) then
write(*,*) 'i, subpa(i)%name, subpa(i)%val_2d : ', i, mysubpa(i)%name, mysubpa(i)%val_2d
end if
end do
!-----------------------------------------------------------------------------------------!
! Test cohort assignments with patch vars are equiv to assigments at sub-patch, just !
! to make sure everything's work properly... !
!-----------------------------------------------------------------------------------------!
write(*,*) ''
write(*,*) '----------------------------------------------------'
write(*,*) ' Testing cohort assigment via patch vars'
write(*,*) '----------------------------------------------------'
mypatch%bleaf (2:3) = [1, 1 ]
mypatch%broot (2:3) = [1, 2 ]
mypatch%bdead (2:3) = [1, 3 ]
mypatch%bsapwooda(2:3) = [1, 4 ]
mypatch%bsapwoodb(2:3) = [1, 5 ]
mypatch%leaf_resp(3) = 10
mypatch%today_root_resp(2) = 20
call print_subpa(mysubpa)
!-----------------------------------------------------------------------------------------!
! Test sub-patch level implementation of cohort fusion.
!-----------------------------------------------------------------------------------------!
write(*,*) ''
write(*,*) '-------------------------------------------------------'
write(*,*) ' Testing cohort fusion loop'
write(*,*) 'This performs (nplant1 *val1 + nplant2 *val2) *newni'
write(*,*) '-------------------------------------------------------'
allocate(lai(ncohorts))
allocate(nplant(ncohorts))
donc = 2
recc = 3
nplant = [2, 1, 1]
lai = [0.387,0.563,0.01]
newn = 2
Write(*,*) 'donc :', donc
Write(*,*) 'recc :', recc
Write(*,*) 'nplant :', nplant(:)
Write(*,*) 'lai :', lai(:)
Write(*,*) 'newn :', newn
do i=1,mypatch%nvars
call mysubpa(i)%fuse(donc,recc,nplant,lai,newn)
end do
call print_subpa(mysubpa)
!-----------------------------------------------------------------------------------------!
! Test assoc_subpa nullify function
!-----------------------------------------------------------------------------------------!
write(*,*) ''
write(*,*) '----------------------------------------------------'
write(*,*) ' Testing assoc_subpa nullify function'
write(*,*) ' For nullifying the patch var names, which should be'
write(*,*) ' nullified before nullifying (via looping) the subpa'
write(*,*) '----------------------------------------------------'
assoc = .false.
call assoc_subpa(mysubpa,mypatch,assoc)
if (associated(mypatch%bleaf )) write(*,*) 'mypatch%bleaf : ', mypatch%bleaf
if (associated(mypatch%broot )) write(*,*) 'mypatch%broot : ', mypatch%broot
if (associated(mypatch%bdead )) write(*,*) 'mypatch%bdead : ', mypatch%bdead
if (associated(mypatch%bsapwooda)) write(*,*) 'mypatch%bsapwooda : ', mypatch%bsapwooda
if (associated(mypatch%bsapwoodb)) write(*,*) 'mypatch%bsapwoodb : ', mypatch%bsapwoodb
if (.not. associated(mypatch%bleaf )) write(*,*) 'mypatch%bleaf : null'
if (.not. associated(mypatch%broot )) write(*,*) 'mypatch%broot : null'
if (.not. associated(mypatch%bdead )) write(*,*) 'mypatch%bdead : null'
if (.not. associated(mypatch%bsapwooda)) write(*,*) 'mypatch%bsapwooda : null'
if (.not. associated(mypatch%bsapwoodb)) write(*,*) 'mypatch%bsapwoodb : null'
if (associated(mysubpa)) then
do i=1,mypatch%nvars
write(*,*) 'i, mysubpa(i)%name, mysubpa(i)%val_1d : ', i, mysubpa(i)%name, mysubpa(i)%val_1d
end do
else
write(*,*) 'mysubpa : null'
end if
end program main
module ed_state_vars
implicit none
!=============================================================================================!
! Module types
!=============================================================================================!
!---------------------------------------------------------------------------------------------!
type varpropstype
!-----------------------------------------------------------------------------------------!
! This type exists to centralize data controlling how subroutines interact with different !
! variables based on their types and properties. Could this be done using polymorphism? !
! Maybe not; Since fortran doesn't support multiple inheritance, the number of types would!
! have to grow combinatorially with the number of properties. Or maybe it could be, if a !
! tree structure was used for typing? !
! !
! In any case, the point is to have a lookup table specifying how variables should be !
! manipulated, which is then interpreted across the model. Note that this already !
! essentially exists in the form of type var_table in module ed_var_tables! As such, my !
! proposal here is really to rework/add to it, and to start using it outside i/o. !
!-----------------------------------------------------------------------------------------!
character(len=16) :: name
logical :: is_avg
logical :: is_cbvar
logical :: is_dmean
logical :: is_mmean
logical :: is_C13
logical :: scale_by_lai
logical :: scale_by_nplant
real :: init_val
integer :: val_dim
integer :: val_dim_len1
integer :: val_dim_len2
end type varpropstype
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
type subpatype
!-----------------------------------------------------------------------------------------!
! The sub-patch type is my solution to making the patch type into a traversable data !
! structure. This has the potential to make big hunks of code MUCH smaller, and to make !
! aspects of the model more conceptually clear, as described elsewhere. It contains the !
! actual values of variables in the patch, as well as info about what to do with them, !
! which should ensure their proper use/propagation. !
! !
! Note that the subpa is not what will be passed around to most routines; The patch type !
! will still interface with most of ED, and as a result there shouldn't be a performance !
! penalty incurred by adopting it. !
!-----------------------------------------------------------------------------------------!
real, pointer, dimension(:) :: val_1d ! dimension( ncohorts), e.g. bleaf
real, pointer, dimension(:,:) :: val_2d ! dimension(:,ncohorts), e.g. cb
logical :: is_avg ! control variable
logical :: is_cbvar ! control variable
logical :: is_dmean ! control variable
logical :: is_mmean ! control variable
logical :: is_C13 ! control variable
logical :: scale_by_lai ! control variable
logical :: scale_by_nplant ! control variable
character(len=16) :: name ! Name in patch pointing to 'val'
contains
!-------------------------------------------------------------------------------------!
! These proceedures implement the cores of various functions of fuse_fiss_utils. !
! 'Aliases' below refer to the subroutine names which these are used in. !
! !
! Why implement the core of these subroutines as type-bound procedures? !
! - They can't be screwed up when you create a new variable !
! - It makes iterating over the sub-patch to apply them more intuitive !
! - It makes it conceptually clear what is happening - patch variables need THIS !
! (below) list of things to happen to them. From a design perspective, this is !
! great, because I know exactly what's going on with this data.
!-------------------------------------------------------------------------------------!
procedure :: create_clone ! Alias: clone_cohort
procedure :: fuse ! Alias: fuse_2_cohorts
! procedure :: rescale ! Alias: split_cohorts, rescale_patches
!-------------------------------------------------------------------------------------!
! NOTE: All of these proceedures could be wrappers for a single proceedure, call it !
! recombine(co1,co2,sc1,sc2,sc3) which scales cohort 1 by sc1, cohort2 by sc2, and !
! their sum by sc3, and assigns this to cohort 1. !
!-------------------------------------------------------------------------------------!
!-------------------------------------------------------------------------------------!
! Some implementations for average_utils !
!-------------------------------------------------------------------------------------!
!procedure :: zero_mo_vars ! Alias: zero_ed_monthly_output_vars
end type subpatype
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
type patchtype
integer :: nvars = 13 ! number of patch vars other than this one.
real, pointer, dimension(:) :: bleaf
real, pointer, dimension(:) :: broot
real, pointer, dimension(:) :: bdead
real, pointer, dimension(:) :: bsapwooda
real, pointer, dimension(:) :: bsapwoodb
real, pointer, dimension(:) :: leaf_resp
real, pointer, dimension(:) :: root_resp
real, pointer, dimension(:) :: today_leaf_resp
real, pointer, dimension(:) :: today_root_resp
real, pointer, dimension(:) :: dmean_leaf_resp
real, pointer, dimension(:) :: dmean_root_resp
real, pointer, dimension(:) :: mmean_leaf_resp
real, pointer, dimension(:) :: mmean_root_resp
real, pointer, dimension(:,:) :: cb
end type patchtype
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
type sitetype
type(patchtype), pointer :: patch
end type sitetype
!---------------------------------------------------------------------------------------------!
!=============================================================================================!
! Module Namespace
!=============================================================================================!
type(varpropstype), allocatable, dimension(:) :: varprops
contains
!=============================================================================================!
! Type Bound Proceedures
!=============================================================================================!
!---------------------------------------------------------------------------------------------!
subroutine create_clone(subpa,isc,idt)
implicit none
!--- Arguments -----------------------------------------------------------------------!
class(subpatype) :: subpa ! Sub-Patch
integer :: isc ! Index of "Source" cohort
integer :: idt ! Index of "Destination" cohort"
!--- Local Vars ----------------------------------------------------------------------!
integer :: imonth
!-------------------------------------------------------------------------------------!
if (subpa%is_cbvar) then
do imonth = 1,13
subpa%val_2d(imonth,idt) = subpa%val_2d(imonth,isc)
end do
else
subpa%val_1d(idt) = subpa%val_1d(isc)
end if
end subroutine create_clone
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
subroutine fuse(subpa,donc,recc,nplant,lai,newn)
implicit none
!--- Arguments -----------------------------------------------------------------------!
! Note: Some of these are real in fuse_fiss, but seem like they should be ints...
!-------------------------------------------------------------------------------------!
class(subpatype) :: subpa ! Sub-Patch
integer :: donc ! Donating cohort.
integer :: recc ! Receptor cohort.
real, dimension(:) :: nplant ! 'Current' nplant
real, dimension(:) :: lai ! 'Current' nplant
real :: newn ! New nplant
!--- Local Vars ----------------------------------------------------------------------!
integer :: imonth
real :: newni
real :: newlaii
!-------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------!
! Find the scaling factor for variables that are not "extensive". !
! - If the unit is X/plant, then we scale by nplant. !
! - If the unit is X/m2_leaf, then we scale by LAI. !
! - If the unit is X/m2_gnd, then we add, since they are "extensive". !
!------------------------------------------------------------------------------------!
newni = 1.0 / newn
if (lai(recc) + lai(donc) > 0.0) then
newlaii = 1.0 / (lai(recc) + lai(donc))
else
newlaii = 0.0
end if
!------------------------------------------------------------------------------------!
if (subpa%is_cbvar) then
do imonth = 1,13
subpa%val_2d(imonth,recc) = (nplant(recc) *subpa%val_2d(imonth,recc) &
+ nplant(donc) *subpa%val_2d(imonth,donc) ) * newni
end do
else
subpa%val_1d(recc) = (nplant(recc) *subpa%val_1d(recc) &
+ nplant(donc) *subpa%val_1d(donc) ) * newni
end if
end subroutine fuse
!---------------------------------------------------------------------------------------------!
!=============================================================================================!
! Module Subroutines
!=============================================================================================!
!---------------------------------------------------------------------------------------------!
! THIS SUBROUTINE, assoc_subpa should be one of only three places variables need to be !
! manually added to the model (to achieve basic functionality), along with addition to the !
! type construct, and the varprop assigment. It is really just a casing wrapper for the SR !
! assoc_null() found below. !
!---------------------------------------------------------------------------------------------!
subroutine assoc_subpa(subpa,patch,assoc)
implicit none
type(subpatype), pointer, dimension(:) :: subpa
type(patchtype) :: patch
logical :: assoc
integer :: i
do i = 1,size(subpa)
select case(subpa(i)%name)
case('bleaf' ); call assoc_null(subpa(i),assoc, d1var = patch%bleaf )
case('broot' ); call assoc_null(subpa(i),assoc, d1var = patch%broot )
case('bdead' ); call assoc_null(subpa(i),assoc, d1var = patch%bdead )
case('bsapwooda' ); call assoc_null(subpa(i),assoc, d1var = patch%bsapwooda )
case('bsapwoodb' ); call assoc_null(subpa(i),assoc, d1var = patch%bsapwoodb )
case('leaf_resp' ); call assoc_null(subpa(i),assoc, d1var = patch%leaf_resp )
case('root_resp' ); call assoc_null(subpa(i),assoc, d1var = patch%root_resp )
case('today_leaf_resp'); call assoc_null(subpa(i),assoc, d1var = patch%today_leaf_resp)
case('today_root_resp'); call assoc_null(subpa(i),assoc, d1var = patch%today_root_resp)
case('dmean_leaf_resp'); call assoc_null(subpa(i),assoc, d1var = patch%dmean_leaf_resp)
case('dmean_root_resp'); call assoc_null(subpa(i),assoc, d1var = patch%dmean_root_resp)
case('mmean_leaf_resp'); call assoc_null(subpa(i),assoc, d1var = patch%mmean_leaf_resp)
case('mmean_root_resp'); call assoc_null(subpa(i),assoc, d1var = patch%mmean_root_resp)
case('cb' ); call assoc_null(subpa(i),assoc, d2var = patch%cb )
case default
write (*,*) 'Error: Nothing associated in subpatype...'
end select
end do
!-------------------------------------------------------------------------------------!
! Deallocating subpatch can be done here if there is no instance in which we want to !
! keep it around while dropping patchtype pointers, otherwise can be done elsewhere !
!-------------------------------------------------------------------------------------!
if ( .not. assoc) then
deallocate(subpa)
end if
end subroutine assoc_subpa
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
! Associates individual patch variables with sub-patch values.
!---------------------------------------------------------------------------------------------!
subroutine assoc_null(subpa,assoc,d1var,d2var)
implicit none
type(subpatype), target :: subpa ! subpatch variable
logical :: assoc ! Associating, or nullifying?
real, pointer, optional, dimension(:) :: d1var ! Dimension 1 patch variable
real, pointer, optional, dimension(:,:) :: d2var ! Dimension 2 patch variable
if (assoc) then
if (present(d1var)) then
d1var => subpa%val_1d
else if (present(d2var)) then
d2var => subpa%val_2d
end if
else
if (present(d1var)) then
nullify(d1var)
else if (present(d2var)) then
nullify(d2var)
end if
end if
end subroutine assoc_null
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
subroutine init_subpa(subpa,subpa_dim)
implicit none
type(subpatype),pointer, dimension(:) :: subpa
integer :: i
integer :: j
integer :: k
integer :: subpa_dim
allocate(subpa(subpa_dim))
do i = 1,subpa_dim
!--------------------------------------------------------------------------------!
! Allocate dimensions of sub patch type depending on the variable's spec. in !
! the 'varprop' variable. !
!--------------------------------------------------------------------------------!
subpa(i)%name = trim(varprops(i)%name)
select case(varprops(i)%val_dim)
case(1)
allocate(subpa(i)%val_1d(varprops(i)%val_dim_len1))
do j = 1,varprops(i)%val_dim_len1
subpa(i)%val_1d(j) = varprops(i)%init_val
end do
case(2)
allocate(subpa(i)%val_2d(varprops(i)%val_dim_len1,varprops(i)%val_dim_len2))
do k = 1,varprops(i)%val_dim_len1
do j = 1,varprops(i)%val_dim_len2
subpa(i)%val_2d(k,j) = varprops(i)%init_val
end do
end do
end select
end do
end subroutine init_subpa
!---------------------------------------------------------------------------------------------!
!---------------------------------------------------------------------------------------------!
subroutine print_subpa(subpa)
implicit none
type(subpatype), dimension(:) :: subpa
integer :: i
integer :: j
do i = 1,size(subpa)
if (associated(subpa(i)%val_1d)) then
write(*,*) 'subpa(i)%name, subpa(i)%val_1d(:) : ', subpa(i)%name, subpa(i)%val_1d(:)
else if (associated(subpa(i)%val_2d)) then
do j = 1,size(subpa(i)%val_2d(:,1))
if (j == 1) then
write(*,*) 'subpa(i)%name, subpa(i)%val_2d(:,:) : ', subpa(i)%name, subpa(i)%val_2d(j,:)
else
write(*,*) ' : ', subpa(i)%name, subpa(i)%val_2d(j,:)
end if
end do
end if
end do
end subroutine print_subpa
!---------------------------------------------------------------------------------------------!
end module ed_state_vars
The output this code presently produces is as follows:
-------------------------------------------------------
Testing init_subpa and print_subpa.
Iterating through subpa, allocating, valuing, printing
-------------------------------------------------------
subpa(i)%name, subpa(i)%val_1d(:) : bleaf 37.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : broot 36.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bdead 35.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bsapwooda 34.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bsapwoodb 33.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : leaf_resp 32.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : today_leaf_resp 31.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : dmean_leaf_resp 30.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : mmean_leaf_resp 29.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : root_resp 28.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : today_root_resp 27.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : dmean_root_resp 26.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : mmean_root_resp 25.0000000 0.00000000 0.00000000
----------------------------------------------------
Testing assoc_subpa association function
Assigning mypatch%bleaf => subpa(-)%val variables
----------------------------------------------------
mypatch%bleaf : 37.0000000 0.00000000 0.00000000
mypatch%broot : 36.0000000 0.00000000 0.00000000
mypatch%bdead : 35.0000000 0.00000000 0.00000000
mypatch%bsapwooda : 34.0000000 0.00000000 0.00000000
mypatch%bsapwoodb : 33.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 1 bleaf 37.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 2 broot 36.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 3 bdead 35.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 4 bsapwooda 34.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 5 bsapwoodb 33.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 6 leaf_resp 32.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 7 today_leaf_resp 31.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 8 dmean_leaf_resp 30.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 9 mmean_leaf_resp 29.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 10 root_resp 28.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 11 today_root_resp 27.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 12 dmean_root_resp 26.0000000 0.00000000 0.00000000
i, subpa(i)%name, subpa(i)%val_1d : 13 mmean_root_resp 25.0000000 0.00000000 0.00000000
----------------------------------------------------
Testing cohort assigment via patch vars
----------------------------------------------------
subpa(i)%name, subpa(i)%val_1d(:) : bleaf 37.0000000 1.00000000 1.00000000
subpa(i)%name, subpa(i)%val_1d(:) : broot 36.0000000 1.00000000 2.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bdead 35.0000000 1.00000000 3.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bsapwooda 34.0000000 1.00000000 4.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bsapwoodb 33.0000000 1.00000000 5.00000000
subpa(i)%name, subpa(i)%val_1d(:) : leaf_resp 32.0000000 0.00000000 10.0000000
subpa(i)%name, subpa(i)%val_1d(:) : today_leaf_resp 31.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : dmean_leaf_resp 30.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : mmean_leaf_resp 29.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : root_resp 28.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : today_root_resp 27.0000000 20.0000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : dmean_root_resp 26.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : mmean_root_resp 25.0000000 0.00000000 0.00000000
-------------------------------------------------------
Testing cohort fusion loop
This performs (nplant1 *val1 + nplant2 *val2) *newni
-------------------------------------------------------
donc : 2
recc : 3
nplant : 2.00000000 1.00000000 1.00000000
lai : 0.386999995 0.563000023 9.99999978E-03
newn : 2.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bleaf 37.0000000 1.00000000 1.00000000
subpa(i)%name, subpa(i)%val_1d(:) : broot 36.0000000 1.00000000 1.50000000
subpa(i)%name, subpa(i)%val_1d(:) : bdead 35.0000000 1.00000000 2.00000000
subpa(i)%name, subpa(i)%val_1d(:) : bsapwooda 34.0000000 1.00000000 2.50000000
subpa(i)%name, subpa(i)%val_1d(:) : bsapwoodb 33.0000000 1.00000000 3.00000000
subpa(i)%name, subpa(i)%val_1d(:) : leaf_resp 32.0000000 0.00000000 5.00000000
subpa(i)%name, subpa(i)%val_1d(:) : today_leaf_resp 31.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : dmean_leaf_resp 30.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : mmean_leaf_resp 29.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : root_resp 28.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : today_root_resp 27.0000000 20.0000000 10.0000000
subpa(i)%name, subpa(i)%val_1d(:) : dmean_root_resp 26.0000000 0.00000000 0.00000000
subpa(i)%name, subpa(i)%val_1d(:) : mmean_root_resp 25.0000000 0.00000000 0.00000000
----------------------------------------------------
Testing assoc_subpa nullify function
For nullifying the patch var names, which should be
nullified before nullifying (via looping) the subpa
----------------------------------------------------
mypatch%bleaf : null
mypatch%broot : null
mypatch%bdead : null
mypatch%bsapwooda : null
mypatch%bsapwoodb : null
mysubpa : null
Two Portland Group articles illustrating some of the basic OOP features in Fortran, related discussion, and an article about updating fortran code. Mainline ED doesn't seem to have any of the problematic features, as noted above.
- http://www.pgroup.com/lit/articles/insider/v3n1a3.htm
- http://www.pgroup.com/lit/articles/insider/v3n2a2.htm
- http://fortranwiki.org/fortran/show/OOP+discussion
- http://fortranwiki.org/fortran/show/Modernizing+Old+Fortran
A bunch of information on the compatibility of new standard code with GNU compilers.
- http://gcc.gnu.org/wiki/Fortran2008Status
- http://gcc.gnu.org/wiki/Fortran2003Status
- https://gcc.gnu.org/onlinedocs/gfortran/Fortran-2008-status.html
- https://gcc.gnu.org/wiki/GFortran/News#GCC4.10
- http://fortranwiki.org/fortran/show/Fortran+2003+status
- http://fortranwiki.org/fortran/show/Fortran+2008+status
A bunch of basic things to know about programming paradigms, i.e. useful background and food for thought on code structure.