!
!***********************************************************************
!
      module Coupling_transform_cfg_LSLSJ3
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      use Coupling_constants
      use Coupling_structures
      use Coupling_data
!-----------------------------------------------
!   R o u t i n e s
!-----------------------------------------------
      public  :: main_cfg_lslsJ3
      public  :: count_nr_of_csfs_LSJ3
      public  :: delete_cfg_expansions
      private :: form_list_nomach_csfs
      private :: form_csfs_LSJ3
      private :: matrix_LS_LSJ3
      private :: dotransform_LSLSJ3
      private :: print_cfg_LSLSJ3
      private :: equivalent_LSLSJ3
!-----------------------------------------------
!   D e f i n i t i o n s
!-----------------------------------------------
      type::Ji_lists
         integer::nr_of_csf !serial number of csf_LS in csfs_LS
         type(list),dimension(:),pointer::Ji !i=1..nr_of_subc
      end type Ji_lists
!
      type:: cfg_Ji_lists
         integer::nr_of_subc
         integer::nr_of_nomach_csfs
         type(Ji_lists),dimension(:),pointer::csfs_Ji !i=1..nr_of_nomach_csfs
      end type cfg_Ji_lists
!
      type(expansion), public :: expansion_cfg_LS
      type(expansion), public :: expansion_cfg_LSJ3
!
      type(list), private ::nomach_csfs_ls
      type(cfg_Ji_lists), private::cfg_Ji_structure
!-----------------------------------------------
!
contains
!
!***********************************************************************
!                                                                      *
      subroutine main_cfg_lslsJ3(print_level)
!                                                                      *
!     This is managerial subroutine                                    *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(in) :: print_level
      integer::error
      integer::itype
      expansion_cfg_LSJ3%nr_of_state=expansion_cfg_LS%nr_of_state
      call form_list_nomach_csfs
      itype=0
      call form_csfs_LSJ3(itype)
      call dotransform_LSLSJ3
      if(print_level.gt.1) call print_cfg_LSLSJ3(2)
      deallocate(nomach_csfs_ls%items, STAT = error)
      end subroutine main_cfg_lslsJ3
!
!***********************************************************************
!                                                                      *
      subroutine count_nr_of_csfs_LSJ3(nr_of_csfs)
!                                                                      *
!     This subroutine counts the number of oneconfigurational          *
!     expansion in LSJ3 coupling                                        *
!     (corresponding to the one in the JJ coupling "expansion_cfg_LS") *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(out):: nr_of_csfs
      integer::error
      integer::itype
      if(expansion_cfg_LS%csfs(1)%nosubc /= 3) then
         write(*,*)                                                    &
            'ERROR at subroutine count_nr_of_csfs_LSJ3: nosubc /= 3'
         write(*,*)                                                    &
            '(you can use LSJ3 coupling with subshells number  = 3)'
         write(*,*) 'At presint number of subshells is',               &
            expansion_cfg_LS%csfs(1)%nosubc
         write(*,*)'program is terminated'
         stop
      end if
      expansion_cfg_LSJ3%nr_of_state=expansion_cfg_LS%nr_of_state
      call form_list_nomach_csfs
      itype=1
      call form_csfs_LSJ3(itype)
      nr_of_csfs = expansion_cfg_LSJ3%size
      if(associated(nomach_csfs_ls%items))                             &
                             deallocate(nomach_csfs_ls%items,STAT=error)
      end subroutine count_nr_of_csfs_LSJ3
!
!***********************************************************************
!                                                                      *
      subroutine delete_cfg_expansions
!                                                                      *
!     This subroutine deallocates the arrays of                        *
!     oneconfigurational expansions "expansion_cfg_LSJ3" and           *
!     "expansion_cfg_LS"                                               *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      integer::icsf
!
!write(iwrite_log,'(6x,a21)') 'delete_cfg_expansions'
!
!delete expansion_cfg_LSJ3
      if(associated(expansion_cfg_LSJ3%coeffs))                        &
                                     deallocate(expansion_cfg_LSJ3%csfs)
      if(associated(expansion_cfg_LSJ3%csfs)) then
         do icsf=1, expansion_cfg_LSJ3%size
            if(associated(expansion_cfg_LSJ3%csfs(icsf)%subc_cfg))     &
                      deallocate(expansion_cfg_LSJ3%csfs(icsf)%subc_cfg)
            if(associated(expansion_cfg_LSJ3%csfs(icsf)%subc))         &
                          deallocate(expansion_cfg_LSJ3%csfs(icsf)%subc)
            if(associated(expansion_cfg_LSJ3%csfs(icsf)%iM1))          &
                           deallocate(expansion_cfg_LSJ3%csfs(icsf)%iM1)
            if(associated(expansion_cfg_LSJ3%csfs(icsf)%iM2))          &
                           deallocate(expansion_cfg_LSJ3%csfs(icsf)%iM2)
            if(associated(expansion_cfg_LSJ3%csfs(icsf)%iJ))           &
                           deallocate(expansion_cfg_LSJ3%csfs(icsf)%iJ)
         end do
         deallocate(expansion_cfg_LSJ3%csfs)
      end if
      expansion_cfg_LSJ3%size=0
      expansion_cfg_LSJ3%nr_of_state=0
!
!delete expansion_cfg_LS
      if(associated(expansion_cfg_LS%coeffs))                          &
                                       deallocate(expansion_cfg_LS%csfs)
      if(associated(expansion_cfg_LS%csfs)) then
         do icsf=1, expansion_cfg_LS%size
            if(associated(expansion_cfg_LS%csfs(icsf)%subc_cfg))       &
                        deallocate(expansion_cfg_LS%csfs(icsf)%subc_cfg)
            if(associated(expansion_cfg_LS%csfs(icsf)%subc))           &
                            deallocate(expansion_cfg_LS%csfs(icsf)%subc)
            if(associated(expansion_cfg_LS%csfs(icsf)%iM1))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iM1)
            if(associated(expansion_cfg_LS%csfs(icsf)%iM2))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iM2)
            if(associated(expansion_cfg_LS%csfs(icsf)%iJ))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iJ)
         end do
         deallocate(expansion_cfg_LS%csfs)
      end if
      expansion_cfg_LS%size=0
      expansion_cfg_LS%nr_of_state=0
!
      end subroutine delete_cfg_expansions
!
!***********************************************************************
!                                                                      *
      function equivalent_LSLSJ3(csf1, csf2)                result(rez)
!                                                                      *
!     This function defines the "equivalency" of                       *
!     two csfs in LS coupling for the formation of LSJ3 csfs            *
!     (for notion of the "equivalency" see the                         *
!     description in the program)                                      *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      type(csf_LS) :: csf1, csf2
      logical :: rez
      integer::isubc
      rez = .true.
      if(csf1%nosubc /= 3 .or. csf2%nosubc /= 3) then
         write(*,*)'ERROR at subroutine equivalent_LSLSJ3: ',          &
                   'csf1%nosubc /= 3 .or. csf2%nosubc /= 3'
         write(*,*)'(you can use LSJ3 coupling with shell number 3)'
         write(*,*)'program will be terminated'
         stop
      end if
      if(csf1%nosubc.eq.csf2%nosubc) then
         do isubc=1,csf1%nosubc
            if(.not.csf1%subc_cfg(isubc)==csf2%subc_cfg(isubc)) then
               rez=.false.
               exit
            else if(.not.csf1%subc(isubc)==csf2%subc(isubc)) then
               rez=.false.
               exit
            end if
!            if(isubc /= 2) then
            if(isubc == 1) then
               if(.not.csf1%iM1(isubc)==csf2%iM1(isubc)) then
                  rez=.false.
                  exit
               else if(.not.csf1%iM2(isubc)==csf2%iM2(isubc)) then
                  rez=.false.
                  exit
               end if
            end if
         end do
      else
         rez=.false.
      end if
      end function equivalent_LSLSJ3
!
!***********************************************************************
!                                                                      *
      subroutine form_list_nomach_csfs
!                                                                      *
!     This subroutine form the list of serial numbers                  *
!     in "expansion_cfg_LS" of "nonequivalent" LS coupling csfs        *
!     (for notion of the "equivalency" see the                         *
!     description in the program)                                      *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer:: inomach_counter
      integer, dimension(:), pointer :: temp_list
      integer::icsf_LS, inew
      logical:: new_csf
!
      inomach_counter=0
      allocate(temp_list(expansion_cfg_LS%size))
!
      do icsf_LS=1,expansion_cfg_LS%size,1
         new_csf = .true.
         do inew = 1, inomach_counter, 1
            if(equivalent_LSLSJ3(expansion_cfg_LS%csfs(icsf_LS),       &
              expansion_cfg_LS%csfs(temp_list(inew)))) new_csf = .false.
         end do
         if(new_csf) then
            inomach_counter = inomach_counter + 1
            if(inomach_counter.gt.expansion_cfg_LS%size) then
               write(*,*) 'stop at subroutine define_nomach: ',        &
                  'inomach_counter.gt.expansion_cfg_LS%size'
               stop
            end if
            temp_list(inomach_counter)= icsf_LS
         end if
      end do
!
      nomach_csfs_LS%list_size = inomach_counter
!
      allocate(nomach_csfs_LS%items(nomach_csfs_LS%list_size))
!
      do icsf_LS=1, nomach_csfs_LS%list_size, 1
         nomach_csfs_LS%items(icsf_LS) = temp_list(icsf_LS)
      end do
!
      deallocate(temp_list)
!----- print down data -----------
!write(iwrite_log, *)'Nonmaching csfs_LS:'
!write(iwrite_log, *)'       Nr.   icsf_nr '
!do icsf_LS=1, nomach_csfs_LS%list_size, 1
!	 write(iwrite_log, '(4x,i3,2x,i3)') icsf_LS, nomach_csfs_LS%items(icsf_LS)
!end do !icsf_LS
!write(iwrite_log, *)'  '
!
      end subroutine form_list_nomach_csfs
!
!***********************************************************************
!                                                                      *
      subroutine form_csfs_LSJ3(itype)
!                                                                      *
!     This subroutine forms the oneconfigurational                     *
!     expansion in LSJ3 coupling "expansion_cfg_LSJ3",                 *
!     correponding to the one in LS coupling "expansion_cfg_LS"        *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
!type(cfg_Ji_lists),intent(in)::cfg_Ji_structure
      integer:: itype !defines the type of execution
                      !itype=1 - to find the number
                      !of csfs_LSJ3 only,
                      !itype.ne.1 - perform full
                      !calculation
      integer :: inr_of_csfs_LSJ3
      integer :: icsf_LS, icsf_LSJ3
      integer :: L, L_min, L_max, IS, IS_min, IS_max
      integer :: J_12, J_12_min, J_12_max, J_34, J_34_min, J_34_max
      integer :: isubc_aviable, ITTK
      integer :: inosubc, isubc
      integer :: iJ_total
      integer :: icsf_nr
      isubc_aviable = 3
      if(expansion_cfg_LS%csfs(1)%nosubc.gt.isubc_aviable) then
         write(*,*) "is available =",isubc_aviable," we have =",       &
            expansion_cfg_LS%csfs(1)%nosubc
         write(*,*) 'STOP at subroutine define_number_of_csfs_LSJ3 ',  &
            'module transform_lslsj3: cfg_Ji_structure%nr_of_subc.gt.',&
            'isubc_aviable'
         stop
      end if
      iJ_total=states%states(expansion_cfg_LS%nr_of_state)%J
      call define_number_of_csfs_LSJ3(inr_of_csfs_LSJ3)
      expansion_cfg_LSJ3%size=inr_of_csfs_LSJ3
      if(itype.ne.1) then
         allocate(expansion_cfg_LSJ3%csfs(expansion_cfg_LSJ3%size))
         allocate(expansion_cfg_LSJ3%coeffs(expansion_cfg_LSJ3%size))
         icsf_LSJ3=0
         do icsf_LS=1, nomach_csfs_ls%list_size,1
           icsf_nr = nomach_csfs_ls%items(icsf_LS)
           inosubc = expansion_cfg_LS%csfs(icsf_nr)%nosubc
           L_min = iabs(                                               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL)
           L_max =                                                     &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL
           IS_min = iabs(                                              &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS)
           IS_max =                                                    &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS
           J_12_min = iabs(                                            &
              expansion_cfg_LS%csfs(icsf_nr)%iM1(1)-                   &
              expansion_cfg_LS%csfs(icsf_nr)%iM2(1))
           J_12_max =                                                  &
              expansion_cfg_LS%csfs(icsf_nr)%iM1(1)+                   &
              expansion_cfg_LS%csfs(icsf_nr)%iM2(1)
           do L = L_min, L_max, 2
              do IS = IS_min, IS_max, 2
                 J_34_min = iabs(L - IS)
                 J_34_max = L + IS
                 do J_12 = J_12_min, J_12_max, 2
                    do J_34 = J_34_min, J_34_max, 2
                       if(ITTK(2*J_12,2*J_34,2*iJ_total) == 1) then
                          icsf_LSJ3 = icsf_LSJ3 + 1
                          if(icsf_LSJ3.gt.expansion_cfg_LSJ3%size) then
                             write(8,*)                                &
                               'stop at subroutine form_csfs_LSJ3:',   &
                               ' icsf_nr.gt.expansion_cfg_LSJ3%size'
                             stop
                          end if
                          expansion_cfg_LSJ3%csfs(icsf_LSJ3)%nosubc =  &
                                                                inosubc
                          allocate(expansion_cfg_LSJ3%csfs(icsf_LSJ3)% &
                          subc_cfg(expansion_cfg_LSJ3%csfs(icsf_LSJ3)% &
                          nosubc))
                          allocate(expansion_cfg_LSJ3%csfs(icsf_LSJ3)% &
                          subc(expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                          nosubc))
                          allocate(expansion_cfg_LSJ3%csfs(icsf_LSJ3)% &
                          iM1(expansion_cfg_LSJ3%csfs(icsf_LSJ3)%      &
                                                               nosubc))
                          allocate(expansion_cfg_LSJ3%csfs(icsf_LSJ3)% &
                          iM2(expansion_cfg_LSJ3%csfs(icsf_LSJ3)%      &
                                                                nosubc))
                          allocate(expansion_cfg_LSJ3%csfs(icsf_LSJ3)% &
                          iJ(expansion_cfg_LSJ3%csfs(icsf_LSJ3)%nosubc))
                          do isubc=1,expansion_cfg_LSJ3%csfs(          &
                                                     icsf_LSJ3)%nosubc,1
                             expansion_cfg_LSJ3%csfs(icsf_LSJ3)%       &
                             subc_cfg(isubc) = expansion_cfg_LS%csfs(  &
                             icsf_nr)%subc_cfg(isubc)
                             expansion_cfg_LSJ3%csfs(icsf_LSJ3)%       &
                             subc(isubc) = expansion_cfg_LS%csfs(      &
                             icsf_nr)%subc(isubc)
                             if(isubc == 1) then
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                               iM1(isubc) = expansion_cfg_LS%csfs(     &
                               icsf_nr)%iM1(isubc)
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                               iM2(isubc) = expansion_cfg_LS%csfs(     &
                               icsf_nr)%iM2(isubc)
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                                                        iJ(isubc)=J_12
                             else if(isubc == 2) then
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                                                         iM1(isubc)=L
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                                                        iM2(isubc)=IS
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                                                        iJ(isubc)=J_34
                             else if(isubc == 3) then
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                               iM1(isubc) = expansion_cfg_LS%csfs(     &
                               icsf_nr)%iM1(isubc)
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                               iM2(isubc) = expansion_cfg_LS%csfs(     &
                               icsf_nr)%iM2(isubc)
                               expansion_cfg_LSJ3%csfs(icsf_LSJ3)%     &
                                                      iJ(isubc)=iJ_total
                             end if
                          end do
                       end if
                    end do
                 end do
              end do
           end do
         end do
!
      end if
!
!write(*,*) '      end subroutine form_csfs_LSJ3'
!write(iwrite_log,*) '      end subroutine form_csfs_LSJ3'
!
      contains
!
!***********************************************************************
!                                                                      *
         subroutine  define_number_of_csfs_LSJ3(irez)
!                                                                      *
!     This subroutine defines the number of csfs in LSJ3 coupling       *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
         implicit none
         integer, intent(out) :: irez
         integer :: L, L_min, L_max, IS, IS_min, IS_max
         integer :: J_12, J_12_min, J_12_max, J_34, J_34_min, J_34_max
         integer :: isubc_aviable
         integer :: icsf, icsf_nr, ITTK
         isubc_aviable = 3
         if(expansion_cfg_LS%csfs(1)%nosubc .gt. isubc_aviable) then
           write(*,*) 'STOP at subroutine define_number_of_csfs_LSJ3 ',&
             'module transform_lslsJ3:cfg_Ji_structure%nr_of_subc.gt.',&
              'isubc_aviable'
           stop
         end if
         irez=0
         do icsf=1, nomach_csfs_ls%list_size,1
           icsf_nr = nomach_csfs_ls%items(icsf)
           L_min = iabs(                                               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL)
           L_max =                                                     &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iL+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iL
           IS_min = iabs(                                              &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS-               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS)
           IS_max =                                                    &
              expansion_cfg_LS%csfs(icsf_nr)%subc(2)%iS+               &
              expansion_cfg_LS%csfs(icsf_nr)%subc(3)%iS
           J_12_min = iabs(                                            &
              expansion_cfg_LS%csfs(icsf_nr)%iM1(1)-                   &
              expansion_cfg_LS%csfs(icsf_nr)%iM2(1))
           J_12_max =                                                  &
              expansion_cfg_LS%csfs(icsf_nr)%iM1(1)+                   &
              expansion_cfg_LS%csfs(icsf_nr)%iM2(1)
           do L = L_min, L_max, 2
              do IS = IS_min, IS_max, 2
                 J_34_min = iabs(L - IS)
                 J_34_max = L + IS
                 do J_12 = J_12_min, J_12_max, 2
                    do J_34 = J_34_min, J_34_max, 2
                       if(ITTK(2*J_12,2*J_34,2*iJ_total) == 1)         &
                                                       irez = irez + 1
                    end do
                 end do
              end do
           end do
         end do
         end subroutine  define_number_of_csfs_LSJ3
      end subroutine form_csfs_LSJ3 !
!***********************************************************************
!                                                                      *
      subroutine matrix_LS_LSJ3(icsf_LS,icsf_LSJ3,rez)
!                                                                      *
!     This subroutine calculates the transformation                    *
!     matrix element between two csfs  (in LS and LSJ3 couplings)       *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer,intent(in) :: icsf_LS, icsf_LSJ3
      real(kind=dp),intent(out) :: rez
      integer :: L_12, L_3, L_123, L_4, L_34, L
      integer :: IS_12, IS_3, IS_123, IS_4, IS_34, IS
      integer :: J_12, J_34, J
      integer :: nosubc
      nosubc=expansion_cfg_LS%csfs(1)%nosubc
      rez = ZERO_dp
      if(equivalent_LSLSJ3(expansion_cfg_LS%csfs(icsf_LS),             &
         expansion_cfg_LSJ3%csfs(icsf_LSJ3))) then
         L_12   = expansion_cfg_LS%csfs(icsf_LS)%iM1(1)
         L_3    = expansion_cfg_LS%csfs(icsf_LS)%subc(2)%iL
         L_123  = expansion_cfg_LS%csfs(icsf_LS)%iM1(2)
         L_4    = expansion_cfg_LS%csfs(icsf_LS)%subc(3)%iL
         L_34   = expansion_cfg_LSJ3%csfs(icsf_LSJ3)%iM1(2)
         L      = expansion_cfg_LS%csfs(icsf_LS)%iM1(3)
         IS_12  = expansion_cfg_LS%csfs(icsf_LS)%iM2(1)
         IS_3   = expansion_cfg_LS%csfs(icsf_LS)%subc(2)%iS
         IS_123 = expansion_cfg_LS%csfs(icsf_LS)%iM2(2)
         IS_4   = expansion_cfg_LS%csfs(icsf_LS)%subc(3)%iS
         IS_34  = expansion_cfg_LSJ3%csfs(icsf_LSJ3)%iM2(2)
         IS     = expansion_cfg_LS%csfs(icsf_LS)%iM2(3)
         J_12   = expansion_cfg_LSJ3%csfs(icsf_LSJ3)%iJ(1)
         J_34   = expansion_cfg_LSJ3%csfs(icsf_LSJ3)%iJ(2)
         J      = expansion_cfg_LSJ3%csfs(icsf_LSJ3)%iJ(3)
         call LSJ3PER(L_12, L_3, L_123, L_4, L_34, L,                  &
                     IS_12,IS_3,IS_123,IS_4,IS_34,IS,J_12,J_34,J,rez)
      end if
      end subroutine matrix_LS_LSJ3
!
!***********************************************************************
!                                                                      *
      subroutine dotransform_LSLSJ3
!                                                                      *
!     This subroutine calculates the weights of the                    *
!     expansions in the LSJ3 coupling                                   *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      real(kind=dp)::coeff_LSJ3,coeff_LS, melement, sum_of_state
      integer::icsf_LS,icsf_LSJ3
!
      melement=0.
      sum_of_state = 0.
      do icsf_LSJ3=1,expansion_cfg_LSJ3%size
         coeff_LSJ3 = 0.
         do icsf_LS=1, expansion_cfg_LS%size
            call matrix_LS_LSJ3(icsf_LS,icsf_LSJ3,melement)
            coeff_LS=expansion_cfg_LS%coeffs(icsf_LS)
            coeff_LSJ3 = coeff_LSJ3 + coeff_LS*melement
         end do
         if((dabs(coeff_LSJ3)-dp_coeff_precision).gt.ONE_dp) then
          write(*,*)'possible error at subroutine dotransform_LSLSJ3:',&
               ' coeff_LSJ3=',coeff_LSJ3
            write(iwrite_log,*)'possible error at subroutine ',        &
               'dotransform_LSLSJ3: coeff_LSJ3=',coeff_LSJ3
         end if
         expansion_cfg_LSJ3%coeffs(icsf_LSJ3)= coeff_LSJ3
         sum_of_state = sum_of_state + coeff_LSJ3*coeff_LSJ3
      end do
!
      if((sum_of_state-TWO_dp*dp_coeff_precision).gt.ONE_dp) then
         write(*,*)'possible error at subroutine dotransform_LSLSJ3: ',&
            'sum_of_state=',sum_of_state
         write(iwrite_log,*)'possible error at subroutine ',           &
            'dotransform_LSLSJ3: sum_of_state=',sum_of_state
      end if
!
      end subroutine dotransform_LSLSJ3
!
!***********************************************************************
!                                                                      *
      subroutine print_cfg_LSLSJ3(itype)
!                                                                      *
!     This subroutine prints the oneconfigurational                    *
!     expansions to the unit "iwrite_cfg_expansions_LSJ3"              *
!     (see module "Coupling_constants")                                *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(in) :: itype
      integer             :: icsf, isubc, j
      character(len=1)    :: CVAL
      character(len=4)    :: JVAL
!
!     LS - Coupling
!
      if(itype.gt.0) then
         write(iwrite_cfg_expansions_LSJ3,*)  &
         '-------------------------------------'
         write(iwrite_cfg_expansions_LSJ3,*)  &
         'state Nr.',expansion_cfg_LS%nr_of_state
         write(iwrite_cfg_expansions_LSJ3,'(3x,a3,a4,a9,3x,f15.8)')    &
         'J =', JVAL(states%states(expansion_cfg_LS%nr_of_state)%J), &
         ' Energy =',states%states(expansion_cfg_LS%nr_of_state)%energy
         write(iwrite_cfg_expansions_LSJ3,'(3x,a30,i2)')               &
         'expansion size (LS coupling): ', expansion_cfg_LS%size
         write(iwrite_cfg_expansions_LSJ3,*)''
         if(associated(expansion_cfg_LS%csfs)) then
            do icsf=1,expansion_cfg_LS%size
               if(associated(expansion_cfg_LS%csfs(icsf)%subc_cfg)) then
                  if(icsf ==1)write(iwrite_cfg_expansions_LSJ3,*)      &
                     'csf Nr.'
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_LSJ3,                 &
                     '(1x,i5,3x,i2,a1,"(",i1,")",6x,a6,f10.7)') icsf,  &
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%in,       &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%iN_big,   &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_LSJ3,                 &
                     '(1x,i5,3x,2(i2,a1,"(",i1,")"),6x,a6,f10.7)')icsf,&
                     (expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%in,      &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%iN_big,   &
                     j=1,2),                                           &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 3) then
                     write(iwrite_cfg_expansions_LSJ3,                 &
                     '(1x,i5,3x,3(i2,a1,"(",i1,")"),6x,a6,f10.7)')icsf,&
                     (expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%in,      &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%iN_big,   &
                     j=1,3),                                           &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else
                    STOP &
               'To many coupled shells in Coupling_transform_cfg_LSLSJ3'
                  end if
               else
                  write(iwrite_cfg_expansions_LSJ3,'(9x,a51)')   &
                  'expansion_cfg_LS%csfs(icsf)%subc_cfg NOT associated'
               end if
               if(associated(expansion_cfg_LS%csfs(icsf)%subc)  &
               .and.associated(expansion_cfg_LS%csfs(icsf)%iM1) &
               .and.associated(expansion_cfg_LS%csfs(icsf)%iM2)) then
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_LSJ3,                &
                     '(13x,i2,a1,i1)')                              &
                     expansion_cfg_LS%csfs(icsf)%subc(1)%iS+1,      &
                     CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(1)%iL),&
                     expansion_cfg_LS%csfs(icsf)%subc(1)%inr
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_LSJ3,                 &
                     '(12x,7(1x,i2,a1,i1))')                         &
                     (expansion_cfg_LS%csfs(icsf)%subc(j)%iS+1,      &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(j)%iL),&
                      expansion_cfg_LS%csfs(icsf)%subc(j)%inr,       &
                      j=1,2),                                        &
                      expansion_cfg_LS%csfs(icsf)%iM2(2)+1,          &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%iM1(2))
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 3) then
                     write(iwrite_cfg_expansions_LSJ3,                 &
                     '(12x,3(1x,i2,a1,i1),3(1x,i2,a1))')              &
                     (expansion_cfg_LS%csfs(icsf)%subc(j)%iS+1,       &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(j)%iL), &
                      expansion_cfg_LS%csfs(icsf)%subc(j)%inr,        &
                      j=1,3),                                         &
                      (expansion_cfg_LS%csfs(icsf)%iM2(j)+1,          &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%iM1(j)),j=2,3)
                  end if
               else
                   write(iwrite_cfg_expansions_LSJ3,'(9x,a63)') &
       'expansion_cfg_LS%csfs(icsf)%subc (or iM1 or iM2) NOT associated'
               end if
               write(iwrite_cfg_expansions_LSJ3,*)' '
            end do
         else
            write(iwrite_cfg_expansions_LSJ3,*) &
            'expansion_cfg_LS%csfs NOT associated'
         end if
      end if
!
!     LSJ3 - Coupling
!
      if(itype.gt.1) then
         write(iwrite_cfg_expansions_LSJ3,*) &
         '-------------------------------------'
         write(iwrite_cfg_expansions_LSJ3,*) &
         'state Nr.',expansion_cfg_LSJ3%nr_of_state
         write(iwrite_cfg_expansions_LSJ3,'(3x,a3,a4,a9,3x,f15.8)')    &
         'J =', JVAL(states%states(expansion_cfg_LSJ3%nr_of_state)%J), &
        ' Energy =',states%states(expansion_cfg_LSJ3%nr_of_state)%energy
         write(iwrite_cfg_expansions_LSJ3,'(3x,a32,i2)')               &
         'expansion size (LSJ3 coupling): ', expansion_cfg_LSJ3%size
         write(iwrite_cfg_expansions_LSJ3,*)''
         if(associated(expansion_cfg_LSJ3%csfs)) then
            do icsf=1,expansion_cfg_LSJ3%size
               if(associated(expansion_cfg_LSJ3%csfs(icsf)%subc_cfg)) then
!                  if(dabs(expansion_cfg_LSJ3%coeffs(icsf)) <=          &
!                                              dp_coeff_precision) cycle
                  if (expansion_cfg_LS%csfs(icsf)%nosubc == 3) then
                     write(iwrite_cfg_expansions_LSJ3,                 &
                     '(1x,i5,3x,3(i2,a1,"(",i1,")"),6x,a6,f10.7)')icsf,&
                     (expansion_cfg_LSJ3%csfs(icsf)%subc_cfg(j)%in,    &
                  CVAL(1,expansion_cfg_LSJ3%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_LSJ3%csfs(icsf)%subc_cfg(j)%iN_big, &
                     j=1,3),                                           &
                     'coeff:',expansion_cfg_LSJ3%coeffs(icsf)
                  end if
               else
                  write(iwrite_cfg_expansions_LSJ3,'(9x,a51)')         &
                 'expansion_cfg_LSJ3%csfs(icsf)%subc_cfg NOT associated'
               end if
               if(associated(expansion_cfg_LSJ3%csfs(icsf)%subc)     &
                  .and.associated(expansion_cfg_LSJ3%csfs(icsf)%iM1) &
                  .and.associated(expansion_cfg_LSJ3%csfs(icsf)%iM2)) then
                  if (expansion_cfg_LS%csfs(icsf)%nosubc == 3) then
                     write(iwrite_cfg_expansions_LSJ3,                 &
                     '(12x,i2,a1,i1,1x," (",i2,a1,i1,1x,i2,a1,i1,")",  &
                     i2,a1,1x," [",a4,","a4," ]")')                    &
                     (expansion_cfg_LSJ3%csfs(icsf)%subc(j)%iS+1,      &
                     CVAL(2,expansion_cfg_LSJ3%csfs(icsf)%subc(j)%iL), &
                     expansion_cfg_LSJ3%csfs(icsf)%subc(j)%inr,        &
                     j=1,3),                                           &
                     expansion_cfg_LSJ3%csfs(icsf)%iM2(2)+1,           &
                     CVAL(2,expansion_cfg_LSJ3%csfs(icsf)%iM1(2)),     &
                     JVAL(expansion_cfg_LSJ3%csfs(icsf)%iJ(1)),        &
                     JVAL(expansion_cfg_LSJ3%csfs(icsf)%iJ(2))
                  end if
               else
                  write(iwrite_cfg_expansions_LSJ3,'(9x,a63)')         &
                     'expansion_cfg_LSJ3%csfs(icsf)%subc (',           &
                     'or iM1 or iM2) NOT associated'
               end if
               write(iwrite_cfg_expansions_LSJ3,*)' '
            end do
         else
            write(iwrite_cfg_expansions_LSJ3,*) &
            'expansion_cfg_LSJ3%csfs NOT associated'
         end if
            write(iwrite_cfg_expansions_LSJ3,*) &
            '-------------------------------------'
      end if
      end subroutine print_cfg_LSLSJ3
!
      end module Coupling_transform_cfg_LSLSJ3


module GwfHfbModule

  use KindModule, only: DP, I4B
  use Xt3dModule,             only: Xt3dType
  use NumericalPackageModule, only: NumericalPackageType
  use BlockParserModule,      only: BlockParserType
  use BaseDisModule,          only: DisBaseType

  implicit none

  private
  public :: GwfHfbType
  public :: hfb_cr

  type, extends(NumericalPackageType) :: GwfHfbType
    integer(I4B), pointer                        :: maxhfb     => null()   !max number of hfb's
    integer(I4B), pointer                        :: nhfb       => null()   !number of hfb's
    integer(I4B), dimension(:), pointer          :: noden      => null()   !first cell
    integer(I4B), dimension(:), pointer          :: nodem      => null()   !second cell
    integer(I4B), dimension(:), pointer          :: idxloc     => null()   !position in model ja
    real(DP), dimension(:), pointer              :: hydchr     => null()   !hydraulic characteristic of the barrier
    real(DP), dimension(:), pointer              :: csatsav    => null()   !value of condsat prior to hfb modification
    real(DP), dimension(:), pointer              :: condsav    => null()   !saved conductance of combined npf and hfb
    type(Xt3dType), pointer                      :: xt3d       => null()   !pointer to xt3d object
    !
    integer(I4B), pointer, dimension(:)          :: ibound     => null()   !pointer to model ibound
    integer(I4B), pointer, dimension(:)          :: icelltype  => null()   !pointer to model icelltype
    integer(I4B), pointer, dimension(:)          :: ihc        => null()   !pointer to model ihc
    integer(I4B), pointer, dimension(:)          :: ia         => null()   !pointer to model ia
    integer(I4B), pointer, dimension(:)          :: ja         => null()   !pointer to model ja
    integer(I4B), pointer, dimension(:)          :: jas        => null()   !pointer to model jas
    integer(I4B), pointer, dimension(:)          :: isym       => null()   !pointer to model isym
    real(DP), pointer, dimension(:)              :: condsat    => null()   !pointer to model condsat
    real(DP), pointer, dimension(:)              :: top        => null()   !pointer to model top
    real(DP), pointer, dimension(:)              :: bot        => null()   !pointer to model bot
    real(DP), pointer, dimension(:)              :: hwva       => null()   !pointer to model hwva
  contains
    procedure :: hfb_ar
    procedure :: hfb_rp
    procedure :: hfb_fc
    procedure :: hfb_flowja
    procedure :: hfb_da
    procedure          :: allocate_scalars
    procedure, private :: allocate_arrays
    procedure, private :: read_options
    procedure, private :: read_dimensions
    procedure, private :: read_data
    procedure, private :: check_data
    procedure, private :: condsat_reset
    procedure, private :: condsat_modify
  end type GwfHfbType

  contains

  subroutine hfb_cr(hfbobj, name_model, inunit, iout)
! ******************************************************************************
! hfb_cr -- Create a new hfb object
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    type(GwfHfbType), pointer :: hfbobj
    character(len=*), intent(in) :: name_model
    integer(I4B), intent(in) :: inunit
    integer(I4B), intent(in) :: iout
! ------------------------------------------------------------------------------
    !
    ! -- Create the object
    allocate(hfbobj)
    !
    ! -- create name and origin
    call hfbobj%set_names(1, name_model, 'HFB', 'HFB')
    !
    ! -- Allocate scalars
    call hfbobj%allocate_scalars()
    !
    ! -- Save unit numbers
    hfbobj%inunit = inunit
    hfbobj%iout = iout
    !
    ! -- Initialize block parser
    call hfbobj%parser%Initialize(hfbobj%inunit, hfbobj%iout)
    !
    ! -- Return
    return
  end subroutine hfb_cr

  subroutine hfb_ar(this, ibound, xt3d, dis)
! ******************************************************************************
! hfb_ar -- Allocate and read
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_setptr
    ! -- dummy
    class(GwfHfbType) :: this
    integer(I4B), dimension(:), pointer :: ibound
    type(Xt3dType), pointer :: xt3d
    class(DisBaseType), pointer, intent(inout) :: dis
    ! -- formats
    character(len=*), parameter :: fmtheader =                                 &
      "(1x, /1x, 'HFB -- HORIZONTAL FLOW BARRIER PACKAGE, VERSION 8, ',        &
        '4/24/2015 INPUT READ FROM UNIT ', i4, //)"
! ------------------------------------------------------------------------------
    !
    ! -- Print a message identifying the node property flow package.
    write(this%iout, fmtheader) this%inunit
    !
    ! -- Set pointers
    this%dis => dis
    this%ibound => ibound
    this%xt3d => xt3d
    call mem_setptr(this%icelltype, 'ICELLTYPE', trim(adjustl(this%name_model))//' NPF')
    call mem_setptr(this%ihc, 'IHC', trim(adjustl(this%name_model))//' CON')
    call mem_setptr(this%ia, 'IA', trim(adjustl(this%name_model))//' CON')
    call mem_setptr(this%ja, 'JA', trim(adjustl(this%name_model))//' CON')
    call mem_setptr(this%jas, 'JAS', trim(adjustl(this%name_model))//' CON')
    call mem_setptr(this%isym, 'ISYM', trim(adjustl(this%name_model))//' CON')
    call mem_setptr(this%condsat, 'CONDSAT', trim(adjustl(this%name_model))//' NPF')
    call mem_setptr(this%top, 'TOP', trim(adjustl(this%name_model))//' DIS')
    call mem_setptr(this%bot, 'BOT', trim(adjustl(this%name_model))//' DIS')
    call mem_setptr(this%hwva, 'HWVA', trim(adjustl(this%name_model))//' CON')
    !
    call this%read_options()
    call this%read_dimensions()
    call this%allocate_arrays()
    !
    ! -- return
    return
  end subroutine hfb_ar

  subroutine hfb_rp(this)
! ******************************************************************************
! hfb_rp -- Check for new hfb stress period data
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LINELENGTH
    use SimModule, only: ustop, store_error, count_errors, store_error_unit
    use TdisModule, only: kper, nper
    ! -- dummy
    class(GwfHfbType) :: this
    ! -- local
    character(len=LINELENGTH) :: line, errmsg
    integer(I4B) :: ierr
    logical :: isfound
    ! -- formats
    character(len=*),parameter :: fmtblkerr = &
      "('Error.  Looking for BEGIN PERIOD iper.  Found ', a, ' instead.')"
    character(len=*),parameter :: fmtlsp = &
      "(1X,/1X,'REUSING ',A,'S FROM LAST STRESS PERIOD')"
! ------------------------------------------------------------------------------
    !
    ! -- Set ionper to the stress period number for which a new block of data
    !    will be read.
    if (this%ionper < kper) then
      !
      ! -- get period block
      call this%parser%GetBlock('PERIOD', isfound, ierr, &
                                supportOpenClose=.true.)
      if(isfound) then
        !
        ! -- read ionper and check for increasing period numbers
        call this%read_check_ionper()
      else
        !
        ! -- PERIOD block not found
        if (ierr < 0) then
          ! -- End of file found; data applies for remainder of simulation.
          this%ionper = nper + 1
        else
          ! -- Found invalid block
          write(errmsg, fmtblkerr) adjustl(trim(line))
          call store_error(errmsg)
          call this%parser%StoreErrorUnit()
          call ustop()
        end if
      endif
    end if
    !
    if(this%ionper == kper) then
      call this%condsat_reset()
      call this%read_data()
      call this%condsat_modify()
    else
      write(this%iout,fmtlsp) 'HFB'
    endif
    !
    ! -- return
    return
  end subroutine hfb_rp

  subroutine hfb_fc(this, kiter, nodes, nja, njasln, amat, idxglo, rhs, hnew)
! ******************************************************************************
! hfb_fc -- Fill amatsln for the following conditions:
!   1.  Not Newton, and
!   2.  Cell type n is convertible or cell type m is convertible
!  OR
!   3.  XT3D
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DHALF, DZERO
    ! -- dummy
    class(GwfHfbType) :: this
    integer(I4B) :: kiter
    integer(I4B),intent(in) :: nodes
    integer(I4B),intent(in) :: nja
    integer(I4B),intent(in) :: njasln
    real(DP),dimension(njasln),intent(inout) :: amat
    integer(I4B),intent(in),dimension(nja) :: idxglo
    real(DP),intent(inout),dimension(nodes) :: rhs
    real(DP),intent(inout),dimension(nodes) :: hnew
    ! -- local
    integer(I4B) :: ihfb, n, m
    integer(I4B) :: ipos
    integer(I4B) :: idiag, isymcon
    integer(I4B) :: ixt3d
    real(DP) :: cond, condhfb, aterm
    real(DP) :: fawidth, faheight
    real(DP) :: topn, topm, botn, botm
! ------------------------------------------------------------------------------
    !
    if (associated(this%xt3d%ixt3d)) then
      ixt3d = this%xt3d%ixt3d
    else
      ixt3d = 0
    end if
    !
    if(ixt3d > 0) then
      !
      do ihfb = 1, this%nhfb
        n = min(this%noden(ihfb), this%nodem(ihfb))
        m = max(this%noden(ihfb), this%nodem(ihfb))
        ! -- Skip if either cell is inactive.
        if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
  !!!      if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then
        ! -- Compute scale factor for hfb correction
        if(this%hydchr(ihfb) > DZERO) then
          if(this%inewton == 0) then
            ipos = this%idxloc(ihfb)
            topn = this%top(n)
            topm = this%top(m)
            botn = this%bot(n)
            botm = this%bot(m)
            if(this%icelltype(n) == 1) then
              if(hnew(n) < topn) topn = hnew(n)
            endif
            if(this%icelltype(m) == 1) then
              if(hnew(m) < topm) topm = hnew(m)
            endif
            if(this%ihc(this%jas(ipos)) == 2) then
              faheight = min(topn, topm) - max(botn, botm)
            else
              faheight = DHALF * ( (topn - botn) + (topm - botm) )
            endif
            fawidth = this%hwva(this%jas(ipos))
            condhfb = this%hydchr(ihfb) * fawidth * faheight
          else
            condhfb = this%hydchr(ihfb)
          end if
        else
          condhfb = this%hydchr(ihfb)
        endif
        ! -- Make hfb corrections for xt3d
        call this%xt3d%xt3d_fhfb(kiter, nodes, nja, njasln, amat, idxglo,      &
          rhs, hnew, n, m, condhfb)
      end do
      !
    else
      !
      ! -- For Newton, the effect of the barrier is included in condsat.
      if(this%inewton == 0) then
        do ihfb = 1, this%nhfb
          ipos = this%idxloc(ihfb)
          aterm = amat(idxglo(ipos))
          n = this%noden(ihfb)
          m = this%nodem(ihfb)
          if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
          if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then
            !
            ! -- Calculate hfb conductance
            topn = this%top(n)
            topm = this%top(m)
            botn = this%bot(n)
            botm = this%bot(m)
            if(this%icelltype(n) == 1) then
              if(hnew(n) < topn) topn = hnew(n)
            endif
            if(this%icelltype(m) == 1) then
              if(hnew(m) < topm) topm = hnew(m)
            endif
            if(this%ihc(this%jas(ipos)) == 2) then
              faheight = min(topn, topm) - max(botn, botm)
            else
              faheight = DHALF * ( (topn - botn) + (topm - botm) )
            endif
            if(this%hydchr(ihfb) > DZERO) then
              fawidth = this%hwva(this%jas(ipos))
              condhfb = this%hydchr(ihfb) * fawidth * faheight
              cond = aterm * condhfb / (aterm + condhfb)
            else
              cond = - aterm * this%hydchr(ihfb)
            endif
            !
            ! -- Save cond for budget calculation
            this%condsav(ihfb) = cond
            !
            ! -- Fill row n diag and off diag
            idiag = this%ia(n)
            amat(idxglo(idiag)) = amat(idxglo(idiag)) + aterm - cond
            amat(idxglo(ipos)) = cond
            !
            ! -- Fill row m diag and off diag
            isymcon = this%isym(ipos)
            idiag = this%ia(m)
            amat(idxglo(idiag)) = amat(idxglo(idiag)) + aterm - cond
            amat(idxglo(isymcon)) = cond
            !
          endif
        enddo
      endif
      !
    endif
    !
    ! -- return
    return
  end subroutine hfb_fc

  subroutine hfb_flowja(this, nodes, nja, hnew, flowja)
! ******************************************************************************
! hfb_flowja -- flowja will automatically include the effects of the hfb
!   for confined and newton cases when xt3d is not used.  This method
!   recalculates flowja for the other cases.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DHALF, DZERO
    ! -- dummy
    class(GwfHfbType) :: this
    integer(I4B),intent(in) :: nodes
    integer(I4B),intent(in) :: nja
    real(DP),intent(inout),dimension(nodes) :: hnew
    real(DP),intent(inout),dimension(nja) :: flowja
    ! -- local
    integer(I4B) :: ihfb, n, m
    integer(I4B) :: ipos
    real(DP) :: qnm
    real(DP) :: cond
    integer(I4B) :: ixt3d
    real(DP) :: condhfb
    real(DP) :: fawidth, faheight
    real(DP) :: topn, topm, botn, botm
! ------------------------------------------------------------------------------
!
    if (associated(this%xt3d%ixt3d)) then
      ixt3d = this%xt3d%ixt3d
    else
      ixt3d = 0
    end if
    !
    if(ixt3d > 0) then
      !
      do ihfb = 1, this%nhfb
        n = min(this%noden(ihfb), this%nodem(ihfb))
        m = max(this%noden(ihfb), this%nodem(ihfb))
        ! -- Skip if either cell is inactive.
        if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
  !!!      if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then
        ! -- Compute scale factor for hfb correction
        if(this%hydchr(ihfb) > DZERO) then
          if(this%inewton == 0) then
            ipos = this%idxloc(ihfb)
            topn = this%top(n)
            topm = this%top(m)
            botn = this%bot(n)
            botm = this%bot(m)
            if(this%icelltype(n) == 1) then
              if(hnew(n) < topn) topn = hnew(n)
            endif
            if(this%icelltype(m) == 1) then
              if(hnew(m) < topm) topm = hnew(m)
            endif
            if(this%ihc(this%jas(ipos)) == 2) then
              faheight = min(topn, topm) - max(botn, botm)
            else
              faheight = DHALF * ( (topn - botn) + (topm - botm) )
            endif
            fawidth = this%hwva(this%jas(ipos))
            condhfb = this%hydchr(ihfb) * fawidth * faheight
          else
            condhfb = this%hydchr(ihfb)
          end if
        else
          condhfb = this%hydchr(ihfb)
        endif
        ! -- Make hfb corrections for xt3d
        call this%xt3d%xt3d_flowjahfb(nodes, n, m, nja, hnew, flowja, condhfb)
      end do
      !
    else
      !
      ! -- Recalculate flowja for non-newton unconfined.
      if(this%inewton == 0) then
        do ihfb = 1, this%nhfb
          n = this%noden(ihfb)
          m = this%nodem(ihfb)
          if(this%ibound(n) == 0 .or. this%ibound(m) == 0) cycle
          if(this%icelltype(n) == 1 .or. this%icelltype(m) == 1) then
            ipos = this%dis%con%getjaindex(n, m)
            cond = this%condsav(ihfb)
            qnm = cond * (hnew(m) - hnew(n))
            flowja(ipos) = qnm
            ipos = this%dis%con%getjaindex(m, n)
            flowja(ipos) = -qnm
            !
          endif
        enddo
      endif
      !
    end if
    !
    ! -- return
    return
  end subroutine hfb_flowja

  subroutine hfb_da(this)
! ******************************************************************************
! hfb_da -- Deallocate
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_deallocate
    ! -- dummy
    class(GwfHfbType) :: this
! ------------------------------------------------------------------------------
    !
    ! -- Strings
    !
    ! -- Scalars
    call mem_deallocate(this%maxhfb)
    call mem_deallocate(this%nhfb)
    !
    ! -- Arrays
    if (this%inunit > 0) then
      call mem_deallocate(this%noden)
      call mem_deallocate(this%nodem)
      call mem_deallocate(this%hydchr)
      call mem_deallocate(this%idxloc)
      call mem_deallocate(this%csatsav)
      call mem_deallocate(this%condsav)
    endif
    !
    ! -- deallocate parent
    call this%NumericalPackageType%da()
    !
    ! -- nullify pointers
    this%xt3d       => null()
    this%inewton    => null()
    this%ibound     => null()
    this%icelltype  => null()
    this%ihc        => null()
    this%ia         => null()
    this%ja         => null()
    this%jas        => null()
    this%isym       => null()
    this%condsat    => null()
    this%top        => null()
    this%bot        => null()
    this%hwva       => null()
    !
    ! -- return
    return
  end subroutine hfb_da

  subroutine allocate_scalars(this)
! ******************************************************************************
! allocate_scalars -- Allocate scalars
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_allocate
    ! -- dummy
    class(GwfHfbType) :: this
! ------------------------------------------------------------------------------
    !
    ! -- allocate scalars in NumericalPackageType
    call this%NumericalPackageType%allocate_scalars()
    !
    ! -- allocate scalars
    call mem_allocate(this%maxhfb, 'MAXHFB', this%origin)
    call mem_allocate(this%nhfb, 'NHFB', this%origin)
    !
    ! -- initialize
    this%maxhfb = 0
    this%nhfb = 0
    !
    ! -- return
    return
  end subroutine allocate_scalars

  subroutine allocate_arrays(this)
! ******************************************************************************
! allocate_arrays -- Allocate arrays
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use MemoryManagerModule, only: mem_allocate
    ! -- dummy
    class(GwfHfbType) :: this
    ! -- local
    integer(I4B) :: ihfb
! ------------------------------------------------------------------------------
    !
    call mem_allocate(this%noden, this%maxhfb, 'NODEN', this%origin)
    call mem_allocate(this%nodem, this%maxhfb, 'NODEM', this%origin)
    call mem_allocate(this%hydchr, this%maxhfb, 'HYDCHR', this%origin)
    call mem_allocate(this%idxloc, this%maxhfb, 'IDXLOC', this%origin)
    call mem_allocate(this%csatsav, this%maxhfb, 'CSATSAV', this%origin)
    call mem_allocate(this%condsav, this%maxhfb, 'CONDSAV', this%origin)
    !
    ! -- initialize idxloc to 0
    do ihfb = 1, this%maxhfb
      this%idxloc(ihfb) = 0
    enddo
    !
    ! -- return
    return
  end subroutine allocate_arrays

  subroutine read_options(this)
! ******************************************************************************
! read_options -- read a hfb options block
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LINELENGTH
    use SimModule, only: ustop, store_error, store_error_unit
    ! -- dummy
    class(GwfHfbType) :: this
    ! -- local
    character(len=LINELENGTH) :: errmsg, keyword
    integer(I4B) :: ierr
    logical :: isfound, endOfBlock
! ------------------------------------------------------------------------------
    !
    ! -- get options block
    call this%parser%GetBlock('OPTIONS', isfound, ierr, blockRequired=.false.)
    !
    ! -- parse options block if detected
    if (isfound) then
      write(this%iout,'(1x,a)')'PROCESSING HFB OPTIONS'
      do
        call this%parser%GetNextLine(endOfBlock)
        if (endOfBlock) exit
        call this%parser%GetStringCaps(keyword)
        select case (keyword)
          case ('PRINT_INPUT')
            this%iprpak = 1
            write(this%iout,'(4x,a)') &
              'THE LIST OF HFBS WILL BE PRINTED.'
          case default
            write(errmsg,'(4x,a,a)')'****ERROR. UNKNOWN HFB OPTION: ',         &
                                     trim(keyword)
            call store_error(errmsg)
            call this%parser%StoreErrorUnit()
            call ustop()
        end select
      end do
      write(this%iout,'(1x,a)')'END OF HFB OPTIONS'
    end if
    !
    ! -- return
    return
  end subroutine read_options

  subroutine read_dimensions(this)
! ******************************************************************************
! read_dimensions -- Read the dimensions for this package
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use ConstantsModule, only: LINELENGTH
    use SimModule, only: ustop, store_error, store_error_unit
    ! -- dummy
    class(GwfHfbType),intent(inout) :: this
    ! -- local
    character(len=LINELENGTH) :: errmsg, keyword
    integer(I4B) :: ierr
    logical :: isfound, endOfBlock
    ! -- format
! ------------------------------------------------------------------------------
    !
    ! -- get dimensions block
    call this%parser%GetBlock('DIMENSIONS', isfound, ierr)
    !
    ! -- parse dimensions block if detected
    if (isfound) then
      write(this%iout,'(/1x,a)')'PROCESSING HFB DIMENSIONS'
      do
        call this%parser%GetNextLine(endOfBlock)
        if (endOfBlock) exit
        call this%parser%GetStringCaps(keyword)
        select case (keyword)
          case ('MAXHFB')
            this%maxhfb = this%parser%GetInteger()
            write(this%iout,'(4x,a,i7)') 'MAXHFB = ', this%maxhfb
          case default
            write(errmsg,'(4x,a,a)') &
              '****ERROR. UNKNOWN HFB DIMENSION: ', &
                                     trim(keyword)
            call store_error(errmsg)
            call this%parser%StoreErrorUnit()
            call ustop()
        end select
      end do
      !
      write(this%iout,'(1x,a)')'END OF HFB DIMENSIONS'
    else
      call store_error('ERROR.  REQUIRED DIMENSIONS BLOCK NOT FOUND.')
      call this%parser%StoreErrorUnit()
      call ustop()
    end if
    !
    ! -- verify dimensions were set
    if(this%maxhfb <= 0) then
      write(errmsg, '(1x,a)') &
        'ERROR.  MAXHFB MUST BE SPECIFIED WITH VALUE GREATER THAN ZERO.'
      call store_error(errmsg)
      call this%parser%StoreErrorUnit()
      call ustop()
    endif
    !
    ! -- return
    return
  end subroutine read_dimensions

  subroutine read_data(this)
! ******************************************************************************
! read_data -- Read hfb period block
!   Data are in form of L, IROW1, ICOL1, IROW2, ICOL2, HYDCHR
!   or for unstructured
!                       N1, N2, HYDCHR
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LINELENGTH
    use SimModule, only: ustop, store_error, count_errors, store_error_unit
    use TdisModule, only: kper
    ! -- dummy
    class(GwfHfbType) :: this
    ! -- local
    character(len=LINELENGTH) :: nodenstr, nodemstr, cellidm, cellidn
    integer(I4B) :: ihfb, nerr
    logical :: endOfBlock
    ! -- formats
    character(len=*), parameter :: fmthfb = "(i10, 2a10, 1(1pg15.6))"
! ------------------------------------------------------------------------------
    !
    write(this%iout,'(//,1x,a)')'READING HFB DATA'
    if(this%iprpak > 0) then
      write(this%iout, '(3a10, 1a15)') 'HFB NUM', 'CELL1', 'CELL2',            &
                                       'HYDCHR'
    endif
    !
    ihfb = 0
    this%nhfb = 0
    readloop: do
      !
      ! -- Check for END of block
      call this%parser%GetNextLine(endOfBlock)
      if (endOfBlock) exit
      !
      ! -- Reset lloc and read noden, nodem, and hydchr
      ihfb = ihfb + 1
      if(ihfb > this%maxhfb) then
        call store_error('MAXHFB not large enough.')
        call this%parser%StoreErrorUnit()
        call ustop()
      endif
      call this%parser%GetCellid(this%dis%ndim, cellidn)
      this%noden(ihfb) = this%dis%noder_from_cellid(cellidn, &
                                       this%parser%iuactive, this%iout)
      call this%parser%GetCellid(this%dis%ndim, cellidm)
      this%nodem(ihfb) = this%dis%noder_from_cellid(cellidm, &
                                       this%parser%iuactive, this%iout)
      this%hydchr(ihfb) = this%parser%GetDouble()
      !
      ! -- Print input if requested
      if(this%iprpak /= 0) then
        call this%dis%noder_to_string(this%noden(ihfb), nodenstr)
        call this%dis%noder_to_string(this%nodem(ihfb), nodemstr)
        write(this%iout, fmthfb) ihfb, trim(adjustl(nodenstr)),                &
                                 trim(adjustl(nodemstr)), this%hydchr(ihfb)
      endif
      !
      this%nhfb = ihfb
    enddo readloop
    !
    ! -- Stop if errors
    nerr = count_errors()
    if(nerr > 0) then
      call store_error('Errors encountered in HFB input file.')
      call this%parser%StoreErrorUnit()
      call ustop()
    endif
    !
    write(this%iout, '(3x,i0,a,i0)') this%nhfb,                                &
          ' HFBs READ FOR STRESS PERIOD ', kper
    call this%check_data()
    write(this%iout, '(1x,a)')'END READING HFB DATA'
    !
    ! -- return
    return
  end subroutine read_data

  subroutine check_data(this)
! ******************************************************************************
! check_data -- Check for hfb's between two unconnected cells and write a
!   warning.  Store ipos in idxloc.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: LINELENGTH
    use SimModule, only: store_error, count_errors, ustop, store_error_unit
    ! -- dummy
    class(GwfHfbType) :: this
    ! -- local
    integer(I4B) :: ihfb, n, m
    integer(I4B) :: ipos
    character(len=LINELENGTH) :: nodenstr, nodemstr
    character(len=LINELENGTH) :: errmsg
    logical :: found
    ! -- formats
    character(len=*), parameter :: fmterr = "(1x, 'Error.  HFB no. ',i0, &
      ' is between two unconnected cells: ', a, ' and ', a)"
! ------------------------------------------------------------------------------
    !
    do ihfb = 1, this%nhfb
      n = this%noden(ihfb)
      m = this%nodem(ihfb)
      found = .false.
      do ipos = this%ia(n)+1, this%ia(n+1)-1
        if(m == this%ja(ipos)) then
          found = .true.
          this%idxloc(ihfb) = ipos
          exit
        endif
      enddo
      if(.not. found) then
        call this%dis%noder_to_string(n, nodenstr)
        call this%dis%noder_to_string(m, nodemstr)
        write(errmsg, fmterr) ihfb, trim(adjustl(nodenstr)),                   &
                                  trim(adjustl(nodemstr))
        call store_error(errmsg)
      endif
    enddo
    !
    ! -- Stop if errors detected
    if(count_errors() > 0) then
      call store_error_unit(this%inunit)
      call ustop()
    endif
    !
    ! -- return
    return
  end subroutine check_data

  subroutine condsat_reset(this)
! ******************************************************************************
! condsat_reset -- Reset condsat to its value prior to being modified by hfb's
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    ! -- dummy
    class(GwfHfbType) :: this
    ! -- local
    integer(I4B) :: ihfb
    integer(I4B) :: ipos
! ------------------------------------------------------------------------------
    !
    do ihfb = 1, this%nhfb
      ipos = this%idxloc(ihfb)
      this%condsat(this%jas(ipos)) = this%csatsav(ihfb)
    enddo
    !
    ! -- return
    return
  end subroutine condsat_reset

  subroutine condsat_modify(this)
! ******************************************************************************
! condsat_modify -- Modify condsat for the following conditions:
!   1.  If Newton is active
!   2.  If icelltype for n and icelltype for m is 0
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- modules
    use ConstantsModule, only: DHALF, DZERO
    ! -- dummy
    class(GwfHfbType) :: this
    ! -- local
    integer(I4B) :: ihfb, n, m
    integer(I4B) :: ipos
    real(DP) :: cond, condhfb
    real(DP) :: fawidth, faheight
    real(DP) :: topn, topm, botn, botm
! ------------------------------------------------------------------------------
    !
    do ihfb = 1, this%nhfb
      ipos = this%idxloc(ihfb)
      cond = this%condsat(this%jas(ipos))
      this%csatsav(ihfb) = cond
      n = this%noden(ihfb)
      m = this%nodem(ihfb)
      if(this%inewton == 1 .or. &
         (this%icelltype(n) == 0 .and. this%icelltype(m) == 0) ) then
        !
        ! -- Calculate hfb conductance
        topn = this%top(n)
        topm = this%top(m)
        botn = this%bot(n)
        botm = this%bot(m)
        if(this%ihc(this%jas(ipos)) == 2) then
          faheight = min(topn, topm) - max(botn, botm)
        else
          faheight = DHALF * ( (topn - botn) + (topm - botm) )
        endif
        if(this%hydchr(ihfb) > DZERO) then
          fawidth = this%hwva(this%jas(ipos))
          condhfb = this%hydchr(ihfb) * fawidth * faheight
          cond = cond * condhfb / (cond + condhfb)
        else
          cond = - cond * this%hydchr(ihfb)
        endif
        this%condsat(this%jas(ipos)) = cond
      endif
    enddo
    !
    ! -- return
    return
  end subroutine condsat_modify

end module GwfHfbModule