text:
!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine getnodesinitetmesh(ne,lakon,ipkon,kon,istartset,
     &     iendset,ialset,set,nset,filab,inodestet,nnodestet,
     &     nodface,ipoface,nk)
!
!     reading the initial tet mesh which will be refined
!
      implicit none
!
      character*8 lakon(*)
      character*81 set(*),elset
      character*87 filab(*)
!
      integer ipkon(*),kon(*),istartset(*),iendset(*),ialset(*),
     &     inodestet(*),nnodestet,i,j,k,m,node,ne,nset,indexe,id,
     &     nodface(5,*),ipoface(*),nodes(3),ifree,ithree,kflag,indexold,
     &     index,ifreenew,iel,iset,j1,nk,iaux,ifacet(6,4)
!
!     nodes belonging to the element faces
!
      data ifacet /1,3,2,7,6,5,
     &     1,2,4,5,9,8,
     &     2,3,4,6,10,9,
     &     1,4,3,8,10,7/
!
      kflag=1
      ithree=3
!
!     identify the set name/s if they exist
!
      read(filab(48)(27:87),'(a61)') elset(1:61)
!
      do i=62,81
        elset(i:i)=' '
      enddo
!
      call cident81(set,elset,nset,id)
      iset=nset+1
      if(id.gt.0) then
        if(elset.eq.set(id)) then
          iset=id
        endif
      endif
!
!     determining the external element faces of the unrefined mesh
!     the faces are catalogued by the three lowes nodes numbers
!     in ascending order. ipoface(i) points to a face for which
!     node i is the lowest node and nodface(1,ipoface(i)) and
!     nodface(2,ipoface(i)) are the next lower ones.
!     nodface(3,ipoface(i)) contains the element number,
!     nodface(4,ipoface(i)) the face number and nodface(5,ipoface(i))
!     is a pointer to the next surface for which node i is the
!     lowest node; if there are no more such surfaces the pointer
!     has the value zero
!     An external element face is one which belongs to one element
!     only
!
      ifree=1
      do i=1,4*ne-1
        nodface(5,i)=i+1
      enddo
!
      if(iset.le.nset) then
        do j1=istartset(iset),iendset(iset)
          if(ialset(j1).gt.0) then
            i=ialset(j1)
!
!     the elements belonging to the unrefined mesh have been deactivated,
!     i.e. the transformation ipkon(k)=-2-ipkon(k) was performed in
!     modelchanges.f
!
            indexe=-2-ipkon(i)
            if(indexe.lt.0) cycle
            if((lakon(i)(1:4).eq.'C3D4').or.
     &           (lakon(i)(1:5).eq.'C3D10')) then
              do j=1,4
                do k=1,3
                  nodes(k)=kon(indexe+ifacet(k,j))
                enddo
                call isortii(nodes,iaux,ithree,kflag)
                indexold=0
                index=ipoface(nodes(1))
                do
!
!     adding a surface which has not been
!     catalogued so far
!
                  if(index.eq.0) then
                    ifreenew=nodface(5,ifree)
                    nodface(1,ifree)=nodes(2)
                    nodface(2,ifree)=nodes(3)
                    nodface(3,ifree)=i
                    nodface(4,ifree)=j
                    nodface(5,ifree)=ipoface(nodes(1))
                    ipoface(nodes(1))=ifree
                    ifree=ifreenew
                    exit
                  endif
!
!     removing a surface which has already
!     been catalogued
!
                  if((nodface(1,index).eq.nodes(2)).and.
     &                 (nodface(2,index).eq.nodes(3))) then
                    if(indexold.eq.0) then
                      ipoface(nodes(1))=nodface(5,index)
                    else
                      nodface(5,indexold)=nodface(5,index)
                    endif
                    nodface(5,index)=ifree
                    ifree=index
                    exit
                  endif
                  indexold=index
                  index=nodface(5,index)
                enddo
              enddo
            endif
          endif
        enddo
      else
        do i=1,ne
!
!     the elements belonging to the unrefined mesh have been deactivated,
!     i.e. the transformation ipkon(k)=-2-ipkon(k) was performed in
!     modelchanges.f
!
          indexe=-2-ipkon(i)
          if(indexe.lt.0) cycle
          if((lakon(i)(1:4).eq.'C3D4').or.
     &         (lakon(i)(1:5).eq.'C3D10')) then
            do j=1,4
              do k=1,3
                nodes(k)=kon(indexe+ifacet(k,j))
              enddo
              call isortii(nodes,iaux,ithree,kflag)
              indexold=0
              index=ipoface(nodes(1))
              do
!
!     adding a surface which has not been
!     catalogued so far
!
                if(index.eq.0) then
                  ifreenew=nodface(5,ifree)
                  nodface(1,ifree)=nodes(2)
                  nodface(2,ifree)=nodes(3)
                  nodface(3,ifree)=i
                  nodface(4,ifree)=j
                  nodface(5,ifree)=ipoface(nodes(1))
                  ipoface(nodes(1))=ifree
                  ifree=ifreenew
                  exit
                endif
!
!     removing a surface which has already
!     been catalogued
!
                if((nodface(1,index).eq.nodes(2)).and.
     &               (nodface(2,index).eq.nodes(3))) then
                  if(indexold.eq.0) then
                    ipoface(nodes(1))=nodface(5,index)
                  else
                    nodface(5,indexold)=nodface(5,index)
                  endif
                  nodface(5,index)=ifree
                  ifree=index
                  exit
                endif
                indexold=index
                index=nodface(5,index)
              enddo
            enddo
          endif
        enddo
      endif
!
!     storing the nodes belonging to the external faces in inodestet
!
      do i=1,nk
        index=ipoface(i)
        do
          if(index.eq.0) exit
          iel=nodface(3,index)
          j=nodface(4,index)
          indexe=-2-ipkon(iel)
          if(lakon(iel)(4:4).eq.'4') then
            do k=1,3
              node=kon(indexe+ifacet(k,j))
              call nident(inodestet,node,nnodestet,id)
              if(id.gt.0) then
                if(inodestet(id).eq.node) cycle
              endif
              nnodestet=nnodestet+1
              do m=nnodestet,id+2,-1
                inodestet(m)=inodestet(m-1)
              enddo
              inodestet(id+1)=node
            enddo
          else
            do k=1,6
              node=kon(indexe+ifacet(k,j))
              call nident(inodestet,node,nnodestet,id)
              if(id.gt.0) then
                if(inodestet(id).eq.node) cycle
              endif
              nnodestet=nnodestet+1
              do m=nnodestet,id+2,-1
                inodestet(m)=inodestet(m-1)
              enddo
              inodestet(id+1)=node
            enddo
          endif
          index=nodface(5,index)
        enddo
      enddo
!
      return
      end

ext: f

max_stars_repo_name: alleindrach/calculix-desktop

max_issues_repo_name: alleindrach/calculix-desktop

max_forks_repo_name: alleindrach/calculix-desktop


text:
      subroutine xpand (xx)
c
c     ******************************************************************
c     *                                                                *
c     *   generates a coarser mesh by taking alternate points          *
c     *                                                                *
c     ******************************************************************
c
      use dims
      use dimsc
c
c     ******************************************************************
c
      use mesh_var
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
      real, dimension(iil,jjl,2)           :: xx
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,j,ii,jj
c
c     ******************************************************************
c
         jj        = 0
      do j=1,jl,2
         jj        = jj  +1
         ii        = 0
      do i=1,il,2
         ii        = ii  +1
         xx(ii,jj,1)  = x(i,j,1)
         xx(ii,jj,2)  = x(i,j,2)
      end do
      end do

      return

      end

max_stars_repo_name: AlexT-L/RANS

max_issues_repo_name: AlexT-L/RANS

max_forks_repo_name: AlexT-L/RANS


text:
! { dg-do run }
! { dg-options "-fbackslash" }

  logical, parameter :: bigendian = transfer ((/1_1,0_1,0_1,0_1/), 0_4) /= 1

  character(kind=1,len=3) :: s1, t1, u1
  character(kind=4,len=3) :: s4, t4, u4

  ! Test MERGE intrinsic

  call check_merge1 ("foo", "gee", .true., .false.)
  call check_merge4 (4_"foo", 4_"gee", .true., .false.)

  if (merge ("foo", "gee", .true.) /= "foo") call abort
  if (merge ("foo", "gee", .false.) /= "gee") call abort
  if (merge (4_"foo", 4_"gee", .true.) /= 4_"foo") call abort
  if (merge (4_"foo", 4_"gee", .false.) /= 4_"gee") call abort

  ! Test TRANSFER intrinsic

  if (bigendian) then
    if (transfer (4_"x", "    ") /= "\0\0\0x") call abort
  else
    if (transfer (4_"x", "    ") /= "x\0\0\0") call abort
  endif
  if (transfer (4_"\U44444444", "    ") /= "\x44\x44\x44\x44") call abort
  if (transfer (4_"\U3FE91B5A", 0_4) /= int(z'3FE91B5A', 4)) call abort

  call check_transfer_i (4_"\U3FE91B5A", [int(z'3FE91B5A', 4)])
  call check_transfer_i (4_"\u1B5A", [int(z'1B5A', 4)])

contains

  subroutine check_merge1 (s1, t1, t, f)
    character(kind=1,len=*) :: s1, t1
    logical :: t, f

    if (merge (s1, t1, .true.) /= s1) call abort
    if (merge (s1, t1, .false.) /= t1) call abort
    if (len (merge (s1, t1, .true.)) /= len (s1)) call abort
    if (len (merge (s1, t1, .false.)) /= len (t1)) call abort
    if (len_trim (merge (s1, t1, .true.)) /= len_trim (s1)) call abort
    if (len_trim (merge (s1, t1, .false.)) /= len_trim (t1)) call abort

    if (merge (s1, t1, t) /= s1) call abort
    if (merge (s1, t1, f) /= t1) call abort
    if (len (merge (s1, t1, t)) /= len (s1)) call abort
    if (len (merge (s1, t1, f)) /= len (t1)) call abort
    if (len_trim (merge (s1, t1, t)) /= len_trim (s1)) call abort
    if (len_trim (merge (s1, t1, f)) /= len_trim (t1)) call abort

  end subroutine check_merge1

  subroutine check_merge4 (s4, t4, t, f)
    character(kind=4,len=*) :: s4, t4
    logical :: t, f

    if (merge (s4, t4, .true.) /= s4) call abort
    if (merge (s4, t4, .false.) /= t4) call abort
    if (len (merge (s4, t4, .true.)) /= len (s4)) call abort
    if (len (merge (s4, t4, .false.)) /= len (t4)) call abort
    if (len_trim (merge (s4, t4, .true.)) /= len_trim (s4)) call abort
    if (len_trim (merge (s4, t4, .false.)) /= len_trim (t4)) call abort

    if (merge (s4, t4, t) /= s4) call abort
    if (merge (s4, t4, f) /= t4) call abort
    if (len (merge (s4, t4, t)) /= len (s4)) call abort
    if (len (merge (s4, t4, f)) /= len (t4)) call abort
    if (len_trim (merge (s4, t4, t)) /= len_trim (s4)) call abort
    if (len_trim (merge (s4, t4, f)) /= len_trim (t4)) call abort

  end subroutine check_merge4

  subroutine check_transfer_i (s, i)
    character(kind=4,len=*) :: s
    integer(kind=4), dimension(len(s)) :: i

    if (transfer (s, 0_4) /= ichar (s(1:1))) call abort
    if (transfer (s, 0_4) /= i(1)) call abort
    if (any (transfer (s, [0_4]) /= i)) call abort
    if (any (transfer (s, 0_4, len(s)) /= i)) call abort

  end subroutine check_transfer_i

end

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
	subroutine sub
	equivalence(i(1),j(3))
	integer,save::i(3),j(3)
	i(1)=2
	end subroutine

max_stars_repo_name: xevolver/xevxml

max_issues_repo_name: xevolver/xevxml

max_forks_repo_name: xevolver/xevxml


MODULE Registerzadokmod
    USE list_sub
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_registerzadok(cumulTT, &
        phase, &
        leafNumber, &
        calendarMoments, &
        calendarDates, &
        calendarCumuls, &
        cumulTTFromZC_65, &
        currentdate, &
        der, &
        slopeTSFLN, &
        intTSFLN, &
        finalLeafNumber, &
        currentZadokStage, &
        hasZadokStageChanged_t1, &
        sowingDate, &
        hasZadokStageChanged)
        IMPLICIT NONE
        REAL, INTENT(IN) :: cumulTT
        REAL, INTENT(IN) :: phase
        REAL, INTENT(IN) :: leafNumber
        CHARACTER(65), ALLOCATABLE , DIMENSION(:), INTENT(INOUT) ::  &
                calendarMoments
        CHARACTER(65), ALLOCATABLE , DIMENSION(:), INTENT(INOUT) ::  &
                calendarDates
        REAL, ALLOCATABLE , DIMENSION(:), INTENT(INOUT) :: calendarCumuls
        REAL, INTENT(IN) :: cumulTTFromZC_65
        CHARACTER(65), INTENT(IN) :: currentdate
        REAL, INTENT(IN) :: der
        REAL, INTENT(IN) :: slopeTSFLN
        REAL, INTENT(IN) :: intTSFLN
        REAL, INTENT(IN) :: finalLeafNumber
        CHARACTER(65), INTENT(INOUT) :: currentZadokStage
        INTEGER, INTENT(IN) :: hasZadokStageChanged_t1
        CHARACTER(65), INTENT(IN) :: sowingDate
        INTEGER, INTENT(OUT) :: hasZadokStageChanged
        INTEGER:: roundedFinalLeafNumber
        !- Description:
    !            * Title: RegisterZadok Model
    !            * Author: Pierre MARTRE
    !            * Reference: Modeling development phase in the
    !                Wheat Simulation Model SiriusQuality.
    !                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    !            * Institution: INRA/LEPSE Montpellier
    !            * Abstract: Record the zadok stage in the calendar
    !
        !- inputs:
    !            * name: cumulTT
    !                          ** description :
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** min : -200
    !                          ** max : 10000
    !                          ** default : 354.582294511779
    !                          ** unit : °C d
    !                          ** uri : some url
    !                          ** inputtype : variable
    !            * name: phase
    !                          ** description : instance of the phase class . You can get the name of the phase using phase.getPhaseAsString(PhaseValue)
    !                          ** variablecategory : state
    !                          ** inputtype : variable
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 7
    !                          ** default : 2
    !                          ** unit :
    !                          ** uri : some url
    !            * name: leafNumber
    !                          ** description : Actual number of phytomers
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 25
    !                          ** default : 4.8854219661087575
    !                          ** unit : leaf
    !                          ** uri : some url
    !                          ** inputtype : variable
    !            * name: calendarMoments
    !                          ** description : List containing apparition of each stage
    !                          ** variablecategory : state
    !                          ** datatype : STRINGLIST
    !                          ** default : ['Sowing']
    !                          ** unit :
    !                          ** inputtype : variable
    !            * name: calendarDates
    !                          ** description : List containing  the dates of the wheat developmental phases
    !                          ** variablecategory : state
    !                          ** datatype : DATELIST
    !                          ** default : ['2007/3/21']
    !                          ** unit :
    !                          ** inputtype : variable
    !            * name: calendarCumuls
    !                          ** description : list containing for each stage occured its cumulated thermal times
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLELIST
    !                          ** default : [0.0]
    !                          ** unit : °C d
    !                          ** inputtype : variable
    !            * name: cumulTTFromZC_65
    !                          ** description : cumul of the thermal time (DeltaTT) since the moment ZC_65
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** min : -200
    !                          ** max : 10000
    !                          ** default : 0
    !                          ** unit : °C d
    !                          ** uri : some url
    !                          ** inputtype : variable
    !            * name: currentdate
    !                          ** description : current date
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DATE
    !                          ** min :
    !                          ** max :
    !                          ** default : 2007/4/9
    !                          ** unit :
    !                          ** uri : some url
    !                          ** inputtype : variable
    !            * name: der
    !                          ** description : Duration of the endosperm endoreduplication phase
    !                          ** parametercategory : species
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** default : 300.0
    !                          ** unit : °C d
    !                          ** uri : some url
    !                          ** inputtype : parameter
    !            * name: slopeTSFLN
    !                          ** description : used to calculate Terminal spikelet
    !                          ** parametercategory : species
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** default : 0.9
    !                          ** unit :
    !                          ** uri : some url
    !                          ** inputtype : parameter
    !            * name: intTSFLN
    !                          ** description : used to calculate Terminal spikelet
    !                          ** parametercategory : species
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** default : 0.9
    !                          ** unit :
    !                          ** uri : some url
    !                          ** inputtype : parameter
    !            * name: finalLeafNumber
    !                          ** description : final leaf number
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** default : 8.797582013199484
    !                          ** unit : leaf
    !                          ** uri : some url
    !                          ** inputtype : variable
    !            * name: currentZadokStage
    !                          ** description : current zadok stage
    !                          ** variablecategory : state
    !                          ** datatype : STRING
    !                          ** min :
    !                          ** max :
    !                          ** default : MainShootPlus1Tiller
    !                          ** unit :
    !                          ** uri : some url
    !                          ** inputtype : variable
    !            * name: hasZadokStageChanged_t1
    !                          ** description : true if the zadok stage has changed this time step
    !                          ** variablecategory : state
    !                          ** datatype : INT
    !                          ** min : 0
    !                          ** max : 1
    !                          ** default : 0
    !                          ** unit :
    !                          ** uri : some url
    !                          ** inputtype : variable
    !            * name: sowingDate
    !                          ** description :  Date of Sowing
    !                          ** parametercategory : constant
    !                          ** datatype : DATE
    !                          ** min :
    !                          ** max :
    !                          ** default : 2007/3/21
    !                          ** unit :
    !                          ** inputtype : parameter
        !- outputs:
    !            * name: hasZadokStageChanged
    !                          ** description : true if the zadok stage has changed this time step
    !                          ** variablecategory : state
    !                          ** datatype : INT
    !                          ** min : 0
    !                          ** max : 1
    !                          ** unit :
    !                          ** uri : some url
    !            * name: currentZadokStage
    !                          ** description : current zadok stage
    !                          ** variablecategory : state
    !                          ** datatype : STRING
    !                          ** unit :
    !                          ** uri : some url
    !            * name: calendarMoments
    !                          ** description :  List containing apparition of each stage
    !                          ** variablecategory : state
    !                          ** datatype : STRINGLIST
    !                          ** unit :
    !            * name: calendarDates
    !                          ** description :  List containing  the dates of the wheat developmental phases
    !                          ** variablecategory : state
    !                          ** datatype : DATELIST
    !                          ** unit :
    !            * name: calendarCumuls
    !                          ** description :  list containing for each stage occured its cumulated thermal times
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLELIST
    !                          ** unit : °C d
        roundedFinalLeafNumber = INT(finalLeafNumber + 0.5)
        IF(leafNumber .GE. 4.0 .AND. ALL(calendarMoments .NE.  &
                'MainShootPlus1Tiller')) THEN
            call Add(calendarMoments, 'MainShootPlus1Tiller')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = 'MainShootPlus1Tiller'
        ELSE IF ( leafNumber .GE. 5.0 .AND. ALL(calendarMoments .NE.  &
                'MainShootPlus2Tiller')) THEN
            call Add(calendarMoments, 'MainShootPlus2Tiller')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = 'MainShootPlus2Tiller'
        ELSE IF ( leafNumber .GE. 6.0 .AND. ALL(calendarMoments .NE.  &
                'MainShootPlus3Tiller')) THEN
            call Add(calendarMoments, 'MainShootPlus3Tiller')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = 'MainShootPlus3Tiller'
        ELSE IF ( finalLeafNumber .GT. 0.0 .AND. (leafNumber .GE. slopeTSFLN  &
                * finalLeafNumber - intTSFLN .AND. ALL(calendarMoments .NE.  &
                'TerminalSpikelet'))) THEN
            call Add(calendarMoments, 'TerminalSpikelet')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = 'TerminalSpikelet'
        ELSE IF ( leafNumber .GE. roundedFinalLeafNumber - 4.0 .AND.  &
                roundedFinalLeafNumber - 4 .GT. 0 .AND. ALL(calendarMoments .NE.  &
                'PseudoStemErection')) THEN
            call Add(calendarMoments, 'PseudoStemErection')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = 'PseudoStemErection'
        ELSE IF ( leafNumber .GE. roundedFinalLeafNumber - 3.0 .AND.  &
                roundedFinalLeafNumber - 3 .GT. 0 .AND. ALL(calendarMoments .NE.  &
                '1stNodeDetectable')) THEN
            call Add(calendarMoments, '1stNodeDetectable')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = '1stNodeDetectable'
        ELSE IF ( leafNumber .GE. roundedFinalLeafNumber - 2.0 .AND.  &
                roundedFinalLeafNumber - 2 .GT. 0 .AND. ALL(calendarMoments .NE.  &
                '2ndNodeDetectable')) THEN
            call Add(calendarMoments, '2ndNodeDetectable')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = '2ndNodeDetectable'
        ELSE IF ( leafNumber .GE. roundedFinalLeafNumber - 1.0 .AND.  &
                roundedFinalLeafNumber - 1 .GT. 0 .AND. ALL(calendarMoments .NE.  &
                'FlagLeafJustVisible')) THEN
            call Add(calendarMoments, 'FlagLeafJustVisible')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = 'FlagLeafJustVisible'
        ELSE IF ( ALL(calendarMoments .NE. 'MidGrainFilling') .AND. (phase  &
                .EQ. 4.5 .AND. cumulTTFromZC_65 .GE. der)) THEN
            call Add(calendarMoments, 'MidGrainFilling')
            call Add(calendarCumuls, cumulTT)
            call Add(calendarDates, currentdate)
            hasZadokStageChanged = 1
            currentZadokStage = 'MidGrainFilling'
        ELSE
            hasZadokStageChanged = 0
        END IF
    END SUBROUTINE model_registerzadok

END MODULE


text:
module halfspace
  !-----------------------------------------------------------------------------
  ! Module: halfspace
  !  This modules contains subroutines specific to problems with a halfspace
  !  geometry.
  !
  ! Subroutines:
  !  driver_reflectance (public)
  !    Compute the Fourier modes of the polarized bidirectional reflectance
  !    from a uniform halfspace.
  !
  !  vrte0_iq (public)
  !    Compute the upper-left block of the discretize system corresponding to
  !    the reduced form of the zeroth Fourier mode of the vector radiative
  !    transport equation (vRTE).
  !
  !  vrte0_uv (public)
  !    Compute the discretize system corresponding to the bottom-right block of
  !    the zeroth Fourier mode of the reduced form of the vector radiative
  !    transport equation (vRTE).
  !
  !  source (public)
  !    Compute the discretized source terms for the reduced problem
  !    resulting from the direct portion of the Stokes vector.
  !
  !  source0_iq (public)
  !    Compute the I and Q parts of the discretized source terms for the
  !    zeroth Fourier mode of the reduced problem resulting from the direct
  !    portion of the Stokes vector.
  !
  !  source0_uv (public)
  !    Compute the U and V parts of the discretized source terms for the
  !    zeroth Fourier mode of the reduced problem resulting from the direct
  !    portion of the Stokes vector.
  !
  ! Useful Citations:
  !  Siewert, C. E. "A discrete-ordinates solution for radiative-transfer
  !  models that include polarization effects." JQRST, 2000.
  !---
  ! Developed by J.P. Dark
  ! Contact: email@jpdark.com
  ! Last modified June 2017
  !-----------------------------------------------------------------------------

  implicit none

  integer, parameter :: sp = kind(1.0)
  integer, parameter :: dp = kind(1.d0)

  private
  public :: driver_reflectance, dirichlet, evaluate

contains

  subroutine driver_reflectance(N, L, kmax, tol, albedo, mu0, mu, wt, &
       FL_coeff, Rk)
    !!--------------------------------------------------------------------------
    !! Name: driver_reflectance
    !!  Compute the Fourier modes of the polarized bidirectional reflectance
    !!  from a uniform halfspace.
    !!
    !! Synopsis
    !!  driver_reflectance(N, L, kmax, tol, albedo, mu0, mu, wt, FL_coeff, Rk)
    !!
    !!    INPUT
    !!      Integer ------------- N, L, kmax
    !!      Double precision ---- tol, albedo, mu0, mu(N), wt(N),
    !!                            FL_coeff(6, L+1)
    !!
    !!    OUTPUT
    !!      Double precision ---- Rk(4N, 4, kmax+1)
    !!
    !! Purpose
    !!   Compute the Fourier modes, Rk(mu, mu0), of the reflection matrix,
    !!   R(mu, mu0, phi-phi0), using the discrete ordinate method where the
    !!   reflection matrix gives the diffuse intensity reflected from the
    !!   scattering halfspace,
    !!
    !!     Id(0, -mu, phi) = mu0/pi * R(mu, mu0, phi-phi0) I0.
    !!
    !! Arguments
    !!  N (input) integer
    !!   The number of ordinate quadrature points.
    !!
    !!  L (input) integer
    !!   The order of the expansion of the scattering matrix.
    !!
    !!  kmax (input) integer
    !!   Maximum Fourier mode. Must have kmax <= L.
    !!
    !!  tol (input) double precision
    !!   Numerical precision threshold for comparing eigenvalues.
    !!
    !!  albedo (input) double precision
    !!   Single scattering albedo.
    !!
    !!  mu0 (input) double precision
    !!   Ordinate direction of incident light.
    !!
    !!  mu (input) double precision, array(N)
    !!   Quadrature of ordinate directions.
    !!
    !!  wt (input) double precision, array(M)
    !!   Associated weights of the quadrature for ordinates.
    !!
    !!  FL_coeff (input) double precision, array(6, L+1)
    !!   Expansion coefficients of the scattering matrix.
    !!
    !!  Rk (output) double precision, array(4N, 4, kmax+1)
    !!   Reflectance matrix for the kth Fourier mode.
    !!--------------------------------------------------------------------------
    use special, only: auxiliary
    use discretize, only: vrte, source, vrte0_iq, vrte0_uv, source0_iq, &
         source0_uv
    use solver, only: vdisord, vdisord0_iq

    implicit none
    ! INPUT
    integer(8) :: N, L, kmax
    real(dp), intent(in) :: tol
    real(dp), intent(in) :: albedo
    real(dp), intent(in) :: mu0
    real(dp), intent(in), dimension(:) :: mu, wt ! dim(N)
    real(dp), intent(in), dimension(:, :) :: FL_coeff ! dim(6, L+1)
    ! OUTPUT
    real(dp), intent(out), dimension(4*N, 4, kmax+1) :: Rk
    ! Workspace: general
    integer(8) :: mm
    real(dp), dimension(N+1) :: x
    integer(8) :: k, nsource, nrows, nreal, nzero
    ! Workspace: zeroth Fourier mode
    real(dp), dimension(2*N, 2*N) :: A0, B0, AB0
    real(dp), dimension(2*N, 2) :: Psip0, Gammap0, Ip_pos0, Ip_neg0, reflmat0
    real(dp), dimension(2*N, 2*N) :: Psih0, Gammah0, Ih_pos0, Ih_neg0
    real(dp), dimension(2*N) :: lambda0
    real(dp), dimension(2*N, 2) :: coeff0
    ! Workspace: higher Fourier modes
    real(dp), dimension(L+1, N+1) :: plk, rlk, tlk
    real(dp), dimension(4*N, 4*N) :: A, B, AB
    real(dp), dimension(4*N, 4) :: Psi_p, Gamma_p
    real(dp), dimension(4*N, 4*N) :: Psi_h, Gamma_h
    real(dp), dimension(4*N, 4) :: coeff_pos
    real(dp), dimension(4*N, 4*N) :: Ih_pos, Ih_neg
    real(dp), dimension(4*N, 4) :: Ip_pos, Ip_neg
    real(dp), dimension(4*N) :: lambda
    real(dp), dimension(4*N, 4) :: reflmat

    ! Create extended ordinate array.
    x(1:N) = mu
    x(N+1) = mu0

    !---------------------------------------------------------------------------
    ! Compute the discretized system for k=0.
    !
    k = 0
    nsource = 2
    nrows = 2*N
    call auxiliary(k, N+1, L, x, plk, rlk, tlk)
    Rk(:, :, 1) = 0.0_dp
    !--
    ! 1. Compute the discretized system for k=0, m=1.
    !
    call vrte0_iq(L, N, nrows, albedo, mu, wt, plk, rlk, FL_coeff, A0, B0, AB0)
    call source0_iq(L, N, albedo, mu, plk, rlk, FL_coeff, Psip0, Gammap0)
    !
    ! 2. Compute Psi and Gamma from the discrete system.
    !
    call vdisord0_iq(nrows, nsource, mu0, A0, B0, AB0, tol, &
         Psip0, Gammap0, Psih0, Gammah0, lambda0, nreal, nzero)
    if (nzero == 1) then
       do mm = 0, N-1
          Psih0(2*mm+1, 1) = 1.0_dp
          Psih0(2*mm+2, 1) = 0.0_dp
       enddo
    endif
    !
    ! 3. Compute the Stokes vector from Psi and Gamma.
    ! The Stokes vector for decaying planewave solutions is given by
    !
    !  I = [[Psi + Gamma],
    !       [D34 * (Psi - Gamma)]].
    !
    if (nzero == 1) then
       Ih_pos0(:, 1) = Psih0(:, 1)
       Ih_neg0(:, 1) = Psih0(:, 1)
    endif
    Ih_pos0(:, nzero+1 : nrows) = &
         Psih0(:, nzero+1 : nrows) + Gammah0(:, nzero+1 : nrows)
    Ih_neg0(:, nzero+1 : nrows) = &
         Psih0(:, nzero+1 : nrows) - Gammah0(:, nzero+1 : nrows)
    Ip_pos0 = Psip0 + Gammap0
    Ip_neg0 = Psip0 - Gammap0
    !
    ! 4. Use the boundary conditions to compute the expansion coefficients.
    !
    coeff0 = -Ip_pos0
    call dirichlet(nrows, nsource, Ih_pos0, coeff0)
    !
    ! 5.  Compute the Fourier modes of the reflectance matrix.
    ! The reflectance matrix is given by
    !
    !   R0 = Ih_neg0 * coeff0 + Ip_neg0.
    !
    reflmat0 = Ip_neg0
    call dgemm('N', 'N', nrows, nsource, nrows, 1.0_dp, Ih_neg0, nrows, &
         coeff0, nrows, 1.0_dp, reflmat0, nrows)
    do mm = 0 , N-1
       Rk(4*mm+1:4*mm+2, 1:2, k+1) = reflmat0(2*mm+1:2*mm+2,:)
    enddo
    !---
    !
    ! 1. Compute the discretized system for k=0, m=1.
    !
    call vrte0_uv(L, N, nrows, albedo, mu, wt, plk, rlk, FL_coeff, A0, B0, AB0)
    call source0_uv(L, N, albedo, mu, plk, rlk, FL_coeff, Psip0, Gammap0)
    !
    ! 2. Compute Psi and Gamma from the discrete system.
    !
    call vdisord(nrows, nsource, mu0, A0, B0, AB0, tol, &
         Psip0, Gammap0, Psih0, Gammah0, lambda0, nreal, nzero)
    !
    ! 3. Compute the Stokes vector from Psi and Gamma.
    ! The Stokes vector for decaying planewave solutions is given by
    !
    !  I = [[Psi + Gamma],
    !       [D34 * (Psi - Gamma)]].
    !
    Ih_pos0 = Psih0 + Gammah0
    Ih_neg0 = -Psih0 + Gammah0
    Ip_pos0 = Psip0 + Gammap0
    Ip_neg0 = -Psip0 + Gammap0
    !
    ! 4. Use the boundary conditions to compute the expansion coefficients.
    !
    coeff0 = -Ip_pos0
    call dirichlet(nrows, nsource, Ih_pos0, coeff0)
    !
    ! 5.  Compute the Fourier modes of the reflectance matrix.
    ! The reflectance matrix is given by
    !
    !   R0 = Ih_neg0 * coeff0 + Ip_neg0.
    !
    reflmat0 = Ip_neg0
    call dgemm('N', 'N', nrows, nsource, nrows, 1.0_dp, Ih_neg0, nrows, &
         coeff0, nrows, 1.0_dp, reflmat0, nrows)
    do mm = 0 , N-1
       Rk(4*mm+3:4*mm+4, 3:4, k+1) = reflmat0(2*mm+1:2*mm+2,:)
    enddo
    !---------------------------------------------------------------------------

    nrows = 4*N
    nsource = 4
    do k = 1, kmax
       !
       ! 1. Compute discretized system.
       !
       call auxiliary(k, N+1, L, x, plk, rlk, tlk)
       call vrte(k, L, N, nrows, albedo, mu, wt, plk, rlk, tlk, FL_coeff, &
            A, B, AB)
       call source(k, L, N, albedo, mu, plk, rlk, tlk, FL_coeff, Psi_p, Gamma_p)
       !
       ! 2. Compute components of the general solution for the Fourier mode.
       !
       !      I_pos(tau, mu) = Psi(tau, mu) + Gamma(tau, mu),
       !      I_neg(tau, mu) = D34 * [Psi(tau, mu) - Gamma(tau, mu)],
       !
       ! where D34 = (1, 1, -1, -1).
       !
       call vdisord(nrows, nsource, mu0, A, B, AB, tol, &
            Psi_p, Gamma_p, Psi_h, Gamma_h, lambda, nreal, nzero)
       Ip_pos = Psi_p + Gamma_p
       Ip_neg = Psi_p - Gamma_p
       do mm = 0, N-1
          Ip_neg(4*mm+1 : 4*mm+2, :) = Psi_p(4*mm+1 : 4*mm+2, :) &
               - Gamma_p(4*mm+1 : 4*mm+2, :)
          Ip_neg(4*mm+3 : 4*mm+4, :) = -Psi_p(4*mm+3 : 4*mm+4, :) &
               + Gamma_p(4*mm+3 : 4*mm+4, :)
       enddo
       Ih_pos = Psi_h + Gamma_h
       do mm = 0, N-1
          Ih_neg(4*mm+1 : 4*mm+2, :) = Psi_h(4*mm+1 : 4*mm+2, :) &
               - Gamma_h(4*mm+1 : 4*mm+2, :)
          Ih_neg(4*mm+3 : 4*mm+4, :) = -Psi_h(4*mm+3 : 4*mm+4, :) &
               + Gamma_h(4*mm+3 : 4*mm+4, :)
       enddo
       !
       ! 3. Compute boundary conditions.
       !
       coeff_pos = -Ip_pos
       call dirichlet(nrows, nsource, Ih_pos, coeff_pos)
       !
       ! 4. Compute the Fourier modes of the reflectance matrix.
       ! The reflectance matrix is given by
       !
       !    Rk = Ih_neg * coeff_pos + Ip_neg
       !
       reflmat = Ip_neg
       call dgemm('N', 'N', nrows, nsource, nrows, 1.0_dp, Ih_neg, nrows, &
            coeff_pos, nrows, 1.0_dp, reflmat, nrows)
       Rk(:, :, k+1) = reflmat
    enddo

  end subroutine driver_reflectance

  subroutine dirichlet(nrows, nsource, Ih_pos, coeff_pos)
    !!--------------------------------------------------------------------------
    !! Name: dirichlet
    !!  Compute the expansion coefficients for scattering on a halfspace with
    !!  Dirichlet boundary conditions.
    !!
    !! Synopsis
    !!  subroutine dirichlet(nrows, nsource, Ih_pos, coeff_pos)
    !!
    !!     INPUT
    !!       Integer ------------- nrows, nsource
    !!       Double precision ---- Ipos(nrows, nrows)
    !!
    !!     IN/OUT
    !!       Double precsion ---- coeff_pos(nrows, nsource)
    !!
    !! Purpose
    !!  Solve for the expansion coefficients, coeff_pos, for Dirichlet
    !!  boundary conditions,
    !!
    !!    sum[j=1,4N] coeff_pos[j] * Ih_pos[j](0)  = I1 - Ip_pos(0).
    !!
    !! Arguments:
    !!  nrows (input) integer
    !!    The number of rows in the discretized system.
    !!
    !!  nsource (input) integer
    !!    The number of source terms.
    !!
    !!  Ih_pos (input) double precision, array(nrows, nrows)
    !!    The homogeneous solution at positive quadrature points
    !!
    !!  coeff_pos(in/out) double precision, array(nrows, source)
    !!    On input coeff_pos is the right-hand side of the boundary conditions,
    !!
    !!       coeff_pos = I1 - Ip_pos(0),
    !!
    !!    and on output coeff_pos is the expansion coefficients.
    !!--------------------------------------------------------------------------
    implicit none
    ! INPUT
    integer(8), intent(in) :: nrows, nsource
    real(dp), intent(in), dimension(:, :) :: Ih_pos ! dim(nrows, nrows)
    ! OUTPUT
    real(dp), intent(inout), dimension(:, :) :: coeff_pos ! dim(nrows, nsource)
    ! Workspace
    real(dp), dimension(nrows, nrows) :: workspace
    integer(8), dimension(nrows) :: IPIV
    integer(8) :: info
    !---------------------------------------------------------------------------
    ! Solve for coeff_pos using
    !
    !  sum[j=1,4N] coeff_pos[j] * Ipos[j](0)  = I1 - Ip(0).
    !
    workspace = Ih_pos
    info = 0
    call dgesv(nrows, nsource, workspace, nrows, IPIV, coeff_pos, nrows, info)
    if (info > 0) then
       write (*, '(A)') "> PROGRAM STOPPED BEFORE COMPLETION."
       write (*, '(A)') "> ERROR in __solver_MOD_dirichlet."
       write (*, '(A)') "> PLU decomposition of the boundary conditions failed."
       write (*, '(A, I4, A, I4, A)') "> U(", INFO, "," ,INFO,") = 0."
       write (*, '(A, I4, A)') "> Dimension of system is ", nrows, "."
       stop
    endif
    !---------------------------------------------------------------------------
  end subroutine dirichlet

  subroutine evaluate(z, nrows, ncols, nsource, nreal, tol, &
       Ih, Ip, mu0, lambda, coeff, Stokes)
    !!--------------------------------------------------------------------------
    !! Name: evaluate
    !!  Compute a Fourier mode of the Stokes vector evaluated at z.
    !!
    !! Synopsis
    !!  subroutine evaluate(z, nrows, ncols, nsource, nreal, tol, Ih, Ip, mu0,
    !!                      lambda, coeff, Stokes)
    !!
    !!     INPUT
    !!       Integer ------------- nrows, ncols, nsource, nreal
    !!       Double precision ---- z, tol, Ih, Ip, mu0, Ipos(nrows, ncols),
    !!                             lambda(ncols), coeff(ncols)
    !!
    !!     OUTPUT
    !!       Double precsion ---- Stokes(nrows, nsource)
    !!
    !! Purpose
    !!  Compute a Fourier mode of the Stokes vector at z from the general
    !!  solution using the general solution,
    !!
    !!   I = Ip * exp(-z/mu0)
    !!    + sum[j=1,nreal] coeff[j] * Ih[j] * exp(-lambda[j] * z)
    !!    + sum[j=nreal+1,nrows] (coeff(j) * Re[Ih[j] * exp(-lambda[j] * z)]
    !!                        + coeff(j+1) * Im[Ih[j] * exp(-lambda[j] * z)])
    !!
    !!
    !! Arguments:
    !!  z (input) double precisions
    !!   The depth at which to evaluate the Stokes vector.
    !!
    !!  nrows (input) integer
    !!    The number of rows in the discretized system.
    !!
    !!  ncols (input) integer
    !!    The number of planewave solutions in the homogeneous solution.
    !!
    !!  nsource (input) integer
    !!    The number of source terms.
    !!
    !!  nreal (input) integer
    !!    The number of eigenvalues, lambda, which are strictly real.
    !!
    !!  Ih (input) double precision, array(nrows, ncols)
    !!    The eigenvectors that make up the homogeneous solution.
    !!
    !!  Ip (input) double precision, array(nrows, nsource)
    !!    The Stokes vector for particular solution for each source.
    !!
    !!  mu0 (input) double precision
    !!    The incident polar direction.
    !!
    !!  coeff(in/out) double precision, array(nrows, source)
    !!    The expansion coefficients for the homogeneous solution.
    !!
    !!  Stokes (output) double precision
    !!    A Fourier mode of the Stokes vector evaluated at z.
    !!--------------------------------------------------------------------------
    implicit none
    ! Input
    real(dp) :: z
    integer(8), intent(in) :: nrows, ncols, nsource, nreal
    real(dp) :: tol
    real(dp), dimension(:, :) :: Ih ! dim(nrows, ncols)
    real(dp), dimension(:, :) :: Ip ! dim(nrows, nsource)
    real(dp) :: mu0
    real(dp), dimension(:) :: lambda ! dim(ncols)
    real(dp), dimension(:, :) :: coeff ! dim(ncols, nsource)
    ! Output
    real(dp), dimension(:, :) :: Stokes ! dim(nrows, nsource)
    ! Workspace
    real(dp), dimension(nrows, ncols) :: work
    integer(8) :: jj

    !---------------------------------------------------------------------------
    ! Compute a Fourier mode of the Stokes vector at z from the general
    ! solution,
    !
    !   I = Ip * exp(-z/mu0)
    !    + sum[j=1,nreal] coeff[j] * Ih[j] * exp(-lambda[j] * z)
    !    + sum[j=nreal+1,nrows] (coeff(j) * Re[Ih[j] * exp(-lambda[j] * z)]
    !                           + coeff(j+1) * Im[Ih[j] * exp(-lambda[j] * z)])
    if (abs(z) < tol) then
       !
       work = Ih
    else
       do jj = 1, nreal
          work(:, jj) = Ih(:, jj) * exp(-lambda(jj) * z)
       enddo
       do jj = nreal+1, ncols, 2
          !
          ! Re[Ih * exp(-lambda *z)] =
          !   Re[Ih] * cos(Im[lambda]*z) * exp(-lambda*z)
          !   - Im[Ih] * sin(-Im[lambda]*z) * exp(-lambda*z)
          !
          ! Im[Ih * exp(-lambda *z)] =
          !   Im[Ih] * cos(Im[lambda]*z) * exp(-lambda*z)
          !   + Re[Ih] * sin(-Im[lambda]*z) * exp(-lambda*z)
          work(:, jj) = exp(-lambda(jj) * z) &
               * (cos(lambda(jj+1) * z) * Ih(:, jj) &
               + sin(lambda(jj+1) * z) * Ih(:, jj+1))
          work(:, jj+1) = exp(-lambda(jj) * z) &
               * (cos(lambda(jj+1) * z) * Ih(:, jj+1) &
               - sin(lambda(jj+1) * z) * Ih(:, jj))
       enddo
    endif
    Stokes = Ip * exp(-z / mu0)
    call dgemm('N', 'N', nrows, nsource, ncols, 1.0_dp, work, nrows, &
         coeff, ncols, 1.0_dp, Stokes, nrows)
    !---------------------------------------------------------------------------
  end subroutine evaluate

end module halfspace

max_stars_repo_name: ugks/pddom

max_issues_repo_name: ugks/pddom

max_forks_repo_name: ugks/pddom


text:
! ==============================================================================
!
! File:    mimics_variable.f90
!
! Purpose: defines/allocates variables for MIMICS model
!   MODULE mimicsdimension
!   MODULE mimicsparam
!   MODULE mimicsvariable with subroutine alloc_mimicsvariable
!
! Contact: Melannie Hartman
!          melannie@ucar.edu
!
! History:
!          12/22/2014 - Created
!          1/5/2015 - Compiled
! ==============================================================================

MODULE mimicsdimension

  IMPLICIT NONE

  INTEGER, PARAMETER :: nmimicslit =  2    ! Number of litter pools (METBC, STRUC)
  INTEGER, PARAMETER :: nmimicsmcrb = 2    ! Number of microbial pools (RSEL, KSEL)
  INTEGER, PARAMETER :: nmimicssom =  3    ! Number of SOM pools (AVAL, CHEM, PHYS)
  INTEGER, PARAMETER :: nRK   = 6	   ! r1, r2, r3, k1, k2, k3

END MODULE mimicsdimension
!--------------------------------------------------------------------------------

MODULE mimicsparam
  USE mimicsdimension

  !Litter Pools
  INTEGER, PARAMETER :: METBC   = 1	! Metabolic
  INTEGER, PARAMETER :: STRUC   = 2	! Structural

  !Microbial Pools
  INTEGER, PARAMETER :: RSEL    = 1	! R-selected
  INTEGER, PARAMETER :: KSEL    = 2	! K-selected

  !Soil Organic Matter Pools
  INTEGER, PARAMETER :: AVAL    = 1	! Available
  INTEGER, PARAMETER :: CHEM    = 2	! Chemically Protected
  INTEGER, PARAMETER :: PHYS    = 3	! Physically Protected

  !Decomposition of litter and active SOM by microbial pools:
  INTEGER, PARAMETER :: R1 = 1  ! LITm to MICr
  INTEGER, PARAMETER :: R2 = 2  ! LITs to MICr
  INTEGER, PARAMETER :: R3 = 3  ! SOMa to MICr
  INTEGER, PARAMETER :: K1 = 4  ! LITm to MICk
  INTEGER, PARAMETER :: K2 = 5  ! LITs to MICk
  INTEGER, PARAMETER :: K3 = 6  ! SOMa to MICk

END MODULE mimicsparam
!--------------------------------------------------------------------------------

MODULE mimicsvariable
  USE casadimension
  USE mimicsdimension

!-------------------------
  TYPE mimics_biome

    REAL(r_2), POINTER :: tauModDenom, tauMod_MIN, tauMod_MAX

    REAL(r_2), DIMENSION(:),    POINTER :: fmet,    &
                                           ligninNratioAvg, &
                                           Vslope,  &
                                           Kslope,  &
                                           Vmod,    &
                                           Vint,    &
                                           av,      &
                                           Kint,    &
                                           ak,    &
                                           Fi,      &
                                           MGE,     &
                                           KO,      &
                                           Pscalar, &
                                           desorb,  &
                                           tauR,    &
                                           tau_r,   &
                                           tauK,    &
                                           tau_k,   &
                                           tauMod,  &
                                           depth,   &
                                           fPHYS_r, &
                                           fPHYS_K, &
                                           fCHEM_r, &
                                           fCHEM_K, &
                                           fSOM_p, &
                                           fmet_p, &
                                           phys_scalar

    REAL(r_2), DIMENSION(:,:),  POINTER :: ligninNratio, &
                                           Kmod, &
                                           Vmax, &
                                           Km,   &
                                           fPHYS,  &
                                           fCHEM,  &
                                           fAVAL
    INTEGER:: fWFunction

  END TYPE mimics_biome

!-------------------------
  TYPE mimics_flux
    REAL(r_2), DIMENSION(:,:),POINTER :: ClitInput
    REAL(r_2), DIMENSION(:)  ,POINTER :: Chresp
  END TYPE mimics_flux

!-------------------------
  TYPE mimics_pool
    REAL(r_2), DIMENSION(:),POINTER :: LITm, &
                                       LITs, &
                                       MICr, &
                                       MICk, &
                                       SOMa, &
                                       SOMc, &
                                       SOMp, &
                                       thetaLiq, &
                                       thetaFrzn, &
                                       fT,   &
                                       fW
  END TYPE mimics_pool

!-------------------------
  TYPE mimics_annual_pool

    REAL(r_2), DIMENSION(:,:), POINTER :: ClitterAn,    &
                                          CsoilAn,      &
                                          CmicrobeAn

    REAL(r_2), DIMENSION(:), POINTER :: thetaLiqAn,  &
                                        thetaFrznAn, &
                                        fTAn,        &
                                        fWAn

  END TYPE mimics_annual_pool

!-------------------------
  TYPE mimics_annual_flux

    REAL(r_2), DIMENSION(:,:), POINTER :: ClitInputAn
    REAL(r_2), DIMENSION(:),   POINTER :: ChrespAn

  END TYPE mimics_annual_flux

!-------------------------
  TYPE (mimics_biome)              :: mimicsbiome
  TYPE (mimics_flux)               :: mimicsflux
  TYPE (mimics_pool)               :: mimicspool
  TYPE (mimics_annual_pool)        :: mimicspoolAn
  TYPE (mimics_annual_flux)        :: mimicsfluxAn

  character(len=100) :: filename_mimicsbiome  !! file for biome-specific MIMICS parameters
  character(len=100) :: sPtFileNameMIMICS
  integer :: iptToSave_mimics

CONTAINS

!-------------------------
SUBROUTINE alloc_mimicsvariable(mp,mvtype,mplant)
  USE mimicsdimension
  implicit none
  integer, INTENT(IN) :: mp     ! number of grid points
  integer, INTENT(IN) :: mvtype ! number of vegetation (biome) types
  integer, INTENT(IN) :: mplant ! number of plant pools
  integer :: arraysize
  arraysize = mp

  ALLOCATE(mimicsbiome%tauModDenom, &
           mimicsbiome%tauMod_MIN, &
           mimicsbiome%tauMod_MAX)

  ALLOCATE(mimicsbiome%Vint(nRK), &
           mimicsbiome%av(nRK),   &
           mimicsbiome%Kint(nRK), &
           mimicsbiome%ak(nRK),   &
           mimicsbiome%Vslope(nRK),    &
           mimicsbiome%Kslope(nRK),    &
           mimicsbiome%Vmod(nRK),      &
           mimicsbiome%Kmod(arraysize,nRK),      &
           mimicsbiome%Vmax(arraysize,nRK),      &
           mimicsbiome%Km(arraysize,nRK),        &
           mimicsbiome%Fi(nmimicslit), &
           mimicsbiome%MGE(4),         &
           mimicsbiome%KO(2),          &
           mimicsbiome%depth(mvtype),      &
           mimicsbiome%Pscalar(arraysize), &
           mimicsbiome%desorb(arraysize),  &
           mimicsbiome%fmet(arraysize),    &
           mimicsbiome%ligninNratioAvg(arraysize), &
           mimicsbiome%tauR(arraysize),    &
           mimicsbiome%tauK(arraysize),    &
           mimicsbiome%tauMod(arraysize),  &
           mimicsbiome%fPHYS(arraysize,2), &
           mimicsbiome%fCHEM(arraysize,2), &
           mimicsbiome%fAVAL(arraysize,2), &
           mimicsbiome%tau_r(2),   &
           mimicsbiome%tau_k(2),   &
           mimicsbiome%fPHYS_r(2), &
           mimicsbiome%fPHYS_K(2), &
           mimicsbiome%fCHEM_r(3), &
           mimicsbiome%fCHEM_K(3), &
           mimicsbiome%fSOM_p(2), &
           mimicsbiome%phys_scalar(2), &
           mimicsbiome%fmet_p(3), &
           mimicsbiome%ligninNratio(arraysize,mplant))

  ALLOCATE(mimicsflux%ClitInput(arraysize,nmimicslit))
  ALLOCATE(mimicsflux%Chresp(arraysize))

  ALLOCATE(mimicspool%LITm(arraysize),        &
           mimicspool%LITs(arraysize),        &
           mimicspool%MICr(arraysize),        &
           mimicspool%MICk(arraysize),        &
           mimicspool%SOMa(arraysize),        &
           mimicspool%SOMc(arraysize),        &
           mimicspool%SOMp(arraysize),        &
           mimicspool%thetaLiq(arraysize),    &
           mimicspool%thetaFrzn(arraysize),   &
           mimicspool%fT(arraysize),          &
           mimicspool%fW(arraysize))

  ALLOCATE(mimicspoolAn%ClitterAn(arraysize,nmimicslit),   &
           mimicspoolAn%CsoilAn(arraysize,nmimicssom),     &
           mimicspoolAn%CmicrobeAn(arraysize,nmimicsmcrb), &
           mimicspoolAn%thetaLiqAn(arraysize),             &
           mimicspoolAn%thetaFrznAn(arraysize),            &
           mimicspoolAn%fTAn(arraysize),                   &
           mimicspoolAn%fWAn(arraysize))

  ALLOCATE(mimicsfluxAn%ChrespAn(arraysize))
  ALLOCATE(mimicsfluxAn%ClitInputAn(arraysize,nmimicslit))

END SUBROUTINE alloc_mimicsvariable

END MODULE mimicsvariable
!--------------------------------------------------------------------------------

max_stars_repo_licenses: MIT Unlicense

max_issues_repo_licenses: MIT Unlicense

max_forks_repo_licenses: MIT Unlicense