! -- Lake Transport Module
! -- todo: what to do about reactions in lake?  Decay?
! -- todo: save the lkt concentration into the lak aux variable?
! -- todo: calculate the lak DENSE aux variable using concentration?
!
! LAK flows (lakbudptr)     index var     LKT term              Transport Type
!---------------------------------------------------------------------------------

! -- terms from LAK that will be handled by parent APT Package
! FLOW-JA-FACE              idxbudfjf     FLOW-JA-FACE          cv2cv
! GWF (aux FLOW-AREA)       idxbudgwf     GWF                   cv2gwf
! STORAGE (aux VOLUME)      idxbudsto     none                  used for cv volumes
! FROM-MVR                  idxbudfmvr    FROM-MVR              q * cext = this%qfrommvr(:)
! TO-MVR                    idxbudtmvr    TO-MVR                q * cfeat

! -- LAK terms
! RAINFALL                  idxbudrain    RAINFALL              q * crain
! EVAPORATION               idxbudevap    EVAPORATION           cfeat<cevap: q*cfeat, else: q*cevap
! RUNOFF                    idxbudroff    RUNOFF                q * croff
! EXT-INFLOW                idxbudiflw    EXT-INFLOW            q * ciflw
! WITHDRAWAL                idxbudwdrl    WITHDRAWAL            q * cfeat
! EXT-OUTFLOW               idxbudoutf    EXT-OUTFLOW           q * cfeat

! -- terms from a flow file that should be skipped
! CONSTANT                  none          none                  none
! AUXILIARY                 none          none                  none

! -- terms that are written to the transport budget file
! none                      none          STORAGE (aux MASS)    dM/dt
! none                      none          AUXILIARY             none
! none                      none          CONSTANT              accumulate
!
!
module GwtLktModule

  use KindModule, only: DP, I4B
  use ConstantsModule, only: DZERO, DONE, LINELENGTH, LENBOUNDNAME
  use SimModule, only: store_error, count_errors, store_error_unit, ustop
  use BndModule, only: BndType, GetBndFromList
  use GwtFmiModule, only: GwtFmiType
  use LakModule, only: LakType
  use GwtAptModule, only: GwtAptType

  implicit none

  public lkt_create

  character(len=*), parameter :: ftype = 'LKT'
  character(len=*), parameter :: flowtype = 'LAK'
  character(len=16)       :: text  = '             LKT'

  type, extends(GwtAptType) :: GwtLktType

    integer(I4B), pointer                              :: idxbudrain => null()  ! index of rainfall terms in flowbudptr
    integer(I4B), pointer                              :: idxbudevap => null()  ! index of evaporation terms in flowbudptr
    integer(I4B), pointer                              :: idxbudroff => null()  ! index of runoff terms in flowbudptr
    integer(I4B), pointer                              :: idxbudiflw => null()  ! index of inflow terms in flowbudptr
    integer(I4B), pointer                              :: idxbudwdrl => null()  ! index of withdrawal terms in flowbudptr
    integer(I4B), pointer                              :: idxbudoutf => null()  ! index of outflow terms in flowbudptr

    real(DP), dimension(:), pointer, contiguous        :: concrain => null() ! rainfall concentration
    real(DP), dimension(:), pointer, contiguous        :: concevap => null() ! evaporation concentration
    real(DP), dimension(:), pointer, contiguous        :: concroff => null() ! runoff concentration
    real(DP), dimension(:), pointer, contiguous        :: conciflw => null() ! inflow concentration

  contains

    procedure :: bnd_da => lkt_da
    procedure :: allocate_scalars
    procedure :: apt_allocate_arrays => lkt_allocate_arrays
    procedure :: find_apt_package => find_lkt_package
    procedure :: pak_fc_expanded => lkt_fc_expanded
    procedure :: pak_solve => lkt_solve
    procedure :: pak_get_nbudterms => lkt_get_nbudterms
    procedure :: pak_setup_budobj => lkt_setup_budobj
    procedure :: pak_fill_budobj => lkt_fill_budobj
    procedure :: lkt_rain_term
    procedure :: lkt_evap_term
    procedure :: lkt_roff_term
    procedure :: lkt_iflw_term
    procedure :: lkt_wdrl_term
    procedure :: lkt_outf_term
    procedure :: pak_df_obs => lkt_df_obs
    procedure :: pak_bd_obs => lkt_bd_obs
    procedure :: pak_set_stressperiod => lkt_set_stressperiod

  end type GwtLktType

  contains

  subroutine lkt_create(packobj, id, ibcnum, inunit, iout, namemodel, pakname, &
                        fmi)
! ******************************************************************************
! mwt_create -- Create a New MWT Package
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(BndType), pointer :: packobj
    integer(I4B),intent(in) :: id
    integer(I4B),intent(in) :: ibcnum
    integer(I4B),intent(in) :: inunit
    integer(I4B),intent(in) :: iout
    character(len=*), intent(in) :: namemodel
    character(len=*), intent(in) :: pakname
    type(GwtFmiType), pointer :: fmi
    ! -- local
    type(GwtLktType), pointer :: lktobj
! ------------------------------------------------------------------------------
    !
    ! -- allocate the object and assign values to object variables
    allocate(lktobj)
    packobj => lktobj
    !
    ! -- create name and origin
    call packobj%set_names(ibcnum, namemodel, pakname, ftype)
    packobj%text = text
    !
    ! -- allocate scalars
    call lktobj%allocate_scalars()
    !
    ! -- initialize package
    call packobj%pack_initialize()

    packobj%inunit = inunit
    packobj%iout = iout
    packobj%id = id
    packobj%ibcnum = ibcnum
    packobj%ncolbnd = 1
    packobj%iscloc = 1

    ! -- Store pointer to flow model interface.  When the GwfGwt exchange is
    !    created, it sets fmi%bndlist so that the GWT model has access to all
    !    the flow packages
    lktobj%fmi => fmi
    !
    ! -- return
    return
  end subroutine lkt_create

  subroutine find_lkt_package(this)
! ******************************************************************************
! find corresponding lkt package
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_allocate
    ! -- dummy
    class(GwtLktType) :: this
    ! -- local
    character(len=LINELENGTH) :: errmsg
    class(BndType), pointer :: packobj
    integer(I4B) :: ip, icount
    integer(I4B) :: nbudterm
    logical :: found
! ------------------------------------------------------------------------------
    !
    ! -- Initialize found to false, and error later if flow package cannot
    !    be found
    found = .false.
    !
    ! -- If user is specifying flows in a binary budget file, then set up
    !    the budget file reader, otherwise set a pointer to the flow package
    !    budobj
    if (this%fmi%flows_from_file) then
      call this%fmi%set_aptbudobj_pointer(this%flowpackagename, this%flowbudptr)
      if (associated(this%flowbudptr)) found = .true.
      !
    else
      if (associated(this%fmi%gwfbndlist)) then
        ! -- Look through gwfbndlist for a flow package with the same name as
        !    this transport package name
        do ip = 1, this%fmi%gwfbndlist%Count()
          packobj => GetBndFromList(this%fmi%gwfbndlist, ip)
          if (packobj%name == this%flowpackagename) then
            found = .true.
            !
            ! -- store BndType pointer to packobj, and then
            !    use the select type to point to the budobj in flow package
            this%flowpackagebnd => packobj
            select type (packobj)
              type is (LakType)
                this%flowbudptr => packobj%budobj
            end select
          end if
          if (found) exit
        end do
      end if
    end if
    !
    ! -- error if flow package not found
    if (.not. found) then
      write(errmsg, '(a)') 'COULD NOT FIND FLOW PACKAGE WITH NAME '&
                            &// trim(adjustl(this%flowpackagename)) // '.'
      call store_error(errmsg)
      call this%parser%StoreErrorUnit()
      call ustop()
    endif
    !
    ! -- allocate space for idxbudssm, which indicates whether this is a
    !    special budget term or one that is a general source and sink
    nbudterm = this%flowbudptr%nbudterm
    call mem_allocate(this%idxbudssm, nbudterm, 'IDXBUDSSM', this%origin)
    !
    ! -- Process budget terms and identify special budget terms
    write(this%iout, '(/, a, a)') &
      'PROCESSING ' // ftype // ' INFORMATION FOR ', this%name
    write(this%iout, '(a)') '  IDENTIFYING FLOW TERMS IN ' // flowtype // ' PACKAGE'
    write(this%iout, '(a, i0)') &
      '  NUMBER OF ' // flowtype // ' = ', this%flowbudptr%ncv
    icount = 1
    do ip = 1, this%flowbudptr%nbudterm
      select case(trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)))
      case('FLOW-JA-FACE')
        this%idxbudfjf = ip
        this%idxbudssm(ip) = 0
      case('GWF')
        this%idxbudgwf = ip
        this%idxbudssm(ip) = 0
      case('STORAGE')
        this%idxbudsto = ip
        this%idxbudssm(ip) = 0
      case('RAINFALL')
        this%idxbudrain = ip
        this%idxbudssm(ip) = 0
      case('EVAPORATION')
        this%idxbudevap = ip
        this%idxbudssm(ip) = 0
      case('RUNOFF')
        this%idxbudroff = ip
        this%idxbudssm(ip) = 0
      case('EXT-INFLOW')
        this%idxbudiflw = ip
        this%idxbudssm(ip) = 0
      case('WITHDRAWAL')
        this%idxbudwdrl = ip
        this%idxbudssm(ip) = 0
      case('EXT-OUTFLOW')
        this%idxbudoutf = ip
        this%idxbudssm(ip) = 0
      case('TO-MVR')
        this%idxbudtmvr = ip
        this%idxbudssm(ip) = 0
      case('FROM-MVR')
        this%idxbudfmvr = ip
        this%idxbudssm(ip) = 0
      case('AUXILIARY')
        this%idxbudaux = ip
        this%idxbudssm(ip) = 0
      case default
        !
        ! -- set idxbudssm equal to a column index for where the concentrations
        !    are stored in the concbud(nbudssm, ncv) array
        this%idxbudssm(ip) = icount
        icount = icount + 1
      end select
      write(this%iout, '(a, i0, " = ", a,/, a, i0)') &
        '  TERM ', ip, trim(adjustl(this%flowbudptr%budterm(ip)%flowtype)), &
        '   MAX NO. OF ENTRIES = ', this%flowbudptr%budterm(ip)%maxlist
    end do
    write(this%iout, '(a, //)') 'DONE PROCESSING ' // ftype // ' INFORMATION'
    !
    ! -- Return
    return
end subroutine find_lkt_package

  subroutine lkt_fc_expanded(this, rhs, ia, idxglo, amatsln)
! ******************************************************************************
! lkt_fc_expanded -- this will be called from GwtAptType%apt_fc_expanded()
!   in order to add matrix terms specifically for LKT
! ****************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwtLktType) :: this
    real(DP), dimension(:), intent(inout) :: rhs
    integer(I4B), dimension(:), intent(in) :: ia
    integer(I4B), dimension(:), intent(in) :: idxglo
    real(DP), dimension(:), intent(inout) :: amatsln
    ! -- local
    integer(I4B) :: j, n1, n2
    integer(I4B) :: iloc
    integer(I4B) :: iposd
    real(DP) :: rrate
    real(DP) :: rhsval
    real(DP) :: hcofval
! ------------------------------------------------------------------------------
    !
    ! -- add rainfall contribution
    if (this%idxbudrain /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist
        call this%lkt_rain_term(j, n1, n2, rrate, rhsval, hcofval)
        iloc = this%idxlocnode(n1)
        iposd = this%idxpakdiag(n1)
        amatsln(iposd) = amatsln(iposd) + hcofval
        rhs(iloc) = rhs(iloc) + rhsval
      end do
    end if
    !
    ! -- add evaporation contribution
    if (this%idxbudevap /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist
        call this%lkt_evap_term(j, n1, n2, rrate, rhsval, hcofval)
        iloc = this%idxlocnode(n1)
        iposd = this%idxpakdiag(n1)
        amatsln(iposd) = amatsln(iposd) + hcofval
        rhs(iloc) = rhs(iloc) + rhsval
      end do
    end if
    !
    ! -- add runoff contribution
    if (this%idxbudroff /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist
        call this%lkt_roff_term(j, n1, n2, rrate, rhsval, hcofval)
        iloc = this%idxlocnode(n1)
        iposd = this%idxpakdiag(n1)
        amatsln(iposd) = amatsln(iposd) + hcofval
        rhs(iloc) = rhs(iloc) + rhsval
      end do
    end if
    !
    ! -- add inflow contribution
    if (this%idxbudiflw /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist
        call this%lkt_iflw_term(j, n1, n2, rrate, rhsval, hcofval)
        iloc = this%idxlocnode(n1)
        iposd = this%idxpakdiag(n1)
        amatsln(iposd) = amatsln(iposd) + hcofval
        rhs(iloc) = rhs(iloc) + rhsval
      end do
    end if
    !
    ! -- add withdrawal contribution
    if (this%idxbudwdrl /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudwdrl)%nlist
        call this%lkt_wdrl_term(j, n1, n2, rrate, rhsval, hcofval)
        iloc = this%idxlocnode(n1)
        iposd = this%idxpakdiag(n1)
        amatsln(iposd) = amatsln(iposd) + hcofval
        rhs(iloc) = rhs(iloc) + rhsval
      end do
    end if
    !
    ! -- add outflow contribution
    if (this%idxbudoutf /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist
        call this%lkt_outf_term(j, n1, n2, rrate, rhsval, hcofval)
        iloc = this%idxlocnode(n1)
        iposd = this%idxpakdiag(n1)
        amatsln(iposd) = amatsln(iposd) + hcofval
        rhs(iloc) = rhs(iloc) + rhsval
      end do
    end if
    !
    ! -- Return
    return
  end subroutine lkt_fc_expanded

  subroutine lkt_solve(this)
! ******************************************************************************
! lkt_solve -- add terms specific to lakes to the explicit lake solve
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType) :: this
    ! -- local
    integer(I4B) :: j
    integer(I4B) :: n1, n2
    real(DP) :: rrate
! ------------------------------------------------------------------------------
    !
    ! -- add rainfall contribution
    if (this%idxbudrain /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudrain)%nlist
        call this%lkt_rain_term(j, n1, n2, rrate)
        this%dbuff(n1) = this%dbuff(n1) + rrate
      end do
    end if
    !
    ! -- add evaporation contribution
    if (this%idxbudevap /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudevap)%nlist
        call this%lkt_evap_term(j, n1, n2, rrate)
        this%dbuff(n1) = this%dbuff(n1) + rrate
      end do
    end if
    !
    ! -- add runoff contribution
    if (this%idxbudroff /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudroff)%nlist
        call this%lkt_roff_term(j, n1, n2, rrate)
        this%dbuff(n1) = this%dbuff(n1) + rrate
      end do
    end if
    !
    ! -- add inflow contribution
    if (this%idxbudiflw /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudiflw)%nlist
        call this%lkt_iflw_term(j, n1, n2, rrate)
        this%dbuff(n1) = this%dbuff(n1) + rrate
      end do
    end if
    !
    ! -- add withdrawal contribution
    if (this%idxbudwdrl /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudwdrl)%nlist
        call this%lkt_wdrl_term(j, n1, n2, rrate)
        this%dbuff(n1) = this%dbuff(n1) + rrate
      end do
    end if
    !
    ! -- add outflow contribution
    if (this%idxbudoutf /= 0) then
      do j = 1, this%flowbudptr%budterm(this%idxbudoutf)%nlist
        call this%lkt_outf_term(j, n1, n2, rrate)
        this%dbuff(n1) = this%dbuff(n1) + rrate
      end do
    end if
    !
    ! -- Return
    return
  end subroutine lkt_solve

  function lkt_get_nbudterms(this) result(nbudterms)
! ******************************************************************************
! lkt_get_nbudterms -- function to return the number of budget terms just for
!   this package.  This overrides function in parent.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwtLktType) :: this
    ! -- return
    integer(I4B) :: nbudterms
    ! -- local
! ------------------------------------------------------------------------------
    !
    ! -- Number of budget terms is 6
    nbudterms = 6
    !
    ! -- Return
    return
  end function lkt_get_nbudterms

  subroutine lkt_setup_budobj(this, idx)
! ******************************************************************************
! lkt_setup_budobj -- Set up the budget object that stores all the lake flows
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LENBUDTXT
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(inout) :: idx
    ! -- local
    integer(I4B) :: maxlist, naux
    character(len=LENBUDTXT) :: text
! ------------------------------------------------------------------------------
    !
    ! --
    text = '        RAINFALL'
    idx = idx + 1
    maxlist = this%flowbudptr%budterm(this%idxbudrain)%maxlist
    naux = 0
    call this%budobj%budterm(idx)%initialize(text, &
                                             this%name_model, &
                                             this%name, &
                                             this%name_model, &
                                             this%name, &
                                             maxlist, .false., .false., &
                                             naux)
    !
    ! --
    text = '     EVAPORATION'
    idx = idx + 1
    maxlist = this%flowbudptr%budterm(this%idxbudevap)%maxlist
    naux = 0
    call this%budobj%budterm(idx)%initialize(text, &
                                             this%name_model, &
                                             this%name, &
                                             this%name_model, &
                                             this%name, &
                                             maxlist, .false., .false., &
                                             naux)
    !
    ! --
    text = '          RUNOFF'
    idx = idx + 1
    maxlist = this%flowbudptr%budterm(this%idxbudroff)%maxlist
    naux = 0
    call this%budobj%budterm(idx)%initialize(text, &
                                             this%name_model, &
                                             this%name, &
                                             this%name_model, &
                                             this%name, &
                                             maxlist, .false., .false., &
                                             naux)
    !
    ! --
    text = '      EXT-INFLOW'
    idx = idx + 1
    maxlist = this%flowbudptr%budterm(this%idxbudiflw)%maxlist
    naux = 0
    call this%budobj%budterm(idx)%initialize(text, &
                                             this%name_model, &
                                             this%name, &
                                             this%name_model, &
                                             this%name, &
                                             maxlist, .false., .false., &
                                             naux)
    !
    ! --
    text = '      WITHDRAWAL'
    idx = idx + 1
    maxlist = this%flowbudptr%budterm(this%idxbudwdrl)%maxlist
    naux = 0
    call this%budobj%budterm(idx)%initialize(text, &
                                             this%name_model, &
                                             this%name, &
                                             this%name_model, &
                                             this%name, &
                                             maxlist, .false., .false., &
                                             naux)
    !
    ! --
    text = '     EXT-OUTFLOW'
    idx = idx + 1
    maxlist = this%flowbudptr%budterm(this%idxbudoutf)%maxlist
    naux = 0
    call this%budobj%budterm(idx)%initialize(text, &
                                             this%name_model, &
                                             this%name, &
                                             this%name_model, &
                                             this%name, &
                                             maxlist, .false., .false., &
                                             naux)
    !
    ! -- return
    return
  end subroutine lkt_setup_budobj

  subroutine lkt_fill_budobj(this, idx, x, ccratin, ccratout)
! ******************************************************************************
! lkt_fill_budobj -- copy flow terms into this%budobj
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(inout) :: idx
    real(DP), dimension(:), intent(in) :: x
    real(DP), intent(inout) :: ccratin
    real(DP), intent(inout) :: ccratout
    ! -- local
    integer(I4B) :: j, n1, n2
    integer(I4B) :: nlist
    real(DP) :: q
    ! -- formats
! -----------------------------------------------------------------------------

    ! -- RAIN
    idx = idx + 1
    nlist = this%flowbudptr%budterm(this%idxbudrain)%nlist
    call this%budobj%budterm(idx)%reset(nlist)
    do j = 1, nlist
      call this%lkt_rain_term(j, n1, n2, q)
      call this%budobj%budterm(idx)%update_term(n1, n2, q)
      call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
    end do

    ! -- EVAPORATION
    idx = idx + 1
    nlist = this%flowbudptr%budterm(this%idxbudevap)%nlist
    call this%budobj%budterm(idx)%reset(nlist)
    do j = 1, nlist
      call this%lkt_evap_term(j, n1, n2, q)
      call this%budobj%budterm(idx)%update_term(n1, n2, q)
      call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
    end do

    ! -- RUNOFF
    idx = idx + 1
    nlist = this%flowbudptr%budterm(this%idxbudroff)%nlist
    call this%budobj%budterm(idx)%reset(nlist)
    do j = 1, nlist
      call this%lkt_roff_term(j, n1, n2, q)
      call this%budobj%budterm(idx)%update_term(n1, n2, q)
      call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
    end do

    ! -- EXT-INFLOW
    idx = idx + 1
    nlist = this%flowbudptr%budterm(this%idxbudiflw)%nlist
    call this%budobj%budterm(idx)%reset(nlist)
    do j = 1, nlist
      call this%lkt_iflw_term(j, n1, n2, q)
      call this%budobj%budterm(idx)%update_term(n1, n2, q)
      call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
    end do

    ! -- WITHDRAWAL
    idx = idx + 1
    nlist = this%flowbudptr%budterm(this%idxbudwdrl)%nlist
    call this%budobj%budterm(idx)%reset(nlist)
    do j = 1, nlist
      call this%lkt_wdrl_term(j, n1, n2, q)
      call this%budobj%budterm(idx)%update_term(n1, n2, q)
      call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
    end do

    ! -- EXT-OUTFLOW
    idx = idx + 1
    nlist = this%flowbudptr%budterm(this%idxbudoutf)%nlist
    call this%budobj%budterm(idx)%reset(nlist)
    do j = 1, nlist
      call this%lkt_outf_term(j, n1, n2, q)
      call this%budobj%budterm(idx)%update_term(n1, n2, q)
      call this%apt_accumulate_ccterm(n1, q, ccratin, ccratout)
    end do

    !
    ! -- return
    return
  end subroutine lkt_fill_budobj

  subroutine allocate_scalars(this)
! ******************************************************************************
! allocate_scalars
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_allocate
    ! -- dummy
    class(GwtLktType) :: this
    ! -- local
! ------------------------------------------------------------------------------
    !
    ! -- allocate scalars in GwtAptType
    call this%GwtAptType%allocate_scalars()
    !
    ! -- Allocate
    call mem_allocate(this%idxbudrain, 'IDXBUDRAIN', this%origin)
    call mem_allocate(this%idxbudevap, 'IDXBUDEVAP', this%origin)
    call mem_allocate(this%idxbudroff, 'IDXBUDROFF', this%origin)
    call mem_allocate(this%idxbudiflw, 'IDXBUDIFLW', this%origin)
    call mem_allocate(this%idxbudwdrl, 'IDXBUDWDRL', this%origin)
    call mem_allocate(this%idxbudoutf, 'IDXBUDOUTF', this%origin)
    !
    ! -- Initialize
    this%idxbudrain = 0
    this%idxbudevap = 0
    this%idxbudroff = 0
    this%idxbudiflw = 0
    this%idxbudwdrl = 0
    this%idxbudoutf = 0
    !
    ! -- Return
    return
  end subroutine allocate_scalars

  subroutine lkt_allocate_arrays(this)
! ******************************************************************************
! lkt_allocate_arrays
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_allocate
    ! -- dummy
    class(GwtLktType), intent(inout) :: this
    ! -- local
    integer(I4B) :: n
! ------------------------------------------------------------------------------
    !
    ! -- time series
    call mem_allocate(this%concrain, this%ncv, 'CONCRAIN', this%origin)
    call mem_allocate(this%concevap, this%ncv, 'CONCEVAP', this%origin)
    call mem_allocate(this%concroff, this%ncv, 'CONCROFF', this%origin)
    call mem_allocate(this%conciflw, this%ncv, 'CONCIFLW', this%origin)
    !
    ! -- call standard GwtApttype allocate arrays
    call this%GwtAptType%apt_allocate_arrays()
    !
    ! -- Initialize
    do n = 1, this%ncv
      this%concrain(n) = DZERO
      this%concevap(n) = DZERO
      this%concroff(n) = DZERO
      this%conciflw(n) = DZERO
    end do
    !
    !
    ! -- Return
    return
  end subroutine lkt_allocate_arrays

  subroutine lkt_da(this)
! ******************************************************************************
! lkt_da
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_deallocate
    ! -- dummy
    class(GwtLktType) :: this
    ! -- local
! ------------------------------------------------------------------------------
    !
    ! -- deallocate scalars
    call mem_deallocate(this%idxbudrain)
    call mem_deallocate(this%idxbudevap)
    call mem_deallocate(this%idxbudroff)
    call mem_deallocate(this%idxbudiflw)
    call mem_deallocate(this%idxbudwdrl)
    call mem_deallocate(this%idxbudoutf)
    !
    ! -- deallocate time series
    call mem_deallocate(this%concrain)
    call mem_deallocate(this%concevap)
    call mem_deallocate(this%concroff)
    call mem_deallocate(this%conciflw)
    !
    ! -- deallocate scalars in GwtAptType
    call this%GwtAptType%bnd_da()
    !
    ! -- Return
    return
  end subroutine lkt_da

  subroutine lkt_rain_term(this, ientry, n1, n2, rrate, &
                           rhsval, hcofval)
! ******************************************************************************
! lkt_rain_term
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(in) :: ientry
    integer(I4B), intent(inout) :: n1
    integer(I4B), intent(inout) :: n2
    real(DP), intent(inout), optional :: rrate
    real(DP), intent(inout), optional :: rhsval
    real(DP), intent(inout), optional :: hcofval
    ! -- local
    real(DP) :: qbnd
    real(DP) :: ctmp
! ------------------------------------------------------------------------------
    n1 = this%flowbudptr%budterm(this%idxbudrain)%id1(ientry)
    n2 = this%flowbudptr%budterm(this%idxbudrain)%id2(ientry)
    qbnd = this%flowbudptr%budterm(this%idxbudrain)%flow(ientry)
    ctmp = this%concrain(n1)
    if (present(rrate)) rrate = ctmp * qbnd
    if (present(rhsval)) rhsval = -rrate
    if (present(hcofval)) hcofval = DZERO
    !
    ! -- return
    return
  end subroutine lkt_rain_term

  subroutine lkt_evap_term(this, ientry, n1, n2, rrate, &
                           rhsval, hcofval)
! ******************************************************************************
! lkt_evap_term
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(in) :: ientry
    integer(I4B), intent(inout) :: n1
    integer(I4B), intent(inout) :: n2
    real(DP), intent(inout), optional :: rrate
    real(DP), intent(inout), optional :: rhsval
    real(DP), intent(inout), optional :: hcofval
    ! -- local
    real(DP) :: qbnd
    real(DP) :: ctmp
    real(DP) :: omega
! ------------------------------------------------------------------------------
    n1 = this%flowbudptr%budterm(this%idxbudevap)%id1(ientry)
    n2 = this%flowbudptr%budterm(this%idxbudevap)%id2(ientry)
    ! -- note that qbnd is negative for evap
    qbnd = this%flowbudptr%budterm(this%idxbudevap)%flow(ientry)
    ctmp = this%concevap(n1)
    if (this%xnewpak(n1) < ctmp) then
      omega = DONE
    else
      omega = DZERO
    end if
    if (present(rrate)) &
      rrate = omega * qbnd * this%xnewpak(n1) + &
              (DONE - omega) * qbnd * ctmp
    if (present(rhsval)) rhsval = - (DONE - omega) * qbnd * ctmp
    if (present(hcofval)) hcofval = omega * qbnd
    !
    ! -- return
    return
  end subroutine lkt_evap_term

  subroutine lkt_roff_term(this, ientry, n1, n2, rrate, &
                           rhsval, hcofval)
! ******************************************************************************
! lkt_roff_term
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(in) :: ientry
    integer(I4B), intent(inout) :: n1
    integer(I4B), intent(inout) :: n2
    real(DP), intent(inout), optional :: rrate
    real(DP), intent(inout), optional :: rhsval
    real(DP), intent(inout), optional :: hcofval
    ! -- local
    real(DP) :: qbnd
    real(DP) :: ctmp
! ------------------------------------------------------------------------------
    n1 = this%flowbudptr%budterm(this%idxbudroff)%id1(ientry)
    n2 = this%flowbudptr%budterm(this%idxbudroff)%id2(ientry)
    qbnd = this%flowbudptr%budterm(this%idxbudroff)%flow(ientry)
    ctmp = this%concroff(n1)
    if (present(rrate)) rrate = ctmp * qbnd
    if (present(rhsval)) rhsval = -rrate
    if (present(hcofval)) hcofval = DZERO
    !
    ! -- return
    return
  end subroutine lkt_roff_term

  subroutine lkt_iflw_term(this, ientry, n1, n2, rrate, &
                           rhsval, hcofval)
! ******************************************************************************
! lkt_iflw_term
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(in) :: ientry
    integer(I4B), intent(inout) :: n1
    integer(I4B), intent(inout) :: n2
    real(DP), intent(inout), optional :: rrate
    real(DP), intent(inout), optional :: rhsval
    real(DP), intent(inout), optional :: hcofval
    ! -- local
    real(DP) :: qbnd
    real(DP) :: ctmp
! ------------------------------------------------------------------------------
    n1 = this%flowbudptr%budterm(this%idxbudiflw)%id1(ientry)
    n2 = this%flowbudptr%budterm(this%idxbudiflw)%id2(ientry)
    qbnd = this%flowbudptr%budterm(this%idxbudiflw)%flow(ientry)
    ctmp = this%conciflw(n1)
    if (present(rrate)) rrate = ctmp * qbnd
    if (present(rhsval)) rhsval = -rrate
    if (present(hcofval)) hcofval = DZERO
    !
    ! -- return
    return
  end subroutine lkt_iflw_term

  subroutine lkt_wdrl_term(this, ientry, n1, n2, rrate, &
                           rhsval, hcofval)
! ******************************************************************************
! lkt_wdrl_term
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(in) :: ientry
    integer(I4B), intent(inout) :: n1
    integer(I4B), intent(inout) :: n2
    real(DP), intent(inout), optional :: rrate
    real(DP), intent(inout), optional :: rhsval
    real(DP), intent(inout), optional :: hcofval
    ! -- local
    real(DP) :: qbnd
    real(DP) :: ctmp
! ------------------------------------------------------------------------------
    n1 = this%flowbudptr%budterm(this%idxbudwdrl)%id1(ientry)
    n2 = this%flowbudptr%budterm(this%idxbudwdrl)%id2(ientry)
    qbnd = this%flowbudptr%budterm(this%idxbudwdrl)%flow(ientry)
    ctmp = this%xnewpak(n1)
    if (present(rrate)) rrate = ctmp * qbnd
    if (present(rhsval)) rhsval = DZERO
    if (present(hcofval)) hcofval = qbnd
    !
    ! -- return
    return
  end subroutine lkt_wdrl_term

  subroutine lkt_outf_term(this, ientry, n1, n2, rrate, &
                           rhsval, hcofval)
! ******************************************************************************
! lkt_outf_term
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType) :: this
    integer(I4B), intent(in) :: ientry
    integer(I4B), intent(inout) :: n1
    integer(I4B), intent(inout) :: n2
    real(DP), intent(inout), optional :: rrate
    real(DP), intent(inout), optional :: rhsval
    real(DP), intent(inout), optional :: hcofval
    ! -- local
    real(DP) :: qbnd
    real(DP) :: ctmp
! ------------------------------------------------------------------------------
    n1 = this%flowbudptr%budterm(this%idxbudoutf)%id1(ientry)
    n2 = this%flowbudptr%budterm(this%idxbudoutf)%id2(ientry)
    qbnd = this%flowbudptr%budterm(this%idxbudoutf)%flow(ientry)
    ctmp = this%xnewpak(n1)
    if (present(rrate)) rrate = ctmp * qbnd
    if (present(rhsval)) rhsval = DZERO
    if (present(hcofval)) hcofval = qbnd
    !
    ! -- return
    return
  end subroutine lkt_outf_term

  subroutine lkt_df_obs(this)
! ******************************************************************************
! lkt_df_obs -- obs are supported?
!   -- Store observation type supported by APT package.
!   -- Overrides BndType%bnd_df_obs
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use GwtAptModule, only: apt_process_obsID
    ! -- dummy
    class(GwtLktType) :: this
    ! -- local
    integer(I4B) :: indx
! ------------------------------------------------------------------------------
    !
    ! -- Store obs type and assign procedure pointer
    !    for rainfall observation type.
    call this%obs%StoreObsType('rainfall', .true., indx)
    this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID
    !
    ! -- Store obs type and assign procedure pointer
    !    for evaporation observation type.
    call this%obs%StoreObsType('evaporation', .true., indx)
    this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID
    !
    ! -- Store obs type and assign procedure pointer
    !    for runoff observation type.
    call this%obs%StoreObsType('runoff', .true., indx)
    this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID
    !
    ! -- Store obs type and assign procedure pointer
    !    for inflow observation type.
    call this%obs%StoreObsType('ext-inflow', .true., indx)
    this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID
    !
    ! -- Store obs type and assign procedure pointer
    !    for withdrawal observation type.
    call this%obs%StoreObsType('withdrawal', .true., indx)
    this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID
    !
    ! -- Store obs type and assign procedure pointer
    !    for ext-outflow observation type.
    call this%obs%StoreObsType('outflow', .true., indx)
    this%obs%obsData(indx)%ProcessIdPtr => apt_process_obsID
    !
    return
  end subroutine lkt_df_obs

  subroutine lkt_bd_obs(this, obstypeid, jj, v, found)
! ******************************************************************************
! lkt_bd_obs -- calculate observation value and pass it back to APT
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    class(GwtLktType), intent(inout) :: this
    character(len=*), intent(in) :: obstypeid
    real(DP), intent(inout) :: v
    integer(I4B), intent(in) :: jj
    logical, intent(inout) :: found
    ! -- local
    integer(I4B) :: n1, n2
! ------------------------------------------------------------------------------
    !
    found = .true.
    select case (obstypeid)
      case ('RAINFALL')
        if (this%iboundpak(jj) /= 0) then
          call this%lkt_rain_term(jj, n1, n2, v)
        end if
      case ('EVAPORATION')
        if (this%iboundpak(jj) /= 0) then
          call this%lkt_evap_term(jj, n1, n2, v)
        end if
      case ('RUNOFF')
        if (this%iboundpak(jj) /= 0) then
          call this%lkt_roff_term(jj, n1, n2, v)
        end if
      case ('EXT-INFLOW')
        if (this%iboundpak(jj) /= 0) then
          call this%lkt_iflw_term(jj, n1, n2, v)
        end if
      case ('WITHDRAWAL')
        if (this%iboundpak(jj) /= 0) then
          call this%lkt_wdrl_term(jj, n1, n2, v)
        end if
      case ('EXT-OUTFLOW')
        if (this%iboundpak(jj) /= 0) then
          call this%lkt_outf_term(jj, n1, n2, v)
        end if
      case default
        found = .false.
    end select
    !
    return
  end subroutine lkt_bd_obs

  subroutine lkt_set_stressperiod(this, itemno, keyword, found)
! ******************************************************************************
! lkt_set_stressperiod -- Set a stress period attribute for using keywords.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use TimeSeriesManagerModule, only: read_value_or_time_series_adv
    ! -- dummy
    class(GwtLktType),intent(inout) :: this
    integer(I4B), intent(in) :: itemno
    character(len=*), intent(in) :: keyword
    logical, intent(inout) :: found
    ! -- local
    character(len=LINELENGTH) :: text
    integer(I4B) :: ierr
    integer(I4B) :: jj
    real(DP), pointer :: bndElem => null()
    ! -- formats
! ------------------------------------------------------------------------------
    !
    ! RAINFALL <rainfall>
    ! EVAPORATION <evaporation>
    ! RUNOFF <runoff>
    ! INFLOW <inflow>
    ! WITHDRAWAL <withdrawal>
    !
    found = .true.
    select case (keyword)
      case ('RAINFALL')
        ierr = this%apt_check_valid(itemno)
        if (ierr /= 0) then
          goto 999
        end if
        call this%parser%GetString(text)
        jj = 1
        bndElem => this%concrain(itemno)
        call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%name, &
                                           'BND', this%tsManager, this%iprpak,   &
                                           'RAINFALL')
      case ('EVAPORATION')
        ierr = this%apt_check_valid(itemno)
        if (ierr /= 0) then
          goto 999
        end if
        call this%parser%GetString(text)
        jj = 1
        bndElem => this%concevap(itemno)
        call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%name, &
                                           'BND', this%tsManager, this%iprpak,   &
                                           'EVAPORATION')
      case ('RUNOFF')
        ierr = this%apt_check_valid(itemno)
        if (ierr /= 0) then
          goto 999
        end if
        call this%parser%GetString(text)
        jj = 1
        bndElem => this%concroff(itemno)
        call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%name, &
                                           'BND', this%tsManager, this%iprpak,   &
                                           'RUNOFF')
      case ('INFLOW')
        ierr = this%apt_check_valid(itemno)
        if (ierr /= 0) then
          goto 999
        end if
        call this%parser%GetString(text)
        jj = 1
        bndElem => this%conciflw(itemno)
        call read_value_or_time_series_adv(text, itemno, jj, bndElem, this%name, &
                                           'BND', this%tsManager, this%iprpak,   &
                                           'INFLOW')
      case default
        !
        ! -- keyword not recognized so return to caller with found = .false.
        found = .false.
    end select
    !
999 continue
    !
    ! -- return
    return
  end subroutine lkt_set_stressperiod

end module GwtLktModule


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE COLAPS (MXND, MXCORN, MLN, MXLOOP, NUID, XN, YN, ZN,
     &   LXK, KXL, NXL, LXN, ANGLE, LNODES, BNSIZE, NODE, KKKOLD,
     &   LLLOLD, NNNOLD, IAVAIL, NAVAIL, DONE, XMIN, XMAX, YMIN, YMAX,
     &   ZMIN, ZMAX, DEV1, LLL, KKK, NNN, LCORN, NCORN, NLOOP, NEXTN1,
     &   KLOOP, GRAPH, VIDEO, KREG, NOROOM, ERR)
C***********************************************************************

C  SUBROUTINE COLAPS = COLLAPSES A LOOP INTO TWO POSSIBLE LOOPS

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

      COMMON /TIMING/ TIMEA, TIMEP, TIMEC, TIMEPC, TIMEAJ, TIMES

      DIMENSION XN (MXND), YN (MXND), ZN (MXND), NUID (MXND)
      DIMENSION LXK (4, MXND), KXL (2, 3*MXND)
      DIMENSION NXL (2, 3*MXND), LXN (4, MXND)
      DIMENSION ANGLE (MXND), LNODES (MLN, MXND), BNSIZE (2, MXND)
      DIMENSION LCORN (MXCORN)
      DIMENSION NLOOP (MXLOOP), NEXTN1 (MXLOOP)

      CHARACTER*3 DEV1

      LOGICAL DONE, ERR, NOROOM, DONE1, DONE2, DONEP
      LOGICAL GRAPH, BOK, LCROSS, LMATCH, VIDEO
      LOGICAL CGRAPH, CWEDGE, PMATCH

      PI = ATAN2(0.0, -1.0)

C  FIND THE FIRST OVERLAPPING LINE STARTING AT THE CURRENT NODE

      CALL GETIME (TIME1)
      CGRAPH = .FALSE.
      CWEDGE = .TRUE.
      DONE1 = .FALSE.
      DONE2 = .FALSE.
      DONEP = .FALSE.
      PMATCH = .FALSE.
      ERR = .FALSE.
  100 CONTINUE
      N1 = NODE
      KOUNT1 = 0

      IF (CGRAPH) THEN
         CALL RPLOTL (MXND, XN, YN, ZN, NXL, XMIN, XMAX,
     &      YMIN, YMAX, ZMIN, ZMAX, LLL, DEV1, KREG)
      ENDIF

  110 CONTINUE
      N0 = LNODES (2, N1)
      N2 = LNODES (3, N1)
      N3 = LNODES (3, N2)
      KOUNT1 = KOUNT1 + 1

C  CHECK FOR COMPLETION

      IF (N2 .EQ. NODE) THEN
         GOTO 140
      ELSEIF (KOUNT1 .GT. NLOOP (1) + 1) THEN
         CALL MESAGE ('** PROBLEMS WITH LOOP CLOSING IN COLAPS **')
         ERR = .TRUE.
         GOTO 140
      ENDIF

C  CHECK THIS LINE AGAINST ALL REMAINING LINES

      KOUNT2 = 2
      N1TEST = LNODES (3, N2)
  120 CONTINUE
      N0TEST = LNODES (2, N1TEST)
      N2TEST = LNODES (3, N1TEST)
      N3TEST = LNODES (3, N2TEST)

      IF (CGRAPH) THEN
         CALL LCOLOR ('YELOW')
         CALL D2NODE (MXND, XN, YN, N1, N2)
         CALL D2NODE (MXND, XN, YN, N1TEST, N2TEST)
         CALL LCOLOR ('WHITE')
         CALL SFLUSH
      ENDIF

      CALL INTSCT (XN(N1), YN(N1), XN(N2), YN(N2), XN(N1TEST),
     &   YN(N1TEST), XN(N2TEST), YN(N2TEST), U, W, LCROSS)
      IF (.NOT. LCROSS) THEN
         IF (CGRAPH) THEN
            CALL D2NODE (MXND, XN, YN, N1, N2)
            CALL D2NODE (MXND, XN, YN, N1TEST, N2TEST)
            CALL SFLUSH
         ENDIF
         N1TEST = N2TEST
         KOUNT2 = KOUNT2 + 1
         IF (KOUNT2 .GT. ( NLOOP (1) / 2) ) THEN
            N1 = N2
            GOTO 110
         ENDIF
         GOTO 120
      ENDIF

C  AN INTERSECTION HAS OCCURRED.
C  GET THE BEST SEAM FROM THIS INTERSECTION

      IF ((GRAPH) .OR. (VIDEO)) THEN
         IF (.NOT. DONEP) THEN
            CALL RPLOTL (MXND, XN, YN, ZN, NXL, XMIN, XMAX,
     &         YMIN, YMAX, ZMIN, ZMAX, LLL, DEV1, KREG)
            DONEP = .TRUE.
            IF (VIDEO) CALL SNAPIT (1)
         ENDIF
         IF (GRAPH) THEN
            CALL LCOLOR ('YELOW')
            CALL D2NODE (MXND, XN, YN, N1, N2)
            CALL D2NODE (MXND, XN, YN, N1TEST, N2TEST)
            CALL LCOLOR ('WHITE')
            CALL SFLUSH
         ENDIF
      ENDIF
      CALL MATCH2 (MXND, MLN, XN, YN, NXL, LXN, LNODES, ANGLE, N0, N1,
     &   N2, N3, N0TEST, N1TEST, N2TEST, N3TEST, I1, I2, J1, J2,
     &   KOUNTL, LMATCH, KOUNT2, NODE, U, W, NLOOP (1), PMATCH, ERR)
      IF (ERR) GOTO 140
      IF (GRAPH) THEN
         CALL LCOLOR ('PINK ')
         CALL D2NODE (MXND, XN, YN, I1, I2)
         CALL D2NODE (MXND, XN, YN, J1, J2)
         CALL LCOLOR ('WHITE')
         CALL SFLUSH
      ENDIF
      IF (.NOT. LMATCH) THEN
         N1TEST = N2TEST
         KOUNT2 = KOUNT2 + 1
         IF (KOUNT2 .GT. ( NLOOP (1) / 2) ) THEN
            N1 = N2
            GOTO 110
         ENDIF
         GOTO 120
      ENDIF

C  NOW CHECK TO SEE IF THE ATTACHMENT WOULD CAUSE
C  LINES ON THE BOUNDARY TO CROSS

      CALL BCROSS (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN, LNODES,
     &   I1, I2, J1, J2, NLOOP(1), BOK, LLL, XMIN, XMAX, YMIN, YMAX,
     &   ZMIN, ZMAX, DEV1, KREG, ERR)
      IF (ERR) GOTO 140
      IF (.NOT. BOK) THEN
         N1TEST = N2TEST
         KOUNT2 = KOUNT2 + 1
         IF (KOUNT2 .GT. ( NLOOP (1) / 2) ) THEN
            N1 = N2
            GOTO 110
         ENDIF
         GOTO 120
      ENDIF

C  NOW CHECK TO SEE IF THE ATTACHMENT WOULD CAUSE
C  AN ILLFORMED 4 NODE ELEMENT

      CALL B4BAD (MXND, MLN, XN, YN, LXK, KXL, NXL, LXN, LNODES,
     &   ANGLE, I1, I2, J1, J2, NLOOP(1), KOUNTL, BOK, ERR)
      IF (ERR) GOTO 140
      IF (.NOT. BOK) THEN
         N1TEST = N2TEST
         KOUNT2 = KOUNT2 + 1
         IF (KOUNT2 .GT. ( NLOOP (1) / 2) ) THEN
            N1 = N2
            GOTO 110
         ENDIF
         GOTO 120
      ENDIF

C  SEE IF THE COLLAPSE IS BETWEEN TWO ELEMENT SIDES OF DISPROPORTIONATE
C  SIZES - IF SO A WEDGE MUST BE ADDED

      DISTI = SQRT ( ((XN (I1) - XN (I2)) **2) +
     &   ((YN (I1) - YN (I2)) **2) )
      DISTJ = SQRT ( ((XN (J1) - XN (J2)) **2) +
     &   ((YN (J1) - YN (J2)) **2) )
      FACT = 2.5
      IF ( (DISTI .GT. FACT * DISTJ) .AND.
     &   ((LXN (3, J1) .GT. 0) .OR. (LXN (2, J1) .LT. 0)) .AND.
     &   ((LXN (3, J2) .GT. 0) .OR. (LXN (2, J2) .LT. 0)) ) THEN
         AHOLD = ANGLE (I2)
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (2, I2), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (2, LNODES (2, I2)), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (3, I2), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (3, LNODES (3, I2)), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      I2, ERR)
         IF (ERR) GOTO 140
         CALL WEDGE (MXND, MLN, NUID, LXK, KXL, NXL, LXN, XN, YN,
     &      LNODES, BNSIZE, IAVAIL, NAVAIL, LLL, KKK, NNN, LLLOLD,
     &      NNNOLD, I2, IDUM, NLOOP (1), CWEDGE, GRAPH, VIDEO, NOROOM,
     &      ERR)
         IF ((NOROOM) .OR. (ERR)) GOTO 140
         IF (VIDEO) CALL SNAPIT (2)
         KOUNTL = KOUNTL + 1
         I1 = I2
         I2 = LNODES (3, I1)
         ANGLE (LNODES (3, I2)) = AHOLD
         ANGLE (I1) = PI
         ANGLE (I2) = PI
         GOTO 100
      ELSEIF ( (DISTJ .GT. FACT * DISTI) .AND.
     &   ((LXN (3, I1) .GT. 0) .OR. (LXN (2, I1) .LT. 0)) .AND.
     &   ((LXN (3, I2) .GT. 0) .OR. (LXN (2, I2) .LT. 0)) ) THEN
         AHOLD = ANGLE (J2)
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (2, J2), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (2, LNODES (2, J2)), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (3, J2), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      LNODES (3, LNODES (3, J2)), ERR)
         IF (ERR) GOTO 140
         CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES,
     &      J2, ERR)
         IF (ERR) GOTO 140
         CALL WEDGE (MXND, MLN, NUID, LXK, KXL, NXL, LXN, XN, YN,
     &      LNODES, BNSIZE, IAVAIL, NAVAIL, LLL, KKK, NNN, LLLOLD,
     &      NNNOLD, J2, IDUM, NLOOP (1), CWEDGE, GRAPH, VIDEO, NOROOM,
     &      ERR)
         IF ((NOROOM) .OR. (ERR)) GOTO 140
         IF (VIDEO) CALL SNAPIT (2)
         KOUNTL = KOUNTL + 1
         J1 = J2
         J2 = LNODES (3, J1)
         ANGLE (LNODES (3, J2)) = AHOLD
         ANGLE (J1) = PI
         ANGLE (J2) = PI
         GOTO 100
      ENDIF

C  NOW THAT THE APPROPRIATE COLLAPSE HAS BEEN FOUND, THE TWO LINES
C  MUST BE JOINED.

      CALL SEW2 (MXND, MLN, NUID, LXK, KXL, NXL, LXN, LNODES,
     &   IAVAIL, NAVAIL, LLL, KKK, NNN, I1, I2, J1, J2, NOROOM, ERR)
      IF ((NOROOM) .OR. (ERR)) GOTO 140

C  NOW SMOOTH AND PLOT THE CURRENT MESH

      NNN2 = 1
      CALL GETIME (TIME2)
      TIMEC = TIMEC + TIME2 - TIME1
      CALL FILSMO  (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN,
     &   LLL, NNN, NNN2, LNODES, BNSIZE, NLOOP (1), XMIN, XMAX, YMIN,
     &   YMAX, ZMIN, ZMAX, DEV1, KREG)
      CALL GETIME (TIME1)
      IF ((GRAPH) .OR. (VIDEO)) THEN
         CALL RPLOTL (MXND, XN, YN, ZN, NXL, XMIN, XMAX,
     &      YMIN, YMAX, ZMIN, ZMAX, LLL, DEV1, KREG)
         IF (VIDEO) CALL SNAPIT (1)
         IF (GRAPH) THEN
            CALL LCOLOR ('YELOW')
            CALL D2NODE (MXND, XN, YN, I1, I2)
            CALL LCOLOR ('WHITE')
            CALL SFLUSH
         ENDIF
      ENDIF
      NLOOP1 = KOUNTL
      NLOOP2 = NLOOP (1) - KOUNTL - 2

C  NOW UPDATE THE DEFINITIONS OF NODE FOR BOTH LOOPS

      IF (J1 .EQ. NODE) THEN
         NODE = I2
      ELSEIF (J2 .EQ. NODE) THEN
         NODE = I1
      ENDIF
      CALL NODE12 (MXND, MLN, LNODES, I1, I2, NLOOP1, NLOOP2,
     &   NODE1, NODE2, NODE, ERR)
      IF (ERR) GOTO 140

C  NOW TRY TO PINCH BOTH LOOPS

      CALL LUPANG (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN, NLOOP1,
     &   ANGLE, LNODES, NODE2, LLL, XMIN, XMAX, YMIN, YMAX, ZMIN, ZMAX,
     &   DEV1, KREG, ERR)
      IF (ERR) GOTO 140
      IDUM1 = 0
      IDUM2 = 0
      CALL GETIME (TIME2)
      TIMEC = TIMEC + TIME2 - TIME1
      CALL PINCH (MXND, MXCORN, MLN, NUID, XN, YN, ZN, LXK, KXL, NXL,
     &   LXN, ANGLE, LNODES, BNSIZE, NODE2, NLOOP1, KKKOLD, LLLOLD,
     &   NNNOLD, IAVAIL, NAVAIL, DONE1, XMIN, XMAX, YMIN, YMAX, ZMIN,
     &   ZMAX, DEV1, LLL, KKK, NNN, LCORN, NCORN, IDUM1, IDUM2, GRAPH,
     &   VIDEO, KREG, NOROOM, ERR)
      IF ((NOROOM) .OR. (ERR)) GOTO 140
      CALL GETIME (TIME1)
      CALL LUPANG (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN, NLOOP2,
     &   ANGLE, LNODES, NODE1, LLL, XMIN, XMAX, YMIN, YMAX, ZMIN, ZMAX,
     &   DEV1, KREG, ERR)
      IF (ERR) GOTO 140
      CALL GETIME (TIME2)
      TIMEC = TIMEC + TIME2 - TIME1
      CALL PINCH (MXND, MXCORN, MLN, NUID, XN, YN, ZN, LXK, KXL, NXL,
     &   LXN, ANGLE, LNODES, BNSIZE, NODE1, NLOOP2, KKKOLD, LLLOLD,
     &   NNNOLD, IAVAIL, NAVAIL, DONE2, XMIN, XMAX, YMIN, YMAX, ZMIN,
     &   ZMAX, DEV1, LLL, KKK, NNN, LCORN, NCORN, IDUM1, IDUM2, GRAPH,
     &   VIDEO, KREG, NOROOM, ERR)
      IF ((NOROOM) .OR. (ERR)) GOTO 140
      CALL GETIME (TIME1)

C  NOW HANDLE THE PLACEMENT OF THOSE LOOPS

      IF ((DONE1) .AND. (DONE2)) THEN
         DONE = .TRUE.
         GOTO 140
      ELSEIF (DONE1) THEN
         NLOOP (1) = NLOOP2
         NODE = NODE1
      ELSEIF (DONE2) THEN
         NLOOP (1) = NLOOP1
         NODE = NODE2
      ELSE

C  MOVE PREVIOUS LOOPS DOWN IN THE LIST

         KLOOP = KLOOP + 1
         DO 130 I = KLOOP, 3, -1
            NLOOP (I) = NLOOP (I - 1)
            NEXTN1 (I) = NEXTN1 (I - 1)
  130    CONTINUE
         NEXTN1 (KLOOP) = 0

C  INSERT THE TWO NEW LISTS AS THE TOP TWO - KEEPING NODE
C  THE SAME FOR ONE OF THE LOOPS

         NLOOP (1) = NLOOP1
         NLOOP (2) = NLOOP2
         NEXTN1 (2) = NEXTN1 (1)
         NEXTN1 (1) = NODE1
         NODE = NODE2
      ENDIF

C  NOW MAKE SURE THAT THE TOP LOOP DOES NOT NEED A COLAPS AGAIN

      GOTO 100

  140 CONTINUE
      CALL GETIME (TIME2)
      TIMEC = TIMEC + TIME2 - TIME1
      RETURN

      END