! todo
  ! velocity is incorrect for a triangular corner cell if two edges are on model perimeter
  ! newton-raphson (head below bottom); more testing
  ! transport when cells are dry (IBOUND=0)
  ! sub timing; what to do about output control
  ! systematic approach to testing
  ! verify that idomain is working (can transport have a different idomain?)
  ! check that discretization is the same between both models
  ! now that immobile domain is separate package, should sorbtion and decay be split?
  ! move the fmi flow error term into the ssm package?
  ! Add internal GWF flows to the diagonal postion of the flowja array
  ! Write CQ transport routine and add internal GWT flows to flowja array
  ! gwt obs
  ! adv obs
  ! dsp obs
  ! mst obs
  ! ist obs
  ! ssm obs
  ! src obs
  ! cnc obs
  ! variable density flow package
  ! heat transport input
  ! memory deallocation
  ! code profiling (how do run times compare with mt3d/seawat?)
  ! GWF-GWF exchange transport
  ! transient flow case; verify that its working properly, test with goode 1990
  ! transport-only (using saved flow budget files)
  ! transport for SFR, LAK, MAW, UZF
  ! What to do about MVR?  Should go into SSM.
  ! implement steady-state transport (affects MST, IST)
  ! update user guide to reflect changes to MST, and IST
  ! update user guide to include conceptual sketch of the packages
  ! refactor code to use the MST and IST packages to replace STO, SRB, DCY, and IMD
  ! pore space discrepancy between flow and transport (porosity vs specific yield)
  ! add separate heat transport model?
  ! xt3d dispersion areas need to be consistent with non-xt3d case
  ! the gwf_fc routines need updating for the mover calculation to hcof and rhs

module GwtModule

  use KindModule,                  only: DP, I4B
  use InputOutputModule,           only: ParseLine, upcase
  use ConstantsModule,             only: LENFTYPE, DZERO, LENPAKLOC
  use VersionModule,               only: write_listfile_header
  use NumericalModelModule,        only: NumericalModelType
  use BaseModelModule,             only: BaseModelType
  use BndModule,                   only: BndType, AddBndToList, GetBndFromList
  use GwtIcModule,                 only: GwtIcType
  use GwtFmiModule,                only: GwtFmiType
  use GwtAdvModule,                only: GwtAdvType
  use GwtDspModule,                only: GwtDspType
  use GwtSsmModule,                only: GwtSsmType
  use GwtMvtModule,                only: GwtMvtType
  use GwtMstModule,                only: GwtMstType
  use GwtOcModule,                 only: GwtOcType
  use GwtObsModule,                only: GwtObsType
  use BudgetModule,                only: BudgetType

  implicit none

  private
  public :: gwt_cr
  public :: GwtModelType

  type, extends(NumericalModelType) :: GwtModelType

    type(GwtIcType),                pointer :: ic      => null()                ! initial conditions package
    type(GwtFmiType),               pointer :: fmi     => null()                ! flow model interface
    type(GwtMstType),               pointer :: mst     => null()                ! mass storage and transfer package
    type(GwtAdvType),               pointer :: adv     => null()                ! advection package
    type(GwtDspType),               pointer :: dsp     => null()                ! dispersion package
    type(GwtSsmType),               pointer :: ssm     => null()                ! source sink mixing package
    type(GwtMvtType),               pointer :: mvt     => null()                ! mover transport package
    type(GwtOcType),                pointer :: oc      => null()                ! output control package
    type(GwtObsType),               pointer :: obs     => null()                ! observation package
    type(BudgetType),               pointer :: budget  => null()                ! budget object
    integer(I4B),                   pointer :: inic    => null()                ! unit number IC
    integer(I4B),                   pointer :: infmi   => null()                ! unit number FMI
    integer(I4B),                   pointer :: inmvt   => null()                ! unit number MVT
    integer(I4B),                   pointer :: inmst   => null()                ! unit number MST
    integer(I4B),                   pointer :: inadv   => null()                ! unit number ADV
    integer(I4B),                   pointer :: indsp   => null()                ! unit number DSP
    integer(I4B),                   pointer :: inssm   => null()                ! unit number SSM
    integer(I4B),                   pointer :: inoc    => null()                ! unit number OC
    integer(I4B),                   pointer :: inobs   => null()                ! unit number OBS

  contains

    procedure :: model_df                => gwt_df
    procedure :: model_ac                => gwt_ac
    procedure :: model_mc                => gwt_mc
    procedure :: model_ar                => gwt_ar
    procedure :: model_rp                => gwt_rp
    procedure :: model_ad                => gwt_ad
    procedure :: model_cf                => gwt_cf
    procedure :: model_fc                => gwt_fc
    procedure :: model_cc                => gwt_cc
    procedure :: model_cq                => gwt_cq
    procedure :: model_bd                => gwt_bd
    procedure :: model_ot                => gwt_ot
    procedure :: model_da                => gwt_da

    procedure :: allocate_scalars
    procedure, private :: package_create
    procedure, private :: ftype_check
    procedure :: get_iasym => gwt_get_iasym
    procedure, private :: gwt_bdsav

  end type GwtModelType

  ! -- Module variables constant for simulation
  integer(I4B), parameter :: NIUNIT=100
  character(len=LENFTYPE), dimension(NIUNIT) :: cunit
  data cunit/   'DIS6 ', 'DISV6', 'DISU6', 'IC6  ', 'MST6 ', & !  5
                'ADV6 ', 'DSP6 ', 'SSM6 ', '     ', 'CNC6 ', & ! 10
                'OC6  ', 'OBS6 ', 'FMI6 ', 'SRC6 ', 'IST6 ', & ! 15
                'LKT6 ', 'SFT6 ', 'MWT6 ', 'UZT6 ', 'MVT6 ', & ! 20
                80 * '     '/

  contains

  subroutine gwt_cr(filename, id, modelname)
! ******************************************************************************
! gwt_cr -- Create a new groundwater transport model object
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ListsModule,                only: basemodellist
    use BaseModelModule,            only: AddBaseModelToList
    use SimModule,                  only: ustop, store_error, count_errors
    use ConstantsModule,            only: LINELENGTH, LENPACKAGENAME
    use CompilerVersion
    use MemoryManagerModule,        only: mem_allocate
    use GwfDisModule,               only: dis_cr
    use GwfDisvModule,              only: disv_cr
    use GwfDisuModule,              only: disu_cr
    use GwtIcModule,                only: ic_cr
    use GwtFmiModule,               only: fmi_cr
    use GwtMstModule,               only: mst_cr
    use GwtAdvModule,               only: adv_cr
    use GwtDspModule,               only: dsp_cr
    use GwtSsmModule,               only: ssm_cr
    use GwtMvtModule,               only: mvt_cr
    use GwtOcModule,                only: oc_cr
    use GwtObsModule,               only: gwt_obs_cr
    use BudgetModule,               only: budget_cr
    use NameFileModule,             only: NameFileType
    ! -- dummy
    character(len=*), intent(in)  :: filename
    integer(I4B), intent(in)      :: id
    character(len=*), intent(in)  :: modelname
    ! -- local
    integer(I4B) :: indis, indis6, indisu6, indisv6
    integer(I4B) :: ipakid, i, j, iu, ipaknum
    character(len=LINELENGTH) :: errmsg
    character(len=LENPACKAGENAME) :: pakname
    type(NameFileType) :: namefile_obj
    type(GwtModelType), pointer        :: this
    class(BaseModelType), pointer       :: model
    integer(I4B) :: nwords
    character(len=LINELENGTH), allocatable, dimension(:) :: words
! ------------------------------------------------------------------------------
    !
    ! -- Allocate a new GWT Model (this) and add it to basemodellist
    allocate(this)
    call this%allocate_scalars(modelname)
    model => this
    call AddBaseModelToList(basemodellist, model)
    !
    ! -- Assign values
    this%filename = filename
    this%name = modelname
    this%macronym = 'GWT'
    this%id = id
    !
    ! -- Open namefile and set iout
    call namefile_obj%init(this%filename, 0)
    call namefile_obj%add_cunit(niunit, cunit)
    call namefile_obj%openlistfile(this%iout)
    !
    ! -- Write header to model list file
    call write_listfile_header(this%iout, 'GROUNDWATER TRANSPORT MODEL (GWT)')
    !
    ! -- Open files
    call namefile_obj%openfiles(this%iout)
    !
    ! --
    if (size(namefile_obj%opts) > 0) then
      write(this%iout, '(1x,a)') 'NAMEFILE OPTIONS:'
    end if
    !
    ! -- parse options in the gwt name file
    do i = 1, size(namefile_obj%opts)
      call ParseLine(namefile_obj%opts(i), nwords, words)
      call upcase(words(1))
      select case(words(1))
        case ('PRINT_INPUT')
          this%iprpak = 1
          write(this%iout,'(4x,a)') 'STRESS PACKAGE INPUT WILL BE PRINTED '//  &
                                    'FOR ALL MODEL STRESS PACKAGES'
        case ('PRINT_FLOWS')
          this%iprflow = 1
          write(this%iout,'(4x,a)') 'PACKAGE FLOWS WILL BE PRINTED '//         &
                                    'FOR ALL MODEL PACKAGES'
        case ('SAVE_FLOWS')
          this%ipakcb = -1
          write(this%iout, '(4x,a)')                                           &
            'FLOWS WILL BE SAVED TO BUDGET FILE SPECIFIED IN OUTPUT CONTROL'
        case default
          write(errmsg,'(4x,a,a,a,a)')                                         &
            '****ERROR. UNKNOWN GWT NAMEFILE (',                               &
            trim(adjustl(this%filename)), ') OPTION: ',                        &
            trim(adjustl(namefile_obj%opts(i)))
          call store_error(errmsg)
          call ustop()
      end select
    end do
    !
    ! -- Assign unit numbers to attached modules, and remove
    ! -- from unitnumber (by specifying 1 for iremove)
    !
    indis = 0
    indis6 = 0
    indisu6 = 0
    indisv6 = 0
    call namefile_obj%get_unitnumber('DIS6', indis6, 1)
    if(indis6 > 0) indis = indis6
    if(indis <= 0) call namefile_obj%get_unitnumber('DISU6', indisu6, 1)
    if(indisu6 > 0) indis = indisu6
    if(indis <= 0) call namefile_obj%get_unitnumber('DISV6', indisv6, 1)
    if(indisv6 > 0) indis = indisv6
    call namefile_obj%get_unitnumber('IC6',  this%inic, 1)
    call namefile_obj%get_unitnumber('FMI6', this%infmi, 1)
    call namefile_obj%get_unitnumber('MVT6', this%inmvt, 1)
    call namefile_obj%get_unitnumber('MST6', this%inmst, 1)
    call namefile_obj%get_unitnumber('ADV6', this%inadv, 1)
    call namefile_obj%get_unitnumber('DSP6', this%indsp, 1)
    call namefile_obj%get_unitnumber('SSM6', this%inssm, 1)
    call namefile_obj%get_unitnumber('OC6',  this%inoc, 1)
    call namefile_obj%get_unitnumber('OBS6', this%inobs, 1)
    !
    ! -- Check to make sure that required ftype's have been specified
    call this%ftype_check(namefile_obj, indis)
    !
    ! -- Create discretization object
    if(indis6 > 0) then
      call dis_cr(this%dis, this%name, indis, this%iout)
    elseif(indisu6 > 0) then
      call disu_cr(this%dis, this%name, indis, this%iout)
    elseif(indisv6 > 0) then
      call disv_cr(this%dis, this%name, indis, this%iout)
    endif
    !
    ! -- Create utility objects
    call budget_cr(this%budget, this%name)
    !
    ! -- Create packages that are tied directly to model
    call ic_cr(this%ic, this%name, this%inic, this%iout, this%dis)
    call fmi_cr(this%fmi, this%name, this%infmi, this%iout)
    call mst_cr(this%mst, this%name, this%inmst, this%iout, this%fmi)
    call adv_cr(this%adv, this%name, this%inadv, this%iout, this%fmi)
    call dsp_cr(this%dsp, this%name, this%indsp, this%iout, this%fmi)
    call ssm_cr(this%ssm, this%name, this%inssm, this%iout, this%fmi)
    call mvt_cr(this%mvt, this%name, this%inmvt, this%iout, this%fmi)
    call oc_cr(this%oc, this%name, this%inoc, this%iout)
    call gwt_obs_cr(this%obs, this%inobs)
    !
    ! -- Create stress packages
    ipakid = 1
    do i = 1, niunit
      ipaknum = 1
      do j = 1, namefile_obj%get_nval_for_row(i)
        iu = namefile_obj%get_unitnumber_rowcol(i, j)
        call namefile_obj%get_pakname(i, j, pakname)
        call this%package_create(cunit(i), ipakid, ipaknum, pakname, iu,       &
          this%iout)
        ipaknum = ipaknum + 1
        ipakid = ipakid + 1
      enddo
    enddo
    !
    ! -- return
    return
  end subroutine gwt_cr

  subroutine gwt_df(this)
! ******************************************************************************
! gwt_df -- Define packages of the model
! Subroutine: (1) call df routines for each package
!             (2) set variables and pointers
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwtModelType) :: this
    ! -- local
    integer(I4B) :: ip
    class(BndType), pointer :: packobj
! ------------------------------------------------------------------------------
    !
    ! -- Define packages and utility objects
    call this%dis%dis_df()
    call this%fmi%fmi_df(this%dis, this%inssm)
    if (this%inmvt > 0) call this%mvt%mvt_df(this%dis)
    if (this%indsp > 0) call this%dsp%dsp_df(this%dis)
    if (this%inssm > 0) call this%ssm%ssm_df()
    call this%oc%oc_df()
    call this%budget%budget_df(niunit, 'MASS', 'M')
    !
    ! -- Assign or point model members to dis members
    this%neq = this%dis%nodes
    this%nja = this%dis%nja
    this%ia  => this%dis%con%ia
    this%ja  => this%dis%con%ja
    !
    ! -- Allocate model arrays, now that neq and nja are assigned
    call this%allocate_arrays()
    !
    ! -- Define packages and assign iout for time series managers
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_df(this%neq, this%dis)
      packobj%TsManager%iout = this%iout
      packobj%TasManager%iout = this%iout
    enddo
    !
    ! -- Store information needed for observations
    call this%obs%obs_df(this%iout, this%name, 'GWT', this%dis)
    !
    ! -- return
    return
  end subroutine gwt_df

  subroutine gwt_ac(this, sparse)
! ******************************************************************************
! gwt_ac -- Add the internal connections of this model to the sparse matrix
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use SparseModule, only: sparsematrix
    ! -- dummy
    class(GwtModelType) :: this
    type(sparsematrix), intent(inout) :: sparse
    ! -- local
    class(BndType), pointer :: packobj
    integer(I4B) :: ip
! ------------------------------------------------------------------------------
    !
    ! -- Add the internal connections of this model to sparse
    call this%dis%dis_ac(this%moffset, sparse)
    if (this%indsp > 0) &
      call this%dsp%dsp_ac(this%moffset, sparse)
    !
    ! -- Add any package connections
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_ac(this%moffset, sparse)
    enddo
    !
    ! -- return
    return
  end subroutine gwt_ac

  subroutine gwt_mc(this, iasln, jasln)
! ******************************************************************************
! gwt_mc -- Map the positions of this models connections in the
! numerical solution coefficient matrix.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtModelType) :: this
    integer(I4B), dimension(:), intent(in) :: iasln
    integer(I4B), dimension(:), intent(in) :: jasln
    ! -- local
    class(BndType), pointer :: packobj
    integer(I4B) :: ip
! ------------------------------------------------------------------------------
    !
    ! -- Find the position of each connection in the global ia, ja structure
    !    and store them in idxglo.
    call this%dis%dis_mc(this%moffset, this%idxglo, iasln, jasln)
    if (this%indsp > 0) call this%dsp%dsp_mc(this%moffset, iasln, jasln)
    !
    ! -- Map any package connections
    do ip=1,this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_mc(this%moffset, iasln, jasln)
    enddo
    !
    ! -- return
    return
  end subroutine gwt_mc

  subroutine gwt_ar(this)
! ******************************************************************************
! gwt_ar -- GroundWater Transport Model Allocate and Read
! Subroutine: (1) allocates and reads packages part of this model,
!             (2) allocates memory for arrays part of this model object
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DHNOFLO
    ! -- dummy
    class(GwtModelType) :: this
    ! -- locals
    integer(I4B) :: ip
    class(BndType), pointer :: packobj
! ------------------------------------------------------------------------------
    !
    ! -- Allocate and read modules attached to model
    call this%fmi%fmi_ar(this%ibound)
    if (this%inmvt > 0) call this%mvt%mvt_ar()
    if (this%inic  > 0) call this%ic%ic_ar(this%x)
    if (this%inmst > 0) call this%mst%mst_ar(this%dis, this%ibound)
    if (this%inadv > 0) call this%adv%adv_ar(this%dis, this%ibound)
    if (this%indsp > 0) call this%dsp%dsp_ar(this%ibound, this%mst%porosity)
    if (this%inssm > 0) call this%ssm%ssm_ar(this%dis, this%ibound, this%x)
    if (this%inobs > 0) call this%obs%gwt_obs_ar(this%ic, this%x, this%flowja)
    !
    ! -- Call dis_ar to write binary grid file
    !call this%dis%dis_ar(this%npf%icelltype)
    !
    ! -- set up output control
    call this%oc%oc_ar(this%x, this%dis, DHNOFLO)
    !
    ! -- Package input files now open, so allocate and read
    do ip=1,this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%set_pointers(this%dis%nodes, this%ibound, this%x,           &
                                this%xold, this%flowja)
      ! -- Read and allocate package
      call packobj%bnd_ar()
    enddo
    !
    ! -- return
    return
  end subroutine gwt_ar

  subroutine gwt_rp(this)
! ******************************************************************************
! gwt_rp -- GroundWater Transport Model Read and Prepare
! Subroutine: (1) calls package read and prepare routines
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use TdisModule, only: readnewdata
    ! -- dummy
    class(GwtModelType) :: this
    ! -- local
    class(BndType), pointer :: packobj
    integer(I4B) :: ip
! ------------------------------------------------------------------------------
    !
    ! -- In fmi, check for mvt and mvrbudobj consistency
    call this%fmi%fmi_rp(this%inmvt)
    if (this%inmvt > 0) call this%mvt%mvt_rp()
    !
    ! -- Check with TDIS on whether or not it is time to RP
    if (.not. readnewdata) return
    !
    ! -- Read and prepare
    if(this%inoc > 0)  call this%oc%oc_rp()
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_rp()
      call packobj%bnd_rp_obs()
    enddo
    !
    ! -- Return
    return
  end subroutine gwt_rp

  subroutine gwt_ad(this)
! ******************************************************************************
! gwt_ad -- GroundWater Transport Model Time Step Advance
! Subroutine: (1) calls package advance subroutines
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use SimVariablesModule, only: isimcheck
    ! -- dummy
    class(GwtModelType) :: this
    class(BndType), pointer :: packobj
    ! -- local
    integer(I4B) :: ip, n
! ------------------------------------------------------------------------------
    !
    ! -- copy x into xold
    do n = 1, this%dis%nodes
      if (this%ibound(n) == 0) then
        this%xold(n) = DZERO
      else
        this%xold(n) = this%x(n)
      endif
    enddo
    !
    ! -- Advance fmi
    call this%fmi%fmi_ad(this%x)
    !
    ! -- Advance
    !if(this%inmst > 0) call this%mst%mst_ad()
    if(this%indsp > 0) call this%dsp%dsp_ad()
    if(this%inssm > 0) call this%ssm%ssm_ad()
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_ad()
      if (isimcheck > 0) then
        call packobj%bnd_ck()
      end if
    enddo
    !
    ! -- Push simulated values to preceding time/subtime step
    call this%obs%obs_ad()
    !
    ! -- return
    return
  end subroutine gwt_ad

  subroutine gwt_cf(this, kiter)
! ******************************************************************************
! gwt_cf -- GroundWater Transport Model calculate coefficients
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwtModelType) :: this
    integer(I4B),intent(in) :: kiter
    ! -- local
    class(BndType), pointer :: packobj
    integer(I4B) :: ip
! ------------------------------------------------------------------------------
    !
    ! -- Recalculate dispersion coefficients
    if(this%indsp > 0) call this%dsp%dsp_cf(kiter)
    !
    ! -- Call package cf routines
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_cf()
    enddo
    !
    ! -- return
    return
  end subroutine gwt_cf

  subroutine gwt_fc(this, kiter, amatsln, njasln, inwtflag)
! ******************************************************************************
! gwt_fc -- GroundWater Transport Model fill coefficients
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwtModelType) :: this
    integer(I4B), intent(in) :: kiter
    integer(I4B), intent(in) :: njasln
    real(DP), dimension(njasln), intent(inout) :: amatsln
    integer(I4B), intent(in) :: inwtflag
    ! -- local
    class(BndType), pointer :: packobj
    integer(I4B) :: ip
! ------------------------------------------------------------------------------
    !
    ! -- call fc routines
    call this%fmi%fmi_fc(this%dis%nodes, this%xold, this%nja, njasln,          &
                         amatsln, this%idxglo, this%rhs)
    if (this%inmvt > 0) then
      call this%mvt%mvt_fc(this%dis%nodes, this%xold, this%nja, njasln,          &
                           amatsln, this%idxglo, this%x, this%rhs)
    end if
    if(this%inmst > 0) then
      call this%mst%mst_fc(this%dis%nodes, this%xold, this%nja, njasln,        &
                           amatsln, this%idxglo, this%rhs)
    endif
    if(this%inadv > 0) then
      call this%adv%adv_fc(this%dis%nodes, amatsln, this%idxglo, this%x,       &
                           this%rhs)
    endif
    if(this%indsp > 0) then
      call this%dsp%dsp_fc(kiter, this%dis%nodes, this%nja, njasln, amatsln,   &
                           this%idxglo, this%rhs, this%x)
    endif
    if(this%inssm > 0) then
      call this%ssm%ssm_fc(amatsln, this%idxglo, this%rhs)
    endif
    !
    ! -- packages
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_fc(this%rhs, this%ia, this%idxglo, amatsln)
    enddo
    !
    ! -- return
    return
  end subroutine gwt_fc

  subroutine gwt_cc(this, innertot, kiter, iend, icnvgmod, cpak, ipak, dpak)
! ******************************************************************************
! gwt_cc -- GroundWater Transport Model Final Convergence Check
! Subroutine: (1) calls package cc routines
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtModelType) :: this
    integer(I4B),intent(in) :: innertot
    integer(I4B),intent(in) :: kiter
    integer(I4B),intent(in) :: iend
    integer(I4B),intent(in) :: icnvgmod
    character(len=LENPAKLOC), intent(inout) :: cpak
    integer(I4B), intent(inout) :: ipak
    real(DP), intent(inout) :: dpak
    ! -- local
    !class(BndType), pointer :: packobj
    !integer(I4B) :: ip
    ! -- formats
! ------------------------------------------------------------------------------
    !
    ! -- If mover is on, then at least 2 outers required
    if (this%inmvt > 0) call this%mvt%mvt_cc(kiter, iend, icnvgmod, cpak, dpak)
    !
    ! -- Call package cc routines
    !do ip = 1, this%bndlist%Count()
    !  packobj => GetBndFromList(this%bndlist, ip)
    !  call packobj%bnd_cc(iend, icnvg, hclose, rclose)
    !enddo
    !
    ! -- return
    return
  end subroutine gwt_cc

  subroutine gwt_cq(this, icnvg, isuppress_output)
! ******************************************************************************
! gwt_cq --Groundwater transport model calculate flow
! Subroutine: (1) Calculate intercell flows (flowja)
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwtModelType) :: this
    integer(I4B), intent(in) :: icnvg
    integer(I4B), intent(in) :: isuppress_output
    ! -- local
    integer(I4B) :: i
! ------------------------------------------------------------------------------
    !
    ! -- Construct the flowja array.  Flowja is calculated each time, even if
    !    output is suppressed.  (flowja is positive into a cell.)
    do i = 1, this%nja
      this%flowja(i) = DZERO
    enddo
    if(this%inadv > 0) call this%adv%adv_flowja(this%x, this%flowja)
    if(this%indsp > 0) call this%dsp%dsp_flowja(this%x, this%flowja)
    !
    ! -- Return
    return
  end subroutine gwt_cq

  subroutine gwt_bd(this, icnvg, isuppress_output)
! ******************************************************************************
! gwt_bd --GroundWater Transport Model Budget
! Subroutine: (1) Calculate intercell flows (flowja)
!             (2) Calculate package contributions to model budget
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use ConstantsModule, only: DZERO
    ! -- dummy
    class(GwtModelType) :: this
    integer(I4B), intent(in) :: icnvg
    integer(I4B), intent(in) :: isuppress_output
    ! -- local
    integer(I4B) :: icbcfl, ibudfl, icbcun, iprobs, idvfl
    integer(I4B) :: ip
    class(BndType),pointer :: packobj
! ------------------------------------------------------------------------------
    !
    ! -- Save the solution convergence flag
    this%icnvg = icnvg
    !
    ! -- Set write and print flags differently if output is suppressed.
    if(isuppress_output == 0) then
      idvfl = 0
      if(this%oc%oc_save('CONCENTRATION')) idvfl = 1
      icbcfl = 0
      if(this%oc%oc_save('BUDGET')) icbcfl = 1
      icbcun = this%oc%oc_save_unit('BUDGET')
      ibudfl = 0
      if(this%oc%oc_print('BUDGET')) ibudfl = 1
      iprobs = 1
    else
      icbcfl = 0
      ibudfl = 0
      icbcun = 0
      iprobs = 0
      idvfl  = 0
    endif
    !
    ! -- Budget routines (start by resetting)
    call this%budget%reset()
    !
    ! -- Mass storage and transfer budgets
    if(this%inmst > 0) then
      call this%mst%mst_bdcalc(this%dis%nodes, this%x, this%xold,              &
                               isuppress_output, this%budget)
      call this%mst%mst_bdsav(icbcfl, icbcun)
    endif
    !
    ! -- Advection and dispersion flowja
    call this%gwt_bdsav(this%nja, this%flowja, icbcfl, icbcun)
    !
    ! -- SSM
    if(this%inssm > 0) then
      call this%ssm%ssm_bdcalc(isuppress_output, this%budget)
      call this%ssm%ssm_bdsav(icbcfl, ibudfl, icbcun, iprobs, isuppress_output)
    endif
    !
    ! - FMI
    call this%fmi%fmi_bdcalc(this%x, isuppress_output, this%budget)
    !
    ! -- Clear obs
    call this%obs%obs_bd_clear()
    !
    ! -- Mover budget
    if (this%inmvt > 0) then
      call this%mvt%mvt_bd(icbcfl, ibudfl, isuppress_output, this%x)
    end if
    !
    ! -- Boundary packages calculate budget and total flows to model budget
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_bd(this%x, idvfl, icbcfl, ibudfl, icbcun, iprobs,       &
                          isuppress_output, this%budget)
    enddo
    !
    ! -- Calculate and write simulated values for observations
    if(iprobs /= 0) then
      if (icnvg > 0) then
        call this%obs%obs_bd()
      endif
    endif
    !
    ! -- Return
    return
  end subroutine gwt_bd

  subroutine gwt_bdsav(this, nja, flowja, icbcfl, icbcun)
! ******************************************************************************
! gwt_bdsav -- Write intercell flows
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtModelType) :: this
    integer(I4B),intent(in) :: nja
    real(DP),dimension(nja),intent(in) :: flowja
    integer(I4B), intent(in) :: icbcfl
    integer(I4B), intent(in) :: icbcun
    ! -- local
    integer(I4B) :: ibinun
    ! -- formats
! ------------------------------------------------------------------------------
    !
    ! -- Set unit number for binary output
    if(this%ipakcb < 0) then
      ibinun = icbcun
    elseif(this%ipakcb == 0) then
      ibinun = 0
    else
      ibinun = this%ipakcb
    endif
    if(icbcfl == 0) ibinun = 0
    !
    ! -- Write the face flows if requested
    if(ibinun /= 0) then
      call this%dis%record_connection_array(flowja, ibinun, this%iout)
    endif
    !
    ! -- Return
    return
  end subroutine gwt_bdsav

  subroutine gwt_ot(this)
! ******************************************************************************
! gwt_ot -- GroundWater Transport Model Output
! Subroutine: (1) Output budget items
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use TdisModule, only:kstp, kper, endofperiod, tdis_ot
    ! -- dummy
    class(GwtModelType) :: this
    ! -- local
    integer(I4B) :: ipflg, ibudfl, ihedfl
    integer(I4B) :: ip
    class(BndType), pointer :: packobj
    ! -- formats
    character(len=*),parameter :: fmtnocnvg = &
      "(1X,/9X,'****FAILED TO MEET SOLVER CONVERGENCE CRITERIA IN TIME STEP ', &
      &I0,' OF STRESS PERIOD ',I0,'****')"
! ------------------------------------------------------------------------------
    !
    ! -- Set ibudfl flag for printing budget information
    ibudfl = 0
    if(this%oc%oc_print('BUDGET')) ibudfl = 1
    if(this%icnvg == 0) ibudfl = 1
    if(endofperiod) ibudfl = 1
    !
    ! -- Set ibudfl flag for printing dependent variable information
    ihedfl = 0
    if(this%oc%oc_print('CONCENTRATION')) ihedfl = 1
    if(this%icnvg == 0) ihedfl = 1
    if(endofperiod) ihedfl = 1
    !
    ! -- Output individual flows if requested
    if(ibudfl /= 0) then
      !
      ! -- NPF output
!      if(this%innpf > 0) call this%npf%npf_ot(this%neq, this%nja, this%flowja)
      !
      ! -- GNC output
!      if(this%ingnc > 0) &
!        call this%gnc%gnc_ot()
    endif
    !
    ! -- Output control
    ipflg = 0
    this%budget%budperc = 1.e30
    if(this%icnvg == 0) then
      write(this%iout,fmtnocnvg) kstp, kper
      ipflg = 1
    endif
    call this%oc%oc_ot(ipflg)
    !
    ! -- Write Budget and Head if these conditions are met
    if (ibudfl /= 0 .or. ihedfl /= 0) then
      ipflg = 1
      !
      ! -- Package budget output
      do ip = 1, this%bndlist%Count()
        packobj => GetBndFromList(this%bndlist, ip)
        call packobj%bnd_ot(kstp, kper, this%iout, ihedfl, ibudfl)
      enddo
      !
      if (ibudfl /= 0) then
        !
        ! -- Mover budget output
        if(this%inmvt > 0) call this%mvt%mvt_ot()
        !
        ! -- gwt model budget
        call this%budget%budget_ot(kstp, kper, this%iout)
      end if
    end if
    !
    ! -- Timing Output
    if(ipflg == 1) call tdis_ot(this%iout)
    !
    ! -- OBS output
    call this%obs%obs_ot()
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_ot_obs()
    enddo
    !
    ! -- return
    return
  end subroutine gwt_ot

  subroutine gwt_da(this)
! ******************************************************************************
! gwt_da -- Deallocate
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_deallocate
    ! -- dummy
    class(GwtModelType) :: this
    ! -- local
    integer(I4B) :: ip
    class(BndType),pointer :: packobj
! ------------------------------------------------------------------------------
    !
    ! -- Internal flow packages deallocate
    call this%dis%dis_da()
    call this%ic%ic_da()
    call this%fmi%fmi_da()
    call this%adv%adv_da()
    call this%dsp%dsp_da()
    call this%ssm%ssm_da()
    call this%mst%mst_da()
    call this%mvt%mvt_da()
    call this%budget%budget_da()
    call this%oc%oc_da()
    call this%obs%obs_da()
    !
    ! -- Internal package objects
    deallocate(this%dis)
    deallocate(this%ic)
    deallocate(this%fmi)
    deallocate(this%adv)
    deallocate(this%dsp)
    deallocate(this%ssm)
    deallocate(this%mst)
    deallocate(this%mvt)
    deallocate(this%budget)
    deallocate(this%oc)
    deallocate(this%obs)
    !
    ! -- Boundary packages
    do ip = 1, this%bndlist%Count()
      packobj => GetBndFromList(this%bndlist, ip)
      call packobj%bnd_da()
      deallocate(packobj)
    enddo
    !
    ! -- Scalars
    call mem_deallocate(this%inic)
    call mem_deallocate(this%infmi)
    call mem_deallocate(this%inadv)
    call mem_deallocate(this%indsp)
    call mem_deallocate(this%inssm)
    call mem_deallocate(this%inmst)
    call mem_deallocate(this%inmvt)
    call mem_deallocate(this%inoc)
    call mem_deallocate(this%inobs)
    !
    ! -- NumericalModelType
    call this%NumericalModelType%model_da()
    !
    ! -- return
    return
  end subroutine gwt_da

  function gwt_get_iasym(this) result (iasym)
! ******************************************************************************
! gwt_get_iasym -- return 1 if any package causes the matrix to be asymmetric.
!   Otherwise return 0.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    class(GwtModelType) :: this
    ! -- local
    integer(I4B) :: iasym
! ------------------------------------------------------------------------------
    !
    ! -- Start by setting iasym to zero
    iasym = 0
    !
    ! -- ADV
    if (this%inadv > 0) then
      if (this%adv%iasym /= 0) iasym = 1
    endif
    !
    ! -- return
    return
  end function gwt_get_iasym

  subroutine allocate_scalars(this, modelname)
! ******************************************************************************
! allocate_scalars -- Allocate memory for non-allocatable members
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_allocate
    ! -- dummy
    class(GwtModelType) :: this
    character(len=*), intent(in)  :: modelname
! ------------------------------------------------------------------------------
    !
    ! -- allocate members from parent class
    call this%NumericalModelType%allocate_scalars(modelname)
    !
    ! -- allocate members that are part of model class
    call mem_allocate(this%inic , 'INIC',  modelname)
    call mem_allocate(this%infmi, 'INFMI', modelname)
    call mem_allocate(this%inmvt, 'INMVT', modelname)
    call mem_allocate(this%inmst, 'INMST', modelname)
    call mem_allocate(this%inadv, 'INADV', modelname)
    call mem_allocate(this%indsp, 'INDSP', modelname)
    call mem_allocate(this%inssm, 'INSSM', modelname)
    call mem_allocate(this%inoc,  'INOC ', modelname)
    call mem_allocate(this%inobs, 'INOBS', modelname)
    !
    this%inic  = 0
    this%infmi = 0
    this%inmvt = 0
    this%inmst = 0
    this%inadv = 0
    this%indsp = 0
    this%inssm = 0
    this%inoc  = 0
    this%inobs = 0
    !
    ! -- return
    return
  end subroutine allocate_scalars

  subroutine package_create(this, filtyp, ipakid, ipaknum, pakname, inunit,    &
                            iout)
! ******************************************************************************
! package_create -- Create boundary condition packages for this model
! Subroutine: (1) create new-style package
!             (2) add a pointer to the package
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LINELENGTH
    use SimModule, only: store_error, ustop
    use GwtCncModule, only: cnc_create
    use GwtSrcModule, only: src_create
    use GwtIstModule, only: ist_create
    use GwtLktModule, only: lkt_create
    use GwtSftModule, only: sft_create
    use GwtMwtModule, only: mwt_create
    use GwtUztModule, only: uzt_create
    ! -- dummy
    class(GwtModelType) :: this
    character(len=*),intent(in) :: filtyp
    character(len=LINELENGTH) :: errmsg
    integer(I4B),intent(in) :: ipakid
    integer(I4B),intent(in) :: ipaknum
    character(len=*), intent(in) :: pakname
    integer(I4B),intent(in) :: inunit
    integer(I4B),intent(in) :: iout
    ! -- local
    class(BndType), pointer :: packobj
    class(BndType), pointer :: packobj2
    integer(I4B) :: ip
! ------------------------------------------------------------------------------
    !
    ! -- This part creates the package object
    select case(filtyp)
    case('CNC6')
      call cnc_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname)
    case('SRC6')
      call src_create(packobj, ipakid, ipaknum, inunit, iout, this%name, pakname)
    case('LKT6')
      call lkt_create(packobj, ipakid, ipaknum, inunit, iout, this%name,       &
                      pakname, this%fmi)
    case('SFT6')
      call sft_create(packobj, ipakid, ipaknum, inunit, iout, this%name,       &
                      pakname, this%fmi)
    case('MWT6')
      call mwt_create(packobj, ipakid, ipaknum, inunit, iout, this%name,       &
                      pakname, this%fmi)
    case('UZT6')
      call uzt_create(packobj, ipakid, ipaknum, inunit, iout, this%name,       &
                      pakname, this%fmi)
    case('IST6')
      call ist_create(packobj, ipakid, ipaknum, inunit, iout, this%name,       &
                      pakname, this%fmi, this%mst)
    case default
      write(errmsg, *) 'Invalid package type: ', filtyp
      call store_error(errmsg)
      call ustop()
    end select
    !
    ! -- Packages is the bndlist that is associated with the parent model
    ! -- The following statement puts a pointer to this package in the ipakid
    ! -- position of packages.
      do ip = 1, this%bndlist%Count()
        packobj2 => GetBndFromList(this%bndlist, ip)
        if(packobj2%name == pakname) then
          write(errmsg, '(a,a)') 'Cannot create package.  Package name  ' //   &
            'already exists: ', trim(pakname)
          call store_error(errmsg)
          call ustop()
        endif
      enddo
    call AddBndToList(this%bndlist, packobj)
    !
    ! -- return
    return
  end subroutine package_create

  subroutine ftype_check(this, namefile_obj, indis)
! ******************************************************************************
! ftype_check -- Check to make sure required input files have been specified
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule,   only: LINELENGTH
    use SimModule,         only: ustop, store_error, count_errors
    use NameFileModule,    only: NameFileType
    ! -- dummy
    class(GwtModelType) :: this
    type(NameFileType), intent(in) :: namefile_obj
    integer(I4B), intent(in) :: indis
    ! -- local
    character(len=LINELENGTH) :: errmsg
    integer(I4B) :: i, iu
    character(len=LENFTYPE), dimension(10) :: nodupftype =                     &
      (/'DIS6 ', 'DISU6', 'DISV6', 'IC6  ', 'MST6 ', 'ADV6 ', 'DSP6 ',         &
        'SSM6 ', 'OC6  ', 'OBS6 '/)
! ------------------------------------------------------------------------------
    !
    ! -- Check for IC6, DIS(u), and MST. Stop if not present.
    if(this%inic == 0) then
      write(errmsg, '(1x,a)') 'ERROR. INITIAL CONDITIONS (IC6) PACKAGE NOT SPECIFIED.'
      call store_error(errmsg)
    endif
    if(indis == 0) then
      write(errmsg, '(1x,a)') &
        'ERROR. DISCRETIZATION (DIS6 or DISU6) PACKAGE NOT SPECIFIED.'
      call store_error(errmsg)
    endif
    if(this%inmst == 0) then
      write(errmsg, '(1x,a)') 'ERROR. MASS STORAGE AND TRANSFER (MST6) &
        &PACKAGE NOT SPECIFIED.'
      call store_error(errmsg)
    endif
    if(count_errors() > 0) then
      write(errmsg,'(1x,a)') 'ERROR. REQUIRED PACKAGE(S) NOT SPECIFIED.'
      call store_error(errmsg)
    endif
    !
    ! -- Check to make sure that some GWT packages are not specified more
    !    than once
    do i = 1, size(nodupftype)
      call namefile_obj%get_unitnumber(trim(nodupftype(i)), iu, 0)
      if (iu > 0) then
        write(errmsg,'(1x, a, a, a)')                                          &
          'DUPLICATE ENTRIES FOR FTYPE ', trim(nodupftype(i)),                 &
          ' NOT ALLOWED FOR GWT MODEL.'
        call store_error(errmsg)
      endif
    enddo
    !
    ! -- Stop if errors
    if(count_errors() > 0) then
      write(errmsg, '(a, a)') 'ERROR OCCURRED WHILE READING FILE: ',           &
        trim(namefile_obj%filename)
      call store_error(errmsg)
      call ustop()
    endif
    !
    ! -- return
    return
  end subroutine ftype_check

end module GwtModule


       subroutine iff_ff2chi(str)
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c given a list of paths, create a chi(k)
       implicit none
       include 'consts.h'
       include 'keywrd.h'
       include 'arrays.h'
       include 'fefdat.h'
       include 'feffit.h'
       include 'pthpar.h'
       save

       character*(*) str
       character*512  name1, namex, list*1024
       integer  idata, irec, istrln, k, j, i, ier, illen
       integer  nxpath,  jk, iupath(mpaths), u2ipth
       integer  nkpts, nkmin, nkmax, nlqpts, iup
       integer  ipath_tmp(max_pathindex)
       double precision  xkmin, xkmax, s02, sigma2
       double precision  aix(maxpts),  arx(maxpts)
       logical  do_pha, do_mag, do_re, isnum
       integer  iff_eval, iff_eval_dp, iff_eval_in
       external iff_eval, iff_eval_dp, iff_eval_in

       external istrln, u2ipth, isnum

       do 10 i = 1, mpthpr
          param(i) = zero
 10    continue

c  interpret any and all keyword/value pairs for setting options
       call bkeys(str, mkeys, keys, values, nkeys)
       idata  =  1
       irec   =  0
       nxpath =  0
       illen  =  1
       list   =  ' '
       name1  =  'feff'
       xkmin  = zero
       xkmax  = 20 * one
       do_re  = .false.
       do_mag = .false.
       do_pha = .false.
       do 100 i = 1, nkeys
          k = istrln( keys(i))
          if ((keys(i).eq.'prefix').or.(keys(i).eq.'group')) then
             name1 = values(i)
             call smcase(name1,'a')
          elseif ((keys(i).eq.'kmax')) then
             ier = iff_eval_dp(values(i), xkmax)
          elseif ((keys(i).eq.'kmin')) then
             ier = iff_eval_dp(values(i), xkmin)
          elseif ((keys(i).eq.'s02')) then
             ier = iff_eval_dp(values(i), s02)
          elseif ((keys(i).eq.'sigma2')) then
             ier = iff_eval_dp(values(i), sigma2)
          elseif ((keys(i).eq.'data_set')) then
             ier = iff_eval_in(values(i), idata)
          elseif ((keys(i).eq.'do_real')) then
             call str2lg(values(i), do_re, ier)
          elseif ((keys(i).eq.'do_mag')) then
             call str2lg(values(i), do_mag, ier)
          elseif ((keys(i).eq.'no_mag')) then
             call str2lg(values(i), do_mag, ier)
             do_mag = .not. do_mag
          elseif ((keys(i).eq.'do_phase')) then
             call str2lg(values(i), do_pha, ier)
          elseif ((keys(i).eq.'no_phase')) then
             call str2lg(values(i), do_pha, ier)
             do_pha = .not. do_pha
          elseif ((keys(i).eq.'do_all')) then
             call str2lg(values(i), do_re, ier)
             do_mag = do_re
             do_pha = do_re
          elseif (values(i).eq.undef) then
             call str2il(keys(i), max_pathindex, nxpath,ipath_tmp,ier)
             if (ier.eq.0) then
                jk    = istrln(keys(i))
                list  = list(1:illen)//keys(i)(1:jk)//','
                illen = illen+jk+1
             else
                call warn(2,' *** ff2chi: error generating path list')
                call warn(2, keys(i)(1:k))
             end if
          else
             call warn(1,' *** ff2chi: unknown key: '//keys(i)(1:k))
          end if
 100   continue
c
c convert list of indices to l_paths
       call str2il(list(1:illen), max_pathindex,nxpath,ipath_tmp,ier)
       do i = 1, mpaths
          iupath(i) = 0
       enddo
       iup= 0

       do 120 i = 1, nxpath
          if (u2ipth(ipath_tmp(i)).ge.1) then
             iup=iup+1
             iupath(iup) = ipath_tmp(i)
          endif
 120   continue
       nxpath= iup

c read the needed feff arrays
       call fefinp
c
c synchronize the math expressions
       call iff_sync
c
c calculate number of k-points

       nkmin = (xkmin / qgrid)
       nkmax = (xkmax / qgrid)
       nkpts = nkmax - nkmin + 1
       nlqpts= nkmax + 10

cc       print*, 'ff2chi: nkmin,nkmax, nkpts, nlqpts'
cc       print*, nkmin,nkmax, nkpts, nlqpts
c
c  do sum over paths (note : iupath is held in common /fitint/)

       call sum_paths(idata, iupath, nxpath, nlqpts, arx, aix)
c
c done with sum over paths
c save arrays to Program Variables
c--k
       do 200 i = 1, nlqpts
          tmparr(i) = qgrid * (i + nkmin - 1)
 200   continue
       call set_array('k',   name1, tmparr(1+nkmin), nkpts, 1)
       call set_array('chi', name1, aix(1+nkmin),  nkpts, 1)
c
c--chi_real
       if (do_re) then
          call set_array('chi_real', name1, arx(1+nkmin), nkpts, 1)
       end if
c--chi_mag
       if (do_mag) then
          do 240 i = 1, nlqpts
             tmparr(i) = sqrt ( arx(i)**2 + aix(i)**2 )
 240      continue
         call set_array('chi_mag', name1, tmparr(1+nkmin), nkpts, 1)
       end if
c--chi_phase
       if (do_pha) then
          do 280 i = 1, nlqpts
             tmparr(i) =  atan2( aix(i), arx(i))
             if (i.gt.1)  call pijump( tmparr(i), tmparr(i-1))
 280      continue
          call set_array('chi_phase', name1, tmparr(1+nkmin),nkpts,1)
       end if
c
c done
       return
       end


      SUBROUTINE PHO_POMCOR(Irej)
C********************************************************************
C
C    join quarks to gluons in case of too small masses
C
C    input:              /POEVT1/
C                        /POSTRG/
C                IREJ    -1          initialization
C                        -2          output of statistics
C
C    output:             /POEVT1/
C                        /POSTRG/
C                IREJ    0  successful
C                        1  failure
C
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION am1 , am2 , am3 , am4 , cmass , cmass0 ,
     &                 DT_RNDM , EPS , pj , prob1 , prob2
      INTEGER i , i1 , i2 , iccor , ictot , ifl1 , ifl2 , ii , ip1 ,
     &        ip2 , ipos , Irej , is , istro , iter , j1 , j2 , je ,
     &        jj , k
      INTEGER k1 , k2 , kk1 , kk2 , ks , niter , nrpom
      SAVE

      PARAMETER (EPS=1.D-10)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'

C  standard particle data interface

      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

C  color string configurations including collapsed strings and hadrons
      INCLUDE 'inc/postrg'

      DIMENSION pj(4)

      IF ( Irej.EQ.-1 ) THEN
         ictot = 0
         iccor = 0
         RETURN
      ELSE IF ( Irej.EQ.-2 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,2I8)')
     &         'PHO_POMCOR: total/joined strings' , ictot , iccor
         RETURN
      END IF
C
      Irej = 0
C
      niter = 100
      iter = 0
      ictot = ictot + ISTr
      IF ( ISWmdl(25).LE.0 ) RETURN
C  debug string entries
      IF ( IDEb(83).GE.25 ) CALL PHO_PRSTRG
C
C50   CONTINUE
      iter = iter + 1
      IF ( iter.GE.niter ) THEN
         Irej = 1
         IF ( IDEb(83).GE.2 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,2I5)')
     &            'PHO_POMCOR: rejection' , iter , niter
            IF ( IDEb(83).GE.10 ) CALL PHO_PREVNT(0)
         END IF
         RETURN
      END IF
C
C  check mass limits
      istro = ISTr
      DO i = 1 , istro
         IF ( NCOde(i).GE.0 ) THEN
            j1 = NPOs(1,i)
            nrpom = IPHist(2,j1)
            IF ( nrpom.LT.100 ) THEN
               cmass0 = PHEp(5,j1)
C  get masses
               IF ( NCOde(i).EQ.3 ) THEN
                  CALL PHO_MEMASS(IPAr1(i),IPAr2(i),am1,am2,am3,am4,ip1,
     &               ip2)
               ELSE IF ( (NCOde(i).EQ.4) .OR. (NCOde(i).EQ.6) ) THEN
                  CALL PHO_BAMASS(IPAr1(i),IPAr2(i),IPAr3(i),am1,am2,
     &               am3,am4,ip1,ip2)
               ELSE IF ( NCOde(i).EQ.5 ) THEN
                  CALL PHO_DQMASS(IPAr1(i),IPAr2(i),IPAr3(i),IPAr4(i),
     &               am1,am2)
                  am3 = 0.D0
                  am4 = 0.D0
                  ip1 = 0
                  ip2 = 0
               ELSE IF ( NCOde(i).EQ.7 ) THEN
                  GOTO 100
               ELSE IF ( NCOde(i).LT.0 ) THEN
                  GOTO 100
               ELSE
                  IF ( LPRi.GT.4 ) WRITE (LO,'(/,1X,A,2I5)')
     &                  'ERROR:PHO_POMCOR:STRING NO,NCODE ' , j1 ,
     &                 NCOde(i)
                  CALL PHO_ABORT
               END IF
               IF ( IDEb(83).GE.5 .AND. LPRi.GT.4 )
     &               WRITE (LO,'(1X,A,/3X,2I4,5E11.3,2I5)')
     &           'PHO_POMCOR: STRING,POM,CHMASS,AM1,AM2,AM3,AM4,IP1,IP2'
     &           , i , nrpom , cmass0 , am1 , am2 , am3 , am4 , ip1 ,
     &           ip2
C  select masses to correct
               IF ( cmass0.LT.MAX(am2,am4) ) THEN
                  DO k = 1 , istro
                     IF ( (k.NE.i) .AND. (NCOde(k).GE.0) ) THEN
                        j2 = NPOs(1,k)
C  join quarks to gluon
                        IF ( nrpom.EQ.IPHist(2,j2) ) THEN
C  flavour check
                           ifl1 = 0
                           ifl2 = 0
                           prob1 = 0.D0
                           prob2 = 0.D0
                           kk1 = NPOs(2,i)
                           kk2 = NPOs(2,k)
                           IF ( IDHep(kk1)+IDHep(kk2).EQ.0 ) THEN
                              cmass = (PHEp(4,kk1)+PHEp(4,kk2))
     &                           **2 - (PHEp(1,kk1)+PHEp(1,kk2))
     &                           **2 - (PHEp(2,kk1)+PHEp(2,kk2))
     &                           **2 - (PHEp(2,kk1)+PHEp(2,kk2))**2
                              ifl1 = ABS(IDHep(kk1))
                              IF ( ifl1.GT.2 ) THEN
                               prob1 = 0.1D0/MAX(cmass,EPS)
                              ELSE
                               prob1 = 0.9D0/MAX(cmass,EPS)
                              END IF
                           END IF
                           kk1 = ABS(NPOs(3,i))
                           kk2 = ABS(NPOs(3,k))
                           IF ( IDHep(kk1)+IDHep(kk2).EQ.0 ) THEN
                              cmass = (PHEp(4,kk1)+PHEp(4,kk2))
     &                           **2 - (PHEp(1,kk1)+PHEp(1,kk2))
     &                           **2 - (PHEp(2,kk1)+PHEp(2,kk2))
     &                           **2 - (PHEp(2,kk1)+PHEp(2,kk2))**2
                              ifl2 = ABS(IDHep(kk1))
                              IF ( ifl2.GT.2 ) THEN
                               prob2 = 0.1D0/MAX(cmass,EPS)
                              ELSE
                               prob2 = 0.9D0/MAX(cmass,EPS)
                              END IF
                           END IF
                           IF ( ifl1+ifl2.NE.0 ) THEN
C  fusion possible
                              iccor = iccor + 1
                              IF ( (DT_RNDM(cmass)*(prob1+prob2))
     &                           .LT.prob1 ) THEN
                               jj = 2
                               je = 3
                              ELSE
                               jj = 3
                               je = 2
                              END IF
                              kk1 = ABS(NPOs(jj,i))
                              kk2 = ABS(NPOs(jj,k))
                              i1 = ABS(NPOs(je,i))
                              i2 = kk1
                              is = SIGN(1,i2-i1)
                              i2 = i2 - is
                              k1 = kk2
                              k2 = ABS(NPOs(je,k))
                              ks = SIGN(1,k2-k1)
                              k1 = k1 + ks
                              ip1 = NHEp + 1
C  copy mother partons of string I
                              DO ii = i1 , i2 , is
                               CALL PHO_REGPAR(-1,IDHep(ii),0,j1,j2,
     &                            PHEp(1,ii),PHEp(2,ii),PHEp(3,ii),
     &                            PHEp(4,ii),i,IPHist(2,ii),ICOlor(1,ii)
     &                            ,ICOlor(2,ii),ipos,1)
                              END DO
C  register gluon
                              DO ii = 1 , 4
                               pj(ii) = PHEp(ii,kk1) + PHEp(ii,kk2)
                              END DO
                              CALL PHO_REGPAR(-1,21,0,j1,j2,pj(1),pj(2),
     &                           pj(3),pj(4),i,IPHist(2,kk2),
     &                           ICOlor(1,kk1),ICOlor(1,kk2),ipos,1)
C  copy mother partons of string K
                              DO ii = k1 , k2 , ks
                               CALL PHO_REGPAR(-1,IDHep(ii),0,j1,j2,
     &                            PHEp(1,ii),PHEp(2,ii),PHEp(3,ii),
     &                            PHEp(4,ii),i,IPHist(2,ii),ICOlor(1,ii)
     &                            ,ICOlor(2,ii),ipos,1)
                              END DO
C  create new string entry
                              DO ii = 1 , 4
                               pj(ii) = PHEp(ii,j1) + PHEp(ii,j2)
                              END DO
                              ip2 = ipos
                              CALL PHO_REGPAR(-1,90,0,ip1,-ip2,pj(1),
     &                           pj(2),pj(3),pj(4),i,IPHist(2,j1),
     &                           ICOlor(1,j1)+ICOlor(1,j2),ICOlor(2,j1)
     &                           +ICOlor(2,j2),ipos,1)
C  delete string K in /POSTRG/
                              NCOde(k) = -999
C  update string I in /POSTRG/
                              NPOs(1,i) = ipos
                              NPOs(2,i) = ip1
                              NPOs(3,i) = -ip2
C  calculate new CPC string codes
                              CALL PHO_ID2STR(IDHep(ip1),IDHep(ip2),
     &                           NCOde(i),IPAr1(i),IPAr2(i),IPAr3(i),
     &                           IPAr4(i))
                           END IF
                           GOTO 100
                        END IF
                     END IF
                  END DO
               END IF
            END IF
         END IF
 100  END DO
      IF ( IDEb(83).GE.20 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A)')
     &         'PHO_POMCOR: after string recombination'
         IF ( IDEb(83).GE.22 ) THEN
            CALL PHO_PRSTRG
            CALL PHO_PREVNT(0)
         END IF
      END IF

      END SUBROUTINE