!***********************************************************************
!  SoilPoBal_C, Subroutine for CENTURY-based SOM/residue module.
!
!  Purpose: Provides output P balance for Century organic matter
!     routines (file SoilPoBal.OUT)
!
!  REVISION   HISTORY
!  09/19/2003 AJG Brought into modular format and linked to the
!                 CENTURY-based SOM/residue module.
!  03/23/2004 CHP Renamed SoilPBal_C and took out plant routines.
!  04/13/2005 CHP Removed inorganic N components from SoilNBal_C
!  08/25/2005 CHP Added consistency in names and methods between
!                 SoilNoBal, SoilNoBal_C, and SoilPoBal.
!
!  Called: CENTURY
!  Calls : GETLUN, HEADER, YR_DOY
!***********************************************************************

      SUBROUTINE SoilPoBal_C (CONTROL, ISWITCH,
     &  HARVRES, IMM, LITE, MNR, NLAYR, OMAData,          !Input
     &  SENESCE, SOM1E, TLITE, TSOME, TSOM1E, TSOM23E)    !Input

!***********************************************************************

!     ------------------------------------------------------------------
      USE ModuleDefs
      USE Interface_SoilPBalSum
      IMPLICIT NONE
      SAVE
!     ------------------------------------------------------------------
      LOGICAL FEXIST

      CHARACTER*1  IDETP, IDETL, ISWPHO
      CHARACTER*13, PARAMETER :: SPBAL = 'SoilPoBal.OUT'

      INTEGER DAS, DOY1, DOY2, DYNAMIC, INCDAT, L, LUNSPC
      INTEGER NLAYR, RUN, YR1, YR2, YRDOY, YRSIM
      INTEGER, PARAMETER :: SRFC = 0  !, SOIL = 1

      REAL AddToday, Balance, CUMBAL, CUMIMMOB, CUMMINER
      REAL CumResP, CumResPY, CumSenP, CumSenPY
      REAL DAYBAL, HarvResP, HResPSurf, HResPSoil
      REAL ResPToday, SenPToday, SenPYest, SubToday
      REAL TALLP, TALLPI, TIMMOB, TMINER, TORGP, TORGPI, TORGPY
      REAL TotLastSenes

      REAL, DIMENSION(NELEM) :: TLITE, TLITEI, TSOME, TSOMEI,
     &  TSOM1E, TSOM1EI, TSOM23E, TSOM23EI

      REAL, DIMENSION(0:0,NELEM) ::  LITEI, SOM1EI
      REAL, DIMENSION(0:NL,NELEM) :: IMM, LITE, MNR, SOM1E

!     The variable "CONTROL" is of type "ControlType".
      TYPE (ControlType)   CONTROL
      TYPE (SwitchType)    ISWITCH
      TYPE (ResidueType)   HARVRES
      TYPE (ResidueType)   SENESCE
      TYPE (OrgMatAppType) OMAData

!     ------------------------------------------------------------------
!     Return if detail not requested.
      IDETL   = ISWITCH % IDETL
      IDETP   = ISWITCH % IDETP
      ISWPHO  = ISWITCH % ISWPHO
      IF (IDETL  == 'N' .OR.
     &    IDETL  == '0' .OR.    !zero
     &    IDETP  == 'N' .OR.
     &    ISWPHO == 'N') RETURN

      DYNAMIC = CONTROL % DYNAMIC
      DAS     = CONTROL % DAS
      RUN     = CONTROL % RUN
      YRDOY   = CONTROL % YRDOY
      YRSIM   = CONTROL % YRSIM

      CumResP = OMADATA % CumResE(P)
      CumSenP = SENESCE % CumResE(P)

!***********************************************************************
!***********************************************************************
!     Seasonal Initialization phase
!***********************************************************************
      IF (DYNAMIC == SEASINIT) THEN
!     ----------------------------------------------------------------
!     Initialize output file
      CALL GETLUN(SPBAL, LUNSPC)
      INQUIRE (FILE = SPBAL, EXIST = FEXIST)
      IF (FEXIST) THEN
        OPEN (UNIT = LUNSPC, FILE = SPBAL, STATUS = 'OLD',
     &    POSITION = 'APPEND')
        WRITE(LUNSPC,'(/,"!",79("="))')
      ELSE
        OPEN (UNIT = LUNSPC, FILE = SPBAL, STATUS = 'NEW')
        WRITE(LUNSPC,'("*SOIL ORGANIC P BALANCE - CENTURY ROUTINES")')
      ENDIF

      CALL HEADER (SEASINIT, LUNSPC, RUN)

!     Initial value for SOM N, summed across all soil layers (not the
!     SRFC layer.
      TSOM1EI(P)  = TSOM1E(P)
      TSOM23EI(P) = TSOM23E(P)
      TSOMEI(P)   = TSOME(P)

      IF (RUN > 1) THEN
!       Harvest residue plus left-over senesced material from previous
!       crop.
        HResPSurf = HARVRES % ResE(SRFC,P)   !surface res P kg[P]/ha
        HResPSoil = 0.0                   !soil res P kg[P]/ha
        DO L = 1, NLAYR
          HResPSoil = HResPSoil + HARVRES % ResE(L,P)
        ENDDO
        HarvResP = HResPSurf + HResPSoil
      ELSE
        HResPSurf = 0.0
        HResPSoil = 0.0
        HarvResP  = 0.0
      ENDIF

!     Initial value for surface litter and surface SOM1.
!     Subtract residue leftover from previous crop from surface
!     litter because this was added in previously.
      LITEI(SRFC,P) = LITE(SRFC,P) - HResPSurf
      SOM1EI(SRFC,P) = SOM1E(SRFC,P)

!     Initial value for soil litter (not surface litter).
!     Subtract residue leftover from previous crop from soil
!       litter because this was added in previously.
      TLITEI(P) = TLITE(P) - HResPSoil

!     Sum all the soil organic P pools.
      TORGPI = TSOMEI(P) + TLITEI(P) + LITEI(SRFC,P) + SOM1EI(SRFC,P)

!     If detailed printout requested, print daily soil P balance
      IF (INDEX('AD',IDETL) > 0) THEN
!       Cumulative values (yesterday)
        CumResPY = 0.0
        CumSenPY = 0.0
        CUMBAL   = 0.0
        SenPYest = 0.0
        TORGPY   = TORGPI + HarvResP

        WRITE(LUNSPC,10)
   10   FORMAT(
     &    17X,'--------  STATE VARIABLES TODAY  -------   -',
     &    '------- ADDED TODAY --------   -REMOV TODAY-   BALANCE',
     &    '   BALANCE',/,
     &    '@YEAR DOY   DAS  SRFLIT SRFSOM1   TLITP    TSOMP  SRFSOIL',
     &    '    ResP  SENESP   IMMOB   TOTAL   MINER   TOTAL     DAILY',
     &    '    CUMUL.')
      ENDIF

      CUMMINER = 0.0
      CUMIMMOB = 0.0

      CALL SoilPBalSum (CONTROL,
     &    LITE=LITE, SOM1E=SOM1E, TLITP=TLITE(P),
     &    TSOM1P=TSOM1E(P), TSOM23P=TSOM23E(P))

      ENDIF !DYNAMIC

!***********************************************************************
!***********************************************************************
!     Daily output
!***********************************************************************
      IF (DYNAMIC == OUTPUT .OR. DYNAMIC .EQ. SEASINIT) THEN
!     ------------------------------------------------------------------
      TMINER = MNR(0,P)
      TIMMOB = IMM(0,P)
!     Combine mineralization in surface and top soil layer and take the profile sum.
!     *** This time the profile sum includes the SRFC value also! ***
      DO L = 1, NLAYR
!       Mineralization.
        TMINER = TMINER + MNR(L,P)
!       Immobilization.
        TIMMOB = TIMMOB + IMM(L,P)
      ENDDO

!     Accumulate immobilization and mineralization over time.
      CUMMINER = CUMMINER + TMINER
      CUMIMMOB = CUMIMMOB + TIMMOB

      IF (INDEX('AD',IDETL) > 0) THEN
!       Compute daily rates from cumulative values
        ResPToday = CumResP - CumResPY
        SenPToday = CumSenP - CumSenPY

!       Total soil organic E and combined with the mineral E.
        TORGP = TSOME(P) + TLITE(P) + LITE(SRFC,P) + SOM1E(SRFC,P)

!       Additions to and removals from the field.
        AddToday = ResPToday + SenPYest + TIMMOB
        SubToday = TMINER

        DAYBAL = TORGP - TORGPY - AddToday + SubToday
        CUMBAL = CUMBAL + DAYBAL
!        IF (ABS(DAYBAL) > 1.E-5) THEN
!          PRINT *, YRDOY, DAYBAL
!        ENDIF

        IF (DYNAMIC .EQ. SEASINIT) THEN
          CALL YR_DOY(INCDAT(YRDOY,-1), YR2, DOY2)
        ELSE
          CALL YR_DOY(YRDOY, YR2, DOY2)
        ENDIF

!       Write daily output to SoilPoBal.OUT.
        WRITE (LUNSPC,50) YR2, DOY2, DAS,
     &    LITE(SRFC,P), SOM1E(SRFC,P), TLITE(P), TSOME(P), TORGP,
     &    RESPTODAY, SenPYest,
     &    TIMMOB, AddToday, TMINER, SubToday, DAYBAL, CUMBAL
   50   FORMAT(1X, I4, 1X, I3, 1X, I5, 3F8.3, 2F9.3, 6F8.3, 2F10.3)

!       Save today's cumulative values for use tomorrow
        CumResPY = CumResP
        CumSenPY = CumSenP
        TORGPY   = TORGP
        SenPYest = SenPToday
      ENDIF

!***********************************************************************
!***********************************************************************
!     Seasonal output
!***********************************************************************
      ELSEIF (DYNAMIC == SEASEND) THEN
!     ------------------------------------------------------------------
!       Sum all the surface and soil organic P pools.
      TORGP = TSOME(P) + TLITE(P) + LITE(SRFC,P) + SOM1E(SRFC,P)

!     Add the P from organic residues applied during the growth period
!     and sum this with the initial TALLPI to make the balance fit with
!     the final TALLP. Senesced material is included in the final litter
!     pools, and thus can be considered as input on the initial soil-P
!     content.
      TALLPI = TORGPI + CumResP + CumSenP + CUMIMMOB + HarvResP

!       P balance will be off by the amount of P uptake on the last day
!         of season because this amount has been added to the P uptake by
!       plant, but has not been subtracted from soil.  This is because
!       soil processes are computed before plant processes.
!     Need to subtract this amount from balance.
      TotLastSenes = 0.0
      DO L = 0, NL
        TotLastSenes = TotLastSenes + SENESCE % ResE(L,P)
      ENDDO
        TALLPI = TALLPI - TotLastSenes

!     Sum the initial value of all abiotic P pools (soil, air,
!     fertilizer), SOM and cumulative mineralization.
      TALLP = TORGP + CUMMINER

!       Write end-of-season output.
        CALL YR_DOY(YRSIM, YR1, DOY1)
        CALL YR_DOY(YRDOY, YR2, DOY2)
        WRITE (LUNSPC,100) YR1, DOY1, YR2, DOY2

      WRITE (LUNSPC,200) TSOM1EI(P), TSOM1E(P),
     &  TSOM23EI(P), TSOM23E(P), TLITEI(P), TLITE(P),
     &  LITEI(SRFC,P), LITE(SRFC,P), SOM1EI(SRFC,P), SOM1E(SRFC,P)

      WRITE (LUNSPC,300) TORGPI, TORGP,
     &  HarvResP, CumResP, CumSenP, CUMIMMOB,
     &  CUMMINER, TALLPI, TALLP

      Balance = TALLP - TALLPI
      WRITE(LUNSPC,400) Balance

        CLOSE (UNIT = LUNSPC)

100   FORMAT (//,T42,'INITIAL Year/Doy', T64, 'FINAL Year/Doy',
     &    /,T49, I5,'/',I3.3, T69,I5,'/',I3.3,
     &  /,'SOIL ORGANIC P BALANCE',T49,'-----------kg P/ha-----------')

200   FORMAT ('  SOIL & SURFACE ORGANIC MATTER P',
     &  /, 3X,'Active (= microbial) SOM P      ',T48, F10.3, T68, F10.3,
     &  /, 3X,'Intermediate & passive SOM P    ',T48, F10.3, T68, F10.3,
     &  /, 3X,'Soil Litter P                   ',T48, F10.3, T68, F10.3,
     &  /, 3X,'P in Litter on Top of the Soil  ',T48, F10.3, T68, F10.3,
     &  /, 3X,'P in Microbes on Top of the Soil',T48, F10.3, T68, F10.3,
     &  /, 3X, T48,'  --------',T68,'  --------')

300   FORMAT (3X, 'Total Organic P in Soil and Surface Layers',
     &                                           T48, F10.2, T68, F10.2,
     &    //,'  ADDITIONS AND REMOVALS:'
     &  /, 3X, 'P in Harvest Residues from Previous Crop',
     &  /, 3X, '  (sequential runs only)',       T48, F10.3,
     &  /, 3X, 'P from Organic Applications',    T48, F10.3,
     &  /, 3X, 'P in returned senesced material',T48, F10.3,
     &  /, 3X, 'P immobilized',                  T48, F10.3,
     &  /, 3X, 'P mineralized',                              T68, F10.3,
     &  /, 3X, T48,'  --------',T68,'  --------',
     &  /, '  TOTAL P BALANCE',                  T48, F10.3, T68, F10.3)

400   FORMAT(3X,'Balance',                                   T68, F10.3)

      CALL SoilPBalSum (CONTROL,
     &    Balance=Balance, CUMIMMOB=CUMIMMOB, CUMMINER=CUMMINER,
     &    CUMRESP=CUMRESP, CumSenP=CumSenP, HARVRESP=HARVRESP,
     &    LITE=LITE, SOM1E=SOM1E, TLITP=TLITE(P),
     &    TSOM1P=TSOM1E(P), TSOM23P=TSOM23E(P))

!***********************************************************************
!***********************************************************************
!     End of DYNAMIC IF construct
!***********************************************************************
      END IF

      RETURN
      END SUBROUTINE SoilPoBal_C


MODULE cartesian_mod
  USE task_list_mod
  USE experiment_mod
  USE patch_mod
  USE link_mod
  USE task_mod
  USE trace_mod
  USE io_mod
  USE timer_mod
  USE mpi_coords_mod
  USE mpi_mod
  USE omp_mod
  USE omp_timer_mod
  USE bits_mod
  implicit none
  private
  type, public, extends(task_t):: rank_t
  end type
  type, public:: cartesian_t
    real(8):: size(3)
    integer:: dims(3)
    type(task_list_t), pointer:: task_list
  contains
    procedure init
    procedure, nopass:: diagnostics
  end type
  logical:: omp_init=.false.
  type(rank_t):: rank
  integer, save:: np=0                  ! patches per process
  public task_list_t                    ! export, to avoid excessive USE
CONTAINS

!===============================================================================
!> Distribute patches in a Cartesian arrangement in a box
!===============================================================================
SUBROUTINE init (self, label)
  class(cartesian_t):: self
  character(len=*), optional:: label
  !.............................................................................
  type(task_list_t), pointer:: patch_list
  class(link_t), pointer:: link, next
  class(experiment_t), pointer:: patch
  class(task_t), pointer:: task
  integer:: i, j, k, id, ip
  integer:: dims(3) = [4,4,4]
  integer:: patches_per_mpi(3)
  integer:: mpi_dims(3) = [1,1,1]
  integer:: per_rank(3) = [0,0,0]
  real(8):: size(3) = [1.0,1.0,1.0]
  real(8):: origin(3) = [-0.5,-0.5,-0.5]
  real(8):: wc
  logical:: face_nbors=.false.
  logical:: periodic(3)=.true.
  integer, save:: itimer=0
  namelist /cartesian_params/ size, dims, mpi_dims, per_rank, origin, face_nbors, &
    omp_init, periodic
  character(len=120):: ids = &
    '$Id: e71d387b943008f46d0f441b4ecad422725030df $ components/cartesian_mod.f90'
  !-----------------------------------------------------------------------------
  call trace%begin ('cartesian_t%init')
  call io%header('begin cartesian_t%init: Cartesian patch arrangement')
  call trace%print_id (ids)
  !-----------------------------------------------------------------------------
  rewind (io%input); read (io%input, cartesian_params)
  write (io%output, cartesian_params)
  if (any(per_rank/=0)) then
    where (per_rank/=0) dims=per_rank*mpi_dims
  end if
  per_rank = dims/mpi_dims
  self%dims = dims
  self%size = size
  io%dims     = dims
  if (mpi%size==1) &
    mpi_dims = 1
  !-----------------------------------------------------------------------------
  ! Generate a (periodic) MPI geometry, with dims specified in the input file,
  ! or assigned automatically by mpi_coords%init.
  !-----------------------------------------------------------------------------
  if (mpi%size == 1) then
     mpi_coords%dims = 1
  else
    if (product(mpi_dims)==1) then
      call mpi_coords%init (dims=dims)
    else
      call mpi_coords%init (mpi_dims=mpi_dims)
    end if
  end if
  mpi_dims = mpi_coords%dims
  patches_per_mpi = self%dims/mpi_dims
  mpi_coords%npatch = patches_per_mpi
  io%mpi_dims = mpi_dims
  !-----------------------------------------------------------------------------
  ! Set attritbutes of the rank_t data type -- just enough to use distance().
  !-----------------------------------------------------------------------------
  rank%periodic = .true.
  rank%box = self%size
  rank%size = rank%box/mpi_dims
  rank%ds = rank%size/patches_per_mpi
  rank%position = (mpi_coords%rank_to_coords(mpi%rank) + 0.5_8)*rank%size
  !-----------------------------------------------------------------------------
  ! Begin on task list
  !-----------------------------------------------------------------------------
  allocate (self%task_list)
  call self%task_list%init ('tlist')
  self%task_list%size = self%size
  self%task_list%dims = self%dims
  io%dims = self%dims
  self%task_list%n_tasks = product(self%dims)
  self%task_list%face_nbors = face_nbors
  !-----------------------------------------------------------------------------
  ! Allocate an array of links, pointing to patches, and give the patches each
  ! id, rank, size, position, integer position, and status bits.  Discard
  ! external patches and add the rest to the task_list.
  !-----------------------------------------------------------------------------
  ip = 0
  do k=0,self%dims(3)-1
  do j=0,self%dims(2)-1
  do i=0,self%dims(1)-1
    allocate (link, patch); link%task => patch; patch%link => link
    task => link%task
    ! --- patch 3D and 1D coordinates ---
    patch%ipos = [i,j,k]
    patch%rank = mpi_coords%coords_to_rank ([i,j,k]/patches_per_mpi)
    if (patch%rank == mpi%rank) then
      ip = ip + 1
      patch%ip = ip
    end if
    !---------------------------------------------------------------------------
    ! Generate the same IDs on all ranks, pruning the external tasks below
    !---------------------------------------------------------------------------
    call patch%task_t%init_unique (same=.true.)
    patch%box = self%size
    patch%size = self%size / self%dims
    patch%position = ([i,j,k]+0.5d0)*patch%size + origin
    if (any(abs(rank%distance (patch)) > 0.5*(rank%size + 1.5*rank%ds))) then
      deallocate (link, patch)
      cycle
    end if
    call patch%set (bits%virtual)
    patch%ds = patch%size*0.001
    patch%origin = origin
    patch%llc_cart = patch%position - 0.5 * patch%size
    patch%centre_nat = patch%position
    patch%llc_nat = patch%llc_cart
    patch%periodic = periodic
    call patch%set(bits%static)
    if (all(self%dims==1)) call task%set(bits%root_grid)
    ! -- initially append all tasks to the task list, to build nbor lists ------
    call self%task_list%append_link (link)
  end do
  end do
  end do
  !-----------------------------------------------------------------------------
  ! Generate nbor lists and set status bits for all tasks
  !-----------------------------------------------------------------------------
  if (io%verbose > 0) write(stdout,*) 'cartesian_t%init: init_all_nbors'
  call self%task_list%init_all_nbors
  if (io%verbose > 0) write(stdout,*) 'cartesian_t%init: reset_status'
  call self%task_list%reset_status
  !-----------------------------------------------------------------------------
  ! Remove tasks that are external, and make sure to also remove them from the
  ! nbor lists of virtual tasks
  !-----------------------------------------------------------------------------
  link => self%task_list%head
  do while (associated(link))
    next => link%next
    if (link%task%is_set (bits%external)) then
      call link%remove_nbor_list2 (link%nbor)
      call self%task_list%remove (link)
      deallocate (link%task)
      deallocate (link)
    end if
    link => next
  end do
  !-----------------------------------------------------------------------------
  ! This call is not valid until the patch meshes have been allocated
  !-----------------------------------------------------------------------------
  if (io%verbose > 0) write(stdout,*) 'cartesian_t%init: count status'
  call self%task_list%count_status
  !-----------------------------------------------------------------------------
  ! These must be set before reading input snapshots
  !-----------------------------------------------------------------------------
  io%ntask = self%task_list%na
  io%nwrite = self%task_list%na
  io%ntotal = product(self%dims)
  write (stdout,*) 'Number of tasks in task list:', self%task_list%n
  write(stdout,*) 'ntask, nwrite, ntotal =', io%ntask, io%nwrite, io%ntotal
  !-----------------------------------------------------------------------------
  ! Initialize tasks
  !-----------------------------------------------------------------------------
  if (omp_init) then
    !$omp parallel default(shared)
    call init_exp (self, origin)
    !$omp end parallel
  else
    call init_exp (self, origin)
  end if
  !-----------------------------------------------------------------------------
  ! This call is not valid until the patch mem and meshes have been allocated
  !-----------------------------------------------------------------------------
  if (io%verbose > 0) &
    write(stdout,*) 'cartesian_t%init: init boundaries'
  call self%task_list%init_bdries
  !-----------------------------------------------------------------------------
  if (io_unit%master) then
    write (io_unit%nml, cartesian_params)
    flush (io_unit%nml)
  end if
  if (io%verbose > 0) &
    write(stdout,*) 'cartesian_t%init: diagnostics'
  call self%diagnostics()
  if (io%verbose > 0) &
    write(stdout,*) 'cartesian_t%init: print tasks'
  call self%task_list%print_tasks
  if (io%verbose > 0) &
    write(stdout,*) 'cartesian_t%init: done'
  flush (stdout)
  !-----------------------------------------------------------------------------
  call trace%end ()
END SUBROUTINE init

SUBROUTINE init_exp (self, origin)
  class(cartesian_t):: self
  real(8):: origin(3)
  !.............................................................................
  type(link_t), pointer:: link
  class(task_t), pointer:: task
  class(experiment_t), pointer:: patch
  integer:: id
  !-----------------------------------------------------------------------------
  id = 0
  link => self%task_list%head
  do while (associated(link))
    id = id+1
    if (.not.omp_init .or. mod(id,omp%nthreads)==omp%thread) then
      task => link%task
      select type (task)
      class is (experiment_t)
        patch => task
        call patch%init
        if (omp_init .and. omp%nthreads>1) then
          task%mem_thread = omp%thread
        else
          task%mem_thread = -1
        end if
        patch%mesh%origin = origin
        !$omp atomic
        np = np + 1
        ! Set physical boundary bits if required.
        if (.not.patch%periodic(1).and.patch%ipos(1)==0)              call patch%boundaries%set(bits%xl)
        if (.not.patch%periodic(2).and.patch%ipos(2)==0)              call patch%boundaries%set(bits%yl)
        if (.not.patch%periodic(3).and.patch%ipos(3)==0)              call patch%boundaries%set(bits%zl)
        if (.not.patch%periodic(1).and.patch%ipos(1)==self%dims(1)-1) call patch%boundaries%set(bits%xu)
        if (.not.patch%periodic(2).and.patch%ipos(2)==self%dims(2)-1) call patch%boundaries%set(bits%yu)
        if (.not.patch%periodic(3).and.patch%ipos(3)==self%dims(3)-1) call patch%boundaries%set(bits%zu)
        if (io%verbose>0) then
          write (io_unit%log,1) &
            'cartesian_t%init: id, rank, size, pos =', &
            patch%id, patch%rank, patch%size, patch%position, &
            patch%is_set(bits%boundary), patch%is_set(bits%virtual)
          1 format(a,i8,i6,1p,2(2x,3e14.6),2x,2l1,2x,a)
          flush (io_unit%log)
        end if
        if (patch%id == io%id_debug) then
          write (io_unit%output,1) &
            'cartesian_t%init: id, rank, size, pos =', &
            patch%id, patch%rank, patch%size, patch%position, &
            patch%is_set(bits%boundary), patch%is_set(bits%virtual), 'DBG'
          flush (io_unit%log)
        else if (io_unit%verbose>1 .and. io_unit%master) then
          write (io_unit%output,1) &
            'cartesian_t%init: id, rank, size, pos =', &
            patch%id, patch%rank, patch%size, patch%position, &
            patch%is_set(bits%boundary), patch%is_set(bits%virtual)
          flush (io_unit%log)
        end if
      end select
    end if
    link => link%next
  end do
END SUBROUTINE init_exp

!===============================================================================
!> Diagnostics: Number of patches and GB of mem
!===============================================================================
SUBROUTINE diagnostics
  if (mpi%master) then
    print '(a,i8)',     ' Patches per process:', np
  end if
END SUBROUTINE diagnostics

END MODULE cartesian_mod


c
c
c
c     =====================================================
       subroutine qinit(meqn,mbc,mx,my,mz, xlower,ylower,zlower,
     &                  dx,dy,dz,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c
       implicit double precision (a-h,o-z)
c
       dimension q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc)
       dimension x(1-mbc:mx+mbc)
       dimension aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc,1-mbc:mz+mbc)
c
c     # set concentration profile
c     ---------------------------
c

       q(1,:,:,:) = 0.d0

      return
      end


      MODULE GWFSFRMODULE
        use ConstantsModule, only: LENPACKAGENAME
        CHARACTER(LEN=64), SAVE :: Version_sfr
        DOUBLE PRECISION,PARAMETER :: NEARZERO=1.0D-30
        DOUBLE PRECISION,SAVE :: THETAB, FLUXB, FLUXHLD2
        REAL,PARAMETER :: CLOSEZERO=1.0E-15
        INTEGER, SAVE :: Nfoldflbt, NUMTAB, MAXVAL
!        INTEGER,SAVE,                 POINTER:: IDVFLG   !diverison recharge is active flag
!        INTEGER,SAVE,  DIMENSION(:),  POINTER:: DVRCH   !(diverted recharge flag; then reharge cell count)
!        INTEGER,SAVE,  DIMENSION(:,:,:),POINTER:: DVRCELL !(store cells to apply diverted recharge)
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: RECHSAVE  !(store original recharge values)
!        REAL,   SAVE,  DIMENSION(:,:),POINTER:: DVRPERC  !(Percentage of diversion applied to each cell)
!        REAL,   SAVE,  DIMENSION(:),POINTER:: DVEFF  !(store efficiency factor)
        INTEGER,SAVE,POINTER:: NSS, NSTRM, NSFRPAR, ISTCB1, ISTCB2
        INTEGER,SAVE,POINTER:: IUZT, MAXPTS, IRTFLG, NUMTIM, NSEGDIM
        INTEGER,SAVE,POINTER:: ISFROPT, NSTRAIL, ISUZN, NSFRSETS
        INTEGER,SAVE,POINTER:: NUZST, NSTOTRL, NUMAVE
        INTEGER,SAVE,POINTER:: ITMP, IRDFLG, IPTFLG, NP
        INTEGER,SAVE,POINTER:: NSFRAUX, Ilgrgrid, Ilgrseg
        double precision, SAVE,POINTER:: CONST, DLEAK, WEIGHT, SFRRATIN,
     &    SFRRATOUT
        double precision,SAVE,POINTER:: FLWTOL, STRMDELSTOR_CUM,
     &    STRMDELSTOR_RATE
        DOUBLE PRECISION,SAVE,POINTER:: TOTSPFLOW
        logical, save, pointer             :: NeedLgrWaterMover
        logical, save, pointer             :: NeedLakWaterMover
        logical, save, pointer             :: NeedSfrWaterMover
        character(len=LENPACKAGENAME), save, pointer :: SfrPackageName
        INTEGER,SAVE,  DIMENSION(:),  POINTER:: IOTSG, NSEGCK
        INTEGER,SAVE,  DIMENSION(:),  POINTER:: ITRLSTH
        INTEGER,SAVE,  DIMENSION(:,:),POINTER:: ISEG, IDIVAR, ISTRM
        INTEGER,SAVE,  DIMENSION(:,:),POINTER:: LTRLIT, LTRLST
        INTEGER,SAVE,  DIMENSION(:,:),POINTER:: ITRLIT, ITRLST, NWAVST
        REAL,   SAVE,  DIMENSION(:),  POINTER:: STRIN, STROUT, FXLKOT
        REAL,   SAVE,  DIMENSION(:),  POINTER:: UHC, SGOTFLW, DVRSFLW
        REAL,   SAVE,  DIMENSION(:),  POINTER:: SFRUZBD
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: SEG, STRM, SFRQ
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: HWDTH, HWTPRM
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: QSTAGE, XSEC
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: AVDPT, AVWAT, WAT1
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: CONCQ, CONCRUN, CONCPPT
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: TABFLOW, TABTIME   !Reading Spedified inflow
        REAL,   SAVE,  DIMENSION(:,:),POINTER:: FNETSEEP           !writing net seepage in UZF
        INTEGER,SAVE,  DIMENSION(:,:),POINTER:: ISFRLIST           !Reading Spedified inflow
        DOUBLE PRECISION,SAVE,DIMENSION(:),  POINTER:: THTS,THTR,EPS
        DOUBLE PRECISION,SAVE,DIMENSION(:),  POINTER:: FOLDFLBT, THTI
        DOUBLE PRECISION,SAVE,DIMENSION(:),  POINTER:: SUMLEAK,SUMRCH
        DOUBLE PRECISION,SAVE,DIMENSION(:),  POINTER:: HLDSFR
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: UZFLWT, UZSTOR
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: UZWDTH, UZSEEP
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: DELSTOR, WETPER
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: UZDPIT, UZDPST
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: UZTHIT, UZTHST
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: UZSPIT, UZSPST
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: UZFLIT, UZFLST
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: UZOLSFLX, HSTRM
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: QSTRM, SLKOTFLW
        DOUBLE PRECISION,SAVE,DIMENSION(:,:),POINTER:: DLKOTFLW,DLKSTAGE
        CHARACTER(LEN=16),SAVE,DIMENSION(:), POINTER:: SFRAUX
      TYPE GWFSFRTYPE
!        INTEGER,                      POINTER:: IDVFLG   !diverison recharge is active flag
!        INTEGER,       DIMENSION(:),  POINTER:: DVRCH      !Diversions to recharge
!        INTEGER,       DIMENSION(:,:,:),  POINTER:: DVRCELL  !Diversions to recharge
        REAL,          DIMENSION(:,:),POINTER:: RECHSAVE  !Diversions to recharge
!        REAL,          DIMENSION(:,:),POINTER:: DVRPERC  !Diversions to recharge
!        REAL,          DIMENSION(:),POINTER:: DVEFF  !Diversions to recharge
        INTEGER,     POINTER:: NSS, NSTRM, NSFRPAR, ISTCB1, ISTCB2
        INTEGER,     POINTER:: IUZT, MAXPTS, IRTFLG, NUMTIM, NSEGDIM
        INTEGER,     POINTER:: ISFROPT, NSTRAIL, ISUZN, NSFRSETS
        INTEGER,     POINTER:: NUZST, NSTOTRL, NUMAVE
        INTEGER,     POINTER:: ITMP, IRDFLG, IPTFLG, NP
        INTEGER,     POINTER:: NSFRAUX, Ilgrgrid, Ilgrseg
        double precision, POINTER:: CONST, DLEAK, WEIGHT, SFRRATIN,
     &    SFRRATOUT
        double precision, POINTER:: FLWTOL, STRMDELSTOR_CUM,
     &    STRMDELSTOR_RATE
        DOUBLE PRECISION, POINTER:: TOTSPFLOW
        logical, pointer                       :: NeedLgrWaterMover
        logical, pointer                       :: NeedLakWaterMover
        logical, pointer                       :: NeedSfrWaterMover
        character(len=LENPACKAGENAME), pointer :: SfrPackageName
        INTEGER,       DIMENSION(:),  POINTER:: IOTSG, NSEGCK
        INTEGER,       DIMENSION(:),  POINTER:: ITRLSTH
        INTEGER,       DIMENSION(:,:),POINTER:: ISEG, IDIVAR, ISTRM
        INTEGER,       DIMENSION(:,:),POINTER:: LTRLIT, LTRLST
        INTEGER,       DIMENSION(:,:),POINTER:: ITRLIT, ITRLST, NWAVST
        REAL,          DIMENSION(:),  POINTER:: STRIN, STROUT, FXLKOT
        REAL,          DIMENSION(:),  POINTER:: UHC, SGOTFLW, DVRSFLW
        REAL,          DIMENSION(:),  POINTER:: SFRUZBD
        REAL,          DIMENSION(:,:),POINTER:: SEG, STRM, SFRQ
        REAL,          DIMENSION(:,:),POINTER:: HWDTH, HWTPRM
        REAL,          DIMENSION(:,:),POINTER:: QSTAGE, XSEC
        REAL,          DIMENSION(:,:),POINTER:: AVDPT, AVWAT, WAT1
        REAL,          DIMENSION(:,:),POINTER:: CONCQ, CONCRUN, CONCPPT
        REAL,          DIMENSION(:,:),POINTER:: TABFLOW, TABTIME  ! Reading SPecified inflow
        REAL,          DIMENSION(:,:),POINTER:: FNETSEEP          !writing net seepage in UZF
        INTEGER,       DIMENSION(:,:),POINTER:: ISFRLIST
        DOUBLE PRECISION,     DIMENSION(:),  POINTER:: THTS,THTR,EPS
        DOUBLE PRECISION,     DIMENSION(:),  POINTER:: FOLDFLBT, THTI
        DOUBLE PRECISION,     DIMENSION(:),  POINTER:: SUMLEAK, SUMRCH
        DOUBLE PRECISION,     DIMENSION(:),  POINTER:: HLDSFR
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: UZFLWT, UZSTOR
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: UZWDTH, UZSEEP
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: DELSTOR, WETPER
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: UZDPIT, UZDPST
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: UZTHIT, UZTHST
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: UZSPIT, UZSPST
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: UZFLIT, UZFLST
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: UZOLSFLX, HSTRM
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: QSTRM, SLKOTFLW
        DOUBLE PRECISION,     DIMENSION(:,:),POINTER:: DLKOTFLW,DLKSTAGE
        CHARACTER(LEN=16),    DIMENSION(:),  POINTER:: SFRAUX
      END TYPE
      TYPE(GWFSFRTYPE), SAVE:: GWFSFRDAT(10)

      contains

C-------SUBROUTINE GWF2SFR7DA
      SUBROUTINE GWF2SFR7DA(IGRID)
C  Save SFR data for a grid.
C     ------------------------------------------------------------------
C     ARGUMENTS
C     ------------------------------------------------------------------
      INTEGER IGRID
C     ------------------------------------------------------------------
      DEALLOCATE (GWFSFRDAT(IGRID)%NSS)
      DEALLOCATE (GWFSFRDAT(IGRID)%NSTRM)
      DEALLOCATE (GWFSFRDAT(IGRID)%NSFRPAR)
      DEALLOCATE (GWFSFRDAT(IGRID)%ISTCB1)
      DEALLOCATE (GWFSFRDAT(IGRID)%ISTCB2)
      DEALLOCATE (GWFSFRDAT(IGRID)%IUZT)
      DEALLOCATE (GWFSFRDAT(IGRID)%MAXPTS)
      DEALLOCATE (GWFSFRDAT(IGRID)%ISFROPT)
      DEALLOCATE (GWFSFRDAT(IGRID)%NSTRAIL)
      DEALLOCATE (GWFSFRDAT(IGRID)%ISUZN)
      DEALLOCATE (GWFSFRDAT(IGRID)%NSFRSETS)
      DEALLOCATE (GWFSFRDAT(IGRID)%NUZST)
      DEALLOCATE (GWFSFRDAT(IGRID)%NSTOTRL)
      DEALLOCATE (GWFSFRDAT(IGRID)%NUMAVE)
      DEALLOCATE (GWFSFRDAT(IGRID)%ITMP)
      DEALLOCATE (GWFSFRDAT(IGRID)%IRDFLG)
      DEALLOCATE (GWFSFRDAT(IGRID)%IPTFLG)
      DEALLOCATE (GWFSFRDAT(IGRID)%NUMTIM)
      DEALLOCATE (GWFSFRDAT(IGRID)%WEIGHT)
      DEALLOCATE (GWFSFRDAT(IGRID)%SFRRATIN)
      DEALLOCATE (GWFSFRDAT(IGRID)%SFRRATOUT)
      DEALLOCATE (GWFSFRDAT(IGRID)%FLWTOL)
      DEALLOCATE (GWFSFRDAT(IGRID)%IRTFLG)
      DEALLOCATE (GWFSFRDAT(IGRID)%NP)
      DEALLOCATE (GWFSFRDAT(IGRID)%CONST)
      DEALLOCATE (GWFSFRDAT(IGRID)%DLEAK)
      DEALLOCATE (GWFSFRDAT(IGRID)%IOTSG)
      !DEALLOCATE (GWFSFRDAT(IGRID)%DVRCH)     !cjm
      !DEALLOCATE (GWFSFRDAT(IGRID)%DVEFF)     !cjm
      !DEALLOCATE (GWFSFRDAT(IGRID)%DVRCELL)   !cjm
       DEALLOCATE (GWFSFRDAT(IGRID)%RECHSAVE)  !cjm
      !DEALLOCATE (GWFSFRDAT(IGRID)%DVRPERC)  !cjm
      !DEALLOCATE (GWFSFRDAT(IGRID)%IDVFLG)  !cjm
      DEALLOCATE (GWFSFRDAT(IGRID)%NSEGCK)
      DEALLOCATE (GWFSFRDAT(IGRID)%ITRLSTH)
      DEALLOCATE (GWFSFRDAT(IGRID)%ISEG)
      DEALLOCATE (GWFSFRDAT(IGRID)%IDIVAR)
      DEALLOCATE (GWFSFRDAT(IGRID)%ISTRM)
      DEALLOCATE (GWFSFRDAT(IGRID)%LTRLIT)
      DEALLOCATE (GWFSFRDAT(IGRID)%LTRLST)
      DEALLOCATE (GWFSFRDAT(IGRID)%ITRLIT)
      DEALLOCATE (GWFSFRDAT(IGRID)%ITRLST)
      DEALLOCATE (GWFSFRDAT(IGRID)%NWAVST)
      DEALLOCATE (GWFSFRDAT(IGRID)%STRIN)
      DEALLOCATE (GWFSFRDAT(IGRID)%STROUT)
      DEALLOCATE (GWFSFRDAT(IGRID)%FXLKOT)
      DEALLOCATE (GWFSFRDAT(IGRID)%UHC)
      DEALLOCATE (GWFSFRDAT(IGRID)%SGOTFLW)
      DEALLOCATE (GWFSFRDAT(IGRID)%DVRSFLW)
      DEALLOCATE (GWFSFRDAT(IGRID)%SFRUZBD)
      DEALLOCATE (GWFSFRDAT(IGRID)%SEG)
      DEALLOCATE (GWFSFRDAT(IGRID)%STRM)
      DEALLOCATE (GWFSFRDAT(IGRID)%HSTRM)
      DEALLOCATE (GWFSFRDAT(IGRID)%QSTRM)
      DEALLOCATE (GWFSFRDAT(IGRID)%SLKOTFLW)
      DEALLOCATE (GWFSFRDAT(IGRID)%DLKOTFLW)
      DEALLOCATE (GWFSFRDAT(IGRID)%DLKSTAGE)
      DEALLOCATE (GWFSFRDAT(IGRID)%HWDTH)
      DEALLOCATE (GWFSFRDAT(IGRID)%HWTPRM)
      DEALLOCATE (GWFSFRDAT(IGRID)%SFRQ)
      DEALLOCATE (GWFSFRDAT(IGRID)%QSTAGE)
      DEALLOCATE (GWFSFRDAT(IGRID)%XSEC)
      DEALLOCATE (GWFSFRDAT(IGRID)%AVDPT)
      DEALLOCATE (GWFSFRDAT(IGRID)%AVWAT)
      DEALLOCATE (GWFSFRDAT(IGRID)%WAT1)
      DEALLOCATE (GWFSFRDAT(IGRID)%CONCQ)
      DEALLOCATE (GWFSFRDAT(IGRID)%CONCRUN)
      DEALLOCATE (GWFSFRDAT(IGRID)%CONCPPT)
      DEALLOCATE (GWFSFRDAT(IGRID)%THTS)
      DEALLOCATE (GWFSFRDAT(IGRID)%THTR)
      DEALLOCATE (GWFSFRDAT(IGRID)%EPS)
      DEALLOCATE (GWFSFRDAT(IGRID)%FOLDFLBT)
      DEALLOCATE (GWFSFRDAT(IGRID)%THTI)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZFLWT)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZSTOR)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZWDTH)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZSEEP)
      DEALLOCATE (GWFSFRDAT(IGRID)%DELSTOR)
      DEALLOCATE (GWFSFRDAT(IGRID)%WETPER)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZDPIT)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZDPST)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZTHIT)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZTHST)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZSPIT)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZSPST)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZFLIT)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZFLST)
      DEALLOCATE (GWFSFRDAT(IGRID)%UZOLSFLX)
      DEALLOCATE (GWFSFRDAT(IGRID)%SUMRCH)
      DEALLOCATE (GWFSFRDAT(IGRID)%SUMLEAK)
      DEALLOCATE (GWFSFRDAT(IGRID)%HLDSFR)
      DEALLOCATE (GWFSFRDAT(IGRID)%STRMDELSTOR_CUM)
      DEALLOCATE (GWFSFRDAT(IGRID)%STRMDELSTOR_RATE)
      DEALLOCATE (GWFSFRDAT(IGRID)%TOTSPFLOW)
      deallocate (GWFSFRDAT(IGRID)%NeedLgrWaterMover)
      deallocate (GWFSFRDAT(IGRID)%NeedLakWaterMover)
      deallocate (GWFSFRDAT(IGRID)%NeedSfrWaterMover)
      deallocate (GWFSFRDAT(IGRID)%SfrPackageName)
      DEALLOCATE (GWFSFRDAT(IGRID)%TABFLOW)
      DEALLOCATE (GWFSFRDAT(IGRID)%TABTIME)
      DEALLOCATE (GWFSFRDAT(IGRID)%ISFRLIST)
      DEALLOCATE (GWFSFRDAT(IGRID)%FNETSEEP)
      DEALLOCATE (GWFSFRDAT(IGRID)%NSEGDIM)
      DEALLOCATE (GWFSFRDAT(IGRID)%NSFRAUX)
      deallocate (GWFSFRDAT(igrid)%Ilgrgrid)
      deallocate (GWFSFRDAT(igrid)%Ilgrseg)
      DEALLOCATE (GWFSFRDAT(IGRID)%SFRAUX)
C
      END SUBROUTINE GWF2SFR7DA
C
C-------SUBROUTINE GWF2SFR7PNT
      SUBROUTINE SGWF2SFR7PNT(IGRID)
C  Change SFR data to a different grid.
C     ------------------------------------------------------------------
C     ARGUMENTS
C     ------------------------------------------------------------------
      INTEGER IGRID
C     ------------------------------------------------------------------
      NSS=>GWFSFRDAT(IGRID)%NSS
      NSTRM=>GWFSFRDAT(IGRID)%NSTRM
      NSFRPAR=>GWFSFRDAT(IGRID)%NSFRPAR
      ISTCB1=>GWFSFRDAT(IGRID)%ISTCB1
      ISTCB2=>GWFSFRDAT(IGRID)%ISTCB2
      IUZT=>GWFSFRDAT(IGRID)%IUZT
      MAXPTS=>GWFSFRDAT(IGRID)%MAXPTS
      ISFROPT=>GWFSFRDAT(IGRID)%ISFROPT
      NSTRAIL=>GWFSFRDAT(IGRID)%NSTRAIL
      ISUZN=>GWFSFRDAT(IGRID)%ISUZN
      NSFRSETS=>GWFSFRDAT(IGRID)%NSFRSETS
      NUZST=>GWFSFRDAT(IGRID)%NUZST
      NSTOTRL=>GWFSFRDAT(IGRID)%NSTOTRL
      NUMAVE=>GWFSFRDAT(IGRID)%NUMAVE
      ITMP=>GWFSFRDAT(IGRID)%ITMP
      IRDFLG=>GWFSFRDAT(IGRID)%IRDFLG
      IPTFLG=>GWFSFRDAT(IGRID)%IPTFLG
      NP=>GWFSFRDAT(IGRID)%NP
      CONST=>GWFSFRDAT(IGRID)%CONST
      DLEAK=>GWFSFRDAT(IGRID)%DLEAK
      NUMTIM=>GWFSFRDAT(IGRID)%NUMTIM
      WEIGHT=>GWFSFRDAT(IGRID)%WEIGHT
      SFRRATIN=>GWFSFRDAT(IGRID)%SFRRATIN
      SFRRATOUT=>GWFSFRDAT(IGRID)%SFRRATOUT
      FLWTOL=>GWFSFRDAT(IGRID)%FLWTOL
      IRTFLG=>GWFSFRDAT(IGRID)%IRTFLG
      IOTSG=>GWFSFRDAT(IGRID)%IOTSG
      !IDVFLG=>GWFSFRDAT(IGRID)%IDVFLG        !cjm
      !DVRCH=>GWFSFRDAT(IGRID)%DVRCH        !cjm
      !DVEFF=>GWFSFRDAT(IGRID)%DVEFF        !cjm
      !DVRCELL=>GWFSFRDAT(IGRID)%DVRCELL    !cjm
       RECHSAVE=>GWFSFRDAT(IGRID)%RECHSAVE  !cjm
      !DVRPERC=>GWFSFRDAT(IGRID)%DVRPERC  !cjm
      NSEGCK=>GWFSFRDAT(IGRID)%NSEGCK
      ITRLSTH=>GWFSFRDAT(IGRID)%ITRLSTH
      ISEG=>GWFSFRDAT(IGRID)%ISEG
      IDIVAR=>GWFSFRDAT(IGRID)%IDIVAR
      ISTRM=>GWFSFRDAT(IGRID)%ISTRM
      LTRLIT=>GWFSFRDAT(IGRID)%LTRLIT
      LTRLST=>GWFSFRDAT(IGRID)%LTRLST
      ITRLIT=>GWFSFRDAT(IGRID)%ITRLIT
      ITRLST=>GWFSFRDAT(IGRID)%ITRLST
      NWAVST=>GWFSFRDAT(IGRID)%NWAVST
      STRIN=>GWFSFRDAT(IGRID)%STRIN
      STROUT=>GWFSFRDAT(IGRID)%STROUT
      FXLKOT=>GWFSFRDAT(IGRID)%FXLKOT
      UHC=>GWFSFRDAT(IGRID)%UHC
      SGOTFLW=>GWFSFRDAT(IGRID)%SGOTFLW
      DVRSFLW=>GWFSFRDAT(IGRID)%DVRSFLW
      SFRUZBD=>GWFSFRDAT(IGRID)%SFRUZBD
      SEG=>GWFSFRDAT(IGRID)%SEG
      STRM=>GWFSFRDAT(IGRID)%STRM
      HSTRM=>GWFSFRDAT(IGRID)%HSTRM
      QSTRM=>GWFSFRDAT(IGRID)%QSTRM
      HWDTH=>GWFSFRDAT(IGRID)%HWDTH
      HWTPRM=>GWFSFRDAT(IGRID)%HWTPRM
      SFRQ=>GWFSFRDAT(IGRID)%SFRQ
      QSTAGE=>GWFSFRDAT(IGRID)%QSTAGE
      SLKOTFLW=>GWFSFRDAT(IGRID)%SLKOTFLW
      DLKOTFLW=>GWFSFRDAT(IGRID)%DLKOTFLW
      DLKSTAGE=>GWFSFRDAT(IGRID)%DLKSTAGE
      XSEC=>GWFSFRDAT(IGRID)%XSEC
      AVDPT=>GWFSFRDAT(IGRID)%AVDPT
      AVWAT=>GWFSFRDAT(IGRID)%AVWAT
      WAT1=>GWFSFRDAT(IGRID)%WAT1
      CONCQ=>GWFSFRDAT(IGRID)%CONCQ
      CONCRUN=>GWFSFRDAT(IGRID)%CONCRUN
      CONCPPT=>GWFSFRDAT(IGRID)%CONCPPT
      THTS=>GWFSFRDAT(IGRID)%THTS
      THTR=>GWFSFRDAT(IGRID)%THTR
      EPS=>GWFSFRDAT(IGRID)%EPS
      FOLDFLBT=>GWFSFRDAT(IGRID)%FOLDFLBT
      THTI=>GWFSFRDAT(IGRID)%THTI
      UZFLWT=>GWFSFRDAT(IGRID)%UZFLWT
      UZSTOR=>GWFSFRDAT(IGRID)%UZSTOR
      UZWDTH=>GWFSFRDAT(IGRID)%UZWDTH
      UZSEEP=>GWFSFRDAT(IGRID)%UZSEEP
      DELSTOR=>GWFSFRDAT(IGRID)%DELSTOR
      WETPER=>GWFSFRDAT(IGRID)%WETPER
      UZDPIT=>GWFSFRDAT(IGRID)%UZDPIT
      UZDPST=>GWFSFRDAT(IGRID)%UZDPST
      UZTHIT=>GWFSFRDAT(IGRID)%UZTHIT
      UZTHST=>GWFSFRDAT(IGRID)%UZTHST
      UZSPIT=>GWFSFRDAT(IGRID)%UZSPIT
      UZSPST=>GWFSFRDAT(IGRID)%UZSPST
      UZFLIT=>GWFSFRDAT(IGRID)%UZFLIT
      UZFLST=>GWFSFRDAT(IGRID)%UZFLST
      UZOLSFLX=>GWFSFRDAT(IGRID)%UZOLSFLX
      SUMRCH=>GWFSFRDAT(IGRID)%SUMRCH
      SUMLEAK=>GWFSFRDAT(IGRID)%SUMLEAK
      HLDSFR=>GWFSFRDAT(IGRID)%HLDSFR
      STRMDELSTOR_CUM=>GWFSFRDAT(IGRID)%STRMDELSTOR_CUM
      STRMDELSTOR_RATE=>GWFSFRDAT(IGRID)%STRMDELSTOR_RATE
      TOTSPFLOW=>GWFSFRDAT(IGRID)%TOTSPFLOW
      NeedLgrWaterMover => GWFSFRDAT(IGRID)%NeedLgrWaterMover
      NeedLakWaterMover => GWFSFRDAT(IGRID)%NeedLakWaterMover
      NeedSfrWaterMover => GWFSFRDAT(IGRID)%NeedSfrWaterMover
      SfrPackageName => GWFSFRDAT(IGRID)%SfrPackageName
      TABFLOW=>GWFSFRDAT(IGRID)%TABFLOW
      TABTIME=>GWFSFRDAT(IGRID)%TABTIME
      ISFRLIST=>GWFSFRDAT(IGRID)%ISFRLIST
      FNETSEEP=>GWFSFRDAT(IGRID)%FNETSEEP
      NSEGDIM=>GWFSFRDAT(IGRID)%NSEGDIM
      NSFRAUX=>GWFSFRDAT(IGRID)%NSFRAUX
      Ilgrgrid=>GWFSFRDAT(IGRID)%Ilgrgrid
      Ilgrseg=>GWFSFRDAT(IGRID)%Ilgrseg
      SFRAUX=>GWFSFRDAT(IGRID)%SFRAUX
C
      END SUBROUTINE SGWF2SFR7PNT
C
C-------SUBROUTINE SGWF2SFR7PSV
      SUBROUTINE SGWF2SFR7PSV(IGRID)
C  Save SFR data for a grid.
C     ------------------------------------------------------------------
C     ARGUMENTS
C     ------------------------------------------------------------------
      INTEGER IGRID
C     ------------------------------------------------------------------
      GWFSFRDAT(IGRID)%NSS=>NSS
      GWFSFRDAT(IGRID)%NSTRM=>NSTRM
      GWFSFRDAT(IGRID)%NSFRPAR=>NSFRPAR
      GWFSFRDAT(IGRID)%ISTCB1=>ISTCB1
      GWFSFRDAT(IGRID)%ISTCB2=>ISTCB2
      GWFSFRDAT(IGRID)%IUZT=>IUZT
      GWFSFRDAT(IGRID)%MAXPTS=>MAXPTS
      GWFSFRDAT(IGRID)%ISFROPT=>ISFROPT
      GWFSFRDAT(IGRID)%NSTRAIL=>NSTRAIL
      GWFSFRDAT(IGRID)%ISUZN=>ISUZN
      GWFSFRDAT(IGRID)%NSFRSETS=>NSFRSETS
      GWFSFRDAT(IGRID)%NUZST=>NUZST
      GWFSFRDAT(IGRID)%NSTOTRL=>NSTOTRL
      GWFSFRDAT(IGRID)%NUMAVE=>NUMAVE
      GWFSFRDAT(IGRID)%ITMP=>ITMP
      GWFSFRDAT(IGRID)%IRDFLG=>IRDFLG
      GWFSFRDAT(IGRID)%IPTFLG=>IPTFLG
      GWFSFRDAT(IGRID)%NP=>NP
      GWFSFRDAT(IGRID)%CONST=>CONST
      GWFSFRDAT(IGRID)%DLEAK=>DLEAK
      GWFSFRDAT(IGRID)%NUMTIM=>NUMTIM
      GWFSFRDAT(IGRID)%WEIGHT=>WEIGHT
      GWFSFRDAT(IGRID)%SFRRATIN=>SFRRATIN
      GWFSFRDAT(IGRID)%SFRRATOUT=>SFRRATOUT
      GWFSFRDAT(IGRID)%FLWTOL=>FLWTOL
      GWFSFRDAT(IGRID)%IRTFLG=>IRTFLG
      GWFSFRDAT(IGRID)%IOTSG=>IOTSG
      !GWFSFRDAT(IGRID)%IDVFLG=>IDVFLG        !cjm
      !GWFSFRDAT(IGRID)%DVRCH=>DVRCH        !cjm
      !GWFSFRDAT(IGRID)%DVEFF=>DVEFF        !cjm
      !GWFSFRDAT(IGRID)%DVRCELL=>DVRCELL    !cjm
      !GWFSFRDAT(IGRID)%DVRPERC=>DVRPERC  !cjm
      GWFSFRDAT(IGRID)%RECHSAVE=>RECHSAVE  !cjm
      GWFSFRDAT(IGRID)%NSEGCK=>NSEGCK
      GWFSFRDAT(IGRID)%ITRLSTH=>ITRLSTH
      GWFSFRDAT(IGRID)%ISEG=>ISEG
      GWFSFRDAT(IGRID)%IDIVAR=>IDIVAR
      GWFSFRDAT(IGRID)%ISTRM=>ISTRM
      GWFSFRDAT(IGRID)%LTRLIT=>LTRLIT
      GWFSFRDAT(IGRID)%LTRLST=>LTRLST
      GWFSFRDAT(IGRID)%ITRLIT=>ITRLIT
      GWFSFRDAT(IGRID)%ITRLST=>ITRLST
      GWFSFRDAT(IGRID)%NWAVST=>NWAVST
      GWFSFRDAT(IGRID)%STRIN=>STRIN
      GWFSFRDAT(IGRID)%STROUT=>STROUT
      GWFSFRDAT(IGRID)%FXLKOT=>FXLKOT
      GWFSFRDAT(IGRID)%UHC=>UHC
      GWFSFRDAT(IGRID)%SGOTFLW=>SGOTFLW
      GWFSFRDAT(IGRID)%DVRSFLW=>DVRSFLW
      GWFSFRDAT(IGRID)%SFRUZBD=>SFRUZBD
      GWFSFRDAT(IGRID)%SEG=>SEG
      GWFSFRDAT(IGRID)%STRM=>STRM
      GWFSFRDAT(IGRID)%HSTRM=>HSTRM
      GWFSFRDAT(IGRID)%QSTRM=>QSTRM
      GWFSFRDAT(IGRID)%SLKOTFLW=>SLKOTFLW
      GWFSFRDAT(IGRID)%DLKOTFLW=>DLKOTFLW
      GWFSFRDAT(IGRID)%DLKSTAGE=>DLKSTAGE
      GWFSFRDAT(IGRID)%HWDTH=>HWDTH
      GWFSFRDAT(IGRID)%HWTPRM=>HWTPRM
      GWFSFRDAT(IGRID)%SFRQ=>SFRQ
      GWFSFRDAT(IGRID)%QSTAGE=>QSTAGE
      GWFSFRDAT(IGRID)%XSEC=>XSEC
      GWFSFRDAT(IGRID)%AVDPT=>AVDPT
      GWFSFRDAT(IGRID)%AVWAT=>AVWAT
      GWFSFRDAT(IGRID)%WAT1=>WAT1
      GWFSFRDAT(IGRID)%CONCQ=>CONCQ
      GWFSFRDAT(IGRID)%CONCRUN=>CONCRUN
      GWFSFRDAT(IGRID)%CONCPPT=>CONCPPT
      GWFSFRDAT(IGRID)%THTS=>THTS
      GWFSFRDAT(IGRID)%THTR=>THTR
      GWFSFRDAT(IGRID)%EPS=>EPS
      GWFSFRDAT(IGRID)%FOLDFLBT=>FOLDFLBT
      GWFSFRDAT(IGRID)%THTI=>THTI
      GWFSFRDAT(IGRID)%UZFLWT=>UZFLWT
      GWFSFRDAT(IGRID)%UZSTOR=>UZSTOR
      GWFSFRDAT(IGRID)%UZWDTH=>UZWDTH
      GWFSFRDAT(IGRID)%UZSEEP=>UZSEEP
      GWFSFRDAT(IGRID)%DELSTOR=>DELSTOR
      GWFSFRDAT(IGRID)%WETPER=>WETPER
      GWFSFRDAT(IGRID)%UZDPIT=>UZDPIT
      GWFSFRDAT(IGRID)%UZDPST=>UZDPST
      GWFSFRDAT(IGRID)%UZTHIT=>UZTHIT
      GWFSFRDAT(IGRID)%UZTHST=>UZTHST
      GWFSFRDAT(IGRID)%UZSPIT=>UZSPIT
      GWFSFRDAT(IGRID)%UZSPST=>UZSPST
      GWFSFRDAT(IGRID)%UZFLIT=>UZFLIT
      GWFSFRDAT(IGRID)%UZFLST=>UZFLST
      GWFSFRDAT(IGRID)%UZOLSFLX=>UZOLSFLX
      GWFSFRDAT(IGRID)%SUMRCH=>SUMRCH
      GWFSFRDAT(IGRID)%SUMLEAK=>SUMLEAK
      GWFSFRDAT(IGRID)%HLDSFR=>HLDSFR
      GWFSFRDAT(IGRID)%STRMDELSTOR_CUM=>STRMDELSTOR_CUM
      GWFSFRDAT(IGRID)%STRMDELSTOR_RATE=>STRMDELSTOR_RATE
      GWFSFRDAT(IGRID)%TOTSPFLOW=>TOTSPFLOW
      GWFSFRDAT(IGRID)%NeedLgrWaterMover => NeedLgrWaterMover
      GWFSFRDAT(IGRID)%NeedLakWaterMover => NeedLakWaterMover
      GWFSFRDAT(IGRID)%NeedSfrWaterMover => NeedSfrWaterMover
      GWFSFRDAT(IGRID)%SfrPackageName => SfrPackageName
      GWFSFRDAT(IGRID)%TABFLOW=>TABFLOW
      GWFSFRDAT(IGRID)%TABTIME=>TABTIME
      GWFSFRDAT(IGRID)%ISFRLIST=>ISFRLIST
      GWFSFRDAT(IGRID)%FNETSEEP=>FNETSEEP
      GWFSFRDAT(IGRID)%NSEGDIM=>NSEGDIM
      GWFSFRDAT(IGRID)%NSFRAUX=>NSFRAUX
      GWFSFRDAT(IGRID)%Ilgrgrid=>Ilgrgrid
      GWFSFRDAT(IGRID)%Ilgrseg=>Ilgrseg
      GWFSFRDAT(IGRID)%SFRAUX=>SFRAUX
C
      END SUBROUTINE SGWF2SFR7PSV

      END MODULE GWFSFRMODULE


c
c program totopo
c
      include 'VICMAIN_FOR'
      subroutine main44

      include 'mp_for_defs'  !needed for MP software
      parameter (maxbuf=1000)
      character*12 planet/'            '/
      character*5 project(2),mode
      integer*4 fdsno,ilab(100,2),scr(1800),camera(2)
      integer*4 idata(40,2),tpt,inunit(2),count,def
      real*4 data(40,2),image_coords(4,32)
      real*4 lat,long,line,samp
      real*4 xyz(4,32),nodata,inten
      real*8 latrad,x,y,z,r8
      real*8 raddeg,rpole,req,MP(2)
      logical xvptst,debug/.false./,xyzmode/.false./
      real*4 inbuf(maxbuf*maxbuf)
      real*4 outbuf(maxbuf*maxbuf)
      equivalence (r8,idata,data)

      raddeg=180.0d0/3.141592653589d0

c Get parameters:
      if(xvptst('DEBUG')) debug=.true.
      if(xvptst('XYZ')) xyzmode=.true.
      call xvparm('MODE',mode,count,def,1)
      call xvparm('NODATA',nodata,count,def,1)
      call xvparm('RADIUS',nw,count,def,1)
      call xvparm('MINPTS',minpts,count,def,1)
      call xvparm('MAXPASS',maxpass,count,def,1)

c open files
      call xvunit(inunit(1),'INP',1,status,' ')
      call xvopen(inunit(1),status,'IO_ACT','AS'
     +            ,'OPEN_ACT','AS','U_FORMAT','REAL',' ')
      call xvget(inunit(1),status,'NL',nl,'NS',np,' ')
      if(nl*np.gt.maxbuf*maxbuf)then
        write(*,*)'Max # input pixels is:',maxbuf*maxbuf
        call abend
      endif

      call xvunit(inunit(2),'INP',2,status,' ')
      call xvopen(inunit(2),status,'IO_ACT','AS'
     +            ,'OPEN_ACT','AS','U_FORMAT','REAL',' ')

      call xvunit(inmark,'INP',3,status,' ')
      call xvopen(inmark,status,'IO_ACT','AS','U_FORMAT','REAL'
     +            ,'OPEN_ACT','AS',' ')
      call xvget(inmark,status,'NL',nl3,'NS',ns3,' ')

      call xvunit(inxyz,'INP',4,status,' ')
      call xvopen(inxyz,status,'IO_ACT','AS','U_FORMAT','REAL'
     +            ,'OPEN_ACT','AS',' ')
      call xvget(inxyz,status,'NL',nl3,'NS',ns3,' ')

      call xvunit(outunit,'OUT',1,status,' ')
      call xvopen(outunit,status,'U_FORMAT','REAL','O_FORMAT',
     +            'REAL','OP','WRITE','OPEN_ACT','AS',
     +            'IO_ACT','AS',' ')

c Extract the navigation for the input images and put it in DATA.
c DATA(1-40,1) is for the Map projected first input image.
c DATA(1-40,2) is for the Map projected second input image.
      do image=1,2

c        Get project names
         call getproj(inunit(image),project(image),camera(image),
     +                fdsno,ind)
         if(ind.ne.0)then
            call mabend('Unknown flight project')
         endif

c        Get label contents
         call getlabcon(inunit(image),project(image),ilab(1,image),
     +                  ind)
         if(ind.gt.1)then
            write(*,*)'Getlabcon: Fatal error',ind
         endif

c        Retrieve the MAP labels from the projections for navigating
c        around in projection space.
c         call searcv2(inunit(image),i,%descr(scr),data(1,image),
c     +                data(1,image))
         call mp_init(mp(image),istat)
         if(istat.ne.mp_success) call mabend('error in mp_init')
         call mp_label_read(mp(image),inunit(image),istat)
         if(istat.ne.mp_success) call mabend('error in mp_read')
         call mp_mpo2buf( mp(image),data(1,image),istat)    !C MP
         if(istat.ne.mp_success) call mabend('error in mpo2buf')

c        Check input types
         if((idata(39,image).eq.7).or.(idata(39,image).eq.8))then
            call mabend('Inputs must be map projections')
         endif

      enddo

c Load input into memory
      if(mode.eq.'ORTHL')then
        image=1
        index=1
        do 160 lrec=1,nl
          i=(lrec-1)*np+1
          call xvread(inunit(1),inbuf(i),status,'LINE',lrec,' ')
160     continue
      else if(mode.eq.'ORTHR')then
        image=2
        index=3
        do 161 lrec=1,nl
          i=(lrec-1)*np+1
          call xvread(inunit(2),inbuf(i),status,'LINE',lrec,' ')
161     continue
      else if(mode.eq.'TOPO ')then
c       no image needed !
        image=1
      else if(mode.eq.'ERROR')then
c       no image needed !
        image=1
      else
        call mabend('Unrecognized mode')
      endif

c clear output buffer.
      call mve(7,nl*np,nodata,outbuf,0,1)

c close first 2 inputs.
      call xvclose(inunit(1),ind,' ')
      call xvclose(inunit(2),ind,' ')

      rpole=data(25,1) ! planet polar radius
      req=data(26,1)   ! planet equatorial radius
      slope=1.0
      offset=0.0

c Loop on coordinate records.
      do 140 lrec=1,nl3
        call xvread(inxyz,xyz,status,'LINE',lrec,' ')
        call xvread(inmark,image_coords,status,'LINE',lrec,' ')

c       Loop on tiepoints
        do 150 tpt=1,32
          if((xyz(1,tpt).eq.0.0).and.
     +       (xyz(2,tpt).eq.0.0)) goto 150

          if(xyzmode)then  ! convert from XYZ to LAT,LON
             x=xyz(1,tpt)
             y=xyz(2,tpt)
             z=xyz(3,tpt)
             latrad=datan2(z,dsqrt(x*x+y*y)) ! centric latitude
             lat=raddeg*latrad
             long=360.d0-raddeg*datan2(y,x)  ! W longitude
             if(long.gt.360.d0) long=long-360.d0
             range=dsqrt(x*x+y*y+z*z)
             rad=rpole*req/dsqrt(rpole*rpole*(dcos(latrad))**2+
     +                           req*req*(dsin(latrad))**2)
             xyz(1,tpt)=lat        ! Geocentric lat. deg.
             xyz(2,tpt)=long       ! W long deg.
             xyz(3,tpt)=range-rad  ! Elevation above geoid Km.
          endif

c         Convert lat,lon to input projection line,samp
c         This is the really correct line,sample.
          lat=xyz(1,tpt)
          long=xyz(2,tpt)
          call convev(ind,data(1,image),data(1,image),
     +                line,samp,lat,long,1,scr)
          if(ind.ne.0) goto 150

          if(debug)then
             write(*,*)'Projection lat,long,->line,samp'
             write(*,99) lat,long,line,samp
          endif

c         Check if in picture.
          iline=nint(line)
          isamp=nint(samp)
          if(isamp.lt.1.or.isamp.gt.np) goto 150
          if(iline.lt.1.or.iline.gt.nl) goto 150

          if(mode.eq.'TOPO ')then

c           Write the elevation to the output at the true location.
            i=(iline-1)*np+isamp
            elev=slope*xyz(3,tpt)+offset
            outbuf(i)=elev

          else if(mode.eq.'ERROR')then

c           Write the error to the output at the true location.
            i=(iline-1)*np+isamp
            elev=slope*xyz(4,tpt)+offset
            outbuf(i)=elev

          else

c           Get the DN value from the input location designated by the
c           original tiepoint line,sample pair.
            i=(image_coords(index,tpt)-1)*np+image_coords(index+1,tpt)
            inten=inbuf(i)

c           Write this intensity to the output at the true location.
            i=(iline-1)*np+isamp
            outbuf(i)=inten

          endif

150     continue
140   continue

c fillin gores
      call fill_gores(outbuf,inbuf,nl,np,nodata,
     +  nw,minpts,maxpass)

c     Write output.
      i=1-np
      do lrec=1,nl
        i=i+np
        call xvwrit(outunit,outbuf(i),status,'LINE',lrec,' ')
      enddo

99    format(4f10.5)

      return
      END

c**************************************************************
      subroutine fill_gores(buf,bufnew,nl,np,nodata,
     + nw,minpts,maxpass)
      real*4 buf(np,nl),bufnew(np,nl),nodata
      real*4 dn(1000),r(1000)
      integer*4 count,pass

c     Fillin the missing pixels.

      do j=1,nl
        do i=1,np
          bufnew(i,j)=nodata
        enddo
      enddo
      nl1=nl
      ns1=np
      rnw=nw*nw+.1 ! radius squared of collection circle + a bit
      pass=0
100   count=0
      pass=pass+1
      do j=1,nl1
        do i=1,ns1
          if(buf(i,j).ne.nodata)goto 10
          k=0
          do jj=max(j-nw,1),min(j+nw,nl1)
            j2=(j-jj)**2
            do ii=max(i-nw,1),min(i+nw,ns1)
              if(buf(ii,jj).ne.nodata)then
c               rad=(i-ii)**2+(j-jj)**2
                rad=(i-ii)**2+j2
                if(rad.le.rnw)then
                  k=k+1
                  dn(k)=buf(ii,jj)
                  r(k)=rad
                endif
              endif
            enddo
          enddo
          if(k.lt.minpts)goto 10
          sum1=0.0
          sum2=0.0
          do n=1,k
            sum1=sum1+dn(n)/r(n)
            sum2=sum2+1.0/r(n)
          enddo
          bufnew(i,j)=sum1/sum2
          count=count+1
10        continue
        enddo
      enddo
      do j=1,nl1
        do i=1,ns1
          if(bufnew(i,j).ne.nodata)then
            buf(i,j)=bufnew(i,j)
            bufnew(i,j)=nodata
          endif
        enddo
      enddo
      write(*,*)count,' pixels interpolated'
      if((count.gt.0).and.(pass.lt.maxpass))then
        goto 100
      endif

      return
      end


      subroutine inmuac (ihole, xionin, iunf, ikap)
      implicit double precision (a-h,o-z)
      include '../HEADERS/dim.h'
      common/dff/cg(nrptx,30),cp(nrptx,30),bg(10,30),bp(10,30),fl(30),
     1    fix(30), ibgp
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
c the meaning of common variables is described below
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
c en one-electron energies
c scc factors for acceleration of convergence
c scw precisions of wave functions
c sce precisions of one-electron energies
c nmax number of tabulation points for orbitals
      common/scrhf1/eps(435),nre(30),ipl
c eps non diagonal lagrange parameters
c nre distingue: - the shell is closed (nre <0)
c                  the shell is open (nre>0)
c                - the orbitals in the integral rk if abs(nre) > or =2
c ipl define the existence of lagrange parameters (ipl>0)
      common/snoyac/dvn(nrptx),anoy(10),nuc
c dvn nuclear potential
c anoy development coefficients at the origin of nuclear potential
c this development is supposed to be written anoy(i)*r**(i-1)
c nuc index of nuclear radius (nuc=1 for point charge)
      common/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension xnval(30), iorb(-4:3)
      data nucm/11/

      testy=10.**(-5)
c testy precision for the wave functions

      call getorb (nz, ihole, xionin, iunf, norb, norbsc, iorb,
     1            iholep, nq, kap, xnel, xnval, en)
c     don't need xmag here, so use en as a dummy

      ipl=0
      do 40 i=1,norb
         en(i) = 0.d0
         nre(i)=-1
         llq= abs(kap(i))
         l=llq+llq
c       find last tabulation point
         nmax(i)=0
         do 100  j = idim, 1, -1
            if ( abs(cg(j,i)) .ge. 1.0d-11 .or.
     1           abs(cp(j,i)) .ge. 1.0d-11 )  then
               nmax(i) = j
               goto 16
            endif
  100    continue
   16    continue

         scc(i)=0.3
         if (xnel(i) .lt. l)  nre(i)=1
         if (ikap.eq.kap(i)) ipl=ipl+1
  40  continue
      norbsc=norb
      norb = norb+1
      xnel(norb)=1
      kap(norb)=ikap
      nq(norb) =9
c nz atomic number     noi ionicity (nz-number of electrons)
c norb number of orbitals
c xnel(i) number of electrons on orbital i.
      nuc=nucm
c nuc number of points inside nucleus (11 by default)

      return
      end


      module rrlw_cld

      use shr_kind_mod, only: r8 => shr_kind_r8

!      use parkind, only : jpim, jprb

      implicit none
      save

!------------------------------------------------------------------
! rrtmg_lw cloud property coefficients

! Revised: MJIacono, AER, jun2006
!------------------------------------------------------------------

!  name     type     purpose
! -----  :  ----   : ----------------------------------------------
! abscld1:  real   :
! absice0:  real   :
! absice1:  real   :
! absice2:  real   :
! absice3:  real   :
! absliq0:  real   :
! absliq1:  real   :
!------------------------------------------------------------------

      real(kind=r8) :: abscld1
      real(kind=r8) , dimension(2) :: absice0
      real(kind=r8) , dimension(2,5) :: absice1
      real(kind=r8) , dimension(43,16) :: absice2
      real(kind=r8) , dimension(46,16) :: absice3
      real(kind=r8) :: absliq0
      real(kind=r8) , dimension(58,16) :: absliq1

      end module rrlw_cld


C=======================================================================
C  FOR_VEGDM, Subroutine
C  Calculates the reduction in vegetative mass in
C       state and rate variables due to pest damage.
C-----------------------------------------------------------------------
C  REVISION       HISTORY
C  01/01/1990 WDB Written
C  02/23/1998 CHP Modified for PEST Module
C  01/12/1999 GH  Incorporated into CROPGRO
C-----------------------------------------------------------------------
C  Called by: PEST
C  Calls:     None
C=======================================================================
      SUBROUTINE FOR_VEGDM(
     &    AREALF, CLW, CSW, PCLMA, PCLMT,                 !Input
     &    PCSTMD, PDLA, PLFAD, PLFMD, PSTMD,              !Input
     &    PVSTGD, SLA, SLDOT, SSDOT, STMWT,               !Input
     &    TDLA, VSTGD, WLFDOT, WSTMD, WTLF,               !Input
     &    TLFAD, TLFMD, VSTAGE, WLIDOT,                   !Input/Output
     &    CLAI, CLFM, CSTEM, DISLA, DISLAP,               !Output
     &    LAIDOT, WSIDOT,                                                      !Output
     &  CSRW, PCSTRD, PSTRD, SSRDOT, STRWT,                        !Input
     &  WSFDOT, WSRFDOT, WSTRD,                                          !Input
     &  CSTRM, WSRIDOT,                                        !Output

     &  CSFRZ, CSRFRZ, DSTOR, SRDAM,                              !Output

     &    DYNAMIC)                                        !Control

!-----------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
        ! which contain control information, soil
        ! parameters, hourly weather data.
      IMPLICIT NONE
      SAVE

C     Leaf Variables
      REAL TLFAD,PLFAD,TLFMD,PLFMD,PCLMT,PCLMA
      REAL CLSEN,CLAI,CLFM,LAIDOT
      REAL DISLA, DISLAP, AREALF
      REAL PDLA, TDLA
      REAL CLW, PWTLF, WLFDOT, CLFRZ, LAIDAM
C     Stem Variables
      REAL WSTMD,PSTMD,PCSTMD,CSTEM
      REAL DSTEM
      REAL CSW, SSDOT, SDAM
      REAL CSFRZ, WSFDOT
      REAL WTLF,STMWT,WLIDOT,WSIDOT,SLDOT,SLA
      REAL VSTAGE,PVSTGD,VSTGD

      REAL LDAM
      INTEGER DYNAMIC

      REAL CSRFRZ, CSRW, CSTRM, DSTOR, PCSTRD, PSTRD, SRDAM,
     &    SSRDOT, STRWT, WSRFDOT, WSRIDOT, WSTRD

!***********************************************************************
!***********************************************************************
!     Seasonal initialization - run once per season
!***********************************************************************
      IF (DYNAMIC .EQ. SEASINIT) THEN
!-----------------------------------------------------------------------
      CLSEN  = 0.0
      CLFRZ  = 0.0
      CLAI   = 0.0
      CLFM   = 0.0
      CSTEM  = 0.0
      CSTRM  = 0.0
      CSFRZ  = 0.0
      CSRFRZ = 0.0
!***********************************************************************
!***********************************************************************
!     Daily rate calculations
!***********************************************************************
      ELSEIF (DYNAMIC .EQ. RATE) THEN
C-----------------------------------------------------------------------
      WSIDOT = 0.0
      WLIDOT = 0.0
      LAIDOT = 0.0
      DISLA  = 0.0
      DISLAP = 0.0
      LDAM   = 0.0
      LAIDAM = 0.0
      SDAM   = 0.0
      WSRIDOT = 0.0
C-----------------------------------------------------------------------
C     Desired observed cumulative stem damage
C-----------------------------------------------------------------------
C     When stem damage is reported as percent reduction of total
C     cumulative stem mass produced, use this section.  The total stem
!     mass produced is CSW.  Part of the observed damage comes from
!     senescence and part from pests.
C-----------------------------------------------------------------------
      IF (PCSTMD .GT. 0.0) THEN
C     Desired stem mass DSTEM after cumulative damage
        DSTEM = CSW * (1.0 - PCSTMD / 100.0)
        IF ((STMWT - SSDOT - WSFDOT) .GT. DSTEM) THEN
        SDAM = STMWT - SSDOT - WSFDOT - DSTEM
        ELSE
        SDAM = 0.0
        ENDIF
        WSIDOT = WSIDOT + SDAM
      ENDIF

C-----------------------------------------------------------------------
C     Percent daily stem damage
C-----------------------------------------------------------------------
      IF (PSTMD .GT. 0.0) THEN
        SDAM = PSTMD*STMWT/100.0
        WSIDOT = WSIDOT + SDAM
      ENDIF
C-----------------------------------------------------------------------
C     Absolute daily amount of stem mass damaged
C-----------------------------------------------------------------------
      IF(WSTMD .GT. 0.0) THEN
        SDAM = MIN(WSTMD, STMWT)
        WSIDOT = WSIDOT + SDAM
      ENDIF

      WSIDOT = MAX(0.,WSIDOT)
      WSIDOT = MIN(WSIDOT, STMWT)

C-----------------------------------------------------------------------
C     Desired observed cumulative storage organ damage
C-----------------------------------------------------------------------
C     When storage organ damage is reported as percent reduction of total
C     cumulative storage organ mass produced, use this section.  The total
!     storage organ mass produced is CSRW.  Part of the observed damage
!     comes from senesence and part from pests.
C-----------------------------------------------------------------------

      IF (PCSTRD .GT. 0.0) THEN
C     Desired storage organ mass DSTOR after cumulative damage
        DSTOR = CSRW * (1.0 - PCSTRD / 100.0)
        IF ((STRWT - SSRDOT - WSRFDOT) .GT. DSTOR) THEN
        SRDAM = (STRWT - SSRDOT - WSRFDOT) - DSTOR
        ELSE
        SRDAM = 0.0
        ENDIF
        WSRIDOT = WSRIDOT + SRDAM
      ENDIF

C-----------------------------------------------------------------------
C     Percent daily storage organ damage
C-----------------------------------------------------------------------
      IF (PSTRD .GT. 0.0) THEN
        SRDAM = PSTRD*STRWT/100.0
        WSRIDOT = WSRIDOT + SRDAM
      ENDIF
C-----------------------------------------------------------------------
C     Absolute daily amount of storage organ mass damaged
C-----------------------------------------------------------------------
      IF(WSTRD .GT. 0.0) THEN
        SRDAM = MIN(WSTRD, STRWT)
        WSRIDOT = WSRIDOT + SRDAM
      ENDIF

      WSRIDOT = MAX(0.,WSRIDOT)
      WSRIDOT = MIN(WSRIDOT, STRWT)

C-----------------------------------------------------------------------
C     Absolute daily leaf damage
C-----------------------------------------------------------------------
      IF (TLFAD .GT. 0.0 .AND. SLA .GT. 0.0) THEN
        LAIDAM = MIN(TLFAD, WTLF * SLA / 10000.0)
        LDAM = LAIDAM * 10000.0 / SLA
        WLIDOT = WLIDOT + LDAM
        LAIDOT = LAIDOT + LAIDAM
      ENDIF

      IF (TLFMD .GT. 0.0) THEN
        LDAM = MIN(TLFMD,WTLF)
        LAIDAM = LDAM * SLA / 10000.
        WLIDOT = WLIDOT + LDAM
        LAIDOT = LAIDOT + LAIDAM
      ENDIF
C-----------------------------------------------------------------------
C     Percent daily leaf damage
C-----------------------------------------------------------------------
      IF (PLFAD .GT. 0.0) THEN
        LDAM = WTLF*(PLFAD/100.0)
        LAIDAM = LDAM * SLA / 10000.0
        WLIDOT = WLIDOT + LDAM
        LAIDOT= LAIDOT + LAIDAM
      ENDIF

      IF (PLFMD .GT. 0.0) THEN
        LDAM = WTLF*(PLFMD/100.0)
        LAIDAM = LDAM * SLA / 10000.0
        WLIDOT = WLIDOT + LDAM
        LAIDOT= LAIDOT + LAIDAM
      ENDIF

C-----------------------------------------------------------------------
C     Desired observed percent leaf damage
C-----------------------------------------------------------------------
C  When damage is reported as percent reduction of total cumulative
C  leaf mass produced, use this section.  The total leaf mass produced is
C  CLW.  Part of the observed damage comes from senesence and freezing
C  and part comes from pests.  This section does not require you to
C  distinguish whether damage came from senesence or pests.  PWTLF is
!  the potential available leaf mass after the observed leaf damage is
!  applied.
!----------------------------------------------------------------
      IF (PCLMT .GE. 0.0001) THEN
        PWTLF = CLW * (1.0 - PCLMT / 100.0)
        IF ((WTLF - SLDOT - WLFDOT) .GT. PWTLF) THEN
        LDAM = (WTLF - SLDOT - WLFDOT) - PWTLF
        ELSE
        LDAM = 0.0
        ENDIF
!--------------------------------------------------------------
        IF (LDAM .GT. 0.0) THEN
        WLIDOT = WLIDOT + LDAM
        LAIDAM = LDAM * SLA / 10000.0
        LAIDOT= LAIDOT + LAIDAM
        ENDIF
      ENDIF

C-----------------------------------------------------------------------
C     Where is PCLMA?? chp 3/23/01
C-----------------------------------------------------------------------

C-----------------------------------------------------------------------
C     Percent diseased leaf area; DISLA and TDLA are in units of cm2/m2
!     This code came from GROW subroutine -- chp
C-----------------------------------------------------------------------
      IF (PDLA .GT. 0.0) THEN
        DISLA = WTLF * SLA * PDLA/100.0
      ENDIF

      IF (TDLA .GT. 0.0) THEN
        DISLA = DISLA + TDLA
      ENDIF

      IF (AREALF .GT. 0.) THEN
        DISLAP = DISLA / AREALF * 100.0
      ELSE
        DISLAP = 0.0
      ENDIF

!***********************************************************************
!***********************************************************************
!     Daily integration
!***********************************************************************
      ELSEIF (DYNAMIC .EQ. INTEGR) THEN
C-----------------------------------------------------------------------
C     Maintain cumulative values for senesenced and frozen leaf tissue.
C-----------------------------------------------------------------------
      IF (SLDOT  .GT. 0.0) CLSEN = CLSEN + SLDOT
      IF (WLFDOT .GT. 0.0) CLFRZ = CLFRZ + WLFDOT
      IF (WSFDOT .GT. 0.0) CSFRZ = CSFRZ + WSFDOT
      IF (WSRFDOT .GT. 0.0) CSRFRZ = CSRFRZ + WSRFDOT
C-----------------------------------------------------------------------
C     Maintain cumulative leaf, leaf area, and stem damage variables.
C-----------------------------------------------------------------------
      CLFM  = CLFM  + WLIDOT
      CLAI  = CLAI  + LAIDOT
      CSTEM = CSTEM + WSIDOT
      CSTRM  = CSTRM + WSRIDOT
C-----------------------------------------------------------------------
C     Percent V-stage damage
C-----------------------------------------------------------------------
      IF (PVSTGD .GT. 0.0)  THEN
        VSTAGE = VSTAGE * (1.0 - PVSTGD/100.)
      ENDIF

C-----------------------------------------------------------------------
C     Absolute daily amount of VSTAGE damaged
C-----------------------------------------------------------------------
      IF (VSTGD .GT. 0.0) THEN
        VSTAGE = VSTAGE - VSTGD
      ENDIF
      VSTAGE = MAX(0.,VSTAGE)

!***********************************************************************
!***********************************************************************
!     END OF DYNAMIC IF CONSTRUCT
!***********************************************************************
      ENDIF
!***********************************************************************
      RETURN
      END  ! SUBROUTINE FOR_VEGDM
!-----------------------------------------------------------------------
!     Variable definitions
!-----------------------------------------------------------------------
! AREALF  Area of leaves (one side) per unit ground area
!           (cm2[leaf] / m2[ground])
! CLAI    Cumulative leaf area index destroyed (m2/m2)
! CLFM    Cumulative leaf mass destroyed  (g/m2)
! CLFRZ   Cumulative frozen leaf tissue (g[leaf]/m2)
! CLSEN   Cumulative leaf senescence (g/m2)
! CLW     Cumulative leaf growth (g[leaf]/m2)
! CSFRZ      Cumulative frozen stem tissue (g[stem]/m2)
! CSRFRZ      Cumulative frozen storage organ tissue (g[storage]/m2)
! CSRW      Cumulative storage organ growth (g[storage]/m2)
! CSTEM   Cumulative stem mass destroyed (g/m2)
! CSTRM      Cumulative storage organ mass destroyed (g/m2)
! CSW     Cumulative stem growth (g[stem]/m2)
! DISLA   Diseased leaf area (cm2[leaf]/m2[ground]/d)
! DISLAP  Percent diseased leaf area (%/d)
! DSTEM   Desired stem mass (g/m2/d)
! DSTOR   Desired storage organ mass (g/m2/d)
! DYNAMIC Module control variable; =RUNINIT, SEASINIT, RATE, EMERG, INTEGR,
!           OUTPUT, or SEASEND
! LAIDAM  Change in leaf area index due to current pest
!           (m2[leaf]/m2[ground])
! LAIDOT  Daily change in leaf area index due to pest damage (m2/m2/d)
! LDAM    Daily leaf damage (g/m2/d)
! PCLMA   Percent observed leaf mass (WTLF) damage (%)
! PCLMT   Percent of total leaf mass (WTLF + senescence) destroyed (%)
! PCSTMD  Observed cumulative percentage stem mass damage (%)
! PCSTRD  Observed cumulative percentage storage organ mass damage (%)
! PDLA    Percent diseased leaf area (%)
! PLFAD   Daily percent leaf area damage (%/d)
! PLFMD   Percent leaf mass damage (%/d)
! PSTMD   Daily percent stem mass damage (%)
! PSTRD   Daily percent storage organ mass damage (%)
! PVSTGD  Percent V-stage damage (%)
! PWTLF   Potential available leaf mass after the observed leaf damage is
!           applied (g[leaf]/m2)
! SDAM    Calculated stem damage (g/m2/d)
! SLA     Specific leaf area (cm2[leaf] / m2[ground])
! SLDOT   Defoliation due to daily leaf senescence (g/m2/day)
! SRDAM   Calculated storage organ damage (g/m2/d)
! SSDOT   Daily senescence of petioles (g / m2 / d)
! SSRDOT      Daily senescence of storage organ(g / m2 / d)
! STMWT   Dry mass of stem tissue, including C and N (g[stem] / m2[ground)
! STRWT   Dry mass of storage organ, including C and N (g[storage] / m2[ground)
! TDLA    Total diseased leaf area (cm2/m2)
! TLFAD   Total leaf area damage (cm2/cm2/d)
! TLFMD   Total leaf mass damage (g/m2/day)
! VSTAGE  Number of nodes on main stem of plant (nodes)
! VSTGD   Absolute daily V-stage damage (nodes/day)
! WLFDOT  Leaf weight losses due to freezing (g[leaf]/m2-d)
! WLIDOT  Daily pest or freeze damage to leaf mass (g/m2/day)
! WSFDOT        Stem weight losses due to freezing (g[stem]/m2-d)
! WSIDOT  Daily pest damage to stem mass (g/m2/day)
! WSRFDOT      Storage organ weight losses due to freezing (g[storage]/m2-d)
! WSRIDOT      Daily pest damage to storage organ mass (g/m2/day)
! WSTMD   Daily absolute stem damage (g/m2/day)
! WSTRD   Daily absolute storage organ damage (g/m2/day)
! WTLF    Dry mass of leaf tissue including C and N (g[leaf] / m2[ground])
!-----------------------------------------------------------------------
!     End Subroutine FOR_VEGDM
!-----------------------------------------------------------------------