!***********************************************************************
! This file is part of OpenMolcas.                                     *
!                                                                      *
! OpenMolcas is free software; you can redistribute it and/or modify   *
! it under the terms of the GNU Lesser General Public License, v. 2.1. *
! OpenMolcas is distributed in the hope that it will be useful, but it *
! is provided "as is" and without any express or implied warranties.   *
! For more details see the full text of the license in the file        *
! LICENSE or in <http://www.gnu.org/licenses/>.                        *
!                                                                      *
! Copyright (C) 2009, Bingbing Suo                                     *
!***********************************************************************
! Jul. 3, 2009 -BSUO- External space loops

!subroutine dd_ext_plpmode(ilnodesm,irnodesm)
!
!use gugaci_global, only: logic_g13, logic_g1415, logic_g36a, logic_g36b
!use Definitions, only: iwp
!
!implicit none
!integer(kind=iwp), intent(in) :: ilnodesm, irnodesm
!
!logic_g36a = .false.
!logic_g36b = .false.
!logic_g1415 = .false.
!logic_g13 = .false.
!if (ilnodesm < irnodesm) then
!  logic_g36a = .true.
!else if (ilnodesm == irnodesm) then
!  logic_g36a = .true.
!  logic_g36b = .true.
!  logic_g1415 = .true.
!  logic_g13 = .true.
!else
!  logic_g36b = .true.
!end if
!
!end subroutine dd_ext_plpmode

subroutine external_space_plpmode_value_dv()

use gugaci_global, only: w0g25, w0g25a, w1g25a

use Constants, only: One

implicit none

! sd   lpmode_value
w0g25 = -One
w0g25a = -One
w1g25a = -One

end subroutine external_space_plpmode_value_dv

subroutine external_space_plpmode_value_vd()

use gugaci_global, only: v_sqtwo, w0g25, w0g25a, w1g25a

implicit none

! sd   lpmode_value
w0g25 = -v_sqtwo
w0g25a = -v_sqtwo
w1g25a = -v_sqtwo

end subroutine external_space_plpmode_value_vd

subroutine g12_t_diffsym(isma,ismb,ismc)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, ngw2, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismc
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, ip2cd, ip3smabc, ipos_intbasetmp, iposint, nsma, num_smab

if (isma < ismb) then
  ip3smabc = isma+jp2(ismb)+jp3(ismc)
  ip2cd = m_jc+(m_jd-1)*nlsm_ext(ismc)   !severe_new_error_1206
  num_smab = nlsm_ext(isma)*nlsm_ext(ismb)  !need checking
  ipos_intbasetmp = ip4_abcd_ext_base(ip3smabc)+(ip2cd-1)*num_smab*3
  ibsta = ibsm_ext(ismb)
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
  iposint = ipos_intbasetmp
  do ib=ibsta,ibend
    do ia=iasta,iaend
      value_lpext(ilwei) = vint_ci(iposint+1)-vint_ci(iposint+2)
      ilwei = ilwei+1
      iposint = iposint+3
    end do
  end do
else
  ip3smabc = isma+jp2(ismb)+jp3(ismc)
  ip2cd = m_jc+NGW2(m_jd)
  nsma = nlsm_ext(isma)
  num_smab = nsma*(nsma-1)/2   !need checking
  ipos_intbasetmp = ip4_abcd_ext_base(ip3smabc)+(ip2cd-1)*num_smab*3
  ibsta = ibsm_ext(ismb)+1
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
  iposint = ipos_intbasetmp
  do ib=ibsta,ibend
    do ia=iasta,ib-1
      value_lpext(ilwei) = vint_ci(iposint+1)-vint_ci(iposint+2)
      ilwei = ilwei+1
      iposint = iposint+3
    end do
  end do
end if

end subroutine g12_t_diffsym

subroutine g11a_t_diffsym(isma,ismb,ismc)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismc
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, ipos_intbasetmp, iposint, ipsmabc, jcoffset, jdoffset, num_smab

ipsmabc = isma+jp2(ismc)+jp3(ismb)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
jdoffset = (m_jd-1)*nlsm_ext(ismb)
jcoffset = (m_jc-1)*nlsm_ext(isma)
num_smab = nlsm_ext(isma)*nlsm_ext(ismc)*3
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
ipos_intbasetmp = ipos_intbasetmp+jdoffset*num_smab+jcoffset*3
do ib=ibsta,ibend
  iposint = ipos_intbasetmp
  do ia=iasta,iaend
    value_lpext(ilwei) = vint_ci(iposint)-vint_ci(iposint+2)
    iposint = iposint+3
    ilwei = ilwei+1
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

end subroutine g11a_t_diffsym

subroutine g11b_t_diffsym(isma,ismb,ismc)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismc
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, ipos_intbasetmp, iposint, ipsmabc, jcoffset, jdoffset, num_smab, &
                     numint_jc

ipsmabc = ismc+jp2(isma)+jp3(ismb)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
jdoffset = (m_jd-1)*nlsm_ext(ismb)
jcoffset = m_jc-1
num_smab = nlsm_ext(isma)*nlsm_ext(ismc)*3
numint_jc = nlsm_ext(ismc)*3
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
ipos_intbasetmp = ipos_intbasetmp+jdoffset*num_smab+jcoffset*3
do ib=ibsta,ibend
  iposint = ipos_intbasetmp      !+jcoffset*3
  do ia=iasta,iaend
    value_lpext(ilwei) = vint_ci(iposint)-vint_ci(iposint+1)
    ilwei = ilwei+1
    iposint = iposint+numint_jc
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

end subroutine g11b_t_diffsym

subroutine g1112_t_symaaaa(isma,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, ngw2, ngw3, ngw4, value_lpext, &
                         vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ic, id
integer(kind=iwp) :: ia, iabcdpos_11b, iasta, ib, ibcdpos_11a, ibcdpos_11b, ibsta, icdpos_11a, icdpos_11b, icdpos_12, ilwei, &
                     ipos_intbasetmp, iposint, ipsmabc, ja, jb

ipsmabc = isma+jp2(isma)+jp3(isma)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)

icdpos_12 = NGW4(m_jd)+NGW3(m_jc)
iasta = ibsm_ext(isma)
ibsta = iasta+1
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
iposint = ipos_intbasetmp+icdpos_12*3         !-3 unnecessary ?
do ib=ibsta,ic-1
  do ia=iasta,ib-1
    value_lpext(ilwei) = vint_ci(iposint+1)-vint_ci(iposint+2)
    ilwei = ilwei+1
    iposint = iposint+3
  end do
end do

icdpos_11a = NGW4(m_jd)+NGW2(m_jc)
jb = m_jc
do ib=ic+1,id-1
  jb = jb+1
  ibcdpos_11a = icdpos_11a+NGW3(jb)
  iposint = ipos_intbasetmp+ibcdpos_11a*3
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    value_lpext(ilwei) = vint_ci(iposint)-vint_ci(iposint+2)
    ilwei = ilwei+1
    iposint = iposint+3
  end do
end do

icdpos_11b = NGW4(m_jd)+m_jc
jb = m_jc+1
do ib=ic+2,id-1
  jb = jb+1
  ibcdpos_11b = icdpos_11b+NGW3(jb)
  ja = m_jc
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,ib-1
    ja = ja+1
    iabcdpos_11b = ibcdpos_11b+NGW2(ja)
    iposint = ipos_intbasetmp+iabcdpos_11b*3-3
    value_lpext(ilwei) = vint_ci(iposint)-vint_ci(iposint+1)
    ilwei = ilwei+1
  end do
end do

end subroutine g1112_t_symaaaa

subroutine g11a11b_t_symaacc(isma,ismc,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, ngw2, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismc, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibdpos, ibsta, ilwei, ipos_intbasetmp, iposint, ipsmabc, ja, num_smab

ipsmabc = isma+jp2(isma)+jp3(ismc)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
num_smab = nlsm_ext(isma)
num_smab = (num_smab*(num_smab-1))/2*3
ibsta = ibsm_ext(ismc)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)

ibdpos = NGW2(m_jd)
ipos_intbasetmp = ipos_intbasetmp+ibdpos*num_smab+NGW2(m_jc)*3
do ib=ibsta,id-1
  iposint = ipos_intbasetmp
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    value_lpext(ilwei) = vint_ci(iposint)-vint_ci(iposint+2)
    ilwei = ilwei+1
    iposint = iposint+3
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
ibdpos = NGW2(m_jd)
ipos_intbasetmp = ipos_intbasetmp+ibdpos*num_smab+m_jc*3
do ib=ibsta,id-1
  iposint = ipos_intbasetmp
  ja = m_jc
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,iaend
    ja = ja+1
    iposint = ipos_intbasetmp+NGW2(ja)*3-3
    value_lpext(ilwei) = vint_ci(iposint)-vint_ci(iposint+1)
    ilwei = ilwei+1
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

end subroutine g11a11b_t_symaacc

subroutine g36_t_ext(ismc,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip2_aa_ext_base, ip3_abd_ext_base, iwt_orb_ext, np3_abd_ext, value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismc, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, ipos_g36, ipos_intbasetmp, iposint

ipos_intbasetmp = ip3_abd_ext_base+(id-1)*np3_abd_ext   !severe_new_
iasta = ibsm_ext(ismc)
ilwei = icnt_base+iwt_orb_ext(iasta,id)
do ia=iasta,ic-1
  ipos_g36 = iwt_orb_ext(ia,ic)-1
  iposint = ipos_intbasetmp+ipos_g36*2         !severe_new_error
  value_lpext(ilwei) = vint_ci(iposint+1)-vint_ci(iposint)+vint_ci(ip2_aa_ext_base+ipos_g36)
  ilwei = ilwei+1
end do

end subroutine g36_t_ext

subroutine g5_t_ext(ismd,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip2_aa_ext_base, ip3_abd_ext_base, iwt_orb_ext, np3_abd_ext, value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ib, ibsta, ilwei, ipos_g5, ipos_intbasetmp, iposint

ipos_intbasetmp = ip3_abd_ext_base+(ic-1)*np3_abd_ext
ibsta = ibsm_ext(ismd)
do ib=max(ic+1,ibsta),id-1
  ipos_g5 = iwt_orb_ext(ib,id)-1            !severe_new_error
  iposint = ipos_intbasetmp+ipos_g5*2         !severe_new_error
  ilwei = icnt_base+iwt_orb_ext(ic,ib)
  value_lpext(ilwei) = vint_ci(iposint+1)-vint_ci(iposint)+vint_ci(ip2_aa_ext_base+ipos_g5)
end do

end subroutine g5_t_ext

subroutine g9_t_ext(ismd,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip2_aa_ext_base, ip3_abd_ext_base, iwt_orb_ext, np3_abd_ext, value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, ipos_g9, ipos_intbasetmp, iposint

ipos_intbasetmp = ip3_abd_ext_base+(ic-1)*np3_abd_ext
iasta = ibsm_ext(ismd)
ilwei = icnt_base+iwt_orb_ext(iasta,ic)
do ia=iasta,ic-1                     !severe_new_error
  ipos_g9 = iwt_orb_ext(ia,id)-1
  iposint = ipos_intbasetmp+ipos_g9*2      !severe_new_error
  value_lpext(ilwei) = vint_ci(iposint)-vint_ci(iposint+1)-vint_ci(ip2_aa_ext_base+ipos_g9)         !severe_new_
  ilwei = ilwei+1
end do

end subroutine g9_t_ext

subroutine gsd_determine_extarmode_paras(ismnodes,ismnoded,logic_sd)

use gugaci_global, only: ibsm_ext, ivaluesta_g26, iweista_g25, iweista_g26, iweista_g28, iwt_orb_ext, iwt_sm_s_ext, logic_g25a, &
                         logic_g25b, logic_g26, logic_g28a, nint_g25, nint_g28, nlsm_ext, nwei_g25, nwei_g26, nwei_g28
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismnodes, ismnoded
logical(kind=iwp), intent(in) :: logic_sd
integer(kind=iwp) :: iorbid, iorbisd, ismnodesd, numsmd, numsmsd

ismnodesd = Mul(ismnodes,ismnoded)
numsmd = nlsm_ext(ismnoded)
numsmsd = nlsm_ext(ismnodesd)
iorbid = ibsm_ext(ismnoded)
iorbisd = ibsm_ext(ismnodesd)

logic_g25a = .false.
logic_g25b = .false.
logic_g28a = .false.
logic_g26 = .false.
if (ismnoded > ismnodesd) then
  logic_g28a = .true.
  iweista_g28 = iwt_orb_ext(iorbisd,iorbid)
  nwei_g28 = numsmd
  nint_g28 = numsmsd
else if (ismnoded == ismnodesd) then
  logic_g25b = .true.
  iweista_g25 = iwt_orb_ext(iorbisd,iorbisd+1)
  nwei_g25 = numsmd
  nint_g25 = numsmsd
  iweista_g28 = iwt_orb_ext(iorbisd,iorbisd+1)
  nwei_g28 = numsmd
  nint_g28 = numsmsd
else
  logic_g25a = .true.
  iweista_g25 = iwt_orb_ext(iorbid,iorbisd)
  nwei_g25 = numsmd
  nint_g25 = numsmsd
end if
if ((ismnodes == 1) .and. logic_sd) then
  logic_g26 = .true.
  iweista_g26 = iwt_sm_s_ext+iorbid
  nwei_g26 = numsmd
  ivaluesta_g26 = 0
end if

end subroutine gsd_determine_extarmode_paras

subroutine g_dd_ext_sequence(ism)

use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, norb_number, value_lpext, voint
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ism
integer(kind=iwp) :: ia, iasta, ib, ibend, ibsta, ilwei, lra, lrb

icano_nnsta = 2
icnt_base = 0
iasta = ibsm_ext(ism)
ibsta = iasta+1
ibend = iesm_ext(ism)
ilwei = 0
do ib=ibsta,ibend
  lrb = norb_number(ib)
  do ia=iasta,ib-1
    lra = norb_number(ia)
    ilwei = ilwei+1
    value_lpext(ilwei) = voint(lrb,lra)
  end do
end do
icano_nnend = ibend-iasta+1
call complete_ext_loop()

end subroutine g_dd_ext_sequence

subroutine g_ss_ext_sequence(ism,itype)

use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iwt_orb_ext, iwt_sm_s_ext, m_jc, m_jd, &
                         max_tmpvalue, ng_sm, norb_ext
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ism, itype
integer(kind=iwp) :: ic, ic_sta, icano_nn, icend, id, id_sta, idend, idsta, isma, ismb, ismc, ismd

icano_nnsta = 2
icnt_base = 0
do ismd=1,ng_sm
  ismc = Mul(ism,ismd)
  if (ismc > ismd) cycle
  id_sta = ibsm_ext(ismd)
  idsta = id_sta
  idend = iesm_ext(ismd)
  ic_sta = ibsm_ext(ismc)
  icend = iesm_ext(ismc)
  if (ismd == ismc) idsta = idsta+1
  do id=idsta,idend
    m_jd = id-id_sta+1
    do ic=ic_sta,min(icend,id-1)
      m_jc = ic-ic_sta+1
      icano_nn = iwt_orb_ext(ic,id)
      if (icnt_base+icano_nn-1 > max_tmpvalue) then
        call complete_ext_loop()
        icnt_base = 0
        icano_nnsta = icano_nn
      end if
      icano_nnend = icano_nn
      do ismb=1,ismd-1
        isma = Mul(ism,ismb)
        if (isma > ismb) cycle
        if (ismc > ismb) then
          call g12_diffsym(isma,ismb,ismc)
        else if (ismc > isma) then
          call g11a_diffsym(isma,ismb,ismc)
        else
          call g11b_diffsym(isma,ismb,ismc)
        end if
      end do
      if (ism == 1) then
        isma = ismd
        call g1112_symaaaa(isma,ic,id)
      else
        isma = Mul(ism,ismd)
        call g11a11b_symaacc(isma,ismd,ic,id)
      end if
      call g10_ext(ismc,ic,id)
      call g5_ext(ismd,ic,id)
      if (ism == 1) call g9_ext(ismd,ic,id)
      icnt_base = icnt_base+icano_nn-1
    end do
  end do
end do
if ((ism == 1) .and. (itype == 4)) then
  do id=1,norb_ext
    icano_nn = id+iwt_sm_s_ext
    if (icnt_base+icano_nn-1 > max_tmpvalue) then
      call complete_ext_loop()
      icnt_base = 0
      icano_nnsta = icano_nn
    end if
    icano_nnend = icano_nn
    call ext_lp_ab_s1(id)
    icnt_base = icnt_base+icano_nn-1
  end do
end if
call complete_ext_loop()

end subroutine g_ss_ext_sequence

subroutine g12_diffsym(isma,ismb,ismc)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, ngw2, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismc
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, ip2cd, ip3smabc, ipos_intbasetmp, iposint, nsma, num_smab

if (isma < ismb) then
  ip3smabc = isma+jp2(ismb)+jp3(ismc)
  ip2cd = m_jc+(m_jd-1)*nlsm_ext(ismc)      !severe_new_error_1206
  num_smab = nlsm_ext(isma)*nlsm_ext(ismb)  !need checking
  ipos_intbasetmp = ip4_abcd_ext_base(ip3smabc)+(ip2cd-1)*num_smab*3
  ibsta = ibsm_ext(ismb)
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
  iposint = ipos_intbasetmp
  do ib=ibsta,ibend
    do ia=iasta,iaend
      value_lpext(ilwei) = vint_ci(iposint+1)+vint_ci(iposint+2)
      ilwei = ilwei+1
      iposint = iposint+3
    end do
  end do
else
  ip3smabc = isma+jp2(ismb)+jp3(ismc)
  ip2cd = m_jc+NGW2(m_jd)
  nsma = nlsm_ext(isma)
  num_smab = nsma*(nsma-1)/2   !need checking
  ipos_intbasetmp = ip4_abcd_ext_base(ip3smabc)+(ip2cd-1)*num_smab*3
  ibsta = ibsm_ext(ismb)+1
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
  iposint = ipos_intbasetmp
  do ib=ibsta,ibend
    do ia=iasta,ib-1
      value_lpext(ilwei) = vint_ci(iposint+1)+vint_ci(iposint+2)
      ilwei = ilwei+1
      iposint = iposint+3
    end do
  end do
end if

end subroutine g12_diffsym

subroutine g11a_diffsym(isma,ismb,ismc)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismc
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, ipos_intbasetmp, iposint, ipsmabc, jcoffset, jdoffset, num_smab

ipsmabc = isma+jp2(ismc)+jp3(ismb)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
jdoffset = (m_jd-1)*nlsm_ext(ismb)
jcoffset = (m_jc-1)*nlsm_ext(isma)
num_smab = nlsm_ext(isma)*nlsm_ext(ismc)*3
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
ipos_intbasetmp = ipos_intbasetmp+jdoffset*num_smab+jcoffset*3
do ib=ibsta,ibend
  iposint = ipos_intbasetmp
  do ia=iasta,iaend
    value_lpext(ilwei) = vint_ci(iposint)+vint_ci(iposint+2)
    iposint = iposint+3
    ilwei = ilwei+1
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

end subroutine g11a_diffsym

subroutine g11b_diffsym(isma,ismb,ismc)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismc
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, ipos_intbasetmp, iposint, ipsmabc, jcoffset, jdoffset, num_smab, &
                     numint_jc

ipsmabc = ismc+jp2(isma)+jp3(ismb)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
jdoffset = (m_jd-1)*nlsm_ext(ismb)
jcoffset = m_jc-1
num_smab = nlsm_ext(isma)*nlsm_ext(ismc)*3
numint_jc = nlsm_ext(ismc)*3
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
ipos_intbasetmp = ipos_intbasetmp+jdoffset*num_smab+jcoffset*3
do ib=ibsta,ibend
  iposint = ipos_intbasetmp      !+jcoffset*3
  do ia=iasta,iaend
    value_lpext(ilwei) = vint_ci(iposint)+vint_ci(iposint+1)
    ilwei = ilwei+1
    iposint = iposint+numint_jc
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

end subroutine g11b_diffsym

subroutine g1112_symaaaa(isma,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, ngw2, ngw3, ngw4, value_lpext, &
                         vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ic, id
integer(kind=iwp) :: ia, iabcdpos_11b, iasta, ib, ibcdpos_11a, ibcdpos_11b, ibsta, icdpos_11a, icdpos_11b, icdpos_12, ilwei, &
                     ipos_intbasetmp, iposint, ipsmabc, ja, jb

ipsmabc = isma+jp2(isma)+jp3(isma)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)

icdpos_12 = NGW4(m_jd)+NGW3(m_jc)
iasta = ibsm_ext(isma)
ibsta = iasta+1
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
iposint = ipos_intbasetmp+icdpos_12*3         !-3 unnecessary ?
do ib=ibsta,ic-1
  !jb = jb+1
  do ia=iasta,ib-1
    value_lpext(ilwei) = vint_ci(iposint+1)+vint_ci(iposint+2)
    ilwei = ilwei+1
    iposint = iposint+3
  end do
end do

icdpos_11a = NGW4(m_jd)+NGW2(m_jc)
jb = m_jc
do ib=ic+1,id-1
  jb = jb+1
  ibcdpos_11a = icdpos_11a+NGW3(jb)
  iposint = ipos_intbasetmp+ibcdpos_11a*3
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    value_lpext(ilwei) = vint_ci(iposint)+vint_ci(iposint+2)
    ilwei = ilwei+1
    iposint = iposint+3
  end do
end do

icdpos_11b = NGW4(m_jd)+m_jc
jb = m_jc+1
do ib=ic+2,id-1
  jb = jb+1
  ibcdpos_11b = icdpos_11b+NGW3(jb)
  ja = m_jc
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,ib-1
    ja = ja+1
    iabcdpos_11b = ibcdpos_11b+NGW2(ja)
    iposint = ipos_intbasetmp+iabcdpos_11b*3-3
    value_lpext(ilwei) = vint_ci(iposint)+vint_ci(iposint+1)
    ilwei = ilwei+1
  end do
end do

end subroutine g1112_symaaaa

subroutine g11a11b_symaacc(isma,ismc,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip4_abcd_ext_base, iwt_orb_ext, jp2, jp3, m_jc, m_jd, ngw2, nlsm_ext, &
                         value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismc, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibdpos, ibsta, ilwei, ipos_intbasetmp, iposint, ipsmabc, ja, num_smab

ipsmabc = isma+jp2(isma)+jp3(ismc)
ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
num_smab = nlsm_ext(isma)
num_smab = (num_smab*(num_smab-1))/2*3
ibsta = ibsm_ext(ismc)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)

ibdpos = NGW2(m_jd)
ipos_intbasetmp = ipos_intbasetmp+ibdpos*num_smab+NGW2(m_jc)*3
do ib=ibsta,id-1
  iposint = ipos_intbasetmp
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    value_lpext(ilwei) = vint_ci(iposint)+vint_ci(iposint+2)
    ilwei = ilwei+1
    iposint = iposint+3
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

ipos_intbasetmp = ip4_abcd_ext_base(ipsmabc)
ibdpos = NGW2(m_jd)
ipos_intbasetmp = ipos_intbasetmp+ibdpos*num_smab+m_jc*3
do ib=ibsta,id-1
  iposint = ipos_intbasetmp
  ja = m_jc
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,iaend
    ja = ja+1
    iposint = ipos_intbasetmp+NGW2(ja)*3-3
    value_lpext(ilwei) = vint_ci(iposint)+vint_ci(iposint+1)
    ilwei = ilwei+1
  end do
  ipos_intbasetmp = ipos_intbasetmp+num_smab
end do

end subroutine g11a11b_symaacc

subroutine g10_ext(ismc,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip2_aa_ext_base, ip3_abd_ext_base, iwt_orb_ext, np3_abd_ext, value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismc, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, ipos_g10, ipos_intbasetmp, iposint

ipos_intbasetmp = ip3_abd_ext_base+(id-1)*np3_abd_ext   !severe_new_
iasta = ibsm_ext(ismc)
ilwei = icnt_base+iwt_orb_ext(iasta,id)
do ia=iasta,ic-1
  ipos_g10 = iwt_orb_ext(ia,ic)-1
  iposint = ipos_intbasetmp+ipos_g10*2
  value_lpext(ilwei) = vint_ci(iposint+1)+vint_ci(iposint)+vint_ci(ip2_aa_ext_base+ipos_g10)
  ilwei = ilwei+1
end do

end subroutine g10_ext

subroutine g5_ext(ismd,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip2_aa_ext_base, ip3_abd_ext_base, iwt_orb_ext, np3_abd_ext, value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ib, ibsta, ilwei, ipos_g5, ipos_intbasetmp, iposint

ipos_intbasetmp = ip3_abd_ext_base+(ic-1)*np3_abd_ext
ibsta = ibsm_ext(ismd)
do ib=max(ic+1,ibsta),id-1
  ipos_g5 = iwt_orb_ext(ib,id)-1            !severe_new_error
  iposint = ipos_intbasetmp+ipos_g5*2         !severe_new_error
  ilwei = icnt_base+iwt_orb_ext(ic,ib)
  value_lpext(ilwei) = vint_ci(iposint+1)+vint_ci(iposint)+vint_ci(ip2_aa_ext_base+ipos_g5)
end do

end subroutine g5_ext

subroutine g9_ext(ismd,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, ip2_aa_ext_base, ip3_abd_ext_base, iwt_orb_ext, np3_abd_ext, value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, ipos_g9, ipos_intbasetmp, iposint

ipos_intbasetmp = ip3_abd_ext_base+(ic-1)*np3_abd_ext
iasta = ibsm_ext(ismd)
ilwei = icnt_base+iwt_orb_ext(iasta,ic)
do ia=iasta,ic-1                     !severe_new_error
  ipos_g9 = iwt_orb_ext(ia,id)-1
  iposint = ipos_intbasetmp+ipos_g9*2      !severe_new_error
  value_lpext(ilwei) = vint_ci(iposint+1)+vint_ci(iposint)+vint_ci(ip2_aa_ext_base+ipos_g9)
  ilwei = ilwei+1
end do

end subroutine g9_ext

subroutine ext_lp_ab_s1(id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, ip2_aa_ext_base, ip2_dd_ext_base, ip3_abd_ext_base, ng_sm, ngw2, &
                         np3_abd_ext, v_sqtwo, value_lpext, vint_ci
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: id
integer(kind=iwp) :: ia, iasta, ib, ibend, ibsta, ic, ilwei, ipos_intbasetmp, iposint, iposintaa, ismb

ipos_intbasetmp = ip3_abd_ext_base+(id-1)*np3_abd_ext
ilwei = icnt_base
iposintaa = ip2_aa_ext_base-1
iposint = ipos_intbasetmp
do ismb=1,ng_sm
  iasta = ibsm_ext(ismb)
  ibend = iesm_ext(ismb)
  ibsta = iasta+1
  do ib=ibsta,ibend
    do ia=iasta,ib-1
      iposintaa = iposintaa+1
      if ((ib == id) .or. (ia == id)) then
        ! g2   arar+ar(head)ar
        ilwei = ilwei+1
        value_lpext(ilwei) = v_sqtwo*(vint_ci(iposintaa)+vint_ci(iposint))
      else
        ! g6g7g8
        ilwei = ilwei+1
        value_lpext(ilwei) = v_sqtwo*vint_ci(iposint)
      end if
      iposint = iposint+2
    end do
  end do
end do
! g1
!lw = lw0
iposint = ip2_dd_ext_base+NGW2(id)
do ic=1,id-1
  ilwei = ilwei+1
  value_lpext(ilwei) = vint_ci(iposint)
  iposint = iposint+1
end do

end subroutine ext_lp_ab_s1

subroutine g31_diffsym(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, intind_iabc, iwt_orb_ext, m_jd, nabc, ngw2, ngw3, value_lpext, vint_ci, &
                         w0plp31, w1plp31
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iabc, iabc0, iaend, iasta, ib, ibend, ibsta, ic, ilwei, iposint

iabc0 = (lri-1)*nabc
ic = m_jd
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
if (isma == ismb) ibsta = ibsta+1
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)
do ib=ibsta,ibend
  if (isma == ismb) iaend = ib-1
  do ia=iasta,iaend
    ! g31   type_12 arbrb^ra^r
    iabc = iabc0+ia+ngw2(ib)+ngw3(ic)
    iposint = intind_iabc(iabc)
    value_lpext(ilwei) = vint_ci(iposint+1)*w0plp31+vint_ci(iposint+2)*w1plp31
    ilwei = ilwei+1
  end do
end do

end subroutine g31_diffsym

subroutine g32a_diffsym(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, intind_iabc, iwt_orb_ext, m_jd, nabc, ngw2, ngw3, value_lpext, vint_ci, &
                         w0plp32, w1plp32
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iabc, iabc0, iaend, iasta, ib, ibend, ibsta, ic, ilwei, iposint

iabc0 = (lri-1)*nabc

ic = m_jd

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)
do ib=ibsta,ibend
  do ia=iasta,iaend
    iabc = iabc0+ia+ngw2(ic)+ngw3(ib)
    iposint = intind_iabc(iabc)
    value_lpext(ilwei) = vint_ci(iposint+2)*w0plp32-vint_ci(iposint)*w1plp32
    ilwei = ilwei+1
  end do
end do

end subroutine g32a_diffsym

subroutine g32b_diffsym(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, intind_iabc, iwt_orb_ext, m_jd, nabc, ngw2, ngw3, value_lpext, vint_ci, &
                         w0plp32, w1plp32
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iabc, iabc0, iaend, iasta, ib, ibend, ibsta, ic, ilwei, iposint

iabc0 = (lri-1)*nabc

ic = m_jd

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
if (ismb == isma) ibsta = ibsta+1         !severe_new_error
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
do ib=ibsta,ibend
  do ia=iasta,min(iaend,ib-1)
    ! g32b
    iabc = iabc0+ic+ngw2(ia)+ngw3(ib)
    iposint = intind_iabc(iabc)
    value_lpext(ilwei) = vint_ci(iposint+1)*w0plp32-vint_ci(iposint)*w1plp32 !severe_new_err
    ilwei = ilwei+1
  end do
end do

end subroutine g32b_diffsym

!subroutine assign_segmode_paras(indl,indr,ilrdivnodesm)
!
!use gugaci_global, only: ilsegdownwei, irsegdownwei, iseg_downwei, iseg_sta
!use Definitions, only: iwp
!
!implicit none
!integer(kind=iwp), intent(in) :: indl, indr, ilrdivnodesm
!
!ilsegdownwei = iseg_downwei(indl)
!irsegdownwei = iseg_downwei(indr)
!irsegstawei = iseg_sta(indr)
!ip2_intbase = ip2_ab_inn_base(ilrdivnodesm)
!ip2_intspace = int2ind_space_extsmab(ilrdivnodesm)
!ip2_intsymspace = int2ind_numijkl_extsmab(ilrdivnodesm)
!
!end subroutine assign_segmode_paras

subroutine external_space_plpmode_value_st()   !tt

use gugaci_global, only: v_sqthree, v_sqthreevsqtwo, w0g14a, w0g15a, w0g2a, w0g2b, w0g34a, w0g34b, w0g35a, w0g35b, w0g36a, w0g36b, &
                         w0g4a, w0g4b, w1g14a, w1g15a, w1g2a, w1g2b, w1g34a, w1g34b, w1g35a, w1g35b, w1g36a, w1g36b, w1g4a, w1g4b
use Constants, only: Zero

implicit none

w0g36a = Zero
w0g36b = Zero
w0g34a = Zero
w0g34b = Zero
w0g35a = Zero
w0g35b = Zero
w0g2a = Zero
w0g2b = Zero
w0g4a = Zero
w0g4b = Zero
w0g14a = Zero
w0g15a = Zero
!w0g13a = Zero

! st
w1g36a = v_sqthreevsqtwo
w1g36b = v_sqthreevsqtwo
w1g34a = -w1g36a
w1g34b = -w1g36a
w1g35a = w1g36a
w1g35b = -w1g36a
w1g2a = Zero      !g2a   ab_d
w1g2b = -v_sqthree   !severe_error
w1g4a = Zero
w1g4b = v_sqthree
w1g14a = w1g36a
w1g15a = -w1g36a

end subroutine external_space_plpmode_value_st

subroutine external_space_plpmode_value_ts()   !tt

use gugaci_global, only: v_onevsqtwo, w0g14a, w0g15a, w0g2a, w0g2b, w0g34a, w0g34b, w0g35a, w0g35b, w0g36a, w0g36b, w0g4a, w0g4b, &
                         w1g14a, w1g15a, w1g2a, w1g2b, w1g34a, w1g34b, w1g35a, w1g35b, w1g36a, w1g36b, w1g4a, w1g4b
use Constants, only: Zero, One

implicit none

w0g36a = Zero
w0g36b = Zero
w0g34a = Zero
w0g34b = Zero
w0g35a = Zero
w0g35b = Zero
w0g2a = Zero
w0g2b = Zero
w0g4a = Zero
w0g4b = Zero
w0g14a = Zero
w0g15a = Zero
! ts
w1g36a = -v_onevsqtwo
w1g36b = -v_onevsqtwo
w1g34a = -w1g36a
w1g34b = -w1g36a
w1g35a = -w1g36a   !severe_error
w1g35b = w1g36a
w1g2a = One       !g2a   ab_d
w1g2b = Zero
w1g4a = -One
w1g4b = Zero
w1g14a = w1g36a
w1g15a = -w1g36a

end subroutine external_space_plpmode_value_ts

subroutine external_space_plpmode_value_ss()   !ss

use gugaci_global, only: v_onevsqtwo, v_sqtwo, w0g13a, w0g14a, w0g15a, w0g2a, w0g2b, w0g34a, w0g34b, w0g35a, w0g35b, w0g36a, &
                         w0g36b, w0g4a, w0g4b, w1g14a, w1g15a, w1g2a, w1g2b, w1g34a, w1g34b, w1g35a, w1g35b, w1g36a, w1g36b, &
                         w1g4a, w1g4b
use Constants, only: Zero, One

implicit none

w0g36a = -v_onevsqtwo
w0g36b = -v_onevsqtwo
w0g34a = w0g36a
w0g34b = w0g36a
w0g35a = w0g36a
w0g35b = w0g36a
w0g2a = -One
w0g2b = -One
w0g4a = -One
w0g4b = -One
w0g14a = w0g36a
w0g15a = w0g36a
w0g13a = -v_sqtwo
w1g36a = Zero
w1g36b = Zero
w1g34a = Zero
w1g34b = Zero
w1g35a = Zero
w1g35b = Zero
w1g2a = Zero
w1g2b = Zero
w1g4a = Zero
w1g4b = Zero
w1g14a = Zero
w1g15a = Zero

end subroutine external_space_plpmode_value_ss

subroutine external_space_plpmode_value_tt()   !tt

use gugaci_global, only: v_onevsqtwo, w0g14a, w0g15a, w0g2a, w0g2b, w0g34a, w0g34b, w0g35a, w0g35b, w0g36a, w0g36b, w0g4a, w0g4b, &
                         w1g14a, w1g15a, w1g2a, w1g2b, w1g34a, w1g34b, w1g35a, w1g35b, w1g36a, w1g36b, w1g4a, w1g4b
use Constants, only: Zero, One

implicit none

w0g36a = -v_onevsqtwo
w0g36b = -v_onevsqtwo
w0g34a = w0g36a
w0g34b = w0g36a
w0g35a = -w0g36a
w0g35b = -w0g36a
w0g2a = Zero
w0g2b = Zero
w0g4a = Zero
w0g4b = Zero
w0g14a = w0g36a
w0g15a = w0g36a
!w0g13a = -v_sqtwo

w1g36a = One
w1g36b = One
w1g34a = w1g36a
w1g34b = w1g36a
w1g35a = -w1g36a
w1g35b = -w1g36a
w1g2a = Zero      !g2a   ab_d
w1g2b = Zero
w1g4a = Zero
w1g4b = Zero
w1g14a = w1g36a
w1g15a = w1g36a

end subroutine external_space_plpmode_value_tt

subroutine external_space_plpmode_value_sd()

use gugaci_global, only: v_sqtwo, w0g25, w0g25a, w0g26a, w0g27, w0g28a, w0g29, w0g30, w0g31, w0g32, w0plp25, w0plp26, w0plp27, &
                         w0plp28, w0plp29, w0plp30, w0plp31, w0plp32, w1g25a, w1g26a, w1g27, w1g28a, w1g31, w1g32, w1plp27, &
                         w1plp31, w1plp32
use Constants, only: One

implicit none

! sd   lpmode_value
w0g29 = v_sqtwo
w0g30 = v_sqtwo
w0g26a = v_sqtwo
w1g26a = v_sqtwo
w0g25 = One
w0g25a = One
w1g25a = One
w0g27 = One
w1g27 = -One
w0g28a = One
w1g28a = One
w0g31 = One
w1g31 = One
w0g32 = One
w1g32 = -One

w0plp25 = w0g25a
w0plp26 = w0g26a
w0plp27 = w0g27
w1plp27 = w1g27
w0plp28 = w0g28a
w0plp29 = w0g29
w0plp30 = w0g30
w0plp31 = w0g31
w1plp31 = w1g31
w0plp32 = w0g32
w1plp32 = w1g32

end subroutine external_space_plpmode_value_sd

subroutine external_space_plpmode_value_td()

use gugaci_global, only: w0g25, w0g25a, w0g26a, w0g27, w0g28a, w0g29, w0g30, w0g31, w0g32, w0plp25, w0plp26, w0plp27, w0plp28, &
                         w0plp31, w0plp32, w1g25a, w1g26a, w1g27, w1g28a, w1g31, w1g32, w1plp27, w1plp31, w1plp32
use Constants, only: Zero, One

implicit none

! td   lpmode_value
w0g29 = Zero
w0g30 = Zero
w0g26a = Zero
w1g26a = Zero
w0g25 = One
w0g25a = One
w1g25a = One
w0g27 = -One
w1g27 = -One
w0g28a = -One
w1g28a = -One
w0g31 = One
w1g31 = -One
w0g32 = -One
w1g32 = -One

w0plp25 = w0g25a
w0plp26 = w0g26a
w0plp27 = w0g27
w1plp27 = w1g27
w0plp28 = w0g28a
w0plp31 = w0g31
w1plp31 = w1g31
w0plp32 = w0g32
w1plp32 = w1g32

end subroutine external_space_plpmode_value_td

subroutine external_space_plpmode_value_ds()

use gugaci_global, only: v_onevsqtwo, w0g25, w0g25b, w0g26b, w0g28b, w0plp25, w0plp26, w0plp28, w1g25b, w1g26b, w1g28b
use Constants, only: One

implicit none

! ds   lpmode_value
w0g25 = -v_onevsqtwo
w0g25b = -v_onevsqtwo
w1g25b = -v_onevsqtwo
w0g28b = -v_onevsqtwo
w1g28b = -v_onevsqtwo
w0g26b = -One
w1g26b = -One

w0plp25 = w0g25
w0plp28 = w0g28b
w0plp26 = w0g26b

end subroutine external_space_plpmode_value_ds

subroutine external_space_plpmode_value_dt()

use gugaci_global, only: v_sqthreevsqtwo, w0g25, w0g25b, w0g26b, w0g28b, w1g25b, w1g26b, w1g28b
use Constants, only: Zero

implicit none

! dt   lpmode_value
w0g25 = v_sqthreevsqtwo   !v_onevsqtwo      !severe_new_error
w0g25b = v_sqthreevsqtwo
w1g25b = v_sqthreevsqtwo
w0g28b = -v_sqthreevsqtwo
w1g28b = -v_sqthreevsqtwo
w0g26b = Zero
w1g26b = Zero

end subroutine external_space_plpmode_value_dt

!subroutine ss_ext_plpmode(ilnodesm,irnodesm,iltype,irtype,lptype)
!
!use gugaci_global, only: idownwei_g131415, ilsegdownwei, irsegdownwei, ism_g1415, ism_g2g4, logic_g13, logic_g1415, logic_g2g4a, &
!                         logic_g2g4b, logic_g34a, logic_g34b, logic_g35a, logic_g35b, logic_g36a, logic_g36b, lpend34a, lpend34b, &
!                         lpend35a, lpend35b, lpend36a, lpend36b, lpsta34a, lpsta34b, lpsta35a, lpsta35b, lpsta36a, lpsta36b, &
!                         nvalue_space_ss
!use Symmetry_Info, only: Mul
!use Definitions, only: iwp
!
!implicit none
!integer(kind=iwp), intent(in) :: ilnodesm, irnodesm, iltype, irtype, lptype
!integer(kind=iwp) :: iii, ilrsm
!
!ilrsm = Mul(ilnodesm,irnodesm)
!iii = 1   !index to determine lwei rwei iposint and nlinkorb
!! G2G4a G2G4b G1415 G13
!logic_g36a = .false.
!logic_g36b = .false.
!logic_g35a = .false.
!logic_g35b = .false.
!logic_g34a = .false.
!logic_g34b = .false.
!!if ((ilnodesm == 1) .and. (irnodesm == 3)) then
!!  write(u6,*)
!!end if
!
!! G36b
!lpsta36a = iii
!call do_g36mode(ilrsm,ilnodesm,iii)
!lpend36a = iii-4
!if (lpend36a >= lpsta36a) logic_g36a = .true.   !severe_new_erro
!lpsta35a = iii
!call do_g35mode(ilrsm,ilnodesm,iii)
!lpend35a = iii-4
!if (lpend35a >= lpsta35a) logic_g35a = .true.
!lpsta34a = iii
!call do_g34mode(ilrsm,ilnodesm,iii)
!lpend34a = iii-4
!if (lpend34a >= lpsta34a) logic_g34a = .true.
!if (ilrsm /= 1) then
!  lpsta36b = iii
!  call do_g36mode(ilrsm,irnodesm,iii)
!  lpend36b = iii-4
!  if (lpend36b >= lpsta36b) logic_g36b = .true.
!  lpsta35b = iii
!  call do_g35mode(ilrsm,irnodesm,iii)
!  lpend35b = iii-4
!  if (lpend35b >= lpsta35b) logic_g35b = .true.
!  lpsta34b = iii
!  call do_g34mode(ilrsm,irnodesm,iii)
!  lpend34b = iii-4
!  if (lpend34b >= lpsta34b) logic_g34b = .true.
!else
!  logic_g36b = logic_g36a
!  lpsta36b = lpsta36a
!  lpend36b = lpend36a
!  logic_g35b = logic_g35a
!  lpsta35b = lpsta35a
!  lpend35b = lpend35a
!  logic_g34b = logic_g34a
!  lpsta34b = lpsta34a
!  lpend34b = lpend34a
!end if
!
!! G2G4a G2G4b G1415 G13
!logic_g2g4a = .false.
!logic_g2g4b = .false.
!logic_g1415 = .false.
!logic_g13 = .false.
!
!if ((irnodesm == 1) .and. (irtype == 4)) then
!  logic_g2g4a = .true.
!  ism_g2g4 = ilnodesm
!end if
!if ((ilnodesm == 1) .and. (iltype == 4)) then
!  logic_g2g4b = .true.
!  ism_g2g4 = irnodesm
!end if
!
!if ((lptype /= 2) .and. (ilrsm == 1)) then
!  logic_g1415 = .true.
!  ism_g1415 = ilnodesm
!  if ((ilnodesm == 1) .and. (iltype == 4) .and. (irtype == 4)) then
!    logic_g13 = .true.
!  end if
!  if (iltype == 4) then          !severe_error
!    idownwei_g131415 = irsegdownwei
!  else
!    idownwei_g131415 = ilsegdownwei
!  end if
!end if
!
!nvalue_space_ss = ip2_intsymspace/3
!
!end subroutine ss_ext_plpmode

subroutine do_g36mode(ilrsm,ilnodesm,iii)

use gugaci_global, only: ng_sm
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ilrsm, ilnodesm
integer(kind=iwp), intent(inout) :: iii
integer(kind=iwp) :: isma, ismb, ismlink

do ismb=1,ng_sm
  isma = Mul(ismb,ilrsm)
  if (isma > ismb) cycle
  ismlink = Mul(isma,ilnodesm)
  if (ismlink > isma) cycle
  call g36_form(isma,ismb,ismlink,iii)
end do

end subroutine do_g36mode

subroutine do_g34mode(ilrsm,ilnodesm,iii)

use gugaci_global, only: ng_sm
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ilrsm, ilnodesm
integer(kind=iwp), intent(inout) :: iii
integer(kind=iwp) :: isma, ismb, ismlink

do ismb=1,ng_sm
  isma = Mul(ismb,ilrsm)
  if (isma > ismb) cycle
  ismlink = Mul(isma,ilnodesm)
  if (ismlink < ismb) cycle
  call g34_form(isma,ismb,ismlink,iii)
end do

end subroutine do_g34mode

subroutine do_g35mode(ilrsm,ilnodesm,iii)

use gugaci_global, only: ng_sm
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ilrsm, ilnodesm
integer(kind=iwp), intent(inout) :: iii
integer(kind=iwp) :: isma, ismb, ismlink

do ismb=1,ng_sm
  isma = Mul(ismb,ilrsm)
  if (isma > ismb) cycle
  ismlink = Mul(isma,ilnodesm)
  if ((ismlink > ismb) .or. (ismlink < isma)) cycle
  call g35_form(isma,ismb,ismlink,iii)
end do

end subroutine do_g35mode

subroutine g36_form(isma,ismb,ismlink,iii)

use gugaci_global, only: ibsm_ext, iesm_ext, iwt_orb_ext, lpext_wei
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismlink
integer(kind=iwp), intent(inout) :: iii
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, icsta, ilinkend, ilinksta, nlinkorb

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilinksta = ibsm_ext(ismlink)
ilinkend = iesm_ext(ismlink)
if (isma == ismlink) iasta = iasta+1
if (ismb == isma) ibsta = ibsta+1
if (ismb == ismlink) ibsta = ibsta+1

do ib=ibsta,ibend
  do ia=iasta,min(iaend,ib-1)
    icsta = ilinksta
    nlinkorb = min(ilinkend,ia-1)-ilinksta+1
    if (nlinkorb <= 0) cycle
    lpext_wei(iii) = iwt_orb_ext(icsta,ia)
    lpext_wei(iii+1) = iwt_orb_ext(icsta,ib)
    lpext_wei(iii+2) = iwt_orb_ext(ia,ib)
    lpext_wei(iii+3) = nlinkorb
    iii = iii+4
  end do
end do

end subroutine g36_form

subroutine g34_form(isma,ismb,ismlink,iii)

use gugaci_global, only: ibsm_ext, iesm_ext, iwt_orb_ext, lpext_wei
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismlink
integer(kind=iwp), intent(inout) :: iii
integer(kind=iwp) :: iaend, iasta, ib, ibend, ibsta, ilink, ilinkend, ilinksta, naorb

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilinksta = ibsm_ext(ismlink)
ilinkend = iesm_ext(ismlink)
if (ismlink == ismb) ilinksta = ilinksta+1
if (ismlink == isma) ilinksta = ilinksta+1
if (ismb == isma) ibsta = ibsta+1

do ilink=ilinksta,ilinkend
  do ib=ibsta,min(ibend,ilink-1)
    naorb = min(iaend,ib-1)-iasta+1
    if (naorb <= 0) cycle
    lpext_wei(iii) = iwt_orb_ext(iasta,ilink)
    lpext_wei(iii+1) = iwt_orb_ext(ib,ilink)
    lpext_wei(iii+2) = iwt_orb_ext(iasta,ib)
    lpext_wei(iii+3) = naorb
    iii = iii+4
  end do
end do

end subroutine g34_form

subroutine g35_form(isma,ismb,ismlink,iii)

use gugaci_global, only: ibsm_ext, iesm_ext, iwt_orb_ext, lpext_wei
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ismlink
integer(kind=iwp), intent(inout) :: iii
integer(kind=iwp) :: iaend, iasta, ib, ibend, ibsta, ilink, ilinkend, ilinksta, naorb

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilinksta = ibsm_ext(ismlink)
ilinkend = iesm_ext(ismlink)
if (ismb == ismlink) ibsta = ibsta+1
if (ismb == isma) ibsta = ibsta+1
if (ismlink == isma) ilinksta = ilinksta+1

do ib=ibsta,ibend
  do ilink=ilinksta,min(ilinkend,ib-1)
    naorb = min(iaend,ilink-1)-iasta+1
    if (naorb <= 0) cycle
    lpext_wei(iii) = iwt_orb_ext(iasta,ilink)
    lpext_wei(iii+1) = iwt_orb_ext(ilink,ib)
    lpext_wei(iii+2) = iwt_orb_ext(iasta,ib)
    lpext_wei(iii+3) = naorb
    iii = iii+4
  end do
end do

end subroutine g35_form

!function ibfunction(ib,istep)
!
!use Definitions, only: iwp, u6
!
!implicit none
!integer(kind=iwp) :: ibfunction
!integer(kind=iwp), intent(in) :: ib, istep
!
!select case (istep)
!  case (2)
!    ibfunction = ib-1
!  case (3)
!    ibfunction = ib+1
!  case default
!    ibfunction = ib
!end select
!if (ibfunction < 0) then
!  write(u6,*) 'error'
!end if
!
!end function ibfunction

subroutine determine_para_array_for_int1ind()

use gugaci_global, only: ng_sm, ngw2, ngw3, nlsm_ext, norb_ext
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp) :: isma, ismab, ismabc, ismb, ismc, nintcount, numa, numb, numc, numint

do ismabc=1,ng_sm
  nintcount = 0
  do ismc=1,ng_sm
    ismab = Mul(ismabc,ismc)
    numc = nlsm_ext(ismc)
    do ismb=1,ismc
      isma = Mul(ismab,ismb)
      if (isma > ismb) cycle
      numb = nlsm_ext(ismb)
      numa = nlsm_ext(isma)
      numint = 0
      if (isma == ismc) then         !aaa
        !numint = numa-2+ip2(numb-1)+ip3(numc)
        if (numb > 1) then
          numint = numa-2+ngw2(numb-1)+ngw3(numc)
        end if
      else if (isma == ismb) then      !aac
        !numint = (numa-1+ip2(numb))*numc
        if (numb > 0) then
          if ((numa-1+ngw2(numb)) > 0) then
            numint = (numa-1+ngw2(numb))*numc
          end if
        end if
      else if (ismb == ismc) then      !acc
        !numint = (numb-1+ip2(numc))*numa
        if (numc > 0) then
          if ((numb-1+ngw2(numc)) > 0) then
            numint = (numb-1+ngw2(numc))*numa
          end if
        end if
      else                        !abc
        numint = numa*numb*numc
      end if
      if (numint <= 0) cycle            !severe_new_error
      numint = numint*3
      nintcount = nintcount+numint
    end do
  end do
  numint = nlsm_ext(ismabc)*norb_ext*2
  nintcount = nintcount+numint
  numint = nlsm_ext(ismabc)
end do

end subroutine determine_para_array_for_int1ind

subroutine g_dd_ext_sequence_G(ism)

use gugaci_global, only: ibsm_ext, ican_a, icano_nnend, icano_nnsta, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, &
                         norb_number, value_lpext2
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ism
integer(kind=iwp) :: ia, iasta, ib, ibend, ibsta, ilwei, lra, lrb, nac

icano_nnsta = 2
icnt_base = 0
iasta = ibsm_ext(ism)
ibsta = iasta+1
ibend = iesm_ext(ism)
ilwei = 0
do ib=ibsta,ibend
  lrb = norb_number(ib)
  do ia=iasta,ib-1
    lra = norb_number(ia)
    ilwei = ilwei+1
    index_lpext(ilwei) = 0
    index_lpext1(ilwei) = 0

    NAC = ICAN_A(LRA)+LRB
    index_lpext2(ilwei) = NAC
    value_lpext2(ilwei) = One
  end do
end do
icano_nnend = ibend-iasta+1
call complete_ext_loop_G()

end subroutine g_dd_ext_sequence_G

subroutine g_tt_ext_sequence_G(ism)

use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iwt_orb_ext, m_jc, m_jd, max_tmpvalue, ng_sm
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ism
integer(kind=iwp) :: ic, ic_sta, icano_nn, icend, id, id_sta, idend, idsta, isma, ismb, ismc, ismd

icano_nnsta = 2
icnt_base = 0
do ismd=1,ng_sm
  ismc = Mul(ism,ismd)
  if (ismc > ismd) cycle
  id_sta = ibsm_ext(ismd)
  idsta = id_sta
  idend = iesm_ext(ismd)
  ic_sta = ibsm_ext(ismc)
  icend = iesm_ext(ismc)
  if (ismd == ismc) idsta = idsta+1
  do id=idsta,idend
    m_jd = id-id_sta+1
    do ic=ic_sta,min(icend,id-1)
      m_jc = ic-ic_sta+1
      icano_nn = iwt_orb_ext(ic,id)
      if (icnt_base+icano_nn-1 > max_tmpvalue) then
        call complete_ext_loop_G()
        icnt_base = 0
        icano_nnsta = icano_nn
      end if
      icano_nnend = icano_nn
      do ismb=1,ismd-1
        isma = Mul(ism,ismb)
        if (isma > ismb) cycle
        if (ismc > ismb) then
          call g12_t_diffsym_G(isma,ismb,ic,id)
        else if (ismc > isma) then
          call g11a_t_diffsym_G(isma,ismb,ic,id)
        else
          call g11b_t_diffsym_G(isma,ismb,ic,id)
        end if
      end do
      if (ism == 1) then
        isma = ismd
        call g1112_t_symaaaa_G(isma,ic,id)
      else
        isma = Mul(ism,ismd)
        call g11a11b_t_symaacc_G(isma,ismd,ic,id)
      end if
      call g36_t_ext_G(ismc,ic,id)
      call g5_t_ext_G(ismd,ic,id)
      if (ism == 1) call g9_t_ext_G(ismd,ic,id)
      icnt_base = icnt_base+icano_nn-1
    end do
  end do
end do
call complete_ext_loop_G()

end subroutine g_tt_ext_sequence_G

subroutine g_ss_ext_sequence_G(ism,itype)

use gugaci_global, only: ibsm_ext, icano_nnend, icano_nnsta, icnt_base, iesm_ext, iwt_orb_ext, iwt_sm_s_ext, m_jc, m_jd, &
                         max_tmpvalue, ng_sm, norb_ext
use Symmetry_Info, only: Mul
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ism, itype
integer(kind=iwp) :: ic, ic_sta, icano_nn, icend, id, id_sta, idend, idsta, isma, ismb, ismc, ismd

icano_nnsta = 2
icnt_base = 0
do ismd=1,ng_sm
  ismc = Mul(ism,ismd)
  if (ismc > ismd) cycle
  id_sta = ibsm_ext(ismd)
  idsta = id_sta
  idend = iesm_ext(ismd)
  ic_sta = ibsm_ext(ismc)
  icend = iesm_ext(ismc)
  if (ismd == ismc) idsta = idsta+1
  do id=idsta,idend
    m_jd = id-id_sta+1
    do ic=ic_sta,min(icend,id-1)
      m_jc = ic-ic_sta+1
      icano_nn = iwt_orb_ext(ic,id)
      if (icnt_base+icano_nn-1 > max_tmpvalue) then
        call complete_ext_loop_G()
        icnt_base = 0
        icano_nnsta = icano_nn
      end if
      icano_nnend = icano_nn
      do ismb=1,ismd-1
        isma = Mul(ism,ismb)
        if (isma > ismb) cycle
        if (ismc > ismb) then
          call g12_diffsym_G(isma,ismb,ic,id)
        else if (ismc > isma) then
          call g11a_diffsym_G(isma,ismb,ic,id)
        else
          call g11b_diffsym_G(isma,ismb,ic,id)
        end if
      end do
      if (ism == 1) then
        isma = ismd
        call g1112_symaaaa_G(isma,ic,id)
      else
        isma = Mul(ism,ismd)
        call g11a11b_symaacc_G(isma,ismd,ic,id)
      end if
      call g10_ext_G(ismc,ic,id)
      call g5_ext_G(ismd,ic,id)
      if (ism == 1) then
        call g9_ext_G(ismd,ic,id)
      end if
      icnt_base = icnt_base+icano_nn-1
    end do
  end do
end do
if ((ism == 1) .and. (itype == 4)) then
  do id=1,norb_ext
    icano_nn = id+iwt_sm_s_ext
    if (icnt_base+icano_nn-1 > max_tmpvalue) then
      call complete_ext_loop_G()
      icnt_base = 0
      icano_nnsta = icano_nn
    end if
    icano_nnend = icano_nn
    call ext_lp_ab_s1_G(id)
    icnt_base = icnt_base+icano_nn-1
  end do
end if
call complete_ext_loop_G()

end subroutine g_ss_ext_sequence_G

subroutine g12_diffsym_G(isma,ismb,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

!write(nf2,*) 'g12_diff'
lrc = norb_number(ic)
lrd = norb_number(id)

if (isma < ismb) then
  ibsta = ibsm_ext(ismb)
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

  do ib=ibsta,ibend
    lrb = norb_number(ib)
    do ia=iasta,iaend
      lra = norb_number(ia)
      call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
      index_lpext(ilwei) = NXO
      value_lpext(ilwei) = One
      call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrb,NXO)
      index_lpext1(ilwei) = NXO
      value_lpext1(ilwei) = One
      index_lpext2(ilwei) = 0
      ilwei = ilwei+1

    end do
  end do
else

  ibsta = ibsm_ext(ismb)+1
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

  do ib=ibsta,ibend
    lrb = norb_number(ib)
    do ia=iasta,ib-1
      lra = norb_number(ia)
      call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
      index_lpext(ilwei) = NXO
      value_lpext(ilwei) = One
      call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrb,NXO)
      index_lpext1(ilwei) = NXO
      value_lpext1(ilwei) = One
      index_lpext2(ilwei) = 0
      ilwei = ilwei+1
    end do
  end do
end if

end subroutine g12_diffsym_G

subroutine g11a_diffsym_G(isma,ismb,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

!write(nf2,*) 'g11a_diff'
lrc = norb_number(ic)
lrd = norb_number(id)

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

do ib=ibsta,ibend
  lrb = norb_number(ib)
  do ia=iasta,iaend
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrc,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g11a_diffsym_G

subroutine g11b_diffsym_G(isma,ismb,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

!write(nf2,*) 'g11b_diff'
lrc = norb_number(ic)
lrd = norb_number(id)

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
do ib=ibsta,ibend
  lrb = norb_number(ib)
  do ia=iasta,iaend
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lrc,lra,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lrc,lrb,lra,lrd,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g11b_diffsym_G

subroutine g1112_symaaaa_G(isma,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, value_lpext, &
                         value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ic, id
integer(kind=iwp) :: ia, iasta, ib, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

!write(nf2,*) 'g1112_symaaaa'
lrc = norb_number(ic)
lrd = norb_number(id)

iasta = ibsm_ext(isma)
ibsta = iasta+1
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

do ib=ibsta,ic-1
  lrb = norb_number(ib)
  do ia=iasta,ib-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrb,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

do ib=ic+1,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrc,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

do ib=ic+2,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,ib-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lrc,lra,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lrc,lrb,lra,lrd,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g1112_symaaaa_G

subroutine g11a11b_symaacc_G(isma,ismc,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismc, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

!write(nf2,*) 'g11a11b_symaacc'
lrc = norb_number(ic)
lrd = norb_number(id)

ibsta = ibsm_ext(ismc)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)

do ib=ibsta,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrc,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

do ib=ibsta,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,iaend
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lrc,lra,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lrc,lrb,lra,lrd,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g11a11b_symaacc_G

subroutine g10_ext_G(ismc,ic,id)

use gugaci_global, only: ibsm_ext, ican_a, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1, value_lpext2
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismc, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, lra, lrc, lrd, nac, nxo

!write(nf2,*) 'g10_ext'
lrc = norb_number(ic)
lrd = norb_number(id)
iasta = ibsm_ext(ismc)
ilwei = icnt_base+iwt_orb_ext(iasta,id)
do ia=iasta,ic-1
  lra = norb_number(ia)
  call TRANS_IJKL_INTPOS(lra,lrc,lrd,lrd,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = One
  call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrd,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = One
  NAC = ICAN_A(LRA)+LRC
  index_lpext2(ilwei) = NAC
  value_lpext2(ilwei) = One
  ilwei = ilwei+1
end do

end subroutine g10_ext_G

subroutine g5_ext_G(ismd,ic,id)

use gugaci_global, only: ibsm_ext, ican_a, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1, value_lpext2
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ib, ibsta, ilwei, lrb, lrc, lrd, nac, nxo

!write(nf2,*) 'g5_ext'
lrc = norb_number(ic)
lrd = norb_number(id)
ibsta = ibsm_ext(ismd)
do ib=max(ic+1,ibsta),id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(ic,ib)
  call TRANS_IJKL_INTPOS(lrb,lrd,lrc,lrc,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = One
  call TRANS_IJKL_INTPOS(lrb,lrc,lrd,lrc,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = One
  NAC = ICAN_A(LRB)+LRD
  index_lpext2(ilwei) = NAC
  value_lpext2(ilwei) = One
end do

end subroutine g5_ext_G

subroutine g9_ext_G(ismd,ic,id)

use gugaci_global, only: ibsm_ext, ican_a, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1, value_lpext2
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, lra, lrc, lrd, nac, nxo

!write(nf2,*) 'g9_ext'
lrc = norb_number(ic)
lrd = norb_number(id)
iasta = ibsm_ext(ismd)
ilwei = icnt_base+iwt_orb_ext(iasta,ic)
do ia=iasta,ic-1
  lra = norb_number(ia)
  call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrc,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = One
  call TRANS_IJKL_INTPOS(lra,lrc,lrd,lrc,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = One
  NAC = ICAN_A(LRA)+LRD
  index_lpext2(ilwei) = NAC
  value_lpext2(ilwei) = One
  ilwei = ilwei+1
end do

end subroutine g9_ext_G

subroutine ext_lp_ab_s1_G(id)

use gugaci_global, only: ibsm_ext, ican_a, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, ng_sm, norb_number, &
                         v_sqtwo, value_lpext, value_lpext2
use Constants, only: Two
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: id
integer(kind=iwp) :: ia, iasta, ib, ibend, ibsta, ic, ilwei, ismb, lra, lrb, lrc, lrd, nac, nxo

!write(nf2,*) 'ext_lp_ab_s1'
lrd = norb_number(id)
ilwei = icnt_base

do ismb=1,ng_sm
  iasta = ibsm_ext(ismb)
  ibend = iesm_ext(ismb)
  ibsta = iasta+1
  do ib=ibsta,ibend
    lrb = norb_number(ib)
    do ia=iasta,ib-1
      lra = norb_number(ia)
      if ((ib == id) .or. (ia == id)) then
        ! g2   arar+ar(head)ar
        ilwei = ilwei+1
        call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrd,NXO)
        index_lpext(ilwei) = NXO
        value_lpext(ilwei) = v_sqtwo
        index_lpext1(ilwei) = 0
        NAC = ICAN_A(LRA)+LRB
        index_lpext2(ilwei) = NAC
        value_lpext2(ilwei) = v_sqtwo
      else
        ! g6g7g8
        ilwei = ilwei+1
        call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrd,NXO)
        index_lpext(ilwei) = NXO
        value_lpext(ilwei) = v_sqtwo
        index_lpext1(ilwei) = 0
        index_lpext2(ilwei) = 0
      end if
    end do
  end do
end do
! g1
!=======================================================================
! Drr-DRR
! WL=Two but not One is based on that the non-diagonal just uses th
! non-triangle <Ci|H|Cj> which designates that I > J.

do ic=1,id-1
  lrc = norb_number(ic)
  ilwei = ilwei+1
  call TRANS_IJKL_INTPOS(lrc,lrd,lrc,lrd,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = Two
  index_lpext1(ilwei) = 0
  index_lpext2(ilwei) = 0
end do

end subroutine ext_lp_ab_s1_G

subroutine g12_t_diffsym_G(isma,ismb,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

lrc = norb_number(ic)
lrd = norb_number(id)

if (isma < ismb) then
  ibsta = ibsm_ext(ismb)
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

  do ib=ibsta,ibend
    lrb = norb_number(ib)
    do ia=iasta,iaend
      lra = norb_number(ia)
      call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
      index_lpext(ilwei) = NXO
      value_lpext(ilwei) = One
      call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrb,NXO)
      index_lpext1(ilwei) = NXO
      value_lpext1(ilwei) = -One
      index_lpext2(ilwei) = 0
      ilwei = ilwei+1

    end do
  end do
else

  ibsta = ibsm_ext(ismb)+1
  ibend = iesm_ext(ismb)
  iasta = ibsm_ext(isma)
  iaend = iesm_ext(isma)
  ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

  do ib=ibsta,ibend
    lrb = norb_number(ib)
    do ia=iasta,ib-1
      lra = norb_number(ia)
      call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
      index_lpext(ilwei) = NXO
      value_lpext(ilwei) = One
      call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrb,NXO)
      index_lpext1(ilwei) = NXO
      value_lpext1(ilwei) = -One
      index_lpext2(ilwei) = 0
      ilwei = ilwei+1
    end do
  end do
end if

end subroutine g12_t_diffsym_G

subroutine g11a_t_diffsym_G(isma,ismb,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

lrc = norb_number(ic)
lrd = norb_number(id)

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

do ib=ibsta,ibend
  lrb = norb_number(ib)
  do ia=iasta,iaend
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrc,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g11a_t_diffsym_G

subroutine g11b_t_diffsym_G(isma,ismb,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismb, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

lrc = norb_number(ic)
lrd = norb_number(id)

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)    !need checking
do ib=ibsta,ibend
  lrb = norb_number(ib)
  do ia=iasta,iaend
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lrc,lra,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lrc,lrb,lra,lrd,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g11b_t_diffsym_G

subroutine g1112_t_symaaaa_G(isma,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, value_lpext, &
                         value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ic, id
integer(kind=iwp) :: ia, iasta, ib, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

lrc = norb_number(ic)
lrd = norb_number(id)

iasta = ibsm_ext(isma)
ibsta = iasta+1
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)

do ib=ibsta,ic-1
  lrb = norb_number(ib)
  do ia=iasta,ib-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrb,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

do ib=ic+1,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrc,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

do ib=ic+2,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,ib-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lrc,lra,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lrc,lrb,lra,lrd,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g1112_t_symaaaa_G

subroutine g11a11b_t_symaacc_G(isma,ismc,ic,id)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: isma, ismc, ic, id
integer(kind=iwp) :: ia, iaend, iasta, ib, ibsta, ilwei, lra, lrb, lrc, lrd, nxo

lrc = norb_number(ic)
lrd = norb_number(id)

ibsta = ibsm_ext(ismc)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)

do ib=ibsta,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lra,lrc,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lra,lrd,lrb,lrc,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

do ib=ibsta,id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,iaend
    lra = norb_number(ia)
    call TRANS_IJKL_INTPOS(lrc,lra,lrb,lrd,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = One
    call TRANS_IJKL_INTPOS(lrc,lrb,lra,lrd,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -One
    index_lpext2(ilwei) = 0
    ilwei = ilwei+1
  end do
end do

end subroutine g11a11b_t_symaacc_G

subroutine g36_t_ext_G(ismc,ic,id)

use gugaci_global, only: ibsm_ext, ican_a, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1, value_lpext2
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismc, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, lra, lrc, lrd, nac, nxo

lrc = norb_number(ic)
lrd = norb_number(id)
iasta = ibsm_ext(ismc)
ilwei = icnt_base+iwt_orb_ext(iasta,id)
do ia=iasta,ic-1
  lra = norb_number(ia)
  call TRANS_IJKL_INTPOS(lra,lrc,lrd,lrd,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = One
  call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrd,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = -One
  NAC = ICAN_A(LRA)+LRC
  index_lpext2(ilwei) = NAC
  value_lpext2(ilwei) = One
  ilwei = ilwei+1
end do

end subroutine g36_t_ext_G

subroutine g5_t_ext_G(ismd,ic,id)

use gugaci_global, only: ibsm_ext, ican_a, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1, value_lpext2
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ib, ibsta, ilwei, lrb, lrc, lrd, nac, nxo

lrc = norb_number(ic)
lrd = norb_number(id)
ibsta = ibsm_ext(ismd)
do ib=max(ic+1,ibsta),id-1
  lrb = norb_number(ib)
  ilwei = icnt_base+iwt_orb_ext(ic,ib)
  call TRANS_IJKL_INTPOS(lrb,lrd,lrc,lrc,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = One
  call TRANS_IJKL_INTPOS(lrb,lrc,lrd,lrc,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = -One
  NAC = ICAN_A(LRB)+LRD
  index_lpext2(ilwei) = NAC
  value_lpext2(ilwei) = One
end do

end subroutine g5_t_ext_G

subroutine g9_t_ext_G(ismd,ic,id)

use gugaci_global, only: ibsm_ext, ican_a, icnt_base, index_lpext, index_lpext1, index_lpext2, iwt_orb_ext, norb_number, &
                         value_lpext, value_lpext1, value_lpext2
use Constants, only: One
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: ismd, ic, id
integer(kind=iwp) :: ia, iasta, ilwei, lra, lrc, lrd, nac, nxo

lrc = norb_number(ic)
lrd = norb_number(id)
iasta = ibsm_ext(ismd)
ilwei = icnt_base+iwt_orb_ext(iasta,ic)
do ia=iasta,ic-1
  lra = norb_number(ia)
  call TRANS_IJKL_INTPOS(lra,lrd,lrc,lrc,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = -One
  call TRANS_IJKL_INTPOS(lra,lrc,lrd,lrc,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = One
  NAC = ICAN_A(LRA)+LRD
  index_lpext2(ilwei) = NAC
  value_lpext2(ilwei) = -One
  ilwei = ilwei+1
end do

end subroutine g9_t_ext_G

subroutine g31_diffsym_G(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, iwt_orb_ext, m_jd, norb_number, value_lpext, &
                         value_lpext1, w0plp31, w1plp31
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, nxo

LRC = norb_number(m_jd)

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
if (isma == ismb) ibsta = ibsta+1
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)
do ib=ibsta,ibend
  LRB = norb_number(IB)
  if (isma == ismb) iaend = ib-1
  do ia=iasta,iaend
    LRA = norb_number(IA)
    ! g31   type_12 arbrb^ra^r

    call TRANS_IJKL_INTPOS(LRA,LRC,LRB,LRI,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp31
    call TRANS_IJKL_INTPOS(LRA,LRI,LRC,LRB,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = w1plp31

    ilwei = ilwei+1
  end do
end do

end subroutine g31_diffsym_G

subroutine g32a_diffsym_G(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, iwt_orb_ext, m_jd, norb_number, value_lpext, &
                         value_lpext1, w0plp32, w1plp32
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, nxo

LRC = norb_number(m_jd)
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)
do ib=ibsta,ibend
  LRB = norb_number(IB)
  do ia=iasta,iaend
    LRA = norb_number(IA)
    call TRANS_IJKL_INTPOS(LRA,LRI,LRB,LRC,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp32
    call TRANS_IJKL_INTPOS(LRA,LRC,LRB,LRI,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -w1plp32

    ilwei = ilwei+1
  end do
end do

end subroutine g32a_diffsym_G

subroutine g32b_diffsym_G(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, iwt_orb_ext, m_jd, norb_number, value_lpext, &
                         value_lpext1, w0plp32, w1plp32
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ilwei, lra, lrb, lrc, nxo

LRC = norb_number(m_jd)
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
if (ismb == isma) ibsta = ibsta+1
ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)
do ib=ibsta,ibend
  LRB = norb_number(IB)
  do ia=iasta,min(iaend,ib-1)
    LRA = norb_number(IA)
    ! g32b
    call TRANS_IJKL_INTPOS(LRC,LRB,LRA,LRI,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp32
    call TRANS_IJKL_INTPOS(LRC,LRA,LRB,LRI,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -w1plp32

    ilwei = ilwei+1
  end do
end do

end subroutine g32b_diffsym_G

subroutine gsd_samesym_aaa_G(lri,isma)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, iwt_orb_ext, m_jd, norb_number, value_lpext, &
                         value_lpext1, w0g28a, w0plp27, w0plp28, w0plp31, w0plp32, w1plp27, w1plp31, w1plp32
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma
integer(kind=iwp) :: ia, iasta, ib, ibend, ibsta, ic, ilwei, lra, lrb, lrc, nxo

ic = m_jd
lrc = norb_number(ic)

iasta = ibsm_ext(isma)
ibend = iesm_ext(isma)
ibsta = iasta+1

ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)
do ib=ibsta,ic-1
  LRB = norb_number(IB)
  do ia=iasta,ib-1
    LRA = norb_number(IA)
    ! g31   type_12 arbrb^ra^r
    call TRANS_IJKL_INTPOS(LRA,LRC,LRB,LRI,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp31
    call TRANS_IJKL_INTPOS(LRA,LRI,LRC,LRB,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = w1plp31

    ilwei = ilwei+1
  end do
end do

ib = ic
ilwei = icnt_base+iwt_orb_ext(iasta,ib)
do ia=iasta,ib-1
  LRA = norb_number(IA)
  ! g28     Cw-Ar                    330
  call TRANS_IJKL_INTPOS(LRA,LRC,LRI,LRC,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = w0plp28/w0g28a
  call TRANS_IJKL_INTPOS(LRA,LRI,LRC,LRC,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = w0plp28

  ilwei = ilwei+1
end do

ia = ic
do ib=ic+1,ibend
  LRB = norb_number(IB)
  ! g25,g27: Bl(20)-Drl(11)         220

  ilwei = icnt_base+iwt_orb_ext(ic,ib)

  call TRANS_IJKL_INTPOS(LRB,LRC,LRI,LRC,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = w0plp27
  call TRANS_IJKL_INTPOS(LRB,LRI,LRC,LRC,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = -w1plp27

end do

do ib=ic+1,ibend
  LRB = norb_number(IB)

  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    LRA = norb_number(IA)

    ! g32a   type g12
    call TRANS_IJKL_INTPOS(LRA,LRI,LRB,LRC,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp32
    call TRANS_IJKL_INTPOS(LRA,LRC,LRB,LRI,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -w1plp32

    ilwei = ilwei+1
  end do
end do

do ib=ic+2,ibend
  LRB = norb_number(IB)

  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,ib-1
    LRA = norb_number(IA)

    ! g32b  type 11
    call TRANS_IJKL_INTPOS(LRC,LRB,LRA,LRI,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp32
    call TRANS_IJKL_INTPOS(LRC,LRA,LRB,LRI,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -w1plp32

    ilwei = ilwei+1
  end do
end do

end subroutine gsd_samesym_aaa_G

subroutine gsd_diffsamesym_abb_G(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, iwt_orb_ext, m_jd, norb_number, value_lpext, &
                         value_lpext1, w0g28a, w0plp28, w0plp31, w0plp32, w1plp31, w1plp32
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ic, ilwei, lra, lrb, lrc, nxo

ic = m_jd
lrc = norb_number(ic)

iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)
ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)

ilwei = icnt_base+iwt_orb_ext(iasta,ibsta)
do ib=ibsta,ic-1
  LRB = norb_number(IB)
  do ia=iasta,iaend
    LRA = norb_number(IA)

    ! g31   type_12 arbrb^ra^r
    call TRANS_IJKL_INTPOS(LRA,LRC,LRB,LRI,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp31
    call TRANS_IJKL_INTPOS(LRA,LRI,LRC,LRB,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = w1plp31

    ilwei = ilwei+1
  end do
end do

ilwei = icnt_base+iwt_orb_ext(iasta,ic+1)
do ib=ic+1,ibend
  LRB = norb_number(IB)
  do ia=iasta,iaend
    LRA = norb_number(IA)
    ! g32a
    call TRANS_IJKL_INTPOS(LRA,LRI,LRB,LRC,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp32
    call TRANS_IJKL_INTPOS(LRA,LRC,LRB,LRI,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -w1plp32

    ilwei = ilwei+1
  end do
end do

ib = ic
ilwei = icnt_base+iwt_orb_ext(iasta,ib)
do ia=iasta,iaend      !ib-1      !severe_error_1020
  LRA = norb_number(IA)

  ! g28
  call TRANS_IJKL_INTPOS(LRA,LRC,LRI,LRC,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = w0plp28/w0g28a
  call TRANS_IJKL_INTPOS(LRA,LRI,LRC,LRC,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = w0plp28

  ilwei = ilwei+1
end do

end subroutine gsd_diffsamesym_abb_G

subroutine gsd_diffsamesym_aab_G(lri,isma,ismb)

use gugaci_global, only: ibsm_ext, icnt_base, iesm_ext, index_lpext, index_lpext1, iwt_orb_ext, m_jd, norb_number, value_lpext, &
                         value_lpext1, w0plp27, w0plp32, w1plp27, w1plp32
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri, isma, ismb
integer(kind=iwp) :: ia, iaend, iasta, ib, ibend, ibsta, ic, ilwei, lra, lrb, lrc, nxo

ic = m_jd
lrc = norb_number(ic)

ibsta = ibsm_ext(ismb)
ibend = iesm_ext(ismb)
iasta = ibsm_ext(isma)
iaend = iesm_ext(isma)

do ib=ibsta,ibend
  LRB = norb_number(IB)
  ilwei = icnt_base+iwt_orb_ext(iasta,ib)
  do ia=iasta,ic-1
    LRA = norb_number(IA)
    ! g32a
    call TRANS_IJKL_INTPOS(LRA,LRI,LRB,LRC,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp32
    call TRANS_IJKL_INTPOS(LRA,LRC,LRB,LRI,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -w1plp32

    ilwei = ilwei+1
  end do
end do

do ib=ibsta,ibend
  LRB = norb_number(IB)
  ilwei = icnt_base+iwt_orb_ext(ic+1,ib)
  do ia=ic+1,iaend
    LRA = norb_number(IA)
    ! g32b
    call TRANS_IJKL_INTPOS(LRC,LRB,LRA,LRI,NXO)
    index_lpext(ilwei) = NXO
    value_lpext(ilwei) = w0plp32
    call TRANS_IJKL_INTPOS(LRC,LRA,LRB,LRI,NXO)
    index_lpext1(ilwei) = NXO
    value_lpext1(ilwei) = -w1plp32

    ilwei = ilwei+1
  end do
end do

ia = ic
do ib=ibsta,ibend
  LRB = norb_number(IB)
  ! g25
  ilwei = icnt_base+iwt_orb_ext(ic,ib)

  call TRANS_IJKL_INTPOS(LRB,LRC,LRI,LRC,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = w0plp27
  call TRANS_IJKL_INTPOS(LRB,LRI,LRC,LRC,NXO)
  index_lpext1(ilwei) = NXO
  value_lpext1(ilwei) = -w1plp27

end do

end subroutine gsd_diffsamesym_aab_G

subroutine gsd_arlp_s1_G(lri)

use gugaci_global, only: icnt_base, index_lpext, index_lpext1, isegdownwei, m_jd, norb_ext, norb_number, value_lpext, w0plp26, &
                         w0plp29, w0plp30
use Definitions, only: iwp

implicit none
integer(kind=iwp), intent(in) :: lri
integer(kind=iwp) :: ic, ilwei, is1orb, lrc, lrk, nxo

ic = m_jd
lrc = norb_number(ic)

ilwei = icnt_base+isegdownwei-norb_ext+1
do is1orb=1,ic-1
  ! g30 -B^rD^rr
  lrk = norb_number(is1orb)
  call TRANS_IJKL_INTPOS(LRC,LRK,LRI,LRK,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = w0plp30
  index_lpext1(ilwei) = 0

  ilwei = ilwei+1
end do

! g26 -A^r     610
lrk = norb_number(ic)
call TRANS_IJKL_INTPOS(LRC,LRK,LRI,LRK,NXO)
index_lpext(ilwei) = NXO
value_lpext(ilwei) = w0plp26
index_lpext1(ilwei) = 0

ilwei = ilwei+1

! g29 -Dl^rA^l
do is1orb=ic+1,norb_ext
  lrk = norb_number(is1orb)
  call TRANS_IJKL_INTPOS(LRC,LRK,LRI,LRK,NXO)
  index_lpext(ilwei) = NXO
  value_lpext(ilwei) = w0plp29
  index_lpext1(ilwei) = 0

  ilwei = ilwei+1
end do

end subroutine gsd_arlp_s1_G
