!=================================================================

function FouriercomponentCoulombinteractionFZ ( Atmdc, Qx, Qy )
!~ function FouriercomponentCoulombinteractionFZ ( Atmdc, kappavalue, Qx, Qy )
use moduleone
implicit none
real(kind=DP):: FouriercomponentCoulombinteractionFZ
real(kind=DP):: Qx, Qy, QQ, kappavalue, Atmdc, carboncarbondistance

QQ=sqrt(Qx**2+Qy**2)

carboncarbondistance=Atmdc/(sq3)  !! Q^(-1) in unit of ( m )

FouriercomponentCoulombinteractionFZ= 4.0d0*pi*Fine_structure_constant*Planck_constant*speedoflight/( QQ*carboncarbondistance )   !! System International
!~ FouriercomponentCoulombinteractionFZ= 4.0d0*pi*Fine_structure_constant*Planck_constant*speedoflight/( QQ*kappavalue*carboncarbondistance )   !! System International
end

!===========================================================================

subroutine Chargedistribution( RNprime, Doping_way, Nlayer, RNprimelayer )
use moduleone
Implicit real (kind=DP) (a-h,o-z)
integer(kind=4), intent(in):: Doping_way, Nlayer

real(kind=DP), intent(in) :: RNprime
real(kind=DP), dimension(1:3*Nlayer), intent(out) :: RNprimelayer
RNprimelayer(:)=0.d0

if      ( Doping_way==1 ) then
    RNprimelayer(1)=RNprime*0.30d0
    RNprimelayer(2)=RNprime*0.35d0
    RNprimelayer(3)=RNprime-RNprimelayer(2)-RNprimelayer(1)
else if ( Doping_way==2 ) then
    RNprimelayer(1)=RNprime*0.20d0
    RNprimelayer(2)=RNprime*0.60d0
    RNprimelayer(3)=RNprime*0.20d0
else if ( Doping_way==3 ) then
    print*, "This part is not complete. "

else
    print*, "what's the value of Doping_way?"
    stop
end if

end	subroutine Chargedistribution

!===========================================================================

subroutine Kappavalue ( Doping_way, kappa )
use moduleone
Implicit real (kind=DP) (a-h,o-z)
integer(kind=4), intent(in):: Doping_way
real(kind=DP), intent(inout)::   kappa
real(kind=DP) :: A

A=kappa

if      ( Doping_way==1 ) then
    kappa=(A+1.0)/2.0_DP

else if ( Doping_way==2 ) then
    kappa= A
else if ( Doping_way==3 ) then
    print*, "This part is not complete. "

else
    print*, "what's the value of Doping_way?"
    stop
end if

end	subroutine Kappavalue

!===========================================================================
subroutine Counter(A, probability, deltax, Ndimension,  Densityofstate)
use moduleone
Implicit real (kind=DP) (a-h,o-z)

real(kind=DP) :: A,  probability
real(kind=DP), dimension(0:Ndimension-1), intent(INout) :: Densityofstate

!~ real(kind=DP), dimension(0:Ndeltax) :: Densityofstate

Densityofstate(:)=0.d0

If ( (A-Al) .Le. 0.d0 ) then
    print*
    print*, "A = ", A
    print*
    print*, "please have a check the first parameter in subrountine_Counter( .A, ... )"
    stop
end if

kc=Nint((A- Al)/deltaX)

Densityofstate(kc)=Densityofstate(kc)+probability

end	subroutine Counter

!===========================================================================

subroutine   area( Ndimension, Densityofstate, N0, Nend, S )
use moduleone
Implicit real (kind=DP) (a-h,o-z)
real(kind=DP), dimension(0:Ndimension-1), intent(IN) :: Densityofstate

integer(kind=4):: N0, Nend

real(kind=DP) :: S

         S=0.0_DP
              do i=N0+1, Nend-1
                  S=S+Densityofstate(i)
              end do
	 S=S+ (Densityofstate(N0)+Densityofstate(Nend))/2.0_DP

end  subroutine area

!===========================================================================

subroutine  paoguang( Ndimension, Densityofstate )
use moduleone
Implicit real (kind=DP) (a-h,o-z)
real(kind=DP), dimension(0:Ndimension-1), intent(INout) :: Densityofstate
real(kind=DP) :: delta

    delta=1e-6
    do i= 0, Ndimension-1
        y=Densityofstate(i)
        if ( abs(y) .le. 1e-6 ) then
            Densityofstate(i)=0.d0
        end if
    end do

end  subroutine paoguang

!===========================================================================
  subroutine Rnorm(nstates,psi_R,r0)
  use moduleone
        implicit real(kind=DP) (a-h,o-z)
        real(kind=DP) psi_R(0:nstates-1)

        r0=0.0
        do j=0,nstates-1
        r0=r0+psi_R(j)
        enddo
end  subroutine Rnorm

!===========================================================================

subroutine Vfun( kappa, nprime, carriernumber, distanceofinterlayer, Sunitcell,  Vdeta)
use moduleone
implicit none

 integer(KIND=4), intent(in):: carriernumber

 real(kind=DP), intent(in):: nprime, Sunitcell, kappa

 real(kind=DP):: Vdeta,  distanceofinterlayer

  !~ electron=1.60217653*10.0**(-19) !!   unit ( C )
  !~ kappa = (3.90d0+1.0d0)/2.0d0 ;
  !~ epsilong = 8.854187817*10.0**(-12)   !! unit (  F/m  )    F=C/V

Vdeta=0.d0
Vdeta=electron*distanceofinterlayer*carriernumber*nprime/(epsilong*kappa*Sunitcell)    ! UNIT ~ eV

!~ AA    Vdeta=electron*distanceofinterlayer*nprime*carriernumber*10.d0**(-17)/(epsilong*kappa*Sunitcell) ! UNIT ~ eV
end subroutine Vfun

!===========================================================================

subroutine Vfunx( kappa, panduanway ,nprime, carriernumber, distanceofinterlayer, Sunitcell,  Vdeta)
use moduleone
implicit none

 integer(KIND=4), intent(in):: carriernumber, panduanway

 real(kind=DP), intent(in):: nprime, Sunitcell, kappa

 real(kind=DP):: Vdeta,  distanceofinterlayer

 if ( panduanway==1 ) then
        Vdeta=electron*distanceofinterlayer*carriernumber*nprime/(epsilong*kappa*Sunitcell)    ! UNIT ~ eV
    else if ( panduanway==2 ) then
        Vdeta=0.5d0*electron*distanceofinterlayer*carriernumber*nprime/(epsilong*kappa*Sunitcell)    ! UNIT ~ eV
 end if

  !~ electron=1.60217653*10.0**(-19) !!   unit ( C )
  !~ kappa = (3.90d0+1.0d0)/2.0d0 ;
  !~ epsilong = 8.854187817*10.0**(-12)   !! unit (  F/m  )    F=C/V

Vdeta=electron*distanceofinterlayer*carriernumber*nprime/(epsilong*kappa*Sunitcell)    ! UNIT ~ eV

!~ AA    Vdeta=electron*distanceofinterlayer*nprime*carriernumber*10.d0**(-17)/(epsilong*kappa*Sunitcell) ! UNIT ~ eV
end subroutine Vfunx

!===========================================================================

subroutine Efun(kappa, nprime, Efiled)    !! nprime  UNIT   (     10^{13} cm^{-2}   )
use moduleone
 implicit none
 real(kind=DP), intent(in):: kappa, nprime     !! UNIT   (     10^{13} cm^{-2}   )

 real(kind=DP), intent(out):: Efiled

  !~ electron=1.60217653*10.0**(-19) !!   unit ( C )

  !~ kappa = (3.90d0+1.0d0)/2.0d0 ;

  !~ epsilong = 8.854187817*10.0**(-12)   !! unit (  F/m  )    F=C/V

   !! nprime  UNIT   (     10^{13} cm^{-2}   )

Efiled=electron*nprime*10.d0**(8)/(2.0d0*epsilong*kappa)    !! UNIT  (    V/nm   )

end subroutine Efun

!===========================================================================

subroutine EfunIIT( kappa, nprime, Efiled )    !! nprime  UNIT   (     10^{13} cm^{-2}   )
use moduleone
 implicit none
 real(kind=DP), intent(in):: nprime, kappa     !! UNIT   (     10^{13} cm^{-2}   )

 real(kind=DP), intent(out):: Efiled

  !~ electron=1.60217653*10.0**(-19) !!   unit ( C )

  !~ kappa = (3.90d0+1.0d0)/2.0d0 ;

  !~ epsilong = 8.854187817*10.0**(-12)   !! unit (  F/m  )    F=C/V

Efiled=electron*nprime*10.d0**(8)/(2.0d0*epsilong*kappa)    !! UNIT  (    V/nm   )

end subroutine EfunIIT

!===========================================================================

function FermiDistribution (E,Ef,Beta)
use moduleone
    implicit none
    real(kind=DP):: FermiDistribution,E,Ef,Beta
    integer imax
    imax=100
    FermiDistribution=Beta*(E-Ef)
    if (FermiDistribution>imax) then
    FermiDistribution=0.
    else if (FermiDistribution<-imax) then
    FermiDistribution=1.
    else
    FermiDistribution=1.+dexp(FermiDistribution)
    FermiDistribution=1./FermiDistribution
    end if
    end

!=================================================================

function FouriercomponentCoulombinteractionFME ( Atmdc, kappavalue, Qx, Qy )
use moduleone
implicit none
    real(kind=DP):: FouriercomponentCoulombinteractionFME, Qx, Qy, QQ, kappavalue
    real(kind=DP):: electron_hat_2, Atmdc, AtmdcII
    real(kind=DP):: carboncarbondistance

    QQ=sqrt(Qx**2+Qy**2)
    !! shengjun note 78page due to the CGS units
    electron_hat_2=1.4399644d0
    AtmdcII=Atmdc*10.0**(10)
    carboncarbondistance=AtmdcII/(sq3)     !!Q^(-1) in unit of ( nm )

    FouriercomponentCoulombinteractionFME= 2.0d0*pi*electron_hat_2/(QQ*kappavalue*carboncarbondistance)   !! System International

end

!!~ FouriercomponentCoulombinteraction= 2.0d0*pi*electron_hat_2/(Qx*kappa*carboncarbondistance)   !! System International
!!~ real(kind=DP) :: electron=1.60217653*10.0**(-19) !!   unit ( C )
!!~ real(kind=DP) :: kappa = (3.90d0+1.0d0)/2.0d0 ;
!!~ real(kind=DP) :: epsilong = 8.854187817*10.0**(-12)   !! unit (  F/m  )    F=C/V
! 1.4399644d0/( t(eV) a(nm) )
!=================================================================

!~ function CGSzhuanhuan( Atmdc)
!~ use moduleone
!~ implicit none
!~ real(kind=DP):: CGSzhuanhuan, Atmdc
!~ real(kind=DP):: e_cgs
    !~ Atmdc=Atmdc*10.0**(10)
    !~ carboncarbondistance=Atmdc/(sq3)
    !~ e_cgs  = 4.80320427_dp*10.0_dp**(-10)  ! statcoulomb
    !~ ev_cgs = 1.0_dp/( 299.792458_dp*4.80320427_dp*10.0_dp**(-10) )
    !~ FouriercomponentCoulombinteraction= 2.0d0*pi*electron_hat_2/(Qx*kappa)   !! System International
!~ end
!=================================================================

!~ ============================================================
subroutine Bond_integrals ( Tswitch, Delta0, Delta1, Delta2, DeltaP, DeltaZ, &
        & V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi, &
		& V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp)
!~ ============================================================
	use moduleone
	use moduletwo
	implicit real (kind=DP) (a-h, o-z)

	integer (kind=4), intent(in) :: Tswitch

	real (kind=DP) :: Delta0, Delta1, Delta2, DeltaP, DeltaZ
	real (kind=DP) :: V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi
	real (kind=DP) :: V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp

	!~ ================================
	!	MoS2
	if (Tswitch==1) then
		Delta0=Delta0_MoS2
		Delta1=Delta1_MoS2
		Delta2=Delta2_MoS2
		DeltaP=DeltaP_MoS2
		DeltaZ=DeltaZ_MoS2
		V_pd_sigma=V_pd_sigma_MoS2
		V_pd_pi=V_pd_pi_MoS2
		V_dd_sigma=V_dd_sigma_MoS2
		V_dd_pi=V_dd_pi_MoS2
		V_dd_delta=V_dd_delta_MoS2
		V_pp_sigma=V_pp_sigma_MoS2
		V_pp_pi=V_pp_pi_MoS2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_MoS2
		V_pp_pi_interlayer=V_pp_pi_interlayer_MoS2
		SOC_dd=SOC_dd_MoS2
		SOC_pp=SOC_pp_MoS2
	!	WS2
	else if (Tswitch==2) then
		Delta0=Delta0_WS2
		Delta1=Delta1_WS2
		Delta2=Delta2_WS2
		DeltaP=DeltaP_WS2
		DeltaZ=DeltaZ_WS2
		V_pd_sigma=V_pd_sigma_WS2
		V_pd_pi=V_pd_pi_WS2
		V_dd_sigma=V_dd_sigma_WS2
		V_dd_pi=V_dd_pi_WS2
		V_dd_delta=V_dd_delta_WS2
		V_pp_sigma=V_pp_sigma_WS2
		V_pp_pi=V_pp_pi_WS2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_WS2
		V_pp_pi_interlayer=V_pp_pi_interlayer_WS2
		SOC_dd=SOC_dd_WS2
		SOC_pp=SOC_pp_WS2
	!	MoSe2
	else if (Tswitch==3) then
		Delta0=Delta0_MoSe2
		Delta1=Delta1_MoSe2
		Delta2=Delta2_MoSe2
		DeltaP=DeltaP_MoSe2
		DeltaZ=DeltaZ_MoSe2
		V_pd_sigma=V_pd_sigma_MoSe2
		V_pd_pi=V_pd_pi_MoSe2
		V_dd_sigma=V_dd_sigma_MoSe2
		V_dd_pi=V_dd_pi_MoSe2
		V_dd_delta=V_dd_delta_MoSe2
		V_pp_sigma=V_pp_sigma_MoSe2
		V_pp_pi=V_pp_pi_MoSe2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_MoSe2
		V_pp_pi_interlayer=V_pp_pi_interlayer_MoSe2
		SOC_dd=SOC_dd_MoSe2
		SOC_pp=SOC_pp_MoSe2
	!	WSe2
	else if (Tswitch==4) then
		Delta0=Delta0_WSe2
		Delta1=Delta1_WSe2
		Delta2=Delta2_WSe2
		DeltaP=DeltaP_WSe2
		DeltaZ=DeltaZ_WSe2
		V_pd_sigma=V_pd_sigma_WSe2
		V_pd_pi=V_pd_pi_WSe2
		V_dd_sigma=V_dd_sigma_WSe2
		V_dd_pi=V_dd_pi_WSe2
		V_dd_delta=V_dd_delta_WSe2
		V_pp_sigma=V_pp_sigma_WSe2
		V_pp_pi=V_pp_pi_WSe2
		V_pp_sigma_interlayer=V_pp_sigma_interlayer_WSe2
		V_pp_pi_interlayer=V_pp_pi_interlayer_WSe2
		SOC_dd=SOC_dd_WSe2
		SOC_pp=SOC_pp_WSe2
	end if

!~ ============================================
end subroutine Bond_integrals
!~ ============================================

!~ ============================================================
subroutine PP_Bonds_Family( Tswitch, Sx, Sy, Sz, &
        & E_x_x, E_x_y, E_x_z, E_y_x,  E_y_y , E_y_z, &
		& E_z_x,  E_z_y , E_z_z)
!~ ============================================================
	use moduleone
	use moduletwo
	implicit real (kind=DP) (a-h, o-z)

	integer (kind=4), intent(in) :: Tswitch

	real (kind=DP) :: Delta0, Delta1, Delta2, DeltaP, DeltaZ
	real (kind=DP) :: V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi
	real (kind=DP) :: V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp
	real (kind=DP) :: Vn, Vx2, Vy2, Vz2

	real (kind=DP), intent(in) :: Sx, Sy, Sz

	real (kind=DP), intent(out) :: E_x_x, E_x_y, E_x_z, &
		& E_y_x,  E_y_y , E_y_z ,  E_z_x,  E_z_y , E_z_z

	Vn=sqrt( Sx**2+Sy**2+Sz**2  )
	Vx=  Sx/Vn  ;       Vy= Sy/Vn  ;      Vz= Sz/Vn
    Vx2=Vx**2
	Vy2=Vy**2
	Vz2=Vz**2

	call Bond_integrals ( Tswitch, Delta0, Delta1, Delta2, DeltaP, DeltaZ, &
        & V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi, &
		& V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp)

	E_x_x = Vx2*V_pp_sigma+(1.d0-Vx2)*V_pp_pi

	E_x_y = Vx*Vy*( V_pp_sigma - V_pp_pi )

	E_x_z = Vx*Vz*( V_pp_sigma - V_pp_pi )

	E_y_x = E_x_y

	E_y_y = Vy2*V_pp_sigma+(1.d0-Vy2)*V_pp_pi

	E_y_z = Vy*Vz*( V_pp_sigma - V_pp_pi )

	E_z_x = E_x_z

	E_z_y = E_y_z

	E_z_z = Vz2*V_pp_sigma+(1.d0-Vz2)*V_pp_pi

!~ ============================================
end subroutine PP_Bonds_Family
!~ ============================================

!~ ============================================================
subroutine PPINTERLAYER_Bonds_Family( Tswitch, Sx, Sy, Sz, &
        & E_x_x, E_x_y, E_x_z, E_y_x,  E_y_y , E_y_z, &
		& E_z_x,  E_z_y , E_z_z)
!~ ============================================================
	use moduleone
	use moduletwo
	implicit real (kind=DP) (a-h, o-z)

	integer (kind=4), intent(in) :: Tswitch

	real (kind=DP) :: Delta0, Delta1, Delta2, DeltaP, DeltaZ
	real (kind=DP) :: V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi
	real (kind=DP) :: V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp
	real (kind=DP) :: Vn, Vx2, Vy2, Vz2

	real (kind=DP), intent(in) :: Sx, Sy, Sz

	real (kind=DP), intent(out) :: E_x_x, E_x_y, E_x_z, &
		& E_y_x,  E_y_y , E_y_z ,  E_z_x,  E_z_y , E_z_z

	Vn=sqrt( Sx**2+Sy**2+Sz**2  )
	Vx=  Sx/Vn  ;       Vy= Sy/Vn  ;      Vz= Sz/Vn
    Vx2=Vx**2
	Vy2=Vy**2
	Vz2=Vz**2

	call Bond_integrals ( Tswitch, Delta0, Delta1, Delta2, DeltaP, DeltaZ, &
        & V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi, &
		& V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp)

	E_x_x = Vx2*V_pp_sigma_interlayer+(1.d0-Vx2)*V_pp_pi_interlayer

	E_x_y = Vx*Vy*( V_pp_sigma_interlayer - V_pp_pi_interlayer )

	E_x_z = Vx*Vz*( V_pp_sigma_interlayer - V_pp_pi_interlayer )

	E_y_x = E_x_y

	E_y_y = Vy2*V_pp_sigma_interlayer+(1.d0-Vy2)*V_pp_pi_interlayer

	E_y_z = Vy*Vz*( V_pp_sigma_interlayer - V_pp_pi_interlayer )

	E_z_x = E_x_z

	E_z_y = E_y_z

	E_z_z = Vz2*V_pp_sigma_interlayer+(1.d0-Vz2)*V_pp_pi_interlayer

!~ ============================================
end subroutine PPINTERLAYER_Bonds_Family
!~ ============================================

!~ ============================================================
subroutine PD_Bonds_Family( Tswitch, Sx, Sy, Sz, &
        & E_x_xy,  E_x_yz,  E_x_xz,  E_x_x2y2, E_x_z2, &
		& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
		& E_z_xy,  E_z_yz ,  E_z_xz,  E_z_x2y2 , E_z_z2)
!~ ============================================================
	use moduleone
	use moduletwo
	implicit real (kind=DP) (a-h, o-z)

	integer (kind=4), intent(in) :: Tswitch

	real (kind=DP) :: Delta0, Delta1, Delta2, DeltaP, DeltaZ
	real (kind=DP) :: V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi
	real (kind=DP) :: V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp
	real (kind=DP) :: Vn, Vx2, Vy2, Vz2

	real (kind=DP), intent(in) :: Sx, Sy, Sz

	real (kind=DP), intent(out) :: E_x_xy, E_x_yz, E_x_xz, E_x_x2y2, E_x_z2, &
		& E_y_xy,  E_y_yz , E_y_xz , E_y_x2y2 , E_y_z2, &
		& E_z_xy,  E_z_yz , E_z_xz , E_z_x2y2 , E_z_z2

	Vn=sqrt( Sx**2+Sy**2+Sz**2  )
	Vx=  Sx/Vn  ;       Vy= Sy/Vn  ;      Vz= Sz/Vn
    Vx2=Vx**2
	Vy2=Vy**2
	Vz2=Vz**2

	call Bond_integrals ( Tswitch, Delta0, Delta1, Delta2, DeltaP, DeltaZ, &
        & V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi, &
		& V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp)

	E_x_xy =sq3*Vx2*Vy*V_pd_sigma+Vy*(1-2.0d0*Vx2)*V_pd_pi

	E_x_yz =Vx*Vy*Vz*(sq3*V_pd_sigma-2.0d0*V_pd_pi)

	E_x_xz =sq3*Vx2*Vz*V_pd_sigma+Vz*(1-2.0d0*Vx2)*V_pd_pi

	E_x_x2y2 =0.5d0*sq3*Vx*(Vx2-Vy2)*V_pd_sigma +Vx*(1.0d0-Vx2+Vy2)*V_pd_pi

	E_x_z2 =Vx*( Vz2-0.5d0*(Vx2+Vy2) )*V_pd_sigma - sq3*Vx*Vz2*V_pd_pi

	E_y_xy =sq3*Vy2*Vx*V_pd_sigma+Vx*(1-2.0d0*Vy2)*V_pd_pi

	E_y_yz =sq3*Vy2*Vz*V_pd_sigma+Vz*(1-2.0d0*Vy2)*V_pd_pi

	E_y_xz =Vy*Vx*Vz*(sq3*V_pd_sigma-2.0d0*V_pd_pi)

	E_y_x2y2 =0.5d0*sq3*Vy*(Vx2-Vy2)*V_pd_sigma - Vy*(1.0d0+Vx2-Vy2)*V_pd_pi

	E_y_z2 =Vy*( Vz2-0.5d0*(Vx2+Vy2) )*V_pd_sigma - sq3*Vy*Vz2*V_pd_pi

	E_z_xy =Vz*Vx*Vy*(sq3*V_pd_sigma-2.0d0*V_pd_pi)

	E_z_yz =sq3*Vz2*Vy*V_pd_sigma+Vy*(1-2.0d0*Vz2)*V_pd_pi

	E_z_xz =sq3*Vz2*Vx*V_pd_sigma+Vx*(1-2.0d0*Vz2)*V_pd_pi

	E_z_x2y2 =Vz*(Vx2-Vy2)*(0.5d0*sq3*V_pd_sigma-V_pd_pi)

	E_z_z2 =Vz*( Vz2-0.5d0*(Vx2+Vy2) )*V_pd_sigma + sq3*Vz*(Vx2+Vy2)*V_pd_pi

!~ ============================================
end subroutine PD_Bonds_Family
!~ ============================================

!~ ============================================================
subroutine DD_Bonds_Family( Tswitch, Sx, Sy, Sz, &
	& E_xy_xy, E_xy_yz, E_xy_xz, E_xy_x2y2, E_xy_z2, &
	& E_yz_xy,  E_yz_yz , E_yz_xz , E_yz_x2y2 , E_yz_z2, &
	& E_xz_xy,  E_xz_yz , E_xz_xz , E_xz_x2y2 , E_xz_z2, &
	& E_x2y2_xy,  E_x2y2_yz , E_x2y2_xz , E_x2y2_x2y2 , E_x2y2_z2, &
	& E_z2_xy,  E_z2_yz , E_z2_xz , E_z2_x2y2 , E_z2_z2 )
!~ ============================================================
	use moduleone
	use moduletwo
	implicit real (kind=DP) (a-h, o-z)

	integer (kind=4), intent(in) :: Tswitch

	real (kind=DP) :: Delta0, Delta1, Delta2, DeltaP, DeltaZ
	real (kind=DP) :: V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi
	real (kind=DP) :: V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp
	real (kind=DP) :: Vn, Vx2, Vy2, Vz2

	real (kind=DP), intent(in) :: Sx, Sy, Sz

	real (kind=DP), intent(out) :: E_xy_xy, E_xy_yz, E_xy_xz, E_xy_x2y2, E_xy_z2, &
		& E_yz_xy,  E_yz_yz , E_yz_xz , E_yz_x2y2 , E_yz_z2, &
		& E_xz_xy,  E_xz_yz , E_xz_xz , E_xz_x2y2 , E_xz_z2, &
		& E_x2y2_xy,  E_x2y2_yz , E_x2y2_xz , E_x2y2_x2y2 , E_x2y2_z2, &
		& E_z2_xy,  E_z2_yz , E_z2_xz , E_z2_x2y2 , E_z2_z2

	Vn=sqrt( Sx**2+Sy**2+Sz**2  )
	Vx=  Sx/Vn  ;       Vy= Sy/Vn  ;      Vz= Sz/Vn
    Vx2=Vx**2
	Vy2=Vy**2
	Vz2=Vz**2

	call Bond_integrals ( Tswitch, Delta0, Delta1, Delta2, DeltaP, DeltaZ, &
        & V_pd_sigma, V_pd_pi, V_dd_sigma, V_dd_pi, V_dd_delta, V_pp_sigma, V_pp_pi, &
		& V_pp_sigma_interlayer,   V_pp_pi_interlayer,   SOC_dd,  SOC_pp)

	E_xy_xy =3.0d0*Vx2*Vy2*V_dd_sigma + (Vx2+Vy2-4.0*Vx2*Vy2)*V_dd_pi + (Vz2+Vx2*Vy2)*V_dd_delta
	E_xy_yz =3.0d0*Vx*Vy2*Vz*V_dd_sigma + Vx*Vz*(1.0d0-4.0*Vy2)*V_dd_pi + Vx*Vz*(Vy2-1.0d0)*V_dd_delta
	E_xy_xz =3.0d0*Vx2*Vy*Vz*V_dd_sigma + Vy*Vz*(1.0d0-4.0*Vx2)*V_dd_pi + Vy*Vz*(Vx2-1.0d0)*V_dd_delta
	E_xy_x2y2 =1.5d0*Vx*Vy*(Vx2-Vy2)*V_dd_sigma + 2.0d0*Vx*Vy*(Vy2-Vx2)*V_dd_pi + 0.5d0*Vx*Vy*(Vx2-Vy2)*V_dd_delta
	E_xy_z2 =sq3*Vx*Vy*(Vz2-0.5d0*Vx2-0.5d0*Vy2)*V_dd_sigma + 2.0d0*sq3*Vx*Vy*Vz2*V_dd_pi + 0.5d0*sq3*Vx*Vy*(1.0d0+Vz2)*V_dd_delta

	E_yz_xy =3.0d0*Vx*Vy2*Vz*V_dd_sigma + Vx*Vz*(1.0d0-4.0*Vy2)*V_dd_pi + Vx*Vz*(Vy2-1.0d0)*V_dd_delta
	E_yz_yz =3.0d0*Vy2*Vz2*V_dd_sigma + (Vy2+Vz2-4.0*Vy2*Vz2)*V_dd_pi + (Vx2+Vy2*Vz2)*V_dd_delta
	E_yz_xz =3.0d0*Vy*Vz2*Vx*V_dd_sigma + Vy*Vx*(1.0d0-4.0*Vz2)*V_dd_pi + Vy*Vx*(Vz2-1.0d0)*V_dd_delta
	E_yz_x2y2 =1.5d0*Vy*Vz*(Vx2-Vy2)*V_dd_sigma - Vy*Vz*(1.0d0+2.0d0*(Vx2-Vy2) )*V_dd_pi + Vy*Vz*(1.d0+0.5d0*(Vx2-Vy2) )*V_dd_delta
	E_yz_z2 =sq3*Vy*Vz*(Vz2-0.5d0*Vx2-0.5d0*Vy2)*V_dd_sigma + sq3*Vy*Vz*(Vx2+Vy2-Vz2)*V_dd_pi - 0.5d0*sq3*Vy*Vz*(Vx2+Vy2)*V_dd_delta

	E_xz_xy =E_xy_xz
	E_xz_yz =E_yz_xz
	E_xz_xz =3.0d0*Vz2*Vx2*V_dd_sigma + (Vz2+Vx2-4.0*Vx2*Vz2)*V_dd_pi + (Vy2+Vx2*Vz2)*V_dd_delta
	E_xz_x2y2 =1.5d0*Vx*Vz*(Vx2-Vy2)*V_dd_sigma + Vz*Vx*(1.0d0-2.0d0*(Vx2-Vy2))*V_dd_pi - Vx*Vz*(1.0d0-0.50d0*(Vx2-Vy2))*V_dd_delta
	E_xz_z2 =sq3*Vx*Vz*(Vz2-0.5d0*Vx2-0.5d0*Vy2)*V_dd_sigma + sq3*Vx*Vz*(Vx2+Vy2-Vz2)*V_dd_pi - 0.5d0*sq3*Vx*Vz*(Vx2+Vy2)*V_dd_delta

	E_x2y2_xy =E_xy_x2y2
	E_x2y2_yz =E_yz_x2y2
	E_x2y2_xz =E_xz_x2y2
	E_x2y2_x2y2 =3.0d0/4.0d0*(Vx2-Vy2)**2*V_dd_sigma + (Vx2+Vy2-(Vx2-Vy2)**2)*V_dd_pi + (Vz2+0.25d0*(Vx2-Vy2)**2 )*V_dd_delta
	E_x2y2_z2 =0.5d0*sq3*(Vx2-Vy2)*(Vz2-0.50d0*(Vx2+Vy2)) *V_dd_sigma + sq3*Vz2*(Vy2-Vx2)*V_dd_pi + 0.25d0*sq3*(1.0d0+Vz2)*(Vx2-Vy2)*V_dd_delta

	E_z2_xy =E_xy_z2
	E_z2_yz =E_yz_z2
	E_z2_xz =E_xz_z2
	E_z2_x2y2 =E_x2y2_z2
	E_z2_z2 =  (Vz2-0.50d0*(Vx2+Vy2) )**2*V_dd_sigma + 3.0d0*Vz2*(Vx2+Vy2)*V_dd_pi +0.75d0*(Vx2+Vy2)**2*V_dd_delta

!~ ============================================
end subroutine DD_Bonds_Family
!~ ============================================


!---------------------------------------------------------------------------------------------------
!
! filename = coupling.f90
! authors = Edison Salazar
!           Pedro Guarderas
! date = 11/01/2014
!
!---------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------
! Module for constructing Khon-Sham equations
module coupling
  use base
  implicit none

contains

!---------------------------------------------------------------------------------------------------
! Building Khon-Shan system of equations
subroutine buildKS( H, T, nc, e, ne, l, d, n, m )
  implicit none
  integer, intent( in ) :: n, m, d(n+1)
  double precision, intent( in ) :: l(n), nc(m), e(m), ne(n)
  double precision, intent( out ) ::  H(m,m), T(m,m)
  integer :: i, j, k, Mi, Ni
  double precision :: nrmj, nrmk

  !$omp parallel do private(i,j) shared(H,T) collapse(2)
  do i = 1,m
     do j = 1,m
        T(i,j) = 0.0D0
        H(i,j) = 0.0D0
     end do
  end do

  Mi = 1
  Ni = 0

!   !$omp parallel do private(i) shared(j,k,nrmj,nrmk,d,nc,ne,e,H,T)
  do i = 1,n

      Mi = Mi + d( i )
      Ni = d( i + 1 ) + Mi - 1

      do j = Mi,Ni
          nrmj = 1.0D0 / sqrt( STOnorm( 2.0D0 * nc(j), 2.0D0 * e(j) ) )
        do k = Mi,Ni

          nrmk = 1.0D0 / sqrt( STOnorm( 2.0D0 * nc(k), 2.0D0 * e(k) ) )

          T( j, k ) = 0.5D0 * ne(i) * nrmj * nrmk * ( &
            ( nc(j) - 1.0D0 ) * ( nc(k) - 1.0D0 ) * &
            STOnorm( nc(j) + nc(k) - 2.0D0, e(j) + e(k) ) - &

            ( ( nc(j) - 1.0D0 ) * e(k) + ( nc(k) - 1.0D0 ) * e(j) ) * &
            STOnorm( nc(j) + nc(k) - 1.0D0, e(j) + e(k) ) + &

            e(j) * e(k) * &
            STOnorm( nc(j) + nc(k), e(j) + e(k) ) + &

            l(i) * ( l(i) + 1.0D0 ) * &
            STOnorm( nc(j) + nc(k) - 2.0D0, e(j) + e(k) ) )

           H( j, k ) = ne(i) * dgamma( nc(j) + nc(k) + 1.0D0 ) * &
            ( e(j) + e(k) )**( -nc(j) - nc(k) - 1.0D0 ) * nrmk * nrmj

        end do
     end do

  end do

end subroutine buildKS

!---------------------------------------------------------------------------------------------------
! Compute the potential
subroutine effectivePotential( Vef, V, p, r, th, Nr, Nth )
  implicit none
  integer, intent( in ) :: Nr, Nth
  double precision, intent( in ) :: r(Nr), th(Nth), p(Nr,Nth), V( Nr, Nth, Nr, Nth )
  double precision, intent( out ) :: Vef(Nr,Nth)
  integer :: i, j, k, l
  double precision :: dx, dy

  !$omp parallel do private(i,j,k,l,dx,dy) shared(Vef,V,p,th) collapse(4)
  do i = 1,Nr
    do j = 1,Nth
      do k = 2,Nr
        do l = 2,Nth
          if ( i /= k .and. j /= l ) then
            dx = r( k ) - r( k - 1 );
            dy = th( l ) - th( l - 1 );
            Vef( i, j ) = Vef( i, j ) + p( k, l ) * V( i, j, k, l ) * &
              sin( th(l) ) * dx * dy;
          end if
        end do
      end do
    end do
  end do

end subroutine effectivePotential

end module coupling


	! integrates the driven hmf model by rk4 method

	implicit none

	integer, parameter :: mm=1000,nn=2*mm
	integer, parameter :: nh=20,tran=90000,iter=100000
	double precision   :: xx(nn),yy(nn),dy(nn)
	double precision   :: tau,dtau,r,phi,grnd
	double precision   :: KK,a,w
	integer            :: i,j,k,l,m,n,tran1,itlen
	double precision   :: KE,PE,H,H0,U0,pRange,Uavg,Tavg,Ravg

	common KK

	call sgrnd(201)

	open (unit=1,file='amp0.5a.dat')

	tau=0.0d0; dtau=0.01d0
	tran1=tran+1; itlen=iter-tran

	a=0.50d0

	do m = 1, 1	! drive frequency

	w=.5d0

	do n = 1, 10	! initial energy

	U0=n*0.01d0; H0=U0*mm
	Uavg=0.0d0; Tavg=0.0d0; Ravg=0.0d0

	do k = 1, nh	! history

	KK=a

	do i = 1, mm
	yy(i) = 0.01*(grnd()-0.5d0)
	end do

	PE = 0.0d0
	do i = 1, mm
	do j = 1, mm
	PE = PE + dcos(yy(i)-yy(j))
	end do
	end do
	PE = (KK/nn)*(mm**2-PE)

	pRange = 2.0d0*dsqrt((12.0d0/nn)*(H0-PE))

	do i = mm+1, nn
        yy(i) = pRange*(grnd()-0.5d0)
        end do

	KE = 0.0d0
	do i = mm+1, nn
	KE = KE + yy(i)**2
	end do
	KE = KE/2.0d0

	do i = mm+1, nn
	yy(i) = yy(i) * dsqrt((H0-PE)/KE)
	end do

	do l = 1, tran	! transients

	KK = abs(a*dcos(w*l*dtau))

	call derivs(tau,yy,dy)
        call rk4(yy,dy,nn,tau,dtau,xx,derivs)

	yy = xx

	end do	! transients

	do l = tran1, iter	! iterations

	KK = abs(a*dcos(w*l*dtau))

	call derivs(tau,yy,dy)
        call rk4(yy,dy,nn,tau,dtau,xx,derivs)

	yy = xx

	call order_parameter(xx,r,phi)

	KE = 0.0d0
	do i = mm+1, nn
	KE = KE + yy(i)**2
	end do
	KE = KE/2.0d0

	PE = 0.0d0
	do i = 1, mm
	do j = 1, mm
	PE = PE + dcos(yy(i)-yy(j))
	end do
	end do
	PE = (KK/nn)*(mm**2-PE)

	H = PE + KE

	!write(1,'(41(xf12.6))') H/mm, 2*KE/mm, r

	Uavg = Uavg + H/mm
	Tavg = Tavg + 2*KE/mm
	Ravg = Ravg + r

	end do	! iterations

        end do	! history

	Uavg = Uavg/(nh*itlen)
	Tavg = Tavg/(nh*itlen)
	Ravg = Ravg/(nh*itlen)

	write(1,'(100(xf12.6))') U0, Uavg, Tavg, Ravg

	end do	! initial energy

	write(1,'(100(xf12.6))')

	end do	! drive frequency

	end program

	! calculates the time derivative

        subroutine derivs(tau,yy,dy)

        integer, parameter :: mm=1000, nn=2*mm
	double precision   :: yy(nn), dy(nn)
	double precision   :: tau, dtau
	integer            :: i, j, k, l, m, n
        double precision   :: KK, r, phi

	common KK

	call order_parameter(yy,r,phi)

        do i = 1, mm
        dy(i) = yy(mm+i)
        end do
	do i = mm+1, nn
        dy(i) = KK*r*dsin(phi-yy(i-mm))
        end do

        return
        end subroutine

	! finds the magnitude and phase of the order parameter

	subroutine order_parameter(theta,r,phi)

        integer, parameter :: mm=1000, nn=2*mm
        double precision   :: theta(nn)
        double precision   :: r, phi, real_sum, imag_sum

        real_sum = 0.0d0
        imag_sum = 0.0d0

        do j=1,mm
        real_sum = real_sum + dcos(theta(j))
        imag_sum = imag_sum + dsin(theta(j))
        enddo

        real_sum = real_sum/mm
        imag_sum = imag_sum/mm
        r = dsqrt((real_sum)**2 + (imag_sum)**2)
        phi = dacos(real_sum/r)

        return
        end

	SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)

	INTEGER n,NMAX
	REAL*8 h,x,dydx(n),y(n),yout(n)
	EXTERNAL derivs
	PARAMETER (NMAX=2000)
	INTEGER i
	REAL*8 h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)

	hh=h*0.5
	h6=h/6.
	xh=x+hh

	do i=1,n
        yt(i)=y(i)+hh*dydx(i)
	end do

	call derivs(xh,yt,dyt)
	do i=1,n
        yt(i)=y(i)+hh*dyt(i)
	end do

	call derivs(xh,yt,dym)
	do i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
	end do

	call derivs(x+h,yt,dyt)
	do i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
	end do

	return
	END

	include 'mt.f'


      SUBROUTINE PCGQS(NN,AA,LENAA,MAXA,PP,YP,RHO,START,WORK,IFLAG)
C
C THIS SUBROUTINE SOLVES A SYSTEM OF EQUATION USING THE METHOD OF
C CONJUGATE GRADIENTS.  THE SYSTEM TO BE SOLVED IS IN THE FORM
C
C   (AUG)*X = B,
C
C WHERE
C
C            +--          --+        +-    -+
C            |        |     |        |      |
C            |   AA   | -PP |        |      |
C      AUG = |        |     | ,  B = | -RHO |
C            +--------------+        |      |
C            |      YP      |        |      |
C            +--          --+        +-    -+
C
C
C
C THE SYSTEM IS SOLVED BY SPLITTING  AUG  INTO TWO MATRICES
C AUG = M + L,  WHERE
C
C       +-        -+                                +-     -+
C       |      |   |                                |       |
C       |  AA  | C |                                | -PP-C |
C   M = |      |   |  ,  L = U * [E(NN+1)**T],  U = |       | ,
C       +------+---+                                +-------+
C       |  C   | D |                                |   0   |
C       +-        -+                                +-     -+
C
C E(NN+1) IS THE (NN+1) X 1 VECTOR CONSISTING OF ALL ZEROS EXCEPT FOR
C A '1' IN ITS LAST POSITION.
C
C THE FINAL SOLUTION VECTOR,  X,  IS GIVEN BY
C
C            +-                                    -+
C            |           [SOL(U)]*[E(NN+1)**T]      |
C       X =  | I  -  -----------------------------  | * SOL(B)
C            |        {[(SOL(U))**T]*E(NN+1)}+1.0   |
C            +-                                    -+
C
C WHERE SOL(A)=[M**(-1)]*A.  THE TWO SYSTEMS  (MZ=U, MZ=B) ARE SOLVED
C BY A PRECONDITIONED CONJUGATE GRADIENT ALGORITHM.
C
C
C ON INPUT:
C
C NN  = THE DIMENSION OF THE MATRIX PACKED IN AA.
C
C AA(1:LENAA)  CONTAINS THE MATRIX  AA,  STORED IN PACKED SKYLINE
C    FORMAT.  LENAA  AND  MAXA  DESCRIBE THE DATA STRUCTURE.
C
C LENAA  = THE LENGTH OF THE ONE-DIMENSIONAL ARRAY  AA.
C
C MAXA(1:NN+2)  IN ITS FIRST  N+1  COMPONENTS CONTAINS THE INDICES OF
C    THE DIAGONAL ELEMENTS OF THE MATRIX STORED IN  AA.
C    MAXA(NN+2)  IS ASSIGNED THE VALUE  LENNAA + NN + 2.
C
C    AS AN EXAMPLE OF THE PACKED SKYLINE STORAGE FORMAT, CONSIDER THE
C    SYMMETRIC MATRIX
C
C
C                +--             --+
C                |  1  3  0  0  0  |
C                |  3  2  0  7  0  |
C                |  0  0  4  6  0  |
C                |  0  7  6  5  9  |
C                |  0  0  0  9  8  |
C                +--             --+
C
C    THIS WOULD RESULT IN  NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,16),
C    AND  AA=(1,2,3,4,5,6,7,8,9).
C
C PP(1:NN)  = THE NEGATIVE OF THE LAST COLUMN OF  AUG.
C
C YP(1:NN+1)  = THE LAST ROW OF  AUG.
C
C RHO(1:NN+1)  = THE NEGATIVE OF THE RIGHT HAND SIDE OF THE EQUATION TO
C    BE SOLVED.
C
C WORK(1:6*(NN+1)+LENAA)  IS A WORK ARRAY DIVIDED UP AS FOLLOWS:
C
C    WORK(1:NN+1) = TEMPORARY WORKING STORAGE.
C
C    WORK(NN+2:2*NN+2) = INTERMEDIATE SOLUTION VECTOR Z FOR  MZ=U.
C       THE INPUT VALUE IS USED AS THE INITIAL ESTIMATE FOR Z.
C
C    WORK(2*NN+3:3*NN+3) = INTERMEDIATE SOLUTION VECTOR Z FOR  MZ=B.
C
C    WORK(3*NN+4:4*NN+4) = STORAGE FOR THE RESIDUAL VECTORS.
C
C    WORK(4*NN+5:5*NN+5) = STORAGE FOR THE DIRECTION VECTORS.
C
C    WORK(5*NN+6:6*NN+6+LENAA) = STORAGE FOR THE PRECONDITIONING
C       MATRIX Q.
C
C
C ON OUTPUT:
C
C NN, AA, LENAA, MAXA, PP, YP, AND RHO  ARE UNCHANGED.
C
C START(1:N+1)  CONTAINS THE SOLUTION VECTOR  X.
C
C IFLAG  IS UNCHANGED UNLESS THE CONJUGATE GRADIENT ITERATION
C    FAILS TO CONVERGE IN 10*(NN+1) ITERATIONS (MOST LIKELY DUE
C    TO A SINGULAR JACOBIAN MATRIX).  IN THIS CASE,  PCGQS  RETURNS
C    IFLAG = 4, AND DOES NOT COMPUTE  X.
C
C
C CALLS  D1MACH, DAXPY, DCOPY, DDOT, DNRM2, DSCAL, GMFADS, MULTDS,
C    SOLVDS.
C
C ***** DECLARATIONS *****
C
C     FUNCTION DECLARATIONS
C
        DOUBLE PRECISION D1MACH, DDOT, DNRM2
C
C     LOCAL VARIABLES
C
        DOUBLE PRECISION AB, AU, BB, BU, DZNRM, PBNPRD, PUNPRD,
     $     RBNPRD, RBTOL, RNPRD, RUNPRD, RUTOL, TEMP, ZLEN, ZTOL
        INTEGER DIR, IMAX, J, LENQ, NP1, Q, RES, ZB, ZU
        LOGICAL STILLU, STILLB
C
C     SCALAR ARGUMENTS
C
        INTEGER NN, LENAA, IFLAG
C
C     ARRAY DECLARATIONS
C
        DOUBLE PRECISION AA(LENAA), PP(NN), YP(NN+1), RHO(NN+1),
     $     START(NN+1), WORK(6*(NN+1)+LENAA)
        INTEGER MAXA(NN+2)
C
C ***** END OF DECLARATIONS *****
C
C ***** FIRST EXECUTABLE STATEMENT *****
C
C SET UP BASES FOR VECTORS STORED IN WORK ARRAY.
C
      NP1=NN+1
      ZU=NN+2
      ZB=(2*NN)+3
      RES=(3*NN)+4
      DIR=(4*NN)+5
      Q=(5*NN)+6
C
C INITIALIZE  PRECONDITIONING MATRIX  Q,  SET VALUES OF  MAXA(NN+1)
C AND  MAXA(NN+2),  COMPUTE PRECONDITIONER.
C
      CALL DCOPY(LENAA,AA,1,WORK(Q),1)
      CALL DCOPY(NP1,YP,1,WORK(Q+LENAA),1)
      MAXA(NN+1)=LENAA+1
      MAXA(NN+2)=LENAA+NN+2
      LENQ = MAXA(NN+2)-1
      CALL GMFADS(NP1,WORK(Q),LENQ,MAXA)
C
C COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA.
C
      CALL DCOPY(NN,PP,1,WORK,1)
      WORK(NP1)=0.0
      CALL DAXPY(NP1,1.0D0,YP,1,WORK,1)
      IMAX=10*NP1
      STILLU=.TRUE.
      STILLB=.TRUE.
      ZTOL=100.0*D1MACH(4)
      RUTOL=ZTOL*DNRM2(NP1,WORK,1)
      RBTOL=ZTOL*DNRM2(NP1,RHO,1)
C
C ***** END OF INITIALIZATION *****
C
C ***** SOLVE SYSTEM  M Z = U *****
C
C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M Z = U .
C     RES = (Q**(-1))*(U - M*Z.)
*
      CALL MULTDS(WORK(RES),AA,WORK(ZU),MAXA,NN,LENAA)
      WORK(RES+NN)= DDOT(NN,YP,1,WORK(ZU),1)
      CALL DAXPY(NP1,WORK(ZU+NN),YP,1,WORK(RES),1)
      CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
      CALL DAXPY(NN,-1.0D0,PP,1,WORK(RES),1)
      CALL DAXPY(NN,-1.0D0,YP,1,WORK(RES),1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C COMPUTE INITIAL DIRECTION VECTOR.
C     DIR = (A**T)*(Q**(-T))*RES.
C
      CALL DCOPY(NP1,WORK(RES),1,WORK,1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
      CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
      WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
      CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C COMPUTE INITIAL INNER PRODUCTS.
C
      RUNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
      PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C REPEAT UNTIL CONVERGENCE OR TOO MANY ITERATIONS.
C
      J=1
C
C     DO WHILE ((STILLU) .AND. (J .LE. IMAX))
100   IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
C
         IF (SQRT(RUNPRD) .GT. RUTOL) THEN
C
C           IF DIRECTION VECTOR IS ZERO, THEN RE-COMPUTE RESIDUAL,
C           DIRECTION VECTOR, AND INNER PRODUCTS FROM SCRATCH
C           (RATHER THAN FROM UPDATES OF PREVIOUS VALUES).
C
            IF (PUNPRD .EQ. 0.0) THEN
C
C              COMPUTE RESIDUAL.
C
               CALL MULTDS(WORK(RES),AA,WORK(ZU),MAXA,NN,LENAA)
               WORK(RES+NN)= DDOT(NN,YP,1,WORK(ZU),1)
               CALL DAXPY(NP1,WORK(ZU+NN),YP,1,WORK(RES),1)
               CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
               CALL DAXPY(NN,-1.0D0,PP,1,WORK(RES),1)
               CALL DAXPY(NN,-1.0D0,YP,1,WORK(RES),1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C              COMPUTE DIRECTION VECTOR.
C
               CALL DCOPY(NP1,WORK(RES),1,WORK,1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
               CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
               WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
               CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C              COMPUTE INNER PRODUCTS
C
               RUNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
               PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C              CHECK FOR CONVERGENCE.
C
               IF (SQRT(RUNPRD) .LE. RUTOL) THEN
                  STILLU=.FALSE.
               ENDIF
            ENDIF
            IF (STILLU) THEN
C
C              UPDATE SOLUTION VECTOR.
C                Z = Z + AU*DIR, WHERE AU= RUNPRD/PUNPRD.
C
               AU=RUNPRD/PUNPRD
               CALL DAXPY(NP1,AU,WORK(DIR),1,WORK(ZU),1)
C
C              COMPUTE RELATIVE CHANGE IN THE SOLUTION.
C
               DZNRM=AU*SQRT(PUNPRD)
               ZLEN=DNRM2(NP1,WORK(ZU),1)
C
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
C
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE.
            ENDIF
         ELSE
            STILLU=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR  MZ=U  HAVE BEEN MET, UPDATE RESIDUAL,
C          DIRECTION VECTORS, AND INNER PRODUCTS FOR NEXT ITERATION.
C
         IF (STILLU) THEN
C
C           UPDATE RESIDUAL VECTOR; COMPUTE <RES,RES>.
C             RES = RES - AU*(Q**(-1))*M*DIR.
C
            CALL MULTDS(WORK,AA,WORK(DIR),MAXA,NN,LENAA)
            WORK(NP1)=DDOT(NN,YP,1,WORK(DIR),1)
            CALL DAXPY(NP1,WORK(DIR+NN),YP,1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL DAXPY(NP1,-AU,WORK,1,WORK(RES),1)
            RNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
C
C           UPDATE DIRECTION VECTOR; COMPUTE <DIR,DIR>.
C             DIR = (M**T)*(Q**(-T))*RES + BU*DIR,
C             WHERE  BU = RNPRD/RUNPRD. (NOTE: START IS USED AS
C             A WORK ARRAY HERE).
C
            BU=RNPRD/RUNPRD
            RUNPRD=RNPRD
            CALL DCOPY(NP1,WORK(RES),1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=DDOT(NN,YP,1,WORK,1)
            CALL DAXPY(NP1,WORK(NP1),YP,1,START,1)
            CALL DAXPY(NP1,BU,WORK(DIR),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(DIR),1)
            PUNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
         ENDIF
C
         J=J+1
      GO TO 100
200   CONTINUE
C     END DO
C
C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE.
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C ***** END OF M Z = U SYSTEM *****
C
C ***** SOLVE SYSTEM M Z = B *****
C
C
C COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M Z = B .
C
      CALL MULTDS(WORK(RES),AA,WORK(ZB),MAXA,NN,LENAA)
      WORK(RES+NN)=DDOT(NN,YP,1,WORK(ZB),1)
      CALL DAXPY(NP1,WORK(ZB+NN),YP,1,WORK(RES),1)
      CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
      CALL DAXPY(NP1,-1.0D0,RHO,1,WORK(RES),1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C COMPUTE INITIAL DIRECTION VECTOR.
C
      CALL DCOPY(NP1,WORK(RES),1,WORK,1)
      CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
      CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
      WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
      CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C COMPUTE INITIAL INNER PRODUCTS.
C
      RBNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
      PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C REPEAT UNTIL CONVERGENCE, OR TOO MANY ITERATIONS.
C
      J=1
C
C     DO WHILE ( STILLB  .AND. (J .LE. IMAX) )
300   IF (.NOT. ( STILLB  .AND. (J .LE. IMAX) ) ) GO TO 400
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
C
         IF (SQRT(RBNPRD) .GT. RBTOL) THEN
C
C           IF DIRECTION VECTOR IS ZERO, RE-COMPUTE RESIDUAL,
C             DIRECTION VECTOR, AND INNER PRODUCTS FROM SCRATCH.
C
            IF (PBNPRD .EQ. 0.0) THEN
C
C              COMPUTE RESIDUAL.
C
               CALL MULTDS(WORK(RES),AA,WORK(ZB),MAXA,NN,LENAA)
               WORK(RES+NN)=DDOT(NN,YP,1,WORK(ZB),1)
               CALL DAXPY(NP1,WORK(ZB+NN),YP,1,WORK(RES),1)
               CALL DSCAL(NP1,-1.0D0,WORK(RES),1)
               CALL DAXPY(NP1,-1.0D0,RHO,1,WORK(RES),1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK(RES))
C
C              COMPUTE DIRECTION VECTOR.
C
               CALL DCOPY(NP1,WORK(RES),1,WORK,1)
               CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
               CALL MULTDS(WORK(DIR),AA,WORK,MAXA,NN,LENAA)
               WORK(DIR+NN)=DDOT(NN,YP,1,WORK,1)
               CALL DAXPY(NP1,WORK(NP1),YP,1,WORK(DIR),1)
C
C              COMPUTE INNER PRODUCTS.
C
               RBNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
               PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
C
C              CHECK FOR CONVERGENCE.
C
               IF (SQRT(RBNPRD) .LE. RBTOL) THEN
                  STILLB=.FALSE.
               ENDIF
            ENDIF
            IF (STILLB) THEN
C
C              UPDATE SOLUTION VECTOR.
C                Z = Z + AB*DIR, WHERE AB=RBNPRD/PBNPRD.
C
               AB=RBNPRD/PBNPRD
               CALL DAXPY(NP1,AB,WORK(DIR),1,WORK(ZB),1)
C
C              COMPUTE RELATIVE CHANGE IN SOLUTIONS.
C
               DZNRM=AB*SQRT(PBNPRD)
               ZLEN=DNRM2(NP1,WORK(ZB),1)
C
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
C
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE.
            ENDIF
         ELSE
            STILLB=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR  MZ=B  HAVE BEEN MET, UPDATE RESIDUAL,
C          DIRECTION VECTORS, AND INNER PRODUCTS.
C
         IF (STILLB) THEN
C
C           UPDATE RESIDUAL VECTOR; COMPUTE <RES,RES>.
C             RES = RES - AB*(Q**(-1))*M*DIR.
C
            CALL MULTDS(WORK,AA,WORK(DIR),MAXA,NN,LENAA)
            WORK(NP1)=DDOT(NN,YP,1,WORK(DIR),1)
            CALL DAXPY(NP1,WORK(DIR+NN),YP,1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL DAXPY(NP1,-AB,WORK,1,WORK(RES),1)
            RNPRD=DDOT(NP1,WORK(RES),1,WORK(RES),1)
C
C           UPDATE DIRECTION VECTOR; COMPUTE <DIR,DIR>.
C             DIR = (M**T)*(Q**(-T))*RES + BB*DIR,
C             WHERE BB=RNPRD/RBNPRD.
C           (NOTE:  START IS USED AS A WORK ARRAY HERE).
C
            BB=RNPRD/RBNPRD
            RBNPRD=RNPRD
            CALL DCOPY(NP1,WORK(RES),1,WORK,1)
            CALL SOLVDS(NP1,WORK(Q),LENQ,MAXA,WORK)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=DDOT(NN,YP,1,WORK,1)
            CALL DAXPY(NP1,WORK(NP1),YP,1,START,1)
            CALL DAXPY(NP1,BB,WORK(DIR),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(DIR),1)
            PBNPRD=DDOT(NP1,WORK(DIR),1,WORK(DIR),1)
         ENDIF
C
         J=J+1
      GO TO 300
400   CONTINUE
C     END DO
C
C SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE.
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C ***** END OF  M Z = B  SYSTEM *****
C
C COMPUTE FINAL SOLUTION VECTOR  X,  AND RETURN IT IN START.
C
      TEMP=-WORK(ZB+NN)/(1.0D0+WORK(ZU+NN))
      CALL DCOPY(NP1,WORK(ZB),1,START,1)
      CALL DAXPY(NP1,TEMP,WORK(ZU),1,START,1)
C
      RETURN
      END


subroutine sort_to_diagonal(A, ind, n)
  IMPLICIT NONE
  COMPLEX*16, intent(in)  :: A(n,n)
  INTEGER, intent(out)    :: ind(n)
  INTEGER, intent(in)     :: n
  ! locals
  COMPLEX*16 :: Anew(n,n)
  REAL*8     :: column(n), m
  INTEGER    :: wind(n,n), cind(n), unique(n), towork(n), degenerate(n), present_(n), missing(n), tocorrect(n)
  INTEGER    :: i, j, current, t_size, d_size, m_size, ti, tii, ic, c
  LOGICAL    :: ind_in_deg
  wind=0
  do i=1,N
     cind = (/(j,j=1,n)/)
     column = abs(A(:,i))
     call SSORT(column, cind, n)
     wind(i,:) = cind
  enddo
  ind = wind(:,1)
  !print *, 'ind=', ind-1

  unique=(/(1,j=1,n)/)

  do i=1,n
     current = ind(i)
     do j=i+1,n
        if (ind(j) .eq. current) then
           unique(i)=0
           unique(j)=0
        endif
     enddo
  enddo
  !print *, 'unique=', unique

  t_size=0
  do i=1,n
     if (unique(i).eq.0) then
        t_size = t_size+1
        towork(t_size) = i
     endif
  enddo

  d_size=0
  do i=1,n
     if (unique(i).eq.0) then
        ind_in_deg=.false.
        do j=1,d_size
           if (ind(i).eq.degenerate(j)) ind_in_deg=.true.
        enddo
        if (.not. ind_in_deg) then
           d_size = d_size + 1
           degenerate(d_size) = ind(i)
        endif
     endif
  enddo
  !print *, 'degenerate:', degenerate(:d_size)

  present_=0
  do i=1,n
     do j=1,n
        if (ind(j).eq.i) present_(i)=1
     enddo
  enddo
  !print *, 'present=', present_

  m_size=0
  do i=1,n
     if (present_(i).eq.0) then
        m_size = m_size+1
        missing(m_size) = i
     endif
  enddo
  !print *, 'missing are:', missing(:m_size)

  tocorrect(:m_size) = missing(:m_size)
  tocorrect(m_size+1:m_size+d_size) = degenerate(:d_size)

  !print *, 'correct=', tocorrect(:m_size+d_size)
  !print *, 'towork=', towork(:t_size)

  do ic=1,m_size+d_size
     c = tocorrect(ic)
     ti = towork(1)
     tii=1
     m = abs(A(c,ti))
     do i=2,t_size
        if (abs(A(c,towork(i))) .gt. m) then
           ti = towork(i)
           tii=i
           m = abs(A(c,ti))
        endif
     enddo
     ind(ti)=c

     ! towork.remove(ti)
     do i=tii,t_size-1
        towork(i) = towork(i+1)
     enddo
     t_size = t_size-1
  enddo
  !print *, 'final ind=', ind-1

  !do i=1,n
  !   Anew(:,ind(i)) = A(:,i)
  !enddo
  !A(:,:) = Anew(:,:)

end subroutine sort_to_diagonal

SUBROUTINE SSORT(X, IY, N)
  IMPLICIT NONE
  !    Example of a Selection Sort   Using a Fortran 90 Intrinsic Function
  !***BEGIN PROLOGUE  SSORT
  !***PURPOSE  Sort an array and make the same interchanges in
  !            an auxiliary array.  The array is sorted in
  !            decreasing order.
  !***TYPE      SINGLE PRECISION
  !***KEYWORDS  SORT, SORTING
  !
  !   Description of Parameters
  !      X - array of values to be sorted   (usually abscissas)
  !      IY - array to be carried with X (all swaps of X elements are
  !          matched in IY .  After the sort IY(J) contains the original
  !          postition of the value X(J) in the unsorted X array.
  !      N - number of values in array X to be sorted
  INTEGER, intent(in) :: N
  !     .. Array Arguments ..  -----NOTE the 2 new ways of declaring array size
  REAL*8, intent(inout)  :: X(N)
  INTEGER, intent(inout) :: IY(N)
  !     .. Local Scalars ..
  REAL TEMP
  INTEGER I, ISWAP(1), ITEMP, ISWAP1
  !     .. Intrinsic Functions ..
  INTRINSIC MAXLOC
  !    MAXLOC is a FORTRAN 90 function that returns the index value for the
  !    maximum element in the array
  !***FIRST EXECUTABLE STATEMENT  SSORT
  !
  DO I=1,N-1
     ISWAP=MAXLOC(X(I:N))
     ISWAP1=ISWAP(1)+I-1
     IF(ISWAP1.NE.I) THEN
        TEMP=X(I)
        X(I)=X(ISWAP1)
        X(ISWAP1)=TEMP
        ITEMP=IY(I)
        IY(I)=IY(ISWAP1)
        IY(ISWAP1)=ITEMP
     ENDIF
  END DO
  RETURN
END SUBROUTINE SSORT


!*==dgebal.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DGEBAL
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGEBAL + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOB
!       INTEGER            IHI, ILO, INFO, LDA, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), SCALE( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGEBAL balances a general real matrix A.  This involves, first,
!> permuting A by a similarity transformation to isolate eigenvalues
!> in the first 1 to ILO-1 and last IHI+1 to N elements on the
!> diagonal; and second, applying a diagonal similarity transformation
!> to rows and columns ILO to IHI to make the rows and columns as
!> close in norm as possible.  Both steps are optional.
!>
!> Balancing may reduce the 1-norm of the matrix, and improve the
!> accuracy of the computed eigenvalues and/or eigenvectors.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOB
!> \verbatim
!>          JOB is CHARACTER*1
!>          Specifies the operations to be performed on A:
!>          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
!>                  for i = 1,...,N;
!>          = 'P':  permute only;
!>          = 'S':  scale only;
!>          = 'B':  both permute and scale.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the input matrix A.
!>          On exit,  A is overwritten by the balanced matrix.
!>          If JOB = 'N', A is not referenced.
!>          See Further Details.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] ILO
!> \verbatim
!>          ILO is INTEGER
!> \endverbatim
!> \param[out] IHI
!> \verbatim
!>          IHI is INTEGER
!>          ILO and IHI are set to integers such that on exit
!>          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
!>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Details of the permutations and scaling factors applied to
!>          A.  If P(j) is the index of the row and column interchanged
!>          with row and column j and D(j) is the scaling factor
!>          applied to row and column j, then
!>          SCALE(j) = P(j)    for j = 1,...,ILO-1
!>                   = D(j)    for j = ILO,...,IHI
!>                   = P(j)    for j = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-1.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2017
!
!> \ingroup doubleGEcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The permutations consist of row and column interchanges which put
!>  the matrix in the form
!>
!>             ( T1   X   Y  )
!>     P A P = (  0   B   Z  )
!>             (  0   0   T2 )
!>
!>  where T1 and T2 are upper triangular matrices whose eigenvalues lie
!>  along the diagonal.  The column indices ILO and IHI mark the starting
!>  and ending columns of the submatrix B. Balancing consists of applying
!>  a diagonal similarity transformation inv(D) * B * D to make the
!>  1-norms of each row of B and its corresponding column nearly equal.
!>  The output matrix is
!>
!>     ( T1     X*D          Y    )
!>     (  0  inv(D)*B*D  inv(D)*Z ).
!>     (  0      0           T2   )
!>
!>  Information about the permutations P and the diagonal matrix D is
!>  returned in the vector SCALE.
!>
!>  This subroutine is based on the EISPACK routine BALANC.
!>
!>  Modified by Tzu-Yi Chen, Computer Science Division, University of
!>    California at Berkeley, USA
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DGEBAL(Job,N,A,Lda,Ilo,Ihi,Scale,Info)
      IMPLICIT NONE
!*--DGEBAL164
!
!  -- LAPACK computational routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      CHARACTER Job
      INTEGER Ihi , Ilo , Info , Lda , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , Scale(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
      DOUBLE PRECISION SCLFAC
      PARAMETER (SCLFAC=2.0D+0)
      DOUBLE PRECISION FACTOR
      PARAMETER (FACTOR=0.95D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL noconv
      INTEGER i , ica , iexc , ira , j , k , l , m
      DOUBLE PRECISION c , ca , f , g , r , ra , s , sfmax1 , sfmax2 ,  &
     &                 sfmin1 , sfmin2
!     ..
!     .. External Functions ..
      LOGICAL DISNAN , LSAME
      INTEGER IDAMAX
      DOUBLE PRECISION DLAMCH , DNRM2
      EXTERNAL DISNAN , LSAME , IDAMAX , DLAMCH , DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL DSCAL , DSWAP , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN
!     ..
!     Test the input parameters
!
      Info = 0
      IF ( .NOT.LSAME(Job,'N') .AND. .NOT.LSAME(Job,'P') .AND.          &
     &     .NOT.LSAME(Job,'S') .AND. .NOT.LSAME(Job,'B') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGEBAL',-Info)
         RETURN
      ENDIF
!
      k = 1
      l = N
!
      IF ( N==0 ) GOTO 700
!
      IF ( LSAME(Job,'N') ) THEN
         DO i = 1 , N
            Scale(i) = ONE
         ENDDO
         GOTO 700
      ENDIF
!
!
!     Permutation to isolate eigenvalues if possible
!
      IF ( .NOT.(LSAME(Job,'S')) ) GOTO 200
      GOTO 600
!
!     Row and column exchange.
!
 100  Scale(m) = j
      IF ( j/=m ) THEN
!
         CALL DSWAP(l,A(1,j),1,A(1,m),1)
         CALL DSWAP(N-k+1,A(j,k),Lda,A(m,k),Lda)
      ENDIF
!
      IF ( iexc==2 ) THEN
!
!     Search for columns isolating an eigenvalue and push them left.
!
         k = k + 1
         GOTO 400
      ELSE
!
!     Search for rows isolating an eigenvalue and push them down.
!
         IF ( l==1 ) GOTO 700
         l = l - 1
      ENDIF
!
 200  DO j = l , 1 , -1
!
         DO i = 1 , l
            IF ( i/=j ) THEN
               IF ( A(j,i)/=ZERO ) GOTO 300
            ENDIF
         ENDDO
!
         m = l
         iexc = 1
         GOTO 100
!
 300  ENDDO
!
 400  DO j = k , l
!
         DO i = k , l
            IF ( i/=j ) THEN
               IF ( A(i,j)/=ZERO ) GOTO 500
            ENDIF
         ENDDO
!
         m = k
         iexc = 2
         GOTO 100
 500  ENDDO
!
 600  DO i = k , l
         Scale(i) = ONE
      ENDDO
!
      IF ( .NOT.(LSAME(Job,'P')) ) THEN
!
!     Balance the submatrix in rows K to L.
!
!     Iterative loop for norm reduction
!
         sfmin1 = DLAMCH('S')/DLAMCH('P')
         sfmax1 = ONE/sfmin1
         sfmin2 = sfmin1*SCLFAC
         sfmax2 = ONE/sfmin2
         DO
!
            noconv = .FALSE.
!
            DO i = k , l
!
               c = DNRM2(l-k+1,A(k,i),1)
               r = DNRM2(l-k+1,A(i,k),Lda)
               ica = IDAMAX(l,A(1,i),1)
               ca = ABS(A(ica,i))
               ira = IDAMAX(N-k+1,A(i,k),Lda)
               ra = ABS(A(i,ira+k-1))
!
!        Guard against zero C or R due to underflow.
!
               IF ( c/=ZERO .AND. r/=ZERO ) THEN
                  g = r/SCLFAC
                  f = ONE
                  s = c + r
                  DO WHILE ( c<g .AND. MAX(f,c,ca)<sfmax2 .AND.         &
     &                       MIN(r,g,ra)>sfmin2 )
                     IF ( DISNAN(c+f+ca+r+g+ra) ) THEN
!
!           Exit if NaN to avoid infinite loop
!
                        Info = -3
                        CALL XERBLA('DGEBAL',-Info)
                        RETURN
                     ENDIF
                     f = f*SCLFAC
                     c = c*SCLFAC
                     ca = ca*SCLFAC
                     r = r/SCLFAC
                     g = g/SCLFAC
                     ra = ra/SCLFAC
                  ENDDO
!
                  g = c/SCLFAC
                  DO WHILE ( g>=r .AND. MAX(r,ra)<sfmax2 .AND.          &
     &                       MIN(f,c,g,ca)>sfmin2 )
                     f = f/SCLFAC
                     c = c/SCLFAC
                     g = g/SCLFAC
                     ca = ca/SCLFAC
                     r = r*SCLFAC
                     ra = ra*SCLFAC
                  ENDDO
!
!        Now balance.
!
                  IF ( (c+r)<FACTOR*s ) THEN
                     IF ( f<ONE .AND. Scale(i)<ONE ) THEN
                        IF ( f*Scale(i)<=sfmin1 ) CYCLE
                     ENDIF
                     IF ( f>ONE .AND. Scale(i)>ONE ) THEN
                        IF ( Scale(i)>=sfmax1/f ) CYCLE
                     ENDIF
                     g = ONE/f
                     Scale(i) = Scale(i)*f
                     noconv = .TRUE.
!
                     CALL DSCAL(N-k+1,g,A(i,k),Lda)
                     CALL DSCAL(l,f,A(1,i),1)
                  ENDIF
               ENDIF
!
            ENDDO
!
            IF ( .NOT.(noconv) ) EXIT
         ENDDO
      ENDIF
!
 700  Ilo = k
      Ihi = l
!
!
!     End of DGEBAL
!
      END SUBROUTINE DGEBAL


module pde2d_base_mod
  use psb_base_mod, only : psb_dpk_
  real(psb_dpk_), save, private :: epsilon=1.d0/80
contains
  subroutine pde2d_set_parm(dat)
    real(psb_dpk_), intent(in) :: dat
    epsilon = dat
  end subroutine pde2d_set_parm
  !
  ! functions parametrizing the differential equation
  !
  function b1(x,y)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) :: b1
    real(psb_dpk_), intent(in) :: x,y
    b1 = 1.d0/1.414d0
  end function b1
  function b2(x,y)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  b2
    real(psb_dpk_), intent(in) :: x,y
    b2 = 1.d0/1.414d0
  end function b2
  function c(x,y)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  c
    real(psb_dpk_), intent(in) :: x,y
    c = 0.d0
  end function c
  function a1(x,y)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  a1
    real(psb_dpk_), intent(in) :: x,y
    a1=1.d0*epsilon
  end function a1
  function a2(x,y)
    use psb_base_mod, only : psb_dpk_
    real(psb_dpk_) ::  a2
    real(psb_dpk_), intent(in) :: x,y
    a2=1.d0*epsilon
  end function a2
  function g(x,y)
    use psb_base_mod, only : psb_dpk_, done, dzero
    real(psb_dpk_) ::  g
    real(psb_dpk_), intent(in) :: x,y
    g = dzero
    if (x == done) then
      g = done
    else if (x == dzero) then
      g = done
    end if
  end function g
end module pde2d_base_mod


      SUBROUTINE SCOMQR(NM,N,LOW,IGH,HR,HI,Z,IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-01-24 SCOMQR Krogh  CSQRT -> CSQRTX to avoid C lib. conflicts.
c>> 1996-04-27 SCOMQR Krogh  Changes to use .C. and C%%.
c>> 1996-03-30 SCOMQR Krogh  Added external statement.
C>> 1996-01-18 SCOMQR Krogh  Added M77CON statements for conv. to C.
C>> 1995-01-03 SCOMQR WVS  Added EXTERNAL CQUO, CSQRT so VAX won't gripe
C>> 1992-03-13 SCOMQR FTK  Removed implicit statements.
C>> 1987-11-12 SCOMQR Lawson  Initial code.
c--S Replaces "?": ?COMQR
c--C (Type) Replaces "?": ?QUO, ?SQRTX
c     ------------------------------------------------------------------
c     Version of the Eispack subr, COMQR, for use in the JPL MATH77
c     library.  C. L. Lawson, JPL, 1987 Feb 17.
c     ------------------------------------------------------------------
      EXTERNAL R1MACH
      INTEGER EN,ENM1,I,IERR,IGH,ITS,J,L,LL,LOW,LP1,N,NM
      REAL             R1MACH,HI(NM,N),HR(NM,N),MACHEP
      REAL             NORM,SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR
c++ Default NO_COMPLEX = .C. | (.N. == 'D')
c++ Default COMPLEX = ~NO_COMPLEX
c++ CODE for COMPLEX is active
      COMPLEX Z(N), Z3
c++ CODE for NO_COMPLEX is inactive
C++ Replace "SCABS" = .N.//.Y.//"ABS"
C      EXTERNAL SCABS
C      REAL             SCABS, Z(2*N), Z1(2), Z2(2)
C      REAL             ZDENOM(2),ZIN(2),ZNUM(2),ZOUT(2),ZQUOT(2)
C      EXTERNAL CQUO, CSQRTX
c++ END
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
C          INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
C          THE REDUCTION BY  CORTH, IF PERFORMED.
C
C     ON OUTPUT-
C
C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
C          CALLING  COMQR  IF SUBSEQUENT CALCULATION OF
C          EIGENVECTORS IS TO BE PERFORMED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     ARITHMETIC IS REAL EXCEPT FOR THE REPLACEMENT OF THE ALGOL
C     PROCEDURE CDIV BY COMPLEX DIVISION AND USE OF THE SUBROUTINES
C     SQRT AND CMPLX IN COMPUTING COMPLEX SQUARE ROOTS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
      MACHEP = R1MACH(4)
C
      IERR = 0
      IF (LOW .EQ. IGH) GO TO 180
C     ********** CREATE REAL SUBDIAGONAL ELEMENTS **********
      L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0) GO TO 170
c++ CODE for COMPLEX is active
         NORM = ABS(CMPLX(HR(I,I-1),HI(I,I-1)))
c++ CODE for NO_COMPLEX is inactive
C         Z1(1) = HR(I,I-1)
C         Z1(2) = HR(I,I-1)
C         NORM = SCABS(Z1)
c++ END
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.0
C
         DO 155 J = I, IGH
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = LOW, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
  170 CONTINUE
C     ********** STORE ROOTS ISOLATED BY CBAL **********
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
c++ CODE for COMPLEX is active
         Z(I) = CMPLX(HR(I,I),HI(I,I))
c++ CODE for NO_COMPLEX is inactive
C         Z(2*I-1) = HR(I,I)
C         Z(2*I) = HI(I,I)
c++ END
  200 CONTINUE
C
      EN = IGH
      TR = 0.0
      TI = 0.0
C     ********** SEARCH FOR NEXT EIGENVALUE **********
  220 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      ENM1 = EN - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW  -- **********
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         IF (ABS(HR(L,L-1)) .LE.
     X      MACHEP * (ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
     X             + ABS(HR(L,L)) +ABS(HI(L,L)))) GO TO 300
  260 CONTINUE
C     ********** FORM SHIFT **********
  300 IF (L .EQ. EN) GO TO 660
      IF (ITS .EQ. 30) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0 .AND. XI .EQ. 0.0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0
      YI = (HI(ENM1,ENM1) - SI) / 2.0
c++ CODE for COMPLEX is active
      Z3 = SQRT(CMPLX(YR**2-YI**2+XR,2.0*YR*YI+XI))
      ZZR = REAL(Z3)
      ZZI = AIMAG(Z3)
c++ CODE for NO_COMPLEX is inactive
C      ZIN(1) = YR**2 - YI**2 + XR
C      ZIN(2) = 2.E0*YR*YI + XI
C      CALL CSQRTX(ZIN,ZOUT)
C      ZZR = ZOUT(1)
C      ZZI = ZOUT(2)
c++ END
      IF (YR * ZZR + YI * ZZI .GE. 0.0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CONTINUE
c++ CODE for COMPLEX is active
      Z3 = CMPLX(XR,XI) / CMPLX(YR+ZZR,YI+ZZI)
      SR = SR - REAL(Z3)
      SI = SI - AIMAG(Z3)
c++ CODE for NO_COMPLEX is inactive
C      ZNUM(1) = XR
C      ZNUM(2) = XI
C      ZDENOM(1) = YR + ZZR
C      ZDENOM(2) = YI + ZZI
Cc                      CQUO computes quotient of two complex numbers.
C      CALL CQUO(ZNUM,ZDENOM,ZQUOT)
C      SR = SR - ZQUOT(1)
C      SI = SI - ZQUOT(2)
c++ END
      GO TO 340
C     ********** FORM EXCEPTIONAL SHIFT **********
  320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
      SI = 0.0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
C     ********** REDUCE TO TRIANGLE (ROWS) **********
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.0
         NORM = SQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1)
     X               +SR*SR)
         XR = HR(I-1,I-1) / NORM
         XI = HI(I-1,I-1) / NORM
c++ CODE for COMPLEX is active
         Z(I-1) = CMPLX(XR,XI)
c++ CODE for NO_COMPLEX is inactive
C         Z(2*I-3) = XR
C         Z(2*I-2) = XI
c++ END
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, EN
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0) GO TO 540
c++ CODE for COMPLEX is active
      NORM = ABS(CMPLX(HR(EN,EN),SI))
c++ CODE for NO_COMPLEX is inactive
C      Z2(1) = HR(EN,EN)
C      Z2(2) = SI
C      NORM = SCABS(Z2)
c++ END
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.0
C     ********** INVERSE OPERATION (COLUMNS) **********
  540 DO 600 J = LP1, EN
c++ CODE for COMPLEX is active
         XR = REAL(Z(J-1))
         XI = AIMAG(Z(J-1))
c++ CODE for NO_COMPLEX is inactive
C         XR = Z(2*J-3)
C         XI = Z(2*J-2)
c++ END
C
         DO 580 I = L, J
            YR = HR(I,J-1)
            YI = 0.0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.0) GO TO 240
C
      DO 630 I = L, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      GO TO 240
C     ********** A ROOT FOUND **********
  660 continue
c++ CODE for COMPLEX is active
      Z(EN) = CMPLX(HR(EN,EN)+TR,HI(EN,EN)+TI)
c++ CODE for NO_COMPLEX is inactive
C      Z(2*EN-1) = HR(EN,EN) + TR
C      Z(2*EN) = HI(EN,EN) + TI
c++ END
      EN = ENM1
      GO TO 220
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
C     ********** LAST CARD OF COMQR **********
      END