      MODULE LGRMODULE
         INTEGER, SAVE, POINTER ::ISCHILD,NGRDS,NPLBEG,NPRBEG,NPCBEG
         INTEGER, SAVE, POINTER ::NPLEND,NPREND,NPCEND,NCPP,NPL,IBOTFLG
         INTEGER, SAVE, POINTER ::ISHFLG,IBFLG,IUPBHSV,IUCBHSV
         INTEGER, SAVE, POINTER ::IUPBFSV,IUCBFSV,MXLGRITER,IOUTLGR
         INTEGER, SAVE, POINTER ::NBNODES,NPBNODES
         INTEGER, SAVE, POINTER ::IBMAXH,IBMAXF,NCMAXH,NCMAXF
         REAL, SAVE, POINTER ::RELAXH,RELAXF,HCLOSELGR,FCLOSELGR
         REAL, SAVE, POINTER ::HDIFFM,FDIFFM
         REAL, SAVE, POINTER ::PRATIN,CRATIN,PRATOUT,CRATOUT
         INTEGER, SAVE, POINTER, DIMENSION(:)     ::IBPFLG
         INTEGER, SAVE, POINTER, DIMENSION(:)     ::IEDG
         INTEGER, SAVE, POINTER, DIMENSION(:)     ::JEDG
         INTEGER, SAVE, POINTER, DIMENSION(:)     ::NCPPL
         INTEGER, SAVE, POINTER, DIMENSION(:)     ::NODEH
         INTEGER, SAVE, POINTER, DIMENSION(:)     ::NODEF
         INTEGER, SAVE, POINTER, DIMENSION(:)     ::NCON
         INTEGER, SAVE, POINTER, DIMENSION(:,:)   ::KPLC
         INTEGER, SAVE, POINTER, DIMENSION(:,:)   ::IPLC
         INTEGER, SAVE, POINTER, DIMENSION(:,:)   ::JPLC
         INTEGER, SAVE, POINTER, DIMENSION(:,:)   ::IFACEGN
         INTEGER, SAVE, POINTER, DIMENSION(:,:,:) ::ICBOUND
         REAL, SAVE,    POINTER, DIMENSION(:,:)   ::GNHEAD
         REAL, SAVE,    POINTER, DIMENSION(:,:)   ::DHGN
         REAL, SAVE,    POINTER, DIMENSION(:,:)   ::GNFLUX
         REAL, SAVE,    POINTER, DIMENSION(:,:)   ::GNFLUXR
         REAL, SAVE,    POINTER, DIMENSION(:,:)   ::GNFLUXOLD
         REAL, SAVE,    POINTER, DIMENSION(:,:,:) ::HOLDC
         REAL, SAVE,    POINTER, DIMENSION(:,:)   ::GNCOND
         REAL, SAVE,    POINTER, DIMENSION(:)     ::VCB
         REAL, SAVE,    POINTER, DIMENSION(:,:,:) ::HK
         REAL, SAVE,    POINTER, DIMENSION(:,:,:) ::VK
        TYPE LGRTYPE
         INTEGER, POINTER ::ISCHILD,NGRDS,NPLBEG,NPRBEG,NPCBEG
         INTEGER, POINTER ::NPLEND,NPREND,NPCEND,NCPP,NPL,IBOTFLG
         INTEGER, POINTER ::ISHFLG,IBFLG,IUPBHSV,IUCBHSV
         INTEGER, POINTER ::IUPBFSV,IUCBFSV,MXLGRITER,IOUTLGR
         INTEGER, POINTER ::NBNODES,NPBNODES
         INTEGER, POINTER ::IBMAXH,IBMAXF,NCMAXH,NCMAXF
         REAL, POINTER ::RELAXH,RELAXF,HCLOSELGR,FCLOSELGR,HDIFFM,FDIFFM
         REAL, POINTER ::PRATIN,CRATIN,PRATOUT,CRATOUT
         INTEGER, POINTER,    DIMENSION(:)     ::IBPFLG
         INTEGER, POINTER,    DIMENSION(:)     ::IEDG
         INTEGER, POINTER,    DIMENSION(:)     ::JEDG
         INTEGER, POINTER,    DIMENSION(:)     ::NCPPL
         INTEGER, POINTER,    DIMENSION(:)     ::NODEH
         INTEGER, POINTER,    DIMENSION(:)     ::NODEF
         INTEGER, POINTER,    DIMENSION(:)     ::NCON
         INTEGER, POINTER,    DIMENSION(:,:)   ::KPLC
         INTEGER, POINTER,    DIMENSION(:,:)   ::IPLC
         INTEGER, POINTER,    DIMENSION(:,:)   ::JPLC
         INTEGER, POINTER,    DIMENSION(:,:)   ::IFACEGN
         INTEGER, POINTER,    DIMENSION(:,:,:) ::ICBOUND
         REAL,    POINTER,    DIMENSION(:,:)   ::GNHEAD
         REAL,    POINTER,    DIMENSION(:,:)   ::DHGN
         REAL,    POINTER,    DIMENSION(:,:)   ::GNFLUX
         REAL,    POINTER,    DIMENSION(:,:)   ::GNFLUXR
         REAL,    POINTER,    DIMENSION(:,:)   ::GNFLUXOLD
         REAL,    POINTER,    DIMENSION(:,:,:) ::HOLDC
         REAL,    POINTER,    DIMENSION(:,:)   ::GNCOND
         REAL,    POINTER,    DIMENSION(:)     ::VCB
         REAL,    POINTER,    DIMENSION(:,:,:) ::HK
         REAL,    POINTER,    DIMENSION(:,:,:) ::VK
        END TYPE
        TYPE(LGRTYPE), SAVE  ::LGRDAT(10)

      contains

      SUBROUTINE GWF2LGR2DA(IGRID)
C     ******************************************************************
C     DEALLOCATE LGR DATA
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      !USE LGRMODULE
C     ------------------------------------------------------------------
C
      DEALLOCATE(LGRDAT(IGRID)%NGRDS)
      DEALLOCATE(LGRDAT(IGRID)%NPLBEG)
      DEALLOCATE(LGRDAT(IGRID)%NPRBEG)
      DEALLOCATE(LGRDAT(IGRID)%NPCBEG)
      DEALLOCATE(LGRDAT(IGRID)%NPLEND)
      DEALLOCATE(LGRDAT(IGRID)%NPREND)
      DEALLOCATE(LGRDAT(IGRID)%NPCEND)
      DEALLOCATE(LGRDAT(IGRID)%NCPP)
      DEALLOCATE(LGRDAT(IGRID)%NPL)
      DEALLOCATE(LGRDAT(IGRID)%IBOTFLG)
      DEALLOCATE(LGRDAT(IGRID)%ISHFLG)
      DEALLOCATE(LGRDAT(IGRID)%IBFLG)
      DEALLOCATE(LGRDAT(IGRID)%IUPBHSV)
      DEALLOCATE(LGRDAT(IGRID)%IUCBHSV)
      DEALLOCATE(LGRDAT(IGRID)%IUPBFSV)
      DEALLOCATE(LGRDAT(IGRID)%IUCBFSV)
      DEALLOCATE(LGRDAT(IGRID)%MXLGRITER)
      DEALLOCATE(LGRDAT(IGRID)%IOUTLGR)
      DEALLOCATE(LGRDAT(IGRID)%RELAXH)
      DEALLOCATE(LGRDAT(IGRID)%RELAXF)
      DEALLOCATE(LGRDAT(IGRID)%HCLOSELGR)
      DEALLOCATE(LGRDAT(IGRID)%FCLOSELGR)
      DEALLOCATE(LGRDAT(IGRID)%HDIFFM)
      DEALLOCATE(LGRDAT(IGRID)%FDIFFM)
      DEALLOCATE(LGRDAT(IGRID)%IBPFLG)
      DEALLOCATE(LGRDAT(IGRID)%HK)
      DEALLOCATE(LGRDAT(IGRID)%VK)
      IF(LGRDAT(IGRID)%ISCHILD .GE. 0)THEN
        DEALLOCATE(LGRDAT(IGRID)%PRATIN)
        DEALLOCATE(LGRDAT(IGRID)%CRATIN)
        DEALLOCATE(LGRDAT(IGRID)%PRATOUT)
        DEALLOCATE(LGRDAT(IGRID)%CRATOUT)
        DEALLOCATE(LGRDAT(IGRID)%NBNODES)
        DEALLOCATE(LGRDAT(IGRID)%NPBNODES)
        DEALLOCATE(LGRDAT(IGRID)%IBMAXH)
        DEALLOCATE(LGRDAT(IGRID)%IBMAXF)
        DEALLOCATE(LGRDAT(IGRID)%NCMAXH)
        DEALLOCATE(LGRDAT(IGRID)%NCMAXF)
        DEALLOCATE(LGRDAT(IGRID)%IEDG)
        DEALLOCATE(LGRDAT(IGRID)%JEDG)
        DEALLOCATE(LGRDAT(IGRID)%NCPPL)
        DEALLOCATE(LGRDAT(IGRID)%NODEH)
        DEALLOCATE(LGRDAT(IGRID)%NODEF)
        DEALLOCATE(LGRDAT(IGRID)%NCON)
        DEALLOCATE(LGRDAT(IGRID)%KPLC)
        DEALLOCATE(LGRDAT(IGRID)%IPLC)
        DEALLOCATE(LGRDAT(IGRID)%JPLC)
        DEALLOCATE(LGRDAT(IGRID)%IFACEGN)
        DEALLOCATE(LGRDAT(IGRID)%ICBOUND)
        DEALLOCATE(LGRDAT(IGRID)%GNHEAD)
        DEALLOCATE(LGRDAT(IGRID)%HOLDC)
        DEALLOCATE(LGRDAT(IGRID)%DHGN)
        DEALLOCATE(LGRDAT(IGRID)%GNFLUX)
        DEALLOCATE(LGRDAT(IGRID)%GNFLUXR)
        DEALLOCATE(LGRDAT(IGRID)%GNFLUXOLD)
        DEALLOCATE(LGRDAT(IGRID)%GNCOND)
        DEALLOCATE(LGRDAT(IGRID)%VCB)
      ENDIF
      DEALLOCATE(LGRDAT(IGRID)%ISCHILD)
C
      RETURN
      END SUBROUTINE GWF2LGR2DA

C***********************************************************************

      SUBROUTINE SGWF2LGR2PNT(IGRID)
C     ******************************************************************
C     CHANGE POINTERS FOR LGR DATA TO A DIFFERENT GRID
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      !USE LGRMODULE
C     ------------------------------------------------------------------
C
      ISCHILD=>LGRDAT(IGRID)%ISCHILD
      NGRDS=>LGRDAT(IGRID)%NGRDS
      NPLBEG=>LGRDAT(IGRID)%NPLBEG
      NPRBEG=>LGRDAT(IGRID)%NPRBEG
      NPCBEG=>LGRDAT(IGRID)%NPCBEG
      NPLEND=>LGRDAT(IGRID)%NPLEND
      NPREND=>LGRDAT(IGRID)%NPREND
      NPCEND=>LGRDAT(IGRID)%NPCEND
      NCPP=>LGRDAT(IGRID)%NCPP
      NPL=>LGRDAT(IGRID)%NPL
      IBOTFLG=>LGRDAT(IGRID)%IBOTFLG
      ISHFLG=>LGRDAT(IGRID)%ISHFLG
      IBFLG=>LGRDAT(IGRID)%IBFLG
      IUPBHSV=>LGRDAT(IGRID)%IUPBHSV
      IUCBHSV=>LGRDAT(IGRID)%IUCBHSV
      IUPBFSV=>LGRDAT(IGRID)%IUPBFSV
      IUCBFSV=>LGRDAT(IGRID)%IUCBFSV
      MXLGRITER=>LGRDAT(IGRID)%MXLGRITER
      IOUTLGR=>LGRDAT(IGRID)%IOUTLGR
      RELAXH=>LGRDAT(IGRID)%RELAXH
      RELAXF=>LGRDAT(IGRID)%RELAXF
      HCLOSELGR=>LGRDAT(IGRID)%HCLOSELGR
      FCLOSELGR=>LGRDAT(IGRID)%FCLOSELGR
      HDIFFM=>LGRDAT(IGRID)%HDIFFM
      FDIFFM=>LGRDAT(IGRID)%FDIFFM
      PRATIN=>LGRDAT(IGRID)%PRATIN
      CRATIN=>LGRDAT(IGRID)%CRATIN
      PRATOUT=>LGRDAT(IGRID)%PRATOUT
      CRATOUT=>LGRDAT(IGRID)%CRATOUT
      IBPFLG=>LGRDAT(IGRID)%IBPFLG
      NBNODES=>LGRDAT(IGRID)%NBNODES
      NPBNODES=>LGRDAT(IGRID)%NPBNODES
      IBMAXH=>LGRDAT(IGRID)%IBMAXH
      IBMAXF=>LGRDAT(IGRID)%IBMAXF
      NCMAXH=>LGRDAT(IGRID)%NCMAXH
      NCMAXF=>LGRDAT(IGRID)%NCMAXF
      IEDG=>LGRDAT(IGRID)%IEDG
      JEDG=>LGRDAT(IGRID)%JEDG
      NCPPL=>LGRDAT(IGRID)%NCPPL
      NODEH=>LGRDAT(IGRID)%NODEH
      NODEF=>LGRDAT(IGRID)%NODEF
      NCON=>LGRDAT(IGRID)%NCON
      KPLC=>LGRDAT(IGRID)%KPLC
      IPLC=>LGRDAT(IGRID)%IPLC
      JPLC=>LGRDAT(IGRID)%JPLC
      IFACEGN=>LGRDAT(IGRID)%IFACEGN
      ICBOUND=>LGRDAT(IGRID)%ICBOUND
      GNHEAD=>LGRDAT(IGRID)%GNHEAD
      HOLDC=>LGRDAT(IGRID)%HOLDC
      DHGN=>LGRDAT(IGRID)%DHGN
      GNFLUX=>LGRDAT(IGRID)%GNFLUX
      GNFLUXR=>LGRDAT(IGRID)%GNFLUXR
      GNFLUXOLD=>LGRDAT(IGRID)%GNFLUXOLD
      GNCOND=>LGRDAT(IGRID)%GNCOND
      VCB=>LGRDAT(IGRID)%VCB
      HK=>LGRDAT(IGRID)%HK
      VK=>LGRDAT(IGRID)%VK
C
      RETURN
      END SUBROUTINE SGWF2LGR2PNT

C***********************************************************************

      SUBROUTINE SGWF2LGR2PSV(IGRID)
C     ******************************************************************
C     SAVE POINTERS ARRAYS FOR LGR DATA
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      !USE LGRMODULE
C     ------------------------------------------------------------------
C
      LGRDAT(IGRID)%ISCHILD=>ISCHILD
      LGRDAT(IGRID)%NGRDS=>NGRDS
      LGRDAT(IGRID)%NPLBEG=>NPLBEG
      LGRDAT(IGRID)%NPRBEG=>NPRBEG
      LGRDAT(IGRID)%NPCBEG=>NPCBEG
      LGRDAT(IGRID)%NPLEND=>NPLEND
      LGRDAT(IGRID)%NPREND=>NPREND
      LGRDAT(IGRID)%NPCEND=>NPCEND
      LGRDAT(IGRID)%NCPP=>NCPP
      LGRDAT(IGRID)%NPL=>NPL
      LGRDAT(IGRID)%IBOTFLG=>IBOTFLG
      LGRDAT(IGRID)%ISHFLG=>ISHFLG
      LGRDAT(IGRID)%IBFLG=>IBFLG
      LGRDAT(IGRID)%IUPBHSV=>IUPBHSV
      LGRDAT(IGRID)%IUCBHSV=>IUCBHSV
      LGRDAT(IGRID)%IUPBFSV=>IUPBFSV
      LGRDAT(IGRID)%IUCBFSV=>IUCBFSV
      LGRDAT(IGRID)%MXLGRITER=>MXLGRITER
      LGRDAT(IGRID)%IOUTLGR=>IOUTLGR
      LGRDAT(IGRID)%RELAXH=>RELAXH
      LGRDAT(IGRID)%RELAXF=>RELAXF
      LGRDAT(IGRID)%HCLOSELGR=>HCLOSELGR
      LGRDAT(IGRID)%FCLOSELGR=>FCLOSELGR
      LGRDAT(IGRID)%HDIFFM=>HDIFFM
      LGRDAT(IGRID)%FDIFFM=>FDIFFM
      LGRDAT(IGRID)%PRATIN=>PRATIN
      LGRDAT(IGRID)%CRATIN=>CRATIN
      LGRDAT(IGRID)%PRATOUT=>PRATOUT
      LGRDAT(IGRID)%CRATOUT=>CRATOUT
      LGRDAT(IGRID)%IBPFLG=>IBPFLG
      LGRDAT(IGRID)%NBNODES=>NBNODES
      LGRDAT(IGRID)%NPBNODES=>NPBNODES
      LGRDAT(IGRID)%IBMAXH=>IBMAXH
      LGRDAT(IGRID)%IBMAXF=>IBMAXF
      LGRDAT(IGRID)%NCMAXH=>NCMAXH
      LGRDAT(IGRID)%NCMAXF=>NCMAXF
      LGRDAT(IGRID)%IEDG=>IEDG
      LGRDAT(IGRID)%JEDG=>JEDG
      LGRDAT(IGRID)%NCPPL=>NCPPL
      LGRDAT(IGRID)%NODEH=>NODEH
      LGRDAT(IGRID)%NODEF=>NODEF
      LGRDAT(IGRID)%NCON=>NCON
      LGRDAT(IGRID)%KPLC=>KPLC
      LGRDAT(IGRID)%IPLC=>IPLC
      LGRDAT(IGRID)%JPLC=>JPLC
      LGRDAT(IGRID)%IFACEGN=>IFACEGN
      LGRDAT(IGRID)%ICBOUND=>ICBOUND
      LGRDAT(IGRID)%GNHEAD=>GNHEAD
      LGRDAT(IGRID)%HOLDC=>HOLDC
      LGRDAT(IGRID)%DHGN=>DHGN
      LGRDAT(IGRID)%GNFLUX=>GNFLUX
      LGRDAT(IGRID)%GNFLUXR=>GNFLUXR
      LGRDAT(IGRID)%GNFLUXOLD=>GNFLUXOLD
      LGRDAT(IGRID)%GNCOND=>GNCOND
      LGRDAT(IGRID)%VCB=>VCB
      LGRDAT(IGRID)%HK=>HK
      LGRDAT(IGRID)%VK=>VK
C
      RETURN
      END SUBROUTINE SGWF2LGR2PSV

      END MODULE LGRMODULE


! This routine returns the externally imposed (i.e. not reactions)
! heating source term to the enthalpy equation (actually rho * H
! is returned, where H has units of erg/g/s).

module heating_module

  use bl_types

  implicit none

  private
  public :: get_rho_Hext

contains

  subroutine get_rho_Hext(mla,tempbar_init,s,rho_Hext,the_bc_level,dx,dt)

    use multifab_module
    use define_bc_module
    use ml_layout_module
    use ml_cc_restriction_module, only : ml_cc_restriction
    use variables, only: foextrap_comp
    use geometry, only: spherical
    use bl_constants_module, only: ZERO
    use probin_module, only: drive_initial_convection
    use fill_3d_module, only: put_1d_array_on_cart

    type(ml_layout), intent(in   ) :: mla
    real(kind=dp_t), intent(in   ) :: tempbar_init(:,0:)
    type(multifab) , intent(in   ) :: s(:)
    type(multifab) , intent(inout) :: rho_Hext(:)
    type(bc_level) , intent(in   ) :: the_bc_level(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:),dt

    ! local
    integer                  :: n,i,ng_s,ng_h,ng_tc,dm,nlevs
    integer                  :: lo(3),hi(3)
    real(kind=dp_t), pointer ::  sp(:,:,:,:)
    real(kind=dp_t), pointer ::  hp(:,:,:,:)
    real(kind=dp_t), pointer :: tcp(:,:,:,:)

    type(multifab) :: tempbar_init_cart(mla%nlevel)

    type(bl_prof_timer), save :: bpt

    call build(bpt, "get_rho_Hext")

    dm = mla%dim
    nlevs = mla%nlevel

    ng_s = nghost(s(1))
    ng_h = nghost(rho_Hext(1))

    ! put tempbar_init on Cart
    if (spherical == 1) then
       do n=1, nlevs
          ! tempbar_init_cart will hold the initial tempbar on a Cartesian
          ! grid to be used if drive_initial_convection is true
          call build(tempbar_init_cart(n),mla%la(n),1,0)
          call setval(tempbar_init_cart(n), ZERO, all=.true.)
       enddo

       if (drive_initial_convection) then
          ! fill all components
          call put_1d_array_on_cart(tempbar_init,tempbar_init_cart, &
                                    foextrap_comp,.false.,.false.,dx, &
                                    the_bc_level,mla)
       endif
    endif

    lo(:) = 1
    hi(:) = 1

    do n=1,nlevs

       do i = 1, nfabs(s(n))
          sp => dataptr(s(n) , i)
          hp => dataptr(rho_Hext(n) , i)

          lo(1:dm) =  lwb(get_box(s(n), i))
          hi(1:dm) =  upb(get_box(s(n), i))

          if (spherical == 1) then
             tcp => dataptr(tempbar_init_cart(n), i)
             ng_tc = nghost(tempbar_init_cart(1))
             call get_rho_Hext_3d_sph(tcp(:,:,:,1),ng_tc, &
                                      hp(:,:,:,1),ng_h,sp(:,:,:,:),ng_s, &
                                      lo,hi,dx(n,:))
          else
             call get_rho_Hext_cart(tempbar_init(n,:), &
                                    hp, lbound(hp), ubound(hp), &
                                    sp, lbound(sp), ubound(sp), &
                                    lo,hi,dx(n,:))
          endif
       enddo

    end do

    ! the loop over nlevs must count backwards to make sure the finer grids are done first
    do n=nlevs,2,-1
       ! set level n-1 data to be the average of the level n data covering it
       call ml_cc_restriction(rho_Hext(n-1), rho_Hext(n), mla%mba%rr(n-1,:))
    end do

    call destroy(bpt)

    if (spherical == 1) then
       do n = 1, nlevs
          call destroy(tempbar_init_cart(n))
       enddo
    endif

  end subroutine get_rho_Hext

  subroutine get_rho_Hext_cart(tempbar_init,rho_Hext,hlo,hhi,s,slo,shi,lo,hi,dx)

    use bl_constants_module

    integer, intent(in) :: lo(:), hi(:), hlo(4), hhi(4), slo(4), shi(4)
    real(kind=dp_t), intent(inout) :: rho_Hext(hlo(1):hhi(1),hlo(2):hhi(2),hlo(3):hhi(3),hlo(4):hhi(4))
    real(kind=dp_t), intent(in   ) :: s(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),slo(4):shi(4))
    real(kind=dp_t), intent(in   ) :: tempbar_init(0:)
    real(kind=dp_t), intent(in   ) :: dx(:)

    rho_Hext = 0.0_dp_t

  end subroutine get_rho_Hext_cart

  subroutine get_rho_Hext_3d_sph(tempbar_init_cart,ng_tc, &
                                 rho_Hext,ng_h,s,ng_s, &
                                 lo,hi,dx)

    use bl_constants_module

    integer, intent(in) :: lo(:), hi(:), ng_s, ng_h, ng_tc
    real(kind=dp_t), intent(in   ) :: tempbar_init_cart(lo(1)-ng_tc:,lo(2)-ng_tc:,lo(3)-ng_tc:)
    real(kind=dp_t), intent(inout) :: rho_Hext(lo(1)-ng_h:,lo(2)-ng_h:,lo(3)-ng_h:)
    real(kind=dp_t), intent(in   ) ::        s(lo(1)-ng_s:,lo(2)-ng_s:,lo(3)-ng_s:,:)
    real(kind=dp_t), intent(in   ) :: dx(:)

    rho_Hext = 0.0_dp_t

  end subroutine get_rho_Hext_3d_sph

end module heating_module


subroutine wrsedmgrp(lundia    ,error     ,filename  ,itmapc    ,mmax      , &
                   & kmax      ,nmaxus    ,lsed      ,lsedtot   , &
                   & kfsmin    ,kfsmax    ,irequest  ,fds       ,iarrc     , &
                   & mf        ,ml        ,nf        ,nl        ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  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 3.
!
!  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, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: wrsedmgrp.f90 6408 2016-08-04 10:22:52Z jagers $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/io/src/output/wrsedmgrp.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Writes the time varying data for bedforms, sediment transport
!              and morphology to the FLOW MAP file
!
! Method used:
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use dfparall, only: inode, nproc, master
    use datagroups
    use globaldata
    use wrtarray, only: wrtvar
    use netcdf
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    include 'fsm.i'
    include 'tri-dyn.igd'
    integer(pntrsize)               , pointer :: sbuu
    integer(pntrsize)               , pointer :: sbvv
    integer(pntrsize)               , pointer :: ws
    integer(pntrsize)               , pointer :: dps
    logical                         , pointer :: lfbedfrmout
    integer                         , pointer :: celidt
    type (datagroup)                , pointer :: group4
    type (datagroup)                , pointer :: group5
    real(hp)                        , pointer :: morft
    real(fp)                        , pointer :: morfac
    integer                         , pointer :: nmaxgl
    integer                         , pointer :: mmaxgl
    integer                         , pointer :: io_prec
!
! Global variables
!
    integer                                                                           , intent(in)  :: itmapc  !!  Current time counter for the MAP data file
    integer                                                                                :: kmax    !  Description and declaration in esm_alloc_int.f90
    integer                                                                                :: lsed    !  Description and declaration in esm_alloc_int.f90
    integer                                                                                :: lsedtot !  Description and declaration in esm_alloc_int.f90
    integer                                                                                :: lundia  !  Description and declaration in inout.igs
    integer                                                                                :: mmax    !  Description and declaration in esm_alloc_int.f90
    integer                                                                                :: nmaxus  !  Description and declaration in esm_alloc_int.f90
    logical                                                                           , intent(out) :: error   !!  Flag=TRUE if an error is encountered
    character(*)                                                                      , intent(in)  :: filename    !  File name
    integer       , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)               , intent(in)  :: kfsmax      !  Description and declaration in esm_alloc_int.f90
    integer       , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)               , intent(in)  :: kfsmin      !  Description and declaration in esm_alloc_int.f90
    integer                                                                           , intent(in)  :: irequest    !  REQUESTTYPE_DEFINE: define variables, REQUESTTYPE_WRITE: write variables
    integer                                                                           , intent(in)  :: fds         !  File handle of output NEFIS/NetCDF file
    !
    integer    , dimension(4,0:nproc-1)                                               , intent(in)  :: iarrc       ! array containing collected grid indices
    integer    , dimension(0:nproc-1)                                                 , intent(in)  :: mf          ! first index w.r.t. global grid in x-direction
    integer    , dimension(0:nproc-1)                                                 , intent(in)  :: ml          ! last index w.r.t. global grid in x-direction
    integer    , dimension(0:nproc-1)                                                 , intent(in)  :: nf          ! first index w.r.t. global grid in y-direction
    integer    , dimension(0:nproc-1)                                                 , intent(in)  :: nl          ! last index w.r.t. global grid in y-direction
!
! Local variables
!
    integer                                       :: ierror     ! Local error flag
    integer                                       :: filetype
    character(16)                                 :: grnam4
    character(16)                                 :: grnam5
    !
    integer                                       :: iddim_time
    !
    data grnam4/'map-infsed-serie'/
    data grnam5/'map-sed-series'/
!
!! executable statements -------------------------------------------------------
!
    call getdatagroup(gdp, FILOUT_MAP, grnam4, group4)
    call getdatagroup(gdp, FILOUT_MAP, grnam5, group5)
    celidt         => group4%celidt
    !
    mmaxgl         => gdp%gdparall%mmaxgl
    nmaxgl         => gdp%gdparall%nmaxgl
    morft          => gdp%gdmorpar%morft
    morfac         => gdp%gdmorpar%morfac
    lfbedfrmout    => gdp%gdbedformpar%lfbedfrmout
    sbuu           => gdp%gdr_i_ch%sbuu
    sbvv           => gdp%gdr_i_ch%sbvv
    ws             => gdp%gdr_i_ch%ws
    dps            => gdp%gdr_i_ch%dps
    io_prec        => gdp%gdpostpr%io_prec
    !
    filetype = getfiletype(gdp, FILOUT_MAP)
    !
    ierror = 0
    select case (irequest)
    case (REQUESTTYPE_DEFINE)
       !
       ! Define dimensions
       !
       iddim_time    = adddim(gdp, lundia, FILOUT_MAP, 'time'   , nf90_unlimited)
       !
       ! map-infsed-serie
       !
       if (filetype == FTYPE_NEFIS) then
          call addelm(gdp, lundia, FILOUT_MAP, grnam4, 'ITMAPS', ' ', IO_INT4    , 0, longname='timestep number (ITMAPC*DT*TUNIT := time in sec from ITDATE)')
       endif
       if (lsedtot > 0) then
          call addelm(gdp, lundia, FILOUT_MAP, grnam4, 'MORFAC', ' ', io_prec , 0, longname='morphological acceleration factor (MORFAC)')
          call addelm(gdp, lundia, FILOUT_MAP, grnam4, 'MORFT' , ' ', IO_REAL8, 0, longname='morphological time (days since start of simulation)', unit='days')
       endif
       !
       group4%grp_dim = iddim_time
       group5%grp_dim = iddim_time
       celidt = 0
       !
    case (REQUESTTYPE_WRITE)
       !
       celidt = celidt + 1
       group5%celidt = celidt
       !
       ! Writing of output on every itmapc
       !
       if (filetype == FTYPE_NEFIS) then
          call wrtvar(fds, filename, filetype, grnam4, celidt, &
                    & gdp, ierror, lundia, itmapc, 'ITMAPS')
          if (ierror/=0) goto 9999
       endif
       !
       if (lsedtot > 0) then
          call wrtvar(fds, filename, filetype, grnam4, celidt, &
                    & gdp, ierror, lundia, morfac, 'MORFAC')
          if (ierror/=0) goto 9999
          !
          call wrtvar(fds, filename, filetype, grnam4, celidt, &
                    & gdp, ierror, lundia, morft, 'MORFT')
          if (ierror/=0) goto 9999
       endif
       !
    end select
    !
    ! Add sediment transport and morphology fields
    !
    call wrsedm(lundia    ,error     ,mmax      ,kmax      ,nmaxus    , &
              & lsed      ,lsedtot   ,irequest  ,fds       ,grnam5    , &
              & r(sbuu)   ,r(sbvv)   ,r(ws)     ,d(dps)    , &
              & filename  ,gdp       ,filetype  , &
              & mf        ,ml        ,nf        ,nl        , &
              & iarrc     ,kfsmin    ,kfsmax    )
    !
    ! Add bedform fields
    !
    if (lfbedfrmout) then
       call wrsedd(lundia    ,error     ,mmax      ,nmaxus    ,irequest  , &
                 & fds       ,grnam5    ,filename  ,gdp       ,filetype  , &
                 & mf        ,ml        ,nf        ,nl        ,iarrc     )
    endif
    !
    ! write error message if error occured and set error = .true.
    !
9999   continue
    if (ierror /= 0) error = .true.
end subroutine wrsedmgrp


!> Functionality for working with association schemes. The work mostly consists
!> of keeping track of indices.
module AssocSchemeUtils
  use thermopack_constants, only: verbose
  use association_var, only: association
  implicit none
  save

  ! An association scheme is nothing but a number of positive sites and a number
  ! of negative sites. Implementing sites as such pairs would be cleaner and
  ! more extensible.

  !> Association schemes.                   ! NONZERO INTERACTIONS FOR SCHEMES:
  integer, parameter :: assoc_scheme_1  = 1 !< AA
  integer, parameter :: assoc_scheme_2A = 2 !< AA AB BB
  integer, parameter :: assoc_scheme_2B = 3 !< AB
  integer, parameter :: assoc_scheme_2C = 4 !< AA AB, where A is a bipolar site that associates with all other sites
  integer, parameter :: assoc_scheme_3A = 5 !< AA AB AC BB BC CC
  integer, parameter :: assoc_scheme_3B = 6 !< AC BC
  integer, parameter :: assoc_scheme_4A = 7 !< AA AB AC AD BB BC BD CC CD DD
  integer, parameter :: assoc_scheme_4B = 8 !< AD BD CD
  integer, parameter :: assoc_scheme_4C = 9 !< AC AD BC BD
  integer, parameter :: assoc_scheme_1ea = 10 !< One site with positive polarity
  integer, parameter :: no_assoc = -1       !< No self-association.

  !> Combining rules
  integer, parameter :: ariComb = 1 !< Arithmetic mean combining rule.
  integer, parameter :: geoComb = 0 !< Geometric mean combining rule.

  integer, parameter :: noSitesFlag = -1

contains

  subroutine assocIndices_bookkeeping (assoc, nc, saft_model, assocSchemes_db)
    use eosdata, only: eosPC_SAFT, eosSAFT_VR_MIE, eosPeTS, eosLJS_BH, &
         get_eos_short_label_from_subidx, eosLJS_WCA, eosLJS_UV, eosLJ_UF
    type(association), intent(inout) :: assoc
    integer, intent(in) :: nc
    integer, intent(in) :: saft_model
    integer, intent(in) :: assocSchemes_db(nc)
    ! Locals
    integer :: ic
    integer :: assocCompIdcs(nc)

    if (allocated(assoc%comp_vs_sites)) deallocate(assoc%comp_vs_sites)
    allocate(assoc%comp_vs_sites(nc,2))

    ! Iterate through the components, count the number of self-associating ones,
    ! as well as the total number of association sites.
    assoc%numAssocComps = 0
    assoc%numAssocSites = 0
    do ic=1,nc
       ! Count numAssocComps.
       if (assocSchemes_db(ic) .ne. no_assoc) then
          assoc%numAssocComps = assoc%numAssocComps + 1
          assocCompIdcs(assoc%numAssocComps) = ic
       end if
       ! Count association sites, and construct a mapping from component
       ! indices to site numbers.
       select case (assocSchemes_db(ic))
       case (assoc_scheme_1)
          assoc%numAssocSites = assoc%numAssocSites + 1
          assoc%comp_vs_sites(ic,1) = assoc%numAssocSites
          assoc%comp_vs_sites(ic,2) = assoc%numAssocSites
       case (assoc_scheme_2A,assoc_scheme_2B,assoc_scheme_2C)
          assoc%numAssocSites = assoc%numAssocSites + 2
          assoc%comp_vs_sites(ic,1) = assoc%numAssocSites - 1
          assoc%comp_vs_sites(ic,2) = assoc%numAssocSites
       case (assoc_scheme_3A,assoc_scheme_3B)
          assoc%numAssocSites = assoc%numAssocSites + 3
          assoc%comp_vs_sites(ic,1) = assoc%numAssocSites - 2
          assoc%comp_vs_sites(ic,2) = assoc%numAssocSites
       case (assoc_scheme_4A,assoc_scheme_4B,assoc_scheme_4C)
          assoc%numAssocSites = assoc%numAssocSites + 4
          assoc%comp_vs_sites(ic,1) = assoc%numAssocSites - 3
          assoc%comp_vs_sites(ic,2) = assoc%numAssocSites
       case (no_assoc)
          assoc%comp_vs_sites(ic,:) = noSitesFlag
       end select
    end do

    if (allocated(assoc%compidcs)) deallocate(assoc%compidcs)
    allocate(assoc%compidcs(assoc%numAssocComps))

    assoc%compidcs(:) = assocCompIdcs(1:assoc%numAssocComps)

    if (assoc%numAssocSites .eq. 0) then
       ! No associating components: exit routine.
      if ( saft_model == eosPC_SAFT .or. &
           saft_model == eosSAFT_VR_MIE .or. &
           saft_model == eosPeTS .or. &
           saft_model == eosLJS_BH .or. &
           saft_model == eosLJS_WCA .or. &
           saft_model == eosLJS_UV .or. &
           saft_model == eosLJ_UF) then
        if (verbose) print *, "Using " // get_eos_short_label_from_subidx(saft_model) &
             // " with no associating components."
        return
      else
        call stoperror("At least one CPA-component must self-associate.")
      end if
    end if

  end subroutine assocIndices_bookkeeping

  !*************************** INDEX FUNCTIONS ***************************!
  !> Gives the component number ic to which association site number k belongs.
  INTEGER FUNCTION site_to_compidx(assoc,k)
    type(association), intent(in) :: assoc
    integer, intent(in)  :: k !< the association site number
    integer :: ic

    ic = 1
    do while (.true.)
       if (assoc%comp_vs_sites(ic,2) >= k .and. k >= assoc%comp_vs_sites(ic,1)) then
          site_to_compidx = ic
          return
       end if
       ic = ic+1
    end do
  end FUNCTION site_to_compidx

  !> Gives the first and last association sites, k_first and k_last, for comp i.
  subroutine compidx_to_sites(assoc,ic,k_first,k_last)
    type(association), intent(in) :: assoc
    integer, intent(in)  :: ic  !< the original component index
    integer, intent(out) :: k_first !< the first association site number for comp i
    integer, intent(out) :: k_last  !< the last association site number for comp i

    k_first = assoc%comp_vs_sites(ic,1)
    k_last = assoc%comp_vs_sites(ic,2)
  end subroutine compidx_to_sites

  !> Implements the combining rules for eps and beta seen in CPA models.
  function applyCombiningRule (ruleIdx,val1,val2)
    real :: applyCombiningRule
    real, intent(in) :: val1, val2
    integer, intent(in) :: ruleIdx

    if ( ruleIdx == ariComb ) then
       applyCombiningRule = (val1+val2)/2
    else if (ruleIdx == geoComb) then
       applyCombiningRule = sqrt(val1*val2)
    else
       print *, "Comb rule inputted:", ruleIdx
       call stoperror("No such combining rule.")
    end if
  end function applyCombiningRule

  !> Returns true if there is nonzero interaction between site1 and site2,
  !> according to association scheme assoc_scheme.
  function site_interaction_internal (site1,site2,assoc_scheme)
    ! Input.
    integer, intent(in) :: site1, site2 !< Interaction sites
    integer, intent(in) :: assoc_scheme !< Association scheme
    ! Output.
    logical :: site_interaction_internal

    ! ! Sanity check on input (development phase)
    ! call check_site_and_scheme(site1,assoc_scheme)
    ! call check_site_and_scheme(site2,assoc_scheme)

    ! Assign truth value according to association scheme. Reference: Kontogeorgis&Folas: "Thermodynamic Models for Industrial Applications".
    site_interaction_internal = .false.
    select case (assoc_scheme)
    case (assoc_scheme_1)
       site_interaction_internal = .true.
    case (assoc_scheme_2A)
       site_interaction_internal = .true.
    case (assoc_scheme_2B)
       if (site1 .ne. site2) site_interaction_internal = .true.
    case (assoc_scheme_2C)
       if (site1==1 .or. site2==1) site_interaction_internal = .true.
    case (assoc_scheme_3A)
       site_interaction_internal = .true.
    case (assoc_scheme_3B)
       if (site1 .eq. 3 .neqv. site2 .eq. 3) site_interaction_internal = .true.
    case (assoc_scheme_4A)
       site_interaction_internal = .true.
    case (assoc_scheme_4B)
       if (site1 .eq. 4 .neqv. site2 .eq. 4) site_interaction_internal = .true.
    case (assoc_scheme_4C)
       if ( (site1 .le. 2 .and. (site2 .ge. 3)) .or. (site2 .le. 2 .and. (site1 .ge. 3)) ) site_interaction_internal = .true.
    end select
  end function site_interaction_internal

  !> Given two associating components with different association schemes, one sometimes wants to model only the realistic
  !> site--site combinations on the different molecules, e.g. only the positively charged sites on ethanol should interact
  !> only with the negatively charged sites on H2O, and vice versa for negatively charged sites on ethanol and positively
  !> charged sites on H2O. This is the function which specifies this. It returns true if there is nonzero interaction
  !> between site1 on a molecule using scheme I and site2 on a molecule with scheme II.
  function cross_site_interaction (site1,site2,assoc_scheme_I,assoc_scheme_II)
    ! Input.
    integer, intent(in) :: site1, site2                    !< Interaction sites.
    integer, intent(in) :: assoc_scheme_I, assoc_scheme_II !< Association schemes.
    ! Output.
    logical :: cross_site_interaction
    ! Internal.
    integer :: pol1,pol2

    ! ! Sanity check on input. (For testing.)
    ! call check_site_and_scheme(site1,assoc_scheme_I)
    ! call check_site_and_scheme(site2,assoc_scheme_II)

    cross_site_interaction = .false.
    if (assoc_scheme_I == no_assoc .or. assoc_scheme_II == no_assoc) then
       cross_site_interaction = .false.
       return
    end if

    pol1 = polarity(site1,assoc_scheme_I)
    pol2 = polarity(site2,assoc_scheme_II)
    if (pol1*pol2 > 0) then
       cross_site_interaction = .false.
    else
       cross_site_interaction = .true.
    end if
  end function cross_site_interaction

  !> Retrieve polarity of site given association scheme.
  !> If an association scheme X is not coded in this function, the site will be given polarity 0, which the
  !> code interprets as having cross-interaction with all sites on any different component.
  function polarity (site,scheme)
    integer, intent(in) :: site,scheme
    integer :: polarity
    polarity = 0
    select case (scheme)
    case (assoc_scheme_1)
       polarity = -1
    case (assoc_scheme_2B)
       if (site .eq. 1) polarity = -1
       if (site .eq. 2) polarity = 1
    case (assoc_scheme_2C)
       if (site .eq. 1) polarity = 0 ! bipolar site
       if (site .eq. 2) polarity = -1
    case (assoc_scheme_3B)
       if (site .le. 2) polarity = 1
       if (site .eq. 3) polarity = -1
    case (assoc_scheme_4C)
       if (site .le. 2) polarity = -1
       if (site .ge. 3) polarity = 1
    case (assoc_scheme_1ea)
       polarity = 1
    end select
  end function polarity

  !> Sanity check for the input (site,scheme).
  subroutine check_site_and_scheme(site,scheme)
    integer, intent(in) :: site, scheme
    if (site < 1) call stoperror("Specify a site using a positive integer.")
    select case (scheme)
    case (assoc_scheme_1)
       if (site > 1) call stoperror("Index exceeds number of sites in scheme!")
    case (assoc_scheme_2A, assoc_scheme_2B, assoc_scheme_2C)
       if (site > 2) call stoperror("Index exceeds number of sites in scheme!")
    case (assoc_scheme_3A,assoc_scheme_3B)
       if (site > 3) call stoperror("Index exceeds number of sites in scheme!")
    case (assoc_scheme_4A,assoc_scheme_4B,assoc_scheme_4C)
       if (site > 4) call stoperror("Index exceeds number of sites in scheme!")
    case (no_assoc)
       call stoperror("Component has not been assigned an association scheme.")
    end select

  end subroutine check_site_and_scheme

  function get_assoc_string(assoc) result(as)
    integer, intent(in) :: assoc
    character(len=10) :: as
    select case(assoc)
    case(assoc_scheme_1)
      as = "1"
    case(assoc_scheme_2A)
      as = "2A"
    case(assoc_scheme_2B)
      as = "2B"
    case(assoc_scheme_2C)
      as = "2C"
    case(assoc_scheme_3A)
      as = "3A"
    case(assoc_scheme_3B)
      as = "3B"
    case(assoc_scheme_4A)
      as = "4A"
    case(assoc_scheme_4B)
      as = "4B"
    case(assoc_scheme_4C)
      as = "4C"
    case(assoc_scheme_1ea)
      as = "1ea"
    case(no_assoc)
      as = "None"
    case default
      print *,"Wrong assoc model"
      as = ""
    end select
  end function get_assoc_string

end module AssocSchemeUtils


      SUBROUTINE zmovbk6 (SVALUES, DVALUES, LDOUBLE, LFILDOB,
     * JQUAL, LQVALS, LQBLOK, NSTART, NVALS,
     * JULS, ISTIME, INTL, BLOCK, DBLOCK, IBLOCK, NDATA,
     * JULSD, ISTAT, IFLAG)
C
C
C     INTERNAL SUBROUTINE FOR zptdts6 AND zgtdts6
C     GIVEN A BUFFER OF INFO, WHICH STARTS AT PERIOD NSTART,
C     AND ENDS AT NVALS, WITH THE TIME FOR PERIOD 1 OF JULS
C     DAYS AND ISTIME MINUTES.
C
C     PUT INFO IN ARRAY BLOCK AND UP TO MAX OF NDATA, WITH
C     TIME FOR LOCATION 1 OF JULSD.  INTERVAL OF VALUES
C     IS INTL IN MINUTES.
C
C     VALUES is the array passed back to the users routine
C     BLOCK is the array read or written to the DSS file
C
C     IF IFLAG = 1, MOVE VALUES INTO BLOCK
C     IF IFLAG = -1, UPDATE VALUES INTO BLOCK
C
C
      REAL SVALUES(*), BLOCK(*)
      INTEGER JQUAL(*), IBLOCK(*)
      DOUBLE PRECISION DVALUES(*), DBLOCK(*)
C
      CHARACTER CDATE1*9, CDATE2*9
      LOGICAL LQVALS, LQBLOK, LEQNER, LDOUBLE, LFILDOB, LEQNERD
      LOGICAL ztstqp6
C
      INCLUDE 'zdssmz.h'
C
      INCLUDE 'zdsslz.h'
C
      INCLUDE 'zdssnz.h'
C
      external lismissingf
      logical lismissingf
      external lismissingd
      logical lismissingd
C
C
      ISTAT = 0
      IF (MLEVEL.GE.9) THEN
      CALL JULDAT (JULS, 114, CDATE1, N)
      CALL JULDAT (JULSD, 114, CDATE2, N)
      WRITE (MUNIT,10) NSTART, NVALS, JULS, ISTIME, NDATA, JULSD,
     * CDATE1, CDATE2, LQVALS, LQBLOK
 10   FORMAT (T10,'----- ENTERING zmovbk6 ',
     */,T5,'NSTART:',I5,T20,'NVALS:',I5,/,T5,'JULS:',I5,
     *T20,'ISTIME:',I5,/,T5,'NDATA:',I5,T20,'JULSD:',I5,
     */,T5,'JULS:',A,T25,'JULSD:',A,/,T5,
     * 'Value Quality Flag: ',L1,',  Block Qualtiy Flag: ',L1)
      ENDIF
C
C
C     GET THE NUMBER OF PERIODS FROM START OF BLOCK TO VALUES
      NPOS = NOPERS (INTL, 0, JULSD, 0, JULS, ISTIME) + NSTART - 1
      IF (NPOS.LT.1) GO TO 910
C
C     Find Upper Limit
C
      NSTORE = NDATA - NPOS + 1
      J = NVALS - NSTART + 1
      IF (J.LT.NSTORE) NSTORE = J
      ILIM = NSTART + NSTORE - 1
C
      IF  (MLEVEL.GE.9) WRITE (MUNIT,25) NPOS, NDATA, NSTORE, ILIM
 25   FORMAT (T10,' --- zmovbk6 CALCULATIONS --',
     */,T5,'NPOS:',I5,T20,'NDATA:',I5,
     */,T5,'NSTORE:',I5,T20,'ILIM:',I5)
C
C     Now move block
C     Prepare block to be stored (called by zsrts6)
C
C     Is data quality used?
      IF ((.NOT.LQVALS).AND.(.NOT.LQBLOK)) THEN
C        No quality
         M = NPOS - 1
C
         IF (LDOUBLE.EQV.LFILDOB) THEN
            IF (.NOT.LDOUBLE) THEN
C              Copy single array to single
               DO 100 I=NSTART,ILIM
                  M = M + 1
                  IF (IFLAG.LT.0) THEN
                     IF (IFLAG.EQ.-1) THEN
                        IF (.NOT.lismissingf(BLOCK(M)))go to 100
                     ELSE IF (IFLAG.EQ.-4) THEN
                        IF (lismissingf(SVALUES(I)))GO TO 100
                     ENDIF
                  ENDIF
                  IF (LTOL) THEN
                     IF (.NOT.(LEQNER(BLOCK(M), SVALUES(I),
     *               TOL))) BLOCK(M) = SVALUES(I)
                  ELSE
                     BLOCK(M) = SVALUES(I)
                  ENDIF
 100           CONTINUE
C
            ELSE
C              Copy double array to double
               DO 120 I=NSTART,ILIM
                  M = M + 1
                  IF (IFLAG.LT.0) THEN
                     IF (IFLAG.EQ.-1) THEN
                        IF (.NOT.lismissingd(DBLOCK(M))) GO TO 120
                     ELSE IF (IFLAG.EQ.-4) THEN
                        IF (lismissingd(DVALUES(I))) GO TO 120
                     ENDIF
                  ENDIF
                  IF (LTOL) THEN
                     IF (.NOT.(LEQNERD(DBLOCK(M), DVALUES(I), TOL)))
     *                   DBLOCK(M) = DVALUES(I)
                  ELSE
                     DBLOCK(M) = DVALUES(I)
                  ENDIF
 120           CONTINUE
            ENDIF
C
         ELSE
C
            IF (LFILDOB) THEN
C              Double (DBLOCK) on disk, inputing single (SVALUES)
C              Copy single array to double
               DO 140 I=NSTART,ILIM
                  M = M + 1
                  IF (IFLAG.LT.0) THEN
                     IF (IFLAG.EQ.-1) THEN
                        IF (.NOT.lismissingd(DBLOCK(M))) GO TO 140
                     ELSE IF (IFLAG.EQ.-4) THEN
                        IF (lismissingd(SVALUES(I))) GO TO 140
                     ENDIF
                  ENDIF
                  IF (LTOL) THEN
                     IF (.NOT.(LEQNER(SNGL(DBLOCK(M)), SVALUES(I),
     *               TOL))) DBLOCK(M) = DBLE (SVALUES(I))
                  ELSE
                     DBLOCK(M) = DBLE (SVALUES(I))
                  ENDIF
 140           CONTINUE
            ELSE
C
C              Single (SBLOCK) on disk, inputing doubles (DVALUES)
C              This is not leagl, and is taken care of in zsrtsi6
               GO TO 920
            ENDIF
C
         ENDIF
C
      ELSE
C
C        Data quality used
         IF (.NOT.LDOUBLE) THEN
C           Copy single array to single
            M = ((NPOS - 1) * 2) - 1
            DO 160 I=NSTART,ILIM
               M = M + 2
               IF (IFLAG.LT.0) THEN
                  IF (IFLAG.EQ.-1) THEN
                      IF (.NOT.lismissingf(BLOCK(M))) GO TO 160
                  ELSE IF (IFLAG.EQ.-4) THEN
                     IF (.NOT.lismissingf(SVALUES(I))) GO TO 160
                  ENDIF
               ENDIF
C              Check for quality protection bit
               IF (LQPBIT.AND.LQVALS) THEN
C                 If protection bit on, and
                  IF (ztstqp6(IBLOCK(M+1)).AND.(.NOT.ztstqp6(JQUAL(I))))
     *                GO TO 160
               ENDIF
C              Copy data value
               IF (LTOL) THEN
                  IF (.NOT.(LEQNER(BLOCK(M), SVALUES(I), TOL)))
     *            BLOCK(M) = SVALUES(I)
               ELSE
                  BLOCK(M) = SVALUES(I)
               ENDIF
C              Copy quality value
               IF (LQVALS) THEN
                  IBLOCK(M+1) = JQUAL(I)
               ELSE
                  IBLOCK(M+1) = 0
               ENDIF
 160        CONTINUE
C
         ELSE
C
C           Copy double array to double
            M = NPOS - 1
            DO 180 I=NSTART,ILIM
               M = M + 1
               IF (IFLAG.LT.0) THEN
                  IF (IFLAG.EQ.-1) THEN
                     IF (.NOT.lismissingd(DBLOCK(M))) GO TO 180
                  ELSE IF (IFLAG.EQ.-4) THEN
                     IF (lismissingd(DVALUES(I))) GO TO 180
                  ENDIF
               ENDIF
C              Check for quality protection bit
               IF (LQPBIT.AND.LQVALS) THEN
C                 If protection bit on, and
                  IF (ztstqp6(IBLOCK((NDATA*2)+M)).AND.
     *               (.NOT.ztstqp6(JQUAL(I)))) GO TO 180
               ENDIF
C              Copy data value
               IF (LTOL) THEN
                  IF (.NOT.(LEQNER(SNGL(DBLOCK(M)), SNGL(DVALUES(I)),
     *            TOL))) DBLOCK(M) = DVALUES(I)
               ELSE
                  DBLOCK(M) = DVALUES(I)
               ENDIF
C              Copy quality value
               IF (LQVALS) THEN
                  IBLOCK((NDATA*2)+M) = JQUAL(I)
               ELSE
                  IBLOCK((NDATA*2)+M) = 0
               ENDIF
 180        CONTINUE
         ENDIF
      ENDIF
C
C
C     Update pointers
      NSTART = ILIM + 1
      RETURN
C
C     ------ERROR CONDITIONS-------
C
 910  CONTINUE
      CALL JULDAT (JULS, 114, CDATE1, N)
      CALL JULDAT (JULSD, 114, CDATE2, N)
      WRITE (MUNIT, 911) JULS, ISTIME, NPOS, JULSD, CDATE1, CDATE2
 911  FORMAT (//,' ***** ERROR - zmovbk6 - Illegal Starting Date',
     +4(2X,I6)/,' Start Date: ',A,'  Block Date: ',A/)
      ISTAT = 21
      RETURN
C
 920  CONTINUE
C     Probably cannot get here
      WRITE (MUNIT, 921)
 921  FORMAT (/, ' ***** ERROR - zmovbk6 - Illegal operation')
      ISTAT = 22
      RETURN
C
      END


      MODULE GWFGHBMODULE
        INTEGER,SAVE,POINTER  ::NBOUND,MXBND,NGHBVL,IGHBCB,IPRGHB
        INTEGER,SAVE,POINTER  ::NPGHB,IGHBPB,NNPGHB
        CHARACTER(LEN=16),SAVE, DIMENSION(:),   POINTER     ::GHBAUX
        REAL,             SAVE, DIMENSION(:,:), POINTER     ::BNDS
      TYPE GWFGHBTYPE
        INTEGER,POINTER  ::NBOUND,MXBND,NGHBVL,IGHBCB,IPRGHB
        INTEGER,POINTER  ::NPGHB,IGHBPB,NNPGHB
        CHARACTER(LEN=16), DIMENSION(:),   POINTER     ::GHBAUX
        REAL,              DIMENSION(:,:), POINTER     ::BNDS
      END TYPE
      TYPE(GWFGHBTYPE), SAVE:: GWFGHBDAT(10)
      END MODULE GWFGHBMODULE

      SUBROUTINE GWF2GHB7AR(IN,IGRID)
C     ******************************************************************
C     ALLOCATE ARRAY STORAGE AND READ PARAMETER DEFINITIONS FOR GHB
C     PACKAGE
C     ******************************************************************
C
C     SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL,       ONLY:IOUT,NCOL,NROW,NLAY,IFREFM
      USE GWFGHBMODULE, ONLY:NBOUND,MXBND,NGHBVL,IGHBCB,IPRGHB,NPGHB,
     1                       IGHBPB,NNPGHB,GHBAUX,BNDS
C
      CHARACTER*200 LINE
C     ------------------------------------------------------------------
      ALLOCATE(NBOUND,MXBND,NGHBVL,IGHBCB,IPRGHB)
      ALLOCATE(NPGHB,IGHBPB,NNPGHB)
C
C1------IDENTIFY PACKAGE AND INITIALIZE NBOUND.
      WRITE(IOUT,1)IN
    1 FORMAT(1X,/1X,'GHB -- GENERAL-HEAD BOUNDARY PACKAGE, VERSION 7',
     1   ', 5/2/2005',/,9X,'INPUT READ FROM UNIT ',I4)
      NBOUND=0
      NNPGHB=0
C
C2------READ MAXIMUM NUMBER OF GHB'S AND UNIT OR FLAG FOR
C2------CELL-BY-CELL FLOW TERMS.
      CALL URDCOM(IN,IOUT,LINE)
      CALL UPARLSTAL(IN,IOUT,LINE,NPGHB,MXPB)
      IF(IFREFM.EQ.0) THEN
         READ(LINE,'(2I10)') MXACTB,IGHBCB
         LLOC=21
      ELSE
         LLOC=1
         CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,MXACTB,R,IOUT,IN)
         CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IGHBCB,R,IOUT,IN)
      END IF
      WRITE(IOUT,3) MXACTB
    3 FORMAT(1X,'MAXIMUM OF ',I6,' ACTIVE GHB CELLS AT ONE TIME')
      IF(IGHBCB.LT.0) WRITE(IOUT,7)
    7 FORMAT(1X,'CELL-BY-CELL FLOWS WILL BE PRINTED WHEN ICBCFL NOT 0')
      IF(IGHBCB.GT.0) WRITE(IOUT,8) IGHBCB
    8 FORMAT(1X,'CELL-BY-CELL FLOWS WILL BE SAVED ON UNIT ',I4)
C
C3------READ AUXILIARY VARIABLES AND PRINT OPTION.
      ALLOCATE (GHBAUX(20))
      NAUX=0
      IPRGHB=1
   10 CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
      IF(LINE(ISTART:ISTOP).EQ.'AUXILIARY' .OR.
     1        LINE(ISTART:ISTOP).EQ.'AUX') THEN
         CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,IN)
         IF(NAUX.LT.5) THEN
            NAUX=NAUX+1
            GHBAUX(NAUX)=LINE(ISTART:ISTOP)
            WRITE(IOUT,12) GHBAUX(NAUX)
   12       FORMAT(1X,'AUXILIARY GHB VARIABLE: ',A)
         END IF
         GO TO 10
      ELSE IF(LINE(ISTART:ISTOP).EQ.'NOPRINT') THEN
         WRITE(IOUT,13)
   13    FORMAT(1X,'LISTS OF GENERAL-HEAD BOUNDARY CELLS WILL NOT BE',
     &          ' PRINTED')
         IPRGHB = 0
         GO TO 10
      END IF
C3A-----THERE ARE FIVE INPUT DATA VALUES PLUS ONE LOCATION FOR
C3A-----CELL-BY-CELL FLOW.
      NGHBVL=6+NAUX
C
C4------ALLOCATE SPACE FOR THE BNDS ARRAY.
      IGHBPB=MXACTB+1
      MXBND=MXACTB+MXPB
      ALLOCATE (BNDS(NGHBVL,MXBND))
C
C-------READ NAMED PARAMETERS.
      WRITE(IOUT,1000) NPGHB
 1000 FORMAT(1X,//1X,I5,' GHB parameters')
      IF(NPGHB.GT.0) THEN
        NAUX=NGHBVL-6
        LSTSUM=IGHBPB
        DO 120 K=1,NPGHB
          LSTBEG=LSTSUM
          CALL UPARLSTRP(LSTSUM,MXBND,IN,IOUT,IP,'GHB','GHB',1,
     &                  NUMINST)
          NLST=LSTSUM-LSTBEG
          IF (NUMINST.EQ.0) THEN
C5A-----READ LIST OF CELLS WITHOUT INSTANCES.
            CALL ULSTRD(NLST,BNDS,LSTBEG,NGHBVL,MXBND,1,IN,IOUT,
     &      'BOUND. NO. LAYER   ROW   COL     STAGE    STRESS FACTOR',
     &      GHBAUX,20,NAUX,IFREFM,NCOL,NROW,NLAY,5,5,IPRGHB)
          ELSE
C5B-----READ INSTANCES
            NINLST=NLST/NUMINST
            DO 110 I=1,NUMINST
            CALL UINSRP(I,IN,IOUT,IP,IPRGHB)
            CALL ULSTRD(NINLST,BNDS,LSTBEG,NGHBVL,MXBND,1,IN,IOUT,
     &      'BOUND. NO. LAYER   ROW   COL     STAGE    STRESS FACTOR',
     &      GHBAUX,20,NAUX,IFREFM,NCOL,NROW,NLAY,5,5,IPRGHB)
            LSTBEG=LSTBEG+NINLST
  110       CONTINUE
          END IF
  120   CONTINUE
      END IF
C
C6------RETURN
      CALL SGWF2GHB7PSV(IGRID)
      RETURN
      END
      SUBROUTINE GWF2GHB7RP(IN,IGRID)
C     ******************************************************************
C     READ GHB HEAD, CONDUCTANCE AND BOTTOM ELEVATION
C     ******************************************************************
C
C     SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL,       ONLY:IOUT,NCOL,NROW,NLAY,IFREFM
      USE GWFGHBMODULE, ONLY:NBOUND,MXBND,NGHBVL,IPRGHB,NPGHB,
     1                       IGHBPB,NNPGHB,GHBAUX,BNDS
C     ------------------------------------------------------------------
      CALL SGWF2GHB7PNT(IGRID)
C
C1------READ ITMP (NUMBER OF GHB'S OR FLAG TO REUSE DATA) AND
C1------NUMBER OF PARAMETERS.
      IF(NPGHB.GT.0) THEN
         IF(IFREFM.EQ.0) THEN
            READ(IN,'(2I10)') ITMP,NP
         ELSE
            READ(IN,*) ITMP,NP
         END IF
      ELSE
         NP=0
         IF(IFREFM.EQ.0) THEN
            READ(IN,'(I10)') ITMP
         ELSE
            READ(IN,*) ITMP
         END IF
      END IF
C
C------CALCULATE SOME CONSTANTS
      NAUX=NGHBVL-6
      IOUTU = IOUT
      IF (IPRGHB.EQ.0) IOUTU=-IOUT
C
C2------DETERMINE THE NUMBER OF NON-PARAMETER GHB'S.
      IF(ITMP.LT.0) THEN
         WRITE(IOUT,7)
    7    FORMAT(1X,/1X,
     1   'REUSING NON-PARAMETER GHB CELLS FROM LAST STRESS PERIOD')
      ELSE
         NNPGHB=ITMP
      END IF
C
C3------IF THERE ARE NEW NON-PARAMETER GHB'S, READ THEM.
      MXACTB=IGHBPB-1
      IF(ITMP.GT.0) THEN
         IF(NNPGHB.GT.MXACTB) THEN
            WRITE(IOUT,99) NNPGHB,MXACTB
   99       FORMAT(1X,/1X,'THE NUMBER OF ACTIVE GHB CELLS (',I6,
     1                     ') IS GREATER THAN MXACTB(',I6,')')
            CALL USTOP(' ')
         END IF
         CALL ULSTRD(NNPGHB,BNDS,1,NGHBVL,MXBND,1,IN,IOUT,
     1      'BOUND. NO. LAYER   ROW   COL     STAGE      CONDUCTANCE',
     2      GHBAUX,20,NAUX,IFREFM,NCOL,NROW,NLAY,5,5,IPRGHB)
      END IF
      NBOUND=NNPGHB
C
C1C-----IF THERE ARE ACTIVE GHB PARAMETERS, READ THEM AND SUBSTITUTE
      CALL PRESET('GHB')
      IF(NP.GT.0) THEN
         NREAD=NGHBVL-1
         DO 30 N=1,NP
         CALL UPARLSTSUB(IN,'GHB',IOUTU,'GHB',BNDS,NGHBVL,MXBND,NREAD,
     1                MXACTB,NBOUND,5,5,
     2      'BOUND. NO. LAYER   ROW   COL     STAGE      CONDUCTANCE',
     3            GHBAUX,20,NAUX)
   30    CONTINUE
      END IF
C
C3------PRINT NUMBER OF GHB'S IN CURRENT STRESS PERIOD.
      WRITE (IOUT,101) NBOUND
  101 FORMAT(1X,/1X,I6,' GHB CELLS')
C
C8------RETURN.
  260 RETURN
      END
      SUBROUTINE GWF2GHB7FM(IGRID)
C     ******************************************************************
C     ADD GHB TERMS TO RHS AND HCOF
C     ******************************************************************
C
C     SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL,       ONLY:IBOUND,RHS,HCOF
      USE GWFGHBMODULE, ONLY:NBOUND,BNDS
C     ------------------------------------------------------------------
      CALL SGWF2GHB7PNT(IGRID)
C
C1------IF NBOUND<=0 THEN THERE ARE NO GENERAL HEAD BOUNDS. RETURN.
      IF(NBOUND.LE.0) RETURN
C
C2------PROCESS EACH ENTRY IN THE GENERAL HEAD BOUND LIST (BNDS).
      DO 100 L=1,NBOUND
C
C3------GET COLUMN, ROW AND LAYER OF CELL CONTAINING BOUNDARY.
      IL=BNDS(1,L)
      IR=BNDS(2,L)
      IC=BNDS(3,L)
C
C4------IF THE CELL IS EXTERNAL THEN SKIP IT.
      IF(IBOUND(IC,IR,IL).LE.0) GO TO 100
C
C5------SINCE THE CELL IS INTERNAL GET THE BOUNDARY DATA.
      HB=BNDS(4,L)
      C=BNDS(5,L)
C
C6------ADD TERMS TO RHS AND HCOF.
      HCOF(IC,IR,IL)=HCOF(IC,IR,IL)-C
      RHS(IC,IR,IL)=RHS(IC,IR,IL)-C*HB
  100 CONTINUE
C
C7------RETURN.
      RETURN
      END
      SUBROUTINE GWF2GHB7BD(KSTP,KPER,IGRID)
C     ******************************************************************
C     CALCULATE VOLUMETRIC BUDGET FOR GHB
C     ******************************************************************
C
C     SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL,      ONLY:IOUT,NCOL,NROW,NLAY,IBOUND,HNEW,BUFF
      USE GWFBASMODULE,ONLY:MSUM,ICBCFL,IAUXSV,DELT,PERTIM,TOTIM,
     1                      VBVL,VBNM
      USE GWFGHBMODULE,ONLY:NBOUND,IGHBCB,BNDS,NGHBVL,GHBAUX
C
      DOUBLE PRECISION CCGHB,CHB,RATIN,RATOUT,RRATE
      CHARACTER*16 TEXT
      DATA TEXT /' HEAD DEP BOUNDS'/
C     ------------------------------------------------------------------
      CALL SGWF2GHB7PNT(IGRID)
C
C1------INITIALIZE CELL-BY-CELL FLOW TERM FLAG (IBD) AND
C1------ACCUMULATORS (RATIN AND RATOUT).
      ZERO=0.
      RATOUT=ZERO
      RATIN=ZERO
      IBD=0
      IF(IGHBCB.LT.0 .AND. ICBCFL.NE.0) IBD=-1
      IF(IGHBCB.GT.0) IBD=ICBCFL
      IBDLBL=0
C
C2------IF CELL-BY-CELL FLOWS WILL BE SAVED AS A LIST, WRITE HEADER.
      IF(IBD.EQ.2) THEN
         NAUX=NGHBVL-6
         IF(IAUXSV.EQ.0) NAUX=0
         CALL UBDSV4(KSTP,KPER,TEXT,NAUX,GHBAUX,IGHBCB,NCOL,NROW,NLAY,
     1          NBOUND,IOUT,DELT,PERTIM,TOTIM,IBOUND)
      END IF
C
C3------CLEAR THE BUFFER.
      DO 50 IL=1,NLAY
      DO 50 IR=1,NROW
      DO 50 IC=1,NCOL
      BUFF(IC,IR,IL)=ZERO
50    CONTINUE
C
C4------IF NO BOUNDARIES, SKIP FLOW CALCULATIONS.
      IF(NBOUND.EQ.0) GO TO 200
C
C5------LOOP THROUGH EACH BOUNDARY CALCULATING FLOW.
      DO 100 L=1,NBOUND
C
C5A-----GET LAYER, ROW AND COLUMN OF EACH GENERAL HEAD BOUNDARY.
      IL=BNDS(1,L)
      IR=BNDS(2,L)
      IC=BNDS(3,L)
      RATE=ZERO
C
C5B-----IF CELL IS NO-FLOW OR CONSTANT-HEAD, THEN IGNORE IT.
      IF(IBOUND(IC,IR,IL).LE.0) GO TO 99
C
C5C-----GET PARAMETERS FROM BOUNDARY LIST.
      HB=BNDS(4,L)
      C=BNDS(5,L)
      CCGHB=C
C
C5D-----CALCULATE THE FOW RATE INTO THE CELL.
      CHB=C*HB
      RRATE=CHB - CCGHB*HNEW(IC,IR,IL)
      RATE=RRATE
C
C5E-----PRINT THE INDIVIDUAL RATES IF REQUESTED(IGHBCB<0).
      IF(IBD.LT.0) THEN
         IF(IBDLBL.EQ.0) WRITE(IOUT,61) TEXT,KPER,KSTP
   61    FORMAT(1X,/1X,A,'   PERIOD ',I4,'   STEP ',I3)
         WRITE(IOUT,62) L,IL,IR,IC,RATE
   62    FORMAT(1X,'BOUNDARY ',I6,'   LAYER ',I3,'   ROW ',I5,'   COL ',
     1       I5,'   RATE ',1PG15.6)
         IBDLBL=1
      END IF
C
C5F-----ADD RATE TO BUFFER.
      BUFF(IC,IR,IL)=BUFF(IC,IR,IL)+RATE
C
C5G-----SEE IF FLOW IS INTO AQUIFER OR OUT OF AQUIFER.
      IF(RATE.LT.ZERO) THEN
C
C5H------FLOW IS OUT OF AQUIFER SUBTRACT RATE FROM RATOUT.
        RATOUT=RATOUT-RRATE
      ELSE
C
C5I-----FLOW IS INTO AQIFER; ADD RATE TO RATIN.
        RATIN=RATIN+RRATE
      END IF
C
C5J-----IF SAVING CELL-BY-CELL FLOWS IN LIST, WRITE FLOW.  ALSO
C5J-----FLOW TO BNDS.
   99 IF(IBD.EQ.2) CALL UBDSVB(IGHBCB,NCOL,NROW,IC,IR,IL,RATE,
     1                  BNDS(:,L),NGHBVL,NAUX,6,IBOUND,NLAY)
      BNDS(NGHBVL,L)=RATE
  100 CONTINUE
C
C6------IF CELL-BY-CELL TERMS WILL BE SAVED AS A 3-D ARRAY, THEN CALL
C6------UTILITY MODULE UBUDSV TO SAVE THEM.
      IF(IBD.EQ.1) CALL UBUDSV(KSTP,KPER,TEXT,IGHBCB,BUFF,NCOL,NROW,
     1                          NLAY,IOUT)
C
C7------MOVE RATES, VOLUMES AND LABELS INTO ARRAYS FOR PRINTING.
  200 RIN=RATIN
      ROUT=RATOUT
      VBVL(3,MSUM)=RIN
      VBVL(1,MSUM)=VBVL(1,MSUM)+RIN*DELT
      VBVL(4,MSUM)=ROUT
      VBVL(2,MSUM)=VBVL(2,MSUM)+ROUT*DELT
      VBNM(MSUM)=TEXT
C
C8------INCREMENT THE BUDGET TERM COUNTER.
      MSUM=MSUM+1
C
C9------RETURN.
      RETURN
      END
      SUBROUTINE GWF2GHB7DA(IGRID)
C  Deallocate GHB MEMORY
      USE GWFGHBMODULE
C
        CALL SGWF2GHB7PNT(IGRID)
        DEALLOCATE(NBOUND)
        DEALLOCATE(MXBND)
        DEALLOCATE(NGHBVL)
        DEALLOCATE(IGHBCB)
        DEALLOCATE(IPRGHB)
        DEALLOCATE(NPGHB)
        DEALLOCATE(IGHBPB)
        DEALLOCATE(NNPGHB)
        DEALLOCATE(GHBAUX)
        DEALLOCATE(BNDS)
C
      RETURN
      END
      SUBROUTINE SGWF2GHB7PNT(IGRID)
C  Change GHB data to a different grid.
      USE GWFGHBMODULE
C
        NBOUND=>GWFGHBDAT(IGRID)%NBOUND
        MXBND=>GWFGHBDAT(IGRID)%MXBND
        NGHBVL=>GWFGHBDAT(IGRID)%NGHBVL
        IGHBCB=>GWFGHBDAT(IGRID)%IGHBCB
        IPRGHB=>GWFGHBDAT(IGRID)%IPRGHB
        NPGHB=>GWFGHBDAT(IGRID)%NPGHB
        IGHBPB=>GWFGHBDAT(IGRID)%IGHBPB
        NNPGHB=>GWFGHBDAT(IGRID)%NNPGHB
        GHBAUX=>GWFGHBDAT(IGRID)%GHBAUX
        BNDS=>GWFGHBDAT(IGRID)%BNDS
C
      RETURN
      END
      SUBROUTINE SGWF2GHB7PSV(IGRID)
C  Save GHB data for a grid.
      USE GWFGHBMODULE
C
        GWFGHBDAT(IGRID)%NBOUND=>NBOUND
        GWFGHBDAT(IGRID)%MXBND=>MXBND
        GWFGHBDAT(IGRID)%NGHBVL=>NGHBVL
        GWFGHBDAT(IGRID)%IGHBCB=>IGHBCB
        GWFGHBDAT(IGRID)%IPRGHB=>IPRGHB
        GWFGHBDAT(IGRID)%NPGHB=>NPGHB
        GWFGHBDAT(IGRID)%IGHBPB=>IGHBPB
        GWFGHBDAT(IGRID)%NNPGHB=>NNPGHB
        GWFGHBDAT(IGRID)%GHBAUX=>GHBAUX
        GWFGHBDAT(IGRID)%BNDS=>BNDS
C
      RETURN
      END