Skip to content

Updating to F03 F08, Iterators for Data Structures

DanielNScott edited this page May 19, 2014 · 10 revisions

Overview:

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.

The Case for Implementing a Traversable Data Structure:

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.

Potential Use of OOP:

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.

A Proof Of Concept:

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

Resources, Links, Etc.

OOP in FTN03/08:

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.

Compiler Status:

A bunch of information on the compatibility of new standard code with GNU compilers.

Background/Concepts:

A bunch of basic things to know about programming paradigms, i.e. useful background and food for thought on code structure.